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 madformat ($) { $_[0] eq '3.0 (quilt)' }
155 sub lbranch () { return "$branchprefix/$csuite"; }
156 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
157 sub lref () { return "refs/heads/".lbranch(); }
158 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
159 sub rrref () { return server_ref($csuite); }
161 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
162 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
164 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
165 # locally fetched refs because they have unhelpful names and clutter
166 # up gitk etc. So we track whether we have "used up" head ref (ie,
167 # whether we have made another local ref which refers to this object).
169 # (If we deleted them unconditionally, then we might end up
170 # re-fetching the same git objects each time dgit fetch was run.)
172 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
173 # in git_fetch_us to fetch the refs in question, and possibly a call
174 # to lrfetchref_used.
176 our (%lrfetchrefs_f, %lrfetchrefs_d);
177 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
179 sub lrfetchref_used ($) {
180 my ($fullrefname) = @_;
181 my $objid = $lrfetchrefs_f{$fullrefname};
182 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
193 return "${package}_".(stripepoch $vsn).$sfx
198 return srcfn($vsn,".dsc");
201 sub changespat ($;$) {
202 my ($vsn, $arch) = @_;
203 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
212 foreach my $f (@end) {
214 print STDERR "$us: cleanup: $@" if length $@;
218 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
220 sub no_such_package () {
221 print STDERR "$us: package $package does not exist in suite $isuite\n";
227 printdebug "CD $newdir\n";
228 chdir $newdir or confess "chdir: $newdir: $!";
231 sub deliberately ($) {
233 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
236 sub deliberately_not_fast_forward () {
237 foreach (qw(not-fast-forward fresh-repo)) {
238 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
242 sub quiltmode_splitbrain () {
243 $quilt_mode =~ m/gbp|dpm|unapplied/;
246 #---------- remote protocol support, common ----------
248 # remote push initiator/responder protocol:
249 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
250 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
251 # < dgit-remote-push-ready <actual-proto-vsn>
258 # > supplementary-message NBYTES # $protovsn >= 3
263 # > file parsed-changelog
264 # [indicates that output of dpkg-parsechangelog follows]
265 # > data-block NBYTES
266 # > [NBYTES bytes of data (no newline)]
267 # [maybe some more blocks]
276 # > param head DGIT-VIEW-HEAD
277 # > param csuite SUITE
278 # > param tagformat old|new
279 # > param maint-view MAINT-VIEW-HEAD
281 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
282 # # goes into tag, for replay prevention
285 # [indicates that signed tag is wanted]
286 # < data-block NBYTES
287 # < [NBYTES bytes of data (no newline)]
288 # [maybe some more blocks]
292 # > want signed-dsc-changes
293 # < data-block NBYTES [transfer of signed dsc]
295 # < data-block NBYTES [transfer of signed changes]
303 sub i_child_report () {
304 # Sees if our child has died, and reap it if so. Returns a string
305 # describing how it died if it failed, or undef otherwise.
306 return undef unless $i_child_pid;
307 my $got = waitpid $i_child_pid, WNOHANG;
308 return undef if $got <= 0;
309 die unless $got == $i_child_pid;
310 $i_child_pid = undef;
311 return undef unless $?;
312 return "build host child ".waitstatusmsg();
317 fail "connection lost: $!" if $fh->error;
318 fail "protocol violation; $m not expected";
321 sub badproto_badread ($$) {
323 fail "connection lost: $!" if $!;
324 my $report = i_child_report();
325 fail $report if defined $report;
326 badproto $fh, "eof (reading $wh)";
329 sub protocol_expect (&$) {
330 my ($match, $fh) = @_;
333 defined && chomp or badproto_badread $fh, "protocol message";
341 badproto $fh, "\`$_'";
344 sub protocol_send_file ($$) {
345 my ($fh, $ourfn) = @_;
346 open PF, "<", $ourfn or die "$ourfn: $!";
349 my $got = read PF, $d, 65536;
350 die "$ourfn: $!" unless defined $got;
352 print $fh "data-block ".length($d)."\n" or die $!;
353 print $fh $d or die $!;
355 PF->error and die "$ourfn $!";
356 print $fh "data-end\n" or die $!;
360 sub protocol_read_bytes ($$) {
361 my ($fh, $nbytes) = @_;
362 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
364 my $got = read $fh, $d, $nbytes;
365 $got==$nbytes or badproto_badread $fh, "data block";
369 sub protocol_receive_file ($$) {
370 my ($fh, $ourfn) = @_;
371 printdebug "() $ourfn\n";
372 open PF, ">", $ourfn or die "$ourfn: $!";
374 my ($y,$l) = protocol_expect {
375 m/^data-block (.*)$/ ? (1,$1) :
376 m/^data-end$/ ? (0,) :
380 my $d = protocol_read_bytes $fh, $l;
381 print PF $d or die $!;
386 #---------- remote protocol support, responder ----------
388 sub responder_send_command ($) {
390 return unless $we_are_responder;
391 # called even without $we_are_responder
392 printdebug ">> $command\n";
393 print PO $command, "\n" or die $!;
396 sub responder_send_file ($$) {
397 my ($keyword, $ourfn) = @_;
398 return unless $we_are_responder;
399 printdebug "]] $keyword $ourfn\n";
400 responder_send_command "file $keyword";
401 protocol_send_file \*PO, $ourfn;
404 sub responder_receive_files ($@) {
405 my ($keyword, @ourfns) = @_;
406 die unless $we_are_responder;
407 printdebug "[[ $keyword @ourfns\n";
408 responder_send_command "want $keyword";
409 foreach my $fn (@ourfns) {
410 protocol_receive_file \*PI, $fn;
413 protocol_expect { m/^files-end$/ } \*PI;
416 #---------- remote protocol support, initiator ----------
418 sub initiator_expect (&) {
420 protocol_expect { &$match } \*RO;
423 #---------- end remote code ----------
426 if ($we_are_responder) {
428 responder_send_command "progress ".length($m) or die $!;
429 print PO $m or die $!;
439 $ua = LWP::UserAgent->new();
443 progress "downloading $what...";
444 my $r = $ua->get(@_) or die $!;
445 return undef if $r->code == 404;
446 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
447 return $r->decoded_content(charset => 'none');
450 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
455 failedcmd @_ if system @_;
458 sub act_local () { return $dryrun_level <= 1; }
459 sub act_scary () { return !$dryrun_level; }
462 if (!$dryrun_level) {
463 progress "dgit ok: @_";
465 progress "would be ok: @_ (but dry run only)";
470 printcmd(\*STDERR,$debugprefix."#",@_);
473 sub runcmd_ordryrun {
481 sub runcmd_ordryrun_local {
490 my ($first_shell, @cmd) = @_;
491 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
494 our $helpmsg = <<END;
496 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
497 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
498 dgit [dgit-opts] build [dpkg-buildpackage-opts]
499 dgit [dgit-opts] sbuild [sbuild-opts]
500 dgit [dgit-opts] push [dgit-opts] [suite]
501 dgit [dgit-opts] rpush build-host:build-dir ...
502 important dgit options:
503 -k<keyid> sign tag and package with <keyid> instead of default
504 --dry-run -n do not change anything, but go through the motions
505 --damp-run -L like --dry-run but make local changes, without signing
506 --new -N allow introducing a new package
507 --debug -D increase debug level
508 -c<name>=<value> set git config option (used directly by dgit too)
511 our $later_warning_msg = <<END;
512 Perhaps the upload is stuck in incoming. Using the version from git.
516 print STDERR "$us: @_\n", $helpmsg or die $!;
521 @ARGV or badusage "too few arguments";
522 return scalar shift @ARGV;
526 print $helpmsg or die $!;
530 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
532 our %defcfg = ('dgit.default.distro' => 'debian',
533 'dgit.default.username' => '',
534 'dgit.default.archive-query-default-component' => 'main',
535 'dgit.default.ssh' => 'ssh',
536 'dgit.default.archive-query' => 'madison:',
537 'dgit.default.sshpsql-dbname' => 'service=projectb',
538 'dgit.default.dgit-tag-format' => 'old,new,maint',
539 # old means "repo server accepts pushes with old dgit tags"
540 # new means "repo server accepts pushes with new dgit tags"
541 # maint means "repo server accepts split brain pushes"
542 # hist means "repo server may have old pushes without new tag"
543 # ("hist" is implied by "old")
544 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
545 'dgit-distro.debian.git-check' => 'url',
546 'dgit-distro.debian.git-check-suffix' => '/info/refs',
547 'dgit-distro.debian.new-private-pushers' => 't',
548 'dgit-distro.debian.dgit-tag-format' => 'new',
549 'dgit-distro.debian/push.git-url' => '',
550 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
551 'dgit-distro.debian/push.git-user-force' => 'dgit',
552 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
553 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
554 'dgit-distro.debian/push.git-create' => 'true',
555 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
556 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
557 # 'dgit-distro.debian.archive-query-tls-key',
558 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
559 # ^ this does not work because curl is broken nowadays
560 # Fixing #790093 properly will involve providing providing the key
561 # in some pacagke and maybe updating these paths.
563 # 'dgit-distro.debian.archive-query-tls-curl-args',
564 # '--ca-path=/etc/ssl/ca-debian',
565 # ^ this is a workaround but works (only) on DSA-administered machines
566 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
567 'dgit-distro.debian.git-url-suffix' => '',
568 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
569 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
570 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
571 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
572 'dgit-distro.ubuntu.git-check' => 'false',
573 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
574 'dgit-distro.test-dummy.ssh' => "$td/ssh",
575 'dgit-distro.test-dummy.username' => "alice",
576 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
577 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
578 'dgit-distro.test-dummy.git-url' => "$td/git",
579 'dgit-distro.test-dummy.git-host' => "git",
580 'dgit-distro.test-dummy.git-path' => "$td/git",
581 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
582 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
583 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
584 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
589 sub git_slurp_config () {
590 local ($debuglevel) = $debuglevel-2;
593 my @cmd = (@git, qw(config -z --get-regexp .*));
596 open GITS, "-|", @cmd or die $!;
599 printdebug "=> ", (messagequote $_), "\n";
601 push @{ $gitcfg{$`} }, $'; #';
605 or ($!==0 && $?==256)
609 sub git_get_config ($) {
612 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
615 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
621 return undef if $c =~ /RETURN-UNDEF/;
622 my $v = git_get_config($c);
623 return $v if defined $v;
624 my $dv = $defcfg{$c};
625 return $dv if defined $dv;
627 badcfg "need value for one of: @_\n".
628 "$us: distro or suite appears not to be (properly) supported";
631 sub access_basedistro () {
632 if (defined $idistro) {
635 return cfg("dgit-suite.$isuite.distro",
636 "dgit.default.distro");
640 sub access_quirk () {
641 # returns (quirk name, distro to use instead or undef, quirk-specific info)
642 my $basedistro = access_basedistro();
643 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
645 if (defined $backports_quirk) {
646 my $re = $backports_quirk;
647 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
649 $re =~ s/\%/([-0-9a-z_]+)/
650 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
651 if ($isuite =~ m/^$re$/) {
652 return ('backports',"$basedistro-backports",$1);
655 return ('none',undef);
660 sub parse_cfg_bool ($$$) {
661 my ($what,$def,$v) = @_;
664 $v =~ m/^[ty1]/ ? 1 :
665 $v =~ m/^[fn0]/ ? 0 :
666 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
669 sub access_forpush_config () {
670 my $d = access_basedistro();
674 parse_cfg_bool('new-private-pushers', 0,
675 cfg("dgit-distro.$d.new-private-pushers",
678 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
681 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
682 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
683 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
684 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
687 sub access_forpush () {
688 $access_forpush //= access_forpush_config();
689 return $access_forpush;
693 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
694 badcfg "pushing but distro is configured readonly"
695 if access_forpush_config() eq '0';
697 $supplementary_message = <<'END' unless $we_are_responder;
698 Push failed, before we got started.
699 You can retry the push, after fixing the problem, if you like.
701 finalise_opts_opts();
705 finalise_opts_opts();
708 sub supplementary_message ($) {
710 if (!$we_are_responder) {
711 $supplementary_message = $msg;
713 } elsif ($protovsn >= 3) {
714 responder_send_command "supplementary-message ".length($msg)
716 print PO $msg or die $!;
720 sub access_distros () {
721 # Returns list of distros to try, in order
724 # 0. `instead of' distro name(s) we have been pointed to
725 # 1. the access_quirk distro, if any
726 # 2a. the user's specified distro, or failing that } basedistro
727 # 2b. the distro calculated from the suite }
728 my @l = access_basedistro();
730 my (undef,$quirkdistro) = access_quirk();
731 unshift @l, $quirkdistro;
732 unshift @l, $instead_distro;
733 @l = grep { defined } @l;
735 if (access_forpush()) {
736 @l = map { ("$_/push", $_) } @l;
741 sub access_cfg_cfgs (@) {
744 # The nesting of these loops determines the search order. We put
745 # the key loop on the outside so that we search all the distros
746 # for each key, before going on to the next key. That means that
747 # if access_cfg is called with a more specific, and then a less
748 # specific, key, an earlier distro can override the less specific
749 # without necessarily overriding any more specific keys. (If the
750 # distro wants to override the more specific keys it can simply do
751 # so; whereas if we did the loop the other way around, it would be
752 # impossible to for an earlier distro to override a less specific
753 # key but not the more specific ones without restating the unknown
754 # values of the more specific keys.
757 # We have to deal with RETURN-UNDEF specially, so that we don't
758 # terminate the search prematurely.
760 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
763 foreach my $d (access_distros()) {
764 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
766 push @cfgs, map { "dgit.default.$_" } @realkeys;
773 my (@cfgs) = access_cfg_cfgs(@keys);
774 my $value = cfg(@cfgs);
778 sub access_cfg_bool ($$) {
779 my ($def, @keys) = @_;
780 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
783 sub string_to_ssh ($) {
785 if ($spec =~ m/\s/) {
786 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
792 sub access_cfg_ssh () {
793 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
794 if (!defined $gitssh) {
797 return string_to_ssh $gitssh;
801 sub access_runeinfo ($) {
803 return ": dgit ".access_basedistro()." $info ;";
806 sub access_someuserhost ($) {
808 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
809 defined($user) && length($user) or
810 $user = access_cfg("$some-user",'username');
811 my $host = access_cfg("$some-host");
812 return length($user) ? "$user\@$host" : $host;
815 sub access_gituserhost () {
816 return access_someuserhost('git');
819 sub access_giturl (;$) {
821 my $url = access_cfg('git-url','RETURN-UNDEF');
824 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
825 return undef unless defined $proto;
828 access_gituserhost().
829 access_cfg('git-path');
831 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
834 return "$url/$package$suffix";
837 sub parsecontrolfh ($$;$) {
838 my ($fh, $desc, $allowsigned) = @_;
839 our $dpkgcontrolhash_noissigned;
842 my %opts = ('name' => $desc);
843 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
844 $c = Dpkg::Control::Hash->new(%opts);
845 $c->parse($fh,$desc) or die "parsing of $desc failed";
846 last if $allowsigned;
847 last if $dpkgcontrolhash_noissigned;
848 my $issigned= $c->get_option('is_pgp_signed');
849 if (!defined $issigned) {
850 $dpkgcontrolhash_noissigned= 1;
851 seek $fh, 0,0 or die "seek $desc: $!";
852 } elsif ($issigned) {
853 fail "control file $desc is (already) PGP-signed. ".
854 " Note that dgit push needs to modify the .dsc and then".
855 " do the signature itself";
864 my ($file, $desc) = @_;
865 my $fh = new IO::Handle;
866 open $fh, '<', $file or die "$file: $!";
867 my $c = parsecontrolfh($fh,$desc);
868 $fh->error and die $!;
874 my ($dctrl,$field) = @_;
875 my $v = $dctrl->{$field};
876 return $v if defined $v;
877 fail "missing field $field in ".$dctrl->get_option('name');
881 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
882 my $p = new IO::Handle;
883 my @cmd = (qw(dpkg-parsechangelog), @_);
884 open $p, '-|', @cmd or die $!;
886 $?=0; $!=0; close $p or failedcmd @cmd;
890 sub commit_getclogp ($) {
891 # Returns the parsed changelog hashref for a particular commit
893 our %commit_getclogp_memo;
894 my $memo = $commit_getclogp_memo{$objid};
895 return $memo if $memo;
897 my $mclog = ".git/dgit/clog-$objid";
898 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
899 "$objid:debian/changelog";
900 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
905 defined $d or fail "getcwd failed: $!";
911 sub archive_query ($) {
913 my $query = access_cfg('archive-query','RETURN-UNDEF');
914 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
917 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
920 sub pool_dsc_subpath ($$) {
921 my ($vsn,$component) = @_; # $package is implict arg
922 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
923 return "/pool/$component/$prefix/$package/".dscfn($vsn);
926 #---------- `ftpmasterapi' archive query method (nascent) ----------
928 sub archive_api_query_cmd ($) {
930 my @cmd = qw(curl -sS);
931 my $url = access_cfg('archive-query-url');
932 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
934 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
935 foreach my $key (split /\:/, $keys) {
936 $key =~ s/\%HOST\%/$host/g;
938 fail "for $url: stat $key: $!" unless $!==ENOENT;
941 fail "config requested specific TLS key but do not know".
942 " how to get curl to use exactly that EE key ($key)";
943 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
944 # # Sadly the above line does not work because of changes
945 # # to gnutls. The real fix for #790093 may involve
946 # # new curl options.
949 # Fixing #790093 properly will involve providing a value
950 # for this on clients.
951 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
952 push @cmd, split / /, $kargs if defined $kargs;
954 push @cmd, $url.$subpath;
960 my ($data, $subpath) = @_;
961 badcfg "ftpmasterapi archive query method takes no data part"
963 my @cmd = archive_api_query_cmd($subpath);
964 my $json = cmdoutput @cmd;
965 return decode_json($json);
968 sub canonicalise_suite_ftpmasterapi () {
969 my ($proto,$data) = @_;
970 my $suites = api_query($data, 'suites');
972 foreach my $entry (@$suites) {
974 my $v = $entry->{$_};
975 defined $v && $v eq $isuite;
977 push @matched, $entry;
979 fail "unknown suite $isuite" unless @matched;
982 @matched==1 or die "multiple matches for suite $isuite\n";
983 $cn = "$matched[0]{codename}";
984 defined $cn or die "suite $isuite info has no codename\n";
985 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
987 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
992 sub archive_query_ftpmasterapi () {
993 my ($proto,$data) = @_;
994 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
996 my $digester = Digest::SHA->new(256);
997 foreach my $entry (@$info) {
999 my $vsn = "$entry->{version}";
1000 my ($ok,$msg) = version_check $vsn;
1001 die "bad version: $msg\n" unless $ok;
1002 my $component = "$entry->{component}";
1003 $component =~ m/^$component_re$/ or die "bad component";
1004 my $filename = "$entry->{filename}";
1005 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1006 or die "bad filename";
1007 my $sha256sum = "$entry->{sha256sum}";
1008 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1009 push @rows, [ $vsn, "/pool/$component/$filename",
1010 $digester, $sha256sum ];
1012 die "bad ftpmaster api response: $@\n".Dumper($entry)
1015 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1019 #---------- `madison' archive query method ----------
1021 sub archive_query_madison {
1022 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1025 sub madison_get_parse {
1026 my ($proto,$data) = @_;
1027 die unless $proto eq 'madison';
1028 if (!length $data) {
1029 $data= access_cfg('madison-distro','RETURN-UNDEF');
1030 $data //= access_basedistro();
1032 $rmad{$proto,$data,$package} ||= cmdoutput
1033 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1034 my $rmad = $rmad{$proto,$data,$package};
1037 foreach my $l (split /\n/, $rmad) {
1038 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1039 \s*( [^ \t|]+ )\s* \|
1040 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1041 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1042 $1 eq $package or die "$rmad $package ?";
1049 $component = access_cfg('archive-query-default-component');
1051 $5 eq 'source' or die "$rmad ?";
1052 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1054 return sort { -version_compare($a->[0],$b->[0]); } @out;
1057 sub canonicalise_suite_madison {
1058 # madison canonicalises for us
1059 my @r = madison_get_parse(@_);
1061 "unable to canonicalise suite using package $package".
1062 " which does not appear to exist in suite $isuite;".
1063 " --existing-package may help";
1067 #---------- `sshpsql' archive query method ----------
1070 my ($data,$runeinfo,$sql) = @_;
1071 if (!length $data) {
1072 $data= access_someuserhost('sshpsql').':'.
1073 access_cfg('sshpsql-dbname');
1075 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1076 my ($userhost,$dbname) = ($`,$'); #';
1078 my @cmd = (access_cfg_ssh, $userhost,
1079 access_runeinfo("ssh-psql $runeinfo").
1080 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1081 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1083 open P, "-|", @cmd or die $!;
1086 printdebug(">|$_|\n");
1089 $!=0; $?=0; close P or failedcmd @cmd;
1091 my $nrows = pop @rows;
1092 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1093 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1094 @rows = map { [ split /\|/, $_ ] } @rows;
1095 my $ncols = scalar @{ shift @rows };
1096 die if grep { scalar @$_ != $ncols } @rows;
1100 sub sql_injection_check {
1101 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1104 sub archive_query_sshpsql ($$) {
1105 my ($proto,$data) = @_;
1106 sql_injection_check $isuite, $package;
1107 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1108 SELECT source.version, component.name, files.filename, files.sha256sum
1110 JOIN src_associations ON source.id = src_associations.source
1111 JOIN suite ON suite.id = src_associations.suite
1112 JOIN dsc_files ON dsc_files.source = source.id
1113 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1114 JOIN component ON component.id = files_archive_map.component_id
1115 JOIN files ON files.id = dsc_files.file
1116 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1117 AND source.source='$package'
1118 AND files.filename LIKE '%.dsc';
1120 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1121 my $digester = Digest::SHA->new(256);
1123 my ($vsn,$component,$filename,$sha256sum) = @$_;
1124 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1129 sub canonicalise_suite_sshpsql ($$) {
1130 my ($proto,$data) = @_;
1131 sql_injection_check $isuite;
1132 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1133 SELECT suite.codename
1134 FROM suite where suite_name='$isuite' or codename='$isuite';
1136 @rows = map { $_->[0] } @rows;
1137 fail "unknown suite $isuite" unless @rows;
1138 die "ambiguous $isuite: @rows ?" if @rows>1;
1142 #---------- `dummycat' archive query method ----------
1144 sub canonicalise_suite_dummycat ($$) {
1145 my ($proto,$data) = @_;
1146 my $dpath = "$data/suite.$isuite";
1147 if (!open C, "<", $dpath) {
1148 $!==ENOENT or die "$dpath: $!";
1149 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1153 chomp or die "$dpath: $!";
1155 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1159 sub archive_query_dummycat ($$) {
1160 my ($proto,$data) = @_;
1161 canonicalise_suite();
1162 my $dpath = "$data/package.$csuite.$package";
1163 if (!open C, "<", $dpath) {
1164 $!==ENOENT or die "$dpath: $!";
1165 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1173 printdebug "dummycat query $csuite $package $dpath | $_\n";
1174 my @row = split /\s+/, $_;
1175 @row==2 or die "$dpath: $_ ?";
1178 C->error and die "$dpath: $!";
1180 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1183 #---------- tag format handling ----------
1185 sub access_cfg_tagformats () {
1186 split /\,/, access_cfg('dgit-tag-format');
1189 sub need_tagformat ($$) {
1190 my ($fmt, $why) = @_;
1191 fail "need to use tag format $fmt ($why) but also need".
1192 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1193 " - no way to proceed"
1194 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1195 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1198 sub select_tagformat () {
1200 return if $tagformatfn && !$tagformat_want;
1201 die 'bug' if $tagformatfn && $tagformat_want;
1202 # ... $tagformat_want assigned after previous select_tagformat
1204 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1205 printdebug "select_tagformat supported @supported\n";
1207 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1208 printdebug "select_tagformat specified @$tagformat_want\n";
1210 my ($fmt,$why,$override) = @$tagformat_want;
1212 fail "target distro supports tag formats @supported".
1213 " but have to use $fmt ($why)"
1215 or grep { $_ eq $fmt } @supported;
1217 $tagformat_want = undef;
1219 $tagformatfn = ${*::}{"debiantag_$fmt"};
1221 fail "trying to use unknown tag format \`$fmt' ($why) !"
1222 unless $tagformatfn;
1225 #---------- archive query entrypoints and rest of program ----------
1227 sub canonicalise_suite () {
1228 return if defined $csuite;
1229 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1230 $csuite = archive_query('canonicalise_suite');
1231 if ($isuite ne $csuite) {
1232 progress "canonical suite name for $isuite is $csuite";
1236 sub get_archive_dsc () {
1237 canonicalise_suite();
1238 my @vsns = archive_query('archive_query');
1239 foreach my $vinfo (@vsns) {
1240 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1241 $dscurl = access_cfg('mirror').$subpath;
1242 $dscdata = url_get($dscurl);
1244 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1249 $digester->add($dscdata);
1250 my $got = $digester->hexdigest();
1252 fail "$dscurl has hash $got but".
1253 " archive told us to expect $digest";
1255 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1256 printdebug Dumper($dscdata) if $debuglevel>1;
1257 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1258 printdebug Dumper($dsc) if $debuglevel>1;
1259 my $fmt = getfield $dsc, 'Format';
1260 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1261 $dsc_checked = !!$digester;
1262 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1266 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1269 sub check_for_git ();
1270 sub check_for_git () {
1272 my $how = access_cfg('git-check');
1273 if ($how eq 'ssh-cmd') {
1275 (access_cfg_ssh, access_gituserhost(),
1276 access_runeinfo("git-check $package").
1277 " set -e; cd ".access_cfg('git-path').";".
1278 " if test -d $package.git; then echo 1; else echo 0; fi");
1279 my $r= cmdoutput @cmd;
1280 if (defined $r and $r =~ m/^divert (\w+)$/) {
1282 my ($usedistro,) = access_distros();
1283 # NB that if we are pushing, $usedistro will be $distro/push
1284 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1285 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1286 progress "diverting to $divert (using config for $instead_distro)";
1287 return check_for_git();
1289 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1291 } elsif ($how eq 'url') {
1292 my $prefix = access_cfg('git-check-url','git-url');
1293 my $suffix = access_cfg('git-check-suffix','git-suffix',
1294 'RETURN-UNDEF') // '.git';
1295 my $url = "$prefix/$package$suffix";
1296 my @cmd = (qw(curl -sS -I), $url);
1297 my $result = cmdoutput @cmd;
1298 $result =~ s/^\S+ 200 .*\n\r?\n//;
1299 # curl -sS -I with https_proxy prints
1300 # HTTP/1.0 200 Connection established
1301 $result =~ m/^\S+ (404|200) /s or
1302 fail "unexpected results from git check query - ".
1303 Dumper($prefix, $result);
1305 if ($code eq '404') {
1307 } elsif ($code eq '200') {
1312 } elsif ($how eq 'true') {
1314 } elsif ($how eq 'false') {
1317 badcfg "unknown git-check \`$how'";
1321 sub create_remote_git_repo () {
1322 my $how = access_cfg('git-create');
1323 if ($how eq 'ssh-cmd') {
1325 (access_cfg_ssh, access_gituserhost(),
1326 access_runeinfo("git-create $package").
1327 "set -e; cd ".access_cfg('git-path').";".
1328 " cp -a _template $package.git");
1329 } elsif ($how eq 'true') {
1332 badcfg "unknown git-create \`$how'";
1336 our ($dsc_hash,$lastpush_mergeinput);
1338 our $ud = '.git/dgit/unpack';
1348 sub mktree_in_ud_here () {
1349 runcmd qw(git init -q);
1350 runcmd qw(git config gc.auto 0);
1351 rmtree('.git/objects');
1352 symlink '../../../../objects','.git/objects' or die $!;
1355 sub git_write_tree () {
1356 my $tree = cmdoutput @git, qw(write-tree);
1357 $tree =~ m/^\w+$/ or die "$tree ?";
1361 sub remove_stray_gits () {
1362 my @gitscmd = qw(find -name .git -prune -print0);
1363 debugcmd "|",@gitscmd;
1364 open GITS, "-|", @gitscmd or die $!;
1369 print STDERR "$us: warning: removing from source package: ",
1370 (messagequote $_), "\n";
1374 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1377 sub mktree_in_ud_from_only_subdir (;$) {
1380 # changes into the subdir
1382 die "@dirs ?" unless @dirs==1;
1383 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1387 remove_stray_gits();
1388 mktree_in_ud_here();
1390 my ($format, $fopts) = get_source_format();
1391 if (madformat($format)) {
1396 runcmd @git, qw(add -Af);
1397 my $tree=git_write_tree();
1398 return ($tree,$dir);
1401 sub dsc_files_info () {
1402 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1403 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1404 ['Files', 'Digest::MD5', 'new()']) {
1405 my ($fname, $module, $method) = @$csumi;
1406 my $field = $dsc->{$fname};
1407 next unless defined $field;
1408 eval "use $module; 1;" or die $@;
1410 foreach (split /\n/, $field) {
1412 m/^(\w+) (\d+) (\S+)$/ or
1413 fail "could not parse .dsc $fname line \`$_'";
1414 my $digester = eval "$module"."->$method;" or die $@;
1419 Digester => $digester,
1424 fail "missing any supported Checksums-* or Files field in ".
1425 $dsc->get_option('name');
1429 map { $_->{Filename} } dsc_files_info();
1432 sub is_orig_file ($;$) {
1435 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1436 defined $base or return 1;
1440 sub make_commit ($) {
1442 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1445 sub clogp_authline ($) {
1447 my $author = getfield $clogp, 'Maintainer';
1448 $author =~ s#,.*##ms;
1449 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1450 my $authline = "$author $date";
1451 $authline =~ m/$git_authline_re/o or
1452 fail "unexpected commit author line format \`$authline'".
1453 " (was generated from changelog Maintainer field)";
1454 return ($1,$2,$3) if wantarray;
1458 sub vendor_patches_distro ($$) {
1459 my ($checkdistro, $what) = @_;
1460 return unless defined $checkdistro;
1462 my $series = "debian/patches/\L$checkdistro\E.series";
1463 printdebug "checking for vendor-specific $series ($what)\n";
1465 if (!open SERIES, "<", $series) {
1466 die "$series $!" unless $!==ENOENT;
1475 Unfortunately, this source package uses a feature of dpkg-source where
1476 the same source package unpacks to different source code on different
1477 distros. dgit cannot safely operate on such packages on affected
1478 distros, because the meaning of source packages is not stable.
1480 Please ask the distro/maintainer to remove the distro-specific series
1481 files and use a different technique (if necessary, uploading actually
1482 different packages, if different distros are supposed to have
1486 fail "Found active distro-specific series file for".
1487 " $checkdistro ($what): $series, cannot continue";
1489 die "$series $!" if SERIES->error;
1493 sub check_for_vendor_patches () {
1494 # This dpkg-source feature doesn't seem to be documented anywhere!
1495 # But it can be found in the changelog (reformatted):
1497 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1498 # Author: Raphael Hertzog <hertzog@debian.org>
1499 # Date: Sun Oct 3 09:36:48 2010 +0200
1501 # dpkg-source: correctly create .pc/.quilt_series with alternate
1504 # If you have debian/patches/ubuntu.series and you were
1505 # unpacking the source package on ubuntu, quilt was still
1506 # directed to debian/patches/series instead of
1507 # debian/patches/ubuntu.series.
1509 # debian/changelog | 3 +++
1510 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1511 # 2 files changed, 6 insertions(+), 1 deletion(-)
1514 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1515 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1516 "Dpkg::Vendor \`current vendor'");
1517 vendor_patches_distro(access_basedistro(),
1518 "distro being accessed");
1521 sub generate_commits_from_dsc () {
1522 # See big comment in fetch_from_archive, below.
1526 foreach my $fi (dsc_files_info()) {
1527 my $f = $fi->{Filename};
1528 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1530 link_ltarget "../../../$f", $f
1534 complete_file_from_dsc('.', $fi)
1537 if (is_orig_file($f)) {
1538 link $f, "../../../../$f"
1544 my $dscfn = "$package.dsc";
1546 open D, ">", $dscfn or die "$dscfn: $!";
1547 print D $dscdata or die "$dscfn: $!";
1548 close D or die "$dscfn: $!";
1549 my @cmd = qw(dpkg-source);
1550 push @cmd, '--no-check' if $dsc_checked;
1551 push @cmd, qw(-x --), $dscfn;
1554 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1555 check_for_vendor_patches() if madformat($dsc->{format});
1556 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1557 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1558 my $authline = clogp_authline $clogp;
1559 my $changes = getfield $clogp, 'Changes';
1560 open C, ">../commit.tmp" or die $!;
1561 print C <<END or die $!;
1568 # imported from the archive
1571 my $rawimport_hash = make_commit qw(../commit.tmp);
1572 my $cversion = getfield $clogp, 'Version';
1573 my $rawimport_mergeinput = {
1574 Commit => $rawimport_hash,
1575 Info => "Import of source package",
1577 my @output = ($rawimport_mergeinput);
1578 progress "synthesised git commit from .dsc $cversion";
1579 if ($lastpush_mergeinput) {
1580 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1581 my $oversion = getfield $oldclogp, 'Version';
1583 version_compare($oversion, $cversion);
1585 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1586 { Message => <<END, ReverseParents => 1 });
1587 Record $package ($cversion) in archive suite $csuite
1589 } elsif ($vcmp > 0) {
1590 print STDERR <<END or die $!;
1592 Version actually in archive: $cversion (older)
1593 Last version pushed with dgit: $oversion (newer or same)
1596 @output = $lastpush_mergeinput;
1598 # Same version. Use what's in the server git branch,
1599 # discarding our own import. (This could happen if the
1600 # server automatically imports all packages into git.)
1601 @output = $lastpush_mergeinput;
1604 changedir '../../../..';
1609 sub complete_file_from_dsc ($$) {
1610 our ($dstdir, $fi) = @_;
1611 # Ensures that we have, in $dir, the file $fi, with the correct
1612 # contents. (Downloading it from alongside $dscurl if necessary.)
1614 my $f = $fi->{Filename};
1615 my $tf = "$dstdir/$f";
1618 if (stat_exists $tf) {
1619 progress "using existing $f";
1622 $furl =~ s{/[^/]+$}{};
1624 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1625 die "$f ?" if $f =~ m#/#;
1626 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1627 return 0 if !act_local();
1631 open F, "<", "$tf" or die "$tf: $!";
1632 $fi->{Digester}->reset();
1633 $fi->{Digester}->addfile(*F);
1634 F->error and die $!;
1635 my $got = $fi->{Digester}->hexdigest();
1636 $got eq $fi->{Hash} or
1637 fail "file $f has hash $got but .dsc".
1638 " demands hash $fi->{Hash} ".
1639 ($downloaded ? "(got wrong file from archive!)"
1640 : "(perhaps you should delete this file?)");
1645 sub ensure_we_have_orig () {
1646 foreach my $fi (dsc_files_info()) {
1647 my $f = $fi->{Filename};
1648 next unless is_orig_file($f);
1649 complete_file_from_dsc('..', $fi)
1654 sub git_fetch_us () {
1655 # Want to fetch only what we are going to use, unless
1656 # deliberately-not-ff, in which case we must fetch everything.
1658 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1660 (quiltmode_splitbrain
1661 ? (map { $_->('*',access_basedistro) }
1662 \&debiantag_new, \&debiantag_maintview)
1663 : debiantags('*',access_basedistro));
1664 push @specs, server_branch($csuite);
1665 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1667 # This is rather miserable:
1668 # When git-fetch --prune is passed a fetchspec ending with a *,
1669 # it does a plausible thing. If there is no * then:
1670 # - it matches subpaths too, even if the supplied refspec
1671 # starts refs, and behaves completely madly if the source
1672 # has refs/refs/something. (See, for example, Debian #NNNN.)
1673 # - if there is no matching remote ref, it bombs out the whole
1675 # We want to fetch a fixed ref, and we don't know in advance
1676 # if it exists, so this is not suitable.
1678 # Our workaround is to use git-ls-remote. git-ls-remote has its
1679 # own qairks. Notably, it has the absurd multi-tail-matching
1680 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1681 # refs/refs/foo etc.
1683 # Also, we want an idempotent snapshot, but we have to make two
1684 # calls to the remote: one to git-ls-remote and to git-fetch. The
1685 # solution is use git-ls-remote to obtain a target state, and
1686 # git-fetch to try to generate it. If we don't manage to generate
1687 # the target state, we try again.
1689 my $specre = join '|', map {
1695 printdebug "git_fetch_us specre=$specre\n";
1696 my $wanted_rref = sub {
1698 return m/^(?:$specre)$/o;
1701 my $fetch_iteration = 0;
1704 if (++$fetch_iteration > 10) {
1705 fail "too many iterations trying to get sane fetch!";
1708 my @look = map { "refs/$_" } @specs;
1709 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1713 open GITLS, "-|", @lcmd or die $!;
1715 printdebug "=> ", $_;
1716 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1717 my ($objid,$rrefname) = ($1,$2);
1718 if (!$wanted_rref->($rrefname)) {
1720 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1724 $wantr{$rrefname} = $objid;
1727 close GITLS or failedcmd @lcmd;
1729 # OK, now %want is exactly what we want for refs in @specs
1731 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1732 "+refs/$_:".lrfetchrefs."/$_";
1735 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1736 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1739 %lrfetchrefs_f = ();
1742 git_for_each_ref(lrfetchrefs, sub {
1743 my ($objid,$objtype,$lrefname,$reftail) = @_;
1744 $lrfetchrefs_f{$lrefname} = $objid;
1745 $objgot{$objid} = 1;
1748 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1749 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1750 if (!exists $wantr{$rrefname}) {
1751 if ($wanted_rref->($rrefname)) {
1753 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1757 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1760 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1761 delete $lrfetchrefs_f{$lrefname};
1765 foreach my $rrefname (sort keys %wantr) {
1766 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1767 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1768 my $want = $wantr{$rrefname};
1769 next if $got eq $want;
1770 if (!defined $objgot{$want}) {
1772 warning: git-ls-remote suggests we want $lrefname
1773 warning: and it should refer to $want
1774 warning: but git-fetch didn't fetch that object to any relevant ref.
1775 warning: This may be due to a race with someone updating the server.
1776 warning: Will try again...
1778 next FETCH_ITERATION;
1781 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1783 runcmd_ordryrun_local @git, qw(update-ref -m),
1784 "dgit fetch git-fetch fixup", $lrefname, $want;
1785 $lrfetchrefs_f{$lrefname} = $want;
1789 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1790 Dumper(\%lrfetchrefs_f);
1793 my @tagpats = debiantags('*',access_basedistro);
1795 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1796 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1797 printdebug "currently $fullrefname=$objid\n";
1798 $here{$fullrefname} = $objid;
1800 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1801 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1802 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1803 printdebug "offered $lref=$objid\n";
1804 if (!defined $here{$lref}) {
1805 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1806 runcmd_ordryrun_local @upd;
1807 lrfetchref_used $fullrefname;
1808 } elsif ($here{$lref} eq $objid) {
1809 lrfetchref_used $fullrefname;
1812 "Not updateting $lref from $here{$lref} to $objid.\n";
1817 sub mergeinfo_getclogp ($) {
1818 # Ensures thit $mi->{Clogp} exists and returns it
1820 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1823 sub mergeinfo_version ($) {
1824 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1827 sub fetch_from_archive () {
1828 # Ensures that lrref() is what is actually in the archive, one way
1829 # or another, according to us - ie this client's
1830 # appropritaely-updated archive view. Also returns the commit id.
1831 # If there is nothing in the archive, leaves lrref alone and
1832 # returns undef. git_fetch_us must have already been called.
1836 foreach my $field (@ourdscfield) {
1837 $dsc_hash = $dsc->{$field};
1838 last if defined $dsc_hash;
1840 if (defined $dsc_hash) {
1841 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1843 progress "last upload to archive specified git hash";
1845 progress "last upload to archive has NO git hash";
1848 progress "no version available from the archive";
1851 # If the archive's .dsc has a Dgit field, there are three
1852 # relevant git commitids we need to choose between and/or merge
1854 # 1. $dsc_hash: the Dgit field from the archive
1855 # 2. $lastpush_hash: the suite branch on the dgit git server
1856 # 3. $lastfetch_hash: our local tracking brach for the suite
1858 # These may all be distinct and need not be in any fast forward
1861 # If the dsc was pushed to this suite, then the server suite
1862 # branch will have been updated; but it might have been pushed to
1863 # a different suite and copied by the archive. Conversely a more
1864 # recent version may have been pushed with dgit but not appeared
1865 # in the archive (yet).
1867 # $lastfetch_hash may be awkward because archive imports
1868 # (particularly, imports of Dgit-less .dscs) are performed only as
1869 # needed on individual clients, so different clients may perform a
1870 # different subset of them - and these imports are only made
1871 # public during push. So $lastfetch_hash may represent a set of
1872 # imports different to a subsequent upload by a different dgit
1875 # Our approach is as follows:
1877 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1878 # descendant of $dsc_hash, then it was pushed by a dgit user who
1879 # had based their work on $dsc_hash, so we should prefer it.
1880 # Otherwise, $dsc_hash was installed into this suite in the
1881 # archive other than by a dgit push, and (necessarily) after the
1882 # last dgit push into that suite (since a dgit push would have
1883 # been descended from the dgit server git branch); thus, in that
1884 # case, we prefer the archive's version (and produce a
1885 # pseudo-merge to overwrite the dgit server git branch).
1887 # (If there is no Dgit field in the archive's .dsc then
1888 # generate_commit_from_dsc uses the version numbers to decide
1889 # whether the suite branch or the archive is newer. If the suite
1890 # branch is newer it ignores the archive's .dsc; otherwise it
1891 # generates an import of the .dsc, and produces a pseudo-merge to
1892 # overwrite the suite branch with the archive contents.)
1894 # The outcome of that part of the algorithm is the `public view',
1895 # and is same for all dgit clients: it does not depend on any
1896 # unpublished history in the local tracking branch.
1898 # As between the public view and the local tracking branch: The
1899 # local tracking branch is only updated by dgit fetch, and
1900 # whenever dgit fetch runs it includes the public view in the
1901 # local tracking branch. Therefore if the public view is not
1902 # descended from the local tracking branch, the local tracking
1903 # branch must contain history which was imported from the archive
1904 # but never pushed; and, its tip is now out of date. So, we make
1905 # a pseudo-merge to overwrite the old imports and stitch the old
1908 # Finally: we do not necessarily reify the public view (as
1909 # described above). This is so that we do not end up stacking two
1910 # pseudo-merges. So what we actually do is figure out the inputs
1911 # to any public view pseudo-merge and put them in @mergeinputs.
1914 # $mergeinputs[]{Commit}
1915 # $mergeinputs[]{Info}
1916 # $mergeinputs[0] is the one whose tree we use
1917 # @mergeinputs is in the order we use in the actual commit)
1920 # $mergeinputs[]{Message} is a commit message to use
1921 # $mergeinputs[]{ReverseParents} if def specifies that parent
1922 # list should be in opposite order
1923 # Such an entry has no Commit or Info. It applies only when found
1924 # in the last entry. (This ugliness is to support making
1925 # identical imports to previous dgit versions.)
1927 my $lastpush_hash = git_get_ref(lrfetchref());
1928 printdebug "previous reference hash=$lastpush_hash\n";
1929 $lastpush_mergeinput = $lastpush_hash && {
1930 Commit => $lastpush_hash,
1931 Info => "dgit suite branch on dgit git server",
1934 my $lastfetch_hash = git_get_ref(lrref());
1935 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1936 my $lastfetch_mergeinput = $lastfetch_hash && {
1937 Commit => $lastfetch_hash,
1938 Info => "dgit client's archive history view",
1941 my $dsc_mergeinput = $dsc_hash && {
1942 Commit => $dsc_hash,
1943 Info => "Dgit field in .dsc from archive",
1947 my $del_lrfetchrefs = sub {
1950 printdebug "del_lrfetchrefs...\n";
1951 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1952 my $objid = $lrfetchrefs_d{$fullrefname};
1953 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1955 $gur ||= new IO::Handle;
1956 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1958 printf $gur "delete %s %s\n", $fullrefname, $objid;
1961 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1965 if (defined $dsc_hash) {
1966 fail "missing remote git history even though dsc has hash -".
1967 " could not find ref ".rref()." at ".access_giturl()
1968 unless $lastpush_hash;
1969 ensure_we_have_orig();
1970 if ($dsc_hash eq $lastpush_hash) {
1971 @mergeinputs = $dsc_mergeinput
1972 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1973 print STDERR <<END or die $!;
1975 Git commit in archive is behind the last version allegedly pushed/uploaded.
1976 Commit referred to by archive: $dsc_hash
1977 Last version pushed with dgit: $lastpush_hash
1980 @mergeinputs = ($lastpush_mergeinput);
1982 # Archive has .dsc which is not a descendant of the last dgit
1983 # push. This can happen if the archive moves .dscs about.
1984 # Just follow its lead.
1985 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1986 progress "archive .dsc names newer git commit";
1987 @mergeinputs = ($dsc_mergeinput);
1989 progress "archive .dsc names other git commit, fixing up";
1990 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1994 @mergeinputs = generate_commits_from_dsc();
1995 # We have just done an import. Now, our import algorithm might
1996 # have been improved. But even so we do not want to generate
1997 # a new different import of the same package. So if the
1998 # version numbers are the same, just use our existing version.
1999 # If the version numbers are different, the archive has changed
2000 # (perhaps, rewound).
2001 if ($lastfetch_mergeinput &&
2002 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2003 (mergeinfo_version $mergeinputs[0]) )) {
2004 @mergeinputs = ($lastfetch_mergeinput);
2006 } elsif ($lastpush_hash) {
2007 # only in git, not in the archive yet
2008 @mergeinputs = ($lastpush_mergeinput);
2009 print STDERR <<END or die $!;
2011 Package not found in the archive, but has allegedly been pushed using dgit.
2015 printdebug "nothing found!\n";
2016 if (defined $skew_warning_vsn) {
2017 print STDERR <<END or die $!;
2019 Warning: relevant archive skew detected.
2020 Archive allegedly contains $skew_warning_vsn
2021 But we were not able to obtain any version from the archive or git.
2025 unshift @end, $del_lrfetchrefs;
2029 if ($lastfetch_hash &&
2031 my $h = $_->{Commit};
2032 $h and is_fast_fwd($lastfetch_hash, $h);
2033 # If true, one of the existing parents of this commit
2034 # is a descendant of the $lastfetch_hash, so we'll
2035 # be ff from that automatically.
2039 push @mergeinputs, $lastfetch_mergeinput;
2042 printdebug "fetch mergeinfos:\n";
2043 foreach my $mi (@mergeinputs) {
2045 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2047 printdebug sprintf " ReverseParents=%d Message=%s",
2048 $mi->{ReverseParents}, $mi->{Message};
2052 my $compat_info= pop @mergeinputs
2053 if $mergeinputs[$#mergeinputs]{Message};
2055 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2058 if (@mergeinputs > 1) {
2060 my $tree_commit = $mergeinputs[0]{Commit};
2062 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2063 $tree =~ m/\n\n/; $tree = $`;
2064 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2067 # We use the changelog author of the package in question the
2068 # author of this pseudo-merge. This is (roughly) correct if
2069 # this commit is simply representing aa non-dgit upload.
2070 # (Roughly because it does not record sponsorship - but we
2071 # don't have sponsorship info because that's in the .changes,
2072 # which isn't in the archivw.)
2074 # But, it might be that we are representing archive history
2075 # updates (including in-archive copies). These are not really
2076 # the responsibility of the person who created the .dsc, but
2077 # there is no-one whose name we should better use. (The
2078 # author of the .dsc-named commit is clearly worse.)
2080 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2081 my $author = clogp_authline $useclogp;
2082 my $cversion = getfield $useclogp, 'Version';
2084 my $mcf = ".git/dgit/mergecommit";
2085 open MC, ">", $mcf or die "$mcf $!";
2086 print MC <<END or die $!;
2090 my @parents = grep { $_->{Commit} } @mergeinputs;
2091 @parents = reverse @parents if $compat_info->{ReverseParents};
2092 print MC <<END or die $! foreach @parents;
2096 print MC <<END or die $!;
2102 if (defined $compat_info->{Message}) {
2103 print MC $compat_info->{Message} or die $!;
2105 print MC <<END or die $!;
2106 Record $package ($cversion) in archive suite $csuite
2110 my $message_add_info = sub {
2112 my $mversion = mergeinfo_version $mi;
2113 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2117 $message_add_info->($mergeinputs[0]);
2118 print MC <<END or die $!;
2119 should be treated as descended from
2121 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2125 $hash = make_commit $mcf;
2127 $hash = $mergeinputs[0]{Commit};
2129 progress "fetch hash=$hash\n";
2132 my ($lasth, $what) = @_;
2133 return unless $lasth;
2134 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2137 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2138 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2140 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2141 'DGIT_ARCHIVE', $hash;
2142 cmdoutput @git, qw(log -n2), $hash;
2143 # ... gives git a chance to complain if our commit is malformed
2145 if (defined $skew_warning_vsn) {
2147 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2148 my $gotclogp = commit_getclogp($hash);
2149 my $got_vsn = getfield $gotclogp, 'Version';
2150 printdebug "SKEW CHECK GOT $got_vsn\n";
2151 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2152 print STDERR <<END or die $!;
2154 Warning: archive skew detected. Using the available version:
2155 Archive allegedly contains $skew_warning_vsn
2156 We were able to obtain only $got_vsn
2162 if ($lastfetch_hash ne $hash) {
2163 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2167 dryrun_report @upd_cmd;
2171 lrfetchref_used lrfetchref();
2173 unshift @end, $del_lrfetchrefs;
2177 sub set_local_git_config ($$) {
2179 runcmd @git, qw(config), $k, $v;
2182 sub setup_mergechangelogs (;$) {
2184 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2186 my $driver = 'dpkg-mergechangelogs';
2187 my $cb = "merge.$driver";
2188 my $attrs = '.git/info/attributes';
2189 ensuredir '.git/info';
2191 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2192 if (!open ATTRS, "<", $attrs) {
2193 $!==ENOENT or die "$attrs: $!";
2197 next if m{^debian/changelog\s};
2198 print NATTRS $_, "\n" or die $!;
2200 ATTRS->error and die $!;
2203 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2206 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2207 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2209 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2212 sub setup_useremail (;$) {
2214 return unless $always || access_cfg_bool(1, 'setup-useremail');
2217 my ($k, $envvar) = @_;
2218 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2219 return unless defined $v;
2220 set_local_git_config "user.$k", $v;
2223 $setup->('email', 'DEBEMAIL');
2224 $setup->('name', 'DEBFULLNAME');
2227 sub setup_new_tree () {
2228 setup_mergechangelogs();
2234 canonicalise_suite();
2235 badusage "dry run makes no sense with clone" unless act_local();
2236 my $hasgit = check_for_git();
2237 mkdir $dstdir or fail "create \`$dstdir': $!";
2239 runcmd @git, qw(init -q);
2240 my $giturl = access_giturl(1);
2241 if (defined $giturl) {
2242 open H, "> .git/HEAD" or die $!;
2243 print H "ref: ".lref()."\n" or die $!;
2245 runcmd @git, qw(remote add), 'origin', $giturl;
2248 progress "fetching existing git history";
2250 runcmd_ordryrun_local @git, qw(fetch origin);
2252 progress "starting new git history";
2254 fetch_from_archive() or no_such_package;
2255 my $vcsgiturl = $dsc->{'Vcs-Git'};
2256 if (length $vcsgiturl) {
2257 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2258 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2261 runcmd @git, qw(reset --hard), lrref();
2262 printdone "ready for work in $dstdir";
2266 if (check_for_git()) {
2269 fetch_from_archive() or no_such_package();
2270 printdone "fetched into ".lrref();
2275 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2277 printdone "fetched to ".lrref()." and merged into HEAD";
2280 sub check_not_dirty () {
2281 foreach my $f (qw(local-options local-patch-header)) {
2282 if (stat_exists "debian/source/$f") {
2283 fail "git tree contains debian/source/$f";
2287 return if $ignoredirty;
2289 my @cmd = (@git, qw(diff --quiet HEAD));
2291 $!=0; $?=-1; system @cmd;
2294 fail "working tree is dirty (does not match HEAD)";
2300 sub commit_admin ($) {
2303 runcmd_ordryrun_local @git, qw(commit -m), $m;
2306 sub commit_quilty_patch () {
2307 my $output = cmdoutput @git, qw(status --porcelain);
2309 foreach my $l (split /\n/, $output) {
2310 next unless $l =~ m/\S/;
2311 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2315 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2317 progress "nothing quilty to commit, ok.";
2320 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2321 runcmd_ordryrun_local @git, qw(add -f), @adds;
2322 commit_admin "Commit Debian 3.0 (quilt) metadata";
2325 sub get_source_format () {
2327 if (open F, "debian/source/options") {
2331 s/\s+$//; # ignore missing final newline
2333 my ($k, $v) = ($`, $'); #');
2334 $v =~ s/^"(.*)"$/$1/;
2340 F->error and die $!;
2343 die $! unless $!==&ENOENT;
2346 if (!open F, "debian/source/format") {
2347 die $! unless $!==&ENOENT;
2351 F->error and die $!;
2353 return ($_, \%options);
2356 sub madformat_wantfixup ($) {
2358 return 0 unless $format eq '3.0 (quilt)';
2359 our $quilt_mode_warned;
2360 if ($quilt_mode eq 'nocheck') {
2361 progress "Not doing any fixup of \`$format' due to".
2362 " ----no-quilt-fixup or --quilt=nocheck"
2363 unless $quilt_mode_warned++;
2366 progress "Format \`$format', need to check/update patch stack"
2367 unless $quilt_mode_warned++;
2371 # An "infopair" is a tuple [ $thing, $what ]
2372 # (often $thing is a commit hash; $what is a description)
2374 sub infopair_cond_equal ($$) {
2376 $x->[0] eq $y->[0] or fail <<END;
2377 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2381 sub infopair_lrf_tag_lookup ($$) {
2382 my ($tagnames, $what) = @_;
2383 # $tagname may be an array ref
2384 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2385 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2386 foreach my $tagname (@tagnames) {
2387 my $lrefname = lrfetchrefs."/tags/$tagname";
2388 my $tagobj = $lrfetchrefs_f{$lrefname};
2389 next unless defined $tagobj;
2390 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2391 return [ git_rev_parse($tagobj), $what ];
2393 fail @tagnames==1 ? <<END : <<END;
2394 Wanted tag $what (@tagnames) on dgit server, but not found
2396 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2400 sub infopair_cond_ff ($$) {
2401 my ($anc,$desc) = @_;
2402 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2403 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2407 sub pseudomerge_version_check ($$) {
2408 my ($clogp, $archive_hash) = @_;
2410 my $arch_clogp = commit_getclogp $archive_hash;
2411 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2412 'version currently in archive' ];
2413 if (defined $overwrite_version) {
2414 if (length $overwrite_version) {
2415 infopair_cond_equal([ $overwrite_version,
2416 '--overwrite= version' ],
2419 my $v = $i_arch_v->[0];
2420 progress "Checking package changelog for archive version $v ...";
2422 my @xa = ("-f$v", "-t$v");
2423 my $vclogp = parsechangelog @xa;
2424 my $cv = [ (getfield $vclogp, 'Version'),
2425 "Version field from dpkg-parsechangelog @xa" ];
2426 infopair_cond_equal($i_arch_v, $cv);
2429 $@ =~ s/^dgit: //gm;
2431 "Perhaps debian/changelog does not mention $v ?";
2436 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2440 sub pseudomerge_make_commit ($$$$ $$) {
2441 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2442 $msg_cmd, $msg_msg) = @_;
2443 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2445 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2446 my $authline = clogp_authline $clogp;
2450 !defined $overwrite_version ? ""
2451 : !length $overwrite_version ? " --overwrite"
2452 : " --overwrite=".$overwrite_version;
2455 my $pmf = ".git/dgit/pseudomerge";
2456 open MC, ">", $pmf or die "$pmf $!";
2457 print MC <<END or die $!;
2460 parent $archive_hash
2470 return make_commit($pmf);
2473 sub splitbrain_pseudomerge ($$$$) {
2474 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2475 # => $merged_dgitview
2476 printdebug "splitbrain_pseudomerge...\n";
2478 # We: debian/PREVIOUS HEAD($maintview)
2479 # expect: o ----------------- o
2482 # a/d/PREVIOUS $dgitview
2485 # we do: `------------------ o
2489 printdebug "splitbrain_pseudomerge...\n";
2491 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2493 return $dgitview unless defined $archive_hash;
2495 if (!defined $overwrite_version) {
2496 progress "Checking that HEAD inciudes all changes in archive...";
2499 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2501 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2502 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2503 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2504 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2505 my $i_archive = [ $archive_hash, "current archive contents" ];
2507 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2509 infopair_cond_equal($i_dgit, $i_archive);
2510 infopair_cond_ff($i_dep14, $i_dgit);
2511 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2513 my $r = pseudomerge_make_commit
2514 $clogp, $dgitview, $archive_hash, $i_arch_v,
2515 "dgit --quilt=$quilt_mode",
2516 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2517 Declare fast forward from $overwrite_version
2519 Make fast forward from $i_arch_v->[0]
2522 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2526 sub plain_overwrite_pseudomerge ($$$) {
2527 my ($clogp, $head, $archive_hash) = @_;
2529 printdebug "plain_overwrite_pseudomerge...";
2531 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2533 my @tagformats = access_cfg_tagformats();
2535 map { $_->($i_arch_v->[0], access_basedistro) }
2536 (grep { m/^(?:old|hist)$/ } @tagformats)
2537 ? \&debiantags : \&debiantag_new;
2538 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2539 my $i_archive = [ $archive_hash, "current archive contents" ];
2541 infopair_cond_equal($i_overwr, $i_archive);
2543 return $head if is_fast_fwd $archive_hash, $head;
2545 my $m = "Declare fast forward from $i_arch_v->[0]";
2547 my $r = pseudomerge_make_commit
2548 $clogp, $head, $archive_hash, $i_arch_v,
2551 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2553 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2557 sub push_parse_changelog ($) {
2560 my $clogp = Dpkg::Control::Hash->new();
2561 $clogp->load($clogpfn) or die;
2563 $package = getfield $clogp, 'Source';
2564 my $cversion = getfield $clogp, 'Version';
2565 my $tag = debiantag($cversion, access_basedistro);
2566 runcmd @git, qw(check-ref-format), $tag;
2568 my $dscfn = dscfn($cversion);
2570 return ($clogp, $cversion, $dscfn);
2573 sub push_parse_dsc ($$$) {
2574 my ($dscfn,$dscfnwhat, $cversion) = @_;
2575 $dsc = parsecontrol($dscfn,$dscfnwhat);
2576 my $dversion = getfield $dsc, 'Version';
2577 my $dscpackage = getfield $dsc, 'Source';
2578 ($dscpackage eq $package && $dversion eq $cversion) or
2579 fail "$dscfn is for $dscpackage $dversion".
2580 " but debian/changelog is for $package $cversion";
2583 sub push_tagwants ($$$$) {
2584 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2587 TagFn => \&debiantag,
2592 if (defined $maintviewhead) {
2594 TagFn => \&debiantag_maintview,
2595 Objid => $maintviewhead,
2596 TfSuffix => '-maintview',
2600 foreach my $tw (@tagwants) {
2601 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2602 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2604 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2608 sub push_mktags ($$ $$ $) {
2610 $changesfile,$changesfilewhat,
2613 die unless $tagwants->[0]{View} eq 'dgit';
2615 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2616 $dsc->save("$dscfn.tmp") or die $!;
2618 my $changes = parsecontrol($changesfile,$changesfilewhat);
2619 foreach my $field (qw(Source Distribution Version)) {
2620 $changes->{$field} eq $clogp->{$field} or
2621 fail "changes field $field \`$changes->{$field}'".
2622 " does not match changelog \`$clogp->{$field}'";
2625 my $cversion = getfield $clogp, 'Version';
2626 my $clogsuite = getfield $clogp, 'Distribution';
2628 # We make the git tag by hand because (a) that makes it easier
2629 # to control the "tagger" (b) we can do remote signing
2630 my $authline = clogp_authline $clogp;
2631 my $delibs = join(" ", "",@deliberatelies);
2632 my $declaredistro = access_basedistro();
2636 my $tfn = $tw->{Tfn};
2637 my $head = $tw->{Objid};
2638 my $tag = $tw->{Tag};
2640 open TO, '>', $tfn->('.tmp') or die $!;
2641 print TO <<END or die $!;
2648 if ($tw->{View} eq 'dgit') {
2649 print TO <<END or die $!;
2650 $package release $cversion for $clogsuite ($csuite) [dgit]
2651 [dgit distro=$declaredistro$delibs]
2653 foreach my $ref (sort keys %previously) {
2654 print TO <<END or die $!;
2655 [dgit previously:$ref=$previously{$ref}]
2658 } elsif ($tw->{View} eq 'maint') {
2659 print TO <<END or die $!;
2660 $package release $cversion for $clogsuite ($csuite)
2661 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2664 die Dumper($tw)."?";
2669 my $tagobjfn = $tfn->('.tmp');
2671 if (!defined $keyid) {
2672 $keyid = access_cfg('keyid','RETURN-UNDEF');
2674 if (!defined $keyid) {
2675 $keyid = getfield $clogp, 'Maintainer';
2677 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2678 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2679 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2680 push @sign_cmd, $tfn->('.tmp');
2681 runcmd_ordryrun @sign_cmd;
2683 $tagobjfn = $tfn->('.signed.tmp');
2684 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2685 $tfn->('.tmp'), $tfn->('.tmp.asc');
2691 my @r = map { $mktag->($_); } @$tagwants;
2695 sub sign_changes ($) {
2696 my ($changesfile) = @_;
2698 my @debsign_cmd = @debsign;
2699 push @debsign_cmd, "-k$keyid" if defined $keyid;
2700 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2701 push @debsign_cmd, $changesfile;
2702 runcmd_ordryrun @debsign_cmd;
2707 printdebug "actually entering push\n";
2709 supplementary_message(<<'END');
2710 Push failed, while checking state of the archive.
2711 You can retry the push, after fixing the problem, if you like.
2713 if (check_for_git()) {
2716 my $archive_hash = fetch_from_archive();
2717 if (!$archive_hash) {
2719 fail "package appears to be new in this suite;".
2720 " if this is intentional, use --new";
2723 supplementary_message(<<'END');
2724 Push failed, while preparing your push.
2725 You can retry the push, after fixing the problem, if you like.
2728 need_tagformat 'new', "quilt mode $quilt_mode"
2729 if quiltmode_splitbrain;
2733 access_giturl(); # check that success is vaguely likely
2736 my $clogpfn = ".git/dgit/changelog.822.tmp";
2737 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2739 responder_send_file('parsed-changelog', $clogpfn);
2741 my ($clogp, $cversion, $dscfn) =
2742 push_parse_changelog("$clogpfn");
2744 my $dscpath = "$buildproductsdir/$dscfn";
2745 stat_exists $dscpath or
2746 fail "looked for .dsc $dscfn, but $!;".
2747 " maybe you forgot to build";
2749 responder_send_file('dsc', $dscpath);
2751 push_parse_dsc($dscpath, $dscfn, $cversion);
2753 my $format = getfield $dsc, 'Format';
2754 printdebug "format $format\n";
2756 my $actualhead = git_rev_parse('HEAD');
2757 my $dgithead = $actualhead;
2758 my $maintviewhead = undef;
2760 if (madformat_wantfixup($format)) {
2761 # user might have not used dgit build, so maybe do this now:
2762 if (quiltmode_splitbrain()) {
2763 my $upstreamversion = $clogp->{Version};
2764 $upstreamversion =~ s/-[^-]*$//;
2766 quilt_make_fake_dsc($upstreamversion);
2767 my ($dgitview, $cachekey) =
2768 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2770 "--quilt=$quilt_mode but no cached dgit view:
2771 perhaps tree changed since dgit build[-source] ?";
2773 $dgithead = splitbrain_pseudomerge($clogp,
2774 $actualhead, $dgitview,
2776 $maintviewhead = $actualhead;
2777 changedir '../../../..';
2778 prep_ud(); # so _only_subdir() works, below
2780 commit_quilty_patch();
2784 if (defined $overwrite_version && !defined $maintviewhead) {
2785 $dgithead = plain_overwrite_pseudomerge($clogp,
2793 if ($archive_hash) {
2794 if (is_fast_fwd($archive_hash, $dgithead)) {
2796 } elsif (deliberately_not_fast_forward) {
2799 fail "dgit push: HEAD is not a descendant".
2800 " of the archive's version.\n".
2801 "To overwrite the archive's contents,".
2802 " pass --overwrite[=VERSION].\n".
2803 "To rewind history, if permitted by the archive,".
2804 " use --deliberately-not-fast-forward.";
2809 progress "checking that $dscfn corresponds to HEAD";
2810 runcmd qw(dpkg-source -x --),
2811 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2812 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2813 check_for_vendor_patches() if madformat($dsc->{format});
2814 changedir '../../../..';
2815 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2816 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2817 debugcmd "+",@diffcmd;
2819 my $r = system @diffcmd;
2822 fail "$dscfn specifies a different tree to your HEAD commit;".
2823 " perhaps you forgot to build".
2824 ($diffopt eq '--exit-code' ? "" :
2825 " (run with -D to see full diff output)");
2830 if (!$changesfile) {
2831 my $pat = changespat $cversion;
2832 my @cs = glob "$buildproductsdir/$pat";
2833 fail "failed to find unique changes file".
2834 " (looked for $pat in $buildproductsdir);".
2835 " perhaps you need to use dgit -C"
2837 ($changesfile) = @cs;
2839 $changesfile = "$buildproductsdir/$changesfile";
2842 # Checks complete, we're going to try and go ahead:
2844 responder_send_file('changes',$changesfile);
2845 responder_send_command("param head $dgithead");
2846 responder_send_command("param csuite $csuite");
2847 responder_send_command("param tagformat $tagformat");
2848 if (defined $maintviewhead) {
2849 die unless ($protovsn//4) >= 4;
2850 responder_send_command("param maint-view $maintviewhead");
2853 if (deliberately_not_fast_forward) {
2854 git_for_each_ref(lrfetchrefs, sub {
2855 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2856 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2857 responder_send_command("previously $rrefname=$objid");
2858 $previously{$rrefname} = $objid;
2862 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2866 supplementary_message(<<'END');
2867 Push failed, while signing the tag.
2868 You can retry the push, after fixing the problem, if you like.
2870 # If we manage to sign but fail to record it anywhere, it's fine.
2871 if ($we_are_responder) {
2872 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2873 responder_receive_files('signed-tag', @tagobjfns);
2875 @tagobjfns = push_mktags($clogp,$dscpath,
2876 $changesfile,$changesfile,
2879 supplementary_message(<<'END');
2880 Push failed, *after* signing the tag.
2881 If you want to try again, you should use a new version number.
2884 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2886 foreach my $tw (@tagwants) {
2887 my $tag = $tw->{Tag};
2888 my $tagobjfn = $tw->{TagObjFn};
2890 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2891 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2892 runcmd_ordryrun_local
2893 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2896 supplementary_message(<<'END');
2897 Push failed, while updating the remote git repository - see messages above.
2898 If you want to try again, you should use a new version number.
2900 if (!check_for_git()) {
2901 create_remote_git_repo();
2904 my @pushrefs = $forceflag.$dgithead.":".rrref();
2905 foreach my $tw (@tagwants) {
2906 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2909 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2910 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2912 supplementary_message(<<'END');
2913 Push failed, after updating the remote git repository.
2914 If you want to try again, you must use a new version number.
2916 if ($we_are_responder) {
2917 my $dryrunsuffix = act_local() ? "" : ".tmp";
2918 responder_receive_files('signed-dsc-changes',
2919 "$dscpath$dryrunsuffix",
2920 "$changesfile$dryrunsuffix");
2923 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2925 progress "[new .dsc left in $dscpath.tmp]";
2927 sign_changes $changesfile;
2930 supplementary_message(<<END);
2931 Push failed, while uploading package(s) to the archive server.
2932 You can retry the upload of exactly these same files with dput of:
2934 If that .changes file is broken, you will need to use a new version
2935 number for your next attempt at the upload.
2937 my $host = access_cfg('upload-host','RETURN-UNDEF');
2938 my @hostarg = defined($host) ? ($host,) : ();
2939 runcmd_ordryrun @dput, @hostarg, $changesfile;
2940 printdone "pushed and uploaded $cversion";
2942 supplementary_message('');
2943 responder_send_command("complete");
2950 badusage "-p is not allowed with clone; specify as argument instead"
2951 if defined $package;
2954 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2955 ($package,$isuite) = @ARGV;
2956 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2957 ($package,$dstdir) = @ARGV;
2958 } elsif (@ARGV==3) {
2959 ($package,$isuite,$dstdir) = @ARGV;
2961 badusage "incorrect arguments to dgit clone";
2963 $dstdir ||= "$package";
2965 if (stat_exists $dstdir) {
2966 fail "$dstdir already exists";
2970 if ($rmonerror && !$dryrun_level) {
2971 $cwd_remove= getcwd();
2973 return unless defined $cwd_remove;
2974 if (!chdir "$cwd_remove") {
2975 return if $!==&ENOENT;
2976 die "chdir $cwd_remove: $!";
2979 rmtree($dstdir) or die "remove $dstdir: $!\n";
2980 } elsif (!grep { $! == $_ }
2981 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2983 print STDERR "check whether to remove $dstdir: $!\n";
2989 $cwd_remove = undef;
2992 sub branchsuite () {
2993 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2994 if ($branch =~ m#$lbranch_re#o) {
3001 sub fetchpullargs () {
3003 if (!defined $package) {
3004 my $sourcep = parsecontrol('debian/control','debian/control');
3005 $package = getfield $sourcep, 'Source';
3008 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3010 my $clogp = parsechangelog();
3011 $isuite = getfield $clogp, 'Distribution';
3013 canonicalise_suite();
3014 progress "fetching from suite $csuite";
3015 } elsif (@ARGV==1) {
3017 canonicalise_suite();
3019 badusage "incorrect arguments to dgit fetch or dgit pull";
3038 badusage "-p is not allowed with dgit push" if defined $package;
3040 my $clogp = parsechangelog();
3041 $package = getfield $clogp, 'Source';
3044 } elsif (@ARGV==1) {
3045 ($specsuite) = (@ARGV);
3047 badusage "incorrect arguments to dgit push";
3049 $isuite = getfield $clogp, 'Distribution';
3051 local ($package) = $existing_package; # this is a hack
3052 canonicalise_suite();
3054 canonicalise_suite();
3056 if (defined $specsuite &&
3057 $specsuite ne $isuite &&
3058 $specsuite ne $csuite) {
3059 fail "dgit push: changelog specifies $isuite ($csuite)".
3060 " but command line specifies $specsuite";
3065 #---------- remote commands' implementation ----------
3067 sub cmd_remote_push_build_host {
3068 my ($nrargs) = shift @ARGV;
3069 my (@rargs) = @ARGV[0..$nrargs-1];
3070 @ARGV = @ARGV[$nrargs..$#ARGV];
3072 my ($dir,$vsnwant) = @rargs;
3073 # vsnwant is a comma-separated list; we report which we have
3074 # chosen in our ready response (so other end can tell if they
3077 $we_are_responder = 1;
3078 $us .= " (build host)";
3082 open PI, "<&STDIN" or die $!;
3083 open STDIN, "/dev/null" or die $!;
3084 open PO, ">&STDOUT" or die $!;
3086 open STDOUT, ">&STDERR" or die $!;
3090 ($protovsn) = grep {
3091 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3092 } @rpushprotovsn_support;
3094 fail "build host has dgit rpush protocol versions ".
3095 (join ",", @rpushprotovsn_support).
3096 " but invocation host has $vsnwant"
3097 unless defined $protovsn;
3099 responder_send_command("dgit-remote-push-ready $protovsn");
3100 rpush_handle_protovsn_bothends();
3105 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3106 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3107 # a good error message)
3109 sub rpush_handle_protovsn_bothends () {
3110 if ($protovsn < 4) {
3111 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3120 my $report = i_child_report();
3121 if (defined $report) {
3122 printdebug "($report)\n";
3123 } elsif ($i_child_pid) {
3124 printdebug "(killing build host child $i_child_pid)\n";
3125 kill 15, $i_child_pid;
3127 if (defined $i_tmp && !defined $initiator_tempdir) {
3129 eval { rmtree $i_tmp; };
3133 END { i_cleanup(); }
3136 my ($base,$selector,@args) = @_;
3137 $selector =~ s/\-/_/g;
3138 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3145 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3153 push @rargs, join ",", @rpushprotovsn_support;
3156 push @rdgit, @ropts;
3157 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3159 my @cmd = (@ssh, $host, shellquote @rdgit);
3162 if (defined $initiator_tempdir) {
3163 rmtree $initiator_tempdir;
3164 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3165 $i_tmp = $initiator_tempdir;
3169 $i_child_pid = open2(\*RO, \*RI, @cmd);
3171 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3172 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3173 $supplementary_message = '' unless $protovsn >= 3;
3175 fail "rpush negotiated protocol version $protovsn".
3176 " which does not support quilt mode $quilt_mode"
3177 if quiltmode_splitbrain;
3179 rpush_handle_protovsn_bothends();
3181 my ($icmd,$iargs) = initiator_expect {
3182 m/^(\S+)(?: (.*))?$/;
3185 i_method "i_resp", $icmd, $iargs;
3189 sub i_resp_progress ($) {
3191 my $msg = protocol_read_bytes \*RO, $rhs;
3195 sub i_resp_supplementary_message ($) {
3197 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3200 sub i_resp_complete {
3201 my $pid = $i_child_pid;
3202 $i_child_pid = undef; # prevents killing some other process with same pid
3203 printdebug "waiting for build host child $pid...\n";
3204 my $got = waitpid $pid, 0;
3205 die $! unless $got == $pid;
3206 die "build host child failed $?" if $?;
3209 printdebug "all done\n";
3213 sub i_resp_file ($) {
3215 my $localname = i_method "i_localname", $keyword;
3216 my $localpath = "$i_tmp/$localname";
3217 stat_exists $localpath and
3218 badproto \*RO, "file $keyword ($localpath) twice";
3219 protocol_receive_file \*RO, $localpath;
3220 i_method "i_file", $keyword;
3225 sub i_resp_param ($) {
3226 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3230 sub i_resp_previously ($) {
3231 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3232 or badproto \*RO, "bad previously spec";
3233 my $r = system qw(git check-ref-format), $1;
3234 die "bad previously ref spec ($r)" if $r;
3235 $previously{$1} = $2;
3240 sub i_resp_want ($) {
3242 die "$keyword ?" if $i_wanted{$keyword}++;
3243 my @localpaths = i_method "i_want", $keyword;
3244 printdebug "[[ $keyword @localpaths\n";
3245 foreach my $localpath (@localpaths) {
3246 protocol_send_file \*RI, $localpath;
3248 print RI "files-end\n" or die $!;
3251 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3253 sub i_localname_parsed_changelog {
3254 return "remote-changelog.822";
3256 sub i_file_parsed_changelog {
3257 ($i_clogp, $i_version, $i_dscfn) =
3258 push_parse_changelog "$i_tmp/remote-changelog.822";
3259 die if $i_dscfn =~ m#/|^\W#;
3262 sub i_localname_dsc {
3263 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3268 sub i_localname_changes {
3269 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3270 $i_changesfn = $i_dscfn;
3271 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3272 return $i_changesfn;
3274 sub i_file_changes { }
3276 sub i_want_signed_tag {
3277 printdebug Dumper(\%i_param, $i_dscfn);
3278 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3279 && defined $i_param{'csuite'}
3280 or badproto \*RO, "premature desire for signed-tag";
3281 my $head = $i_param{'head'};
3282 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3284 my $maintview = $i_param{'maint-view'};
3285 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3288 if ($protovsn >= 4) {
3289 my $p = $i_param{'tagformat'} // '<undef>';
3291 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3294 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3296 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3298 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3301 push_mktags $i_clogp, $i_dscfn,
3302 $i_changesfn, 'remote changes',
3306 sub i_want_signed_dsc_changes {
3307 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3308 sign_changes $i_changesfn;
3309 return ($i_dscfn, $i_changesfn);
3312 #---------- building etc. ----------
3318 #----- `3.0 (quilt)' handling -----
3320 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3322 sub quiltify_dpkg_commit ($$$;$) {
3323 my ($patchname,$author,$msg, $xinfo) = @_;
3327 my $descfn = ".git/dgit/quilt-description.tmp";
3328 open O, '>', $descfn or die "$descfn: $!";
3331 $msg =~ s/^\s+$/ ./mg;
3332 print O <<END or die $!;
3342 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3343 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3344 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3345 runcmd @dpkgsource, qw(--commit .), $patchname;
3349 sub quiltify_trees_differ ($$;$$) {
3350 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3351 # returns true iff the two tree objects differ other than in debian/
3352 # with $finegrained,
3353 # returns bitmask 01 - differ in upstream files except .gitignore
3354 # 02 - differ in .gitignore
3355 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3356 # is set for each modified .gitignore filename $fn
3358 my @cmd = (@git, qw(diff-tree --name-only -z));
3359 push @cmd, qw(-r) if $finegrained;
3361 my $diffs= cmdoutput @cmd;
3363 foreach my $f (split /\0/, $diffs) {
3364 next if $f =~ m#^debian(?:/.*)?$#s;
3365 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3366 $r |= $isignore ? 02 : 01;
3367 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3369 printdebug "quiltify_trees_differ $x $y => $r\n";
3373 sub quiltify_tree_sentinelfiles ($) {
3374 # lists the `sentinel' files present in the tree
3376 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3377 qw(-- debian/rules debian/control);
3382 sub quiltify_splitbrain_needed () {
3383 if (!$split_brain) {
3384 progress "dgit view: changes are required...";
3385 runcmd @git, qw(checkout -q -b dgit-view);
3390 sub quiltify_splitbrain ($$$$$$) {
3391 my ($clogp, $unapplied, $headref, $diffbits,
3392 $editedignores, $cachekey) = @_;
3393 if ($quilt_mode !~ m/gbp|dpm/) {
3394 # treat .gitignore just like any other upstream file
3395 $diffbits = { %$diffbits };
3396 $_ = !!$_ foreach values %$diffbits;
3398 # We would like any commits we generate to be reproducible
3399 my @authline = clogp_authline($clogp);
3400 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3401 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3402 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3404 if ($quilt_mode =~ m/gbp|unapplied/ &&
3405 ($diffbits->{H2O} & 01)) {
3407 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3408 " but git tree differs from orig in upstream files.";
3409 if (!stat_exists "debian/patches") {
3411 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3415 if ($quilt_mode =~ m/dpm/ &&
3416 ($diffbits->{H2A} & 01)) {
3418 --quilt=$quilt_mode specified, implying patches-applied git tree
3419 but git tree differs from result of applying debian/patches to upstream
3422 if ($quilt_mode =~ m/gbp|unapplied/ &&
3423 ($diffbits->{O2A} & 01)) { # some patches
3424 quiltify_splitbrain_needed();
3425 progress "dgit view: creating patches-applied version using gbp pq";
3426 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3427 # gbp pq import creates a fresh branch; push back to dgit-view
3428 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3429 runcmd @git, qw(checkout -q dgit-view);
3431 if ($quilt_mode =~ m/gbp|dpm/ &&
3432 ($diffbits->{O2A} & 02)) {
3434 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3435 tool which does not create patches for changes to upstream
3436 .gitignores: but, such patches exist in debian/patches.
3439 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3440 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3441 quiltify_splitbrain_needed();
3442 progress "dgit view: creating patch to represent .gitignore changes";
3443 ensuredir "debian/patches";
3444 my $gipatch = "debian/patches/auto-gitignore";
3445 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3446 stat GIPATCH or die "$gipatch: $!";
3447 fail "$gipatch already exists; but want to create it".
3448 " to record .gitignore changes" if (stat _)[7];
3449 print GIPATCH <<END or die "$gipatch: $!";
3450 Subject: Update .gitignore from Debian packaging branch
3452 The Debian packaging git branch contains these updates to the upstream
3453 .gitignore file(s). This patch is autogenerated, to provide these
3454 updates to users of the official Debian archive view of the package.
3456 [dgit version $our_version]
3459 close GIPATCH or die "$gipatch: $!";
3460 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3461 $unapplied, $headref, "--", sort keys %$editedignores;
3462 open SERIES, "+>>", "debian/patches/series" or die $!;
3463 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3465 defined read SERIES, $newline, 1 or die $!;
3466 print SERIES "\n" or die $! unless $newline eq "\n";
3467 print SERIES "auto-gitignore\n" or die $!;
3468 close SERIES or die $!;
3469 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3470 commit_admin "Commit patch to update .gitignore";
3473 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3475 changedir '../../../..';
3476 ensuredir ".git/logs/refs/dgit-intern";
3477 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3479 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3482 progress "dgit view: created (commit id $dgitview)";
3484 changedir '.git/dgit/unpack/work';
3487 sub quiltify ($$$$) {
3488 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3490 # Quilt patchification algorithm
3492 # We search backwards through the history of the main tree's HEAD
3493 # (T) looking for a start commit S whose tree object is identical
3494 # to to the patch tip tree (ie the tree corresponding to the
3495 # current dpkg-committed patch series). For these purposes
3496 # `identical' disregards anything in debian/ - this wrinkle is
3497 # necessary because dpkg-source treates debian/ specially.
3499 # We can only traverse edges where at most one of the ancestors'
3500 # trees differs (in changes outside in debian/). And we cannot
3501 # handle edges which change .pc/ or debian/patches. To avoid
3502 # going down a rathole we avoid traversing edges which introduce
3503 # debian/rules or debian/control. And we set a limit on the
3504 # number of edges we are willing to look at.
3506 # If we succeed, we walk forwards again. For each traversed edge
3507 # PC (with P parent, C child) (starting with P=S and ending with
3508 # C=T) to we do this:
3510 # - dpkg-source --commit with a patch name and message derived from C
3511 # After traversing PT, we git commit the changes which
3512 # should be contained within debian/patches.
3514 # The search for the path S..T is breadth-first. We maintain a
3515 # todo list containing search nodes. A search node identifies a
3516 # commit, and looks something like this:
3518 # Commit => $git_commit_id,
3519 # Child => $c, # or undef if P=T
3520 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3521 # Nontrivial => true iff $p..$c has relevant changes
3528 my %considered; # saves being exponential on some weird graphs
3530 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3533 my ($search,$whynot) = @_;
3534 printdebug " search NOT $search->{Commit} $whynot\n";
3535 $search->{Whynot} = $whynot;
3536 push @nots, $search;
3537 no warnings qw(exiting);
3546 my $c = shift @todo;
3547 next if $considered{$c->{Commit}}++;
3549 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3551 printdebug "quiltify investigate $c->{Commit}\n";
3554 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3555 printdebug " search finished hooray!\n";
3560 if ($quilt_mode eq 'nofix') {
3561 fail "quilt fixup required but quilt mode is \`nofix'\n".
3562 "HEAD commit $c->{Commit} differs from tree implied by ".
3563 " debian/patches (tree object $oldtiptree)";
3565 if ($quilt_mode eq 'smash') {
3566 printdebug " search quitting smash\n";
3570 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3571 $not->($c, "has $c_sentinels not $t_sentinels")
3572 if $c_sentinels ne $t_sentinels;
3574 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3575 $commitdata =~ m/\n\n/;
3577 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3578 @parents = map { { Commit => $_, Child => $c } } @parents;
3580 $not->($c, "root commit") if !@parents;
3582 foreach my $p (@parents) {
3583 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3585 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3586 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3588 foreach my $p (@parents) {
3589 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3591 my @cmd= (@git, qw(diff-tree -r --name-only),
3592 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3593 my $patchstackchange = cmdoutput @cmd;
3594 if (length $patchstackchange) {
3595 $patchstackchange =~ s/\n/,/g;
3596 $not->($p, "changed $patchstackchange");
3599 printdebug " search queue P=$p->{Commit} ",
3600 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3606 printdebug "quiltify want to smash\n";
3609 my $x = $_[0]{Commit};
3610 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3613 my $reportnot = sub {
3615 my $s = $abbrev->($notp);
3616 my $c = $notp->{Child};
3617 $s .= "..".$abbrev->($c) if $c;
3618 $s .= ": ".$notp->{Whynot};
3621 if ($quilt_mode eq 'linear') {
3622 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3623 foreach my $notp (@nots) {
3624 print STDERR "$us: ", $reportnot->($notp), "\n";
3626 print STDERR "$us: $_\n" foreach @$failsuggestion;
3627 fail "quilt fixup naive history linearisation failed.\n".
3628 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3629 } elsif ($quilt_mode eq 'smash') {
3630 } elsif ($quilt_mode eq 'auto') {
3631 progress "quilt fixup cannot be linear, smashing...";
3633 die "$quilt_mode ?";
3636 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3637 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3639 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3641 quiltify_dpkg_commit "auto-$version-$target-$time",
3642 (getfield $clogp, 'Maintainer'),
3643 "Automatically generated patch ($clogp->{Version})\n".
3644 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3648 progress "quiltify linearisation planning successful, executing...";
3650 for (my $p = $sref_S;
3651 my $c = $p->{Child};
3653 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3654 next unless $p->{Nontrivial};
3656 my $cc = $c->{Commit};
3658 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3659 $commitdata =~ m/\n\n/ or die "$c ?";
3662 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3665 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3668 my $patchname = $title;
3669 $patchname =~ s/[.:]$//;
3670 $patchname =~ y/ A-Z/-a-z/;
3671 $patchname =~ y/-a-z0-9_.+=~//cd;
3672 $patchname =~ s/^\W/x-$&/;
3673 $patchname = substr($patchname,0,40);
3676 stat "debian/patches/$patchname$index";
3678 $!==ENOENT or die "$patchname$index $!";
3680 runcmd @git, qw(checkout -q), $cc;
3682 # We use the tip's changelog so that dpkg-source doesn't
3683 # produce complaining messages from dpkg-parsechangelog. None
3684 # of the information dpkg-source gets from the changelog is
3685 # actually relevant - it gets put into the original message
3686 # which dpkg-source provides our stunt editor, and then
3688 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3690 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3691 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3693 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3696 runcmd @git, qw(checkout -q master);
3699 sub build_maybe_quilt_fixup () {
3700 my ($format,$fopts) = get_source_format;
3701 return unless madformat_wantfixup $format;
3704 check_for_vendor_patches();
3706 if (quiltmode_splitbrain) {
3707 foreach my $needtf (qw(new maint)) {
3708 next if grep { $_ eq $needtf } access_cfg_tagformats;
3710 quilt mode $quilt_mode requires split view so server needs to support
3711 both "new" and "maint" tag formats, but config says it doesn't.
3716 my $clogp = parsechangelog();
3717 my $headref = git_rev_parse('HEAD');
3722 my $upstreamversion=$version;
3723 $upstreamversion =~ s/-[^-]*$//;
3725 if ($fopts->{'single-debian-patch'}) {
3726 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3728 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3731 die 'bug' if $split_brain && !$need_split_build_invocation;
3733 changedir '../../../..';
3734 runcmd_ordryrun_local
3735 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3738 sub quilt_fixup_mkwork ($) {
3741 mkdir "work" or die $!;
3743 mktree_in_ud_here();
3744 runcmd @git, qw(reset -q --hard), $headref;
3747 sub quilt_fixup_linkorigs ($$) {
3748 my ($upstreamversion, $fn) = @_;
3749 # calls $fn->($leafname);
3751 foreach my $f (<../../../../*>) { #/){
3752 my $b=$f; $b =~ s{.*/}{};
3754 local ($debuglevel) = $debuglevel-1;
3755 printdebug "QF linkorigs $b, $f ?\n";
3757 next unless is_orig_file $b, srcfn $upstreamversion,'';
3758 printdebug "QF linkorigs $b, $f Y\n";
3759 link_ltarget $f, $b or die "$b $!";
3764 sub quilt_fixup_delete_pc () {
3765 runcmd @git, qw(rm -rqf .pc);
3766 commit_admin "Commit removal of .pc (quilt series tracking data)";
3769 sub quilt_fixup_singlepatch ($$$) {
3770 my ($clogp, $headref, $upstreamversion) = @_;
3772 progress "starting quiltify (single-debian-patch)";
3774 # dpkg-source --commit generates new patches even if
3775 # single-debian-patch is in debian/source/options. In order to
3776 # get it to generate debian/patches/debian-changes, it is
3777 # necessary to build the source package.
3779 quilt_fixup_linkorigs($upstreamversion, sub { });
3780 quilt_fixup_mkwork($headref);
3782 rmtree("debian/patches");
3784 runcmd @dpkgsource, qw(-b .);
3786 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3787 rename srcfn("$upstreamversion", "/debian/patches"),
3788 "work/debian/patches";
3791 commit_quilty_patch();
3794 sub quilt_make_fake_dsc ($) {
3795 my ($upstreamversion) = @_;
3797 my $fakeversion="$upstreamversion-~~DGITFAKE";
3799 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3800 print $fakedsc <<END or die $!;
3803 Version: $fakeversion
3807 my $dscaddfile=sub {
3810 my $md = new Digest::MD5;
3812 my $fh = new IO::File $b, '<' or die "$b $!";
3817 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3820 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3822 my @files=qw(debian/source/format debian/rules
3823 debian/control debian/changelog);
3824 foreach my $maybe (qw(debian/patches debian/source/options
3825 debian/tests/control)) {
3826 next unless stat_exists "../../../$maybe";
3827 push @files, $maybe;
3830 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3831 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3833 $dscaddfile->($debtar);
3834 close $fakedsc or die $!;
3837 sub quilt_check_splitbrain_cache ($$) {
3838 my ($headref, $upstreamversion) = @_;
3839 # Called only if we are in (potentially) split brain mode.
3841 # Computes the cache key and looks in the cache.
3842 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3844 my $splitbrain_cachekey;
3847 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3848 # we look in the reflog of dgit-intern/quilt-cache
3849 # we look for an entry whose message is the key for the cache lookup
3850 my @cachekey = (qw(dgit), $our_version);
3851 push @cachekey, $upstreamversion;
3852 push @cachekey, $quilt_mode;
3853 push @cachekey, $headref;
3855 push @cachekey, hashfile('fake.dsc');
3857 my $srcshash = Digest::SHA->new(256);
3858 my %sfs = ( %INC, '$0(dgit)' => $0 );
3859 foreach my $sfk (sort keys %sfs) {
3860 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3861 $srcshash->add($sfk," ");
3862 $srcshash->add(hashfile($sfs{$sfk}));
3863 $srcshash->add("\n");
3865 push @cachekey, $srcshash->hexdigest();
3866 $splitbrain_cachekey = "@cachekey";
3868 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3870 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3871 debugcmd "|(probably)",@cmd;
3872 my $child = open GC, "-|"; defined $child or die $!;
3874 chdir '../../..' or die $!;
3875 if (!stat ".git/logs/refs/$splitbraincache") {
3876 $! == ENOENT or die $!;
3877 printdebug ">(no reflog)\n";
3884 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3885 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3888 quilt_fixup_mkwork($headref);
3889 if ($cachehit ne $headref) {
3890 progress "dgit view: found cached (commit id $cachehit)";
3891 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3893 return ($cachehit, $splitbrain_cachekey);
3895 progress "dgit view: found cached, no changes required";
3896 return ($headref, $splitbrain_cachekey);
3898 die $! if GC->error;
3899 failedcmd unless close GC;
3901 printdebug "splitbrain cache miss\n";
3902 return (undef, $splitbrain_cachekey);
3905 sub quilt_fixup_multipatch ($$$) {
3906 my ($clogp, $headref, $upstreamversion) = @_;
3908 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3911 # - honour any existing .pc in case it has any strangeness
3912 # - determine the git commit corresponding to the tip of
3913 # the patch stack (if there is one)
3914 # - if there is such a git commit, convert each subsequent
3915 # git commit into a quilt patch with dpkg-source --commit
3916 # - otherwise convert all the differences in the tree into
3917 # a single git commit
3921 # Our git tree doesn't necessarily contain .pc. (Some versions of
3922 # dgit would include the .pc in the git tree.) If there isn't
3923 # one, we need to generate one by unpacking the patches that we
3926 # We first look for a .pc in the git tree. If there is one, we
3927 # will use it. (This is not the normal case.)
3929 # Otherwise need to regenerate .pc so that dpkg-source --commit
3930 # can work. We do this as follows:
3931 # 1. Collect all relevant .orig from parent directory
3932 # 2. Generate a debian.tar.gz out of
3933 # debian/{patches,rules,source/format,source/options}
3934 # 3. Generate a fake .dsc containing just these fields:
3935 # Format Source Version Files
3936 # 4. Extract the fake .dsc
3937 # Now the fake .dsc has a .pc directory.
3938 # (In fact we do this in every case, because in future we will
3939 # want to search for a good base commit for generating patches.)
3941 # Then we can actually do the dpkg-source --commit
3942 # 1. Make a new working tree with the same object
3943 # store as our main tree and check out the main
3945 # 2. Copy .pc from the fake's extraction, if necessary
3946 # 3. Run dpkg-source --commit
3947 # 4. If the result has changes to debian/, then
3948 # - git-add them them
3949 # - git-add .pc if we had a .pc in-tree
3951 # 5. If we had a .pc in-tree, delete it, and git-commit
3952 # 6. Back in the main tree, fast forward to the new HEAD
3954 # Another situation we may have to cope with is gbp-style
3955 # patches-unapplied trees.
3957 # We would want to detect these, so we know to escape into
3958 # quilt_fixup_gbp. However, this is in general not possible.
3959 # Consider a package with a one patch which the dgit user reverts
3960 # (with git-revert or the moral equivalent).
3962 # That is indistinguishable in contents from a patches-unapplied
3963 # tree. And looking at the history to distinguish them is not
3964 # useful because the user might have made a confusing-looking git
3965 # history structure (which ought to produce an error if dgit can't
3966 # cope, not a silent reintroduction of an unwanted patch).
3968 # So gbp users will have to pass an option. But we can usually
3969 # detect their failure to do so: if the tree is not a clean
3970 # patches-applied tree, quilt linearisation fails, but the tree
3971 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3972 # they want --quilt=unapplied.
3974 # To help detect this, when we are extracting the fake dsc, we
3975 # first extract it with --skip-patches, and then apply the patches
3976 # afterwards with dpkg-source --before-build. That lets us save a
3977 # tree object corresponding to .origs.
3979 my $splitbrain_cachekey;
3981 quilt_make_fake_dsc($upstreamversion);
3983 if (quiltmode_splitbrain()) {
3985 ($cachehit, $splitbrain_cachekey) =
3986 quilt_check_splitbrain_cache($headref, $upstreamversion);
3987 return if $cachehit;
3991 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3993 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3994 rename $fakexdir, "fake" or die "$fakexdir $!";
3998 remove_stray_gits();
3999 mktree_in_ud_here();
4003 runcmd @git, qw(add -Af .);
4004 my $unapplied=git_write_tree();
4005 printdebug "fake orig tree object $unapplied\n";
4010 'exec dpkg-source --before-build . >/dev/null';
4014 quilt_fixup_mkwork($headref);
4017 if (stat_exists ".pc") {
4019 progress "Tree already contains .pc - will use it then delete it.";
4022 rename '../fake/.pc','.pc' or die $!;
4025 changedir '../fake';
4027 runcmd @git, qw(add -Af .);
4028 my $oldtiptree=git_write_tree();
4029 printdebug "fake o+d/p tree object $unapplied\n";
4030 changedir '../work';
4033 # We calculate some guesswork now about what kind of tree this might
4034 # be. This is mostly for error reporting.
4039 # O = orig, without patches applied
4040 # A = "applied", ie orig with H's debian/patches applied
4041 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4042 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4043 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4047 foreach my $b (qw(01 02)) {
4048 foreach my $v (qw(H2O O2A H2A)) {
4049 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4052 printdebug "differences \@dl @dl.\n";
4055 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4056 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4057 $dl[0], $dl[1], $dl[3], $dl[4],
4061 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4062 push @failsuggestion, "This might be a patches-unapplied branch.";
4063 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4064 push @failsuggestion, "This might be a patches-applied branch.";
4066 push @failsuggestion, "Maybe you need to specify one of".
4067 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4069 if (quiltmode_splitbrain()) {
4070 quiltify_splitbrain($clogp, $unapplied, $headref,
4071 $diffbits, \%editedignores,
4072 $splitbrain_cachekey);
4076 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4077 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4079 if (!open P, '>>', ".pc/applied-patches") {
4080 $!==&ENOENT or die $!;
4085 commit_quilty_patch();
4087 if ($mustdeletepc) {
4088 quilt_fixup_delete_pc();
4092 sub quilt_fixup_editor () {
4093 my $descfn = $ENV{$fakeeditorenv};
4094 my $editing = $ARGV[$#ARGV];
4095 open I1, '<', $descfn or die "$descfn: $!";
4096 open I2, '<', $editing or die "$editing: $!";
4097 unlink $editing or die "$editing: $!";
4098 open O, '>', $editing or die "$editing: $!";
4099 while (<I1>) { print O or die $!; } I1->error and die $!;
4102 $copying ||= m/^\-\-\- /;
4103 next unless $copying;
4106 I2->error and die $!;
4111 sub maybe_apply_patches_dirtily () {
4112 return unless $quilt_mode =~ m/gbp|unapplied/;
4113 print STDERR <<END or die $!;
4115 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4116 dgit: Have to apply the patches - making the tree dirty.
4117 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4120 $patches_applied_dirtily = 01;
4121 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4122 runcmd qw(dpkg-source --before-build .);
4125 sub maybe_unapply_patches_again () {
4126 progress "dgit: Unapplying patches again to tidy up the tree."
4127 if $patches_applied_dirtily;
4128 runcmd qw(dpkg-source --after-build .)
4129 if $patches_applied_dirtily & 01;
4131 if $patches_applied_dirtily & 02;
4132 $patches_applied_dirtily = 0;
4135 #----- other building -----
4137 our $clean_using_builder;
4138 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4139 # clean the tree before building (perhaps invoked indirectly by
4140 # whatever we are using to run the build), rather than separately
4141 # and explicitly by us.
4144 return if $clean_using_builder;
4145 if ($cleanmode eq 'dpkg-source') {
4146 maybe_apply_patches_dirtily();
4147 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4148 } elsif ($cleanmode eq 'dpkg-source-d') {
4149 maybe_apply_patches_dirtily();
4150 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4151 } elsif ($cleanmode eq 'git') {
4152 runcmd_ordryrun_local @git, qw(clean -xdf);
4153 } elsif ($cleanmode eq 'git-ff') {
4154 runcmd_ordryrun_local @git, qw(clean -xdff);
4155 } elsif ($cleanmode eq 'check') {
4156 my $leftovers = cmdoutput @git, qw(clean -xdn);
4157 if (length $leftovers) {
4158 print STDERR $leftovers, "\n" or die $!;
4159 fail "tree contains uncommitted files and --clean=check specified";
4161 } elsif ($cleanmode eq 'none') {
4168 badusage "clean takes no additional arguments" if @ARGV;
4171 maybe_unapply_patches_again();
4176 badusage "-p is not allowed when building" if defined $package;
4179 my $clogp = parsechangelog();
4180 $isuite = getfield $clogp, 'Distribution';
4181 $package = getfield $clogp, 'Source';
4182 $version = getfield $clogp, 'Version';
4183 build_maybe_quilt_fixup();
4185 my $pat = changespat $version;
4186 foreach my $f (glob "$buildproductsdir/$pat") {
4188 unlink $f or fail "remove old changes file $f: $!";
4190 progress "would remove $f";
4196 sub changesopts_initial () {
4197 my @opts =@changesopts[1..$#changesopts];
4200 sub changesopts_version () {
4201 if (!defined $changes_since_version) {
4202 my @vsns = archive_query('archive_query');
4203 my @quirk = access_quirk();
4204 if ($quirk[0] eq 'backports') {
4205 local $isuite = $quirk[2];
4207 canonicalise_suite();
4208 push @vsns, archive_query('archive_query');
4211 @vsns = map { $_->[0] } @vsns;
4212 @vsns = sort { -version_compare($a, $b) } @vsns;
4213 $changes_since_version = $vsns[0];
4214 progress "changelog will contain changes since $vsns[0]";
4216 $changes_since_version = '_';
4217 progress "package seems new, not specifying -v<version>";
4220 if ($changes_since_version ne '_') {
4221 return ("-v$changes_since_version");
4227 sub changesopts () {
4228 return (changesopts_initial(), changesopts_version());
4231 sub massage_dbp_args ($;$) {
4232 my ($cmd,$xargs) = @_;
4235 # - if we're going to split the source build out so we can
4236 # do strange things to it, massage the arguments to dpkg-buildpackage
4237 # so that the main build doessn't build source (or add an argument
4238 # to stop it building source by default).
4240 # - add -nc to stop dpkg-source cleaning the source tree,
4241 # unless we're not doing a split build and want dpkg-source
4242 # as cleanmode, in which case we can do nothing
4245 # 0 - source will NOT need to be built separately by caller
4246 # +1 - source will need to be built separately by caller
4247 # +2 - source will need to be built separately by caller AND
4248 # dpkg-buildpackage should not in fact be run at all!
4249 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4250 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4251 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4252 $clean_using_builder = 1;
4255 # -nc has the side effect of specifying -b if nothing else specified
4256 # and some combinations of -S, -b, et al, are errors, rather than
4257 # later simply overriding earlie. So we need to:
4258 # - search the command line for these options
4259 # - pick the last one
4260 # - perhaps add our own as a default
4261 # - perhaps adjust it to the corresponding non-source-building version
4263 foreach my $l ($cmd, $xargs) {
4265 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4268 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4270 if ($need_split_build_invocation) {
4271 printdebug "massage split $dmode.\n";
4272 $r = $dmode =~ m/[S]/ ? +2 :
4273 $dmode =~ y/gGF/ABb/ ? +1 :
4274 $dmode =~ m/[ABb]/ ? 0 :
4277 printdebug "massage done $r $dmode.\n";
4279 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4284 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4285 my $wantsrc = massage_dbp_args \@dbp;
4292 push @dbp, changesopts_version();
4293 maybe_apply_patches_dirtily();
4294 runcmd_ordryrun_local @dbp;
4296 maybe_unapply_patches_again();
4297 printdone "build successful\n";
4301 my @dbp = @dpkgbuildpackage;
4303 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4306 if (length executable_on_path('git-buildpackage')) {
4307 @cmd = qw(git-buildpackage);
4309 @cmd = qw(gbp buildpackage);
4311 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4316 if (!$clean_using_builder) {
4317 push @cmd, '--git-cleaner=true';
4321 maybe_unapply_patches_again();
4323 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4324 canonicalise_suite();
4325 push @cmd, "--git-debian-branch=".lbranch();
4327 push @cmd, changesopts();
4328 runcmd_ordryrun_local @cmd, @ARGV;
4330 printdone "build successful\n";
4332 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4335 my $our_cleanmode = $cleanmode;
4336 if ($need_split_build_invocation) {
4337 # Pretend that clean is being done some other way. This
4338 # forces us not to try to use dpkg-buildpackage to clean and
4339 # build source all in one go; and instead we run dpkg-source
4340 # (and build_prep() will do the clean since $clean_using_builder
4342 $our_cleanmode = 'ELSEWHERE';
4344 if ($our_cleanmode =~ m/^dpkg-source/) {
4345 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4346 $clean_using_builder = 1;
4349 $sourcechanges = changespat $version,'source';
4351 unlink "../$sourcechanges" or $!==ENOENT
4352 or fail "remove $sourcechanges: $!";
4354 $dscfn = dscfn($version);
4355 if ($our_cleanmode eq 'dpkg-source') {
4356 maybe_apply_patches_dirtily();
4357 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4359 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4360 maybe_apply_patches_dirtily();
4361 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4364 my @cmd = (@dpkgsource, qw(-b --));
4367 runcmd_ordryrun_local @cmd, "work";
4368 my @udfiles = <${package}_*>;
4369 changedir "../../..";
4370 foreach my $f (@udfiles) {
4371 printdebug "source copy, found $f\n";
4374 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4375 $f eq srcfn($version, $&));
4376 printdebug "source copy, found $f - renaming\n";
4377 rename "$ud/$f", "../$f" or $!==ENOENT
4378 or fail "put in place new source file ($f): $!";
4381 my $pwd = must_getcwd();
4382 my $leafdir = basename $pwd;
4384 runcmd_ordryrun_local @cmd, $leafdir;
4387 runcmd_ordryrun_local qw(sh -ec),
4388 'exec >$1; shift; exec "$@"','x',
4389 "../$sourcechanges",
4390 @dpkggenchanges, qw(-S), changesopts();
4394 sub cmd_build_source {
4395 badusage "build-source takes no additional arguments" if @ARGV;
4397 maybe_unapply_patches_again();
4398 printdone "source built, results in $dscfn and $sourcechanges";
4403 my $pat = changespat $version;
4405 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4406 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4407 fail "changes files other than source matching $pat".
4408 " already present (@unwanted);".
4409 " building would result in ambiguity about the intended results"
4412 my $wasdir = must_getcwd();
4415 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4416 stat_exists $sourcechanges
4417 or fail "$sourcechanges (in parent directory): $!";
4419 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4420 my @changesfiles = glob $pat;
4421 @changesfiles = sort {
4422 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4425 fail "wrong number of different changes files (@changesfiles)"
4426 unless @changesfiles==2;
4427 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4428 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4429 fail "$l found in binaries changes file $binchanges"
4432 runcmd_ordryrun_local @mergechanges, @changesfiles;
4433 my $multichanges = changespat $version,'multi';
4435 stat_exists $multichanges or fail "$multichanges: $!";
4436 foreach my $cf (glob $pat) {
4437 next if $cf eq $multichanges;
4438 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4442 maybe_unapply_patches_again();
4443 printdone "build successful, results in $multichanges\n" or die $!;
4446 sub cmd_quilt_fixup {
4447 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4448 my $clogp = parsechangelog();
4449 $version = getfield $clogp, 'Version';
4450 $package = getfield $clogp, 'Source';
4453 build_maybe_quilt_fixup();
4456 sub cmd_archive_api_query {
4457 badusage "need only 1 subpath argument" unless @ARGV==1;
4458 my ($subpath) = @ARGV;
4459 my @cmd = archive_api_query_cmd($subpath);
4461 exec @cmd or fail "exec curl: $!\n";
4464 sub cmd_clone_dgit_repos_server {
4465 badusage "need destination argument" unless @ARGV==1;
4466 my ($destdir) = @ARGV;
4467 $package = '_dgit-repos-server';
4468 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4470 exec @cmd or fail "exec git clone: $!\n";
4473 sub cmd_setup_mergechangelogs {
4474 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4475 setup_mergechangelogs(1);
4478 sub cmd_setup_useremail {
4479 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4483 sub cmd_setup_new_tree {
4484 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4488 #---------- argument parsing and main program ----------
4491 print "dgit version $our_version\n" or die $!;
4495 our (%valopts_long, %valopts_short);
4498 sub defvalopt ($$$$) {
4499 my ($long,$short,$val_re,$how) = @_;
4500 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4501 $valopts_long{$long} = $oi;
4502 $valopts_short{$short} = $oi;
4503 # $how subref should:
4504 # do whatever assignemnt or thing it likes with $_[0]
4505 # if the option should not be passed on to remote, @rvalopts=()
4506 # or $how can be a scalar ref, meaning simply assign the value
4509 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4510 defvalopt '--distro', '-d', '.+', \$idistro;
4511 defvalopt '', '-k', '.+', \$keyid;
4512 defvalopt '--existing-package','', '.*', \$existing_package;
4513 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4514 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4515 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4517 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4519 defvalopt '', '-C', '.+', sub {
4520 ($changesfile) = (@_);
4521 if ($changesfile =~ s#^(.*)/##) {
4522 $buildproductsdir = $1;
4526 defvalopt '--initiator-tempdir','','.*', sub {
4527 ($initiator_tempdir) = (@_);
4528 $initiator_tempdir =~ m#^/# or
4529 badusage "--initiator-tempdir must be used specify an".
4530 " absolute, not relative, directory."
4536 if (defined $ENV{'DGIT_SSH'}) {
4537 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4538 } elsif (defined $ENV{'GIT_SSH'}) {
4539 @ssh = ($ENV{'GIT_SSH'});
4547 if (!defined $val) {
4548 badusage "$what needs a value" unless @ARGV;
4550 push @rvalopts, $val;
4552 badusage "bad value \`$val' for $what" unless
4553 $val =~ m/^$oi->{Re}$(?!\n)/s;
4554 my $how = $oi->{How};
4555 if (ref($how) eq 'SCALAR') {
4560 push @ropts, @rvalopts;
4564 last unless $ARGV[0] =~ m/^-/;
4568 if (m/^--dry-run$/) {
4571 } elsif (m/^--damp-run$/) {
4574 } elsif (m/^--no-sign$/) {
4577 } elsif (m/^--help$/) {
4579 } elsif (m/^--version$/) {
4581 } elsif (m/^--new$/) {
4584 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4585 ($om = $opts_opt_map{$1}) &&
4589 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4590 !$opts_opt_cmdonly{$1} &&
4591 ($om = $opts_opt_map{$1})) {
4594 } elsif (m/^--ignore-dirty$/s) {
4597 } elsif (m/^--no-quilt-fixup$/s) {
4599 $quilt_mode = 'nocheck';
4600 } elsif (m/^--no-rm-on-error$/s) {
4603 } elsif (m/^--overwrite$/s) {
4605 $overwrite_version = '';
4606 } elsif (m/^--overwrite=(.+)$/s) {
4608 $overwrite_version = $1;
4609 } elsif (m/^--(no-)?rm-old-changes$/s) {
4612 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4614 push @deliberatelies, $&;
4615 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4616 # undocumented, for testing
4618 $tagformat_want = [ $1, 'command line', 1 ];
4619 # 1 menas overrides distro configuration
4620 } elsif (m/^--always-split-source-build$/s) {
4621 # undocumented, for testing
4623 $need_split_build_invocation = 1;
4624 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4625 $val = $2 ? $' : undef; #';
4626 $valopt->($oi->{Long});
4628 badusage "unknown long option \`$_'";
4635 } elsif (s/^-L/-/) {
4638 } elsif (s/^-h/-/) {
4640 } elsif (s/^-D/-/) {
4644 } elsif (s/^-N/-/) {
4649 push @changesopts, $_;
4651 } elsif (s/^-wn$//s) {
4653 $cleanmode = 'none';
4654 } elsif (s/^-wg$//s) {
4657 } elsif (s/^-wgf$//s) {
4659 $cleanmode = 'git-ff';
4660 } elsif (s/^-wd$//s) {
4662 $cleanmode = 'dpkg-source';
4663 } elsif (s/^-wdd$//s) {
4665 $cleanmode = 'dpkg-source-d';
4666 } elsif (s/^-wc$//s) {
4668 $cleanmode = 'check';
4669 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4671 $val = undef unless length $val;
4672 $valopt->($oi->{Short});
4675 badusage "unknown short option \`$_'";
4682 sub finalise_opts_opts () {
4683 foreach my $k (keys %opts_opt_map) {
4684 my $om = $opts_opt_map{$k};
4686 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4688 badcfg "cannot set command for $k"
4689 unless length $om->[0];
4693 foreach my $c (access_cfg_cfgs("opts-$k")) {
4694 my $vl = $gitcfg{$c};
4695 printdebug "CL $c ",
4696 ($vl ? join " ", map { shellquote } @$vl : ""),
4697 "\n" if $debuglevel >= 4;
4699 badcfg "cannot configure options for $k"
4700 if $opts_opt_cmdonly{$k};
4701 my $insertpos = $opts_cfg_insertpos{$k};
4702 @$om = ( @$om[0..$insertpos-1],
4704 @$om[$insertpos..$#$om] );
4709 if ($ENV{$fakeeditorenv}) {
4711 quilt_fixup_editor();
4717 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4718 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4719 if $dryrun_level == 1;
4721 print STDERR $helpmsg or die $!;
4724 my $cmd = shift @ARGV;
4727 if (!defined $rmchanges) {
4728 local $access_forpush;
4729 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4732 if (!defined $quilt_mode) {
4733 local $access_forpush;
4734 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4735 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4737 $quilt_mode =~ m/^($quilt_modes_re)$/
4738 or badcfg "unknown quilt-mode \`$quilt_mode'";
4742 $need_split_build_invocation ||= quiltmode_splitbrain();
4744 if (!defined $cleanmode) {
4745 local $access_forpush;
4746 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4747 $cleanmode //= 'dpkg-source';
4749 badcfg "unknown clean-mode \`$cleanmode'" unless
4750 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4753 my $fn = ${*::}{"cmd_$cmd"};
4754 $fn or badusage "unknown operation $cmd";