3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 $SIG{__WARN__} = sub { die $_[0]; };
26 use Dpkg::Control::Hash;
28 use File::Temp qw(tempdir);
38 our $our_version = 'UNRELEASED'; ###substituted###
40 our $rpushprotovsn = 2;
42 our $isuite = 'unstable';
48 our $dryrun_level = 0;
50 our $buildproductsdir = '..';
56 our $existing_package = 'dpkg';
57 our $cleanmode = 'dpkg-source';
58 our $changes_since_version;
60 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck';
61 our $we_are_responder;
62 our $initiator_tempdir;
64 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
66 our $suite_re = '[-+.0-9a-z]+';
69 our (@dget) = qw(dget);
70 our (@curl) = qw(curl -f);
71 our (@dput) = qw(dput);
72 our (@debsign) = qw(debsign);
74 our (@sbuild) = qw(sbuild -A);
76 our (@dgit) = qw(dgit);
77 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
78 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
79 our (@dpkggenchanges) = qw(dpkg-genchanges);
80 our (@mergechanges) = qw(mergechanges -f);
81 our (@changesopts) = ('');
83 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
86 'debsign' => \@debsign,
91 'dpkg-source' => \@dpkgsource,
92 'dpkg-buildpackage' => \@dpkgbuildpackage,
93 'dpkg-genchanges' => \@dpkggenchanges,
94 'ch' => \@changesopts,
95 'mergechanges' => \@mergechanges);
97 our %opts_opt_cmdonly = ('gpg' => 1);
103 our $remotename = 'dgit';
104 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
108 sub lbranch () { return "$branchprefix/$csuite"; }
109 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
110 sub lref () { return "refs/heads/".lbranch(); }
111 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
112 sub rrref () { return server_ref($csuite); }
114 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
124 return "${package}_".(stripepoch $vsn).$sfx
129 return srcfn($vsn,".dsc");
138 foreach my $f (@end) {
140 warn "$us: cleanup: $@" if length $@;
144 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
146 sub no_such_package () {
147 print STDERR "$us: package $package does not exist in suite $isuite\n";
153 return "+".rrref().":".lrref();
158 printdebug "CD $newdir\n";
159 chdir $newdir or die "chdir: $newdir: $!";
162 sub deliberately ($) {
164 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
167 sub deliberately_not_fast_forward () {
168 foreach (qw(not-fast-forward fresh-repo)) {
169 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
173 #---------- remote protocol support, common ----------
175 # remote push initiator/responder protocol:
176 # < dgit-remote-push-ready [optional extra info ignored by old initiators]
178 # > file parsed-changelog
179 # [indicates that output of dpkg-parsechangelog follows]
180 # > data-block NBYTES
181 # > [NBYTES bytes of data (no newline)]
182 # [maybe some more blocks]
194 # [indicates that signed tag is wanted]
195 # < data-block NBYTES
196 # < [NBYTES bytes of data (no newline)]
197 # [maybe some more blocks]
201 # > want signed-dsc-changes
202 # < data-block NBYTES [transfer of signed dsc]
204 # < data-block NBYTES [transfer of signed changes]
212 sub i_child_report () {
213 # Sees if our child has died, and reap it if so. Returns a string
214 # describing how it died if it failed, or undef otherwise.
215 return undef unless $i_child_pid;
216 my $got = waitpid $i_child_pid, WNOHANG;
217 return undef if $got <= 0;
218 die unless $got == $i_child_pid;
219 $i_child_pid = undef;
220 return undef unless $?;
221 return "build host child ".waitstatusmsg();
226 fail "connection lost: $!" if $fh->error;
227 fail "protocol violation; $m not expected";
230 sub badproto_badread ($$) {
232 fail "connection lost: $!" if $!;
233 my $report = i_child_report();
234 fail $report if defined $report;
235 badproto $fh, "eof (reading $wh)";
238 sub protocol_expect (&$) {
239 my ($match, $fh) = @_;
242 defined && chomp or badproto_badread $fh, "protocol message";
250 badproto $fh, "\`$_'";
253 sub protocol_send_file ($$) {
254 my ($fh, $ourfn) = @_;
255 open PF, "<", $ourfn or die "$ourfn: $!";
258 my $got = read PF, $d, 65536;
259 die "$ourfn: $!" unless defined $got;
261 print $fh "data-block ".length($d)."\n" or die $!;
262 print $fh $d or die $!;
264 PF->error and die "$ourfn $!";
265 print $fh "data-end\n" or die $!;
269 sub protocol_read_bytes ($$) {
270 my ($fh, $nbytes) = @_;
271 $nbytes =~ m/^[1-9]\d{0,5}$/ or badproto \*RO, "bad byte count";
273 my $got = read $fh, $d, $nbytes;
274 $got==$nbytes or badproto_badread $fh, "data block";
278 sub protocol_receive_file ($$) {
279 my ($fh, $ourfn) = @_;
280 printdebug "() $ourfn\n";
281 open PF, ">", $ourfn or die "$ourfn: $!";
283 my ($y,$l) = protocol_expect {
284 m/^data-block (.*)$/ ? (1,$1) :
285 m/^data-end$/ ? (0,) :
289 my $d = protocol_read_bytes $fh, $l;
290 print PF $d or die $!;
295 #---------- remote protocol support, responder ----------
297 sub responder_send_command ($) {
299 return unless $we_are_responder;
300 # called even without $we_are_responder
301 printdebug ">> $command\n";
302 print PO $command, "\n" or die $!;
305 sub responder_send_file ($$) {
306 my ($keyword, $ourfn) = @_;
307 return unless $we_are_responder;
308 printdebug "]] $keyword $ourfn\n";
309 responder_send_command "file $keyword";
310 protocol_send_file \*PO, $ourfn;
313 sub responder_receive_files ($@) {
314 my ($keyword, @ourfns) = @_;
315 die unless $we_are_responder;
316 printdebug "[[ $keyword @ourfns\n";
317 responder_send_command "want $keyword";
318 foreach my $fn (@ourfns) {
319 protocol_receive_file \*PI, $fn;
322 protocol_expect { m/^files-end$/ } \*PI;
325 #---------- remote protocol support, initiator ----------
327 sub initiator_expect (&) {
329 protocol_expect { &$match } \*RO;
332 #---------- end remote code ----------
335 if ($we_are_responder) {
337 responder_send_command "progress ".length($m) or die $!;
338 print PO $m or die $!;
348 $ua = LWP::UserAgent->new();
352 progress "downloading $what...";
353 my $r = $ua->get(@_) or die $!;
354 return undef if $r->code == 404;
355 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
356 return $r->decoded_content(charset => 'none');
359 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
364 failedcmd @_ if system @_;
367 sub act_local () { return $dryrun_level <= 1; }
368 sub act_scary () { return !$dryrun_level; }
371 if (!$dryrun_level) {
372 progress "dgit ok: @_";
374 progress "would be ok: @_ (but dry run only)";
379 printcmd(\*STDERR,$debugprefix."#",@_);
382 sub runcmd_ordryrun {
390 sub runcmd_ordryrun_local {
399 my ($first_shell, @cmd) = @_;
400 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
403 our $helpmsg = <<END;
405 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
406 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
407 dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
408 dgit [dgit-opts] push [dgit-opts] [suite]
409 dgit [dgit-opts] rpush build-host:build-dir ...
410 important dgit options:
411 -k<keyid> sign tag and package with <keyid> instead of default
412 --dry-run -n do not change anything, but go through the motions
413 --damp-run -L like --dry-run but make local changes, without signing
414 --new -N allow introducing a new package
415 --debug -D increase debug level
416 -c<name>=<value> set git config option (used directly by dgit too)
419 our $later_warning_msg = <<END;
420 Perhaps the upload is stuck in incoming. Using the version from git.
424 print STDERR "$us: @_\n", $helpmsg or die $!;
429 @ARGV or badusage "too few arguments";
430 return scalar shift @ARGV;
434 print $helpmsg or die $!;
438 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
440 our %defcfg = ('dgit.default.distro' => 'debian',
441 'dgit.default.username' => '',
442 'dgit.default.archive-query-default-component' => 'main',
443 'dgit.default.ssh' => 'ssh',
444 'dgit.default.archive-query' => 'madison:',
445 'dgit.default.sshpsql-dbname' => 'service=projectb',
446 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
447 'dgit-distro.debian.git-check' => 'url',
448 'dgit-distro.debian.git-check-suffix' => '/info/refs',
449 'dgit-distro.debian/push.git-url' => '',
450 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
451 'dgit-distro.debian/push.git-user-force' => 'dgit',
452 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
453 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
454 'dgit-distro.debian/push.git-create' => 'true',
455 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
456 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
457 # 'dgit-distro.debian.archive-query-tls-key',
458 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
459 # ^ this does not work because curl is broken nowadays
460 # Fixing #790093 properly will involve providing providing the key
461 # in some pacagke and maybe updating these paths.
463 # 'dgit-distro.debian.archive-query-tls-curl-args',
464 # '--ca-path=/etc/ssl/ca-debian',
465 # ^ this is a workaround but works (only) on DSA-administered machines
466 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
467 'dgit-distro.debian.git-url-suffix' => '',
468 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
469 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
470 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
471 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
472 'dgit-distro.ubuntu.git-check' => 'false',
473 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
474 'dgit-distro.test-dummy.ssh' => "$td/ssh",
475 'dgit-distro.test-dummy.username' => "alice",
476 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
477 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
478 'dgit-distro.test-dummy.git-url' => "$td/git",
479 'dgit-distro.test-dummy.git-host' => "git",
480 'dgit-distro.test-dummy.git-path' => "$td/git",
481 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
482 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
483 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
484 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
487 sub git_get_config ($) {
490 our %git_get_config_memo;
491 if (exists $git_get_config_memo{$c}) {
492 return $git_get_config_memo{$c};
496 my @cmd = (@git, qw(config --), $c);
498 local ($debuglevel) = $debuglevel-2;
499 $v = cmdoutput_errok @cmd;
507 $git_get_config_memo{$c} = $v;
513 return undef if $c =~ /RETURN-UNDEF/;
514 my $v = git_get_config($c);
515 return $v if defined $v;
516 my $dv = $defcfg{$c};
517 return $dv if defined $dv;
519 badcfg "need value for one of: @_\n".
520 "$us: distro or suite appears not to be (properly) supported";
523 sub access_basedistro () {
524 if (defined $idistro) {
527 return cfg("dgit-suite.$isuite.distro",
528 "dgit.default.distro");
532 sub access_quirk () {
533 # returns (quirk name, distro to use instead or undef, quirk-specific info)
534 my $basedistro = access_basedistro();
535 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
537 if (defined $backports_quirk) {
538 my $re = $backports_quirk;
539 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
541 $re =~ s/\%/([-0-9a-z_]+)/
542 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
543 if ($isuite =~ m/^$re$/) {
544 return ('backports',"$basedistro-backports",$1);
547 return ('none',undef);
550 our $access_forpush = 0;
556 sub access_forpush () {
557 return $access_forpush;
560 sub access_distros () {
561 # Returns list of distros to try, in order
564 # 0. `instead of' distro name(s) we have been pointed to
565 # 1. the access_quirk distro, if any
566 # 2a. the user's specified distro, or failing that } basedistro
567 # 2b. the distro calculated from the suite }
568 my @l = access_basedistro();
570 my (undef,$quirkdistro) = access_quirk();
571 unshift @l, $quirkdistro;
572 unshift @l, $instead_distro;
573 @l = grep { defined } @l;
575 if (access_forpush()) {
576 @l = map { ("$_/push", $_) } @l;
584 # The nesting of these loops determines the search order. We put
585 # the key loop on the outside so that we search all the distros
586 # for each key, before going on to the next key. That means that
587 # if access_cfg is called with a more specific, and then a less
588 # specific, key, an earlier distro can override the less specific
589 # without necessarily overriding any more specific keys. (If the
590 # distro wants to override the more specific keys it can simply do
591 # so; whereas if we did the loop the other way around, it would be
592 # impossible to for an earlier distro to override a less specific
593 # key but not the more specific ones without restating the unknown
594 # values of the more specific keys.
597 # We have to deal with RETURN-UNDEF specially, so that we don't
598 # terminate the search prematurely.
600 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
603 foreach my $d (access_distros()) {
604 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
606 push @cfgs, map { "dgit.default.$_" } @realkeys;
608 my $value = cfg(@cfgs);
612 sub string_to_ssh ($) {
614 if ($spec =~ m/\s/) {
615 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
621 sub access_cfg_ssh () {
622 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
623 if (!defined $gitssh) {
626 return string_to_ssh $gitssh;
630 sub access_runeinfo ($) {
632 return ": dgit ".access_basedistro()." $info ;";
635 sub access_someuserhost ($) {
637 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
638 defined($user) && length($user) or
639 $user = access_cfg("$some-user",'username');
640 my $host = access_cfg("$some-host");
641 return length($user) ? "$user\@$host" : $host;
644 sub access_gituserhost () {
645 return access_someuserhost('git');
648 sub access_giturl (;$) {
650 my $url = access_cfg('git-url','RETURN-UNDEF');
653 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
654 return undef unless defined $proto;
657 access_gituserhost().
658 access_cfg('git-path');
660 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
663 return "$url/$package$suffix";
666 sub parsecontrolfh ($$;$) {
667 my ($fh, $desc, $allowsigned) = @_;
668 our $dpkgcontrolhash_noissigned;
671 my %opts = ('name' => $desc);
672 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
673 $c = Dpkg::Control::Hash->new(%opts);
674 $c->parse($fh,$desc) or die "parsing of $desc failed";
675 last if $allowsigned;
676 last if $dpkgcontrolhash_noissigned;
677 my $issigned= $c->get_option('is_pgp_signed');
678 if (!defined $issigned) {
679 $dpkgcontrolhash_noissigned= 1;
680 seek $fh, 0,0 or die "seek $desc: $!";
681 } elsif ($issigned) {
682 fail "control file $desc is (already) PGP-signed. ".
683 " Note that dgit push needs to modify the .dsc and then".
684 " do the signature itself";
693 my ($file, $desc) = @_;
694 my $fh = new IO::Handle;
695 open $fh, '<', $file or die "$file: $!";
696 my $c = parsecontrolfh($fh,$desc);
697 $fh->error and die $!;
703 my ($dctrl,$field) = @_;
704 my $v = $dctrl->{$field};
705 return $v if defined $v;
706 fail "missing field $field in ".$v->get_option('name');
710 my $c = Dpkg::Control::Hash->new();
711 my $p = new IO::Handle;
712 my @cmd = (qw(dpkg-parsechangelog), @_);
713 open $p, '-|', @cmd or die $!;
715 $?=0; $!=0; close $p or failedcmd @cmd;
721 defined $d or fail "getcwd failed: $!";
727 sub archive_query ($) {
729 my $query = access_cfg('archive-query','RETURN-UNDEF');
730 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
733 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
736 sub pool_dsc_subpath ($$) {
737 my ($vsn,$component) = @_; # $package is implict arg
738 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
739 return "/pool/$component/$prefix/$package/".dscfn($vsn);
742 #---------- `ftpmasterapi' archive query method (nascent) ----------
744 sub archive_api_query_cmd ($) {
746 my @cmd = qw(curl -sS);
747 my $url = access_cfg('archive-query-url');
748 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
750 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
751 foreach my $key (split /\:/, $keys) {
752 $key =~ s/\%HOST\%/$host/g;
754 fail "for $url: stat $key: $!" unless $!==ENOENT;
757 fail "config requested specific TLS key but do not know".
758 " how to get curl to use exactly that EE key ($key)";
759 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
760 # # Sadly the above line does not work because of changes
761 # # to gnutls. The real fix for #790093 may involve
762 # # new curl options.
765 # Fixing #790093 properly will involve providing a value
766 # for this on clients.
767 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
768 push @cmd, split / /, $kargs if defined $kargs;
770 push @cmd, $url.$subpath;
776 my ($data, $subpath) = @_;
777 badcfg "ftpmasterapi archive query method takes no data part"
779 my @cmd = archive_api_query_cmd($subpath);
780 my $json = cmdoutput @cmd;
781 return decode_json($json);
784 sub canonicalise_suite_ftpmasterapi () {
785 my ($proto,$data) = @_;
786 my $suites = api_query($data, 'suites');
788 foreach my $entry (@$suites) {
790 my $v = $entry->{$_};
791 defined $v && $v eq $isuite;
793 push @matched, $entry;
795 fail "unknown suite $isuite" unless @matched;
798 @matched==1 or die "multiple matches for suite $isuite\n";
799 $cn = "$matched[0]{codename}";
800 defined $cn or die "suite $isuite info has no codename\n";
801 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
803 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
808 sub archive_query_ftpmasterapi () {
809 my ($proto,$data) = @_;
810 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
812 my $digester = Digest::SHA->new(256);
813 foreach my $entry (@$info) {
815 my $vsn = "$entry->{version}";
816 my ($ok,$msg) = version_check $vsn;
817 die "bad version: $msg\n" unless $ok;
818 my $component = "$entry->{component}";
819 $component =~ m/^$component_re$/ or die "bad component";
820 my $filename = "$entry->{filename}";
821 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
822 or die "bad filename";
823 my $sha256sum = "$entry->{sha256sum}";
824 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
825 push @rows, [ $vsn, "/pool/$component/$filename",
826 $digester, $sha256sum ];
828 die "bad ftpmaster api response: $@\n".Dumper($entry)
831 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
835 #---------- `madison' archive query method ----------
837 sub archive_query_madison {
838 return map { [ @$_[0..1] ] } madison_get_parse(@_);
841 sub madison_get_parse {
842 my ($proto,$data) = @_;
843 die unless $proto eq 'madison';
845 $data= access_cfg('madison-distro','RETURN-UNDEF');
846 $data //= access_basedistro();
848 $rmad{$proto,$data,$package} ||= cmdoutput
849 qw(rmadison -asource),"-s$isuite","-u$data",$package;
850 my $rmad = $rmad{$proto,$data,$package};
853 foreach my $l (split /\n/, $rmad) {
854 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
855 \s*( [^ \t|]+ )\s* \|
856 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
857 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
858 $1 eq $package or die "$rmad $package ?";
865 $component = access_cfg('archive-query-default-component');
867 $5 eq 'source' or die "$rmad ?";
868 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
870 return sort { -version_compare($a->[0],$b->[0]); } @out;
873 sub canonicalise_suite_madison {
874 # madison canonicalises for us
875 my @r = madison_get_parse(@_);
877 "unable to canonicalise suite using package $package".
878 " which does not appear to exist in suite $isuite;".
879 " --existing-package may help";
883 #---------- `sshpsql' archive query method ----------
886 my ($data,$runeinfo,$sql) = @_;
888 $data= access_someuserhost('sshpsql').':'.
889 access_cfg('sshpsql-dbname');
891 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
892 my ($userhost,$dbname) = ($`,$'); #';
894 my @cmd = (access_cfg_ssh, $userhost,
895 access_runeinfo("ssh-psql $runeinfo").
896 " export LC_MESSAGES=C; export LC_CTYPE=C;".
897 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
899 open P, "-|", @cmd or die $!;
902 printdebug("$debugprefix>|$_|\n");
905 $!=0; $?=0; close P or failedcmd @cmd;
907 my $nrows = pop @rows;
908 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
909 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
910 @rows = map { [ split /\|/, $_ ] } @rows;
911 my $ncols = scalar @{ shift @rows };
912 die if grep { scalar @$_ != $ncols } @rows;
916 sub sql_injection_check {
917 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
920 sub archive_query_sshpsql ($$) {
921 my ($proto,$data) = @_;
922 sql_injection_check $isuite, $package;
923 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
924 SELECT source.version, component.name, files.filename, files.sha256sum
926 JOIN src_associations ON source.id = src_associations.source
927 JOIN suite ON suite.id = src_associations.suite
928 JOIN dsc_files ON dsc_files.source = source.id
929 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
930 JOIN component ON component.id = files_archive_map.component_id
931 JOIN files ON files.id = dsc_files.file
932 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
933 AND source.source='$package'
934 AND files.filename LIKE '%.dsc';
936 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
937 my $digester = Digest::SHA->new(256);
939 my ($vsn,$component,$filename,$sha256sum) = @$_;
940 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
945 sub canonicalise_suite_sshpsql ($$) {
946 my ($proto,$data) = @_;
947 sql_injection_check $isuite;
948 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
949 SELECT suite.codename
950 FROM suite where suite_name='$isuite' or codename='$isuite';
952 @rows = map { $_->[0] } @rows;
953 fail "unknown suite $isuite" unless @rows;
954 die "ambiguous $isuite: @rows ?" if @rows>1;
958 #---------- `dummycat' archive query method ----------
960 sub canonicalise_suite_dummycat ($$) {
961 my ($proto,$data) = @_;
962 my $dpath = "$data/suite.$isuite";
963 if (!open C, "<", $dpath) {
964 $!==ENOENT or die "$dpath: $!";
965 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
969 chomp or die "$dpath: $!";
971 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
975 sub archive_query_dummycat ($$) {
976 my ($proto,$data) = @_;
977 canonicalise_suite();
978 my $dpath = "$data/package.$csuite.$package";
979 if (!open C, "<", $dpath) {
980 $!==ENOENT or die "$dpath: $!";
981 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
989 printdebug "dummycat query $csuite $package $dpath | $_\n";
990 my @row = split /\s+/, $_;
991 @row==2 or die "$dpath: $_ ?";
994 C->error and die "$dpath: $!";
996 return sort { -version_compare($a->[0],$b->[0]); } @rows;
999 #---------- archive query entrypoints and rest of program ----------
1001 sub canonicalise_suite () {
1002 return if defined $csuite;
1003 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1004 $csuite = archive_query('canonicalise_suite');
1005 if ($isuite ne $csuite) {
1006 progress "canonical suite name for $isuite is $csuite";
1010 sub get_archive_dsc () {
1011 canonicalise_suite();
1012 my @vsns = archive_query('archive_query');
1013 foreach my $vinfo (@vsns) {
1014 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1015 $dscurl = access_cfg('mirror').$subpath;
1016 $dscdata = url_get($dscurl);
1018 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1023 $digester->add($dscdata);
1024 my $got = $digester->hexdigest();
1026 fail "$dscurl has hash $got but".
1027 " archive told us to expect $digest";
1029 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1030 printdebug Dumper($dscdata) if $debuglevel>1;
1031 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1032 printdebug Dumper($dsc) if $debuglevel>1;
1033 my $fmt = getfield $dsc, 'Format';
1034 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1035 $dsc_checked = !!$digester;
1041 sub check_for_git ();
1042 sub check_for_git () {
1044 my $how = access_cfg('git-check');
1045 if ($how eq 'ssh-cmd') {
1047 (access_cfg_ssh, access_gituserhost(),
1048 access_runeinfo("git-check $package").
1049 " set -e; cd ".access_cfg('git-path').";".
1050 " if test -d $package.git; then echo 1; else echo 0; fi");
1051 my $r= cmdoutput @cmd;
1052 if ($r =~ m/^divert (\w+)$/) {
1054 my ($usedistro,) = access_distros();
1055 # NB that if we are pushing, $usedistro will be $distro/push
1056 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1057 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1058 progress "diverting to $divert (using config for $instead_distro)";
1059 return check_for_git();
1061 failedcmd @cmd unless $r =~ m/^[01]$/;
1063 } elsif ($how eq 'url') {
1064 my $prefix = access_cfg('git-check-url','git-url');
1065 my $suffix = access_cfg('git-check-suffix','git-suffix',
1066 'RETURN-UNDEF') // '.git';
1067 my $url = "$prefix/$package$suffix";
1068 my @cmd = (qw(curl -sS -I), $url);
1069 my $result = cmdoutput @cmd;
1070 $result =~ m/^\S+ (404|200) /s or
1071 fail "unexpected results from git check query - ".
1072 Dumper($prefix, $result);
1074 if ($code eq '404') {
1076 } elsif ($code eq '200') {
1081 } elsif ($how eq 'true') {
1083 } elsif ($how eq 'false') {
1086 badcfg "unknown git-check \`$how'";
1090 sub create_remote_git_repo () {
1091 my $how = access_cfg('git-create');
1092 if ($how eq 'ssh-cmd') {
1094 (access_cfg_ssh, access_gituserhost(),
1095 access_runeinfo("git-create $package").
1096 "set -e; cd ".access_cfg('git-path').";".
1097 " cp -a _template $package.git");
1098 } elsif ($how eq 'true') {
1101 badcfg "unknown git-create \`$how'";
1105 our ($dsc_hash,$lastpush_hash);
1107 our $ud = '.git/dgit/unpack';
1112 mkdir $ud or die $!;
1115 sub mktree_in_ud_here () {
1116 runcmd qw(git init -q);
1117 rmtree('.git/objects');
1118 symlink '../../../../objects','.git/objects' or die $!;
1121 sub git_write_tree () {
1122 my $tree = cmdoutput @git, qw(write-tree);
1123 $tree =~ m/^\w+$/ or die "$tree ?";
1127 sub mktree_in_ud_from_only_subdir () {
1128 # changes into the subdir
1130 die unless @dirs==1;
1131 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1134 fail "source package contains .git directory" if stat_exists '.git';
1135 mktree_in_ud_here();
1136 my $format=get_source_format();
1137 if (madformat($format)) {
1140 runcmd @git, qw(add -Af);
1141 my $tree=git_write_tree();
1142 return ($tree,$dir);
1145 sub dsc_files_info () {
1146 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1147 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1148 ['Files', 'Digest::MD5', 'new()']) {
1149 my ($fname, $module, $method) = @$csumi;
1150 my $field = $dsc->{$fname};
1151 next unless defined $field;
1152 eval "use $module; 1;" or die $@;
1154 foreach (split /\n/, $field) {
1156 m/^(\w+) (\d+) (\S+)$/ or
1157 fail "could not parse .dsc $fname line \`$_'";
1158 my $digester = eval "$module"."->$method;" or die $@;
1163 Digester => $digester,
1168 fail "missing any supported Checksums-* or Files field in ".
1169 $dsc->get_option('name');
1173 map { $_->{Filename} } dsc_files_info();
1176 sub is_orig_file ($;$) {
1179 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1180 defined $base or return 1;
1184 sub make_commit ($) {
1186 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1189 sub clogp_authline ($) {
1191 my $author = getfield $clogp, 'Maintainer';
1192 $author =~ s#,.*##ms;
1193 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1194 my $authline = "$author $date";
1195 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1196 fail "unexpected commit author line format \`$authline'".
1197 " (was generated from changelog Maintainer field)";
1201 sub vendor_patches_distro ($$) {
1202 my ($checkdistro, $what) = @_;
1203 return unless defined $checkdistro;
1205 my $series = "debian/patches/\L$checkdistro\E.series";
1206 printdebug "checking for vendor-specific $series ($what)\n";
1208 if (!open SERIES, "<", $series) {
1209 die "$series $!" unless $!==ENOENT;
1218 Unfortunately, this source package uses a feature of dpkg-source where
1219 the same source package unpacks to different source code on different
1220 distros. dgit cannot safely operate on such packages on affected
1221 distros, because the meaning of source packages is not stable.
1223 Please ask the distro/maintainer to remove the distro-specific series
1224 files and use a different technique (if necessary, uploading actually
1225 different packages, if different distros are supposed to have
1229 fail "Found active distro-specific series file for".
1230 " $checkdistro ($what): $series, cannot continue";
1232 die "$series $!" if SERIES->error;
1236 sub check_for_vendor_patches () {
1237 # This dpkg-source feature doesn't seem to be documented anywhere!
1238 # But it can be found in the changelog (reformatted):
1240 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1241 # Author: Raphael Hertzog <hertzog@debian.org>
1242 # Date: Sun Oct 3 09:36:48 2010 +0200
1244 # dpkg-source: correctly create .pc/.quilt_series with alternate
1247 # If you have debian/patches/ubuntu.series and you were
1248 # unpacking the source package on ubuntu, quilt was still
1249 # directed to debian/patches/series instead of
1250 # debian/patches/ubuntu.series.
1252 # debian/changelog | 3 +++
1253 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1254 # 2 files changed, 6 insertions(+), 1 deletion(-)
1257 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1258 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1259 "Dpkg::Vendor \`current vendor'");
1260 vendor_patches_distro(access_basedistro(),
1261 "distro being accessed");
1264 sub generate_commit_from_dsc () {
1268 foreach my $fi (dsc_files_info()) {
1269 my $f = $fi->{Filename};
1270 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1272 link "../../../$f", $f
1276 complete_file_from_dsc('.', $fi);
1278 if (is_orig_file($f)) {
1279 link $f, "../../../../$f"
1285 my $dscfn = "$package.dsc";
1287 open D, ">", $dscfn or die "$dscfn: $!";
1288 print D $dscdata or die "$dscfn: $!";
1289 close D or die "$dscfn: $!";
1290 my @cmd = qw(dpkg-source);
1291 push @cmd, '--no-check' if $dsc_checked;
1292 push @cmd, qw(-x --), $dscfn;
1295 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1296 check_for_vendor_patches() if madformat($dsc->{format});
1297 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1298 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1299 my $authline = clogp_authline $clogp;
1300 my $changes = getfield $clogp, 'Changes';
1301 open C, ">../commit.tmp" or die $!;
1302 print C <<END or die $!;
1309 # imported from the archive
1312 my $outputhash = make_commit qw(../commit.tmp);
1313 my $cversion = getfield $clogp, 'Version';
1314 progress "synthesised git commit from .dsc $cversion";
1315 if ($lastpush_hash) {
1316 runcmd @git, qw(reset --hard), $lastpush_hash;
1317 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1318 my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1319 my $oversion = getfield $oldclogp, 'Version';
1321 version_compare($oversion, $cversion);
1323 # git upload/ is earlier vsn than archive, use archive
1324 open C, ">../commit2.tmp" or die $!;
1325 print C <<END or die $!;
1327 parent $lastpush_hash
1332 Record $package ($cversion) in archive suite $csuite
1334 $outputhash = make_commit qw(../commit2.tmp);
1335 } elsif ($vcmp > 0) {
1336 print STDERR <<END or die $!;
1338 Version actually in archive: $cversion (older)
1339 Last allegedly pushed/uploaded: $oversion (newer or same)
1342 $outputhash = $lastpush_hash;
1344 $outputhash = $lastpush_hash;
1347 changedir '../../../..';
1348 runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1349 'DGIT_ARCHIVE', $outputhash;
1350 cmdoutput @git, qw(log -n2), $outputhash;
1351 # ... gives git a chance to complain if our commit is malformed
1356 sub complete_file_from_dsc ($$) {
1357 our ($dstdir, $fi) = @_;
1358 # Ensures that we have, in $dir, the file $fi, with the correct
1359 # contents. (Downloading it from alongside $dscurl if necessary.)
1361 my $f = $fi->{Filename};
1362 my $tf = "$dstdir/$f";
1365 if (stat_exists $tf) {
1366 progress "using existing $f";
1369 $furl =~ s{/[^/]+$}{};
1371 die "$f ?" unless $f =~ m/^${package}_/;
1372 die "$f ?" if $f =~ m#/#;
1373 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1374 next if !act_local();
1378 open F, "<", "$tf" or die "$tf: $!";
1379 $fi->{Digester}->reset();
1380 $fi->{Digester}->addfile(*F);
1381 F->error and die $!;
1382 my $got = $fi->{Digester}->hexdigest();
1383 $got eq $fi->{Hash} or
1384 fail "file $f has hash $got but .dsc".
1385 " demands hash $fi->{Hash} ".
1386 ($downloaded ? "(got wrong file from archive!)"
1387 : "(perhaps you should delete this file?)");
1390 sub ensure_we_have_orig () {
1391 foreach my $fi (dsc_files_info()) {
1392 my $f = $fi->{Filename};
1393 next unless is_orig_file($f);
1394 complete_file_from_dsc('..', $fi);
1398 sub git_fetch_us () {
1399 my @specs = (fetchspec());
1401 map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1403 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1406 my $tagpat = debiantag('*',access_basedistro);
1408 git_for_each_ref("refs/tags/".$tagpat, sub {
1409 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1410 printdebug "currently $fullrefname=$objid\n";
1411 $here{$fullrefname} = $objid;
1413 git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1414 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1415 my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1416 printdebug "offered $lref=$objid\n";
1417 if (!defined $here{$lref}) {
1418 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1419 runcmd_ordryrun_local @upd;
1420 } elsif ($here{$lref} eq $objid) {
1423 "Not updateting $lref from $here{$lref} to $objid.\n";
1428 sub fetch_from_archive () {
1429 # ensures that lrref() is what is actually in the archive,
1430 # one way or another
1434 foreach my $field (@ourdscfield) {
1435 $dsc_hash = $dsc->{$field};
1436 last if defined $dsc_hash;
1438 if (defined $dsc_hash) {
1439 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1441 progress "last upload to archive specified git hash";
1443 progress "last upload to archive has NO git hash";
1446 progress "no version available from the archive";
1449 $lastpush_hash = git_get_ref(lrref());
1450 printdebug "previous reference hash=$lastpush_hash\n";
1452 if (defined $dsc_hash) {
1453 fail "missing remote git history even though dsc has hash -".
1454 " could not find ref ".lrref().
1455 " (should have been fetched from ".access_giturl()."#".rrref().")"
1456 unless $lastpush_hash;
1458 ensure_we_have_orig();
1459 if ($dsc_hash eq $lastpush_hash) {
1460 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1461 print STDERR <<END or die $!;
1463 Git commit in archive is behind the last version allegedly pushed/uploaded.
1464 Commit referred to by archive: $dsc_hash
1465 Last allegedly pushed/uploaded: $lastpush_hash
1468 $hash = $lastpush_hash;
1470 fail "git head (".lrref()."=$lastpush_hash) is not a ".
1471 "descendant of archive's .dsc hash ($dsc_hash)";
1474 $hash = generate_commit_from_dsc();
1475 } elsif ($lastpush_hash) {
1476 # only in git, not in the archive yet
1477 $hash = $lastpush_hash;
1478 print STDERR <<END or die $!;
1480 Package not found in the archive, but has allegedly been pushed using dgit.
1484 printdebug "nothing found!\n";
1485 if (defined $skew_warning_vsn) {
1486 print STDERR <<END or die $!;
1488 Warning: relevant archive skew detected.
1489 Archive allegedly contains $skew_warning_vsn
1490 But we were not able to obtain any version from the archive or git.
1496 printdebug "current hash=$hash\n";
1497 if ($lastpush_hash) {
1498 fail "not fast forward on last upload branch!".
1499 " (archive's version left in DGIT_ARCHIVE)"
1500 unless is_fast_fwd($lastpush_hash, $hash);
1502 if (defined $skew_warning_vsn) {
1504 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1505 my $clogf = ".git/dgit/changelog.tmp";
1506 runcmd shell_cmd "exec >$clogf",
1507 @git, qw(cat-file blob), "$hash:debian/changelog";
1508 my $gotclogp = parsechangelog("-l$clogf");
1509 my $got_vsn = getfield $gotclogp, 'Version';
1510 printdebug "SKEW CHECK GOT $got_vsn\n";
1511 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1512 print STDERR <<END or die $!;
1514 Warning: archive skew detected. Using the available version:
1515 Archive allegedly contains $skew_warning_vsn
1516 We were able to obtain only $got_vsn
1521 if ($lastpush_hash ne $hash) {
1522 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1526 dryrun_report @upd_cmd;
1532 sub set_local_git_config ($$) {
1534 runcmd @git, qw(config), $k, $v;
1537 sub setup_mergechangelogs () {
1538 my $driver = 'dpkg-mergechangelogs';
1539 my $cb = "merge.$driver";
1540 my $attrs = '.git/info/attributes';
1541 ensuredir '.git/info';
1543 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1544 if (!open ATTRS, "<", $attrs) {
1545 $!==ENOENT or die "$attrs: $!";
1549 next if m{^debian/changelog\s};
1550 print NATTRS $_, "\n" or die $!;
1552 ATTRS->error and die $!;
1555 print NATTRS "debian/changelog merge=$driver\n" or die $!;
1558 set_local_git_config "$cb.name", 'debian/changelog merge driver';
1559 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1561 rename "$attrs.new", "$attrs" or die "$attrs: $!";
1566 canonicalise_suite();
1567 badusage "dry run makes no sense with clone" unless act_local();
1568 my $hasgit = check_for_git();
1569 mkdir $dstdir or die "$dstdir $!";
1571 runcmd @git, qw(init -q);
1572 my $giturl = access_giturl(1);
1573 if (defined $giturl) {
1574 set_local_git_config "remote.$remotename.fetch", fetchspec();
1575 open H, "> .git/HEAD" or die $!;
1576 print H "ref: ".lref()."\n" or die $!;
1578 runcmd @git, qw(remote add), 'origin', $giturl;
1581 progress "fetching existing git history";
1583 runcmd_ordryrun_local @git, qw(fetch origin);
1585 progress "starting new git history";
1587 fetch_from_archive() or no_such_package;
1588 my $vcsgiturl = $dsc->{'Vcs-Git'};
1589 if (length $vcsgiturl) {
1590 $vcsgiturl =~ s/\s+-b\s+\S+//g;
1591 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1593 setup_mergechangelogs();
1594 runcmd @git, qw(reset --hard), lrref();
1595 printdone "ready for work in $dstdir";
1599 if (check_for_git()) {
1602 fetch_from_archive() or no_such_package();
1603 printdone "fetched into ".lrref();
1608 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1610 printdone "fetched to ".lrref()." and merged into HEAD";
1613 sub check_not_dirty () {
1614 return if $ignoredirty;
1615 my @cmd = (@git, qw(diff --quiet HEAD));
1617 $!=0; $?=0; system @cmd;
1618 return if !$! && !$?;
1619 if (!$! && $?==256) {
1620 fail "working tree is dirty (does not match HEAD)";
1626 sub commit_admin ($) {
1629 runcmd_ordryrun_local @git, qw(commit -m), $m;
1632 sub commit_quilty_patch () {
1633 my $output = cmdoutput @git, qw(status --porcelain);
1635 foreach my $l (split /\n/, $output) {
1636 next unless $l =~ m/\S/;
1637 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1641 delete $adds{'.pc'}; # if there wasn't one before, don't add it
1643 progress "nothing quilty to commit, ok.";
1646 runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1647 commit_admin "Commit Debian 3.0 (quilt) metadata";
1650 sub get_source_format () {
1651 if (!open F, "debian/source/format") {
1652 die $! unless $!==&ENOENT;
1656 F->error and die $!;
1663 return 0 unless $format eq '3.0 (quilt)';
1664 if ($quilt_mode eq 'nocheck') {
1665 progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1668 progress "Format \`$format', checking/updating patch stack";
1672 sub push_parse_changelog ($) {
1675 my $clogp = Dpkg::Control::Hash->new();
1676 $clogp->load($clogpfn) or die;
1678 $package = getfield $clogp, 'Source';
1679 my $cversion = getfield $clogp, 'Version';
1680 my $tag = debiantag($cversion, access_basedistro);
1681 runcmd @git, qw(check-ref-format), $tag;
1683 my $dscfn = dscfn($cversion);
1685 return ($clogp, $cversion, $tag, $dscfn);
1688 sub push_parse_dsc ($$$) {
1689 my ($dscfn,$dscfnwhat, $cversion) = @_;
1690 $dsc = parsecontrol($dscfn,$dscfnwhat);
1691 my $dversion = getfield $dsc, 'Version';
1692 my $dscpackage = getfield $dsc, 'Source';
1693 ($dscpackage eq $package && $dversion eq $cversion) or
1694 fail "$dscfn is for $dscpackage $dversion".
1695 " but debian/changelog is for $package $cversion";
1698 sub push_mktag ($$$$$$$) {
1699 my ($head,$clogp,$tag,
1701 $changesfile,$changesfilewhat,
1704 $dsc->{$ourdscfield[0]} = $head;
1705 $dsc->save("$dscfn.tmp") or die $!;
1707 my $changes = parsecontrol($changesfile,$changesfilewhat);
1708 foreach my $field (qw(Source Distribution Version)) {
1709 $changes->{$field} eq $clogp->{$field} or
1710 fail "changes field $field \`$changes->{$field}'".
1711 " does not match changelog \`$clogp->{$field}'";
1714 my $cversion = getfield $clogp, 'Version';
1715 my $clogsuite = getfield $clogp, 'Distribution';
1717 # We make the git tag by hand because (a) that makes it easier
1718 # to control the "tagger" (b) we can do remote signing
1719 my $authline = clogp_authline $clogp;
1720 my $delibs = join(" ", "",@deliberatelies);
1721 my $declaredistro = access_basedistro();
1722 open TO, '>', $tfn->('.tmp') or die $!;
1723 print TO <<END or die $!;
1729 $package release $cversion for $clogsuite ($csuite) [dgit]
1730 [dgit distro=$declaredistro$delibs]
1732 foreach my $ref (sort keys %previously) {
1733 print TO <<END or die $!;
1734 [dgit previously:$ref=$previously{$ref}]
1740 my $tagobjfn = $tfn->('.tmp');
1742 if (!defined $keyid) {
1743 $keyid = access_cfg('keyid','RETURN-UNDEF');
1745 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1746 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1747 push @sign_cmd, qw(-u),$keyid if defined $keyid;
1748 push @sign_cmd, $tfn->('.tmp');
1749 runcmd_ordryrun @sign_cmd;
1751 $tagobjfn = $tfn->('.signed.tmp');
1752 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1753 $tfn->('.tmp'), $tfn->('.tmp.asc');
1760 sub sign_changes ($) {
1761 my ($changesfile) = @_;
1763 my @debsign_cmd = @debsign;
1764 push @debsign_cmd, "-k$keyid" if defined $keyid;
1765 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1766 push @debsign_cmd, $changesfile;
1767 runcmd_ordryrun @debsign_cmd;
1772 my ($forceflag) = @_;
1773 printdebug "actually entering push\n";
1776 access_giturl(); # check that success is vaguely likely
1778 my $clogpfn = ".git/dgit/changelog.822.tmp";
1779 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1781 responder_send_file('parsed-changelog', $clogpfn);
1783 my ($clogp, $cversion, $tag, $dscfn) =
1784 push_parse_changelog("$clogpfn");
1786 my $dscpath = "$buildproductsdir/$dscfn";
1787 stat_exists $dscpath or
1788 fail "looked for .dsc $dscfn, but $!;".
1789 " maybe you forgot to build";
1791 responder_send_file('dsc', $dscpath);
1793 push_parse_dsc($dscpath, $dscfn, $cversion);
1795 my $format = getfield $dsc, 'Format';
1796 printdebug "format $format\n";
1797 if (madformat($format)) {
1798 commit_quilty_patch();
1802 progress "checking that $dscfn corresponds to HEAD";
1803 runcmd qw(dpkg-source -x --),
1804 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1805 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1806 check_for_vendor_patches() if madformat($dsc->{format});
1807 changedir '../../../..';
1808 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1809 my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1810 debugcmd "+",@diffcmd;
1812 my $r = system @diffcmd;
1815 fail "$dscfn specifies a different tree to your HEAD commit;".
1816 " perhaps you forgot to build".
1817 ($diffopt eq '--exit-code' ? "" :
1818 " (run with -D to see full diff output)");
1823 my $head = git_rev_parse('HEAD');
1824 if (!$changesfile) {
1825 my $multi = "$buildproductsdir/".
1826 "${package}_".(stripepoch $cversion)."_multi.changes";
1827 if (stat_exists "$multi") {
1828 $changesfile = $multi;
1830 my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1831 my @cs = glob "$buildproductsdir/$pat";
1832 fail "failed to find unique changes file".
1833 " (looked for $pat in $buildproductsdir, or $multi);".
1834 " perhaps you need to use dgit -C"
1836 ($changesfile) = @cs;
1839 $changesfile = "$buildproductsdir/$changesfile";
1842 responder_send_file('changes',$changesfile);
1843 responder_send_command("param head $head");
1844 responder_send_command("param csuite $csuite");
1846 if (deliberately_not_fast_forward) {
1847 git_for_each_ref(lrfetchrefs, sub {
1848 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1849 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1850 responder_send_command("previously $rrefname=$objid");
1851 $previously{$rrefname} = $objid;
1855 my $tfn = sub { ".git/dgit/tag$_[0]"; };
1858 if ($we_are_responder) {
1859 $tagobjfn = $tfn->('.signed.tmp');
1860 responder_receive_files('signed-tag', $tagobjfn);
1863 push_mktag($head,$clogp,$tag,
1865 $changesfile,$changesfile,
1869 my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1870 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1871 runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1873 if (!check_for_git()) {
1874 create_remote_git_repo();
1876 runcmd_ordryrun @git, qw(push),access_giturl(),
1877 $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1878 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1880 if ($we_are_responder) {
1881 my $dryrunsuffix = act_local() ? "" : ".tmp";
1882 responder_receive_files('signed-dsc-changes',
1883 "$dscpath$dryrunsuffix",
1884 "$changesfile$dryrunsuffix");
1887 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1889 progress "[new .dsc left in $dscpath.tmp]";
1891 sign_changes $changesfile;
1894 my $host = access_cfg('upload-host','RETURN-UNDEF');
1895 my @hostarg = defined($host) ? ($host,) : ();
1896 runcmd_ordryrun @dput, @hostarg, $changesfile;
1897 printdone "pushed and uploaded $cversion";
1899 responder_send_command("complete");
1905 badusage "-p is not allowed with clone; specify as argument instead"
1906 if defined $package;
1909 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1910 ($package,$isuite) = @ARGV;
1911 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1912 ($package,$dstdir) = @ARGV;
1913 } elsif (@ARGV==3) {
1914 ($package,$isuite,$dstdir) = @ARGV;
1916 badusage "incorrect arguments to dgit clone";
1918 $dstdir ||= "$package";
1920 if (stat_exists $dstdir) {
1921 fail "$dstdir already exists";
1925 if ($rmonerror && !$dryrun_level) {
1926 $cwd_remove= getcwd();
1928 return unless defined $cwd_remove;
1929 if (!chdir "$cwd_remove") {
1930 return if $!==&ENOENT;
1931 die "chdir $cwd_remove: $!";
1933 rmtree($dstdir) or die "remove $dstdir: $!\n";
1938 $cwd_remove = undef;
1941 sub branchsuite () {
1942 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1943 if ($branch =~ m#$lbranch_re#o) {
1950 sub fetchpullargs () {
1951 if (!defined $package) {
1952 my $sourcep = parsecontrol('debian/control','debian/control');
1953 $package = getfield $sourcep, 'Source';
1956 # $isuite = branchsuite(); # this doesn't work because dak hates canons
1958 my $clogp = parsechangelog();
1959 $isuite = getfield $clogp, 'Distribution';
1961 canonicalise_suite();
1962 progress "fetching from suite $csuite";
1963 } elsif (@ARGV==1) {
1965 canonicalise_suite();
1967 badusage "incorrect arguments to dgit fetch or dgit pull";
1986 badusage "-p is not allowed with dgit push" if defined $package;
1988 my $clogp = parsechangelog();
1989 $package = getfield $clogp, 'Source';
1992 } elsif (@ARGV==1) {
1993 ($specsuite) = (@ARGV);
1995 badusage "incorrect arguments to dgit push";
1997 $isuite = getfield $clogp, 'Distribution';
1999 local ($package) = $existing_package; # this is a hack
2000 canonicalise_suite();
2002 canonicalise_suite();
2004 if (defined $specsuite &&
2005 $specsuite ne $isuite &&
2006 $specsuite ne $csuite) {
2007 fail "dgit push: changelog specifies $isuite ($csuite)".
2008 " but command line specifies $specsuite";
2010 if (check_for_git()) {
2014 if (fetch_from_archive()) {
2015 if (is_fast_fwd(lrref(), 'HEAD')) {
2017 } elsif (deliberately_not_fast_forward) {
2020 fail "dgit push: HEAD is not a descendant".
2021 " of the archive's version.\n".
2022 "dgit: To overwrite its contents,".
2023 " use git merge -s ours ".lrref().".\n".
2024 "dgit: To rewind history, if permitted by the archive,".
2025 " use --deliberately-not-fast-forward";
2029 fail "package appears to be new in this suite;".
2030 " if this is intentional, use --new";
2035 #---------- remote commands' implementation ----------
2037 sub cmd_remote_push_build_host {
2039 my ($nrargs) = shift @ARGV;
2040 my (@rargs) = @ARGV[0..$nrargs-1];
2041 @ARGV = @ARGV[$nrargs..$#ARGV];
2043 my ($dir,$vsnwant) = @rargs;
2044 # vsnwant is a comma-separated list; we report which we have
2045 # chosen in our ready response (so other end can tell if they
2048 $we_are_responder = 1;
2049 $us .= " (build host)";
2051 open PI, "<&STDIN" or die $!;
2052 open STDIN, "/dev/null" or die $!;
2053 open PO, ">&STDOUT" or die $!;
2055 open STDOUT, ">&STDERR" or die $!;
2059 fail "build host has dgit rpush protocol version".
2060 " $rpushprotovsn but invocation host has $vsnwant"
2061 unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2063 responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2069 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2070 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2071 # a good error message)
2077 my $report = i_child_report();
2078 if (defined $report) {
2079 printdebug "($report)\n";
2080 } elsif ($i_child_pid) {
2081 printdebug "(killing build host child $i_child_pid)\n";
2082 kill 15, $i_child_pid;
2084 if (defined $i_tmp && !defined $initiator_tempdir) {
2086 eval { rmtree $i_tmp; };
2090 END { i_cleanup(); }
2093 my ($base,$selector,@args) = @_;
2094 $selector =~ s/\-/_/g;
2095 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2102 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2109 my @rargs = ($dir,$rpushprotovsn);
2112 push @rdgit, @ropts;
2113 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2115 my @cmd = (@ssh, $host, shellquote @rdgit);
2118 if (defined $initiator_tempdir) {
2119 rmtree $initiator_tempdir;
2120 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2121 $i_tmp = $initiator_tempdir;
2125 $i_child_pid = open2(\*RO, \*RI, @cmd);
2127 initiator_expect { m/^dgit-remote-push-ready/ };
2129 my ($icmd,$iargs) = initiator_expect {
2130 m/^(\S+)(?: (.*))?$/;
2133 i_method "i_resp", $icmd, $iargs;
2137 sub i_resp_progress ($) {
2139 my $msg = protocol_read_bytes \*RO, $rhs;
2143 sub i_resp_complete {
2144 my $pid = $i_child_pid;
2145 $i_child_pid = undef; # prevents killing some other process with same pid
2146 printdebug "waiting for build host child $pid...\n";
2147 my $got = waitpid $pid, 0;
2148 die $! unless $got == $pid;
2149 die "build host child failed $?" if $?;
2152 printdebug "all done\n";
2156 sub i_resp_file ($) {
2158 my $localname = i_method "i_localname", $keyword;
2159 my $localpath = "$i_tmp/$localname";
2160 stat_exists $localpath and
2161 badproto \*RO, "file $keyword ($localpath) twice";
2162 protocol_receive_file \*RO, $localpath;
2163 i_method "i_file", $keyword;
2168 sub i_resp_param ($) {
2169 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2173 sub i_resp_previously ($) {
2174 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2175 or badproto \*RO, "bad previously spec";
2176 my $r = system qw(git check-ref-format), $1;
2177 die "bad previously ref spec ($r)" if $r;
2178 $previously{$1} = $2;
2183 sub i_resp_want ($) {
2185 die "$keyword ?" if $i_wanted{$keyword}++;
2186 my @localpaths = i_method "i_want", $keyword;
2187 printdebug "[[ $keyword @localpaths\n";
2188 foreach my $localpath (@localpaths) {
2189 protocol_send_file \*RI, $localpath;
2191 print RI "files-end\n" or die $!;
2194 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2196 sub i_localname_parsed_changelog {
2197 return "remote-changelog.822";
2199 sub i_file_parsed_changelog {
2200 ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2201 push_parse_changelog "$i_tmp/remote-changelog.822";
2202 die if $i_dscfn =~ m#/|^\W#;
2205 sub i_localname_dsc {
2206 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2211 sub i_localname_changes {
2212 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2213 $i_changesfn = $i_dscfn;
2214 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2215 return $i_changesfn;
2217 sub i_file_changes { }
2219 sub i_want_signed_tag {
2220 printdebug Dumper(\%i_param, $i_dscfn);
2221 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2222 && defined $i_param{'csuite'}
2223 or badproto \*RO, "premature desire for signed-tag";
2224 my $head = $i_param{'head'};
2225 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2227 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2229 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2232 push_mktag $head, $i_clogp, $i_tag,
2234 $i_changesfn, 'remote changes',
2235 sub { "tag$_[0]"; };
2240 sub i_want_signed_dsc_changes {
2241 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2242 sign_changes $i_changesfn;
2243 return ($i_dscfn, $i_changesfn);
2246 #---------- building etc. ----------
2252 #----- `3.0 (quilt)' handling -----
2254 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2256 sub quiltify_dpkg_commit ($$$;$) {
2257 my ($patchname,$author,$msg, $xinfo) = @_;
2261 my $descfn = ".git/dgit/quilt-description.tmp";
2262 open O, '>', $descfn or die "$descfn: $!";
2265 $msg =~ s/^\s+$/ ./mg;
2266 print O <<END or die $!;
2276 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2277 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2278 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2279 runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2283 sub quiltify_trees_differ ($$) {
2285 # returns 1 iff the two tree objects differ other than in debian/
2287 my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2288 my $diffs= cmdoutput @cmd;
2289 foreach my $f (split /\0/, $diffs) {
2290 next if $f eq 'debian';
2296 sub quiltify_tree_sentinelfiles ($) {
2297 # lists the `sentinel' files present in the tree
2299 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2300 qw(-- debian/rules debian/control);
2306 my ($clogp,$target) = @_;
2308 # Quilt patchification algorithm
2310 # We search backwards through the history of the main tree's HEAD
2311 # (T) looking for a start commit S whose tree object is identical
2312 # to to the patch tip tree (ie the tree corresponding to the
2313 # current dpkg-committed patch series). For these purposes
2314 # `identical' disregards anything in debian/ - this wrinkle is
2315 # necessary because dpkg-source treates debian/ specially.
2317 # We can only traverse edges where at most one of the ancestors'
2318 # trees differs (in changes outside in debian/). And we cannot
2319 # handle edges which change .pc/ or debian/patches. To avoid
2320 # going down a rathole we avoid traversing edges which introduce
2321 # debian/rules or debian/control. And we set a limit on the
2322 # number of edges we are willing to look at.
2324 # If we succeed, we walk forwards again. For each traversed edge
2325 # PC (with P parent, C child) (starting with P=S and ending with
2326 # C=T) to we do this:
2328 # - dpkg-source --commit with a patch name and message derived from C
2329 # After traversing PT, we git commit the changes which
2330 # should be contained within debian/patches.
2332 changedir '../fake';
2333 mktree_in_ud_here();
2335 runcmd @git, 'add', '.';
2336 my $oldtiptree=git_write_tree();
2337 changedir '../work';
2339 # The search for the path S..T is breadth-first. We maintain a
2340 # todo list containing search nodes. A search node identifies a
2341 # commit, and looks something like this:
2343 # Commit => $git_commit_id,
2344 # Child => $c, # or undef if P=T
2345 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
2346 # Nontrivial => true iff $p..$c has relevant changes
2353 my %considered; # saves being exponential on some weird graphs
2355 my $t_sentinels = quiltify_tree_sentinelfiles $target;
2358 my ($search,$whynot) = @_;
2359 printdebug " search NOT $search->{Commit} $whynot\n";
2360 $search->{Whynot} = $whynot;
2361 push @nots, $search;
2362 no warnings qw(exiting);
2371 my $c = shift @todo;
2372 next if $considered{$c->{Commit}}++;
2374 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2376 printdebug "quiltify investigate $c->{Commit}\n";
2379 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2380 printdebug " search finished hooray!\n";
2385 if ($quilt_mode eq 'nofix') {
2386 fail "quilt fixup required but quilt mode is \`nofix'\n".
2387 "HEAD commit $c->{Commit} differs from tree implied by ".
2388 " debian/patches (tree object $oldtiptree)";
2390 if ($quilt_mode eq 'smash') {
2391 printdebug " search quitting smash\n";
2395 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2396 $not->($c, "has $c_sentinels not $t_sentinels")
2397 if $c_sentinels ne $t_sentinels;
2399 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2400 $commitdata =~ m/\n\n/;
2402 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2403 @parents = map { { Commit => $_, Child => $c } } @parents;
2405 $not->($c, "root commit") if !@parents;
2407 foreach my $p (@parents) {
2408 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2410 my $ndiffers = grep { $_->{Nontrivial} } @parents;
2411 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2413 foreach my $p (@parents) {
2414 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2416 my @cmd= (@git, qw(diff-tree -r --name-only),
2417 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2418 my $patchstackchange = cmdoutput @cmd;
2419 if (length $patchstackchange) {
2420 $patchstackchange =~ s/\n/,/g;
2421 $not->($p, "changed $patchstackchange");
2424 printdebug " search queue P=$p->{Commit} ",
2425 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2431 printdebug "quiltify want to smash\n";
2434 my $x = $_[0]{Commit};
2435 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2438 my $reportnot = sub {
2440 my $s = $abbrev->($notp);
2441 my $c = $notp->{Child};
2442 $s .= "..".$abbrev->($c) if $c;
2443 $s .= ": ".$notp->{Whynot};
2446 if ($quilt_mode eq 'linear') {
2447 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
2448 foreach my $notp (@nots) {
2449 print STDERR "$us: ", $reportnot->($notp), "\n";
2451 fail "quilt fixup naive history linearisation failed.\n".
2452 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2453 } elsif ($quilt_mode eq 'smash') {
2454 } elsif ($quilt_mode eq 'auto') {
2455 progress "quilt fixup cannot be linear, smashing...";
2457 die "$quilt_mode ?";
2462 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2464 quiltify_dpkg_commit "auto-$version-$target-$time",
2465 (getfield $clogp, 'Maintainer'),
2466 "Automatically generated patch ($clogp->{Version})\n".
2467 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2471 progress "quiltify linearisation planning successful, executing...";
2473 for (my $p = $sref_S;
2474 my $c = $p->{Child};
2476 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2477 next unless $p->{Nontrivial};
2479 my $cc = $c->{Commit};
2481 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2482 $commitdata =~ m/\n\n/ or die "$c ?";
2485 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2488 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2491 my $patchname = $title;
2492 $patchname =~ s/[.:]$//;
2493 $patchname =~ y/ A-Z/-a-z/;
2494 $patchname =~ y/-a-z0-9_.+=~//cd;
2495 $patchname =~ s/^\W/x-$&/;
2496 $patchname = substr($patchname,0,40);
2499 stat "debian/patches/$patchname$index";
2501 $!==ENOENT or die "$patchname$index $!";
2503 runcmd @git, qw(checkout -q), $cc;
2505 # We use the tip's changelog so that dpkg-source doesn't
2506 # produce complaining messages from dpkg-parsechangelog. None
2507 # of the information dpkg-source gets from the changelog is
2508 # actually relevant - it gets put into the original message
2509 # which dpkg-source provides our stunt editor, and then
2511 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2513 quiltify_dpkg_commit "$patchname$index", $author, $msg,
2514 "X-Dgit-Generated: $clogp->{Version} $cc\n";
2516 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2519 runcmd @git, qw(checkout -q master);
2522 sub build_maybe_quilt_fixup () {
2523 my $format=get_source_format;
2524 return unless madformat $format;
2527 check_for_vendor_patches();
2530 # - honour any existing .pc in case it has any strangeness
2531 # - determine the git commit corresponding to the tip of
2532 # the patch stack (if there is one)
2533 # - if there is such a git commit, convert each subsequent
2534 # git commit into a quilt patch with dpkg-source --commit
2535 # - otherwise convert all the differences in the tree into
2536 # a single git commit
2540 # Our git tree doesn't necessarily contain .pc. (Some versions of
2541 # dgit would include the .pc in the git tree.) If there isn't
2542 # one, we need to generate one by unpacking the patches that we
2545 # We first look for a .pc in the git tree. If there is one, we
2546 # will use it. (This is not the normal case.)
2548 # Otherwise need to regenerate .pc so that dpkg-source --commit
2549 # can work. We do this as follows:
2550 # 1. Collect all relevant .orig from parent directory
2551 # 2. Generate a debian.tar.gz out of
2552 # debian/{patches,rules,source/format}
2553 # 3. Generate a fake .dsc containing just these fields:
2554 # Format Source Version Files
2555 # 4. Extract the fake .dsc
2556 # Now the fake .dsc has a .pc directory.
2557 # (In fact we do this in every case, because in future we will
2558 # want to search for a good base commit for generating patches.)
2560 # Then we can actually do the dpkg-source --commit
2561 # 1. Make a new working tree with the same object
2562 # store as our main tree and check out the main
2564 # 2. Copy .pc from the fake's extraction, if necessary
2565 # 3. Run dpkg-source --commit
2566 # 4. If the result has changes to debian/, then
2567 # - git-add them them
2568 # - git-add .pc if we had a .pc in-tree
2570 # 5. If we had a .pc in-tree, delete it, and git-commit
2571 # 6. Back in the main tree, fast forward to the new HEAD
2573 my $clogp = parsechangelog();
2574 my $headref = git_rev_parse('HEAD');
2579 my $upstreamversion=$version;
2580 $upstreamversion =~ s/-[^-]*$//;
2582 my $fakeversion="$upstreamversion-~~DGITFAKE";
2584 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2585 print $fakedsc <<END or die $!;
2588 Version: $fakeversion
2592 my $dscaddfile=sub {
2595 my $md = new Digest::MD5;
2597 my $fh = new IO::File $b, '<' or die "$b $!";
2602 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2605 foreach my $f (<../../../../*>) { #/){
2606 my $b=$f; $b =~ s{.*/}{};
2607 next unless is_orig_file $b, srcfn $upstreamversion,'';
2608 link $f, $b or die "$b $!";
2612 my @files=qw(debian/source/format debian/rules);
2613 if (stat_exists '../../../debian/patches') {
2614 push @files, 'debian/patches';
2617 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2618 runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2620 $dscaddfile->($debtar);
2621 close $fakedsc or die $!;
2623 runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2625 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2626 rename $fakexdir, "fake" or die "$fakexdir $!";
2628 mkdir "work" or die $!;
2630 mktree_in_ud_here();
2631 runcmd @git, qw(reset --hard), $headref;
2634 if (stat_exists ".pc") {
2636 progress "Tree already contains .pc - will use it then delete it.";
2639 rename '../fake/.pc','.pc' or die $!;
2642 quiltify($clogp,$headref);
2644 if (!open P, '>>', ".pc/applied-patches") {
2645 $!==&ENOENT or die $!;
2650 commit_quilty_patch();
2652 if ($mustdeletepc) {
2653 runcmd @git, qw(rm -rqf .pc);
2654 commit_admin "Commit removal of .pc (quilt series tracking data)";
2657 changedir '../../../..';
2658 runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2661 sub quilt_fixup_editor () {
2662 my $descfn = $ENV{$fakeeditorenv};
2663 my $editing = $ARGV[$#ARGV];
2664 open I1, '<', $descfn or die "$descfn: $!";
2665 open I2, '<', $editing or die "$editing: $!";
2666 unlink $editing or die "$editing: $!";
2667 open O, '>', $editing or die "$editing: $!";
2668 while (<I1>) { print O or die $!; } I1->error and die $!;
2671 $copying ||= m/^\-\-\- /;
2672 next unless $copying;
2675 I2->error and die $!;
2680 #----- other building -----
2683 if ($cleanmode eq 'dpkg-source') {
2684 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2685 } elsif ($cleanmode eq 'dpkg-source-d') {
2686 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2687 } elsif ($cleanmode eq 'git') {
2688 runcmd_ordryrun_local @git, qw(clean -xdf);
2689 } elsif ($cleanmode eq 'git-ff') {
2690 runcmd_ordryrun_local @git, qw(clean -xdff);
2691 } elsif ($cleanmode eq 'check') {
2692 my $leftovers = cmdoutput @git, qw(clean -xdn);
2693 if (length $leftovers) {
2694 print STDERR $leftovers, "\n" or die $!;
2695 fail "tree contains uncommitted files and --clean=check specified";
2697 } elsif ($cleanmode eq 'none') {
2704 badusage "clean takes no additional arguments" if @ARGV;
2709 badusage "-p is not allowed when building" if defined $package;
2712 my $clogp = parsechangelog();
2713 $isuite = getfield $clogp, 'Distribution';
2714 $package = getfield $clogp, 'Source';
2715 $version = getfield $clogp, 'Version';
2716 build_maybe_quilt_fixup();
2719 sub changesopts () {
2720 my @opts =@changesopts[1..$#changesopts];
2721 if (!defined $changes_since_version) {
2722 my @vsns = archive_query('archive_query');
2723 my @quirk = access_quirk();
2724 if ($quirk[0] eq 'backports') {
2725 local $isuite = $quirk[2];
2727 canonicalise_suite();
2728 push @vsns, archive_query('archive_query');
2731 @vsns = map { $_->[0] } @vsns;
2732 @vsns = sort { -version_compare($a, $b) } @vsns;
2733 $changes_since_version = $vsns[0];
2734 progress "changelog will contain changes since $vsns[0]";
2736 $changes_since_version = '_';
2737 progress "package seems new, not specifying -v<version>";
2740 if ($changes_since_version ne '_') {
2741 unshift @opts, "-v$changes_since_version";
2746 sub massage_dbp_args ($) {
2748 return unless $cleanmode =~ m/git|none/;
2749 debugcmd '#massaging#', @$cmd if $debuglevel>1;
2750 my @newcmd = shift @$cmd;
2751 # -nc has the side effect of specifying -b if nothing else specified
2752 push @newcmd, '-nc';
2753 # and some combinations of -S, -b, et al, are errors, rather than
2754 # later simply overriding earlier
2755 push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2756 push @newcmd, @$cmd;
2762 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2763 massage_dbp_args \@dbp;
2764 runcmd_ordryrun_local @dbp;
2765 printdone "build successful\n";
2770 my @dbp = @dpkgbuildpackage;
2771 massage_dbp_args \@dbp;
2773 (qw(git-buildpackage -us -uc --git-no-sign-tags),
2774 "--git-builder=@dbp");
2775 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2776 canonicalise_suite();
2777 push @cmd, "--git-debian-branch=".lbranch();
2779 push @cmd, changesopts();
2780 runcmd_ordryrun_local @cmd, @ARGV;
2781 printdone "build successful\n";
2786 $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2787 $dscfn = dscfn($version);
2788 if ($cleanmode eq 'dpkg-source') {
2789 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2791 } elsif ($cleanmode eq 'dpkg-source-d') {
2792 runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2795 my $pwd = must_getcwd();
2796 my $leafdir = basename $pwd;
2798 runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2800 runcmd_ordryrun_local qw(sh -ec),
2801 'exec >$1; shift; exec "$@"','x',
2802 "../$sourcechanges",
2803 @dpkggenchanges, qw(-S), changesopts();
2807 sub cmd_build_source {
2808 badusage "build-source takes no additional arguments" if @ARGV;
2810 printdone "source built, results in $dscfn and $sourcechanges";
2816 my $pat = "${package}_".(stripepoch $version)."_*.changes";
2818 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2819 stat_exists $sourcechanges
2820 or fail "$sourcechanges (in parent directory): $!";
2821 foreach my $cf (glob $pat) {
2822 next if $cf eq $sourcechanges;
2823 unlink $cf or fail "remove $cf: $!";
2826 runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2827 my @changesfiles = glob $pat;
2828 @changesfiles = sort {
2829 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2832 fail "wrong number of different changes files (@changesfiles)"
2833 unless @changesfiles;
2834 runcmd_ordryrun_local @mergechanges, @changesfiles;
2835 my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2837 stat_exists $multichanges or fail "$multichanges: $!";
2839 printdone "build successful, results in $multichanges\n" or die $!;
2842 sub cmd_quilt_fixup {
2843 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2844 my $clogp = parsechangelog();
2845 $version = getfield $clogp, 'Version';
2846 $package = getfield $clogp, 'Source';
2847 build_maybe_quilt_fixup();
2850 sub cmd_archive_api_query {
2851 badusage "need only 1 subpath argument" unless @ARGV==1;
2852 my ($subpath) = @ARGV;
2853 my @cmd = archive_api_query_cmd($subpath);
2855 exec @cmd or fail "exec curl: $!\n";
2858 sub cmd_clone_dgit_repos_server {
2859 badusage "need destination argument" unless @ARGV==1;
2860 my ($destdir) = @ARGV;
2861 $package = '_dgit-repos-server';
2862 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2864 exec @cmd or fail "exec git clone: $!\n";
2867 sub cmd_setup_mergechangelogs {
2868 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2869 setup_mergechangelogs();
2872 #---------- argument parsing and main program ----------
2875 print "dgit version $our_version\n" or die $!;
2882 if (defined $ENV{'DGIT_SSH'}) {
2883 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2884 } elsif (defined $ENV{'GIT_SSH'}) {
2885 @ssh = ($ENV{'GIT_SSH'});
2889 last unless $ARGV[0] =~ m/^-/;
2893 if (m/^--dry-run$/) {
2896 } elsif (m/^--damp-run$/) {
2899 } elsif (m/^--no-sign$/) {
2902 } elsif (m/^--help$/) {
2904 } elsif (m/^--version$/) {
2906 } elsif (m/^--new$/) {
2909 } elsif (m/^--since-version=([^_]+|_)$/) {
2911 $changes_since_version = $1;
2912 } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2913 ($om = $opts_opt_map{$1}) &&
2917 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2918 !$opts_opt_cmdonly{$1} &&
2919 ($om = $opts_opt_map{$1})) {
2922 } elsif (m/^--existing-package=(.*)/s) {
2924 $existing_package = $1;
2925 } elsif (m/^--initiator-tempdir=(.*)/s) {
2926 $initiator_tempdir = $1;
2927 $initiator_tempdir =~ m#^/# or
2928 badusage "--initiator-tempdir must be used specify an".
2929 " absolute, not relative, directory."
2930 } elsif (m/^--distro=(.*)/s) {
2933 } elsif (m/^--build-products-dir=(.*)/s) {
2935 $buildproductsdir = $1;
2936 } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2939 } elsif (m/^--clean=(.*)$/s) {
2940 badusage "unknown cleaning mode \`$1'";
2941 } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2944 } elsif (m/^--quilt=(.*)$/s) {
2945 badusage "unknown quilt fixup mode \`$1'";
2946 } elsif (m/^--ignore-dirty$/s) {
2949 } elsif (m/^--no-quilt-fixup$/s) {
2951 $quilt_mode = 'nocheck';
2952 } elsif (m/^--no-rm-on-error$/s) {
2955 } elsif (m/^--deliberately-($deliberately_re)$/s) {
2957 push @deliberatelies, $&;
2959 badusage "unknown long option \`$_'";
2966 } elsif (s/^-L/-/) {
2969 } elsif (s/^-h/-/) {
2971 } elsif (s/^-D/-/) {
2975 } elsif (s/^-N/-/) {
2978 } elsif (s/^-v([^_]+|_)$//s) {
2980 $changes_since_version = $1;
2983 push @changesopts, $_;
2985 } elsif (s/^-c(.*=.*)//s) {
2987 push @git, '-c', $1;
2988 } elsif (s/^-d(.+)//s) {
2991 } elsif (s/^-C(.+)//s) {
2994 if ($changesfile =~ s#^(.*)/##) {
2995 $buildproductsdir = $1;
2997 } elsif (s/^-k(.+)//s) {
2999 } elsif (m/^-[vdCk]$/) {
3001 "option \`$_' requires an argument (and no space before the argument)";
3002 } elsif (s/^-wn$//s) {
3004 $cleanmode = 'none';
3005 } elsif (s/^-wg$//s) {
3008 } elsif (s/^-wgf$//s) {
3010 $cleanmode = 'git-ff';
3011 } elsif (s/^-wd$//s) {
3013 $cleanmode = 'dpkg-source';
3014 } elsif (s/^-wdd$//s) {
3016 $cleanmode = 'dpkg-source-d';
3017 } elsif (s/^-wc$//s) {
3019 $cleanmode = 'check';
3021 badusage "unknown short option \`$_'";
3028 if ($ENV{$fakeeditorenv}) {
3029 quilt_fixup_editor();
3033 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3034 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3035 if $dryrun_level == 1;
3037 print STDERR $helpmsg or die $!;
3040 my $cmd = shift @ARGV;
3043 if (!defined $quilt_mode) {
3044 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3045 // access_cfg('quilt-mode', 'RETURN-UNDEF')
3047 $quilt_mode =~ m/^($quilt_modes_re)$/
3048 or badcfg "unknown quilt-mode \`$quilt_mode'";
3052 my $fn = ${*::}{"cmd_$cmd"};
3053 $fn or badusage "unknown operation $cmd";