3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 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/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
48 our $isuite = 'unstable';
54 our $dryrun_level = 0;
56 our $buildproductsdir = '..';
62 our $existing_package = 'dpkg';
64 our $changes_since_version;
66 our $overwrite_version; # undef: not specified; '': check changelog
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
80 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
81 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
82 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
84 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
85 our $splitbraincache = 'dgit-intern/quilt-cache';
88 our (@dget) = qw(dget);
89 our (@curl) = qw(curl -f);
90 our (@dput) = qw(dput);
91 our (@debsign) = qw(debsign);
93 our (@sbuild) = qw(sbuild);
95 our (@dgit) = qw(dgit);
96 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
97 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
98 our (@dpkggenchanges) = qw(dpkg-genchanges);
99 our (@mergechanges) = qw(mergechanges -f);
100 our (@gbp_build) = ('');
101 our (@gbp_pq) = ('gbp pq');
102 our (@changesopts) = ('');
104 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
107 'debsign' => \@debsign,
109 'sbuild' => \@sbuild,
113 'dpkg-source' => \@dpkgsource,
114 'dpkg-buildpackage' => \@dpkgbuildpackage,
115 'dpkg-genchanges' => \@dpkggenchanges,
116 'gbp-build' => \@gbp_build,
117 'gbp-pq' => \@gbp_pq,
118 'ch' => \@changesopts,
119 'mergechanges' => \@mergechanges);
121 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
122 our %opts_cfg_insertpos = map {
124 scalar @{ $opts_opt_map{$_} }
125 } keys %opts_opt_map;
127 sub finalise_opts_opts();
133 our $supplementary_message = '';
134 our $need_split_build_invocation = 0;
135 our $split_brain = 0;
139 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
142 our $remotename = 'dgit';
143 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
148 my ($v,$distro) = @_;
149 return $tagformatfn->($v, $distro);
152 sub debiantag_maintview ($$) {
153 my ($v,$distro) = @_;
158 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
160 sub lbranch () { return "$branchprefix/$csuite"; }
161 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
162 sub lref () { return "refs/heads/".lbranch(); }
163 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
164 sub rrref () { return server_ref($csuite); }
166 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
167 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
169 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
170 # locally fetched refs because they have unhelpful names and clutter
171 # up gitk etc. So we track whether we have "used up" head ref (ie,
172 # whether we have made another local ref which refers to this object).
174 # (If we deleted them unconditionally, then we might end up
175 # re-fetching the same git objects each time dgit fetch was run.)
177 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
178 # in git_fetch_us to fetch the refs in question, and possibly a call
179 # to lrfetchref_used.
181 our (%lrfetchrefs_f, %lrfetchrefs_d);
182 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
184 sub lrfetchref_used ($) {
185 my ($fullrefname) = @_;
186 my $objid = $lrfetchrefs_f{$fullrefname};
187 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
198 return "${package}_".(stripepoch $vsn).$sfx
203 return srcfn($vsn,".dsc");
206 sub changespat ($;$) {
207 my ($vsn, $arch) = @_;
208 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
217 foreach my $f (@end) {
219 print STDERR "$us: cleanup: $@" if length $@;
223 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
225 sub no_such_package () {
226 print STDERR "$us: package $package does not exist in suite $isuite\n";
232 printdebug "CD $newdir\n";
233 chdir $newdir or confess "chdir: $newdir: $!";
236 sub deliberately ($) {
238 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
241 sub deliberately_not_fast_forward () {
242 foreach (qw(not-fast-forward fresh-repo)) {
243 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
247 sub quiltmode_splitbrain () {
248 $quilt_mode =~ m/gbp|dpm|unapplied/;
251 sub opts_opt_multi_cmd {
253 push @cmd, split /\s+/, shift @_;
259 return opts_opt_multi_cmd @gbp_pq;
262 #---------- remote protocol support, common ----------
264 # remote push initiator/responder protocol:
265 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
266 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
267 # < dgit-remote-push-ready <actual-proto-vsn>
274 # > supplementary-message NBYTES # $protovsn >= 3
279 # > file parsed-changelog
280 # [indicates that output of dpkg-parsechangelog follows]
281 # > data-block NBYTES
282 # > [NBYTES bytes of data (no newline)]
283 # [maybe some more blocks]
292 # > param head DGIT-VIEW-HEAD
293 # > param csuite SUITE
294 # > param tagformat old|new
295 # > param maint-view MAINT-VIEW-HEAD
297 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
298 # # goes into tag, for replay prevention
301 # [indicates that signed tag is wanted]
302 # < data-block NBYTES
303 # < [NBYTES bytes of data (no newline)]
304 # [maybe some more blocks]
308 # > want signed-dsc-changes
309 # < data-block NBYTES [transfer of signed dsc]
311 # < data-block NBYTES [transfer of signed changes]
319 sub i_child_report () {
320 # Sees if our child has died, and reap it if so. Returns a string
321 # describing how it died if it failed, or undef otherwise.
322 return undef unless $i_child_pid;
323 my $got = waitpid $i_child_pid, WNOHANG;
324 return undef if $got <= 0;
325 die unless $got == $i_child_pid;
326 $i_child_pid = undef;
327 return undef unless $?;
328 return "build host child ".waitstatusmsg();
333 fail "connection lost: $!" if $fh->error;
334 fail "protocol violation; $m not expected";
337 sub badproto_badread ($$) {
339 fail "connection lost: $!" if $!;
340 my $report = i_child_report();
341 fail $report if defined $report;
342 badproto $fh, "eof (reading $wh)";
345 sub protocol_expect (&$) {
346 my ($match, $fh) = @_;
349 defined && chomp or badproto_badread $fh, "protocol message";
357 badproto $fh, "\`$_'";
360 sub protocol_send_file ($$) {
361 my ($fh, $ourfn) = @_;
362 open PF, "<", $ourfn or die "$ourfn: $!";
365 my $got = read PF, $d, 65536;
366 die "$ourfn: $!" unless defined $got;
368 print $fh "data-block ".length($d)."\n" or die $!;
369 print $fh $d or die $!;
371 PF->error and die "$ourfn $!";
372 print $fh "data-end\n" or die $!;
376 sub protocol_read_bytes ($$) {
377 my ($fh, $nbytes) = @_;
378 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
380 my $got = read $fh, $d, $nbytes;
381 $got==$nbytes or badproto_badread $fh, "data block";
385 sub protocol_receive_file ($$) {
386 my ($fh, $ourfn) = @_;
387 printdebug "() $ourfn\n";
388 open PF, ">", $ourfn or die "$ourfn: $!";
390 my ($y,$l) = protocol_expect {
391 m/^data-block (.*)$/ ? (1,$1) :
392 m/^data-end$/ ? (0,) :
396 my $d = protocol_read_bytes $fh, $l;
397 print PF $d or die $!;
402 #---------- remote protocol support, responder ----------
404 sub responder_send_command ($) {
406 return unless $we_are_responder;
407 # called even without $we_are_responder
408 printdebug ">> $command\n";
409 print PO $command, "\n" or die $!;
412 sub responder_send_file ($$) {
413 my ($keyword, $ourfn) = @_;
414 return unless $we_are_responder;
415 printdebug "]] $keyword $ourfn\n";
416 responder_send_command "file $keyword";
417 protocol_send_file \*PO, $ourfn;
420 sub responder_receive_files ($@) {
421 my ($keyword, @ourfns) = @_;
422 die unless $we_are_responder;
423 printdebug "[[ $keyword @ourfns\n";
424 responder_send_command "want $keyword";
425 foreach my $fn (@ourfns) {
426 protocol_receive_file \*PI, $fn;
429 protocol_expect { m/^files-end$/ } \*PI;
432 #---------- remote protocol support, initiator ----------
434 sub initiator_expect (&) {
436 protocol_expect { &$match } \*RO;
439 #---------- end remote code ----------
442 if ($we_are_responder) {
444 responder_send_command "progress ".length($m) or die $!;
445 print PO $m or die $!;
455 $ua = LWP::UserAgent->new();
459 progress "downloading $what...";
460 my $r = $ua->get(@_) or die $!;
461 return undef if $r->code == 404;
462 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
463 return $r->decoded_content(charset => 'none');
466 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
471 failedcmd @_ if system @_;
474 sub act_local () { return $dryrun_level <= 1; }
475 sub act_scary () { return !$dryrun_level; }
478 if (!$dryrun_level) {
479 progress "dgit ok: @_";
481 progress "would be ok: @_ (but dry run only)";
486 printcmd(\*STDERR,$debugprefix."#",@_);
489 sub runcmd_ordryrun {
497 sub runcmd_ordryrun_local {
506 my ($first_shell, @cmd) = @_;
507 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
510 our $helpmsg = <<END;
512 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
513 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
514 dgit [dgit-opts] build [dpkg-buildpackage-opts]
515 dgit [dgit-opts] sbuild [sbuild-opts]
516 dgit [dgit-opts] push [dgit-opts] [suite]
517 dgit [dgit-opts] rpush build-host:build-dir ...
518 important dgit options:
519 -k<keyid> sign tag and package with <keyid> instead of default
520 --dry-run -n do not change anything, but go through the motions
521 --damp-run -L like --dry-run but make local changes, without signing
522 --new -N allow introducing a new package
523 --debug -D increase debug level
524 -c<name>=<value> set git config option (used directly by dgit too)
527 our $later_warning_msg = <<END;
528 Perhaps the upload is stuck in incoming. Using the version from git.
532 print STDERR "$us: @_\n", $helpmsg or die $!;
537 @ARGV or badusage "too few arguments";
538 return scalar shift @ARGV;
542 print $helpmsg or die $!;
546 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
548 our %defcfg = ('dgit.default.distro' => 'debian',
549 'dgit.default.username' => '',
550 'dgit.default.archive-query-default-component' => 'main',
551 'dgit.default.ssh' => 'ssh',
552 'dgit.default.archive-query' => 'madison:',
553 'dgit.default.sshpsql-dbname' => 'service=projectb',
554 'dgit.default.dgit-tag-format' => 'new,old,maint',
555 # old means "repo server accepts pushes with old dgit tags"
556 # new means "repo server accepts pushes with new dgit tags"
557 # maint means "repo server accepts split brain pushes"
558 # hist means "repo server may have old pushes without new tag"
559 # ("hist" is implied by "old")
560 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
561 'dgit-distro.debian.git-check' => 'url',
562 'dgit-distro.debian.git-check-suffix' => '/info/refs',
563 'dgit-distro.debian.new-private-pushers' => 't',
564 'dgit-distro.debian/push.git-url' => '',
565 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
566 'dgit-distro.debian/push.git-user-force' => 'dgit',
567 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
568 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
569 'dgit-distro.debian/push.git-create' => 'true',
570 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
571 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
572 # 'dgit-distro.debian.archive-query-tls-key',
573 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
574 # ^ this does not work because curl is broken nowadays
575 # Fixing #790093 properly will involve providing providing the key
576 # in some pacagke and maybe updating these paths.
578 # 'dgit-distro.debian.archive-query-tls-curl-args',
579 # '--ca-path=/etc/ssl/ca-debian',
580 # ^ this is a workaround but works (only) on DSA-administered machines
581 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
582 'dgit-distro.debian.git-url-suffix' => '',
583 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
584 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
585 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
586 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
587 'dgit-distro.ubuntu.git-check' => 'false',
588 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
589 'dgit-distro.test-dummy.ssh' => "$td/ssh",
590 'dgit-distro.test-dummy.username' => "alice",
591 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
592 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
593 'dgit-distro.test-dummy.git-url' => "$td/git",
594 'dgit-distro.test-dummy.git-host' => "git",
595 'dgit-distro.test-dummy.git-path' => "$td/git",
596 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
597 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
598 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
599 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
603 our @gitcfgsources = qw(cmdline local global system);
605 sub git_slurp_config () {
606 local ($debuglevel) = $debuglevel-2;
609 # This algoritm is a bit subtle, but this is needed so that for
610 # options which we want to be single-valued, we allow the
611 # different config sources to override properly. See #835858.
612 foreach my $src (@gitcfgsources) {
613 next if $src eq 'cmdline';
614 # we do this ourselves since git doesn't handle it
616 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
619 open GITS, "-|", @cmd or die $!;
622 printdebug "=> ", (messagequote $_), "\n";
624 push @{ $gitcfgs{$src}{$`} }, $'; #';
628 or ($!==0 && $?==256)
633 sub git_get_config ($) {
635 foreach my $src (@gitcfgsources) {
636 my $l = $gitcfgs{$src}{$c};
637 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
640 @$l==1 or badcfg "multiple values for $c".
641 " (in $src git config)" if @$l > 1;
649 return undef if $c =~ /RETURN-UNDEF/;
650 my $v = git_get_config($c);
651 return $v if defined $v;
652 my $dv = $defcfg{$c};
653 return $dv if defined $dv;
655 badcfg "need value for one of: @_\n".
656 "$us: distro or suite appears not to be (properly) supported";
659 sub access_basedistro () {
660 if (defined $idistro) {
663 return cfg("dgit-suite.$isuite.distro",
664 "dgit.default.distro");
668 sub access_quirk () {
669 # returns (quirk name, distro to use instead or undef, quirk-specific info)
670 my $basedistro = access_basedistro();
671 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
673 if (defined $backports_quirk) {
674 my $re = $backports_quirk;
675 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
677 $re =~ s/\%/([-0-9a-z_]+)/
678 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
679 if ($isuite =~ m/^$re$/) {
680 return ('backports',"$basedistro-backports",$1);
683 return ('none',undef);
688 sub parse_cfg_bool ($$$) {
689 my ($what,$def,$v) = @_;
692 $v =~ m/^[ty1]/ ? 1 :
693 $v =~ m/^[fn0]/ ? 0 :
694 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
697 sub access_forpush_config () {
698 my $d = access_basedistro();
702 parse_cfg_bool('new-private-pushers', 0,
703 cfg("dgit-distro.$d.new-private-pushers",
706 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
709 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
710 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
711 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
712 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
715 sub access_forpush () {
716 $access_forpush //= access_forpush_config();
717 return $access_forpush;
721 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
722 badcfg "pushing but distro is configured readonly"
723 if access_forpush_config() eq '0';
725 $supplementary_message = <<'END' unless $we_are_responder;
726 Push failed, before we got started.
727 You can retry the push, after fixing the problem, if you like.
729 finalise_opts_opts();
733 finalise_opts_opts();
736 sub supplementary_message ($) {
738 if (!$we_are_responder) {
739 $supplementary_message = $msg;
741 } elsif ($protovsn >= 3) {
742 responder_send_command "supplementary-message ".length($msg)
744 print PO $msg or die $!;
748 sub access_distros () {
749 # Returns list of distros to try, in order
752 # 0. `instead of' distro name(s) we have been pointed to
753 # 1. the access_quirk distro, if any
754 # 2a. the user's specified distro, or failing that } basedistro
755 # 2b. the distro calculated from the suite }
756 my @l = access_basedistro();
758 my (undef,$quirkdistro) = access_quirk();
759 unshift @l, $quirkdistro;
760 unshift @l, $instead_distro;
761 @l = grep { defined } @l;
763 if (access_forpush()) {
764 @l = map { ("$_/push", $_) } @l;
769 sub access_cfg_cfgs (@) {
772 # The nesting of these loops determines the search order. We put
773 # the key loop on the outside so that we search all the distros
774 # for each key, before going on to the next key. That means that
775 # if access_cfg is called with a more specific, and then a less
776 # specific, key, an earlier distro can override the less specific
777 # without necessarily overriding any more specific keys. (If the
778 # distro wants to override the more specific keys it can simply do
779 # so; whereas if we did the loop the other way around, it would be
780 # impossible to for an earlier distro to override a less specific
781 # key but not the more specific ones without restating the unknown
782 # values of the more specific keys.
785 # We have to deal with RETURN-UNDEF specially, so that we don't
786 # terminate the search prematurely.
788 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
791 foreach my $d (access_distros()) {
792 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
794 push @cfgs, map { "dgit.default.$_" } @realkeys;
801 my (@cfgs) = access_cfg_cfgs(@keys);
802 my $value = cfg(@cfgs);
806 sub access_cfg_bool ($$) {
807 my ($def, @keys) = @_;
808 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
811 sub string_to_ssh ($) {
813 if ($spec =~ m/\s/) {
814 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
820 sub access_cfg_ssh () {
821 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
822 if (!defined $gitssh) {
825 return string_to_ssh $gitssh;
829 sub access_runeinfo ($) {
831 return ": dgit ".access_basedistro()." $info ;";
834 sub access_someuserhost ($) {
836 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
837 defined($user) && length($user) or
838 $user = access_cfg("$some-user",'username');
839 my $host = access_cfg("$some-host");
840 return length($user) ? "$user\@$host" : $host;
843 sub access_gituserhost () {
844 return access_someuserhost('git');
847 sub access_giturl (;$) {
849 my $url = access_cfg('git-url','RETURN-UNDEF');
852 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
853 return undef unless defined $proto;
856 access_gituserhost().
857 access_cfg('git-path');
859 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
862 return "$url/$package$suffix";
865 sub parsecontrolfh ($$;$) {
866 my ($fh, $desc, $allowsigned) = @_;
867 our $dpkgcontrolhash_noissigned;
870 my %opts = ('name' => $desc);
871 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
872 $c = Dpkg::Control::Hash->new(%opts);
873 $c->parse($fh,$desc) or die "parsing of $desc failed";
874 last if $allowsigned;
875 last if $dpkgcontrolhash_noissigned;
876 my $issigned= $c->get_option('is_pgp_signed');
877 if (!defined $issigned) {
878 $dpkgcontrolhash_noissigned= 1;
879 seek $fh, 0,0 or die "seek $desc: $!";
880 } elsif ($issigned) {
881 fail "control file $desc is (already) PGP-signed. ".
882 " Note that dgit push needs to modify the .dsc and then".
883 " do the signature itself";
892 my ($file, $desc) = @_;
893 my $fh = new IO::Handle;
894 open $fh, '<', $file or die "$file: $!";
895 my $c = parsecontrolfh($fh,$desc);
896 $fh->error and die $!;
902 my ($dctrl,$field) = @_;
903 my $v = $dctrl->{$field};
904 return $v if defined $v;
905 fail "missing field $field in ".$dctrl->get_option('name');
909 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
910 my $p = new IO::Handle;
911 my @cmd = (qw(dpkg-parsechangelog), @_);
912 open $p, '-|', @cmd or die $!;
914 $?=0; $!=0; close $p or failedcmd @cmd;
918 sub commit_getclogp ($) {
919 # Returns the parsed changelog hashref for a particular commit
921 our %commit_getclogp_memo;
922 my $memo = $commit_getclogp_memo{$objid};
923 return $memo if $memo;
925 my $mclog = ".git/dgit/clog-$objid";
926 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
927 "$objid:debian/changelog";
928 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
933 defined $d or fail "getcwd failed: $!";
939 sub archive_query ($) {
941 my $query = access_cfg('archive-query','RETURN-UNDEF');
942 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
945 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
948 sub pool_dsc_subpath ($$) {
949 my ($vsn,$component) = @_; # $package is implict arg
950 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
951 return "/pool/$component/$prefix/$package/".dscfn($vsn);
954 #---------- `ftpmasterapi' archive query method (nascent) ----------
956 sub archive_api_query_cmd ($) {
958 my @cmd = qw(curl -sS);
959 my $url = access_cfg('archive-query-url');
960 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
962 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
963 foreach my $key (split /\:/, $keys) {
964 $key =~ s/\%HOST\%/$host/g;
966 fail "for $url: stat $key: $!" unless $!==ENOENT;
969 fail "config requested specific TLS key but do not know".
970 " how to get curl to use exactly that EE key ($key)";
971 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
972 # # Sadly the above line does not work because of changes
973 # # to gnutls. The real fix for #790093 may involve
974 # # new curl options.
977 # Fixing #790093 properly will involve providing a value
978 # for this on clients.
979 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
980 push @cmd, split / /, $kargs if defined $kargs;
982 push @cmd, $url.$subpath;
988 my ($data, $subpath) = @_;
989 badcfg "ftpmasterapi archive query method takes no data part"
991 my @cmd = archive_api_query_cmd($subpath);
992 my $json = cmdoutput @cmd;
993 return decode_json($json);
996 sub canonicalise_suite_ftpmasterapi () {
997 my ($proto,$data) = @_;
998 my $suites = api_query($data, 'suites');
1000 foreach my $entry (@$suites) {
1002 my $v = $entry->{$_};
1003 defined $v && $v eq $isuite;
1004 } qw(codename name);
1005 push @matched, $entry;
1007 fail "unknown suite $isuite" unless @matched;
1010 @matched==1 or die "multiple matches for suite $isuite\n";
1011 $cn = "$matched[0]{codename}";
1012 defined $cn or die "suite $isuite info has no codename\n";
1013 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1015 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1020 sub archive_query_ftpmasterapi () {
1021 my ($proto,$data) = @_;
1022 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1024 my $digester = Digest::SHA->new(256);
1025 foreach my $entry (@$info) {
1027 my $vsn = "$entry->{version}";
1028 my ($ok,$msg) = version_check $vsn;
1029 die "bad version: $msg\n" unless $ok;
1030 my $component = "$entry->{component}";
1031 $component =~ m/^$component_re$/ or die "bad component";
1032 my $filename = "$entry->{filename}";
1033 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1034 or die "bad filename";
1035 my $sha256sum = "$entry->{sha256sum}";
1036 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1037 push @rows, [ $vsn, "/pool/$component/$filename",
1038 $digester, $sha256sum ];
1040 die "bad ftpmaster api response: $@\n".Dumper($entry)
1043 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1047 #---------- `madison' archive query method ----------
1049 sub archive_query_madison {
1050 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1053 sub madison_get_parse {
1054 my ($proto,$data) = @_;
1055 die unless $proto eq 'madison';
1056 if (!length $data) {
1057 $data= access_cfg('madison-distro','RETURN-UNDEF');
1058 $data //= access_basedistro();
1060 $rmad{$proto,$data,$package} ||= cmdoutput
1061 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1062 my $rmad = $rmad{$proto,$data,$package};
1065 foreach my $l (split /\n/, $rmad) {
1066 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1067 \s*( [^ \t|]+ )\s* \|
1068 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1069 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1070 $1 eq $package or die "$rmad $package ?";
1077 $component = access_cfg('archive-query-default-component');
1079 $5 eq 'source' or die "$rmad ?";
1080 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1082 return sort { -version_compare($a->[0],$b->[0]); } @out;
1085 sub canonicalise_suite_madison {
1086 # madison canonicalises for us
1087 my @r = madison_get_parse(@_);
1089 "unable to canonicalise suite using package $package".
1090 " which does not appear to exist in suite $isuite;".
1091 " --existing-package may help";
1095 #---------- `sshpsql' archive query method ----------
1098 my ($data,$runeinfo,$sql) = @_;
1099 if (!length $data) {
1100 $data= access_someuserhost('sshpsql').':'.
1101 access_cfg('sshpsql-dbname');
1103 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1104 my ($userhost,$dbname) = ($`,$'); #';
1106 my @cmd = (access_cfg_ssh, $userhost,
1107 access_runeinfo("ssh-psql $runeinfo").
1108 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1109 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1111 open P, "-|", @cmd or die $!;
1114 printdebug(">|$_|\n");
1117 $!=0; $?=0; close P or failedcmd @cmd;
1119 my $nrows = pop @rows;
1120 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1121 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1122 @rows = map { [ split /\|/, $_ ] } @rows;
1123 my $ncols = scalar @{ shift @rows };
1124 die if grep { scalar @$_ != $ncols } @rows;
1128 sub sql_injection_check {
1129 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1132 sub archive_query_sshpsql ($$) {
1133 my ($proto,$data) = @_;
1134 sql_injection_check $isuite, $package;
1135 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1136 SELECT source.version, component.name, files.filename, files.sha256sum
1138 JOIN src_associations ON source.id = src_associations.source
1139 JOIN suite ON suite.id = src_associations.suite
1140 JOIN dsc_files ON dsc_files.source = source.id
1141 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1142 JOIN component ON component.id = files_archive_map.component_id
1143 JOIN files ON files.id = dsc_files.file
1144 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1145 AND source.source='$package'
1146 AND files.filename LIKE '%.dsc';
1148 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1149 my $digester = Digest::SHA->new(256);
1151 my ($vsn,$component,$filename,$sha256sum) = @$_;
1152 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1157 sub canonicalise_suite_sshpsql ($$) {
1158 my ($proto,$data) = @_;
1159 sql_injection_check $isuite;
1160 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1161 SELECT suite.codename
1162 FROM suite where suite_name='$isuite' or codename='$isuite';
1164 @rows = map { $_->[0] } @rows;
1165 fail "unknown suite $isuite" unless @rows;
1166 die "ambiguous $isuite: @rows ?" if @rows>1;
1170 #---------- `dummycat' archive query method ----------
1172 sub canonicalise_suite_dummycat ($$) {
1173 my ($proto,$data) = @_;
1174 my $dpath = "$data/suite.$isuite";
1175 if (!open C, "<", $dpath) {
1176 $!==ENOENT or die "$dpath: $!";
1177 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1181 chomp or die "$dpath: $!";
1183 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1187 sub archive_query_dummycat ($$) {
1188 my ($proto,$data) = @_;
1189 canonicalise_suite();
1190 my $dpath = "$data/package.$csuite.$package";
1191 if (!open C, "<", $dpath) {
1192 $!==ENOENT or die "$dpath: $!";
1193 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1201 printdebug "dummycat query $csuite $package $dpath | $_\n";
1202 my @row = split /\s+/, $_;
1203 @row==2 or die "$dpath: $_ ?";
1206 C->error and die "$dpath: $!";
1208 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1211 #---------- tag format handling ----------
1213 sub access_cfg_tagformats () {
1214 split /\,/, access_cfg('dgit-tag-format');
1217 sub need_tagformat ($$) {
1218 my ($fmt, $why) = @_;
1219 fail "need to use tag format $fmt ($why) but also need".
1220 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1221 " - no way to proceed"
1222 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1223 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1226 sub select_tagformat () {
1228 return if $tagformatfn && !$tagformat_want;
1229 die 'bug' if $tagformatfn && $tagformat_want;
1230 # ... $tagformat_want assigned after previous select_tagformat
1232 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1233 printdebug "select_tagformat supported @supported\n";
1235 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1236 printdebug "select_tagformat specified @$tagformat_want\n";
1238 my ($fmt,$why,$override) = @$tagformat_want;
1240 fail "target distro supports tag formats @supported".
1241 " but have to use $fmt ($why)"
1243 or grep { $_ eq $fmt } @supported;
1245 $tagformat_want = undef;
1247 $tagformatfn = ${*::}{"debiantag_$fmt"};
1249 fail "trying to use unknown tag format \`$fmt' ($why) !"
1250 unless $tagformatfn;
1253 #---------- archive query entrypoints and rest of program ----------
1255 sub canonicalise_suite () {
1256 return if defined $csuite;
1257 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1258 $csuite = archive_query('canonicalise_suite');
1259 if ($isuite ne $csuite) {
1260 progress "canonical suite name for $isuite is $csuite";
1264 sub get_archive_dsc () {
1265 canonicalise_suite();
1266 my @vsns = archive_query('archive_query');
1267 foreach my $vinfo (@vsns) {
1268 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1269 $dscurl = access_cfg('mirror').$subpath;
1270 $dscdata = url_get($dscurl);
1272 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1277 $digester->add($dscdata);
1278 my $got = $digester->hexdigest();
1280 fail "$dscurl has hash $got but".
1281 " archive told us to expect $digest";
1283 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1284 printdebug Dumper($dscdata) if $debuglevel>1;
1285 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1286 printdebug Dumper($dsc) if $debuglevel>1;
1287 my $fmt = getfield $dsc, 'Format';
1288 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1289 $dsc_checked = !!$digester;
1290 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1294 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1297 sub check_for_git ();
1298 sub check_for_git () {
1300 my $how = access_cfg('git-check');
1301 if ($how eq 'ssh-cmd') {
1303 (access_cfg_ssh, access_gituserhost(),
1304 access_runeinfo("git-check $package").
1305 " set -e; cd ".access_cfg('git-path').";".
1306 " if test -d $package.git; then echo 1; else echo 0; fi");
1307 my $r= cmdoutput @cmd;
1308 if (defined $r and $r =~ m/^divert (\w+)$/) {
1310 my ($usedistro,) = access_distros();
1311 # NB that if we are pushing, $usedistro will be $distro/push
1312 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1313 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1314 progress "diverting to $divert (using config for $instead_distro)";
1315 return check_for_git();
1317 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1319 } elsif ($how eq 'url') {
1320 my $prefix = access_cfg('git-check-url','git-url');
1321 my $suffix = access_cfg('git-check-suffix','git-suffix',
1322 'RETURN-UNDEF') // '.git';
1323 my $url = "$prefix/$package$suffix";
1324 my @cmd = (qw(curl -sS -I), $url);
1325 my $result = cmdoutput @cmd;
1326 $result =~ s/^\S+ 200 .*\n\r?\n//;
1327 # curl -sS -I with https_proxy prints
1328 # HTTP/1.0 200 Connection established
1329 $result =~ m/^\S+ (404|200) /s or
1330 fail "unexpected results from git check query - ".
1331 Dumper($prefix, $result);
1333 if ($code eq '404') {
1335 } elsif ($code eq '200') {
1340 } elsif ($how eq 'true') {
1342 } elsif ($how eq 'false') {
1345 badcfg "unknown git-check \`$how'";
1349 sub create_remote_git_repo () {
1350 my $how = access_cfg('git-create');
1351 if ($how eq 'ssh-cmd') {
1353 (access_cfg_ssh, access_gituserhost(),
1354 access_runeinfo("git-create $package").
1355 "set -e; cd ".access_cfg('git-path').";".
1356 " cp -a _template $package.git");
1357 } elsif ($how eq 'true') {
1360 badcfg "unknown git-create \`$how'";
1364 our ($dsc_hash,$lastpush_mergeinput);
1366 our $ud = '.git/dgit/unpack';
1376 sub mktree_in_ud_here () {
1377 runcmd qw(git init -q);
1378 runcmd qw(git config gc.auto 0);
1379 rmtree('.git/objects');
1380 symlink '../../../../objects','.git/objects' or die $!;
1383 sub git_write_tree () {
1384 my $tree = cmdoutput @git, qw(write-tree);
1385 $tree =~ m/^\w+$/ or die "$tree ?";
1389 sub remove_stray_gits () {
1390 my @gitscmd = qw(find -name .git -prune -print0);
1391 debugcmd "|",@gitscmd;
1392 open GITS, "-|", @gitscmd or die $!;
1397 print STDERR "$us: warning: removing from source package: ",
1398 (messagequote $_), "\n";
1402 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1405 sub mktree_in_ud_from_only_subdir (;$) {
1408 # changes into the subdir
1410 die "expected one subdir but found @dirs ?" unless @dirs==1;
1411 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1415 remove_stray_gits();
1416 mktree_in_ud_here();
1418 my ($format, $fopts) = get_source_format();
1419 if (madformat($format)) {
1424 runcmd @git, qw(add -Af);
1425 my $tree=git_write_tree();
1426 return ($tree,$dir);
1429 our @files_csum_info_fields =
1430 (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1431 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1432 ['Files', 'Digest::MD5', 'new()']);
1434 sub dsc_files_info () {
1435 foreach my $csumi (@files_csum_info_fields) {
1436 my ($fname, $module, $method) = @$csumi;
1437 my $field = $dsc->{$fname};
1438 next unless defined $field;
1439 eval "use $module; 1;" or die $@;
1441 foreach (split /\n/, $field) {
1443 m/^(\w+) (\d+) (\S+)$/ or
1444 fail "could not parse .dsc $fname line \`$_'";
1445 my $digester = eval "$module"."->$method;" or die $@;
1450 Digester => $digester,
1455 fail "missing any supported Checksums-* or Files field in ".
1456 $dsc->get_option('name');
1460 map { $_->{Filename} } dsc_files_info();
1463 sub files_compare_inputs (@) {
1468 my $showinputs = sub {
1469 return join "; ", map { $_->get_option('name') } @$inputs;
1472 foreach my $in (@$inputs) {
1474 my $in_name = $in->get_option('name');
1476 printdebug "files_compare_inputs $in_name\n";
1478 foreach my $csumi (@files_csum_info_fields) {
1479 my ($fname) = @$csumi;
1480 printdebug "files_compare_inputs $in_name $fname\n";
1482 my $field = $in->{$fname};
1483 next unless defined $field;
1486 foreach (split /\n/, $field) {
1489 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1490 fail "could not parse $in_name $fname line \`$_'";
1492 printdebug "files_compare_inputs $in_name $fname $f\n";
1496 my $re = \ $record{$f}{$fname};
1498 $fchecked{$f}{$in_name} = 1;
1500 fail "hash or size of $f varies in $fname fields".
1501 " (between: ".$showinputs->().")";
1506 @files = sort @files;
1507 $expected_files //= \@files;
1508 "@$expected_files" eq "@files" or
1509 fail "file list in $in_name varies between hash fields!";
1512 fail "$in_name has no files list field(s)";
1514 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1517 grep { keys %$_ == @$inputs-1 } values %fchecked
1518 or fail "no file appears in all file lists".
1519 " (looked in: ".$showinputs->().")";
1522 sub is_orig_file_in_dsc ($$) {
1523 my ($f, $dsc_files_info) = @_;
1524 return 0 if @$dsc_files_info <= 1;
1525 # One file means no origs, and the filename doesn't have a "what
1526 # part of dsc" component. (Consider versions ending `.orig'.)
1527 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1531 sub is_orig_file_of_vsn ($$) {
1532 my ($f, $upstreamvsn) = @_;
1533 my $base = srcfn $upstreamvsn, '';
1534 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1538 sub make_commit ($) {
1540 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1543 sub make_commit_text ($) {
1546 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1548 print Dumper($text) if $debuglevel > 1;
1549 my $child = open2($out, $in, @cmd) or die $!;
1552 print $in $text or die $!;
1553 close $in or die $!;
1555 $h =~ m/^\w+$/ or die;
1557 printdebug "=> $h\n";
1560 waitpid $child, 0 == $child or die "$child $!";
1561 $? and failedcmd @cmd;
1565 sub clogp_authline ($) {
1567 my $author = getfield $clogp, 'Maintainer';
1568 $author =~ s#,.*##ms;
1569 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1570 my $authline = "$author $date";
1571 $authline =~ m/$git_authline_re/o or
1572 fail "unexpected commit author line format \`$authline'".
1573 " (was generated from changelog Maintainer field)";
1574 return ($1,$2,$3) if wantarray;
1578 sub vendor_patches_distro ($$) {
1579 my ($checkdistro, $what) = @_;
1580 return unless defined $checkdistro;
1582 my $series = "debian/patches/\L$checkdistro\E.series";
1583 printdebug "checking for vendor-specific $series ($what)\n";
1585 if (!open SERIES, "<", $series) {
1586 die "$series $!" unless $!==ENOENT;
1595 Unfortunately, this source package uses a feature of dpkg-source where
1596 the same source package unpacks to different source code on different
1597 distros. dgit cannot safely operate on such packages on affected
1598 distros, because the meaning of source packages is not stable.
1600 Please ask the distro/maintainer to remove the distro-specific series
1601 files and use a different technique (if necessary, uploading actually
1602 different packages, if different distros are supposed to have
1606 fail "Found active distro-specific series file for".
1607 " $checkdistro ($what): $series, cannot continue";
1609 die "$series $!" if SERIES->error;
1613 sub check_for_vendor_patches () {
1614 # This dpkg-source feature doesn't seem to be documented anywhere!
1615 # But it can be found in the changelog (reformatted):
1617 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1618 # Author: Raphael Hertzog <hertzog@debian.org>
1619 # Date: Sun Oct 3 09:36:48 2010 +0200
1621 # dpkg-source: correctly create .pc/.quilt_series with alternate
1624 # If you have debian/patches/ubuntu.series and you were
1625 # unpacking the source package on ubuntu, quilt was still
1626 # directed to debian/patches/series instead of
1627 # debian/patches/ubuntu.series.
1629 # debian/changelog | 3 +++
1630 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1631 # 2 files changed, 6 insertions(+), 1 deletion(-)
1634 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1635 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1636 "Dpkg::Vendor \`current vendor'");
1637 vendor_patches_distro(access_basedistro(),
1638 "distro being accessed");
1641 sub generate_commits_from_dsc () {
1642 # See big comment in fetch_from_archive, below.
1643 # See also README.dsc-import.
1647 my @dfi = dsc_files_info();
1648 foreach my $fi (@dfi) {
1649 my $f = $fi->{Filename};
1650 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1652 link_ltarget "../../../$f", $f
1656 complete_file_from_dsc('.', $fi)
1659 if (is_orig_file_in_dsc($f, \@dfi)) {
1660 link $f, "../../../../$f"
1666 # We unpack and record the orig tarballs first, so that we only
1667 # need disk space for one private copy of the unpacked source.
1668 # But we can't make them into commits until we have the metadata
1669 # from the debian/changelog, so we record the tree objects now and
1670 # make them into commits later.
1672 my $upstreamv = $dsc->{version};
1673 $upstreamv =~ s/-[^-]+$//;
1674 my $orig_f_base = srcfn $upstreamv, '';
1676 foreach my $fi (@dfi) {
1677 # We actually import, and record as a commit, every tarball
1678 # (unless there is only one file, in which case there seems
1681 my $f = $fi->{Filename};
1682 printdebug "import considering $f ";
1683 (printdebug "only one dfi\n"), next if @dfi == 1;
1684 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1685 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1689 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1691 printdebug "Y ", (join ' ', map { $_//"(none)" }
1692 $compr_ext, $orig_f_part
1695 my $input = new IO::File $f, '<' or die "$f $!";
1699 if (defined $compr_ext) {
1701 Dpkg::Compression::compression_guess_from_filename $f;
1702 fail "Dpkg::Compression cannot handle file $f in source package"
1703 if defined $compr_ext && !defined $cname;
1705 new Dpkg::Compression::Process compression => $cname;
1706 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1707 my $compr_fh = new IO::Handle;
1708 my $compr_pid = open $compr_fh, "-|" // die $!;
1710 open STDIN, "<&", $input or die $!;
1712 die "dgit (child): exec $compr_cmd[0]: $!\n";
1717 rmtree "../unpack-tar";
1718 mkdir "../unpack-tar" or die $!;
1719 my @tarcmd = qw(tar -x -f -
1720 --no-same-owner --no-same-permissions
1721 --no-acls --no-xattrs --no-selinux);
1722 my $tar_pid = fork // die $!;
1724 chdir "../unpack-tar" or die $!;
1725 open STDIN, "<&", $input or die $!;
1727 die "dgit (child): exec $tarcmd[0]: $!";
1729 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1730 !$? or failedcmd @tarcmd;
1733 (@compr_cmd ? failedcmd @compr_cmd
1735 # finally, we have the results in "tarball", but maybe
1736 # with the wrong permissions
1738 runcmd qw(chmod -R +rwX ../unpack-tar);
1739 changedir "../unpack-tar";
1740 my ($tree) = mktree_in_ud_from_only_subdir(1);
1741 changedir "../../unpack";
1742 rmtree "../unpack-tar";
1744 my $ent = [ $f, $tree ];
1746 Orig => !!$orig_f_part,
1747 Sort => (!$orig_f_part ? 2 :
1748 $orig_f_part =~ m/-/g ? 1 :
1756 # put any without "_" first (spec is not clear whether files
1757 # are always in the usual order). Tarballs without "_" are
1758 # the main orig or the debian tarball.
1759 $a->{Sort} <=> $b->{Sort} or
1763 my $any_orig = grep { $_->{Orig} } @tartrees;
1765 my $dscfn = "$package.dsc";
1767 my $treeimporthow = 'package';
1769 open D, ">", $dscfn or die "$dscfn: $!";
1770 print D $dscdata or die "$dscfn: $!";
1771 close D or die "$dscfn: $!";
1772 my @cmd = qw(dpkg-source);
1773 push @cmd, '--no-check' if $dsc_checked;
1774 if (madformat $dsc->{format}) {
1775 push @cmd, '--skip-patches';
1776 $treeimporthow = 'unpatched';
1778 push @cmd, qw(-x --), $dscfn;
1781 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1782 if (madformat $dsc->{format}) {
1783 check_for_vendor_patches();
1787 if (madformat $dsc->{format}) {
1788 my @pcmd = qw(dpkg-source --before-build .);
1789 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1791 runcmd @git, qw(add -Af);
1792 $dappliedtree = git_write_tree();
1795 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1796 debugcmd "|",@clogcmd;
1797 open CLOGS, "-|", @clogcmd or die $!;
1802 printdebug "import clog search...\n";
1805 my $stanzatext = do { local $/=""; <CLOGS>; };
1806 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1807 last if !defined $stanzatext;
1809 my $desc = "package changelog, entry no.$.";
1810 open my $stanzafh, "<", \$stanzatext or die;
1811 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1812 $clogp //= $thisstanza;
1814 printdebug "import clog $thisstanza->{version} $desc...\n";
1816 last if !$any_orig; # we don't need $r1clogp
1818 # We look for the first (most recent) changelog entry whose
1819 # version number is lower than the upstream version of this
1820 # package. Then the last (least recent) previous changelog
1821 # entry is treated as the one which introduced this upstream
1822 # version and used for the synthetic commits for the upstream
1825 # One might think that a more sophisticated algorithm would be
1826 # necessary. But: we do not want to scan the whole changelog
1827 # file. Stopping when we see an earlier version, which
1828 # necessarily then is an earlier upstream version, is the only
1829 # realistic way to do that. Then, either the earliest
1830 # changelog entry we have seen so far is indeed the earliest
1831 # upload of this upstream version; or there are only changelog
1832 # entries relating to later upstream versions (which is not
1833 # possible unless the changelog and .dsc disagree about the
1834 # version). Then it remains to choose between the physically
1835 # last entry in the file, and the one with the lowest version
1836 # number. If these are not the same, we guess that the
1837 # versions were created in a non-monotic order rather than
1838 # that the changelog entries have been misordered.
1840 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1842 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1843 $r1clogp = $thisstanza;
1845 printdebug "import clog $r1clogp->{version} becomes r1\n";
1847 die $! if CLOGS->error;
1848 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
1850 $clogp or fail "package changelog has no entries!";
1852 my $authline = clogp_authline $clogp;
1853 my $changes = getfield $clogp, 'Changes';
1854 my $cversion = getfield $clogp, 'Version';
1857 $r1clogp //= $clogp; # maybe there's only one entry;
1858 my $r1authline = clogp_authline $r1clogp;
1859 # Strictly, r1authline might now be wrong if it's going to be
1860 # unused because !$any_orig. Whatever.
1862 printdebug "import tartrees authline $authline\n";
1863 printdebug "import tartrees r1authline $r1authline\n";
1865 foreach my $tt (@tartrees) {
1866 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1868 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1871 committer $r1authline
1875 [dgit import orig $tt->{F}]
1883 [dgit import tarball $package $cversion $tt->{F}]
1888 printdebug "import main commit\n";
1890 open C, ">../commit.tmp" or die $!;
1891 print C <<END or die $!;
1894 print C <<END or die $! foreach @tartrees;
1897 print C <<END or die $!;
1903 [dgit import $treeimporthow $package $cversion]
1907 my $rawimport_hash = make_commit qw(../commit.tmp);
1909 if (madformat $dsc->{format}) {
1910 printdebug "import apply patches...\n";
1912 # regularise the state of the working tree so that
1913 # the checkout of $rawimport_hash works nicely.
1914 my $dappliedcommit = make_commit_text(<<END);
1921 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1923 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1925 # We need the answers to be reproducible
1926 my @authline = clogp_authline($clogp);
1927 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1928 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1929 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1930 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1931 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1932 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1935 runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
1939 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
1943 my $gapplied = git_rev_parse('HEAD');
1944 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1945 $gappliedtree eq $dappliedtree or
1947 gbp-pq import and dpkg-source disagree!
1948 gbp-pq import gave commit $gapplied
1949 gbp-pq import gave tree $gappliedtree
1950 dpkg-source --before-build gave tree $dappliedtree
1952 $rawimport_hash = $gapplied;
1955 progress "synthesised git commit from .dsc $cversion";
1957 my $rawimport_mergeinput = {
1958 Commit => $rawimport_hash,
1959 Info => "Import of source package",
1961 my @output = ($rawimport_mergeinput);
1963 if ($lastpush_mergeinput) {
1964 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1965 my $oversion = getfield $oldclogp, 'Version';
1967 version_compare($oversion, $cversion);
1969 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1970 { Message => <<END, ReverseParents => 1 });
1971 Record $package ($cversion) in archive suite $csuite
1973 } elsif ($vcmp > 0) {
1974 print STDERR <<END or die $!;
1976 Version actually in archive: $cversion (older)
1977 Last version pushed with dgit: $oversion (newer or same)
1980 @output = $lastpush_mergeinput;
1982 # Same version. Use what's in the server git branch,
1983 # discarding our own import. (This could happen if the
1984 # server automatically imports all packages into git.)
1985 @output = $lastpush_mergeinput;
1988 changedir '../../../..';
1993 sub complete_file_from_dsc ($$) {
1994 our ($dstdir, $fi) = @_;
1995 # Ensures that we have, in $dir, the file $fi, with the correct
1996 # contents. (Downloading it from alongside $dscurl if necessary.)
1998 my $f = $fi->{Filename};
1999 my $tf = "$dstdir/$f";
2002 if (stat_exists $tf) {
2003 progress "using existing $f";
2006 $furl =~ s{/[^/]+$}{};
2008 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2009 die "$f ?" if $f =~ m#/#;
2010 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
2011 return 0 if !act_local();
2015 open F, "<", "$tf" or die "$tf: $!";
2016 $fi->{Digester}->reset();
2017 $fi->{Digester}->addfile(*F);
2018 F->error and die $!;
2019 my $got = $fi->{Digester}->hexdigest();
2020 $got eq $fi->{Hash} or
2021 fail "file $f has hash $got but .dsc".
2022 " demands hash $fi->{Hash} ".
2023 ($downloaded ? "(got wrong file from archive!)"
2024 : "(perhaps you should delete this file?)");
2029 sub ensure_we_have_orig () {
2030 my @dfi = dsc_files_info();
2031 foreach my $fi (@dfi) {
2032 my $f = $fi->{Filename};
2033 next unless is_orig_file_in_dsc($f, \@dfi);
2034 complete_file_from_dsc('..', $fi)
2039 sub git_fetch_us () {
2040 # Want to fetch only what we are going to use, unless
2041 # deliberately-not-ff, in which case we must fetch everything.
2043 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2045 (quiltmode_splitbrain
2046 ? (map { $_->('*',access_basedistro) }
2047 \&debiantag_new, \&debiantag_maintview)
2048 : debiantags('*',access_basedistro));
2049 push @specs, server_branch($csuite);
2050 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2052 # This is rather miserable:
2053 # When git fetch --prune is passed a fetchspec ending with a *,
2054 # it does a plausible thing. If there is no * then:
2055 # - it matches subpaths too, even if the supplied refspec
2056 # starts refs, and behaves completely madly if the source
2057 # has refs/refs/something. (See, for example, Debian #NNNN.)
2058 # - if there is no matching remote ref, it bombs out the whole
2060 # We want to fetch a fixed ref, and we don't know in advance
2061 # if it exists, so this is not suitable.
2063 # Our workaround is to use git ls-remote. git ls-remote has its
2064 # own qairks. Notably, it has the absurd multi-tail-matching
2065 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2066 # refs/refs/foo etc.
2068 # Also, we want an idempotent snapshot, but we have to make two
2069 # calls to the remote: one to git ls-remote and to git fetch. The
2070 # solution is use git ls-remote to obtain a target state, and
2071 # git fetch to try to generate it. If we don't manage to generate
2072 # the target state, we try again.
2074 my $specre = join '|', map {
2080 printdebug "git_fetch_us specre=$specre\n";
2081 my $wanted_rref = sub {
2083 return m/^(?:$specre)$/o;
2086 my $fetch_iteration = 0;
2089 if (++$fetch_iteration > 10) {
2090 fail "too many iterations trying to get sane fetch!";
2093 my @look = map { "refs/$_" } @specs;
2094 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2098 open GITLS, "-|", @lcmd or die $!;
2100 printdebug "=> ", $_;
2101 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2102 my ($objid,$rrefname) = ($1,$2);
2103 if (!$wanted_rref->($rrefname)) {
2105 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2109 $wantr{$rrefname} = $objid;
2112 close GITLS or failedcmd @lcmd;
2114 # OK, now %want is exactly what we want for refs in @specs
2116 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2117 "+refs/$_:".lrfetchrefs."/$_";
2120 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2121 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2124 %lrfetchrefs_f = ();
2127 git_for_each_ref(lrfetchrefs, sub {
2128 my ($objid,$objtype,$lrefname,$reftail) = @_;
2129 $lrfetchrefs_f{$lrefname} = $objid;
2130 $objgot{$objid} = 1;
2133 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2134 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2135 if (!exists $wantr{$rrefname}) {
2136 if ($wanted_rref->($rrefname)) {
2138 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2142 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2145 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2146 delete $lrfetchrefs_f{$lrefname};
2150 foreach my $rrefname (sort keys %wantr) {
2151 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2152 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2153 my $want = $wantr{$rrefname};
2154 next if $got eq $want;
2155 if (!defined $objgot{$want}) {
2157 warning: git ls-remote suggests we want $lrefname
2158 warning: and it should refer to $want
2159 warning: but git fetch didn't fetch that object to any relevant ref.
2160 warning: This may be due to a race with someone updating the server.
2161 warning: Will try again...
2163 next FETCH_ITERATION;
2166 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2168 runcmd_ordryrun_local @git, qw(update-ref -m),
2169 "dgit fetch git fetch fixup", $lrefname, $want;
2170 $lrfetchrefs_f{$lrefname} = $want;
2174 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2175 Dumper(\%lrfetchrefs_f);
2178 my @tagpats = debiantags('*',access_basedistro);
2180 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2181 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2182 printdebug "currently $fullrefname=$objid\n";
2183 $here{$fullrefname} = $objid;
2185 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2186 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2187 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2188 printdebug "offered $lref=$objid\n";
2189 if (!defined $here{$lref}) {
2190 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2191 runcmd_ordryrun_local @upd;
2192 lrfetchref_used $fullrefname;
2193 } elsif ($here{$lref} eq $objid) {
2194 lrfetchref_used $fullrefname;
2197 "Not updateting $lref from $here{$lref} to $objid.\n";
2202 sub mergeinfo_getclogp ($) {
2203 # Ensures thit $mi->{Clogp} exists and returns it
2205 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2208 sub mergeinfo_version ($) {
2209 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2212 sub fetch_from_archive () {
2213 ensure_setup_existing_tree();
2215 # Ensures that lrref() is what is actually in the archive, one way
2216 # or another, according to us - ie this client's
2217 # appropritaely-updated archive view. Also returns the commit id.
2218 # If there is nothing in the archive, leaves lrref alone and
2219 # returns undef. git_fetch_us must have already been called.
2223 foreach my $field (@ourdscfield) {
2224 $dsc_hash = $dsc->{$field};
2225 last if defined $dsc_hash;
2227 if (defined $dsc_hash) {
2228 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2230 progress "last upload to archive specified git hash";
2232 progress "last upload to archive has NO git hash";
2235 progress "no version available from the archive";
2238 # If the archive's .dsc has a Dgit field, there are three
2239 # relevant git commitids we need to choose between and/or merge
2241 # 1. $dsc_hash: the Dgit field from the archive
2242 # 2. $lastpush_hash: the suite branch on the dgit git server
2243 # 3. $lastfetch_hash: our local tracking brach for the suite
2245 # These may all be distinct and need not be in any fast forward
2248 # If the dsc was pushed to this suite, then the server suite
2249 # branch will have been updated; but it might have been pushed to
2250 # a different suite and copied by the archive. Conversely a more
2251 # recent version may have been pushed with dgit but not appeared
2252 # in the archive (yet).
2254 # $lastfetch_hash may be awkward because archive imports
2255 # (particularly, imports of Dgit-less .dscs) are performed only as
2256 # needed on individual clients, so different clients may perform a
2257 # different subset of them - and these imports are only made
2258 # public during push. So $lastfetch_hash may represent a set of
2259 # imports different to a subsequent upload by a different dgit
2262 # Our approach is as follows:
2264 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2265 # descendant of $dsc_hash, then it was pushed by a dgit user who
2266 # had based their work on $dsc_hash, so we should prefer it.
2267 # Otherwise, $dsc_hash was installed into this suite in the
2268 # archive other than by a dgit push, and (necessarily) after the
2269 # last dgit push into that suite (since a dgit push would have
2270 # been descended from the dgit server git branch); thus, in that
2271 # case, we prefer the archive's version (and produce a
2272 # pseudo-merge to overwrite the dgit server git branch).
2274 # (If there is no Dgit field in the archive's .dsc then
2275 # generate_commit_from_dsc uses the version numbers to decide
2276 # whether the suite branch or the archive is newer. If the suite
2277 # branch is newer it ignores the archive's .dsc; otherwise it
2278 # generates an import of the .dsc, and produces a pseudo-merge to
2279 # overwrite the suite branch with the archive contents.)
2281 # The outcome of that part of the algorithm is the `public view',
2282 # and is same for all dgit clients: it does not depend on any
2283 # unpublished history in the local tracking branch.
2285 # As between the public view and the local tracking branch: The
2286 # local tracking branch is only updated by dgit fetch, and
2287 # whenever dgit fetch runs it includes the public view in the
2288 # local tracking branch. Therefore if the public view is not
2289 # descended from the local tracking branch, the local tracking
2290 # branch must contain history which was imported from the archive
2291 # but never pushed; and, its tip is now out of date. So, we make
2292 # a pseudo-merge to overwrite the old imports and stitch the old
2295 # Finally: we do not necessarily reify the public view (as
2296 # described above). This is so that we do not end up stacking two
2297 # pseudo-merges. So what we actually do is figure out the inputs
2298 # to any public view pseudo-merge and put them in @mergeinputs.
2301 # $mergeinputs[]{Commit}
2302 # $mergeinputs[]{Info}
2303 # $mergeinputs[0] is the one whose tree we use
2304 # @mergeinputs is in the order we use in the actual commit)
2307 # $mergeinputs[]{Message} is a commit message to use
2308 # $mergeinputs[]{ReverseParents} if def specifies that parent
2309 # list should be in opposite order
2310 # Such an entry has no Commit or Info. It applies only when found
2311 # in the last entry. (This ugliness is to support making
2312 # identical imports to previous dgit versions.)
2314 my $lastpush_hash = git_get_ref(lrfetchref());
2315 printdebug "previous reference hash=$lastpush_hash\n";
2316 $lastpush_mergeinput = $lastpush_hash && {
2317 Commit => $lastpush_hash,
2318 Info => "dgit suite branch on dgit git server",
2321 my $lastfetch_hash = git_get_ref(lrref());
2322 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2323 my $lastfetch_mergeinput = $lastfetch_hash && {
2324 Commit => $lastfetch_hash,
2325 Info => "dgit client's archive history view",
2328 my $dsc_mergeinput = $dsc_hash && {
2329 Commit => $dsc_hash,
2330 Info => "Dgit field in .dsc from archive",
2334 my $del_lrfetchrefs = sub {
2337 printdebug "del_lrfetchrefs...\n";
2338 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2339 my $objid = $lrfetchrefs_d{$fullrefname};
2340 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2342 $gur ||= new IO::Handle;
2343 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2345 printf $gur "delete %s %s\n", $fullrefname, $objid;
2348 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2352 if (defined $dsc_hash) {
2353 fail "missing remote git history even though dsc has hash -".
2354 " could not find ref ".rref()." at ".access_giturl()
2355 unless $lastpush_hash;
2356 ensure_we_have_orig();
2357 if ($dsc_hash eq $lastpush_hash) {
2358 @mergeinputs = $dsc_mergeinput
2359 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2360 print STDERR <<END or die $!;
2362 Git commit in archive is behind the last version allegedly pushed/uploaded.
2363 Commit referred to by archive: $dsc_hash
2364 Last version pushed with dgit: $lastpush_hash
2367 @mergeinputs = ($lastpush_mergeinput);
2369 # Archive has .dsc which is not a descendant of the last dgit
2370 # push. This can happen if the archive moves .dscs about.
2371 # Just follow its lead.
2372 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2373 progress "archive .dsc names newer git commit";
2374 @mergeinputs = ($dsc_mergeinput);
2376 progress "archive .dsc names other git commit, fixing up";
2377 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2381 @mergeinputs = generate_commits_from_dsc();
2382 # We have just done an import. Now, our import algorithm might
2383 # have been improved. But even so we do not want to generate
2384 # a new different import of the same package. So if the
2385 # version numbers are the same, just use our existing version.
2386 # If the version numbers are different, the archive has changed
2387 # (perhaps, rewound).
2388 if ($lastfetch_mergeinput &&
2389 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2390 (mergeinfo_version $mergeinputs[0]) )) {
2391 @mergeinputs = ($lastfetch_mergeinput);
2393 } elsif ($lastpush_hash) {
2394 # only in git, not in the archive yet
2395 @mergeinputs = ($lastpush_mergeinput);
2396 print STDERR <<END or die $!;
2398 Package not found in the archive, but has allegedly been pushed using dgit.
2402 printdebug "nothing found!\n";
2403 if (defined $skew_warning_vsn) {
2404 print STDERR <<END or die $!;
2406 Warning: relevant archive skew detected.
2407 Archive allegedly contains $skew_warning_vsn
2408 But we were not able to obtain any version from the archive or git.
2412 unshift @end, $del_lrfetchrefs;
2416 if ($lastfetch_hash &&
2418 my $h = $_->{Commit};
2419 $h and is_fast_fwd($lastfetch_hash, $h);
2420 # If true, one of the existing parents of this commit
2421 # is a descendant of the $lastfetch_hash, so we'll
2422 # be ff from that automatically.
2426 push @mergeinputs, $lastfetch_mergeinput;
2429 printdebug "fetch mergeinfos:\n";
2430 foreach my $mi (@mergeinputs) {
2432 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2434 printdebug sprintf " ReverseParents=%d Message=%s",
2435 $mi->{ReverseParents}, $mi->{Message};
2439 my $compat_info= pop @mergeinputs
2440 if $mergeinputs[$#mergeinputs]{Message};
2442 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2445 if (@mergeinputs > 1) {
2447 my $tree_commit = $mergeinputs[0]{Commit};
2449 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2450 $tree =~ m/\n\n/; $tree = $`;
2451 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2454 # We use the changelog author of the package in question the
2455 # author of this pseudo-merge. This is (roughly) correct if
2456 # this commit is simply representing aa non-dgit upload.
2457 # (Roughly because it does not record sponsorship - but we
2458 # don't have sponsorship info because that's in the .changes,
2459 # which isn't in the archivw.)
2461 # But, it might be that we are representing archive history
2462 # updates (including in-archive copies). These are not really
2463 # the responsibility of the person who created the .dsc, but
2464 # there is no-one whose name we should better use. (The
2465 # author of the .dsc-named commit is clearly worse.)
2467 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2468 my $author = clogp_authline $useclogp;
2469 my $cversion = getfield $useclogp, 'Version';
2471 my $mcf = ".git/dgit/mergecommit";
2472 open MC, ">", $mcf or die "$mcf $!";
2473 print MC <<END or die $!;
2477 my @parents = grep { $_->{Commit} } @mergeinputs;
2478 @parents = reverse @parents if $compat_info->{ReverseParents};
2479 print MC <<END or die $! foreach @parents;
2483 print MC <<END or die $!;
2489 if (defined $compat_info->{Message}) {
2490 print MC $compat_info->{Message} or die $!;
2492 print MC <<END or die $!;
2493 Record $package ($cversion) in archive suite $csuite
2497 my $message_add_info = sub {
2499 my $mversion = mergeinfo_version $mi;
2500 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2504 $message_add_info->($mergeinputs[0]);
2505 print MC <<END or die $!;
2506 should be treated as descended from
2508 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2512 $hash = make_commit $mcf;
2514 $hash = $mergeinputs[0]{Commit};
2516 printdebug "fetch hash=$hash\n";
2519 my ($lasth, $what) = @_;
2520 return unless $lasth;
2521 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2524 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2525 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2527 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2528 'DGIT_ARCHIVE', $hash;
2529 cmdoutput @git, qw(log -n2), $hash;
2530 # ... gives git a chance to complain if our commit is malformed
2532 if (defined $skew_warning_vsn) {
2534 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2535 my $gotclogp = commit_getclogp($hash);
2536 my $got_vsn = getfield $gotclogp, 'Version';
2537 printdebug "SKEW CHECK GOT $got_vsn\n";
2538 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2539 print STDERR <<END or die $!;
2541 Warning: archive skew detected. Using the available version:
2542 Archive allegedly contains $skew_warning_vsn
2543 We were able to obtain only $got_vsn
2549 if ($lastfetch_hash ne $hash) {
2550 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2554 dryrun_report @upd_cmd;
2558 lrfetchref_used lrfetchref();
2560 unshift @end, $del_lrfetchrefs;
2564 sub set_local_git_config ($$) {
2566 runcmd @git, qw(config), $k, $v;
2569 sub setup_mergechangelogs (;$) {
2571 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2573 my $driver = 'dpkg-mergechangelogs';
2574 my $cb = "merge.$driver";
2575 my $attrs = '.git/info/attributes';
2576 ensuredir '.git/info';
2578 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2579 if (!open ATTRS, "<", $attrs) {
2580 $!==ENOENT or die "$attrs: $!";
2584 next if m{^debian/changelog\s};
2585 print NATTRS $_, "\n" or die $!;
2587 ATTRS->error and die $!;
2590 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2593 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2594 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2596 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2599 sub setup_useremail (;$) {
2601 return unless $always || access_cfg_bool(1, 'setup-useremail');
2604 my ($k, $envvar) = @_;
2605 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2606 return unless defined $v;
2607 set_local_git_config "user.$k", $v;
2610 $setup->('email', 'DEBEMAIL');
2611 $setup->('name', 'DEBFULLNAME');
2614 sub ensure_setup_existing_tree () {
2615 my $k = "remote.$remotename.skipdefaultupdate";
2616 my $c = git_get_config $k;
2617 return if defined $c;
2618 set_local_git_config $k, 'true';
2621 sub setup_new_tree () {
2622 setup_mergechangelogs();
2628 canonicalise_suite();
2629 badusage "dry run makes no sense with clone" unless act_local();
2630 my $hasgit = check_for_git();
2631 mkdir $dstdir or fail "create \`$dstdir': $!";
2633 runcmd @git, qw(init -q);
2634 my $giturl = access_giturl(1);
2635 if (defined $giturl) {
2636 open H, "> .git/HEAD" or die $!;
2637 print H "ref: ".lref()."\n" or die $!;
2639 runcmd @git, qw(remote add), 'origin', $giturl;
2642 progress "fetching existing git history";
2644 runcmd_ordryrun_local @git, qw(fetch origin);
2646 progress "starting new git history";
2648 fetch_from_archive() or no_such_package;
2649 my $vcsgiturl = $dsc->{'Vcs-Git'};
2650 if (length $vcsgiturl) {
2651 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2652 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2655 runcmd @git, qw(reset --hard), lrref();
2656 printdone "ready for work in $dstdir";
2660 if (check_for_git()) {
2663 fetch_from_archive() or no_such_package();
2664 printdone "fetched into ".lrref();
2669 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2671 printdone "fetched to ".lrref()." and merged into HEAD";
2674 sub check_not_dirty () {
2675 foreach my $f (qw(local-options local-patch-header)) {
2676 if (stat_exists "debian/source/$f") {
2677 fail "git tree contains debian/source/$f";
2681 return if $ignoredirty;
2683 my @cmd = (@git, qw(diff --quiet HEAD));
2685 $!=0; $?=-1; system @cmd;
2688 fail "working tree is dirty (does not match HEAD)";
2694 sub commit_admin ($) {
2697 runcmd_ordryrun_local @git, qw(commit -m), $m;
2700 sub commit_quilty_patch () {
2701 my $output = cmdoutput @git, qw(status --porcelain);
2703 foreach my $l (split /\n/, $output) {
2704 next unless $l =~ m/\S/;
2705 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2709 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2711 progress "nothing quilty to commit, ok.";
2714 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2715 runcmd_ordryrun_local @git, qw(add -f), @adds;
2717 Commit Debian 3.0 (quilt) metadata
2719 [dgit ($our_version) quilt-fixup]
2723 sub get_source_format () {
2725 if (open F, "debian/source/options") {
2729 s/\s+$//; # ignore missing final newline
2731 my ($k, $v) = ($`, $'); #');
2732 $v =~ s/^"(.*)"$/$1/;
2738 F->error and die $!;
2741 die $! unless $!==&ENOENT;
2744 if (!open F, "debian/source/format") {
2745 die $! unless $!==&ENOENT;
2749 F->error and die $!;
2751 return ($_, \%options);
2754 sub madformat_wantfixup ($) {
2756 return 0 unless $format eq '3.0 (quilt)';
2757 our $quilt_mode_warned;
2758 if ($quilt_mode eq 'nocheck') {
2759 progress "Not doing any fixup of \`$format' due to".
2760 " ----no-quilt-fixup or --quilt=nocheck"
2761 unless $quilt_mode_warned++;
2764 progress "Format \`$format', need to check/update patch stack"
2765 unless $quilt_mode_warned++;
2769 # An "infopair" is a tuple [ $thing, $what ]
2770 # (often $thing is a commit hash; $what is a description)
2772 sub infopair_cond_equal ($$) {
2774 $x->[0] eq $y->[0] or fail <<END;
2775 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2779 sub infopair_lrf_tag_lookup ($$) {
2780 my ($tagnames, $what) = @_;
2781 # $tagname may be an array ref
2782 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2783 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2784 foreach my $tagname (@tagnames) {
2785 my $lrefname = lrfetchrefs."/tags/$tagname";
2786 my $tagobj = $lrfetchrefs_f{$lrefname};
2787 next unless defined $tagobj;
2788 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2789 return [ git_rev_parse($tagobj), $what ];
2791 fail @tagnames==1 ? <<END : <<END;
2792 Wanted tag $what (@tagnames) on dgit server, but not found
2794 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2798 sub infopair_cond_ff ($$) {
2799 my ($anc,$desc) = @_;
2800 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2801 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2805 sub pseudomerge_version_check ($$) {
2806 my ($clogp, $archive_hash) = @_;
2808 my $arch_clogp = commit_getclogp $archive_hash;
2809 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2810 'version currently in archive' ];
2811 if (defined $overwrite_version) {
2812 if (length $overwrite_version) {
2813 infopair_cond_equal([ $overwrite_version,
2814 '--overwrite= version' ],
2817 my $v = $i_arch_v->[0];
2818 progress "Checking package changelog for archive version $v ...";
2820 my @xa = ("-f$v", "-t$v");
2821 my $vclogp = parsechangelog @xa;
2822 my $cv = [ (getfield $vclogp, 'Version'),
2823 "Version field from dpkg-parsechangelog @xa" ];
2824 infopair_cond_equal($i_arch_v, $cv);
2827 $@ =~ s/^dgit: //gm;
2829 "Perhaps debian/changelog does not mention $v ?";
2834 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2838 sub pseudomerge_make_commit ($$$$ $$) {
2839 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2840 $msg_cmd, $msg_msg) = @_;
2841 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2843 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2844 my $authline = clogp_authline $clogp;
2848 !defined $overwrite_version ? ""
2849 : !length $overwrite_version ? " --overwrite"
2850 : " --overwrite=".$overwrite_version;
2853 my $pmf = ".git/dgit/pseudomerge";
2854 open MC, ">", $pmf or die "$pmf $!";
2855 print MC <<END or die $!;
2858 parent $archive_hash
2868 return make_commit($pmf);
2871 sub splitbrain_pseudomerge ($$$$) {
2872 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2873 # => $merged_dgitview
2874 printdebug "splitbrain_pseudomerge...\n";
2876 # We: debian/PREVIOUS HEAD($maintview)
2877 # expect: o ----------------- o
2880 # a/d/PREVIOUS $dgitview
2883 # we do: `------------------ o
2887 printdebug "splitbrain_pseudomerge...\n";
2889 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2891 return $dgitview unless defined $archive_hash;
2893 if (!defined $overwrite_version) {
2894 progress "Checking that HEAD inciudes all changes in archive...";
2897 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2899 if (defined $overwrite_version) {
2901 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2902 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2903 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2904 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2905 my $i_archive = [ $archive_hash, "current archive contents" ];
2907 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2909 infopair_cond_equal($i_dgit, $i_archive);
2910 infopair_cond_ff($i_dep14, $i_dgit);
2911 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2915 $us: check failed (maybe --overwrite is needed, consult documentation)
2920 my $r = pseudomerge_make_commit
2921 $clogp, $dgitview, $archive_hash, $i_arch_v,
2922 "dgit --quilt=$quilt_mode",
2923 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2924 Declare fast forward from $i_arch_v->[0]
2926 Make fast forward from $i_arch_v->[0]
2929 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2933 sub plain_overwrite_pseudomerge ($$$) {
2934 my ($clogp, $head, $archive_hash) = @_;
2936 printdebug "plain_overwrite_pseudomerge...";
2938 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2940 return $head if is_fast_fwd $archive_hash, $head;
2942 my $m = "Declare fast forward from $i_arch_v->[0]";
2944 my $r = pseudomerge_make_commit
2945 $clogp, $head, $archive_hash, $i_arch_v,
2948 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2950 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2954 sub push_parse_changelog ($) {
2957 my $clogp = Dpkg::Control::Hash->new();
2958 $clogp->load($clogpfn) or die;
2960 $package = getfield $clogp, 'Source';
2961 my $cversion = getfield $clogp, 'Version';
2962 my $tag = debiantag($cversion, access_basedistro);
2963 runcmd @git, qw(check-ref-format), $tag;
2965 my $dscfn = dscfn($cversion);
2967 return ($clogp, $cversion, $dscfn);
2970 sub push_parse_dsc ($$$) {
2971 my ($dscfn,$dscfnwhat, $cversion) = @_;
2972 $dsc = parsecontrol($dscfn,$dscfnwhat);
2973 my $dversion = getfield $dsc, 'Version';
2974 my $dscpackage = getfield $dsc, 'Source';
2975 ($dscpackage eq $package && $dversion eq $cversion) or
2976 fail "$dscfn is for $dscpackage $dversion".
2977 " but debian/changelog is for $package $cversion";
2980 sub push_tagwants ($$$$) {
2981 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2984 TagFn => \&debiantag,
2989 if (defined $maintviewhead) {
2991 TagFn => \&debiantag_maintview,
2992 Objid => $maintviewhead,
2993 TfSuffix => '-maintview',
2997 foreach my $tw (@tagwants) {
2998 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2999 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3001 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3005 sub push_mktags ($$ $$ $) {
3007 $changesfile,$changesfilewhat,
3010 die unless $tagwants->[0]{View} eq 'dgit';
3012 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3013 $dsc->save("$dscfn.tmp") or die $!;
3015 my $changes = parsecontrol($changesfile,$changesfilewhat);
3016 foreach my $field (qw(Source Distribution Version)) {
3017 $changes->{$field} eq $clogp->{$field} or
3018 fail "changes field $field \`$changes->{$field}'".
3019 " does not match changelog \`$clogp->{$field}'";
3022 my $cversion = getfield $clogp, 'Version';
3023 my $clogsuite = getfield $clogp, 'Distribution';
3025 # We make the git tag by hand because (a) that makes it easier
3026 # to control the "tagger" (b) we can do remote signing
3027 my $authline = clogp_authline $clogp;
3028 my $delibs = join(" ", "",@deliberatelies);
3029 my $declaredistro = access_basedistro();
3033 my $tfn = $tw->{Tfn};
3034 my $head = $tw->{Objid};
3035 my $tag = $tw->{Tag};
3037 open TO, '>', $tfn->('.tmp') or die $!;
3038 print TO <<END or die $!;
3045 if ($tw->{View} eq 'dgit') {
3046 print TO <<END or die $!;
3047 $package release $cversion for $clogsuite ($csuite) [dgit]
3048 [dgit distro=$declaredistro$delibs]
3050 foreach my $ref (sort keys %previously) {
3051 print TO <<END or die $!;
3052 [dgit previously:$ref=$previously{$ref}]
3055 } elsif ($tw->{View} eq 'maint') {
3056 print TO <<END or die $!;
3057 $package release $cversion for $clogsuite ($csuite)
3058 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3061 die Dumper($tw)."?";
3066 my $tagobjfn = $tfn->('.tmp');
3068 if (!defined $keyid) {
3069 $keyid = access_cfg('keyid','RETURN-UNDEF');
3071 if (!defined $keyid) {
3072 $keyid = getfield $clogp, 'Maintainer';
3074 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3075 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3076 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3077 push @sign_cmd, $tfn->('.tmp');
3078 runcmd_ordryrun @sign_cmd;
3080 $tagobjfn = $tfn->('.signed.tmp');
3081 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3082 $tfn->('.tmp'), $tfn->('.tmp.asc');
3088 my @r = map { $mktag->($_); } @$tagwants;
3092 sub sign_changes ($) {
3093 my ($changesfile) = @_;
3095 my @debsign_cmd = @debsign;
3096 push @debsign_cmd, "-k$keyid" if defined $keyid;
3097 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3098 push @debsign_cmd, $changesfile;
3099 runcmd_ordryrun @debsign_cmd;
3104 printdebug "actually entering push\n";
3106 supplementary_message(<<'END');
3107 Push failed, while checking state of the archive.
3108 You can retry the push, after fixing the problem, if you like.
3110 if (check_for_git()) {
3113 my $archive_hash = fetch_from_archive();
3114 if (!$archive_hash) {
3116 fail "package appears to be new in this suite;".
3117 " if this is intentional, use --new";
3120 supplementary_message(<<'END');
3121 Push failed, while preparing your push.
3122 You can retry the push, after fixing the problem, if you like.
3125 need_tagformat 'new', "quilt mode $quilt_mode"
3126 if quiltmode_splitbrain;
3130 access_giturl(); # check that success is vaguely likely
3133 my $clogpfn = ".git/dgit/changelog.822.tmp";
3134 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3136 responder_send_file('parsed-changelog', $clogpfn);
3138 my ($clogp, $cversion, $dscfn) =
3139 push_parse_changelog("$clogpfn");
3141 my $dscpath = "$buildproductsdir/$dscfn";
3142 stat_exists $dscpath or
3143 fail "looked for .dsc $dscfn, but $!;".
3144 " maybe you forgot to build";
3146 responder_send_file('dsc', $dscpath);
3148 push_parse_dsc($dscpath, $dscfn, $cversion);
3150 my $format = getfield $dsc, 'Format';
3151 printdebug "format $format\n";
3153 my $actualhead = git_rev_parse('HEAD');
3154 my $dgithead = $actualhead;
3155 my $maintviewhead = undef;
3157 if (madformat_wantfixup($format)) {
3158 # user might have not used dgit build, so maybe do this now:
3159 if (quiltmode_splitbrain()) {
3160 my $upstreamversion = $clogp->{Version};
3161 $upstreamversion =~ s/-[^-]*$//;
3163 quilt_make_fake_dsc($upstreamversion);
3165 ($dgithead, $cachekey) =
3166 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3168 "--quilt=$quilt_mode but no cached dgit view:
3169 perhaps tree changed since dgit build[-source] ?";
3171 $dgithead = splitbrain_pseudomerge($clogp,
3172 $actualhead, $dgithead,
3174 $maintviewhead = $actualhead;
3175 changedir '../../../..';
3176 prep_ud(); # so _only_subdir() works, below
3178 commit_quilty_patch();
3182 if (defined $overwrite_version && !defined $maintviewhead) {
3183 $dgithead = plain_overwrite_pseudomerge($clogp,
3191 if ($archive_hash) {
3192 if (is_fast_fwd($archive_hash, $dgithead)) {
3194 } elsif (deliberately_not_fast_forward) {
3197 fail "dgit push: HEAD is not a descendant".
3198 " of the archive's version.\n".
3199 "To overwrite the archive's contents,".
3200 " pass --overwrite[=VERSION].\n".
3201 "To rewind history, if permitted by the archive,".
3202 " use --deliberately-not-fast-forward.";
3207 progress "checking that $dscfn corresponds to HEAD";
3208 runcmd qw(dpkg-source -x --),
3209 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3210 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3211 check_for_vendor_patches() if madformat($dsc->{format});
3212 changedir '../../../..';
3213 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3214 debugcmd "+",@diffcmd;
3216 my $r = system @diffcmd;
3219 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3221 HEAD specifies a different tree to $dscfn:
3223 Perhaps you forgot to build. Or perhaps there is a problem with your
3224 source tree (see dgit(7) for some hints). To see a full diff, run
3231 if (!$changesfile) {
3232 my $pat = changespat $cversion;
3233 my @cs = glob "$buildproductsdir/$pat";
3234 fail "failed to find unique changes file".
3235 " (looked for $pat in $buildproductsdir);".
3236 " perhaps you need to use dgit -C"
3238 ($changesfile) = @cs;
3240 $changesfile = "$buildproductsdir/$changesfile";
3243 # Check that changes and .dsc agree enough
3244 $changesfile =~ m{[^/]*$};
3245 files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3247 # Checks complete, we're going to try and go ahead:
3249 responder_send_file('changes',$changesfile);
3250 responder_send_command("param head $dgithead");
3251 responder_send_command("param csuite $csuite");
3252 responder_send_command("param tagformat $tagformat");
3253 if (defined $maintviewhead) {
3254 die unless ($protovsn//4) >= 4;
3255 responder_send_command("param maint-view $maintviewhead");
3258 if (deliberately_not_fast_forward) {
3259 git_for_each_ref(lrfetchrefs, sub {
3260 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3261 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3262 responder_send_command("previously $rrefname=$objid");
3263 $previously{$rrefname} = $objid;
3267 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3271 supplementary_message(<<'END');
3272 Push failed, while signing the tag.
3273 You can retry the push, after fixing the problem, if you like.
3275 # If we manage to sign but fail to record it anywhere, it's fine.
3276 if ($we_are_responder) {
3277 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3278 responder_receive_files('signed-tag', @tagobjfns);
3280 @tagobjfns = push_mktags($clogp,$dscpath,
3281 $changesfile,$changesfile,
3284 supplementary_message(<<'END');
3285 Push failed, *after* signing the tag.
3286 If you want to try again, you should use a new version number.
3289 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3291 foreach my $tw (@tagwants) {
3292 my $tag = $tw->{Tag};
3293 my $tagobjfn = $tw->{TagObjFn};
3295 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3296 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3297 runcmd_ordryrun_local
3298 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3301 supplementary_message(<<'END');
3302 Push failed, while updating the remote git repository - see messages above.
3303 If you want to try again, you should use a new version number.
3305 if (!check_for_git()) {
3306 create_remote_git_repo();
3309 my @pushrefs = $forceflag.$dgithead.":".rrref();
3310 foreach my $tw (@tagwants) {
3311 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3314 runcmd_ordryrun @git,
3315 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3316 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3318 supplementary_message(<<'END');
3319 Push failed, after updating the remote git repository.
3320 If you want to try again, you must use a new version number.
3322 if ($we_are_responder) {
3323 my $dryrunsuffix = act_local() ? "" : ".tmp";
3324 responder_receive_files('signed-dsc-changes',
3325 "$dscpath$dryrunsuffix",
3326 "$changesfile$dryrunsuffix");
3329 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3331 progress "[new .dsc left in $dscpath.tmp]";
3333 sign_changes $changesfile;
3336 supplementary_message(<<END);
3337 Push failed, while uploading package(s) to the archive server.
3338 You can retry the upload of exactly these same files with dput of:
3340 If that .changes file is broken, you will need to use a new version
3341 number for your next attempt at the upload.
3343 my $host = access_cfg('upload-host','RETURN-UNDEF');
3344 my @hostarg = defined($host) ? ($host,) : ();
3345 runcmd_ordryrun @dput, @hostarg, $changesfile;
3346 printdone "pushed and uploaded $cversion";
3348 supplementary_message('');
3349 responder_send_command("complete");
3356 badusage "-p is not allowed with clone; specify as argument instead"
3357 if defined $package;
3360 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3361 ($package,$isuite) = @ARGV;
3362 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3363 ($package,$dstdir) = @ARGV;
3364 } elsif (@ARGV==3) {
3365 ($package,$isuite,$dstdir) = @ARGV;
3367 badusage "incorrect arguments to dgit clone";
3369 $dstdir ||= "$package";
3371 if (stat_exists $dstdir) {
3372 fail "$dstdir already exists";
3376 if ($rmonerror && !$dryrun_level) {
3377 $cwd_remove= getcwd();
3379 return unless defined $cwd_remove;
3380 if (!chdir "$cwd_remove") {
3381 return if $!==&ENOENT;
3382 die "chdir $cwd_remove: $!";
3385 rmtree($dstdir) or die "remove $dstdir: $!\n";
3386 } elsif (grep { $! == $_ }
3387 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3389 print STDERR "check whether to remove $dstdir: $!\n";
3395 $cwd_remove = undef;
3398 sub branchsuite () {
3399 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3400 if ($branch =~ m#$lbranch_re#o) {
3407 sub fetchpullargs () {
3409 if (!defined $package) {
3410 my $sourcep = parsecontrol('debian/control','debian/control');
3411 $package = getfield $sourcep, 'Source';
3414 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3416 my $clogp = parsechangelog();
3417 $isuite = getfield $clogp, 'Distribution';
3419 canonicalise_suite();
3420 progress "fetching from suite $csuite";
3421 } elsif (@ARGV==1) {
3423 canonicalise_suite();
3425 badusage "incorrect arguments to dgit fetch or dgit pull";
3444 badusage "-p is not allowed with dgit push" if defined $package;
3446 my $clogp = parsechangelog();
3447 $package = getfield $clogp, 'Source';
3450 } elsif (@ARGV==1) {
3451 ($specsuite) = (@ARGV);
3453 badusage "incorrect arguments to dgit push";
3455 $isuite = getfield $clogp, 'Distribution';
3457 local ($package) = $existing_package; # this is a hack
3458 canonicalise_suite();
3460 canonicalise_suite();
3462 if (defined $specsuite &&
3463 $specsuite ne $isuite &&
3464 $specsuite ne $csuite) {
3465 fail "dgit push: changelog specifies $isuite ($csuite)".
3466 " but command line specifies $specsuite";
3471 #---------- remote commands' implementation ----------
3473 sub cmd_remote_push_build_host {
3474 my ($nrargs) = shift @ARGV;
3475 my (@rargs) = @ARGV[0..$nrargs-1];
3476 @ARGV = @ARGV[$nrargs..$#ARGV];
3478 my ($dir,$vsnwant) = @rargs;
3479 # vsnwant is a comma-separated list; we report which we have
3480 # chosen in our ready response (so other end can tell if they
3483 $we_are_responder = 1;
3484 $us .= " (build host)";
3488 open PI, "<&STDIN" or die $!;
3489 open STDIN, "/dev/null" or die $!;
3490 open PO, ">&STDOUT" or die $!;
3492 open STDOUT, ">&STDERR" or die $!;
3496 ($protovsn) = grep {
3497 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3498 } @rpushprotovsn_support;
3500 fail "build host has dgit rpush protocol versions ".
3501 (join ",", @rpushprotovsn_support).
3502 " but invocation host has $vsnwant"
3503 unless defined $protovsn;
3505 responder_send_command("dgit-remote-push-ready $protovsn");
3506 rpush_handle_protovsn_bothends();
3511 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3512 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3513 # a good error message)
3515 sub rpush_handle_protovsn_bothends () {
3516 if ($protovsn < 4) {
3517 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3526 my $report = i_child_report();
3527 if (defined $report) {
3528 printdebug "($report)\n";
3529 } elsif ($i_child_pid) {
3530 printdebug "(killing build host child $i_child_pid)\n";
3531 kill 15, $i_child_pid;
3533 if (defined $i_tmp && !defined $initiator_tempdir) {
3535 eval { rmtree $i_tmp; };
3539 END { i_cleanup(); }
3542 my ($base,$selector,@args) = @_;
3543 $selector =~ s/\-/_/g;
3544 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3551 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3559 push @rargs, join ",", @rpushprotovsn_support;
3562 push @rdgit, @ropts;
3563 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3565 my @cmd = (@ssh, $host, shellquote @rdgit);
3568 if (defined $initiator_tempdir) {
3569 rmtree $initiator_tempdir;
3570 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3571 $i_tmp = $initiator_tempdir;
3575 $i_child_pid = open2(\*RO, \*RI, @cmd);
3577 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3578 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3579 $supplementary_message = '' unless $protovsn >= 3;
3581 fail "rpush negotiated protocol version $protovsn".
3582 " which does not support quilt mode $quilt_mode"
3583 if quiltmode_splitbrain;
3585 rpush_handle_protovsn_bothends();
3587 my ($icmd,$iargs) = initiator_expect {
3588 m/^(\S+)(?: (.*))?$/;
3591 i_method "i_resp", $icmd, $iargs;
3595 sub i_resp_progress ($) {
3597 my $msg = protocol_read_bytes \*RO, $rhs;
3601 sub i_resp_supplementary_message ($) {
3603 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3606 sub i_resp_complete {
3607 my $pid = $i_child_pid;
3608 $i_child_pid = undef; # prevents killing some other process with same pid
3609 printdebug "waiting for build host child $pid...\n";
3610 my $got = waitpid $pid, 0;
3611 die $! unless $got == $pid;
3612 die "build host child failed $?" if $?;
3615 printdebug "all done\n";
3619 sub i_resp_file ($) {
3621 my $localname = i_method "i_localname", $keyword;
3622 my $localpath = "$i_tmp/$localname";
3623 stat_exists $localpath and
3624 badproto \*RO, "file $keyword ($localpath) twice";
3625 protocol_receive_file \*RO, $localpath;
3626 i_method "i_file", $keyword;
3631 sub i_resp_param ($) {
3632 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3636 sub i_resp_previously ($) {
3637 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3638 or badproto \*RO, "bad previously spec";
3639 my $r = system qw(git check-ref-format), $1;
3640 die "bad previously ref spec ($r)" if $r;
3641 $previously{$1} = $2;
3646 sub i_resp_want ($) {
3648 die "$keyword ?" if $i_wanted{$keyword}++;
3649 my @localpaths = i_method "i_want", $keyword;
3650 printdebug "[[ $keyword @localpaths\n";
3651 foreach my $localpath (@localpaths) {
3652 protocol_send_file \*RI, $localpath;
3654 print RI "files-end\n" or die $!;
3657 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3659 sub i_localname_parsed_changelog {
3660 return "remote-changelog.822";
3662 sub i_file_parsed_changelog {
3663 ($i_clogp, $i_version, $i_dscfn) =
3664 push_parse_changelog "$i_tmp/remote-changelog.822";
3665 die if $i_dscfn =~ m#/|^\W#;
3668 sub i_localname_dsc {
3669 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3674 sub i_localname_changes {
3675 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3676 $i_changesfn = $i_dscfn;
3677 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3678 return $i_changesfn;
3680 sub i_file_changes { }
3682 sub i_want_signed_tag {
3683 printdebug Dumper(\%i_param, $i_dscfn);
3684 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3685 && defined $i_param{'csuite'}
3686 or badproto \*RO, "premature desire for signed-tag";
3687 my $head = $i_param{'head'};
3688 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3690 my $maintview = $i_param{'maint-view'};
3691 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3694 if ($protovsn >= 4) {
3695 my $p = $i_param{'tagformat'} // '<undef>';
3697 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3700 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3702 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3704 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3707 push_mktags $i_clogp, $i_dscfn,
3708 $i_changesfn, 'remote changes',
3712 sub i_want_signed_dsc_changes {
3713 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3714 sign_changes $i_changesfn;
3715 return ($i_dscfn, $i_changesfn);
3718 #---------- building etc. ----------
3724 #----- `3.0 (quilt)' handling -----
3726 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3728 sub quiltify_dpkg_commit ($$$;$) {
3729 my ($patchname,$author,$msg, $xinfo) = @_;
3733 my $descfn = ".git/dgit/quilt-description.tmp";
3734 open O, '>', $descfn or die "$descfn: $!";
3735 $msg =~ s/\n+/\n\n/;
3736 print O <<END or die $!;
3738 ${xinfo}Subject: $msg
3745 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3746 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3747 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3748 runcmd @dpkgsource, qw(--commit .), $patchname;