3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
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';
81 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
82 our $splitbraincache = 'dgit-intern/quilt-cache';
85 our (@dget) = qw(dget);
86 our (@curl) = qw(curl -f);
87 our (@dput) = qw(dput);
88 our (@debsign) = qw(debsign);
90 our (@sbuild) = qw(sbuild);
92 our (@dgit) = qw(dgit);
93 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
94 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
95 our (@dpkggenchanges) = qw(dpkg-genchanges);
96 our (@mergechanges) = qw(mergechanges -f);
98 our (@changesopts) = ('');
100 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
103 'debsign' => \@debsign,
105 'sbuild' => \@sbuild,
109 'dpkg-source' => \@dpkgsource,
110 'dpkg-buildpackage' => \@dpkgbuildpackage,
111 'dpkg-genchanges' => \@dpkggenchanges,
113 'ch' => \@changesopts,
114 'mergechanges' => \@mergechanges);
116 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
117 our %opts_cfg_insertpos = map {
119 scalar @{ $opts_opt_map{$_} }
120 } keys %opts_opt_map;
122 sub finalise_opts_opts();
128 our $supplementary_message = '';
129 our $need_split_build_invocation = 0;
130 our $split_brain = 0;
134 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
137 our $remotename = 'dgit';
138 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
143 my ($v,$distro) = @_;
144 return $tagformatfn->($v, $distro);
147 sub debiantag_maintview ($$) {
148 my ($v,$distro) = @_;
153 sub lbranch () { return "$branchprefix/$csuite"; }
154 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
155 sub lref () { return "refs/heads/".lbranch(); }
156 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
157 sub rrref () { return server_ref($csuite); }
159 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
160 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
162 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
163 # locally fetched refs because they have unhelpful names and clutter
164 # up gitk etc. So we track whether we have "used up" head ref (ie,
165 # whether we have made another local ref which refers to this object).
167 # (If we deleted them unconditionally, then we might end up
168 # re-fetching the same git objects each time dgit fetch was run.)
170 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
171 # in git_fetch_us to fetch the refs in question, and possibly a call
172 # to lrfetchref_used.
174 our (%lrfetchrefs_f, %lrfetchrefs_d);
175 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
177 sub lrfetchref_used ($) {
178 my ($fullrefname) = @_;
179 my $objid = $lrfetchrefs_f{$fullrefname};
180 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
191 return "${package}_".(stripepoch $vsn).$sfx
196 return srcfn($vsn,".dsc");
199 sub changespat ($;$) {
200 my ($vsn, $arch) = @_;
201 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
210 foreach my $f (@end) {
212 print STDERR "$us: cleanup: $@" if length $@;
216 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
218 sub no_such_package () {
219 print STDERR "$us: package $package does not exist in suite $isuite\n";
225 printdebug "CD $newdir\n";
226 chdir $newdir or confess "chdir: $newdir: $!";
229 sub deliberately ($) {
231 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
234 sub deliberately_not_fast_forward () {
235 foreach (qw(not-fast-forward fresh-repo)) {
236 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
240 sub quiltmode_splitbrain () {
241 $quilt_mode =~ m/gbp|dpm|unapplied/;
244 #---------- remote protocol support, common ----------
246 # remote push initiator/responder protocol:
247 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
248 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
249 # < dgit-remote-push-ready <actual-proto-vsn>
256 # > supplementary-message NBYTES # $protovsn >= 3
261 # > file parsed-changelog
262 # [indicates that output of dpkg-parsechangelog follows]
263 # > data-block NBYTES
264 # > [NBYTES bytes of data (no newline)]
265 # [maybe some more blocks]
274 # > param head DGIT-VIEW-HEAD
275 # > param csuite SUITE
276 # > param tagformat old|new
277 # > param maint-view MAINT-VIEW-HEAD
279 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
280 # # goes into tag, for replay prevention
283 # [indicates that signed tag is wanted]
284 # < data-block NBYTES
285 # < [NBYTES bytes of data (no newline)]
286 # [maybe some more blocks]
290 # > want signed-dsc-changes
291 # < data-block NBYTES [transfer of signed dsc]
293 # < data-block NBYTES [transfer of signed changes]
301 sub i_child_report () {
302 # Sees if our child has died, and reap it if so. Returns a string
303 # describing how it died if it failed, or undef otherwise.
304 return undef unless $i_child_pid;
305 my $got = waitpid $i_child_pid, WNOHANG;
306 return undef if $got <= 0;
307 die unless $got == $i_child_pid;
308 $i_child_pid = undef;
309 return undef unless $?;
310 return "build host child ".waitstatusmsg();
315 fail "connection lost: $!" if $fh->error;
316 fail "protocol violation; $m not expected";
319 sub badproto_badread ($$) {
321 fail "connection lost: $!" if $!;
322 my $report = i_child_report();
323 fail $report if defined $report;
324 badproto $fh, "eof (reading $wh)";
327 sub protocol_expect (&$) {
328 my ($match, $fh) = @_;
331 defined && chomp or badproto_badread $fh, "protocol message";
339 badproto $fh, "\`$_'";
342 sub protocol_send_file ($$) {
343 my ($fh, $ourfn) = @_;
344 open PF, "<", $ourfn or die "$ourfn: $!";
347 my $got = read PF, $d, 65536;
348 die "$ourfn: $!" unless defined $got;
350 print $fh "data-block ".length($d)."\n" or die $!;
351 print $fh $d or die $!;
353 PF->error and die "$ourfn $!";
354 print $fh "data-end\n" or die $!;
358 sub protocol_read_bytes ($$) {
359 my ($fh, $nbytes) = @_;
360 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
362 my $got = read $fh, $d, $nbytes;
363 $got==$nbytes or badproto_badread $fh, "data block";
367 sub protocol_receive_file ($$) {
368 my ($fh, $ourfn) = @_;
369 printdebug "() $ourfn\n";
370 open PF, ">", $ourfn or die "$ourfn: $!";
372 my ($y,$l) = protocol_expect {
373 m/^data-block (.*)$/ ? (1,$1) :
374 m/^data-end$/ ? (0,) :
378 my $d = protocol_read_bytes $fh, $l;
379 print PF $d or die $!;
384 #---------- remote protocol support, responder ----------
386 sub responder_send_command ($) {
388 return unless $we_are_responder;
389 # called even without $we_are_responder
390 printdebug ">> $command\n";
391 print PO $command, "\n" or die $!;
394 sub responder_send_file ($$) {
395 my ($keyword, $ourfn) = @_;
396 return unless $we_are_responder;
397 printdebug "]] $keyword $ourfn\n";
398 responder_send_command "file $keyword";
399 protocol_send_file \*PO, $ourfn;
402 sub responder_receive_files ($@) {
403 my ($keyword, @ourfns) = @_;
404 die unless $we_are_responder;
405 printdebug "[[ $keyword @ourfns\n";
406 responder_send_command "want $keyword";
407 foreach my $fn (@ourfns) {
408 protocol_receive_file \*PI, $fn;
411 protocol_expect { m/^files-end$/ } \*PI;
414 #---------- remote protocol support, initiator ----------
416 sub initiator_expect (&) {
418 protocol_expect { &$match } \*RO;
421 #---------- end remote code ----------
424 if ($we_are_responder) {
426 responder_send_command "progress ".length($m) or die $!;
427 print PO $m or die $!;
437 $ua = LWP::UserAgent->new();
441 progress "downloading $what...";
442 my $r = $ua->get(@_) or die $!;
443 return undef if $r->code == 404;
444 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
445 return $r->decoded_content(charset => 'none');
448 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
453 failedcmd @_ if system @_;
456 sub act_local () { return $dryrun_level <= 1; }
457 sub act_scary () { return !$dryrun_level; }
460 if (!$dryrun_level) {
461 progress "dgit ok: @_";
463 progress "would be ok: @_ (but dry run only)";
468 printcmd(\*STDERR,$debugprefix."#",@_);
471 sub runcmd_ordryrun {
479 sub runcmd_ordryrun_local {
488 my ($first_shell, @cmd) = @_;
489 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
492 our $helpmsg = <<END;
494 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
495 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
496 dgit [dgit-opts] build [dpkg-buildpackage-opts]
497 dgit [dgit-opts] sbuild [sbuild-opts]
498 dgit [dgit-opts] push [dgit-opts] [suite]
499 dgit [dgit-opts] rpush build-host:build-dir ...
500 important dgit options:
501 -k<keyid> sign tag and package with <keyid> instead of default
502 --dry-run -n do not change anything, but go through the motions
503 --damp-run -L like --dry-run but make local changes, without signing
504 --new -N allow introducing a new package
505 --debug -D increase debug level
506 -c<name>=<value> set git config option (used directly by dgit too)
509 our $later_warning_msg = <<END;
510 Perhaps the upload is stuck in incoming. Using the version from git.
514 print STDERR "$us: @_\n", $helpmsg or die $!;
519 @ARGV or badusage "too few arguments";
520 return scalar shift @ARGV;
524 print $helpmsg or die $!;
528 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
530 our %defcfg = ('dgit.default.distro' => 'debian',
531 'dgit.default.username' => '',
532 'dgit.default.archive-query-default-component' => 'main',
533 'dgit.default.ssh' => 'ssh',
534 'dgit.default.archive-query' => 'madison:',
535 'dgit.default.sshpsql-dbname' => 'service=projectb',
536 'dgit.default.dgit-tag-format' => 'old,new,maint',
537 # old means "repo server accepts pushes with old dgit tags"
538 # new means "repo server accepts pushes with new dgit tags"
539 # maint means "repo server accepts split brain pushes"
540 # hist means "repo server may have old pushes without new tag"
541 # ("hist" is implied by "old")
542 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
543 'dgit-distro.debian.git-check' => 'url',
544 'dgit-distro.debian.git-check-suffix' => '/info/refs',
545 'dgit-distro.debian.new-private-pushers' => 't',
546 'dgit-distro.debian.dgit-tag-format' => 'new',
547 'dgit-distro.debian/push.git-url' => '',
548 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
549 'dgit-distro.debian/push.git-user-force' => 'dgit',
550 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
551 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
552 'dgit-distro.debian/push.git-create' => 'true',
553 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
554 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
555 # 'dgit-distro.debian.archive-query-tls-key',
556 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
557 # ^ this does not work because curl is broken nowadays
558 # Fixing #790093 properly will involve providing providing the key
559 # in some pacagke and maybe updating these paths.
561 # 'dgit-distro.debian.archive-query-tls-curl-args',
562 # '--ca-path=/etc/ssl/ca-debian',
563 # ^ this is a workaround but works (only) on DSA-administered machines
564 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
565 'dgit-distro.debian.git-url-suffix' => '',
566 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
567 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
568 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
569 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
570 'dgit-distro.ubuntu.git-check' => 'false',
571 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
572 'dgit-distro.test-dummy.ssh' => "$td/ssh",
573 'dgit-distro.test-dummy.username' => "alice",
574 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
575 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
576 'dgit-distro.test-dummy.git-url' => "$td/git",
577 'dgit-distro.test-dummy.git-host' => "git",
578 'dgit-distro.test-dummy.git-path' => "$td/git",
579 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
580 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
581 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
582 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
587 sub git_slurp_config () {
588 local ($debuglevel) = $debuglevel-2;
591 my @cmd = (@git, qw(config -z --get-regexp .*));
594 open GITS, "-|", @cmd or die $!;
597 printdebug "=> ", (messagequote $_), "\n";
599 push @{ $gitcfg{$`} }, $'; #';
603 or ($!==0 && $?==256)
607 sub git_get_config ($) {
610 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
613 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
619 return undef if $c =~ /RETURN-UNDEF/;
620 my $v = git_get_config($c);
621 return $v if defined $v;
622 my $dv = $defcfg{$c};
623 return $dv if defined $dv;
625 badcfg "need value for one of: @_\n".
626 "$us: distro or suite appears not to be (properly) supported";
629 sub access_basedistro () {
630 if (defined $idistro) {
633 return cfg("dgit-suite.$isuite.distro",
634 "dgit.default.distro");
638 sub access_quirk () {
639 # returns (quirk name, distro to use instead or undef, quirk-specific info)
640 my $basedistro = access_basedistro();
641 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
643 if (defined $backports_quirk) {
644 my $re = $backports_quirk;
645 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
647 $re =~ s/\%/([-0-9a-z_]+)/
648 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
649 if ($isuite =~ m/^$re$/) {
650 return ('backports',"$basedistro-backports",$1);
653 return ('none',undef);
658 sub parse_cfg_bool ($$$) {
659 my ($what,$def,$v) = @_;
662 $v =~ m/^[ty1]/ ? 1 :
663 $v =~ m/^[fn0]/ ? 0 :
664 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
667 sub access_forpush_config () {
668 my $d = access_basedistro();
672 parse_cfg_bool('new-private-pushers', 0,
673 cfg("dgit-distro.$d.new-private-pushers",
676 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
679 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
680 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
681 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
682 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
685 sub access_forpush () {
686 $access_forpush //= access_forpush_config();
687 return $access_forpush;
691 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
692 badcfg "pushing but distro is configured readonly"
693 if access_forpush_config() eq '0';
695 $supplementary_message = <<'END' unless $we_are_responder;
696 Push failed, before we got started.
697 You can retry the push, after fixing the problem, if you like.
699 finalise_opts_opts();
703 finalise_opts_opts();
706 sub supplementary_message ($) {
708 if (!$we_are_responder) {
709 $supplementary_message = $msg;
711 } elsif ($protovsn >= 3) {
712 responder_send_command "supplementary-message ".length($msg)
714 print PO $msg or die $!;
718 sub access_distros () {
719 # Returns list of distros to try, in order
722 # 0. `instead of' distro name(s) we have been pointed to
723 # 1. the access_quirk distro, if any
724 # 2a. the user's specified distro, or failing that } basedistro
725 # 2b. the distro calculated from the suite }
726 my @l = access_basedistro();
728 my (undef,$quirkdistro) = access_quirk();
729 unshift @l, $quirkdistro;
730 unshift @l, $instead_distro;
731 @l = grep { defined } @l;
733 if (access_forpush()) {
734 @l = map { ("$_/push", $_) } @l;
739 sub access_cfg_cfgs (@) {
742 # The nesting of these loops determines the search order. We put
743 # the key loop on the outside so that we search all the distros
744 # for each key, before going on to the next key. That means that
745 # if access_cfg is called with a more specific, and then a less
746 # specific, key, an earlier distro can override the less specific
747 # without necessarily overriding any more specific keys. (If the
748 # distro wants to override the more specific keys it can simply do
749 # so; whereas if we did the loop the other way around, it would be
750 # impossible to for an earlier distro to override a less specific
751 # key but not the more specific ones without restating the unknown
752 # values of the more specific keys.
755 # We have to deal with RETURN-UNDEF specially, so that we don't
756 # terminate the search prematurely.
758 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
761 foreach my $d (access_distros()) {
762 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
764 push @cfgs, map { "dgit.default.$_" } @realkeys;
771 my (@cfgs) = access_cfg_cfgs(@keys);
772 my $value = cfg(@cfgs);
776 sub access_cfg_bool ($$) {
777 my ($def, @keys) = @_;
778 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
781 sub string_to_ssh ($) {
783 if ($spec =~ m/\s/) {
784 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
790 sub access_cfg_ssh () {
791 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
792 if (!defined $gitssh) {
795 return string_to_ssh $gitssh;
799 sub access_runeinfo ($) {
801 return ": dgit ".access_basedistro()." $info ;";
804 sub access_someuserhost ($) {
806 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
807 defined($user) && length($user) or
808 $user = access_cfg("$some-user",'username');
809 my $host = access_cfg("$some-host");
810 return length($user) ? "$user\@$host" : $host;
813 sub access_gituserhost () {
814 return access_someuserhost('git');
817 sub access_giturl (;$) {
819 my $url = access_cfg('git-url','RETURN-UNDEF');
822 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
823 return undef unless defined $proto;
826 access_gituserhost().
827 access_cfg('git-path');
829 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
832 return "$url/$package$suffix";
835 sub parsecontrolfh ($$;$) {
836 my ($fh, $desc, $allowsigned) = @_;
837 our $dpkgcontrolhash_noissigned;
840 my %opts = ('name' => $desc);
841 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
842 $c = Dpkg::Control::Hash->new(%opts);
843 $c->parse($fh,$desc) or die "parsing of $desc failed";
844 last if $allowsigned;
845 last if $dpkgcontrolhash_noissigned;
846 my $issigned= $c->get_option('is_pgp_signed');
847 if (!defined $issigned) {
848 $dpkgcontrolhash_noissigned= 1;
849 seek $fh, 0,0 or die "seek $desc: $!";
850 } elsif ($issigned) {
851 fail "control file $desc is (already) PGP-signed. ".
852 " Note that dgit push needs to modify the .dsc and then".
853 " do the signature itself";
862 my ($file, $desc) = @_;
863 my $fh = new IO::Handle;
864 open $fh, '<', $file or die "$file: $!";
865 my $c = parsecontrolfh($fh,$desc);
866 $fh->error and die $!;
872 my ($dctrl,$field) = @_;
873 my $v = $dctrl->{$field};
874 return $v if defined $v;
875 fail "missing field $field in ".$dctrl->get_option('name');
879 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
880 my $p = new IO::Handle;
881 my @cmd = (qw(dpkg-parsechangelog), @_);
882 open $p, '-|', @cmd or die $!;
884 $?=0; $!=0; close $p or failedcmd @cmd;
888 sub commit_getclogp ($) {
889 # Returns the parsed changelog hashref for a particular commit
891 our %commit_getclogp_memo;
892 my $memo = $commit_getclogp_memo{$objid};
893 return $memo if $memo;
895 my $mclog = ".git/dgit/clog-$objid";
896 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
897 "$objid:debian/changelog";
898 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
903 defined $d or fail "getcwd failed: $!";
909 sub archive_query ($) {
911 my $query = access_cfg('archive-query','RETURN-UNDEF');
912 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
915 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
918 sub pool_dsc_subpath ($$) {
919 my ($vsn,$component) = @_; # $package is implict arg
920 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
921 return "/pool/$component/$prefix/$package/".dscfn($vsn);
924 #---------- `ftpmasterapi' archive query method (nascent) ----------
926 sub archive_api_query_cmd ($) {
928 my @cmd = qw(curl -sS);
929 my $url = access_cfg('archive-query-url');
930 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
932 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
933 foreach my $key (split /\:/, $keys) {
934 $key =~ s/\%HOST\%/$host/g;
936 fail "for $url: stat $key: $!" unless $!==ENOENT;
939 fail "config requested specific TLS key but do not know".
940 " how to get curl to use exactly that EE key ($key)";
941 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
942 # # Sadly the above line does not work because of changes
943 # # to gnutls. The real fix for #790093 may involve
944 # # new curl options.
947 # Fixing #790093 properly will involve providing a value
948 # for this on clients.
949 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
950 push @cmd, split / /, $kargs if defined $kargs;
952 push @cmd, $url.$subpath;
958 my ($data, $subpath) = @_;
959 badcfg "ftpmasterapi archive query method takes no data part"
961 my @cmd = archive_api_query_cmd($subpath);
962 my $json = cmdoutput @cmd;
963 return decode_json($json);
966 sub canonicalise_suite_ftpmasterapi () {
967 my ($proto,$data) = @_;
968 my $suites = api_query($data, 'suites');
970 foreach my $entry (@$suites) {
972 my $v = $entry->{$_};
973 defined $v && $v eq $isuite;
975 push @matched, $entry;
977 fail "unknown suite $isuite" unless @matched;
980 @matched==1 or die "multiple matches for suite $isuite\n";
981 $cn = "$matched[0]{codename}";
982 defined $cn or die "suite $isuite info has no codename\n";
983 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
985 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
990 sub archive_query_ftpmasterapi () {
991 my ($proto,$data) = @_;
992 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
994 my $digester = Digest::SHA->new(256);
995 foreach my $entry (@$info) {
997 my $vsn = "$entry->{version}";
998 my ($ok,$msg) = version_check $vsn;
999 die "bad version: $msg\n" unless $ok;
1000 my $component = "$entry->{component}";
1001 $component =~ m/^$component_re$/ or die "bad component";
1002 my $filename = "$entry->{filename}";
1003 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1004 or die "bad filename";
1005 my $sha256sum = "$entry->{sha256sum}";
1006 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1007 push @rows, [ $vsn, "/pool/$component/$filename",
1008 $digester, $sha256sum ];
1010 die "bad ftpmaster api response: $@\n".Dumper($entry)
1013 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1017 #---------- `madison' archive query method ----------
1019 sub archive_query_madison {
1020 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1023 sub madison_get_parse {
1024 my ($proto,$data) = @_;
1025 die unless $proto eq 'madison';
1026 if (!length $data) {
1027 $data= access_cfg('madison-distro','RETURN-UNDEF');
1028 $data //= access_basedistro();
1030 $rmad{$proto,$data,$package} ||= cmdoutput
1031 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1032 my $rmad = $rmad{$proto,$data,$package};
1035 foreach my $l (split /\n/, $rmad) {
1036 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1037 \s*( [^ \t|]+ )\s* \|
1038 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1039 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1040 $1 eq $package or die "$rmad $package ?";
1047 $component = access_cfg('archive-query-default-component');
1049 $5 eq 'source' or die "$rmad ?";
1050 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1052 return sort { -version_compare($a->[0],$b->[0]); } @out;
1055 sub canonicalise_suite_madison {
1056 # madison canonicalises for us
1057 my @r = madison_get_parse(@_);
1059 "unable to canonicalise suite using package $package".
1060 " which does not appear to exist in suite $isuite;".
1061 " --existing-package may help";
1065 #---------- `sshpsql' archive query method ----------
1068 my ($data,$runeinfo,$sql) = @_;
1069 if (!length $data) {
1070 $data= access_someuserhost('sshpsql').':'.
1071 access_cfg('sshpsql-dbname');
1073 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1074 my ($userhost,$dbname) = ($`,$'); #';
1076 my @cmd = (access_cfg_ssh, $userhost,
1077 access_runeinfo("ssh-psql $runeinfo").
1078 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1079 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1081 open P, "-|", @cmd or die $!;
1084 printdebug(">|$_|\n");
1087 $!=0; $?=0; close P or failedcmd @cmd;
1089 my $nrows = pop @rows;
1090 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1091 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1092 @rows = map { [ split /\|/, $_ ] } @rows;
1093 my $ncols = scalar @{ shift @rows };
1094 die if grep { scalar @$_ != $ncols } @rows;
1098 sub sql_injection_check {
1099 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1102 sub archive_query_sshpsql ($$) {
1103 my ($proto,$data) = @_;
1104 sql_injection_check $isuite, $package;
1105 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1106 SELECT source.version, component.name, files.filename, files.sha256sum
1108 JOIN src_associations ON source.id = src_associations.source
1109 JOIN suite ON suite.id = src_associations.suite
1110 JOIN dsc_files ON dsc_files.source = source.id
1111 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1112 JOIN component ON component.id = files_archive_map.component_id
1113 JOIN files ON files.id = dsc_files.file
1114 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1115 AND source.source='$package'
1116 AND files.filename LIKE '%.dsc';
1118 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1119 my $digester = Digest::SHA->new(256);
1121 my ($vsn,$component,$filename,$sha256sum) = @$_;
1122 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1127 sub canonicalise_suite_sshpsql ($$) {
1128 my ($proto,$data) = @_;
1129 sql_injection_check $isuite;
1130 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1131 SELECT suite.codename
1132 FROM suite where suite_name='$isuite' or codename='$isuite';
1134 @rows = map { $_->[0] } @rows;
1135 fail "unknown suite $isuite" unless @rows;
1136 die "ambiguous $isuite: @rows ?" if @rows>1;
1140 #---------- `dummycat' archive query method ----------
1142 sub canonicalise_suite_dummycat ($$) {
1143 my ($proto,$data) = @_;
1144 my $dpath = "$data/suite.$isuite";
1145 if (!open C, "<", $dpath) {
1146 $!==ENOENT or die "$dpath: $!";
1147 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1151 chomp or die "$dpath: $!";
1153 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1157 sub archive_query_dummycat ($$) {
1158 my ($proto,$data) = @_;
1159 canonicalise_suite();
1160 my $dpath = "$data/package.$csuite.$package";
1161 if (!open C, "<", $dpath) {
1162 $!==ENOENT or die "$dpath: $!";
1163 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1171 printdebug "dummycat query $csuite $package $dpath | $_\n";
1172 my @row = split /\s+/, $_;
1173 @row==2 or die "$dpath: $_ ?";
1176 C->error and die "$dpath: $!";
1178 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1181 #---------- tag format handling ----------
1183 sub access_cfg_tagformats () {
1184 split /\,/, access_cfg('dgit-tag-format');
1187 sub need_tagformat ($$) {
1188 my ($fmt, $why) = @_;
1189 fail "need to use tag format $fmt ($why) but also need".
1190 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1191 " - no way to proceed"
1192 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1193 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1196 sub select_tagformat () {
1198 return if $tagformatfn && !$tagformat_want;
1199 die 'bug' if $tagformatfn && $tagformat_want;
1200 # ... $tagformat_want assigned after previous select_tagformat
1202 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1203 printdebug "select_tagformat supported @supported\n";
1205 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1206 printdebug "select_tagformat specified @$tagformat_want\n";
1208 my ($fmt,$why,$override) = @$tagformat_want;
1210 fail "target distro supports tag formats @supported".
1211 " but have to use $fmt ($why)"
1213 or grep { $_ eq $fmt } @supported;
1215 $tagformat_want = undef;
1217 $tagformatfn = ${*::}{"debiantag_$fmt"};
1219 fail "trying to use unknown tag format \`$fmt' ($why) !"
1220 unless $tagformatfn;
1223 #---------- archive query entrypoints and rest of program ----------
1225 sub canonicalise_suite () {
1226 return if defined $csuite;
1227 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1228 $csuite = archive_query('canonicalise_suite');
1229 if ($isuite ne $csuite) {
1230 progress "canonical suite name for $isuite is $csuite";
1234 sub get_archive_dsc () {
1235 canonicalise_suite();
1236 my @vsns = archive_query('archive_query');
1237 foreach my $vinfo (@vsns) {
1238 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1239 $dscurl = access_cfg('mirror').$subpath;
1240 $dscdata = url_get($dscurl);
1242 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1247 $digester->add($dscdata);
1248 my $got = $digester->hexdigest();
1250 fail "$dscurl has hash $got but".
1251 " archive told us to expect $digest";
1253 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1254 printdebug Dumper($dscdata) if $debuglevel>1;
1255 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1256 printdebug Dumper($dsc) if $debuglevel>1;
1257 my $fmt = getfield $dsc, 'Format';
1258 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1259 $dsc_checked = !!$digester;
1260 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1264 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1267 sub check_for_git ();
1268 sub check_for_git () {
1270 my $how = access_cfg('git-check');
1271 if ($how eq 'ssh-cmd') {
1273 (access_cfg_ssh, access_gituserhost(),
1274 access_runeinfo("git-check $package").
1275 " set -e; cd ".access_cfg('git-path').";".
1276 " if test -d $package.git; then echo 1; else echo 0; fi");
1277 my $r= cmdoutput @cmd;
1278 if (defined $r and $r =~ m/^divert (\w+)$/) {
1280 my ($usedistro,) = access_distros();
1281 # NB that if we are pushing, $usedistro will be $distro/push
1282 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1283 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1284 progress "diverting to $divert (using config for $instead_distro)";
1285 return check_for_git();
1287 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1289 } elsif ($how eq 'url') {
1290 my $prefix = access_cfg('git-check-url','git-url');
1291 my $suffix = access_cfg('git-check-suffix','git-suffix',
1292 'RETURN-UNDEF') // '.git';
1293 my $url = "$prefix/$package$suffix";
1294 my @cmd = (qw(curl -sS -I), $url);
1295 my $result = cmdoutput @cmd;
1296 $result =~ s/^\S+ 200 .*\n\r?\n//;
1297 # curl -sS -I with https_proxy prints
1298 # HTTP/1.0 200 Connection established
1299 $result =~ m/^\S+ (404|200) /s or
1300 fail "unexpected results from git check query - ".
1301 Dumper($prefix, $result);
1303 if ($code eq '404') {
1305 } elsif ($code eq '200') {
1310 } elsif ($how eq 'true') {
1312 } elsif ($how eq 'false') {
1315 badcfg "unknown git-check \`$how'";
1319 sub create_remote_git_repo () {
1320 my $how = access_cfg('git-create');
1321 if ($how eq 'ssh-cmd') {
1323 (access_cfg_ssh, access_gituserhost(),
1324 access_runeinfo("git-create $package").
1325 "set -e; cd ".access_cfg('git-path').";".
1326 " cp -a _template $package.git");
1327 } elsif ($how eq 'true') {
1330 badcfg "unknown git-create \`$how'";
1334 our ($dsc_hash,$lastpush_mergeinput);
1336 our $ud = '.git/dgit/unpack';
1346 sub mktree_in_ud_here () {
1347 runcmd qw(git init -q);
1348 runcmd qw(git config gc.auto 0);
1349 rmtree('.git/objects');
1350 symlink '../../../../objects','.git/objects' or die $!;
1353 sub git_write_tree () {
1354 my $tree = cmdoutput @git, qw(write-tree);
1355 $tree =~ m/^\w+$/ or die "$tree ?";
1359 sub remove_stray_gits () {
1360 my @gitscmd = qw(find -name .git -prune -print0);
1361 debugcmd "|",@gitscmd;
1362 open GITS, "-|", @gitscmd or die $!;
1367 print STDERR "$us: warning: removing from source package: ",
1368 (messagequote $_), "\n";
1372 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1375 sub mktree_in_ud_from_only_subdir () {
1376 # changes into the subdir
1378 die "@dirs ?" unless @dirs==1;
1379 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1383 remove_stray_gits();
1384 mktree_in_ud_here();
1385 my ($format, $fopts) = get_source_format();
1386 if (madformat($format)) {
1389 runcmd @git, qw(add -Af);
1390 my $tree=git_write_tree();
1391 return ($tree,$dir);
1394 sub dsc_files_info () {
1395 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1396 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1397 ['Files', 'Digest::MD5', 'new()']) {
1398 my ($fname, $module, $method) = @$csumi;
1399 my $field = $dsc->{$fname};
1400 next unless defined $field;
1401 eval "use $module; 1;" or die $@;
1403 foreach (split /\n/, $field) {
1405 m/^(\w+) (\d+) (\S+)$/ or
1406 fail "could not parse .dsc $fname line \`$_'";
1407 my $digester = eval "$module"."->$method;" or die $@;
1412 Digester => $digester,
1417 fail "missing any supported Checksums-* or Files field in ".
1418 $dsc->get_option('name');
1422 map { $_->{Filename} } dsc_files_info();
1425 sub is_orig_file ($;$) {
1428 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1429 defined $base or return 1;
1433 sub make_commit ($) {
1435 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1438 sub clogp_authline ($) {
1440 my $author = getfield $clogp, 'Maintainer';
1441 $author =~ s#,.*##ms;
1442 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1443 my $authline = "$author $date";
1444 $authline =~ m/$git_authline_re/o or
1445 fail "unexpected commit author line format \`$authline'".
1446 " (was generated from changelog Maintainer field)";
1447 return ($1,$2,$3) if wantarray;
1451 sub vendor_patches_distro ($$) {
1452 my ($checkdistro, $what) = @_;
1453 return unless defined $checkdistro;
1455 my $series = "debian/patches/\L$checkdistro\E.series";
1456 printdebug "checking for vendor-specific $series ($what)\n";
1458 if (!open SERIES, "<", $series) {
1459 die "$series $!" unless $!==ENOENT;
1468 Unfortunately, this source package uses a feature of dpkg-source where
1469 the same source package unpacks to different source code on different
1470 distros. dgit cannot safely operate on such packages on affected
1471 distros, because the meaning of source packages is not stable.
1473 Please ask the distro/maintainer to remove the distro-specific series
1474 files and use a different technique (if necessary, uploading actually
1475 different packages, if different distros are supposed to have
1479 fail "Found active distro-specific series file for".
1480 " $checkdistro ($what): $series, cannot continue";
1482 die "$series $!" if SERIES->error;
1486 sub check_for_vendor_patches () {
1487 # This dpkg-source feature doesn't seem to be documented anywhere!
1488 # But it can be found in the changelog (reformatted):
1490 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1491 # Author: Raphael Hertzog <hertzog@debian.org>
1492 # Date: Sun Oct 3 09:36:48 2010 +0200
1494 # dpkg-source: correctly create .pc/.quilt_series with alternate
1497 # If you have debian/patches/ubuntu.series and you were
1498 # unpacking the source package on ubuntu, quilt was still
1499 # directed to debian/patches/series instead of
1500 # debian/patches/ubuntu.series.
1502 # debian/changelog | 3 +++
1503 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1504 # 2 files changed, 6 insertions(+), 1 deletion(-)
1507 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1508 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1509 "Dpkg::Vendor \`current vendor'");
1510 vendor_patches_distro(access_basedistro(),
1511 "distro being accessed");
1514 sub generate_commits_from_dsc () {
1515 # See big comment in fetch_from_archive, below.
1519 foreach my $fi (dsc_files_info()) {
1520 my $f = $fi->{Filename};
1521 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1523 link_ltarget "../../../$f", $f
1527 complete_file_from_dsc('.', $fi)
1530 if (is_orig_file($f)) {
1531 link $f, "../../../../$f"
1537 my $dscfn = "$package.dsc";
1539 open D, ">", $dscfn or die "$dscfn: $!";
1540 print D $dscdata or die "$dscfn: $!";
1541 close D or die "$dscfn: $!";
1542 my @cmd = qw(dpkg-source);
1543 push @cmd, '--no-check' if $dsc_checked;
1544 push @cmd, qw(-x --), $dscfn;
1547 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1548 check_for_vendor_patches() if madformat($dsc->{format});
1549 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1550 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1551 my $authline = clogp_authline $clogp;
1552 my $changes = getfield $clogp, 'Changes';
1553 open C, ">../commit.tmp" or die $!;
1554 print C <<END or die $!;
1561 # imported from the archive
1564 my $rawimport_hash = make_commit qw(../commit.tmp);
1565 my $cversion = getfield $clogp, 'Version';
1566 my $rawimport_mergeinput = {
1567 Commit => $rawimport_hash,
1568 Info => "Import of source package",
1570 my @output = ($rawimport_mergeinput);
1571 progress "synthesised git commit from .dsc $cversion";
1572 if ($lastpush_mergeinput) {
1573 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1574 my $oversion = getfield $oldclogp, 'Version';
1576 version_compare($oversion, $cversion);
1578 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1579 { Message => <<END, ReverseParents => 1 });
1580 Record $package ($cversion) in archive suite $csuite
1582 } elsif ($vcmp > 0) {
1583 print STDERR <<END or die $!;
1585 Version actually in archive: $cversion (older)
1586 Last version pushed with dgit: $oversion (newer or same)
1589 @output = $lastpush_mergeinput;
1591 # Same version. Use what's in the server git branch,
1592 # discarding our own import. (This could happen if the
1593 # server automatically imports all packages into git.)
1594 @output = $lastpush_mergeinput;
1597 changedir '../../../..';
1602 sub complete_file_from_dsc ($$) {
1603 our ($dstdir, $fi) = @_;
1604 # Ensures that we have, in $dir, the file $fi, with the correct
1605 # contents. (Downloading it from alongside $dscurl if necessary.)
1607 my $f = $fi->{Filename};
1608 my $tf = "$dstdir/$f";
1611 if (stat_exists $tf) {
1612 progress "using existing $f";
1615 $furl =~ s{/[^/]+$}{};
1617 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1618 die "$f ?" if $f =~ m#/#;
1619 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1620 return 0 if !act_local();
1624 open F, "<", "$tf" or die "$tf: $!";
1625 $fi->{Digester}->reset();
1626 $fi->{Digester}->addfile(*F);
1627 F->error and die $!;
1628 my $got = $fi->{Digester}->hexdigest();
1629 $got eq $fi->{Hash} or
1630 fail "file $f has hash $got but .dsc".
1631 " demands hash $fi->{Hash} ".
1632 ($downloaded ? "(got wrong file from archive!)"
1633 : "(perhaps you should delete this file?)");
1638 sub ensure_we_have_orig () {
1639 foreach my $fi (dsc_files_info()) {
1640 my $f = $fi->{Filename};
1641 next unless is_orig_file($f);
1642 complete_file_from_dsc('..', $fi)
1647 sub git_fetch_us () {
1648 # Want to fetch only what we are going to use, unless
1649 # deliberately-not-ff, in which case we must fetch everything.
1651 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1653 (quiltmode_splitbrain
1654 ? (map { $_->('*',access_basedistro) }
1655 \&debiantag_new, \&debiantag_maintview)
1656 : debiantags('*',access_basedistro));
1657 push @specs, server_branch($csuite);
1658 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1660 # This is rather miserable:
1661 # When git-fetch --prune is passed a fetchspec ending with a *,
1662 # it does a plausible thing. If there is no * then:
1663 # - it matches subpaths too, even if the supplied refspec
1664 # starts refs, and behaves completely madly if the source
1665 # has refs/refs/something. (See, for example, Debian #NNNN.)
1666 # - if there is no matching remote ref, it bombs out the whole
1668 # We want to fetch a fixed ref, and we don't know in advance
1669 # if it exists, so this is not suitable.
1671 # Our workaround is to use git-ls-remote. git-ls-remote has its
1672 # own qairks. Notably, it has the absurd multi-tail-matching
1673 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1674 # refs/refs/foo etc.
1676 # Also, we want an idempotent snapshot, but we have to make two
1677 # calls to the remote: one to git-ls-remote and to git-fetch. The
1678 # solution is use git-ls-remote to obtain a target state, and
1679 # git-fetch to try to generate it. If we don't manage to generate
1680 # the target state, we try again.
1682 my $specre = join '|', map {
1688 printdebug "git_fetch_us specre=$specre\n";
1689 my $wanted_rref = sub {
1691 return m/^(?:$specre)$/o;
1694 my $fetch_iteration = 0;
1697 if (++$fetch_iteration > 10) {
1698 fail "too many iterations trying to get sane fetch!";
1701 my @look = map { "refs/$_" } @specs;
1702 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1706 open GITLS, "-|", @lcmd or die $!;
1708 printdebug "=> ", $_;
1709 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1710 my ($objid,$rrefname) = ($1,$2);
1711 if (!$wanted_rref->($rrefname)) {
1713 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1717 $wantr{$rrefname} = $objid;
1720 close GITLS or failedcmd @lcmd;
1722 # OK, now %want is exactly what we want for refs in @specs
1724 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1725 "+refs/$_:".lrfetchrefs."/$_";
1728 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1729 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1732 %lrfetchrefs_f = ();
1735 git_for_each_ref(lrfetchrefs, sub {
1736 my ($objid,$objtype,$lrefname,$reftail) = @_;
1737 $lrfetchrefs_f{$lrefname} = $objid;
1738 $objgot{$objid} = 1;
1741 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1742 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1743 if (!exists $wantr{$rrefname}) {
1744 if ($wanted_rref->($rrefname)) {
1746 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1750 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1753 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1754 delete $lrfetchrefs_f{$lrefname};
1758 foreach my $rrefname (sort keys %wantr) {
1759 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1760 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1761 my $want = $wantr{$rrefname};
1762 next if $got eq $want;
1763 if (!defined $objgot{$want}) {
1765 warning: git-ls-remote suggests we want $lrefname
1766 warning: and it should refer to $want
1767 warning: but git-fetch didn't fetch that object to any relevant ref.
1768 warning: This may be due to a race with someone updating the server.
1769 warning: Will try again...
1771 next FETCH_ITERATION;
1774 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1776 runcmd_ordryrun_local @git, qw(update-ref -m),
1777 "dgit fetch git-fetch fixup", $lrefname, $want;
1778 $lrfetchrefs_f{$lrefname} = $want;
1782 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1783 Dumper(\%lrfetchrefs_f);
1786 my @tagpats = debiantags('*',access_basedistro);
1788 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1789 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1790 printdebug "currently $fullrefname=$objid\n";
1791 $here{$fullrefname} = $objid;
1793 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1794 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1795 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1796 printdebug "offered $lref=$objid\n";
1797 if (!defined $here{$lref}) {
1798 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1799 runcmd_ordryrun_local @upd;
1800 lrfetchref_used $fullrefname;
1801 } elsif ($here{$lref} eq $objid) {
1802 lrfetchref_used $fullrefname;
1805 "Not updateting $lref from $here{$lref} to $objid.\n";
1810 sub mergeinfo_getclogp ($) {
1811 # Ensures thit $mi->{Clogp} exists and returns it
1813 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1816 sub mergeinfo_version ($) {
1817 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1820 sub fetch_from_archive () {
1821 # Ensures that lrref() is what is actually in the archive, one way
1822 # or another, according to us - ie this client's
1823 # appropritaely-updated archive view. Also returns the commit id.
1824 # If there is nothing in the archive, leaves lrref alone and
1825 # returns undef. git_fetch_us must have already been called.
1829 foreach my $field (@ourdscfield) {
1830 $dsc_hash = $dsc->{$field};
1831 last if defined $dsc_hash;
1833 if (defined $dsc_hash) {
1834 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1836 progress "last upload to archive specified git hash";
1838 progress "last upload to archive has NO git hash";
1841 progress "no version available from the archive";
1844 # If the archive's .dsc has a Dgit field, there are three
1845 # relevant git commitids we need to choose between and/or merge
1847 # 1. $dsc_hash: the Dgit field from the archive
1848 # 2. $lastpush_hash: the suite branch on the dgit git server
1849 # 3. $lastfetch_hash: our local tracking brach for the suite
1851 # These may all be distinct and need not be in any fast forward
1854 # If the dsc was pushed to this suite, then the server suite
1855 # branch will have been updated; but it might have been pushed to
1856 # a different suite and copied by the archive. Conversely a more
1857 # recent version may have been pushed with dgit but not appeared
1858 # in the archive (yet).
1860 # $lastfetch_hash may be awkward because archive imports
1861 # (particularly, imports of Dgit-less .dscs) are performed only as
1862 # needed on individual clients, so different clients may perform a
1863 # different subset of them - and these imports are only made
1864 # public during push. So $lastfetch_hash may represent a set of
1865 # imports different to a subsequent upload by a different dgit
1868 # Our approach is as follows:
1870 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1871 # descendant of $dsc_hash, then it was pushed by a dgit user who
1872 # had based their work on $dsc_hash, so we should prefer it.
1873 # Otherwise, $dsc_hash was installed into this suite in the
1874 # archive other than by a dgit push, and (necessarily) after the
1875 # last dgit push into that suite (since a dgit push would have
1876 # been descended from the dgit server git branch); thus, in that
1877 # case, we prefer the archive's version (and produce a
1878 # pseudo-merge to overwrite the dgit server git branch).
1880 # (If there is no Dgit field in the archive's .dsc then
1881 # generate_commit_from_dsc uses the version numbers to decide
1882 # whether the suite branch or the archive is newer. If the suite
1883 # branch is newer it ignores the archive's .dsc; otherwise it
1884 # generates an import of the .dsc, and produces a pseudo-merge to
1885 # overwrite the suite branch with the archive contents.)
1887 # The outcome of that part of the algorithm is the `public view',
1888 # and is same for all dgit clients: it does not depend on any
1889 # unpublished history in the local tracking branch.
1891 # As between the public view and the local tracking branch: The
1892 # local tracking branch is only updated by dgit fetch, and
1893 # whenever dgit fetch runs it includes the public view in the
1894 # local tracking branch. Therefore if the public view is not
1895 # descended from the local tracking branch, the local tracking
1896 # branch must contain history which was imported from the archive
1897 # but never pushed; and, its tip is now out of date. So, we make
1898 # a pseudo-merge to overwrite the old imports and stitch the old
1901 # Finally: we do not necessarily reify the public view (as
1902 # described above). This is so that we do not end up stacking two
1903 # pseudo-merges. So what we actually do is figure out the inputs
1904 # to any public view pseudo-merge and put them in @mergeinputs.
1907 # $mergeinputs[]{Commit}
1908 # $mergeinputs[]{Info}
1909 # $mergeinputs[0] is the one whose tree we use
1910 # @mergeinputs is in the order we use in the actual commit)
1913 # $mergeinputs[]{Message} is a commit message to use
1914 # $mergeinputs[]{ReverseParents} if def specifies that parent
1915 # list should be in opposite order
1916 # Such an entry has no Commit or Info. It applies only when found
1917 # in the last entry. (This ugliness is to support making
1918 # identical imports to previous dgit versions.)
1920 my $lastpush_hash = git_get_ref(lrfetchref());
1921 printdebug "previous reference hash=$lastpush_hash\n";
1922 $lastpush_mergeinput = $lastpush_hash && {
1923 Commit => $lastpush_hash,
1924 Info => "dgit suite branch on dgit git server",
1927 my $lastfetch_hash = git_get_ref(lrref());
1928 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1929 my $lastfetch_mergeinput = $lastfetch_hash && {
1930 Commit => $lastfetch_hash,
1931 Info => "dgit client's archive history view",
1934 my $dsc_mergeinput = $dsc_hash && {
1935 Commit => $dsc_hash,
1936 Info => "Dgit field in .dsc from archive",
1940 my $del_lrfetchrefs = sub {
1943 printdebug "del_lrfetchrefs...\n";
1944 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1945 my $objid = $lrfetchrefs_d{$fullrefname};
1946 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1948 $gur ||= new IO::Handle;
1949 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1951 printf $gur "delete %s %s\n", $fullrefname, $objid;
1954 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1958 if (defined $dsc_hash) {
1959 fail "missing remote git history even though dsc has hash -".
1960 " could not find ref ".rref()." at ".access_giturl()
1961 unless $lastpush_hash;
1962 ensure_we_have_orig();
1963 if ($dsc_hash eq $lastpush_hash) {
1964 @mergeinputs = $dsc_mergeinput
1965 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1966 print STDERR <<END or die $!;
1968 Git commit in archive is behind the last version allegedly pushed/uploaded.
1969 Commit referred to by archive: $dsc_hash
1970 Last version pushed with dgit: $lastpush_hash
1973 @mergeinputs = ($lastpush_mergeinput);
1975 # Archive has .dsc which is not a descendant of the last dgit
1976 # push. This can happen if the archive moves .dscs about.
1977 # Just follow its lead.
1978 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1979 progress "archive .dsc names newer git commit";
1980 @mergeinputs = ($dsc_mergeinput);
1982 progress "archive .dsc names other git commit, fixing up";
1983 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1987 @mergeinputs = generate_commits_from_dsc();
1988 # We have just done an import. Now, our import algorithm might
1989 # have been improved. But even so we do not want to generate
1990 # a new different import of the same package. So if the
1991 # version numbers are the same, just use our existing version.
1992 # If the version numbers are different, the archive has changed
1993 # (perhaps, rewound).
1994 if ($lastfetch_mergeinput &&
1995 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1996 (mergeinfo_version $mergeinputs[0]) )) {
1997 @mergeinputs = ($lastfetch_mergeinput);
1999 } elsif ($lastpush_hash) {
2000 # only in git, not in the archive yet
2001 @mergeinputs = ($lastpush_mergeinput);
2002 print STDERR <<END or die $!;
2004 Package not found in the archive, but has allegedly been pushed using dgit.
2008 printdebug "nothing found!\n";
2009 if (defined $skew_warning_vsn) {
2010 print STDERR <<END or die $!;
2012 Warning: relevant archive skew detected.
2013 Archive allegedly contains $skew_warning_vsn
2014 But we were not able to obtain any version from the archive or git.
2018 unshift @end, $del_lrfetchrefs;
2022 if ($lastfetch_hash &&
2024 my $h = $_->{Commit};
2025 $h and is_fast_fwd($lastfetch_hash, $h);
2026 # If true, one of the existing parents of this commit
2027 # is a descendant of the $lastfetch_hash, so we'll
2028 # be ff from that automatically.
2032 push @mergeinputs, $lastfetch_mergeinput;
2035 printdebug "fetch mergeinfos:\n";
2036 foreach my $mi (@mergeinputs) {
2038 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2040 printdebug sprintf " ReverseParents=%d Message=%s",
2041 $mi->{ReverseParents}, $mi->{Message};
2045 my $compat_info= pop @mergeinputs
2046 if $mergeinputs[$#mergeinputs]{Message};
2048 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2051 if (@mergeinputs > 1) {
2053 my $tree_commit = $mergeinputs[0]{Commit};
2055 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2056 $tree =~ m/\n\n/; $tree = $`;
2057 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2060 # We use the changelog author of the package in question the
2061 # author of this pseudo-merge. This is (roughly) correct if
2062 # this commit is simply representing aa non-dgit upload.
2063 # (Roughly because it does not record sponsorship - but we
2064 # don't have sponsorship info because that's in the .changes,
2065 # which isn't in the archivw.)
2067 # But, it might be that we are representing archive history
2068 # updates (including in-archive copies). These are not really
2069 # the responsibility of the person who created the .dsc, but
2070 # there is no-one whose name we should better use. (The
2071 # author of the .dsc-named commit is clearly worse.)
2073 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2074 my $author = clogp_authline $useclogp;
2075 my $cversion = getfield $useclogp, 'Version';
2077 my $mcf = ".git/dgit/mergecommit";
2078 open MC, ">", $mcf or die "$mcf $!";
2079 print MC <<END or die $!;
2083 my @parents = grep { $_->{Commit} } @mergeinputs;
2084 @parents = reverse @parents if $compat_info->{ReverseParents};
2085 print MC <<END or die $! foreach @parents;
2089 print MC <<END or die $!;
2095 if (defined $compat_info->{Message}) {
2096 print MC $compat_info->{Message} or die $!;
2098 print MC <<END or die $!;
2099 Record $package ($cversion) in archive suite $csuite
2103 my $message_add_info = sub {
2105 my $mversion = mergeinfo_version $mi;
2106 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2110 $message_add_info->($mergeinputs[0]);
2111 print MC <<END or die $!;
2112 should be treated as descended from
2114 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2118 $hash = make_commit $mcf;
2120 $hash = $mergeinputs[0]{Commit};
2122 progress "fetch hash=$hash\n";
2125 my ($lasth, $what) = @_;
2126 return unless $lasth;
2127 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2130 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2131 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2133 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2134 'DGIT_ARCHIVE', $hash;
2135 cmdoutput @git, qw(log -n2), $hash;
2136 # ... gives git a chance to complain if our commit is malformed
2138 if (defined $skew_warning_vsn) {
2140 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2141 my $gotclogp = commit_getclogp($hash);
2142 my $got_vsn = getfield $gotclogp, 'Version';
2143 printdebug "SKEW CHECK GOT $got_vsn\n";
2144 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2145 print STDERR <<END or die $!;
2147 Warning: archive skew detected. Using the available version:
2148 Archive allegedly contains $skew_warning_vsn
2149 We were able to obtain only $got_vsn
2155 if ($lastfetch_hash ne $hash) {
2156 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2160 dryrun_report @upd_cmd;
2164 lrfetchref_used lrfetchref();
2166 unshift @end, $del_lrfetchrefs;
2170 sub set_local_git_config ($$) {
2172 runcmd @git, qw(config), $k, $v;
2175 sub setup_mergechangelogs (;$) {
2177 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2179 my $driver = 'dpkg-mergechangelogs';
2180 my $cb = "merge.$driver";
2181 my $attrs = '.git/info/attributes';
2182 ensuredir '.git/info';
2184 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2185 if (!open ATTRS, "<", $attrs) {
2186 $!==ENOENT or die "$attrs: $!";
2190 next if m{^debian/changelog\s};
2191 print NATTRS $_, "\n" or die $!;
2193 ATTRS->error and die $!;
2196 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2199 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2200 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2202 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2205 sub setup_useremail (;$) {
2207 return unless $always || access_cfg_bool(1, 'setup-useremail');
2210 my ($k, $envvar) = @_;
2211 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2212 return unless defined $v;
2213 set_local_git_config "user.$k", $v;
2216 $setup->('email', 'DEBEMAIL');
2217 $setup->('name', 'DEBFULLNAME');
2220 sub setup_new_tree () {
2221 setup_mergechangelogs();
2227 canonicalise_suite();
2228 badusage "dry run makes no sense with clone" unless act_local();
2229 my $hasgit = check_for_git();
2230 mkdir $dstdir or fail "create \`$dstdir': $!";
2232 runcmd @git, qw(init -q);
2233 my $giturl = access_giturl(1);
2234 if (defined $giturl) {
2235 open H, "> .git/HEAD" or die $!;
2236 print H "ref: ".lref()."\n" or die $!;
2238 runcmd @git, qw(remote add), 'origin', $giturl;
2241 progress "fetching existing git history";
2243 runcmd_ordryrun_local @git, qw(fetch origin);
2245 progress "starting new git history";
2247 fetch_from_archive() or no_such_package;
2248 my $vcsgiturl = $dsc->{'Vcs-Git'};
2249 if (length $vcsgiturl) {
2250 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2251 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2254 runcmd @git, qw(reset --hard), lrref();
2255 printdone "ready for work in $dstdir";
2259 if (check_for_git()) {
2262 fetch_from_archive() or no_such_package();
2263 printdone "fetched into ".lrref();
2268 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2270 printdone "fetched to ".lrref()." and merged into HEAD";
2273 sub check_not_dirty () {
2274 foreach my $f (qw(local-options local-patch-header)) {
2275 if (stat_exists "debian/source/$f") {
2276 fail "git tree contains debian/source/$f";
2280 return if $ignoredirty;
2282 my @cmd = (@git, qw(diff --quiet HEAD));
2284 $!=0; $?=-1; system @cmd;
2287 fail "working tree is dirty (does not match HEAD)";
2293 sub commit_admin ($) {
2296 runcmd_ordryrun_local @git, qw(commit -m), $m;
2299 sub commit_quilty_patch () {
2300 my $output = cmdoutput @git, qw(status --porcelain);
2302 foreach my $l (split /\n/, $output) {
2303 next unless $l =~ m/\S/;
2304 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2308 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2310 progress "nothing quilty to commit, ok.";
2313 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2314 runcmd_ordryrun_local @git, qw(add -f), @adds;
2315 commit_admin "Commit Debian 3.0 (quilt) metadata";
2318 sub get_source_format () {
2320 if (open F, "debian/source/options") {
2324 s/\s+$//; # ignore missing final newline
2326 my ($k, $v) = ($`, $'); #');
2327 $v =~ s/^"(.*)"$/$1/;
2333 F->error and die $!;
2336 die $! unless $!==&ENOENT;
2339 if (!open F, "debian/source/format") {
2340 die $! unless $!==&ENOENT;
2344 F->error and die $!;
2346 return ($_, \%options);
2351 return 0 unless $format eq '3.0 (quilt)';
2352 our $quilt_mode_warned;
2353 if ($quilt_mode eq 'nocheck') {
2354 progress "Not doing any fixup of \`$format' due to".
2355 " ----no-quilt-fixup or --quilt=nocheck"
2356 unless $quilt_mode_warned++;
2359 progress "Format \`$format', need to check/update patch stack"
2360 unless $quilt_mode_warned++;
2364 # An "infopair" is a tuple [ $thing, $what ]
2365 # (often $thing is a commit hash; $what is a description)
2367 sub infopair_cond_equal ($$) {
2369 $x->[0] eq $y->[0] or fail <<END;
2370 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2374 sub infopair_lrf_tag_lookup ($$) {
2375 my ($tagnames, $what) = @_;
2376 # $tagname may be an array ref
2377 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2378 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2379 foreach my $tagname (@tagnames) {
2380 my $lrefname = lrfetchrefs."/tags/$tagname";
2381 my $tagobj = $lrfetchrefs_f{$lrefname};
2382 next unless defined $tagobj;
2383 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2384 return [ git_rev_parse($tagobj), $what ];
2386 fail @tagnames==1 ? <<END : <<END;
2387 Wanted tag $what (@tagnames) on dgit server, but not found
2389 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2393 sub infopair_cond_ff ($$) {
2394 my ($anc,$desc) = @_;
2395 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2396 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2400 sub pseudomerge_version_check ($$) {
2401 my ($clogp, $archive_hash) = @_;
2403 my $arch_clogp = commit_getclogp $archive_hash;
2404 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2405 'version currently in archive' ];
2406 if (defined $overwrite_version) {
2407 if (length $overwrite_version) {
2408 infopair_cond_equal([ $overwrite_version,
2409 '--overwrite= version' ],
2412 my $v = $i_arch_v->[0];
2413 progress "Checking package changelog for archive version $v ...";
2415 my @xa = ("-f$v", "-t$v");
2416 my $vclogp = parsechangelog @xa;
2417 my $cv = [ (getfield $vclogp, 'Version'),
2418 "Version field from dpkg-parsechangelog @xa" ];
2419 infopair_cond_equal($i_arch_v, $cv);
2422 $@ =~ s/^dgit: //gm;
2424 "Perhaps debian/changelog does not mention $v ?";
2429 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2433 sub pseudomerge_make_commit ($$$$ $$) {
2434 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2435 $msg_cmd, $msg_msg) = @_;
2436 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2438 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2439 my $authline = clogp_authline $clogp;
2443 !defined $overwrite_version ? ""
2444 : !length $overwrite_version ? " --overwrite"
2445 : " --overwrite=".$overwrite_version;
2448 my $pmf = ".git/dgit/pseudomerge";
2449 open MC, ">", $pmf or die "$pmf $!";
2450 print MC <<END or die $!;
2453 parent $archive_hash
2463 return make_commit($pmf);
2466 sub splitbrain_pseudomerge ($$$$) {
2467 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2468 # => $merged_dgitview
2469 printdebug "splitbrain_pseudomerge...\n";
2471 # We: debian/PREVIOUS HEAD($maintview)
2472 # expect: o ----------------- o
2475 # a/d/PREVIOUS $dgitview
2478 # we do: `------------------ o
2482 printdebug "splitbrain_pseudomerge...\n";
2484 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2486 return $dgitview unless defined $archive_hash;
2488 if (!defined $overwrite_version) {
2489 progress "Checking that HEAD inciudes all changes in archive...";
2492 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2494 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2495 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2496 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2497 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2498 my $i_archive = [ $archive_hash, "current archive contents" ];
2500 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2502 infopair_cond_equal($i_dgit, $i_archive);
2503 infopair_cond_ff($i_dep14, $i_dgit);
2504 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2506 my $r = pseudomerge_make_commit
2507 $clogp, $dgitview, $archive_hash, $i_arch_v,
2508 "dgit --quilt=$quilt_mode",
2509 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2510 Declare fast forward from $overwrite_version
2512 Make fast forward from $i_arch_v->[0]
2515 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2519 sub plain_overwrite_pseudomerge ($$$) {
2520 my ($clogp, $head, $archive_hash) = @_;
2522 printdebug "plain_overwrite_pseudomerge...";
2524 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2526 my @tagformats = access_cfg_tagformats();
2528 map { $_->($i_arch_v->[0], access_basedistro) }
2529 (grep { m/^(?:old|hist)$/ } @tagformats)
2530 ? \&debiantags : \&debiantag_new;
2531 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2532 my $i_archive = [ $archive_hash, "current archive contents" ];
2534 infopair_cond_equal($i_overwr, $i_archive);
2536 return $head if is_fast_fwd $archive_hash, $head;
2538 my $m = "Declare fast forward from $i_arch_v->[0]";
2540 my $r = pseudomerge_make_commit
2541 $clogp, $head, $archive_hash, $i_arch_v,
2544 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2546 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2550 sub push_parse_changelog ($) {
2553 my $clogp = Dpkg::Control::Hash->new();
2554 $clogp->load($clogpfn) or die;
2556 $package = getfield $clogp, 'Source';
2557 my $cversion = getfield $clogp, 'Version';
2558 my $tag = debiantag($cversion, access_basedistro);
2559 runcmd @git, qw(check-ref-format), $tag;
2561 my $dscfn = dscfn($cversion);
2563 return ($clogp, $cversion, $dscfn);
2566 sub push_parse_dsc ($$$) {
2567 my ($dscfn,$dscfnwhat, $cversion) = @_;
2568 $dsc = parsecontrol($dscfn,$dscfnwhat);
2569 my $dversion = getfield $dsc, 'Version';
2570 my $dscpackage = getfield $dsc, 'Source';
2571 ($dscpackage eq $package && $dversion eq $cversion) or
2572 fail "$dscfn is for $dscpackage $dversion".
2573 " but debian/changelog is for $package $cversion";
2576 sub push_tagwants ($$$$) {
2577 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2580 TagFn => \&debiantag,
2585 if (defined $maintviewhead) {
2587 TagFn => \&debiantag_maintview,
2588 Objid => $maintviewhead,
2589 TfSuffix => '-maintview',
2593 foreach my $tw (@tagwants) {
2594 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2595 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2597 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2601 sub push_mktags ($$ $$ $) {
2603 $changesfile,$changesfilewhat,
2606 die unless $tagwants->[0]{View} eq 'dgit';
2608 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2609 $dsc->save("$dscfn.tmp") or die $!;
2611 my $changes = parsecontrol($changesfile,$changesfilewhat);
2612 foreach my $field (qw(Source Distribution Version)) {
2613 $changes->{$field} eq $clogp->{$field} or
2614 fail "changes field $field \`$changes->{$field}'".
2615 " does not match changelog \`$clogp->{$field}'";
2618 my $cversion = getfield $clogp, 'Version';
2619 my $clogsuite = getfield $clogp, 'Distribution';
2621 # We make the git tag by hand because (a) that makes it easier
2622 # to control the "tagger" (b) we can do remote signing
2623 my $authline = clogp_authline $clogp;
2624 my $delibs = join(" ", "",@deliberatelies);
2625 my $declaredistro = access_basedistro();
2629 my $tfn = $tw->{Tfn};
2630 my $head = $tw->{Objid};
2631 my $tag = $tw->{Tag};
2633 open TO, '>', $tfn->('.tmp') or die $!;
2634 print TO <<END or die $!;
2641 if ($tw->{View} eq 'dgit') {
2642 print TO <<END or die $!;
2643 $package release $cversion for $clogsuite ($csuite) [dgit]
2644 [dgit distro=$declaredistro$delibs]
2646 foreach my $ref (sort keys %previously) {
2647 print TO <<END or die $!;
2648 [dgit previously:$ref=$previously{$ref}]
2651 } elsif ($tw->{View} eq 'maint') {
2652 print TO <<END or die $!;
2653 $package release $cversion for $clogsuite ($csuite)
2654 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2657 die Dumper($tw)."?";
2662 my $tagobjfn = $tfn->('.tmp');
2664 if (!defined $keyid) {
2665 $keyid = access_cfg('keyid','RETURN-UNDEF');
2667 if (!defined $keyid) {
2668 $keyid = getfield $clogp, 'Maintainer';
2670 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2671 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2672 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2673 push @sign_cmd, $tfn->('.tmp');
2674 runcmd_ordryrun @sign_cmd;
2676 $tagobjfn = $tfn->('.signed.tmp');
2677 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2678 $tfn->('.tmp'), $tfn->('.tmp.asc');
2684 my @r = map { $mktag->($_); } @$tagwants;
2688 sub sign_changes ($) {
2689 my ($changesfile) = @_;
2691 my @debsign_cmd = @debsign;
2692 push @debsign_cmd, "-k$keyid" if defined $keyid;
2693 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2694 push @debsign_cmd, $changesfile;
2695 runcmd_ordryrun @debsign_cmd;
2700 printdebug "actually entering push\n";
2702 supplementary_message(<<'END');
2703 Push failed, while checking state of the archive.
2704 You can retry the push, after fixing the problem, if you like.
2706 if (check_for_git()) {
2709 my $archive_hash = fetch_from_archive();
2710 if (!$archive_hash) {
2712 fail "package appears to be new in this suite;".
2713 " if this is intentional, use --new";
2716 supplementary_message(<<'END');
2717 Push failed, while preparing your push.
2718 You can retry the push, after fixing the problem, if you like.
2721 need_tagformat 'new', "quilt mode $quilt_mode"
2722 if quiltmode_splitbrain;
2726 access_giturl(); # check that success is vaguely likely
2729 my $clogpfn = ".git/dgit/changelog.822.tmp";
2730 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2732 responder_send_file('parsed-changelog', $clogpfn);
2734 my ($clogp, $cversion, $dscfn) =
2735 push_parse_changelog("$clogpfn");
2737 my $dscpath = "$buildproductsdir/$dscfn";
2738 stat_exists $dscpath or
2739 fail "looked for .dsc $dscfn, but $!;".
2740 " maybe you forgot to build";
2742 responder_send_file('dsc', $dscpath);
2744 push_parse_dsc($dscpath, $dscfn, $cversion);
2746 my $format = getfield $dsc, 'Format';
2747 printdebug "format $format\n";
2749 my $actualhead = git_rev_parse('HEAD');
2750 my $dgithead = $actualhead;
2751 my $maintviewhead = undef;
2753 if (madformat($format)) {
2754 # user might have not used dgit build, so maybe do this now:
2755 if (quiltmode_splitbrain()) {
2756 my $upstreamversion = $clogp->{Version};
2757 $upstreamversion =~ s/-[^-]*$//;
2759 quilt_make_fake_dsc($upstreamversion);
2760 my ($dgitview, $cachekey) =
2761 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2763 "--quilt=$quilt_mode but no cached dgit view:
2764 perhaps tree changed since dgit build[-source] ?";
2766 $dgithead = splitbrain_pseudomerge($clogp,
2767 $actualhead, $dgitview,
2769 $maintviewhead = $actualhead;
2770 changedir '../../../..';
2771 prep_ud(); # so _only_subdir() works, below
2773 commit_quilty_patch();
2777 if (defined $overwrite_version && !defined $maintviewhead) {
2778 $dgithead = plain_overwrite_pseudomerge($clogp,
2786 if ($archive_hash) {
2787 if (is_fast_fwd($archive_hash, $dgithead)) {
2789 } elsif (deliberately_not_fast_forward) {
2792 fail "dgit push: HEAD is not a descendant".
2793 " of the archive's version.\n".
2794 "To overwrite the archive's contents,".
2795 " pass --overwrite[=VERSION].\n".
2796 "To rewind history, if permitted by the archive,".
2797 " use --deliberately-not-fast-forward.";
2802 progress "checking that $dscfn corresponds to HEAD";
2803 runcmd qw(dpkg-source -x --),
2804 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2805 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2806 check_for_vendor_patches() if madformat($dsc->{format});
2807 changedir '../../../..';
2808 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2809 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2810 debugcmd "+",@diffcmd;
2812 my $r = system @diffcmd;
2815 fail "$dscfn specifies a different tree to your HEAD commit;".
2816 " perhaps you forgot to build".
2817 ($diffopt eq '--exit-code' ? "" :
2818 " (run with -D to see full diff output)");
2823 if (!$changesfile) {
2824 my $pat = changespat $cversion;
2825 my @cs = glob "$buildproductsdir/$pat";
2826 fail "failed to find unique changes file".
2827 " (looked for $pat in $buildproductsdir);".
2828 " perhaps you need to use dgit -C"
2830 ($changesfile) = @cs;
2832 $changesfile = "$buildproductsdir/$changesfile";
2835 # Checks complete, we're going to try and go ahead:
2837 responder_send_file('changes',$changesfile);
2838 responder_send_command("param head $dgithead");
2839 responder_send_command("param csuite $csuite");
2840 responder_send_command("param tagformat $tagformat");
2841 if (defined $maintviewhead) {
2842 die unless ($protovsn//4) >= 4;
2843 responder_send_command("param maint-view $maintviewhead");
2846 if (deliberately_not_fast_forward) {
2847 git_for_each_ref(lrfetchrefs, sub {
2848 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2849 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2850 responder_send_command("previously $rrefname=$objid");
2851 $previously{$rrefname} = $objid;
2855 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2859 supplementary_message(<<'END');
2860 Push failed, while signing the tag.
2861 You can retry the push, after fixing the problem, if you like.
2863 # If we manage to sign but fail to record it anywhere, it's fine.
2864 if ($we_are_responder) {
2865 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2866 responder_receive_files('signed-tag', @tagobjfns);
2868 @tagobjfns = push_mktags($clogp,$dscpath,
2869 $changesfile,$changesfile,
2872 supplementary_message(<<'END');
2873 Push failed, *after* signing the tag.
2874 If you want to try again, you should use a new version number.
2877 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2879 foreach my $tw (@tagwants) {
2880 my $tag = $tw->{Tag};
2881 my $tagobjfn = $tw->{TagObjFn};
2883 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2884 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2885 runcmd_ordryrun_local
2886 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2889 supplementary_message(<<'END');
2890 Push failed, while updating the remote git repository - see messages above.
2891 If you want to try again, you should use a new version number.
2893 if (!check_for_git()) {
2894 create_remote_git_repo();
2897 my @pushrefs = $forceflag.$dgithead.":".rrref();
2898 foreach my $tw (@tagwants) {
2899 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2902 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2903 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2905 supplementary_message(<<'END');
2906 Push failed, after updating the remote git repository.
2907 If you want to try again, you must use a new version number.
2909 if ($we_are_responder) {
2910 my $dryrunsuffix = act_local() ? "" : ".tmp";
2911 responder_receive_files('signed-dsc-changes',
2912 "$dscpath$dryrunsuffix",
2913 "$changesfile$dryrunsuffix");
2916 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2918 progress "[new .dsc left in $dscpath.tmp]";
2920 sign_changes $changesfile;
2923 supplementary_message(<<END);
2924 Push failed, while uploading package(s) to the archive server.
2925 You can retry the upload of exactly these same files with dput of:
2927 If that .changes file is broken, you will need to use a new version
2928 number for your next attempt at the upload.
2930 my $host = access_cfg('upload-host','RETURN-UNDEF');
2931 my @hostarg = defined($host) ? ($host,) : ();
2932 runcmd_ordryrun @dput, @hostarg, $changesfile;
2933 printdone "pushed and uploaded $cversion";
2935 supplementary_message('');
2936 responder_send_command("complete");
2943 badusage "-p is not allowed with clone; specify as argument instead"
2944 if defined $package;
2947 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2948 ($package,$isuite) = @ARGV;
2949 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2950 ($package,$dstdir) = @ARGV;
2951 } elsif (@ARGV==3) {
2952 ($package,$isuite,$dstdir) = @ARGV;
2954 badusage "incorrect arguments to dgit clone";
2956 $dstdir ||= "$package";
2958 if (stat_exists $dstdir) {
2959 fail "$dstdir already exists";
2963 if ($rmonerror && !$dryrun_level) {
2964 $cwd_remove= getcwd();
2966 return unless defined $cwd_remove;
2967 if (!chdir "$cwd_remove") {
2968 return if $!==&ENOENT;
2969 die "chdir $cwd_remove: $!";
2972 rmtree($dstdir) or die "remove $dstdir: $!\n";
2973 } elsif (!grep { $! == $_ }
2974 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2976 print STDERR "check whether to remove $dstdir: $!\n";
2982 $cwd_remove = undef;
2985 sub branchsuite () {
2986 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2987 if ($branch =~ m#$lbranch_re#o) {
2994 sub fetchpullargs () {
2996 if (!defined $package) {
2997 my $sourcep = parsecontrol('debian/control','debian/control');
2998 $package = getfield $sourcep, 'Source';
3001 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3003 my $clogp = parsechangelog();
3004 $isuite = getfield $clogp, 'Distribution';
3006 canonicalise_suite();
3007 progress "fetching from suite $csuite";
3008 } elsif (@ARGV==1) {
3010 canonicalise_suite();
3012 badusage "incorrect arguments to dgit fetch or dgit pull";
3031 badusage "-p is not allowed with dgit push" if defined $package;
3033 my $clogp = parsechangelog();
3034 $package = getfield $clogp, 'Source';
3037 } elsif (@ARGV==1) {
3038 ($specsuite) = (@ARGV);
3040 badusage "incorrect arguments to dgit push";
3042 $isuite = getfield $clogp, 'Distribution';
3044 local ($package) = $existing_package; # this is a hack
3045 canonicalise_suite();
3047 canonicalise_suite();
3049 if (defined $specsuite &&
3050 $specsuite ne $isuite &&
3051 $specsuite ne $csuite) {
3052 fail "dgit push: changelog specifies $isuite ($csuite)".
3053 " but command line specifies $specsuite";
3058 #---------- remote commands' implementation ----------
3060 sub cmd_remote_push_build_host {
3061 my ($nrargs) = shift @ARGV;
3062 my (@rargs) = @ARGV[0..$nrargs-1];
3063 @ARGV = @ARGV[$nrargs..$#ARGV];
3065 my ($dir,$vsnwant) = @rargs;
3066 # vsnwant is a comma-separated list; we report which we have
3067 # chosen in our ready response (so other end can tell if they
3070 $we_are_responder = 1;
3071 $us .= " (build host)";
3075 open PI, "<&STDIN" or die $!;
3076 open STDIN, "/dev/null" or die $!;
3077 open PO, ">&STDOUT" or die $!;
3079 open STDOUT, ">&STDERR" or die $!;
3083 ($protovsn) = grep {
3084 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3085 } @rpushprotovsn_support;
3087 fail "build host has dgit rpush protocol versions ".
3088 (join ",", @rpushprotovsn_support).
3089 " but invocation host has $vsnwant"
3090 unless defined $protovsn;
3092 responder_send_command("dgit-remote-push-ready $protovsn");
3093 rpush_handle_protovsn_bothends();
3098 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3099 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3100 # a good error message)
3102 sub rpush_handle_protovsn_bothends () {
3103 if ($protovsn < 4) {
3104 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3113 my $report = i_child_report();
3114 if (defined $report) {
3115 printdebug "($report)\n";
3116 } elsif ($i_child_pid) {
3117 printdebug "(killing build host child $i_child_pid)\n";
3118 kill 15, $i_child_pid;
3120 if (defined $i_tmp && !defined $initiator_tempdir) {
3122 eval { rmtree $i_tmp; };
3126 END { i_cleanup(); }
3129 my ($base,$selector,@args) = @_;
3130 $selector =~ s/\-/_/g;
3131 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3138 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3146 push @rargs, join ",", @rpushprotovsn_support;
3149 push @rdgit, @ropts;
3150 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3152 my @cmd = (@ssh, $host, shellquote @rdgit);
3155 if (defined $initiator_tempdir) {
3156 rmtree $initiator_tempdir;
3157 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3158 $i_tmp = $initiator_tempdir;
3162 $i_child_pid = open2(\*RO, \*RI, @cmd);
3164 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3165 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3166 $supplementary_message = '' unless $protovsn >= 3;
3168 fail "rpush negotiated protocol version $protovsn".
3169 " which does not support quilt mode $quilt_mode"
3170 if quiltmode_splitbrain;
3172 rpush_handle_protovsn_bothends();
3174 my ($icmd,$iargs) = initiator_expect {
3175 m/^(\S+)(?: (.*))?$/;
3178 i_method "i_resp", $icmd, $iargs;
3182 sub i_resp_progress ($) {
3184 my $msg = protocol_read_bytes \*RO, $rhs;
3188 sub i_resp_supplementary_message ($) {
3190 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3193 sub i_resp_complete {
3194 my $pid = $i_child_pid;
3195 $i_child_pid = undef; # prevents killing some other process with same pid
3196 printdebug "waiting for build host child $pid...\n";
3197 my $got = waitpid $pid, 0;
3198 die $! unless $got == $pid;
3199 die "build host child failed $?" if $?;
3202 printdebug "all done\n";
3206 sub i_resp_file ($) {
3208 my $localname = i_method "i_localname", $keyword;
3209 my $localpath = "$i_tmp/$localname";
3210 stat_exists $localpath and
3211 badproto \*RO, "file $keyword ($localpath) twice";
3212 protocol_receive_file \*RO, $localpath;
3213 i_method "i_file", $keyword;
3218 sub i_resp_param ($) {
3219 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3223 sub i_resp_previously ($) {
3224 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3225 or badproto \*RO, "bad previously spec";
3226 my $r = system qw(git check-ref-format), $1;
3227 die "bad previously ref spec ($r)" if $r;
3228 $previously{$1} = $2;
3233 sub i_resp_want ($) {
3235 die "$keyword ?" if $i_wanted{$keyword}++;
3236 my @localpaths = i_method "i_want", $keyword;
3237 printdebug "[[ $keyword @localpaths\n";
3238 foreach my $localpath (@localpaths) {
3239 protocol_send_file \*RI, $localpath;
3241 print RI "files-end\n" or die $!;
3244 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3246 sub i_localname_parsed_changelog {
3247 return "remote-changelog.822";
3249 sub i_file_parsed_changelog {
3250 ($i_clogp, $i_version, $i_dscfn) =
3251 push_parse_changelog "$i_tmp/remote-changelog.822";
3252 die if $i_dscfn =~ m#/|^\W#;
3255 sub i_localname_dsc {
3256 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3261 sub i_localname_changes {
3262 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3263 $i_changesfn = $i_dscfn;
3264 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3265 return $i_changesfn;
3267 sub i_file_changes { }
3269 sub i_want_signed_tag {
3270 printdebug Dumper(\%i_param, $i_dscfn);
3271 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3272 && defined $i_param{'csuite'}
3273 or badproto \*RO, "premature desire for signed-tag";
3274 my $head = $i_param{'head'};
3275 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3277 my $maintview = $i_param{'maint-view'};
3278 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3281 if ($protovsn >= 4) {
3282 my $p = $i_param{'tagformat'} // '<undef>';
3284 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3287 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3289 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3291 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3294 push_mktags $i_clogp, $i_dscfn,
3295 $i_changesfn, 'remote changes',
3299 sub i_want_signed_dsc_changes {
3300 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3301 sign_changes $i_changesfn;
3302 return ($i_dscfn, $i_changesfn);
3305 #---------- building etc. ----------
3311 #----- `3.0 (quilt)' handling -----
3313 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3315 sub quiltify_dpkg_commit ($$$;$) {
3316 my ($patchname,$author,$msg, $xinfo) = @_;
3320 my $descfn = ".git/dgit/quilt-description.tmp";
3321 open O, '>', $descfn or die "$descfn: $!";
3324 $msg =~ s/^\s+$/ ./mg;
3325 print O <<END or die $!;
3335 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3336 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3337 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3338 runcmd @dpkgsource, qw(--commit .), $patchname;
3342 sub quiltify_trees_differ ($$;$$) {
3343 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3344 # returns true iff the two tree objects differ other than in debian/
3345 # with $finegrained,
3346 # returns bitmask 01 - differ in upstream files except .gitignore
3347 # 02 - differ in .gitignore
3348 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3349 # is set for each modified .gitignore filename $fn
3351 my @cmd = (@git, qw(diff-tree --name-only -z));
3352 push @cmd, qw(-r) if $finegrained;
3354 my $diffs= cmdoutput @cmd;
3356 foreach my $f (split /\0/, $diffs) {
3357 next if $f =~ m#^debian(?:/.*)?$#s;
3358 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3359 $r |= $isignore ? 02 : 01;
3360 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3362 printdebug "quiltify_trees_differ $x $y => $r\n";
3366 sub quiltify_tree_sentinelfiles ($) {
3367 # lists the `sentinel' files present in the tree
3369 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3370 qw(-- debian/rules debian/control);
3375 sub quiltify_splitbrain_needed () {
3376 if (!$split_brain) {
3377 progress "dgit view: changes are required...";
3378 runcmd @git, qw(checkout -q -b dgit-view);
3383 sub quiltify_splitbrain ($$$$$$) {
3384 my ($clogp, $unapplied, $headref, $diffbits,
3385 $editedignores, $cachekey) = @_;
3386 if ($quilt_mode !~ m/gbp|dpm/) {
3387 # treat .gitignore just like any other upstream file
3388 $diffbits = { %$diffbits };
3389 $_ = !!$_ foreach values %$diffbits;
3391 # We would like any commits we generate to be reproducible
3392 my @authline = clogp_authline($clogp);
3393 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3394 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3395 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3397 if ($quilt_mode =~ m/gbp|unapplied/ &&
3398 ($diffbits->{H2O} & 01)) {
3400 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3401 " but git tree differs from orig in upstream files.";
3402 if (!stat_exists "debian/patches") {
3404 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3408 if ($quilt_mode =~ m/dpm/ &&
3409 ($diffbits->{H2A} & 01)) {
3411 --quilt=$quilt_mode specified, implying patches-applied git tree
3412 but git tree differs from result of applying debian/patches to upstream
3415 if ($quilt_mode =~ m/gbp|unapplied/ &&
3416 ($diffbits->{O2A} & 01)) { # some patches
3417 quiltify_splitbrain_needed();
3418 progress "dgit view: creating patches-applied version using gbp pq";
3419 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3420 # gbp pq import creates a fresh branch; push back to dgit-view
3421 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3422 runcmd @git, qw(checkout -q dgit-view);
3424 if ($quilt_mode =~ m/gbp|dpm/ &&
3425 ($diffbits->{O2A} & 02)) {
3427 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3428 tool which does not create patches for changes to upstream
3429 .gitignores: but, such patches exist in debian/patches.
3432 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3433 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3434 quiltify_splitbrain_needed();
3435 progress "dgit view: creating patch to represent .gitignore changes";
3436 ensuredir "debian/patches";
3437 my $gipatch = "debian/patches/auto-gitignore";
3438 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3439 stat GIPATCH or die "$gipatch: $!";
3440 fail "$gipatch already exists; but want to create it".
3441 " to record .gitignore changes" if (stat _)[7];
3442 print GIPATCH <<END or die "$gipatch: $!";
3443 Subject: Update .gitignore from Debian packaging branch
3445 The Debian packaging git branch contains these updates to the upstream
3446 .gitignore file(s). This patch is autogenerated, to provide these
3447 updates to users of the official Debian archive view of the package.
3449 [dgit version $our_version]
3452 close GIPATCH or die "$gipatch: $!";
3453 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3454 $unapplied, $headref, "--", sort keys %$editedignores;
3455 open SERIES, "+>>", "debian/patches/series" or die $!;
3456 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3458 defined read SERIES, $newline, 1 or die $!;
3459 print SERIES "\n" or die $! unless $newline eq "\n";
3460 print SERIES "auto-gitignore\n" or die $!;
3461 close SERIES or die $!;
3462 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3463 commit_admin "Commit patch to update .gitignore";
3466 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3468 changedir '../../../..';
3469 ensuredir ".git/logs/refs/dgit-intern";
3470 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3472 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3475 progress "dgit view: created (commit id $dgitview)";
3477 changedir '.git/dgit/unpack/work';
3480 sub quiltify ($$$$) {
3481 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3483 # Quilt patchification algorithm
3485 # We search backwards through the history of the main tree's HEAD
3486 # (T) looking for a start commit S whose tree object is identical
3487 # to to the patch tip tree (ie the tree corresponding to the
3488 # current dpkg-committed patch series). For these purposes
3489 # `identical' disregards anything in debian/ - this wrinkle is
3490 # necessary because dpkg-source treates debian/ specially.
3492 # We can only traverse edges where at most one of the ancestors'
3493 # trees differs (in changes outside in debian/). And we cannot
3494 # handle edges which change .pc/ or debian/patches. To avoid
3495 # going down a rathole we avoid traversing edges which introduce
3496 # debian/rules or debian/control. And we set a limit on the
3497 # number of edges we are willing to look at.
3499 # If we succeed, we walk forwards again. For each traversed edge
3500 # PC (with P parent, C child) (starting with P=S and ending with
3501 # C=T) to we do this:
3503 # - dpkg-source --commit with a patch name and message derived from C
3504 # After traversing PT, we git commit the changes which
3505 # should be contained within debian/patches.
3507 # The search for the path S..T is breadth-first. We maintain a
3508 # todo list containing search nodes. A search node identifies a
3509 # commit, and looks something like this:
3511 # Commit => $git_commit_id,
3512 # Child => $c, # or undef if P=T
3513 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3514 # Nontrivial => true iff $p..$c has relevant changes
3521 my %considered; # saves being exponential on some weird graphs
3523 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3526 my ($search,$whynot) = @_;
3527 printdebug " search NOT $search->{Commit} $whynot\n";
3528 $search->{Whynot} = $whynot;
3529 push @nots, $search;
3530 no warnings qw(exiting);
3539 my $c = shift @todo;
3540 next if $considered{$c->{Commit}}++;
3542 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3544 printdebug "quiltify investigate $c->{Commit}\n";
3547 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3548 printdebug " search finished hooray!\n";
3553 if ($quilt_mode eq 'nofix') {
3554 fail "quilt fixup required but quilt mode is \`nofix'\n".
3555 "HEAD commit $c->{Commit} differs from tree implied by ".
3556 " debian/patches (tree object $oldtiptree)";
3558 if ($quilt_mode eq 'smash') {
3559 printdebug " search quitting smash\n";
3563 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3564 $not->($c, "has $c_sentinels not $t_sentinels")
3565 if $c_sentinels ne $t_sentinels;
3567 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3568 $commitdata =~ m/\n\n/;
3570 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3571 @parents = map { { Commit => $_, Child => $c } } @parents;
3573 $not->($c, "root commit") if !@parents;
3575 foreach my $p (@parents) {
3576 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3578 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3579 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3581 foreach my $p (@parents) {
3582 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3584 my @cmd= (@git, qw(diff-tree -r --name-only),
3585 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3586 my $patchstackchange = cmdoutput @cmd;
3587 if (length $patchstackchange) {
3588 $patchstackchange =~ s/\n/,/g;
3589 $not->($p, "changed $patchstackchange");
3592 printdebug " search queue P=$p->{Commit} ",
3593 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3599 printdebug "quiltify want to smash\n";
3602 my $x = $_[0]{Commit};
3603 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3606 my $reportnot = sub {
3608 my $s = $abbrev->($notp);
3609 my $c = $notp->{Child};
3610 $s .= "..".$abbrev->($c) if $c;
3611 $s .= ": ".$notp->{Whynot};
3614 if ($quilt_mode eq 'linear') {
3615 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3616 foreach my $notp (@nots) {
3617 print STDERR "$us: ", $reportnot->($notp), "\n";
3619 print STDERR "$us: $_\n" foreach @$failsuggestion;
3620 fail "quilt fixup naive history linearisation failed.\n".
3621 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3622 } elsif ($quilt_mode eq 'smash') {
3623 } elsif ($quilt_mode eq 'auto') {
3624 progress "quilt fixup cannot be linear, smashing...";
3626 die "$quilt_mode ?";
3629 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3630 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3632 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3634 quiltify_dpkg_commit "auto-$version-$target-$time",
3635 (getfield $clogp, 'Maintainer'),
3636 "Automatically generated patch ($clogp->{Version})\n".
3637 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3641 progress "quiltify linearisation planning successful, executing...";
3643 for (my $p = $sref_S;
3644 my $c = $p->{Child};
3646 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3647 next unless $p->{Nontrivial};
3649 my $cc = $c->{Commit};
3651 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3652 $commitdata =~ m/\n\n/ or die "$c ?";
3655 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3658 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3661 my $patchname = $title;
3662 $patchname =~ s/[.:]$//;
3663 $patchname =~ y/ A-Z/-a-z/;
3664 $patchname =~ y/-a-z0-9_.+=~//cd;
3665 $patchname =~ s/^\W/x-$&/;
3666 $patchname = substr($patchname,0,40);
3669 stat "debian/patches/$patchname$index";
3671 $!==ENOENT or die "$patchname$index $!";
3673 runcmd @git, qw(checkout -q), $cc;
3675 # We use the tip's changelog so that dpkg-source doesn't
3676 # produce complaining messages from dpkg-parsechangelog. None
3677 # of the information dpkg-source gets from the changelog is
3678 # actually relevant - it gets put into the original message
3679 # which dpkg-source provides our stunt editor, and then
3681 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3683 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3684 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3686 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3689 runcmd @git, qw(checkout -q master);
3692 sub build_maybe_quilt_fixup () {
3693 my ($format,$fopts) = get_source_format;
3694 return unless madformat $format;
3697 check_for_vendor_patches();
3699 if (quiltmode_splitbrain) {
3700 foreach my $needtf (qw(new maint)) {
3701 next if grep { $_ eq $needtf } access_cfg_tagformats;
3703 quilt mode $quilt_mode requires split view so server needs to support
3704 both "new" and "maint" tag formats, but config says it doesn't.
3709 my $clogp = parsechangelog();
3710 my $headref = git_rev_parse('HEAD');
3715 my $upstreamversion=$version;
3716 $upstreamversion =~ s/-[^-]*$//;
3718 if ($fopts->{'single-debian-patch'}) {
3719 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3721 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3724 die 'bug' if $split_brain && !$need_split_build_invocation;
3726 changedir '../../../..';
3727 runcmd_ordryrun_local
3728 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3731 sub quilt_fixup_mkwork ($) {
3734 mkdir "work" or die $!;
3736 mktree_in_ud_here();
3737 runcmd @git, qw(reset -q --hard), $headref;
3740 sub quilt_fixup_linkorigs ($$) {
3741 my ($upstreamversion, $fn) = @_;
3742 # calls $fn->($leafname);
3744 foreach my $f (<../../../../*>) { #/){
3745 my $b=$f; $b =~ s{.*/}{};
3747 local ($debuglevel) = $debuglevel-1;
3748 printdebug "QF linkorigs $b, $f ?\n";
3750 next unless is_orig_file $b, srcfn $upstreamversion,'';
3751 printdebug "QF linkorigs $b, $f Y\n";
3752 link_ltarget $f, $b or die "$b $!";
3757 sub quilt_fixup_delete_pc () {
3758 runcmd @git, qw(rm -rqf .pc);
3759 commit_admin "Commit removal of .pc (quilt series tracking data)";
3762 sub quilt_fixup_singlepatch ($$$) {
3763 my ($clogp, $headref, $upstreamversion) = @_;
3765 progress "starting quiltify (single-debian-patch)";
3767 # dpkg-source --commit generates new patches even if
3768 # single-debian-patch is in debian/source/options. In order to
3769 # get it to generate debian/patches/debian-changes, it is
3770 # necessary to build the source package.
3772 quilt_fixup_linkorigs($upstreamversion, sub { });
3773 quilt_fixup_mkwork($headref);
3775 rmtree("debian/patches");
3777 runcmd @dpkgsource, qw(-b .);
3779 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3780 rename srcfn("$upstreamversion", "/debian/patches"),
3781 "work/debian/patches";
3784 commit_quilty_patch();
3787 sub quilt_make_fake_dsc ($) {
3788 my ($upstreamversion) = @_;
3790 my $fakeversion="$upstreamversion-~~DGITFAKE";
3792 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3793 print $fakedsc <<END or die $!;
3796 Version: $fakeversion
3800 my $dscaddfile=sub {
3803 my $md = new Digest::MD5;
3805 my $fh = new IO::File $b, '<' or die "$b $!";
3810 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3813 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3815 my @files=qw(debian/source/format debian/rules
3816 debian/control debian/changelog);
3817 foreach my $maybe (qw(debian/patches debian/source/options
3818 debian/tests/control)) {
3819 next unless stat_exists "../../../$maybe";
3820 push @files, $maybe;
3823 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3824 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3826 $dscaddfile->($debtar);
3827 close $fakedsc or die $!;
3830 sub quilt_check_splitbrain_cache ($$) {
3831 my ($headref, $upstreamversion) = @_;
3832 # Called only if we are in (potentially) split brain mode.
3834 # Computes the cache key and looks in the cache.
3835 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3837 my $splitbrain_cachekey;
3840 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3841 # we look in the reflog of dgit-intern/quilt-cache
3842 # we look for an entry whose message is the key for the cache lookup
3843 my @cachekey = (qw(dgit), $our_version);
3844 push @cachekey, $upstreamversion;
3845 push @cachekey, $quilt_mode;
3846 push @cachekey, $headref;
3848 push @cachekey, hashfile('fake.dsc');
3850 my $srcshash = Digest::SHA->new(256);
3851 my %sfs = ( %INC, '$0(dgit)' => $0 );
3852 foreach my $sfk (sort keys %sfs) {
3853 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3854 $srcshash->add($sfk," ");
3855 $srcshash->add(hashfile($sfs{$sfk}));
3856 $srcshash->add("\n");
3858 push @cachekey, $srcshash->hexdigest();
3859 $splitbrain_cachekey = "@cachekey";
3861 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3863 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3864 debugcmd "|(probably)",@cmd;
3865 my $child = open GC, "-|"; defined $child or die $!;
3867 chdir '../../..' or die $!;
3868 if (!stat ".git/logs/refs/$splitbraincache") {
3869 $! == ENOENT or die $!;
3870 printdebug ">(no reflog)\n";
3877 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3878 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3881 quilt_fixup_mkwork($headref);
3882 if ($cachehit ne $headref) {
3883 progress "dgit view: found cached (commit id $cachehit)";
3884 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3886 return ($cachehit, $splitbrain_cachekey);
3888 progress "dgit view: found cached, no changes required";
3889 return ($headref, $splitbrain_cachekey);
3891 die $! if GC->error;
3892 failedcmd unless close GC;
3894 printdebug "splitbrain cache miss\n";
3895 return (undef, $splitbrain_cachekey);
3898 sub quilt_fixup_multipatch ($$$) {
3899 my ($clogp, $headref, $upstreamversion) = @_;
3901 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3904 # - honour any existing .pc in case it has any strangeness
3905 # - determine the git commit corresponding to the tip of
3906 # the patch stack (if there is one)
3907 # - if there is such a git commit, convert each subsequent
3908 # git commit into a quilt patch with dpkg-source --commit
3909 # - otherwise convert all the differences in the tree into
3910 # a single git commit
3914 # Our git tree doesn't necessarily contain .pc. (Some versions of
3915 # dgit would include the .pc in the git tree.) If there isn't
3916 # one, we need to generate one by unpacking the patches that we
3919 # We first look for a .pc in the git tree. If there is one, we
3920 # will use it. (This is not the normal case.)
3922 # Otherwise need to regenerate .pc so that dpkg-source --commit
3923 # can work. We do this as follows:
3924 # 1. Collect all relevant .orig from parent directory
3925 # 2. Generate a debian.tar.gz out of
3926 # debian/{patches,rules,source/format,source/options}
3927 # 3. Generate a fake .dsc containing just these fields:
3928 # Format Source Version Files
3929 # 4. Extract the fake .dsc
3930 # Now the fake .dsc has a .pc directory.
3931 # (In fact we do this in every case, because in future we will
3932 # want to search for a good base commit for generating patches.)
3934 # Then we can actually do the dpkg-source --commit
3935 # 1. Make a new working tree with the same object
3936 # store as our main tree and check out the main
3938 # 2. Copy .pc from the fake's extraction, if necessary
3939 # 3. Run dpkg-source --commit
3940 # 4. If the result has changes to debian/, then
3941 # - git-add them them
3942 # - git-add .pc if we had a .pc in-tree
3944 # 5. If we had a .pc in-tree, delete it, and git-commit
3945 # 6. Back in the main tree, fast forward to the new HEAD
3947 # Another situation we may have to cope with is gbp-style
3948 # patches-unapplied trees.
3950 # We would want to detect these, so we know to escape into
3951 # quilt_fixup_gbp. However, this is in general not possible.
3952 # Consider a package with a one patch which the dgit user reverts
3953 # (with git-revert or the moral equivalent).
3955 # That is indistinguishable in contents from a patches-unapplied
3956 # tree. And looking at the history to distinguish them is not
3957 # useful because the user might have made a confusing-looking git
3958 # history structure (which ought to produce an error if dgit can't
3959 # cope, not a silent reintroduction of an unwanted patch).
3961 # So gbp users will have to pass an option. But we can usually
3962 # detect their failure to do so: if the tree is not a clean
3963 # patches-applied tree, quilt linearisation fails, but the tree
3964 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3965 # they want --quilt=unapplied.
3967 # To help detect this, when we are extracting the fake dsc, we
3968 # first extract it with --skip-patches, and then apply the patches
3969 # afterwards with dpkg-source --before-build. That lets us save a
3970 # tree object corresponding to .origs.
3972 my $splitbrain_cachekey;
3974 quilt_make_fake_dsc($upstreamversion);
3976 if (quiltmode_splitbrain()) {
3978 ($cachehit, $splitbrain_cachekey) =
3979 quilt_check_splitbrain_cache($headref, $upstreamversion);
3980 return if $cachehit;
3984 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3986 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3987 rename $fakexdir, "fake" or die "$fakexdir $!";
3991 remove_stray_gits();
3992 mktree_in_ud_here();
3996 runcmd @git, qw(add -Af .);
3997 my $unapplied=git_write_tree();
3998 printdebug "fake orig tree object $unapplied\n";
4003 'exec dpkg-source --before-build . >/dev/null';
4007 quilt_fixup_mkwork($headref);
4010 if (stat_exists ".pc") {
4012 progress "Tree already contains .pc - will use it then delete it.";
4015 rename '../fake/.pc','.pc' or die $!;
4018 changedir '../fake';
4020 runcmd @git, qw(add -Af .);
4021 my $oldtiptree=git_write_tree();
4022 printdebug "fake o+d/p tree object $unapplied\n";
4023 changedir '../work';
4026 # We calculate some guesswork now about what kind of tree this might
4027 # be. This is mostly for error reporting.
4032 # O = orig, without patches applied
4033 # A = "applied", ie orig with H's debian/patches applied
4034 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4035 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4036 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4040 foreach my $b (qw(01 02)) {
4041 foreach my $v (qw(H2O O2A H2A)) {
4042 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4045 printdebug "differences \@dl @dl.\n";
4048 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4049 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4050 $dl[0], $dl[1], $dl[3], $dl[4],
4054 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4055 push @failsuggestion, "This might be a patches-unapplied branch.";
4056 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4057 push @failsuggestion, "This might be a patches-applied branch.";
4059 push @failsuggestion, "Maybe you need to specify one of".
4060 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4062 if (quiltmode_splitbrain()) {
4063 quiltify_splitbrain($clogp, $unapplied, $headref,
4064 $diffbits, \%editedignores,
4065 $splitbrain_cachekey);
4069 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4070 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4072 if (!open P, '>>', ".pc/applied-patches") {
4073 $!==&ENOENT or die $!;
4078 commit_quilty_patch();
4080 if ($mustdeletepc) {
4081 quilt_fixup_delete_pc();
4085 sub quilt_fixup_editor () {
4086 my $descfn = $ENV{$fakeeditorenv};
4087 my $editing = $ARGV[$#ARGV];
4088 open I1, '<', $descfn or die "$descfn: $!";
4089 open I2, '<', $editing or die "$editing: $!";
4090 unlink $editing or die "$editing: $!";
4091 open O, '>', $editing or die "$editing: $!";
4092 while (<I1>) { print O or die $!; } I1->error and die $!;
4095 $copying ||= m/^\-\-\- /;
4096 next unless $copying;
4099 I2->error and die $!;
4104 sub maybe_apply_patches_dirtily () {
4105 return unless $quilt_mode =~ m/gbp|unapplied/;
4106 print STDERR <<END or die $!;
4108 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4109 dgit: Have to apply the patches - making the tree dirty.
4110 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4113 $patches_applied_dirtily = 01;
4114 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4115 runcmd qw(dpkg-source --before-build .);
4118 sub maybe_unapply_patches_again () {
4119 progress "dgit: Unapplying patches again to tidy up the tree."
4120 if $patches_applied_dirtily;
4121 runcmd qw(dpkg-source --after-build .)
4122 if $patches_applied_dirtily & 01;
4124 if $patches_applied_dirtily & 02;
4125 $patches_applied_dirtily = 0;
4128 #----- other building -----
4130 our $clean_using_builder;
4131 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4132 # clean the tree before building (perhaps invoked indirectly by
4133 # whatever we are using to run the build), rather than separately
4134 # and explicitly by us.
4137 return if $clean_using_builder;
4138 if ($cleanmode eq 'dpkg-source') {
4139 maybe_apply_patches_dirtily();
4140 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4141 } elsif ($cleanmode eq 'dpkg-source-d') {
4142 maybe_apply_patches_dirtily();
4143 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4144 } elsif ($cleanmode eq 'git') {
4145 runcmd_ordryrun_local @git, qw(clean -xdf);
4146 } elsif ($cleanmode eq 'git-ff') {
4147 runcmd_ordryrun_local @git, qw(clean -xdff);
4148 } elsif ($cleanmode eq 'check') {
4149 my $leftovers = cmdoutput @git, qw(clean -xdn);
4150 if (length $leftovers) {
4151 print STDERR $leftovers, "\n" or die $!;
4152 fail "tree contains uncommitted files and --clean=check specified";
4154 } elsif ($cleanmode eq 'none') {
4161 badusage "clean takes no additional arguments" if @ARGV;
4164 maybe_unapply_patches_again();
4169 badusage "-p is not allowed when building" if defined $package;
4172 my $clogp = parsechangelog();
4173 $isuite = getfield $clogp, 'Distribution';
4174 $package = getfield $clogp, 'Source';
4175 $version = getfield $clogp, 'Version';
4176 build_maybe_quilt_fixup();
4178 my $pat = changespat $version;
4179 foreach my $f (glob "$buildproductsdir/$pat") {
4181 unlink $f or fail "remove old changes file $f: $!";
4183 progress "would remove $f";
4189 sub changesopts_initial () {
4190 my @opts =@changesopts[1..$#changesopts];
4193 sub changesopts_version () {
4194 if (!defined $changes_since_version) {
4195 my @vsns = archive_query('archive_query');
4196 my @quirk = access_quirk();
4197 if ($quirk[0] eq 'backports') {
4198 local $isuite = $quirk[2];
4200 canonicalise_suite();
4201 push @vsns, archive_query('archive_query');
4204 @vsns = map { $_->[0] } @vsns;
4205 @vsns = sort { -version_compare($a, $b) } @vsns;
4206 $changes_since_version = $vsns[0];
4207 progress "changelog will contain changes since $vsns[0]";
4209 $changes_since_version = '_';
4210 progress "package seems new, not specifying -v<version>";
4213 if ($changes_since_version ne '_') {
4214 return ("-v$changes_since_version");
4220 sub changesopts () {
4221 return (changesopts_initial(), changesopts_version());
4224 sub massage_dbp_args ($;$) {
4225 my ($cmd,$xargs) = @_;
4228 # - if we're going to split the source build out so we can
4229 # do strange things to it, massage the arguments to dpkg-buildpackage
4230 # so that the main build doessn't build source (or add an argument
4231 # to stop it building source by default).
4233 # - add -nc to stop dpkg-source cleaning the source tree,
4234 # unless we're not doing a split build and want dpkg-source
4235 # as cleanmode, in which case we can do nothing
4238 # 0 - source will NOT need to be built separately by caller
4239 # +1 - source will need to be built separately by caller
4240 # +2 - source will need to be built separately by caller AND
4241 # dpkg-buildpackage should not in fact be run at all!
4242 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4243 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4244 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4245 $clean_using_builder = 1;
4248 # -nc has the side effect of specifying -b if nothing else specified
4249 # and some combinations of -S, -b, et al, are errors, rather than
4250 # later simply overriding earlie. So we need to:
4251 # - search the command line for these options
4252 # - pick the last one
4253 # - perhaps add our own as a default
4254 # - perhaps adjust it to the corresponding non-source-building version
4256 foreach my $l ($cmd, $xargs) {
4258 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4261 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4263 if ($need_split_build_invocation) {
4264 printdebug "massage split $dmode.\n";
4265 $r = $dmode =~ m/[S]/ ? +2 :
4266 $dmode =~ y/gGF/ABb/ ? +1 :
4267 $dmode =~ m/[ABb]/ ? 0 :
4270 printdebug "massage done $r $dmode.\n";
4272 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4277 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4278 my $wantsrc = massage_dbp_args \@dbp;
4285 push @dbp, changesopts_version();
4286 maybe_apply_patches_dirtily();
4287 runcmd_ordryrun_local @dbp;
4289 maybe_unapply_patches_again();
4290 printdone "build successful\n";
4294 my @dbp = @dpkgbuildpackage;
4296 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4299 if (length executable_on_path('git-buildpackage')) {
4300 @cmd = qw(git-buildpackage);
4302 @cmd = qw(gbp buildpackage);
4304 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4309 if (!$clean_using_builder) {
4310 push @cmd, '--git-cleaner=true';
4314 maybe_unapply_patches_again();
4316 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4317 canonicalise_suite();
4318 push @cmd, "--git-debian-branch=".lbranch();
4320 push @cmd, changesopts();
4321 runcmd_ordryrun_local @cmd, @ARGV;
4323 printdone "build successful\n";
4325 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4328 my $our_cleanmode = $cleanmode;
4329 if ($need_split_build_invocation) {
4330 # Pretend that clean is being done some other way. This
4331 # forces us not to try to use dpkg-buildpackage to clean and
4332 # build source all in one go; and instead we run dpkg-source
4333 # (and build_prep() will do the clean since $clean_using_builder
4335 $our_cleanmode = 'ELSEWHERE';
4337 if ($our_cleanmode =~ m/^dpkg-source/) {
4338 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4339 $clean_using_builder = 1;
4342 $sourcechanges = changespat $version,'source';
4344 unlink "../$sourcechanges" or $!==ENOENT
4345 or fail "remove $sourcechanges: $!";
4347 $dscfn = dscfn($version);
4348 if ($our_cleanmode eq 'dpkg-source') {
4349 maybe_apply_patches_dirtily();
4350 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4352 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4353 maybe_apply_patches_dirtily();
4354 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4357 my @cmd = (@dpkgsource, qw(-b --));
4360 runcmd_ordryrun_local @cmd, "work";
4361 my @udfiles = <${package}_*>;
4362 changedir "../../..";
4363 foreach my $f (@udfiles) {
4364 printdebug "source copy, found $f\n";
4367 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4368 $f eq srcfn($version, $&));
4369 printdebug "source copy, found $f - renaming\n";
4370 rename "$ud/$f", "../$f" or $!==ENOENT
4371 or fail "put in place new source file ($f): $!";
4374 my $pwd = must_getcwd();
4375 my $leafdir = basename $pwd;
4377 runcmd_ordryrun_local @cmd, $leafdir;
4380 runcmd_ordryrun_local qw(sh -ec),
4381 'exec >$1; shift; exec "$@"','x',
4382 "../$sourcechanges",
4383 @dpkggenchanges, qw(-S), changesopts();
4387 sub cmd_build_source {
4388 badusage "build-source takes no additional arguments" if @ARGV;
4390 maybe_unapply_patches_again();
4391 printdone "source built, results in $dscfn and $sourcechanges";
4396 my $pat = changespat $version;
4398 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4399 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4400 fail "changes files other than source matching $pat".
4401 " already present (@unwanted);".
4402 " building would result in ambiguity about the intended results"
4405 my $wasdir = must_getcwd();
4408 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4409 stat_exists $sourcechanges
4410 or fail "$sourcechanges (in parent directory): $!";
4412 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4413 my @changesfiles = glob $pat;
4414 @changesfiles = sort {
4415 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4418 fail "wrong number of different changes files (@changesfiles)"
4419 unless @changesfiles==2;
4420 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4421 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4422 fail "$l found in binaries changes file $binchanges"
4425 runcmd_ordryrun_local @mergechanges, @changesfiles;
4426 my $multichanges = changespat $version,'multi';
4428 stat_exists $multichanges or fail "$multichanges: $!";
4429 foreach my $cf (glob $pat) {
4430 next if $cf eq $multichanges;
4431 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4435 maybe_unapply_patches_again();
4436 printdone "build successful, results in $multichanges\n" or die $!;
4439 sub cmd_quilt_fixup {
4440 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4441 my $clogp = parsechangelog();
4442 $version = getfield $clogp, 'Version';
4443 $package = getfield $clogp, 'Source';
4446 build_maybe_quilt_fixup();
4449 sub cmd_archive_api_query {
4450 badusage "need only 1 subpath argument" unless @ARGV==1;
4451 my ($subpath) = @ARGV;
4452 my @cmd = archive_api_query_cmd($subpath);
4454 exec @cmd or fail "exec curl: $!\n";
4457 sub cmd_clone_dgit_repos_server {
4458 badusage "need destination argument" unless @ARGV==1;
4459 my ($destdir) = @ARGV;
4460 $package = '_dgit-repos-server';
4461 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4463 exec @cmd or fail "exec git clone: $!\n";
4466 sub cmd_setup_mergechangelogs {
4467 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4468 setup_mergechangelogs(1);
4471 sub cmd_setup_useremail {
4472 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4476 sub cmd_setup_new_tree {
4477 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4481 #---------- argument parsing and main program ----------
4484 print "dgit version $our_version\n" or die $!;
4488 our (%valopts_long, %valopts_short);
4491 sub defvalopt ($$$$) {
4492 my ($long,$short,$val_re,$how) = @_;
4493 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4494 $valopts_long{$long} = $oi;
4495 $valopts_short{$short} = $oi;
4496 # $how subref should:
4497 # do whatever assignemnt or thing it likes with $_[0]
4498 # if the option should not be passed on to remote, @rvalopts=()
4499 # or $how can be a scalar ref, meaning simply assign the value
4502 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4503 defvalopt '--distro', '-d', '.+', \$idistro;
4504 defvalopt '', '-k', '.+', \$keyid;
4505 defvalopt '--existing-package','', '.*', \$existing_package;
4506 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4507 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4508 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4510 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4512 defvalopt '', '-C', '.+', sub {
4513 ($changesfile) = (@_);
4514 if ($changesfile =~ s#^(.*)/##) {
4515 $buildproductsdir = $1;
4519 defvalopt '--initiator-tempdir','','.*', sub {
4520 ($initiator_tempdir) = (@_);
4521 $initiator_tempdir =~ m#^/# or
4522 badusage "--initiator-tempdir must be used specify an".
4523 " absolute, not relative, directory."
4529 if (defined $ENV{'DGIT_SSH'}) {
4530 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4531 } elsif (defined $ENV{'GIT_SSH'}) {
4532 @ssh = ($ENV{'GIT_SSH'});
4540 if (!defined $val) {
4541 badusage "$what needs a value" unless @ARGV;
4543 push @rvalopts, $val;
4545 badusage "bad value \`$val' for $what" unless
4546 $val =~ m/^$oi->{Re}$(?!\n)/s;
4547 my $how = $oi->{How};
4548 if (ref($how) eq 'SCALAR') {
4553 push @ropts, @rvalopts;
4557 last unless $ARGV[0] =~ m/^-/;
4561 if (m/^--dry-run$/) {
4564 } elsif (m/^--damp-run$/) {
4567 } elsif (m/^--no-sign$/) {
4570 } elsif (m/^--help$/) {
4572 } elsif (m/^--version$/) {
4574 } elsif (m/^--new$/) {
4577 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4578 ($om = $opts_opt_map{$1}) &&
4582 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4583 !$opts_opt_cmdonly{$1} &&
4584 ($om = $opts_opt_map{$1})) {
4587 } elsif (m/^--ignore-dirty$/s) {
4590 } elsif (m/^--no-quilt-fixup$/s) {
4592 $quilt_mode = 'nocheck';
4593 } elsif (m/^--no-rm-on-error$/s) {
4596 } elsif (m/^--overwrite$/s) {
4598 $overwrite_version = '';
4599 } elsif (m/^--overwrite=(.+)$/s) {
4601 $overwrite_version = $1;
4602 } elsif (m/^--(no-)?rm-old-changes$/s) {
4605 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4607 push @deliberatelies, $&;
4608 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4609 # undocumented, for testing
4611 $tagformat_want = [ $1, 'command line', 1 ];
4612 # 1 menas overrides distro configuration
4613 } elsif (m/^--always-split-source-build$/s) {
4614 # undocumented, for testing
4616 $need_split_build_invocation = 1;
4617 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4618 $val = $2 ? $' : undef; #';
4619 $valopt->($oi->{Long});
4621 badusage "unknown long option \`$_'";
4628 } elsif (s/^-L/-/) {
4631 } elsif (s/^-h/-/) {
4633 } elsif (s/^-D/-/) {
4637 } elsif (s/^-N/-/) {
4642 push @changesopts, $_;
4644 } elsif (s/^-wn$//s) {
4646 $cleanmode = 'none';
4647 } elsif (s/^-wg$//s) {
4650 } elsif (s/^-wgf$//s) {
4652 $cleanmode = 'git-ff';
4653 } elsif (s/^-wd$//s) {
4655 $cleanmode = 'dpkg-source';
4656 } elsif (s/^-wdd$//s) {
4658 $cleanmode = 'dpkg-source-d';
4659 } elsif (s/^-wc$//s) {
4661 $cleanmode = 'check';
4662 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4664 $val = undef unless length $val;
4665 $valopt->($oi->{Short});
4668 badusage "unknown short option \`$_'";
4675 sub finalise_opts_opts () {
4676 foreach my $k (keys %opts_opt_map) {
4677 my $om = $opts_opt_map{$k};
4679 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4681 badcfg "cannot set command for $k"
4682 unless length $om->[0];
4686 foreach my $c (access_cfg_cfgs("opts-$k")) {
4687 my $vl = $gitcfg{$c};
4688 printdebug "CL $c ",
4689 ($vl ? join " ", map { shellquote } @$vl : ""),
4690 "\n" if $debuglevel >= 4;
4692 badcfg "cannot configure options for $k"
4693 if $opts_opt_cmdonly{$k};
4694 my $insertpos = $opts_cfg_insertpos{$k};
4695 @$om = ( @$om[0..$insertpos-1],
4697 @$om[$insertpos..$#$om] );
4702 if ($ENV{$fakeeditorenv}) {
4704 quilt_fixup_editor();
4710 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4711 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4712 if $dryrun_level == 1;
4714 print STDERR $helpmsg or die $!;
4717 my $cmd = shift @ARGV;
4720 if (!defined $rmchanges) {
4721 local $access_forpush;
4722 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4725 if (!defined $quilt_mode) {
4726 local $access_forpush;
4727 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4728 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4730 $quilt_mode =~ m/^($quilt_modes_re)$/
4731 or badcfg "unknown quilt-mode \`$quilt_mode'";
4735 $need_split_build_invocation ||= quiltmode_splitbrain();
4737 if (!defined $cleanmode) {
4738 local $access_forpush;
4739 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4740 $cleanmode //= 'dpkg-source';
4742 badcfg "unknown clean-mode \`$cleanmode'" unless
4743 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4746 my $fn = ${*::}{"cmd_$cmd"};
4747 $fn or badusage "unknown operation $cmd";