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' => 'old,new,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;
3752 sub quiltify_trees_differ ($$;$$$) {
3753 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3754 # returns true iff the two tree objects differ other than in debian/
3755 # with $finegrained,
3756 # returns bitmask 01 - differ in upstream files except .gitignore
3757 # 02 - differ in .gitignore
3758 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3759 # is set for each modified .gitignore filename $fn
3760 # if $unrepres is defined, array ref to which is appeneded
3761 # a list of unrepresentable changes (removals of upstream files
3764 my @cmd = (@git, qw(diff-tree -z));
3765 push @cmd, qw(--name-only) unless $unrepres;
3766 push @cmd, qw(-r) if $finegrained || $unrepres;
3768 my $diffs= cmdoutput @cmd;
3771 foreach my $f (split /\0/, $diffs) {
3772 if ($unrepres && !@lmodes) {
3773 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3776 my ($oldmode,$newmode) = @lmodes;
3779 next if $f =~ m#^debian(?:/.*)?$#s;
3783 die "deleted\n" unless $newmode =~ m/[^0]/;
3784 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3785 if ($oldmode =~ m/[^0]/) {
3786 die "mode changed\n" if $oldmode ne $newmode;
3788 die "non-default mode\n" unless $newmode =~ m/^100644$/;
3792 local $/="\n"; chomp $@;
3793 push @$unrepres, [ $f, $@ ];
3797 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3798 $r |= $isignore ? 02 : 01;
3799 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3801 printdebug "quiltify_trees_differ $x $y => $r\n";
3805 sub quiltify_tree_sentinelfiles ($) {
3806 # lists the `sentinel' files present in the tree
3808 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3809 qw(-- debian/rules debian/control);
3814 sub quiltify_splitbrain_needed () {
3815 if (!$split_brain) {
3816 progress "dgit view: changes are required...";
3817 runcmd @git, qw(checkout -q -b dgit-view);
3822 sub quiltify_splitbrain ($$$$$$) {
3823 my ($clogp, $unapplied, $headref, $diffbits,
3824 $editedignores, $cachekey) = @_;
3825 if ($quilt_mode !~ m/gbp|dpm/) {
3826 # treat .gitignore just like any other upstream file
3827 $diffbits = { %$diffbits };
3828 $_ = !!$_ foreach values %$diffbits;
3830 # We would like any commits we generate to be reproducible
3831 my @authline = clogp_authline($clogp);
3832 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3833 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3834 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3835 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3836 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3837 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3839 if ($quilt_mode =~ m/gbp|unapplied/ &&
3840 ($diffbits->{O2H} & 01)) {
3842 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3843 " but git tree differs from orig in upstream files.";
3844 if (!stat_exists "debian/patches") {
3846 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3850 if ($quilt_mode =~ m/dpm/ &&
3851 ($diffbits->{H2A} & 01)) {
3853 --quilt=$quilt_mode specified, implying patches-applied git tree
3854 but git tree differs from result of applying debian/patches to upstream
3857 if ($quilt_mode =~ m/gbp|unapplied/ &&
3858 ($diffbits->{O2A} & 01)) { # some patches
3859 quiltify_splitbrain_needed();
3860 progress "dgit view: creating patches-applied version using gbp pq";
3861 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3862 # gbp pq import creates a fresh branch; push back to dgit-view
3863 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3864 runcmd @git, qw(checkout -q dgit-view);
3866 if ($quilt_mode =~ m/gbp|dpm/ &&
3867 ($diffbits->{O2A} & 02)) {
3869 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3870 tool which does not create patches for changes to upstream
3871 .gitignores: but, such patches exist in debian/patches.
3874 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3875 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3876 quiltify_splitbrain_needed();
3877 progress "dgit view: creating patch to represent .gitignore changes";
3878 ensuredir "debian/patches";
3879 my $gipatch = "debian/patches/auto-gitignore";
3880 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3881 stat GIPATCH or die "$gipatch: $!";
3882 fail "$gipatch already exists; but want to create it".
3883 " to record .gitignore changes" if (stat _)[7];
3884 print GIPATCH <<END or die "$gipatch: $!";
3885 Subject: Update .gitignore from Debian packaging branch
3887 The Debian packaging git branch contains these updates to the upstream
3888 .gitignore file(s). This patch is autogenerated, to provide these
3889 updates to users of the official Debian archive view of the package.
3891 [dgit ($our_version) update-gitignore]
3894 close GIPATCH or die "$gipatch: $!";
3895 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3896 $unapplied, $headref, "--", sort keys %$editedignores;
3897 open SERIES, "+>>", "debian/patches/series" or die $!;
3898 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3900 defined read SERIES, $newline, 1 or die $!;
3901 print SERIES "\n" or die $! unless $newline eq "\n";
3902 print SERIES "auto-gitignore\n" or die $!;
3903 close SERIES or die $!;
3904 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3906 Commit patch to update .gitignore
3908 [dgit ($our_version) update-gitignore-quilt-fixup]
3912 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3914 changedir '../../../..';
3915 # When we no longer need to support squeeze, use --create-reflog
3917 ensuredir ".git/logs/refs/dgit-intern";
3918 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3921 my $oldcache = git_get_ref "refs/$splitbraincache";
3922 if ($oldcache eq $dgitview) {
3923 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
3924 # git update-ref doesn't always update, in this case. *sigh*
3925 my $dummy = make_commit_text <<END;
3928 author Dgit <dgit\@example.com> 1000000000 +0000
3929 committer Dgit <dgit\@example.com> 1000000000 +0000
3931 Dummy commit - do not use
3933 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
3934 "refs/$splitbraincache", $dummy;
3936 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3939 progress "dgit view: created (commit id $dgitview)";
3941 changedir '.git/dgit/unpack/work';
3944 sub quiltify ($$$$) {
3945 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3947 # Quilt patchification algorithm
3949 # We search backwards through the history of the main tree's HEAD
3950 # (T) looking for a start commit S whose tree object is identical
3951 # to to the patch tip tree (ie the tree corresponding to the
3952 # current dpkg-committed patch series). For these purposes
3953 # `identical' disregards anything in debian/ - this wrinkle is
3954 # necessary because dpkg-source treates debian/ specially.
3956 # We can only traverse edges where at most one of the ancestors'
3957 # trees differs (in changes outside in debian/). And we cannot
3958 # handle edges which change .pc/ or debian/patches. To avoid
3959 # going down a rathole we avoid traversing edges which introduce
3960 # debian/rules or debian/control. And we set a limit on the
3961 # number of edges we are willing to look at.
3963 # If we succeed, we walk forwards again. For each traversed edge
3964 # PC (with P parent, C child) (starting with P=S and ending with
3965 # C=T) to we do this:
3967 # - dpkg-source --commit with a patch name and message derived from C
3968 # After traversing PT, we git commit the changes which
3969 # should be contained within debian/patches.
3971 # The search for the path S..T is breadth-first. We maintain a
3972 # todo list containing search nodes. A search node identifies a
3973 # commit, and looks something like this:
3975 # Commit => $git_commit_id,
3976 # Child => $c, # or undef if P=T
3977 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3978 # Nontrivial => true iff $p..$c has relevant changes
3985 my %considered; # saves being exponential on some weird graphs
3987 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3990 my ($search,$whynot) = @_;
3991 printdebug " search NOT $search->{Commit} $whynot\n";
3992 $search->{Whynot} = $whynot;
3993 push @nots, $search;
3994 no warnings qw(exiting);
4003 my $c = shift @todo;
4004 next if $considered{$c->{Commit}}++;
4006 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4008 printdebug "quiltify investigate $c->{Commit}\n";
4011 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4012 printdebug " search finished hooray!\n";
4017 if ($quilt_mode eq 'nofix') {
4018 fail "quilt fixup required but quilt mode is \`nofix'\n".
4019 "HEAD commit $c->{Commit} differs from tree implied by ".
4020 " debian/patches (tree object $oldtiptree)";
4022 if ($quilt_mode eq 'smash') {
4023 printdebug " search quitting smash\n";
4027 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4028 $not->($c, "has $c_sentinels not $t_sentinels")
4029 if $c_sentinels ne $t_sentinels;
4031 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4032 $commitdata =~ m/\n\n/;
4034 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4035 @parents = map { { Commit => $_, Child => $c } } @parents;
4037 $not->($c, "root commit") if !@parents;
4039 foreach my $p (@parents) {
4040 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4042 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4043 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4045 foreach my $p (@parents) {
4046 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4048 my @cmd= (@git, qw(diff-tree -r --name-only),
4049 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4050 my $patchstackchange = cmdoutput @cmd;
4051 if (length $patchstackchange) {
4052 $patchstackchange =~ s/\n/,/g;
4053 $not->($p, "changed $patchstackchange");
4056 printdebug " search queue P=$p->{Commit} ",
4057 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4063 printdebug "quiltify want to smash\n";
4066 my $x = $_[0]{Commit};
4067 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4070 my $reportnot = sub {
4072 my $s = $abbrev->($notp);
4073 my $c = $notp->{Child};
4074 $s .= "..".$abbrev->($c) if $c;
4075 $s .= ": ".$notp->{Whynot};
4078 if ($quilt_mode eq 'linear') {
4079 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4080 foreach my $notp (@nots) {
4081 print STDERR "$us: ", $reportnot->($notp), "\n";
4083 print STDERR "$us: $_\n" foreach @$failsuggestion;
4084 fail "quilt fixup naive history linearisation failed.\n".
4085 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4086 } elsif ($quilt_mode eq 'smash') {
4087 } elsif ($quilt_mode eq 'auto') {
4088 progress "quilt fixup cannot be linear, smashing...";
4090 die "$quilt_mode ?";
4093 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4094 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4096 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4098 quiltify_dpkg_commit "auto-$version-$target-$time",
4099 (getfield $clogp, 'Maintainer'),
4100 "Automatically generated patch ($clogp->{Version})\n".
4101 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4105 progress "quiltify linearisation planning successful, executing...";
4107 for (my $p = $sref_S;
4108 my $c = $p->{Child};
4110 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4111 next unless $p->{Nontrivial};
4113 my $cc = $c->{Commit};
4115 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4116 $commitdata =~ m/\n\n/ or die "$c ?";
4119 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4122 my $commitdate = cmdoutput
4123 @git, qw(log -n1 --pretty=format:%aD), $cc;
4125 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4127 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4134 my $gbp_check_suitable = sub {
4139 die "contains unexpected slashes\n" if m{//} || m{/$};
4140 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4141 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4142 die "too long" if length > 200;
4144 return $_ unless $@;
4145 print STDERR "quiltifying commit $cc:".
4146 " ignoring/dropping Gbp-Pq $what: $@";
4150 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4152 (\S+) \s* \n //ixm) {
4153 $patchname = $gbp_check_suitable->($1, 'Name');
4155 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4157 (\S+) \s* \n //ixm) {
4158 $patchdir = $gbp_check_suitable->($1, 'Topic');
4163 if (!defined $patchname) {
4164 $patchname = $title;
4165 $patchname =~ s/[.:]$//;
4168 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4169 my $translitname = $converter->convert($patchname);
4170 die unless defined $translitname;
4171 $patchname = $translitname;
4174 "dgit: patch title transliteration error: $@"
4176 $patchname =~ y/ A-Z/-a-z/;
4177 $patchname =~ y/-a-z0-9_.+=~//cd;
4178 $patchname =~ s/^\W/x-$&/;
4179 $patchname = substr($patchname,0,40);
4181 if (!defined $patchdir) {
4184 if (length $patchdir) {
4185 $patchname = "$patchdir/$patchname";
4187 if ($patchname =~ m{^(.*)/}) {
4188 mkpath "debian/patches/$1";
4193 stat "debian/patches/$patchname$index";
4195 $!==ENOENT or die "$patchname$index $!";
4197 runcmd @git, qw(checkout -q), $cc;
4199 # We use the tip's changelog so that dpkg-source doesn't
4200 # produce complaining messages from dpkg-parsechangelog. None
4201 # of the information dpkg-source gets from the changelog is
4202 # actually relevant - it gets put into the original message
4203 # which dpkg-source provides our stunt editor, and then
4205 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4207 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4208 "Date: $commitdate\n".
4209 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4211 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4214 runcmd @git, qw(checkout -q master);
4217 sub build_maybe_quilt_fixup () {
4218 my ($format,$fopts) = get_source_format;
4219 return unless madformat_wantfixup $format;
4222 check_for_vendor_patches();
4224 if (quiltmode_splitbrain) {
4225 foreach my $needtf (qw(new maint)) {
4226 next if grep { $_ eq $needtf } access_cfg_tagformats;
4228 quilt mode $quilt_mode requires split view so server needs to support
4229 both "new" and "maint" tag formats, but config says it doesn't.
4234 my $clogp = parsechangelog();
4235 my $headref = git_rev_parse('HEAD');
4240 my $upstreamversion=$version;
4241 $upstreamversion =~ s/-[^-]*$//;
4243 if ($fopts->{'single-debian-patch'}) {
4244 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4246 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4249 die 'bug' if $split_brain && !$need_split_build_invocation;
4251 changedir '../../../..';
4252 runcmd_ordryrun_local
4253 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4256 sub quilt_fixup_mkwork ($) {
4259 mkdir "work" or die $!;
4261 mktree_in_ud_here();
4262 runcmd @git, qw(reset -q --hard), $headref;
4265 sub quilt_fixup_linkorigs ($$) {
4266 my ($upstreamversion, $fn) = @_;
4267 # calls $fn->($leafname);
4269 foreach my $f (<../../../../*>) { #/){
4270 my $b=$f; $b =~ s{.*/}{};
4272 local ($debuglevel) = $debuglevel-1;
4273 printdebug "QF linkorigs $b, $f ?\n";
4275 next unless is_orig_file_of_vsn $b, $upstreamversion;
4276 printdebug "QF linkorigs $b, $f Y\n";
4277 link_ltarget $f, $b or die "$b $!";
4282 sub quilt_fixup_delete_pc () {
4283 runcmd @git, qw(rm -rqf .pc);
4285 Commit removal of .pc (quilt series tracking data)
4287 [dgit ($our_version) upgrade quilt-remove-pc]
4291 sub quilt_fixup_singlepatch ($$$) {
4292 my ($clogp, $headref, $upstreamversion) = @_;
4294 progress "starting quiltify (single-debian-patch)";
4296 # dpkg-source --commit generates new patches even if
4297 # single-debian-patch is in debian/source/options. In order to
4298 # get it to generate debian/patches/debian-changes, it is
4299 # necessary to build the source package.
4301 quilt_fixup_linkorigs($upstreamversion, sub { });
4302 quilt_fixup_mkwork($headref);
4304 rmtree("debian/patches");
4306 runcmd @dpkgsource, qw(-b .);
4308 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4309 rename srcfn("$upstreamversion", "/debian/patches"),
4310 "work/debian/patches";
4313 commit_quilty_patch();
4316 sub quilt_make_fake_dsc ($) {
4317 my ($upstreamversion) = @_;
4319 my $fakeversion="$upstreamversion-~~DGITFAKE";
4321 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4322 print $fakedsc <<END or die $!;
4325 Version: $fakeversion
4329 my $dscaddfile=sub {
4332 my $md = new Digest::MD5;
4334 my $fh = new IO::File $b, '<' or die "$b $!";
4339 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4342 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4344 my @files=qw(debian/source/format debian/rules
4345 debian/control debian/changelog);
4346 foreach my $maybe (qw(debian/patches debian/source/options
4347 debian/tests/control)) {
4348 next unless stat_exists "../../../$maybe";
4349 push @files, $maybe;
4352 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4353 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4355 $dscaddfile->($debtar);
4356 close $fakedsc or die $!;
4359 sub quilt_check_splitbrain_cache ($$) {
4360 my ($headref, $upstreamversion) = @_;
4361 # Called only if we are in (potentially) split brain mode.
4363 # Computes the cache key and looks in the cache.
4364 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4366 my $splitbrain_cachekey;
4369 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4370 # we look in the reflog of dgit-intern/quilt-cache
4371 # we look for an entry whose message is the key for the cache lookup
4372 my @cachekey = (qw(dgit), $our_version);
4373 push @cachekey, $upstreamversion;
4374 push @cachekey, $quilt_mode;
4375 push @cachekey, $headref;
4377 push @cachekey, hashfile('fake.dsc');
4379 my $srcshash = Digest::SHA->new(256);
4380 my %sfs = ( %INC, '$0(dgit)' => $0 );
4381 foreach my $sfk (sort keys %sfs) {
4382 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4383 $srcshash->add($sfk," ");
4384 $srcshash->add(hashfile($sfs{$sfk}));
4385 $srcshash->add("\n");
4387 push @cachekey, $srcshash->hexdigest();
4388 $splitbrain_cachekey = "@cachekey";
4390 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4392 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4393 debugcmd "|(probably)",@cmd;
4394 my $child = open GC, "-|"; defined $child or die $!;
4396 chdir '../../..' or die $!;
4397 if (!stat ".git/logs/refs/$splitbraincache") {
4398 $! == ENOENT or die $!;
4399 printdebug ">(no reflog)\n";
4406 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4407 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4410 quilt_fixup_mkwork($headref);
4411 if ($cachehit ne $headref) {
4412 progress "dgit view: found cached (commit id $cachehit)";
4413 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4415 return ($cachehit, $splitbrain_cachekey);
4417 progress "dgit view: found cached, no changes required";
4418 return ($headref, $splitbrain_cachekey);
4420 die $! if GC->error;
4421 failedcmd unless close GC;
4423 printdebug "splitbrain cache miss\n";
4424 return (undef, $splitbrain_cachekey);
4427 sub quilt_fixup_multipatch ($$$) {
4428 my ($clogp, $headref, $upstreamversion) = @_;
4430 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4433 # - honour any existing .pc in case it has any strangeness
4434 # - determine the git commit corresponding to the tip of
4435 # the patch stack (if there is one)
4436 # - if there is such a git commit, convert each subsequent
4437 # git commit into a quilt patch with dpkg-source --commit
4438 # - otherwise convert all the differences in the tree into
4439 # a single git commit
4443 # Our git tree doesn't necessarily contain .pc. (Some versions of
4444 # dgit would include the .pc in the git tree.) If there isn't
4445 # one, we need to generate one by unpacking the patches that we
4448 # We first look for a .pc in the git tree. If there is one, we
4449 # will use it. (This is not the normal case.)
4451 # Otherwise need to regenerate .pc so that dpkg-source --commit
4452 # can work. We do this as follows:
4453 # 1. Collect all relevant .orig from parent directory
4454 # 2. Generate a debian.tar.gz out of
4455 # debian/{patches,rules,source/format,source/options}
4456 # 3. Generate a fake .dsc containing just these fields:
4457 # Format Source Version Files
4458 # 4. Extract the fake .dsc
4459 # Now the fake .dsc has a .pc directory.
4460 # (In fact we do this in every case, because in future we will
4461 # want to search for a good base commit for generating patches.)
4463 # Then we can actually do the dpkg-source --commit
4464 # 1. Make a new working tree with the same object
4465 # store as our main tree and check out the main
4467 # 2. Copy .pc from the fake's extraction, if necessary
4468 # 3. Run dpkg-source --commit
4469 # 4. If the result has changes to debian/, then
4470 # - git add them them
4471 # - git add .pc if we had a .pc in-tree
4473 # 5. If we had a .pc in-tree, delete it, and git commit
4474 # 6. Back in the main tree, fast forward to the new HEAD
4476 # Another situation we may have to cope with is gbp-style
4477 # patches-unapplied trees.
4479 # We would want to detect these, so we know to escape into
4480 # quilt_fixup_gbp. However, this is in general not possible.
4481 # Consider a package with a one patch which the dgit user reverts
4482 # (with git revert or the moral equivalent).
4484 # That is indistinguishable in contents from a patches-unapplied
4485 # tree. And looking at the history to distinguish them is not
4486 # useful because the user might have made a confusing-looking git
4487 # history structure (which ought to produce an error if dgit can't
4488 # cope, not a silent reintroduction of an unwanted patch).
4490 # So gbp users will have to pass an option. But we can usually
4491 # detect their failure to do so: if the tree is not a clean
4492 # patches-applied tree, quilt linearisation fails, but the tree
4493 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4494 # they want --quilt=unapplied.
4496 # To help detect this, when we are extracting the fake dsc, we
4497 # first extract it with --skip-patches, and then apply the patches
4498 # afterwards with dpkg-source --before-build. That lets us save a
4499 # tree object corresponding to .origs.
4501 my $splitbrain_cachekey;
4503 quilt_make_fake_dsc($upstreamversion);
4505 if (quiltmode_splitbrain()) {
4507 ($cachehit, $splitbrain_cachekey) =
4508 quilt_check_splitbrain_cache($headref, $upstreamversion);
4509 return if $cachehit;
4513 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4515 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4516 rename $fakexdir, "fake" or die "$fakexdir $!";
4520 remove_stray_gits();
4521 mktree_in_ud_here();
4525 runcmd @git, qw(add -Af .);
4526 my $unapplied=git_write_tree();
4527 printdebug "fake orig tree object $unapplied\n";
4531 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4533 if (system @bbcmd) {
4534 failedcmd @bbcmd if $? < 0;
4536 failed to apply your git tree's patch stack (from debian/patches/) to
4537 the corresponding upstream tarball(s). Your source tree and .orig
4538 are probably too inconsistent. dgit can only fix up certain kinds of
4539 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4545 quilt_fixup_mkwork($headref);
4548 if (stat_exists ".pc") {
4550 progress "Tree already contains .pc - will use it then delete it.";
4553 rename '../fake/.pc','.pc' or die $!;
4556 changedir '../fake';
4558 runcmd @git, qw(add -Af .);
4559 my $oldtiptree=git_write_tree();
4560 printdebug "fake o+d/p tree object $unapplied\n";
4561 changedir '../work';
4564 # We calculate some guesswork now about what kind of tree this might
4565 # be. This is mostly for error reporting.
4571 # O = orig, without patches applied
4572 # A = "applied", ie orig with H's debian/patches applied
4573 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4574 \%editedignores, \@unrepres),
4575 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4576 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4580 foreach my $b (qw(01 02)) {
4581 foreach my $v (qw(O2H O2A H2A)) {
4582 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4585 printdebug "differences \@dl @dl.\n";
4588 "$us: base trees orig=%.20s o+d/p=%.20s",
4589 $unapplied, $oldtiptree;
4591 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4592 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4593 $dl[0], $dl[1], $dl[3], $dl[4],
4597 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4600 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4605 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4606 push @failsuggestion, "This might be a patches-unapplied branch.";
4607 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4608 push @failsuggestion, "This might be a patches-applied branch.";
4610 push @failsuggestion, "Maybe you need to specify one of".
4611 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4613 if (quiltmode_splitbrain()) {
4614 quiltify_splitbrain($clogp, $unapplied, $headref,
4615 $diffbits, \%editedignores,
4616 $splitbrain_cachekey);
4620 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4621 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4623 if (!open P, '>>', ".pc/applied-patches") {
4624 $!==&ENOENT or die $!;
4629 commit_quilty_patch();
4631 if ($mustdeletepc) {
4632 quilt_fixup_delete_pc();
4636 sub quilt_fixup_editor () {
4637 my $descfn = $ENV{$fakeeditorenv};
4638 my $editing = $ARGV[$#ARGV];
4639 open I1, '<', $descfn or die "$descfn: $!";
4640 open I2, '<', $editing or die "$editing: $!";
4641 unlink $editing or die "$editing: $!";
4642 open O, '>', $editing or die "$editing: $!";
4643 while (<I1>) { print O or die $!; } I1->error and die $!;
4646 $copying ||= m/^\-\-\- /;
4647 next unless $copying;
4650 I2->error and die $!;
4655 sub maybe_apply_patches_dirtily () {
4656 return unless $quilt_mode =~ m/gbp|unapplied/;
4657 print STDERR <<END or die $!;
4659 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4660 dgit: Have to apply the patches - making the tree dirty.
4661 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4664 $patches_applied_dirtily = 01;
4665 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4666 runcmd qw(dpkg-source --before-build .);
4669 sub maybe_unapply_patches_again () {
4670 progress "dgit: Unapplying patches again to tidy up the tree."
4671 if $patches_applied_dirtily;
4672 runcmd qw(dpkg-source --after-build .)
4673 if $patches_applied_dirtily & 01;
4675 if $patches_applied_dirtily & 02;
4676 $patches_applied_dirtily = 0;
4679 #----- other building -----
4681 our $clean_using_builder;
4682 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4683 # clean the tree before building (perhaps invoked indirectly by
4684 # whatever we are using to run the build), rather than separately
4685 # and explicitly by us.
4688 return if $clean_using_builder;
4689 if ($cleanmode eq 'dpkg-source') {
4690 maybe_apply_patches_dirtily();
4691 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4692 } elsif ($cleanmode eq 'dpkg-source-d') {
4693 maybe_apply_patches_dirtily();
4694 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4695 } elsif ($cleanmode eq 'git') {
4696 runcmd_ordryrun_local @git, qw(clean -xdf);
4697 } elsif ($cleanmode eq 'git-ff') {
4698 runcmd_ordryrun_local @git, qw(clean -xdff);
4699 } elsif ($cleanmode eq 'check') {
4700 my $leftovers = cmdoutput @git, qw(clean -xdn);
4701 if (length $leftovers) {
4702 print STDERR $leftovers, "\n" or die $!;
4703 fail "tree contains uncommitted files and --clean=check specified";
4705 } elsif ($cleanmode eq 'none') {
4712 badusage "clean takes no additional arguments" if @ARGV;
4715 maybe_unapply_patches_again();
4720 badusage "-p is not allowed when building" if defined $package;
4723 my $clogp = parsechangelog();
4724 $isuite = getfield $clogp, 'Distribution';
4725 $package = getfield $clogp, 'Source';
4726 $version = getfield $clogp, 'Version';
4727 build_maybe_quilt_fixup();
4729 my $pat = changespat $version;
4730 foreach my $f (glob "$buildproductsdir/$pat") {
4732 unlink $f or fail "remove old changes file $f: $!";
4734 progress "would remove $f";
4740 sub changesopts_initial () {
4741 my @opts =@changesopts[1..$#changesopts];
4744 sub changesopts_version () {
4745 if (!defined $changes_since_version) {
4746 my @vsns = archive_query('archive_query');
4747 my @quirk = access_quirk();
4748 if ($quirk[0] eq 'backports') {
4749 local $isuite = $quirk[2];
4751 canonicalise_suite();
4752 push @vsns, archive_query('archive_query');
4755 @vsns = map { $_->[0] } @vsns;
4756 @vsns = sort { -version_compare($a, $b) } @vsns;
4757 $changes_since_version = $vsns[0];
4758 progress "changelog will contain changes since $vsns[0]";
4760 $changes_since_version = '_';
4761 progress "package seems new, not specifying -v<version>";
4764 if ($changes_since_version ne '_') {
4765 return ("-v$changes_since_version");
4771 sub changesopts () {
4772 return (changesopts_initial(), changesopts_version());
4775 sub massage_dbp_args ($;$) {
4776 my ($cmd,$xargs) = @_;
4779 # - if we're going to split the source build out so we can
4780 # do strange things to it, massage the arguments to dpkg-buildpackage
4781 # so that the main build doessn't build source (or add an argument
4782 # to stop it building source by default).
4784 # - add -nc to stop dpkg-source cleaning the source tree,
4785 # unless we're not doing a split build and want dpkg-source
4786 # as cleanmode, in which case we can do nothing
4789 # 0 - source will NOT need to be built separately by caller
4790 # +1 - source will need to be built separately by caller
4791 # +2 - source will need to be built separately by caller AND
4792 # dpkg-buildpackage should not in fact be run at all!
4793 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4794 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4795 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4796 $clean_using_builder = 1;
4799 # -nc has the side effect of specifying -b if nothing else specified
4800 # and some combinations of -S, -b, et al, are errors, rather than
4801 # later simply overriding earlie. So we need to:
4802 # - search the command line for these options
4803 # - pick the last one
4804 # - perhaps add our own as a default
4805 # - perhaps adjust it to the corresponding non-source-building version
4807 foreach my $l ($cmd, $xargs) {
4809 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4812 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4814 if ($need_split_build_invocation) {
4815 printdebug "massage split $dmode.\n";
4816 $r = $dmode =~ m/[S]/ ? +2 :
4817 $dmode =~ y/gGF/ABb/ ? +1 :
4818 $dmode =~ m/[ABb]/ ? 0 :
4821 printdebug "massage done $r $dmode.\n";
4823 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4828 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4829 my $wantsrc = massage_dbp_args \@dbp;
4836 push @dbp, changesopts_version();
4837 maybe_apply_patches_dirtily();
4838 runcmd_ordryrun_local @dbp;
4840 maybe_unapply_patches_again();
4841 printdone "build successful\n";
4845 $quilt_mode //= 'gbp';
4849 my @dbp = @dpkgbuildpackage;
4851 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4853 if (!length $gbp_build[0]) {
4854 if (length executable_on_path('git-buildpackage')) {
4855 $gbp_build[0] = qw(git-buildpackage);
4857 $gbp_build[0] = 'gbp buildpackage';
4860 my @cmd = opts_opt_multi_cmd @gbp_build;
4862 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4867 if (!$clean_using_builder) {
4868 push @cmd, '--git-cleaner=true';
4872 maybe_unapply_patches_again();
4874 push @cmd, changesopts();
4875 runcmd_ordryrun_local @cmd, @ARGV;
4877 printdone "build successful\n";
4879 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4882 my $our_cleanmode = $cleanmode;
4883 if ($need_split_build_invocation) {
4884 # Pretend that clean is being done some other way. This
4885 # forces us not to try to use dpkg-buildpackage to clean and
4886 # build source all in one go; and instead we run dpkg-source
4887 # (and build_prep() will do the clean since $clean_using_builder
4889 $our_cleanmode = 'ELSEWHERE';
4891 if ($our_cleanmode =~ m/^dpkg-source/) {
4892 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4893 $clean_using_builder = 1;
4896 $sourcechanges = changespat $version,'source';
4898 unlink "../$sourcechanges" or $!==ENOENT
4899 or fail "remove $sourcechanges: $!";
4901 $dscfn = dscfn($version);
4902 if ($our_cleanmode eq 'dpkg-source') {
4903 maybe_apply_patches_dirtily();
4904 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4906 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4907 maybe_apply_patches_dirtily();
4908 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4911 my @cmd = (@dpkgsource, qw(-b --));
4914 runcmd_ordryrun_local @cmd, "work";
4915 my @udfiles = <${package}_*>;
4916 changedir "../../..";
4917 foreach my $f (@udfiles) {
4918 printdebug "source copy, found $f\n";
4921 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4922 $f eq srcfn($version, $&));
4923 printdebug "source copy, found $f - renaming\n";
4924 rename "$ud/$f", "../$f" or $!==ENOENT
4925 or fail "put in place new source file ($f): $!";
4928 my $pwd = must_getcwd();
4929 my $leafdir = basename $pwd;
4931 runcmd_ordryrun_local @cmd, $leafdir;
4934 runcmd_ordryrun_local qw(sh -ec),
4935 'exec >$1; shift; exec "$@"','x',
4936 "../$sourcechanges",
4937 @dpkggenchanges, qw(-S), changesopts();
4941 sub cmd_build_source {
4942 badusage "build-source takes no additional arguments" if @ARGV;
4944 maybe_unapply_patches_again();
4945 printdone "source built, results in $dscfn and $sourcechanges";
4950 my $pat = changespat $version;
4952 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4953 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4955 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
4956 Suggest you delete @unwanted.
4960 my $wasdir = must_getcwd();
4963 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4964 stat_exists $sourcechanges
4965 or fail "$sourcechanges (in parent directory): $!";
4967 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4968 my @changesfiles = glob $pat;
4969 @changesfiles = sort {
4970 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4973 fail <<END if @changesfiles==1;
4974 only one changes file from sbuild (@changesfiles)
4975 perhaps you need to pass -A ? (sbuild's default is to build only
4976 arch-specific binaries; dgit 1.4 used to override that.)
4978 fail "wrong number of different changes files (@changesfiles)"
4979 unless @changesfiles==2;
4980 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4981 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4982 fail "$l found in binaries changes file $binchanges"
4985 runcmd_ordryrun_local @mergechanges, @changesfiles;
4986 my $multichanges = changespat $version,'multi';
4988 stat_exists $multichanges or fail "$multichanges: $!";
4989 foreach my $cf (glob $pat) {
4990 next if $cf eq $multichanges;
4991 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4995 maybe_unapply_patches_again();
4996 printdone "build successful, results in $multichanges\n" or die $!;
4999 sub cmd_quilt_fixup {
5000 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5001 my $clogp = parsechangelog();
5002 $version = getfield $clogp, 'Version';
5003 $package = getfield $clogp, 'Source';
5006 build_maybe_quilt_fixup();
5009 sub cmd_archive_api_query {
5010 badusage "need only 1 subpath argument" unless @ARGV==1;
5011 my ($subpath) = @ARGV;
5012 my @cmd = archive_api_query_cmd($subpath);
5014 exec @cmd or fail "exec curl: $!\n";
5017 sub cmd_clone_dgit_repos_server {
5018 badusage "need destination argument" unless @ARGV==1;
5019 my ($destdir) = @ARGV;
5020 $package = '_dgit-repos-server';
5021 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5023 exec @cmd or fail "exec git clone: $!\n";
5026 sub cmd_setup_mergechangelogs {
5027 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5028 setup_mergechangelogs(1);
5031 sub cmd_setup_useremail {
5032 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5036 sub cmd_setup_new_tree {
5037 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5041 #---------- argument parsing and main program ----------
5044 print "dgit version $our_version\n" or die $!;
5048 our (%valopts_long, %valopts_short);
5051 sub defvalopt ($$$$) {
5052 my ($long,$short,$val_re,$how) = @_;
5053 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5054 $valopts_long{$long} = $oi;
5055 $valopts_short{$short} = $oi;
5056 # $how subref should:
5057 # do whatever assignemnt or thing it likes with $_[0]
5058 # if the option should not be passed on to remote, @rvalopts=()
5059 # or $how can be a scalar ref, meaning simply assign the value
5062 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5063 defvalopt '--distro', '-d', '.+', \$idistro;
5064 defvalopt '', '-k', '.+', \$keyid;
5065 defvalopt '--existing-package','', '.*', \$existing_package;
5066 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5067 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5068 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5070 defvalopt '', '-C', '.+', sub {
5071 ($changesfile) = (@_);
5072 if ($changesfile =~ s#^(.*)/##) {
5073 $buildproductsdir = $1;
5077 defvalopt '--initiator-tempdir','','.*', sub {
5078 ($initiator_tempdir) = (@_);
5079 $initiator_tempdir =~ m#^/# or
5080 badusage "--initiator-tempdir must be used specify an".
5081 " absolute, not relative, directory."
5087 if (defined $ENV{'DGIT_SSH'}) {
5088 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5089 } elsif (defined $ENV{'GIT_SSH'}) {
5090 @ssh = ($ENV{'GIT_SSH'});
5098 if (!defined $val) {
5099 badusage "$what needs a value" unless @ARGV;
5101 push @rvalopts, $val;
5103 badusage "bad value \`$val' for $what" unless
5104 $val =~ m/^$oi->{Re}$(?!\n)/s;
5105 my $how = $oi->{How};
5106 if (ref($how) eq 'SCALAR') {
5111 push @ropts, @rvalopts;
5115 last unless $ARGV[0] =~ m/^-/;
5119 if (m/^--dry-run$/) {
5122 } elsif (m/^--damp-run$/) {
5125 } elsif (m/^--no-sign$/) {
5128 } elsif (m/^--help$/) {
5130 } elsif (m/^--version$/) {
5132 } elsif (m/^--new$/) {
5135 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5136 ($om = $opts_opt_map{$1}) &&
5140 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5141 !$opts_opt_cmdonly{$1} &&
5142 ($om = $opts_opt_map{$1})) {
5145 } elsif (m/^--ignore-dirty$/s) {
5148 } elsif (m/^--no-quilt-fixup$/s) {
5150 $quilt_mode = 'nocheck';
5151 } elsif (m/^--no-rm-on-error$/s) {
5154 } elsif (m/^--overwrite$/s) {
5156 $overwrite_version = '';
5157 } elsif (m/^--overwrite=(.+)$/s) {
5159 $overwrite_version = $1;
5160 } elsif (m/^--(no-)?rm-old-changes$/s) {
5163 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5165 push @deliberatelies, $&;
5166 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5167 # undocumented, for testing
5169 $tagformat_want = [ $1, 'command line', 1 ];
5170 # 1 menas overrides distro configuration
5171 } elsif (m/^--always-split-source-build$/s) {
5172 # undocumented, for testing
5174 $need_split_build_invocation = 1;
5175 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5176 $val = $2 ? $' : undef; #';
5177 $valopt->($oi->{Long});
5179 badusage "unknown long option \`$_'";
5186 } elsif (s/^-L/-/) {
5189 } elsif (s/^-h/-/) {
5191 } elsif (s/^-D/-/) {
5195 } elsif (s/^-N/-/) {
5200 push @changesopts, $_;
5202 } elsif (s/^-wn$//s) {
5204 $cleanmode = 'none';
5205 } elsif (s/^-wg$//s) {
5208 } elsif (s/^-wgf$//s) {
5210 $cleanmode = 'git-ff';
5211 } elsif (s/^-wd$//s) {
5213 $cleanmode = 'dpkg-source';
5214 } elsif (s/^-wdd$//s) {
5216 $cleanmode = 'dpkg-source-d';
5217 } elsif (s/^-wc$//s) {
5219 $cleanmode = 'check';
5220 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5221 push @git, '-c', $&;
5222 $gitcfgs{cmdline}{$1} = [ $2 ];
5223 } elsif (s/^-c([^=]+)$//s) {
5224 push @git, '-c', $&;
5225 $gitcfgs{cmdline}{$1} = [ 'true' ];
5226 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5228 $val = undef unless length $val;
5229 $valopt->($oi->{Short});
5232 badusage "unknown short option \`$_'";
5239 sub check_env_sanity () {
5240 my $blocked = new POSIX::SigSet;
5241 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5244 foreach my $name (qw(PIPE CHLD)) {
5245 my $signame = "SIG$name";
5246 my $signum = eval "POSIX::$signame" // die;
5247 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5248 die "$signame is set to something other than SIG_DFL\n";
5249 $blocked->ismember($signum) and
5250 die "$signame is blocked\n";
5256 On entry to dgit, $@
5257 This is a bug produced by something in in your execution environment.
5263 sub finalise_opts_opts () {
5264 foreach my $k (keys %opts_opt_map) {
5265 my $om = $opts_opt_map{$k};
5267 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5269 badcfg "cannot set command for $k"
5270 unless length $om->[0];
5274 foreach my $c (access_cfg_cfgs("opts-$k")) {
5276 map { $_ ? @$_ : () }
5277 map { $gitcfgs{$_}{$c} }
5278 reverse @gitcfgsources;
5279 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5280 "\n" if $debuglevel >= 4;
5282 badcfg "cannot configure options for $k"
5283 if $opts_opt_cmdonly{$k};
5284 my $insertpos = $opts_cfg_insertpos{$k};
5285 @$om = ( @$om[0..$insertpos-1],
5287 @$om[$insertpos..$#$om] );
5292 if ($ENV{$fakeeditorenv}) {
5294 quilt_fixup_editor();
5301 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5302 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5303 if $dryrun_level == 1;
5305 print STDERR $helpmsg or die $!;
5308 my $cmd = shift @ARGV;
5311 my $pre_fn = ${*::}{"pre_$cmd"};
5312 $pre_fn->() if $pre_fn;
5314 if (!defined $rmchanges) {
5315 local $access_forpush;
5316 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5319 if (!defined $quilt_mode) {
5320 local $access_forpush;
5321 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5322 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5324 $quilt_mode =~ m/^($quilt_modes_re)$/
5325 or badcfg "unknown quilt-mode \`$quilt_mode'";
5329 $need_split_build_invocation ||= quiltmode_splitbrain();
5331 if (!defined $cleanmode) {
5332 local $access_forpush;
5333 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5334 $cleanmode //= 'dpkg-source';
5336 badcfg "unknown clean-mode \`$cleanmode'" unless
5337 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5340 my $fn = ${*::}{"cmd_$cmd"};
5341 $fn or badusage "unknown operation $cmd";