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 () {
1378 # changes into the subdir
1380 die "@dirs ?" unless @dirs==1;
1381 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1385 remove_stray_gits();
1386 mktree_in_ud_here();
1387 my ($format, $fopts) = get_source_format();
1388 if (madformat($format)) {
1391 runcmd @git, qw(add -Af);
1392 my $tree=git_write_tree();
1393 return ($tree,$dir);
1396 sub dsc_files_info () {
1397 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1398 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1399 ['Files', 'Digest::MD5', 'new()']) {
1400 my ($fname, $module, $method) = @$csumi;
1401 my $field = $dsc->{$fname};
1402 next unless defined $field;
1403 eval "use $module; 1;" or die $@;
1405 foreach (split /\n/, $field) {
1407 m/^(\w+) (\d+) (\S+)$/ or
1408 fail "could not parse .dsc $fname line \`$_'";
1409 my $digester = eval "$module"."->$method;" or die $@;
1414 Digester => $digester,
1419 fail "missing any supported Checksums-* or Files field in ".
1420 $dsc->get_option('name');
1424 map { $_->{Filename} } dsc_files_info();
1427 sub is_orig_file ($;$) {
1430 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1431 defined $base or return 1;
1435 sub make_commit ($) {
1437 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1440 sub clogp_authline ($) {
1442 my $author = getfield $clogp, 'Maintainer';
1443 $author =~ s#,.*##ms;
1444 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1445 my $authline = "$author $date";
1446 $authline =~ m/$git_authline_re/o or
1447 fail "unexpected commit author line format \`$authline'".
1448 " (was generated from changelog Maintainer field)";
1449 return ($1,$2,$3) if wantarray;
1453 sub vendor_patches_distro ($$) {
1454 my ($checkdistro, $what) = @_;
1455 return unless defined $checkdistro;
1457 my $series = "debian/patches/\L$checkdistro\E.series";
1458 printdebug "checking for vendor-specific $series ($what)\n";
1460 if (!open SERIES, "<", $series) {
1461 die "$series $!" unless $!==ENOENT;
1470 Unfortunately, this source package uses a feature of dpkg-source where
1471 the same source package unpacks to different source code on different
1472 distros. dgit cannot safely operate on such packages on affected
1473 distros, because the meaning of source packages is not stable.
1475 Please ask the distro/maintainer to remove the distro-specific series
1476 files and use a different technique (if necessary, uploading actually
1477 different packages, if different distros are supposed to have
1481 fail "Found active distro-specific series file for".
1482 " $checkdistro ($what): $series, cannot continue";
1484 die "$series $!" if SERIES->error;
1488 sub check_for_vendor_patches () {
1489 # This dpkg-source feature doesn't seem to be documented anywhere!
1490 # But it can be found in the changelog (reformatted):
1492 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1493 # Author: Raphael Hertzog <hertzog@debian.org>
1494 # Date: Sun Oct 3 09:36:48 2010 +0200
1496 # dpkg-source: correctly create .pc/.quilt_series with alternate
1499 # If you have debian/patches/ubuntu.series and you were
1500 # unpacking the source package on ubuntu, quilt was still
1501 # directed to debian/patches/series instead of
1502 # debian/patches/ubuntu.series.
1504 # debian/changelog | 3 +++
1505 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1506 # 2 files changed, 6 insertions(+), 1 deletion(-)
1509 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1510 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1511 "Dpkg::Vendor \`current vendor'");
1512 vendor_patches_distro(access_basedistro(),
1513 "distro being accessed");
1516 sub generate_commits_from_dsc () {
1517 # See big comment in fetch_from_archive, below.
1521 foreach my $fi (dsc_files_info()) {
1522 my $f = $fi->{Filename};
1523 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1525 link_ltarget "../../../$f", $f
1529 complete_file_from_dsc('.', $fi)
1532 if (is_orig_file($f)) {
1533 link $f, "../../../../$f"
1539 my $dscfn = "$package.dsc";
1541 open D, ">", $dscfn or die "$dscfn: $!";
1542 print D $dscdata or die "$dscfn: $!";
1543 close D or die "$dscfn: $!";
1544 my @cmd = qw(dpkg-source);
1545 push @cmd, '--no-check' if $dsc_checked;
1546 push @cmd, qw(-x --), $dscfn;
1549 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1550 check_for_vendor_patches() if madformat($dsc->{format});
1551 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1552 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1553 my $authline = clogp_authline $clogp;
1554 my $changes = getfield $clogp, 'Changes';
1555 open C, ">../commit.tmp" or die $!;
1556 print C <<END or die $!;
1563 # imported from the archive
1566 my $rawimport_hash = make_commit qw(../commit.tmp);
1567 my $cversion = getfield $clogp, 'Version';
1568 my $rawimport_mergeinput = {
1569 Commit => $rawimport_hash,
1570 Info => "Import of source package",
1572 my @output = ($rawimport_mergeinput);
1573 progress "synthesised git commit from .dsc $cversion";
1574 if ($lastpush_mergeinput) {
1575 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1576 my $oversion = getfield $oldclogp, 'Version';
1578 version_compare($oversion, $cversion);
1580 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1581 { Message => <<END, ReverseParents => 1 });
1582 Record $package ($cversion) in archive suite $csuite
1584 } elsif ($vcmp > 0) {
1585 print STDERR <<END or die $!;
1587 Version actually in archive: $cversion (older)
1588 Last version pushed with dgit: $oversion (newer or same)
1591 @output = $lastpush_mergeinput;
1593 # Same version. Use what's in the server git branch,
1594 # discarding our own import. (This could happen if the
1595 # server automatically imports all packages into git.)
1596 @output = $lastpush_mergeinput;
1599 changedir '../../../..';
1604 sub complete_file_from_dsc ($$) {
1605 our ($dstdir, $fi) = @_;
1606 # Ensures that we have, in $dir, the file $fi, with the correct
1607 # contents. (Downloading it from alongside $dscurl if necessary.)
1609 my $f = $fi->{Filename};
1610 my $tf = "$dstdir/$f";
1613 if (stat_exists $tf) {
1614 progress "using existing $f";
1617 $furl =~ s{/[^/]+$}{};
1619 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1620 die "$f ?" if $f =~ m#/#;
1621 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1622 return 0 if !act_local();
1626 open F, "<", "$tf" or die "$tf: $!";
1627 $fi->{Digester}->reset();
1628 $fi->{Digester}->addfile(*F);
1629 F->error and die $!;
1630 my $got = $fi->{Digester}->hexdigest();
1631 $got eq $fi->{Hash} or
1632 fail "file $f has hash $got but .dsc".
1633 " demands hash $fi->{Hash} ".
1634 ($downloaded ? "(got wrong file from archive!)"
1635 : "(perhaps you should delete this file?)");
1640 sub ensure_we_have_orig () {
1641 foreach my $fi (dsc_files_info()) {
1642 my $f = $fi->{Filename};
1643 next unless is_orig_file($f);
1644 complete_file_from_dsc('..', $fi)
1649 sub git_fetch_us () {
1650 # Want to fetch only what we are going to use, unless
1651 # deliberately-not-ff, in which case we must fetch everything.
1653 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1655 (quiltmode_splitbrain
1656 ? (map { $_->('*',access_basedistro) }
1657 \&debiantag_new, \&debiantag_maintview)
1658 : debiantags('*',access_basedistro));
1659 push @specs, server_branch($csuite);
1660 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1662 # This is rather miserable:
1663 # When git-fetch --prune is passed a fetchspec ending with a *,
1664 # it does a plausible thing. If there is no * then:
1665 # - it matches subpaths too, even if the supplied refspec
1666 # starts refs, and behaves completely madly if the source
1667 # has refs/refs/something. (See, for example, Debian #NNNN.)
1668 # - if there is no matching remote ref, it bombs out the whole
1670 # We want to fetch a fixed ref, and we don't know in advance
1671 # if it exists, so this is not suitable.
1673 # Our workaround is to use git-ls-remote. git-ls-remote has its
1674 # own qairks. Notably, it has the absurd multi-tail-matching
1675 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1676 # refs/refs/foo etc.
1678 # Also, we want an idempotent snapshot, but we have to make two
1679 # calls to the remote: one to git-ls-remote and to git-fetch. The
1680 # solution is use git-ls-remote to obtain a target state, and
1681 # git-fetch to try to generate it. If we don't manage to generate
1682 # the target state, we try again.
1684 my $specre = join '|', map {
1690 printdebug "git_fetch_us specre=$specre\n";
1691 my $wanted_rref = sub {
1693 return m/^(?:$specre)$/o;
1696 my $fetch_iteration = 0;
1699 if (++$fetch_iteration > 10) {
1700 fail "too many iterations trying to get sane fetch!";
1703 my @look = map { "refs/$_" } @specs;
1704 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1708 open GITLS, "-|", @lcmd or die $!;
1710 printdebug "=> ", $_;
1711 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1712 my ($objid,$rrefname) = ($1,$2);
1713 if (!$wanted_rref->($rrefname)) {
1715 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1719 $wantr{$rrefname} = $objid;
1722 close GITLS or failedcmd @lcmd;
1724 # OK, now %want is exactly what we want for refs in @specs
1726 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1727 "+refs/$_:".lrfetchrefs."/$_";
1730 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1731 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1734 %lrfetchrefs_f = ();
1737 git_for_each_ref(lrfetchrefs, sub {
1738 my ($objid,$objtype,$lrefname,$reftail) = @_;
1739 $lrfetchrefs_f{$lrefname} = $objid;
1740 $objgot{$objid} = 1;
1743 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1744 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1745 if (!exists $wantr{$rrefname}) {
1746 if ($wanted_rref->($rrefname)) {
1748 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1752 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1755 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1756 delete $lrfetchrefs_f{$lrefname};
1760 foreach my $rrefname (sort keys %wantr) {
1761 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1762 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1763 my $want = $wantr{$rrefname};
1764 next if $got eq $want;
1765 if (!defined $objgot{$want}) {
1767 warning: git-ls-remote suggests we want $lrefname
1768 warning: and it should refer to $want
1769 warning: but git-fetch didn't fetch that object to any relevant ref.
1770 warning: This may be due to a race with someone updating the server.
1771 warning: Will try again...
1773 next FETCH_ITERATION;
1776 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1778 runcmd_ordryrun_local @git, qw(update-ref -m),
1779 "dgit fetch git-fetch fixup", $lrefname, $want;
1780 $lrfetchrefs_f{$lrefname} = $want;
1784 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1785 Dumper(\%lrfetchrefs_f);
1788 my @tagpats = debiantags('*',access_basedistro);
1790 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1791 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1792 printdebug "currently $fullrefname=$objid\n";
1793 $here{$fullrefname} = $objid;
1795 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1796 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1797 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1798 printdebug "offered $lref=$objid\n";
1799 if (!defined $here{$lref}) {
1800 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1801 runcmd_ordryrun_local @upd;
1802 lrfetchref_used $fullrefname;
1803 } elsif ($here{$lref} eq $objid) {
1804 lrfetchref_used $fullrefname;
1807 "Not updateting $lref from $here{$lref} to $objid.\n";
1812 sub mergeinfo_getclogp ($) {
1813 # Ensures thit $mi->{Clogp} exists and returns it
1815 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1818 sub mergeinfo_version ($) {
1819 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1822 sub fetch_from_archive () {
1823 # Ensures that lrref() is what is actually in the archive, one way
1824 # or another, according to us - ie this client's
1825 # appropritaely-updated archive view. Also returns the commit id.
1826 # If there is nothing in the archive, leaves lrref alone and
1827 # returns undef. git_fetch_us must have already been called.
1831 foreach my $field (@ourdscfield) {
1832 $dsc_hash = $dsc->{$field};
1833 last if defined $dsc_hash;
1835 if (defined $dsc_hash) {
1836 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1838 progress "last upload to archive specified git hash";
1840 progress "last upload to archive has NO git hash";
1843 progress "no version available from the archive";
1846 # If the archive's .dsc has a Dgit field, there are three
1847 # relevant git commitids we need to choose between and/or merge
1849 # 1. $dsc_hash: the Dgit field from the archive
1850 # 2. $lastpush_hash: the suite branch on the dgit git server
1851 # 3. $lastfetch_hash: our local tracking brach for the suite
1853 # These may all be distinct and need not be in any fast forward
1856 # If the dsc was pushed to this suite, then the server suite
1857 # branch will have been updated; but it might have been pushed to
1858 # a different suite and copied by the archive. Conversely a more
1859 # recent version may have been pushed with dgit but not appeared
1860 # in the archive (yet).
1862 # $lastfetch_hash may be awkward because archive imports
1863 # (particularly, imports of Dgit-less .dscs) are performed only as
1864 # needed on individual clients, so different clients may perform a
1865 # different subset of them - and these imports are only made
1866 # public during push. So $lastfetch_hash may represent a set of
1867 # imports different to a subsequent upload by a different dgit
1870 # Our approach is as follows:
1872 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1873 # descendant of $dsc_hash, then it was pushed by a dgit user who
1874 # had based their work on $dsc_hash, so we should prefer it.
1875 # Otherwise, $dsc_hash was installed into this suite in the
1876 # archive other than by a dgit push, and (necessarily) after the
1877 # last dgit push into that suite (since a dgit push would have
1878 # been descended from the dgit server git branch); thus, in that
1879 # case, we prefer the archive's version (and produce a
1880 # pseudo-merge to overwrite the dgit server git branch).
1882 # (If there is no Dgit field in the archive's .dsc then
1883 # generate_commit_from_dsc uses the version numbers to decide
1884 # whether the suite branch or the archive is newer. If the suite
1885 # branch is newer it ignores the archive's .dsc; otherwise it
1886 # generates an import of the .dsc, and produces a pseudo-merge to
1887 # overwrite the suite branch with the archive contents.)
1889 # The outcome of that part of the algorithm is the `public view',
1890 # and is same for all dgit clients: it does not depend on any
1891 # unpublished history in the local tracking branch.
1893 # As between the public view and the local tracking branch: The
1894 # local tracking branch is only updated by dgit fetch, and
1895 # whenever dgit fetch runs it includes the public view in the
1896 # local tracking branch. Therefore if the public view is not
1897 # descended from the local tracking branch, the local tracking
1898 # branch must contain history which was imported from the archive
1899 # but never pushed; and, its tip is now out of date. So, we make
1900 # a pseudo-merge to overwrite the old imports and stitch the old
1903 # Finally: we do not necessarily reify the public view (as
1904 # described above). This is so that we do not end up stacking two
1905 # pseudo-merges. So what we actually do is figure out the inputs
1906 # to any public view pseudo-merge and put them in @mergeinputs.
1909 # $mergeinputs[]{Commit}
1910 # $mergeinputs[]{Info}
1911 # $mergeinputs[0] is the one whose tree we use
1912 # @mergeinputs is in the order we use in the actual commit)
1915 # $mergeinputs[]{Message} is a commit message to use
1916 # $mergeinputs[]{ReverseParents} if def specifies that parent
1917 # list should be in opposite order
1918 # Such an entry has no Commit or Info. It applies only when found
1919 # in the last entry. (This ugliness is to support making
1920 # identical imports to previous dgit versions.)
1922 my $lastpush_hash = git_get_ref(lrfetchref());
1923 printdebug "previous reference hash=$lastpush_hash\n";
1924 $lastpush_mergeinput = $lastpush_hash && {
1925 Commit => $lastpush_hash,
1926 Info => "dgit suite branch on dgit git server",
1929 my $lastfetch_hash = git_get_ref(lrref());
1930 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1931 my $lastfetch_mergeinput = $lastfetch_hash && {
1932 Commit => $lastfetch_hash,
1933 Info => "dgit client's archive history view",
1936 my $dsc_mergeinput = $dsc_hash && {
1937 Commit => $dsc_hash,
1938 Info => "Dgit field in .dsc from archive",
1942 my $del_lrfetchrefs = sub {
1945 printdebug "del_lrfetchrefs...\n";
1946 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1947 my $objid = $lrfetchrefs_d{$fullrefname};
1948 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1950 $gur ||= new IO::Handle;
1951 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1953 printf $gur "delete %s %s\n", $fullrefname, $objid;
1956 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1960 if (defined $dsc_hash) {
1961 fail "missing remote git history even though dsc has hash -".
1962 " could not find ref ".rref()." at ".access_giturl()
1963 unless $lastpush_hash;
1964 ensure_we_have_orig();
1965 if ($dsc_hash eq $lastpush_hash) {
1966 @mergeinputs = $dsc_mergeinput
1967 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1968 print STDERR <<END or die $!;
1970 Git commit in archive is behind the last version allegedly pushed/uploaded.
1971 Commit referred to by archive: $dsc_hash
1972 Last version pushed with dgit: $lastpush_hash
1975 @mergeinputs = ($lastpush_mergeinput);
1977 # Archive has .dsc which is not a descendant of the last dgit
1978 # push. This can happen if the archive moves .dscs about.
1979 # Just follow its lead.
1980 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1981 progress "archive .dsc names newer git commit";
1982 @mergeinputs = ($dsc_mergeinput);
1984 progress "archive .dsc names other git commit, fixing up";
1985 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1989 @mergeinputs = generate_commits_from_dsc();
1990 # We have just done an import. Now, our import algorithm might
1991 # have been improved. But even so we do not want to generate
1992 # a new different import of the same package. So if the
1993 # version numbers are the same, just use our existing version.
1994 # If the version numbers are different, the archive has changed
1995 # (perhaps, rewound).
1996 if ($lastfetch_mergeinput &&
1997 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1998 (mergeinfo_version $mergeinputs[0]) )) {
1999 @mergeinputs = ($lastfetch_mergeinput);
2001 } elsif ($lastpush_hash) {
2002 # only in git, not in the archive yet
2003 @mergeinputs = ($lastpush_mergeinput);
2004 print STDERR <<END or die $!;
2006 Package not found in the archive, but has allegedly been pushed using dgit.
2010 printdebug "nothing found!\n";
2011 if (defined $skew_warning_vsn) {
2012 print STDERR <<END or die $!;
2014 Warning: relevant archive skew detected.
2015 Archive allegedly contains $skew_warning_vsn
2016 But we were not able to obtain any version from the archive or git.
2020 unshift @end, $del_lrfetchrefs;
2024 if ($lastfetch_hash &&
2026 my $h = $_->{Commit};
2027 $h and is_fast_fwd($lastfetch_hash, $h);
2028 # If true, one of the existing parents of this commit
2029 # is a descendant of the $lastfetch_hash, so we'll
2030 # be ff from that automatically.
2034 push @mergeinputs, $lastfetch_mergeinput;
2037 printdebug "fetch mergeinfos:\n";
2038 foreach my $mi (@mergeinputs) {
2040 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2042 printdebug sprintf " ReverseParents=%d Message=%s",
2043 $mi->{ReverseParents}, $mi->{Message};
2047 my $compat_info= pop @mergeinputs
2048 if $mergeinputs[$#mergeinputs]{Message};
2050 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2053 if (@mergeinputs > 1) {
2055 my $tree_commit = $mergeinputs[0]{Commit};
2057 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2058 $tree =~ m/\n\n/; $tree = $`;
2059 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2062 # We use the changelog author of the package in question the
2063 # author of this pseudo-merge. This is (roughly) correct if
2064 # this commit is simply representing aa non-dgit upload.
2065 # (Roughly because it does not record sponsorship - but we
2066 # don't have sponsorship info because that's in the .changes,
2067 # which isn't in the archivw.)
2069 # But, it might be that we are representing archive history
2070 # updates (including in-archive copies). These are not really
2071 # the responsibility of the person who created the .dsc, but
2072 # there is no-one whose name we should better use. (The
2073 # author of the .dsc-named commit is clearly worse.)
2075 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2076 my $author = clogp_authline $useclogp;
2077 my $cversion = getfield $useclogp, 'Version';
2079 my $mcf = ".git/dgit/mergecommit";
2080 open MC, ">", $mcf or die "$mcf $!";
2081 print MC <<END or die $!;
2085 my @parents = grep { $_->{Commit} } @mergeinputs;
2086 @parents = reverse @parents if $compat_info->{ReverseParents};
2087 print MC <<END or die $! foreach @parents;
2091 print MC <<END or die $!;
2097 if (defined $compat_info->{Message}) {
2098 print MC $compat_info->{Message} or die $!;
2100 print MC <<END or die $!;
2101 Record $package ($cversion) in archive suite $csuite
2105 my $message_add_info = sub {
2107 my $mversion = mergeinfo_version $mi;
2108 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2112 $message_add_info->($mergeinputs[0]);
2113 print MC <<END or die $!;
2114 should be treated as descended from
2116 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2120 $hash = make_commit $mcf;
2122 $hash = $mergeinputs[0]{Commit};
2124 progress "fetch hash=$hash\n";
2127 my ($lasth, $what) = @_;
2128 return unless $lasth;
2129 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2132 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2133 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2135 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2136 'DGIT_ARCHIVE', $hash;
2137 cmdoutput @git, qw(log -n2), $hash;
2138 # ... gives git a chance to complain if our commit is malformed
2140 if (defined $skew_warning_vsn) {
2142 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2143 my $gotclogp = commit_getclogp($hash);
2144 my $got_vsn = getfield $gotclogp, 'Version';
2145 printdebug "SKEW CHECK GOT $got_vsn\n";
2146 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2147 print STDERR <<END or die $!;
2149 Warning: archive skew detected. Using the available version:
2150 Archive allegedly contains $skew_warning_vsn
2151 We were able to obtain only $got_vsn
2157 if ($lastfetch_hash ne $hash) {
2158 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2162 dryrun_report @upd_cmd;
2166 lrfetchref_used lrfetchref();
2168 unshift @end, $del_lrfetchrefs;
2172 sub set_local_git_config ($$) {
2174 runcmd @git, qw(config), $k, $v;
2177 sub setup_mergechangelogs (;$) {
2179 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2181 my $driver = 'dpkg-mergechangelogs';
2182 my $cb = "merge.$driver";
2183 my $attrs = '.git/info/attributes';
2184 ensuredir '.git/info';
2186 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2187 if (!open ATTRS, "<", $attrs) {
2188 $!==ENOENT or die "$attrs: $!";
2192 next if m{^debian/changelog\s};
2193 print NATTRS $_, "\n" or die $!;
2195 ATTRS->error and die $!;
2198 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2201 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2202 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2204 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2207 sub setup_useremail (;$) {
2209 return unless $always || access_cfg_bool(1, 'setup-useremail');
2212 my ($k, $envvar) = @_;
2213 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2214 return unless defined $v;
2215 set_local_git_config "user.$k", $v;
2218 $setup->('email', 'DEBEMAIL');
2219 $setup->('name', 'DEBFULLNAME');
2222 sub setup_new_tree () {
2223 setup_mergechangelogs();
2229 canonicalise_suite();
2230 badusage "dry run makes no sense with clone" unless act_local();
2231 my $hasgit = check_for_git();
2232 mkdir $dstdir or fail "create \`$dstdir': $!";
2234 runcmd @git, qw(init -q);
2235 my $giturl = access_giturl(1);
2236 if (defined $giturl) {
2237 open H, "> .git/HEAD" or die $!;
2238 print H "ref: ".lref()."\n" or die $!;
2240 runcmd @git, qw(remote add), 'origin', $giturl;
2243 progress "fetching existing git history";
2245 runcmd_ordryrun_local @git, qw(fetch origin);
2247 progress "starting new git history";
2249 fetch_from_archive() or no_such_package;
2250 my $vcsgiturl = $dsc->{'Vcs-Git'};
2251 if (length $vcsgiturl) {
2252 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2253 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2256 runcmd @git, qw(reset --hard), lrref();
2257 printdone "ready for work in $dstdir";
2261 if (check_for_git()) {
2264 fetch_from_archive() or no_such_package();
2265 printdone "fetched into ".lrref();
2270 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2272 printdone "fetched to ".lrref()." and merged into HEAD";
2275 sub check_not_dirty () {
2276 foreach my $f (qw(local-options local-patch-header)) {
2277 if (stat_exists "debian/source/$f") {
2278 fail "git tree contains debian/source/$f";
2282 return if $ignoredirty;
2284 my @cmd = (@git, qw(diff --quiet HEAD));
2286 $!=0; $?=-1; system @cmd;
2289 fail "working tree is dirty (does not match HEAD)";
2295 sub commit_admin ($) {
2298 runcmd_ordryrun_local @git, qw(commit -m), $m;
2301 sub commit_quilty_patch () {
2302 my $output = cmdoutput @git, qw(status --porcelain);
2304 foreach my $l (split /\n/, $output) {
2305 next unless $l =~ m/\S/;
2306 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2310 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2312 progress "nothing quilty to commit, ok.";
2315 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2316 runcmd_ordryrun_local @git, qw(add -f), @adds;
2317 commit_admin "Commit Debian 3.0 (quilt) metadata";
2320 sub get_source_format () {
2322 if (open F, "debian/source/options") {
2326 s/\s+$//; # ignore missing final newline
2328 my ($k, $v) = ($`, $'); #');
2329 $v =~ s/^"(.*)"$/$1/;
2335 F->error and die $!;
2338 die $! unless $!==&ENOENT;
2341 if (!open F, "debian/source/format") {
2342 die $! unless $!==&ENOENT;
2346 F->error and die $!;
2348 return ($_, \%options);
2351 sub madformat_wantfixup ($) {
2353 return 0 unless $format eq '3.0 (quilt)';
2354 our $quilt_mode_warned;
2355 if ($quilt_mode eq 'nocheck') {
2356 progress "Not doing any fixup of \`$format' due to".
2357 " ----no-quilt-fixup or --quilt=nocheck"
2358 unless $quilt_mode_warned++;
2361 progress "Format \`$format', need to check/update patch stack"
2362 unless $quilt_mode_warned++;
2366 # An "infopair" is a tuple [ $thing, $what ]
2367 # (often $thing is a commit hash; $what is a description)
2369 sub infopair_cond_equal ($$) {
2371 $x->[0] eq $y->[0] or fail <<END;
2372 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2376 sub infopair_lrf_tag_lookup ($$) {
2377 my ($tagnames, $what) = @_;
2378 # $tagname may be an array ref
2379 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2380 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2381 foreach my $tagname (@tagnames) {
2382 my $lrefname = lrfetchrefs."/tags/$tagname";
2383 my $tagobj = $lrfetchrefs_f{$lrefname};
2384 next unless defined $tagobj;
2385 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2386 return [ git_rev_parse($tagobj), $what ];
2388 fail @tagnames==1 ? <<END : <<END;
2389 Wanted tag $what (@tagnames) on dgit server, but not found
2391 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2395 sub infopair_cond_ff ($$) {
2396 my ($anc,$desc) = @_;
2397 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2398 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2402 sub pseudomerge_version_check ($$) {
2403 my ($clogp, $archive_hash) = @_;
2405 my $arch_clogp = commit_getclogp $archive_hash;
2406 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2407 'version currently in archive' ];
2408 if (defined $overwrite_version) {
2409 if (length $overwrite_version) {
2410 infopair_cond_equal([ $overwrite_version,
2411 '--overwrite= version' ],
2414 my $v = $i_arch_v->[0];
2415 progress "Checking package changelog for archive version $v ...";
2417 my @xa = ("-f$v", "-t$v");
2418 my $vclogp = parsechangelog @xa;
2419 my $cv = [ (getfield $vclogp, 'Version'),
2420 "Version field from dpkg-parsechangelog @xa" ];
2421 infopair_cond_equal($i_arch_v, $cv);
2424 $@ =~ s/^dgit: //gm;
2426 "Perhaps debian/changelog does not mention $v ?";
2431 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2435 sub pseudomerge_make_commit ($$$$ $$) {
2436 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2437 $msg_cmd, $msg_msg) = @_;
2438 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2440 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2441 my $authline = clogp_authline $clogp;
2445 !defined $overwrite_version ? ""
2446 : !length $overwrite_version ? " --overwrite"
2447 : " --overwrite=".$overwrite_version;
2450 my $pmf = ".git/dgit/pseudomerge";
2451 open MC, ">", $pmf or die "$pmf $!";
2452 print MC <<END or die $!;
2455 parent $archive_hash
2465 return make_commit($pmf);
2468 sub splitbrain_pseudomerge ($$$$) {
2469 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2470 # => $merged_dgitview
2471 printdebug "splitbrain_pseudomerge...\n";
2473 # We: debian/PREVIOUS HEAD($maintview)
2474 # expect: o ----------------- o
2477 # a/d/PREVIOUS $dgitview
2480 # we do: `------------------ o
2484 printdebug "splitbrain_pseudomerge...\n";
2486 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2488 return $dgitview unless defined $archive_hash;
2490 if (!defined $overwrite_version) {
2491 progress "Checking that HEAD inciudes all changes in archive...";
2494 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2496 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2497 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2498 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2499 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2500 my $i_archive = [ $archive_hash, "current archive contents" ];
2502 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2504 infopair_cond_equal($i_dgit, $i_archive);
2505 infopair_cond_ff($i_dep14, $i_dgit);
2506 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2508 my $r = pseudomerge_make_commit
2509 $clogp, $dgitview, $archive_hash, $i_arch_v,
2510 "dgit --quilt=$quilt_mode",
2511 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2512 Declare fast forward from $overwrite_version
2514 Make fast forward from $i_arch_v->[0]
2517 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2521 sub plain_overwrite_pseudomerge ($$$) {
2522 my ($clogp, $head, $archive_hash) = @_;
2524 printdebug "plain_overwrite_pseudomerge...";
2526 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2528 my @tagformats = access_cfg_tagformats();
2530 map { $_->($i_arch_v->[0], access_basedistro) }
2531 (grep { m/^(?:old|hist)$/ } @tagformats)
2532 ? \&debiantags : \&debiantag_new;
2533 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2534 my $i_archive = [ $archive_hash, "current archive contents" ];
2536 infopair_cond_equal($i_overwr, $i_archive);
2538 return $head if is_fast_fwd $archive_hash, $head;
2540 my $m = "Declare fast forward from $i_arch_v->[0]";
2542 my $r = pseudomerge_make_commit
2543 $clogp, $head, $archive_hash, $i_arch_v,
2546 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2548 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2552 sub push_parse_changelog ($) {
2555 my $clogp = Dpkg::Control::Hash->new();
2556 $clogp->load($clogpfn) or die;
2558 $package = getfield $clogp, 'Source';
2559 my $cversion = getfield $clogp, 'Version';
2560 my $tag = debiantag($cversion, access_basedistro);
2561 runcmd @git, qw(check-ref-format), $tag;
2563 my $dscfn = dscfn($cversion);
2565 return ($clogp, $cversion, $dscfn);
2568 sub push_parse_dsc ($$$) {
2569 my ($dscfn,$dscfnwhat, $cversion) = @_;
2570 $dsc = parsecontrol($dscfn,$dscfnwhat);
2571 my $dversion = getfield $dsc, 'Version';
2572 my $dscpackage = getfield $dsc, 'Source';
2573 ($dscpackage eq $package && $dversion eq $cversion) or
2574 fail "$dscfn is for $dscpackage $dversion".
2575 " but debian/changelog is for $package $cversion";
2578 sub push_tagwants ($$$$) {
2579 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2582 TagFn => \&debiantag,
2587 if (defined $maintviewhead) {
2589 TagFn => \&debiantag_maintview,
2590 Objid => $maintviewhead,
2591 TfSuffix => '-maintview',
2595 foreach my $tw (@tagwants) {
2596 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2597 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2599 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2603 sub push_mktags ($$ $$ $) {
2605 $changesfile,$changesfilewhat,
2608 die unless $tagwants->[0]{View} eq 'dgit';
2610 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2611 $dsc->save("$dscfn.tmp") or die $!;
2613 my $changes = parsecontrol($changesfile,$changesfilewhat);
2614 foreach my $field (qw(Source Distribution Version)) {
2615 $changes->{$field} eq $clogp->{$field} or
2616 fail "changes field $field \`$changes->{$field}'".
2617 " does not match changelog \`$clogp->{$field}'";
2620 my $cversion = getfield $clogp, 'Version';
2621 my $clogsuite = getfield $clogp, 'Distribution';
2623 # We make the git tag by hand because (a) that makes it easier
2624 # to control the "tagger" (b) we can do remote signing
2625 my $authline = clogp_authline $clogp;
2626 my $delibs = join(" ", "",@deliberatelies);
2627 my $declaredistro = access_basedistro();
2631 my $tfn = $tw->{Tfn};
2632 my $head = $tw->{Objid};
2633 my $tag = $tw->{Tag};
2635 open TO, '>', $tfn->('.tmp') or die $!;
2636 print TO <<END or die $!;
2643 if ($tw->{View} eq 'dgit') {
2644 print TO <<END or die $!;
2645 $package release $cversion for $clogsuite ($csuite) [dgit]
2646 [dgit distro=$declaredistro$delibs]
2648 foreach my $ref (sort keys %previously) {
2649 print TO <<END or die $!;
2650 [dgit previously:$ref=$previously{$ref}]
2653 } elsif ($tw->{View} eq 'maint') {
2654 print TO <<END or die $!;
2655 $package release $cversion for $clogsuite ($csuite)
2656 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2659 die Dumper($tw)."?";
2664 my $tagobjfn = $tfn->('.tmp');
2666 if (!defined $keyid) {
2667 $keyid = access_cfg('keyid','RETURN-UNDEF');
2669 if (!defined $keyid) {
2670 $keyid = getfield $clogp, 'Maintainer';
2672 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2673 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2674 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2675 push @sign_cmd, $tfn->('.tmp');
2676 runcmd_ordryrun @sign_cmd;
2678 $tagobjfn = $tfn->('.signed.tmp');
2679 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2680 $tfn->('.tmp'), $tfn->('.tmp.asc');
2686 my @r = map { $mktag->($_); } @$tagwants;
2690 sub sign_changes ($) {
2691 my ($changesfile) = @_;
2693 my @debsign_cmd = @debsign;
2694 push @debsign_cmd, "-k$keyid" if defined $keyid;
2695 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2696 push @debsign_cmd, $changesfile;
2697 runcmd_ordryrun @debsign_cmd;
2702 printdebug "actually entering push\n";
2704 supplementary_message(<<'END');
2705 Push failed, while checking state of the archive.
2706 You can retry the push, after fixing the problem, if you like.
2708 if (check_for_git()) {
2711 my $archive_hash = fetch_from_archive();
2712 if (!$archive_hash) {
2714 fail "package appears to be new in this suite;".
2715 " if this is intentional, use --new";
2718 supplementary_message(<<'END');
2719 Push failed, while preparing your push.
2720 You can retry the push, after fixing the problem, if you like.
2723 need_tagformat 'new', "quilt mode $quilt_mode"
2724 if quiltmode_splitbrain;
2728 access_giturl(); # check that success is vaguely likely
2731 my $clogpfn = ".git/dgit/changelog.822.tmp";
2732 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2734 responder_send_file('parsed-changelog', $clogpfn);
2736 my ($clogp, $cversion, $dscfn) =
2737 push_parse_changelog("$clogpfn");
2739 my $dscpath = "$buildproductsdir/$dscfn";
2740 stat_exists $dscpath or
2741 fail "looked for .dsc $dscfn, but $!;".
2742 " maybe you forgot to build";
2744 responder_send_file('dsc', $dscpath);
2746 push_parse_dsc($dscpath, $dscfn, $cversion);
2748 my $format = getfield $dsc, 'Format';
2749 printdebug "format $format\n";
2751 my $actualhead = git_rev_parse('HEAD');
2752 my $dgithead = $actualhead;
2753 my $maintviewhead = undef;
2755 if (madformat_wantfixup($format)) {
2756 # user might have not used dgit build, so maybe do this now:
2757 if (quiltmode_splitbrain()) {
2758 my $upstreamversion = $clogp->{Version};
2759 $upstreamversion =~ s/-[^-]*$//;
2761 quilt_make_fake_dsc($upstreamversion);
2762 my ($dgitview, $cachekey) =
2763 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2765 "--quilt=$quilt_mode but no cached dgit view:
2766 perhaps tree changed since dgit build[-source] ?";
2768 $dgithead = splitbrain_pseudomerge($clogp,
2769 $actualhead, $dgitview,
2771 $maintviewhead = $actualhead;
2772 changedir '../../../..';
2773 prep_ud(); # so _only_subdir() works, below
2775 commit_quilty_patch();
2779 if (defined $overwrite_version && !defined $maintviewhead) {
2780 $dgithead = plain_overwrite_pseudomerge($clogp,
2788 if ($archive_hash) {
2789 if (is_fast_fwd($archive_hash, $dgithead)) {
2791 } elsif (deliberately_not_fast_forward) {
2794 fail "dgit push: HEAD is not a descendant".
2795 " of the archive's version.\n".
2796 "To overwrite the archive's contents,".
2797 " pass --overwrite[=VERSION].\n".
2798 "To rewind history, if permitted by the archive,".
2799 " use --deliberately-not-fast-forward.";
2804 progress "checking that $dscfn corresponds to HEAD";
2805 runcmd qw(dpkg-source -x --),
2806 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2807 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2808 check_for_vendor_patches() if madformat($dsc->{format});
2809 changedir '../../../..';
2810 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2811 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2812 debugcmd "+",@diffcmd;
2814 my $r = system @diffcmd;
2817 fail "$dscfn specifies a different tree to your HEAD commit;".
2818 " perhaps you forgot to build".
2819 ($diffopt eq '--exit-code' ? "" :
2820 " (run with -D to see full diff output)");
2825 if (!$changesfile) {
2826 my $pat = changespat $cversion;
2827 my @cs = glob "$buildproductsdir/$pat";
2828 fail "failed to find unique changes file".
2829 " (looked for $pat in $buildproductsdir);".
2830 " perhaps you need to use dgit -C"
2832 ($changesfile) = @cs;
2834 $changesfile = "$buildproductsdir/$changesfile";
2837 # Checks complete, we're going to try and go ahead:
2839 responder_send_file('changes',$changesfile);
2840 responder_send_command("param head $dgithead");
2841 responder_send_command("param csuite $csuite");
2842 responder_send_command("param tagformat $tagformat");
2843 if (defined $maintviewhead) {
2844 die unless ($protovsn//4) >= 4;
2845 responder_send_command("param maint-view $maintviewhead");
2848 if (deliberately_not_fast_forward) {
2849 git_for_each_ref(lrfetchrefs, sub {
2850 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2851 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2852 responder_send_command("previously $rrefname=$objid");
2853 $previously{$rrefname} = $objid;
2857 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2861 supplementary_message(<<'END');
2862 Push failed, while signing the tag.
2863 You can retry the push, after fixing the problem, if you like.
2865 # If we manage to sign but fail to record it anywhere, it's fine.
2866 if ($we_are_responder) {
2867 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2868 responder_receive_files('signed-tag', @tagobjfns);
2870 @tagobjfns = push_mktags($clogp,$dscpath,
2871 $changesfile,$changesfile,
2874 supplementary_message(<<'END');
2875 Push failed, *after* signing the tag.
2876 If you want to try again, you should use a new version number.
2879 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2881 foreach my $tw (@tagwants) {
2882 my $tag = $tw->{Tag};
2883 my $tagobjfn = $tw->{TagObjFn};
2885 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2886 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2887 runcmd_ordryrun_local
2888 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2891 supplementary_message(<<'END');
2892 Push failed, while updating the remote git repository - see messages above.
2893 If you want to try again, you should use a new version number.
2895 if (!check_for_git()) {
2896 create_remote_git_repo();
2899 my @pushrefs = $forceflag.$dgithead.":".rrref();
2900 foreach my $tw (@tagwants) {
2901 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2904 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2905 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2907 supplementary_message(<<'END');
2908 Push failed, after updating the remote git repository.
2909 If you want to try again, you must use a new version number.
2911 if ($we_are_responder) {
2912 my $dryrunsuffix = act_local() ? "" : ".tmp";
2913 responder_receive_files('signed-dsc-changes',
2914 "$dscpath$dryrunsuffix",
2915 "$changesfile$dryrunsuffix");
2918 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2920 progress "[new .dsc left in $dscpath.tmp]";
2922 sign_changes $changesfile;
2925 supplementary_message(<<END);
2926 Push failed, while uploading package(s) to the archive server.
2927 You can retry the upload of exactly these same files with dput of:
2929 If that .changes file is broken, you will need to use a new version
2930 number for your next attempt at the upload.
2932 my $host = access_cfg('upload-host','RETURN-UNDEF');
2933 my @hostarg = defined($host) ? ($host,) : ();
2934 runcmd_ordryrun @dput, @hostarg, $changesfile;
2935 printdone "pushed and uploaded $cversion";
2937 supplementary_message('');
2938 responder_send_command("complete");
2945 badusage "-p is not allowed with clone; specify as argument instead"
2946 if defined $package;
2949 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2950 ($package,$isuite) = @ARGV;
2951 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2952 ($package,$dstdir) = @ARGV;
2953 } elsif (@ARGV==3) {
2954 ($package,$isuite,$dstdir) = @ARGV;
2956 badusage "incorrect arguments to dgit clone";
2958 $dstdir ||= "$package";
2960 if (stat_exists $dstdir) {
2961 fail "$dstdir already exists";
2965 if ($rmonerror && !$dryrun_level) {
2966 $cwd_remove= getcwd();
2968 return unless defined $cwd_remove;
2969 if (!chdir "$cwd_remove") {
2970 return if $!==&ENOENT;
2971 die "chdir $cwd_remove: $!";
2974 rmtree($dstdir) or die "remove $dstdir: $!\n";
2975 } elsif (!grep { $! == $_ }
2976 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2978 print STDERR "check whether to remove $dstdir: $!\n";
2984 $cwd_remove = undef;
2987 sub branchsuite () {
2988 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2989 if ($branch =~ m#$lbranch_re#o) {
2996 sub fetchpullargs () {
2998 if (!defined $package) {
2999 my $sourcep = parsecontrol('debian/control','debian/control');
3000 $package = getfield $sourcep, 'Source';
3003 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3005 my $clogp = parsechangelog();
3006 $isuite = getfield $clogp, 'Distribution';
3008 canonicalise_suite();
3009 progress "fetching from suite $csuite";
3010 } elsif (@ARGV==1) {
3012 canonicalise_suite();
3014 badusage "incorrect arguments to dgit fetch or dgit pull";
3033 badusage "-p is not allowed with dgit push" if defined $package;
3035 my $clogp = parsechangelog();
3036 $package = getfield $clogp, 'Source';
3039 } elsif (@ARGV==1) {
3040 ($specsuite) = (@ARGV);
3042 badusage "incorrect arguments to dgit push";
3044 $isuite = getfield $clogp, 'Distribution';
3046 local ($package) = $existing_package; # this is a hack
3047 canonicalise_suite();
3049 canonicalise_suite();
3051 if (defined $specsuite &&
3052 $specsuite ne $isuite &&
3053 $specsuite ne $csuite) {
3054 fail "dgit push: changelog specifies $isuite ($csuite)".
3055 " but command line specifies $specsuite";
3060 #---------- remote commands' implementation ----------
3062 sub cmd_remote_push_build_host {
3063 my ($nrargs) = shift @ARGV;
3064 my (@rargs) = @ARGV[0..$nrargs-1];
3065 @ARGV = @ARGV[$nrargs..$#ARGV];
3067 my ($dir,$vsnwant) = @rargs;
3068 # vsnwant is a comma-separated list; we report which we have
3069 # chosen in our ready response (so other end can tell if they
3072 $we_are_responder = 1;
3073 $us .= " (build host)";
3077 open PI, "<&STDIN" or die $!;
3078 open STDIN, "/dev/null" or die $!;
3079 open PO, ">&STDOUT" or die $!;
3081 open STDOUT, ">&STDERR" or die $!;
3085 ($protovsn) = grep {
3086 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3087 } @rpushprotovsn_support;
3089 fail "build host has dgit rpush protocol versions ".
3090 (join ",", @rpushprotovsn_support).
3091 " but invocation host has $vsnwant"
3092 unless defined $protovsn;
3094 responder_send_command("dgit-remote-push-ready $protovsn");
3095 rpush_handle_protovsn_bothends();
3100 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3101 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3102 # a good error message)
3104 sub rpush_handle_protovsn_bothends () {
3105 if ($protovsn < 4) {
3106 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3115 my $report = i_child_report();
3116 if (defined $report) {
3117 printdebug "($report)\n";
3118 } elsif ($i_child_pid) {
3119 printdebug "(killing build host child $i_child_pid)\n";
3120 kill 15, $i_child_pid;
3122 if (defined $i_tmp && !defined $initiator_tempdir) {
3124 eval { rmtree $i_tmp; };
3128 END { i_cleanup(); }
3131 my ($base,$selector,@args) = @_;
3132 $selector =~ s/\-/_/g;
3133 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3140 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3148 push @rargs, join ",", @rpushprotovsn_support;
3151 push @rdgit, @ropts;
3152 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3154 my @cmd = (@ssh, $host, shellquote @rdgit);
3157 if (defined $initiator_tempdir) {
3158 rmtree $initiator_tempdir;
3159 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3160 $i_tmp = $initiator_tempdir;
3164 $i_child_pid = open2(\*RO, \*RI, @cmd);
3166 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3167 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3168 $supplementary_message = '' unless $protovsn >= 3;
3170 fail "rpush negotiated protocol version $protovsn".
3171 " which does not support quilt mode $quilt_mode"
3172 if quiltmode_splitbrain;
3174 rpush_handle_protovsn_bothends();
3176 my ($icmd,$iargs) = initiator_expect {
3177 m/^(\S+)(?: (.*))?$/;
3180 i_method "i_resp", $icmd, $iargs;
3184 sub i_resp_progress ($) {
3186 my $msg = protocol_read_bytes \*RO, $rhs;
3190 sub i_resp_supplementary_message ($) {
3192 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3195 sub i_resp_complete {
3196 my $pid = $i_child_pid;
3197 $i_child_pid = undef; # prevents killing some other process with same pid
3198 printdebug "waiting for build host child $pid...\n";
3199 my $got = waitpid $pid, 0;
3200 die $! unless $got == $pid;
3201 die "build host child failed $?" if $?;
3204 printdebug "all done\n";
3208 sub i_resp_file ($) {
3210 my $localname = i_method "i_localname", $keyword;
3211 my $localpath = "$i_tmp/$localname";
3212 stat_exists $localpath and
3213 badproto \*RO, "file $keyword ($localpath) twice";
3214 protocol_receive_file \*RO, $localpath;
3215 i_method "i_file", $keyword;
3220 sub i_resp_param ($) {
3221 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3225 sub i_resp_previously ($) {
3226 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3227 or badproto \*RO, "bad previously spec";
3228 my $r = system qw(git check-ref-format), $1;
3229 die "bad previously ref spec ($r)" if $r;
3230 $previously{$1} = $2;
3235 sub i_resp_want ($) {
3237 die "$keyword ?" if $i_wanted{$keyword}++;
3238 my @localpaths = i_method "i_want", $keyword;
3239 printdebug "[[ $keyword @localpaths\n";
3240 foreach my $localpath (@localpaths) {
3241 protocol_send_file \*RI, $localpath;
3243 print RI "files-end\n" or die $!;
3246 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3248 sub i_localname_parsed_changelog {
3249 return "remote-changelog.822";
3251 sub i_file_parsed_changelog {
3252 ($i_clogp, $i_version, $i_dscfn) =
3253 push_parse_changelog "$i_tmp/remote-changelog.822";
3254 die if $i_dscfn =~ m#/|^\W#;
3257 sub i_localname_dsc {
3258 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3263 sub i_localname_changes {
3264 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3265 $i_changesfn = $i_dscfn;
3266 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3267 return $i_changesfn;
3269 sub i_file_changes { }
3271 sub i_want_signed_tag {
3272 printdebug Dumper(\%i_param, $i_dscfn);
3273 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3274 && defined $i_param{'csuite'}
3275 or badproto \*RO, "premature desire for signed-tag";
3276 my $head = $i_param{'head'};
3277 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3279 my $maintview = $i_param{'maint-view'};
3280 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3283 if ($protovsn >= 4) {
3284 my $p = $i_param{'tagformat'} // '<undef>';
3286 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3289 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3291 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3293 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3296 push_mktags $i_clogp, $i_dscfn,
3297 $i_changesfn, 'remote changes',
3301 sub i_want_signed_dsc_changes {
3302 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3303 sign_changes $i_changesfn;
3304 return ($i_dscfn, $i_changesfn);
3307 #---------- building etc. ----------
3313 #----- `3.0 (quilt)' handling -----
3315 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3317 sub quiltify_dpkg_commit ($$$;$) {
3318 my ($patchname,$author,$msg, $xinfo) = @_;
3322 my $descfn = ".git/dgit/quilt-description.tmp";
3323 open O, '>', $descfn or die "$descfn: $!";
3326 $msg =~ s/^\s+$/ ./mg;
3327 print O <<END or die $!;
3337 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3338 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3339 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3340 runcmd @dpkgsource, qw(--commit .), $patchname;
3344 sub quiltify_trees_differ ($$;$$) {
3345 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3346 # returns true iff the two tree objects differ other than in debian/
3347 # with $finegrained,
3348 # returns bitmask 01 - differ in upstream files except .gitignore
3349 # 02 - differ in .gitignore
3350 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3351 # is set for each modified .gitignore filename $fn
3353 my @cmd = (@git, qw(diff-tree --name-only -z));
3354 push @cmd, qw(-r) if $finegrained;
3356 my $diffs= cmdoutput @cmd;
3358 foreach my $f (split /\0/, $diffs) {
3359 next if $f =~ m#^debian(?:/.*)?$#s;
3360 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3361 $r |= $isignore ? 02 : 01;
3362 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3364 printdebug "quiltify_trees_differ $x $y => $r\n";
3368 sub quiltify_tree_sentinelfiles ($) {
3369 # lists the `sentinel' files present in the tree
3371 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3372 qw(-- debian/rules debian/control);
3377 sub quiltify_splitbrain_needed () {
3378 if (!$split_brain) {
3379 progress "dgit view: changes are required...";
3380 runcmd @git, qw(checkout -q -b dgit-view);
3385 sub quiltify_splitbrain ($$$$$$) {
3386 my ($clogp, $unapplied, $headref, $diffbits,
3387 $editedignores, $cachekey) = @_;
3388 if ($quilt_mode !~ m/gbp|dpm/) {
3389 # treat .gitignore just like any other upstream file
3390 $diffbits = { %$diffbits };
3391 $_ = !!$_ foreach values %$diffbits;
3393 # We would like any commits we generate to be reproducible
3394 my @authline = clogp_authline($clogp);
3395 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3396 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3397 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3399 if ($quilt_mode =~ m/gbp|unapplied/ &&
3400 ($diffbits->{H2O} & 01)) {
3402 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3403 " but git tree differs from orig in upstream files.";
3404 if (!stat_exists "debian/patches") {
3406 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3410 if ($quilt_mode =~ m/dpm/ &&
3411 ($diffbits->{H2A} & 01)) {
3413 --quilt=$quilt_mode specified, implying patches-applied git tree
3414 but git tree differs from result of applying debian/patches to upstream
3417 if ($quilt_mode =~ m/gbp|unapplied/ &&
3418 ($diffbits->{O2A} & 01)) { # some patches
3419 quiltify_splitbrain_needed();
3420 progress "dgit view: creating patches-applied version using gbp pq";
3421 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3422 # gbp pq import creates a fresh branch; push back to dgit-view
3423 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3424 runcmd @git, qw(checkout -q dgit-view);
3426 if ($quilt_mode =~ m/gbp|dpm/ &&
3427 ($diffbits->{O2A} & 02)) {
3429 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3430 tool which does not create patches for changes to upstream
3431 .gitignores: but, such patches exist in debian/patches.
3434 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3435 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3436 quiltify_splitbrain_needed();
3437 progress "dgit view: creating patch to represent .gitignore changes";
3438 ensuredir "debian/patches";
3439 my $gipatch = "debian/patches/auto-gitignore";
3440 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3441 stat GIPATCH or die "$gipatch: $!";
3442 fail "$gipatch already exists; but want to create it".
3443 " to record .gitignore changes" if (stat _)[7];
3444 print GIPATCH <<END or die "$gipatch: $!";
3445 Subject: Update .gitignore from Debian packaging branch
3447 The Debian packaging git branch contains these updates to the upstream
3448 .gitignore file(s). This patch is autogenerated, to provide these
3449 updates to users of the official Debian archive view of the package.
3451 [dgit version $our_version]
3454 close GIPATCH or die "$gipatch: $!";
3455 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3456 $unapplied, $headref, "--", sort keys %$editedignores;
3457 open SERIES, "+>>", "debian/patches/series" or die $!;
3458 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3460 defined read SERIES, $newline, 1 or die $!;
3461 print SERIES "\n" or die $! unless $newline eq "\n";
3462 print SERIES "auto-gitignore\n" or die $!;
3463 close SERIES or die $!;
3464 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3465 commit_admin "Commit patch to update .gitignore";
3468 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3470 changedir '../../../..';
3471 ensuredir ".git/logs/refs/dgit-intern";
3472 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3474 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3477 progress "dgit view: created (commit id $dgitview)";
3479 changedir '.git/dgit/unpack/work';
3482 sub quiltify ($$$$) {
3483 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3485 # Quilt patchification algorithm
3487 # We search backwards through the history of the main tree's HEAD
3488 # (T) looking for a start commit S whose tree object is identical
3489 # to to the patch tip tree (ie the tree corresponding to the
3490 # current dpkg-committed patch series). For these purposes
3491 # `identical' disregards anything in debian/ - this wrinkle is
3492 # necessary because dpkg-source treates debian/ specially.
3494 # We can only traverse edges where at most one of the ancestors'
3495 # trees differs (in changes outside in debian/). And we cannot
3496 # handle edges which change .pc/ or debian/patches. To avoid
3497 # going down a rathole we avoid traversing edges which introduce
3498 # debian/rules or debian/control. And we set a limit on the
3499 # number of edges we are willing to look at.
3501 # If we succeed, we walk forwards again. For each traversed edge
3502 # PC (with P parent, C child) (starting with P=S and ending with
3503 # C=T) to we do this:
3505 # - dpkg-source --commit with a patch name and message derived from C
3506 # After traversing PT, we git commit the changes which
3507 # should be contained within debian/patches.
3509 # The search for the path S..T is breadth-first. We maintain a
3510 # todo list containing search nodes. A search node identifies a
3511 # commit, and looks something like this:
3513 # Commit => $git_commit_id,
3514 # Child => $c, # or undef if P=T
3515 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3516 # Nontrivial => true iff $p..$c has relevant changes
3523 my %considered; # saves being exponential on some weird graphs
3525 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3528 my ($search,$whynot) = @_;
3529 printdebug " search NOT $search->{Commit} $whynot\n";
3530 $search->{Whynot} = $whynot;
3531 push @nots, $search;
3532 no warnings qw(exiting);
3541 my $c = shift @todo;
3542 next if $considered{$c->{Commit}}++;
3544 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3546 printdebug "quiltify investigate $c->{Commit}\n";
3549 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3550 printdebug " search finished hooray!\n";
3555 if ($quilt_mode eq 'nofix') {
3556 fail "quilt fixup required but quilt mode is \`nofix'\n".
3557 "HEAD commit $c->{Commit} differs from tree implied by ".
3558 " debian/patches (tree object $oldtiptree)";
3560 if ($quilt_mode eq 'smash') {
3561 printdebug " search quitting smash\n";
3565 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3566 $not->($c, "has $c_sentinels not $t_sentinels")
3567 if $c_sentinels ne $t_sentinels;
3569 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3570 $commitdata =~ m/\n\n/;
3572 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3573 @parents = map { { Commit => $_, Child => $c } } @parents;
3575 $not->($c, "root commit") if !@parents;
3577 foreach my $p (@parents) {
3578 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3580 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3581 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3583 foreach my $p (@parents) {
3584 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3586 my @cmd= (@git, qw(diff-tree -r --name-only),
3587 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3588 my $patchstackchange = cmdoutput @cmd;
3589 if (length $patchstackchange) {
3590 $patchstackchange =~ s/\n/,/g;
3591 $not->($p, "changed $patchstackchange");
3594 printdebug " search queue P=$p->{Commit} ",
3595 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3601 printdebug "quiltify want to smash\n";
3604 my $x = $_[0]{Commit};
3605 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3608 my $reportnot = sub {
3610 my $s = $abbrev->($notp);
3611 my $c = $notp->{Child};
3612 $s .= "..".$abbrev->($c) if $c;
3613 $s .= ": ".$notp->{Whynot};
3616 if ($quilt_mode eq 'linear') {
3617 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3618 foreach my $notp (@nots) {
3619 print STDERR "$us: ", $reportnot->($notp), "\n";
3621 print STDERR "$us: $_\n" foreach @$failsuggestion;
3622 fail "quilt fixup naive history linearisation failed.\n".
3623 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3624 } elsif ($quilt_mode eq 'smash') {
3625 } elsif ($quilt_mode eq 'auto') {
3626 progress "quilt fixup cannot be linear, smashing...";
3628 die "$quilt_mode ?";
3631 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3632 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3634 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3636 quiltify_dpkg_commit "auto-$version-$target-$time",
3637 (getfield $clogp, 'Maintainer'),
3638 "Automatically generated patch ($clogp->{Version})\n".
3639 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3643 progress "quiltify linearisation planning successful, executing...";
3645 for (my $p = $sref_S;
3646 my $c = $p->{Child};
3648 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3649 next unless $p->{Nontrivial};
3651 my $cc = $c->{Commit};
3653 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3654 $commitdata =~ m/\n\n/ or die "$c ?";
3657 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3660 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3663 my $patchname = $title;
3664 $patchname =~ s/[.:]$//;
3665 $patchname =~ y/ A-Z/-a-z/;
3666 $patchname =~ y/-a-z0-9_.+=~//cd;
3667 $patchname =~ s/^\W/x-$&/;
3668 $patchname = substr($patchname,0,40);
3671 stat "debian/patches/$patchname$index";
3673 $!==ENOENT or die "$patchname$index $!";
3675 runcmd @git, qw(checkout -q), $cc;
3677 # We use the tip's changelog so that dpkg-source doesn't
3678 # produce complaining messages from dpkg-parsechangelog. None
3679 # of the information dpkg-source gets from the changelog is
3680 # actually relevant - it gets put into the original message
3681 # which dpkg-source provides our stunt editor, and then
3683 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3685 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3686 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3688 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3691 runcmd @git, qw(checkout -q master);
3694 sub build_maybe_quilt_fixup () {
3695 my ($format,$fopts) = get_source_format;
3696 return unless madformat_wantfixup $format;
3699 check_for_vendor_patches();
3701 if (quiltmode_splitbrain) {
3702 foreach my $needtf (qw(new maint)) {
3703 next if grep { $_ eq $needtf } access_cfg_tagformats;
3705 quilt mode $quilt_mode requires split view so server needs to support
3706 both "new" and "maint" tag formats, but config says it doesn't.
3711 my $clogp = parsechangelog();
3712 my $headref = git_rev_parse('HEAD');
3717 my $upstreamversion=$version;
3718 $upstreamversion =~ s/-[^-]*$//;
3720 if ($fopts->{'single-debian-patch'}) {
3721 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3723 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3726 die 'bug' if $split_brain && !$need_split_build_invocation;
3728 changedir '../../../..';
3729 runcmd_ordryrun_local
3730 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3733 sub quilt_fixup_mkwork ($) {
3736 mkdir "work" or die $!;
3738 mktree_in_ud_here();
3739 runcmd @git, qw(reset -q --hard), $headref;
3742 sub quilt_fixup_linkorigs ($$) {
3743 my ($upstreamversion, $fn) = @_;
3744 # calls $fn->($leafname);
3746 foreach my $f (<../../../../*>) { #/){
3747 my $b=$f; $b =~ s{.*/}{};
3749 local ($debuglevel) = $debuglevel-1;
3750 printdebug "QF linkorigs $b, $f ?\n";
3752 next unless is_orig_file $b, srcfn $upstreamversion,'';
3753 printdebug "QF linkorigs $b, $f Y\n";
3754 link_ltarget $f, $b or die "$b $!";
3759 sub quilt_fixup_delete_pc () {
3760 runcmd @git, qw(rm -rqf .pc);
3761 commit_admin "Commit removal of .pc (quilt series tracking data)";
3764 sub quilt_fixup_singlepatch ($$$) {
3765 my ($clogp, $headref, $upstreamversion) = @_;
3767 progress "starting quiltify (single-debian-patch)";
3769 # dpkg-source --commit generates new patches even if
3770 # single-debian-patch is in debian/source/options. In order to
3771 # get it to generate debian/patches/debian-changes, it is
3772 # necessary to build the source package.
3774 quilt_fixup_linkorigs($upstreamversion, sub { });
3775 quilt_fixup_mkwork($headref);
3777 rmtree("debian/patches");
3779 runcmd @dpkgsource, qw(-b .);
3781 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3782 rename srcfn("$upstreamversion", "/debian/patches"),
3783 "work/debian/patches";
3786 commit_quilty_patch();
3789 sub quilt_make_fake_dsc ($) {
3790 my ($upstreamversion) = @_;
3792 my $fakeversion="$upstreamversion-~~DGITFAKE";
3794 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3795 print $fakedsc <<END or die $!;
3798 Version: $fakeversion
3802 my $dscaddfile=sub {
3805 my $md = new Digest::MD5;
3807 my $fh = new IO::File $b, '<' or die "$b $!";
3812 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3815 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3817 my @files=qw(debian/source/format debian/rules
3818 debian/control debian/changelog);
3819 foreach my $maybe (qw(debian/patches debian/source/options
3820 debian/tests/control)) {
3821 next unless stat_exists "../../../$maybe";
3822 push @files, $maybe;
3825 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3826 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3828 $dscaddfile->($debtar);
3829 close $fakedsc or die $!;
3832 sub quilt_check_splitbrain_cache ($$) {
3833 my ($headref, $upstreamversion) = @_;
3834 # Called only if we are in (potentially) split brain mode.
3836 # Computes the cache key and looks in the cache.
3837 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3839 my $splitbrain_cachekey;
3842 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3843 # we look in the reflog of dgit-intern/quilt-cache
3844 # we look for an entry whose message is the key for the cache lookup
3845 my @cachekey = (qw(dgit), $our_version);
3846 push @cachekey, $upstreamversion;
3847 push @cachekey, $quilt_mode;
3848 push @cachekey, $headref;
3850 push @cachekey, hashfile('fake.dsc');
3852 my $srcshash = Digest::SHA->new(256);
3853 my %sfs = ( %INC, '$0(dgit)' => $0 );
3854 foreach my $sfk (sort keys %sfs) {
3855 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3856 $srcshash->add($sfk," ");
3857 $srcshash->add(hashfile($sfs{$sfk}));
3858 $srcshash->add("\n");
3860 push @cachekey, $srcshash->hexdigest();
3861 $splitbrain_cachekey = "@cachekey";
3863 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3865 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3866 debugcmd "|(probably)",@cmd;
3867 my $child = open GC, "-|"; defined $child or die $!;
3869 chdir '../../..' or die $!;
3870 if (!stat ".git/logs/refs/$splitbraincache") {
3871 $! == ENOENT or die $!;
3872 printdebug ">(no reflog)\n";
3879 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3880 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3883 quilt_fixup_mkwork($headref);
3884 if ($cachehit ne $headref) {
3885 progress "dgit view: found cached (commit id $cachehit)";
3886 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3888 return ($cachehit, $splitbrain_cachekey);
3890 progress "dgit view: found cached, no changes required";
3891 return ($headref, $splitbrain_cachekey);
3893 die $! if GC->error;
3894 failedcmd unless close GC;
3896 printdebug "splitbrain cache miss\n";
3897 return (undef, $splitbrain_cachekey);
3900 sub quilt_fixup_multipatch ($$$) {
3901 my ($clogp, $headref, $upstreamversion) = @_;
3903 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3906 # - honour any existing .pc in case it has any strangeness
3907 # - determine the git commit corresponding to the tip of
3908 # the patch stack (if there is one)
3909 # - if there is such a git commit, convert each subsequent
3910 # git commit into a quilt patch with dpkg-source --commit
3911 # - otherwise convert all the differences in the tree into
3912 # a single git commit
3916 # Our git tree doesn't necessarily contain .pc. (Some versions of
3917 # dgit would include the .pc in the git tree.) If there isn't
3918 # one, we need to generate one by unpacking the patches that we
3921 # We first look for a .pc in the git tree. If there is one, we
3922 # will use it. (This is not the normal case.)
3924 # Otherwise need to regenerate .pc so that dpkg-source --commit
3925 # can work. We do this as follows:
3926 # 1. Collect all relevant .orig from parent directory
3927 # 2. Generate a debian.tar.gz out of
3928 # debian/{patches,rules,source/format,source/options}
3929 # 3. Generate a fake .dsc containing just these fields:
3930 # Format Source Version Files
3931 # 4. Extract the fake .dsc
3932 # Now the fake .dsc has a .pc directory.
3933 # (In fact we do this in every case, because in future we will
3934 # want to search for a good base commit for generating patches.)
3936 # Then we can actually do the dpkg-source --commit
3937 # 1. Make a new working tree with the same object
3938 # store as our main tree and check out the main
3940 # 2. Copy .pc from the fake's extraction, if necessary
3941 # 3. Run dpkg-source --commit
3942 # 4. If the result has changes to debian/, then
3943 # - git-add them them
3944 # - git-add .pc if we had a .pc in-tree
3946 # 5. If we had a .pc in-tree, delete it, and git-commit
3947 # 6. Back in the main tree, fast forward to the new HEAD
3949 # Another situation we may have to cope with is gbp-style
3950 # patches-unapplied trees.
3952 # We would want to detect these, so we know to escape into
3953 # quilt_fixup_gbp. However, this is in general not possible.
3954 # Consider a package with a one patch which the dgit user reverts
3955 # (with git-revert or the moral equivalent).
3957 # That is indistinguishable in contents from a patches-unapplied
3958 # tree. And looking at the history to distinguish them is not
3959 # useful because the user might have made a confusing-looking git
3960 # history structure (which ought to produce an error if dgit can't
3961 # cope, not a silent reintroduction of an unwanted patch).
3963 # So gbp users will have to pass an option. But we can usually
3964 # detect their failure to do so: if the tree is not a clean
3965 # patches-applied tree, quilt linearisation fails, but the tree
3966 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3967 # they want --quilt=unapplied.
3969 # To help detect this, when we are extracting the fake dsc, we
3970 # first extract it with --skip-patches, and then apply the patches
3971 # afterwards with dpkg-source --before-build. That lets us save a
3972 # tree object corresponding to .origs.
3974 my $splitbrain_cachekey;
3976 quilt_make_fake_dsc($upstreamversion);
3978 if (quiltmode_splitbrain()) {
3980 ($cachehit, $splitbrain_cachekey) =
3981 quilt_check_splitbrain_cache($headref, $upstreamversion);
3982 return if $cachehit;
3986 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3988 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3989 rename $fakexdir, "fake" or die "$fakexdir $!";
3993 remove_stray_gits();
3994 mktree_in_ud_here();
3998 runcmd @git, qw(add -Af .);
3999 my $unapplied=git_write_tree();
4000 printdebug "fake orig tree object $unapplied\n";
4005 'exec dpkg-source --before-build . >/dev/null';
4009 quilt_fixup_mkwork($headref);
4012 if (stat_exists ".pc") {
4014 progress "Tree already contains .pc - will use it then delete it.";
4017 rename '../fake/.pc','.pc' or die $!;
4020 changedir '../fake';
4022 runcmd @git, qw(add -Af .);
4023 my $oldtiptree=git_write_tree();
4024 printdebug "fake o+d/p tree object $unapplied\n";
4025 changedir '../work';
4028 # We calculate some guesswork now about what kind of tree this might
4029 # be. This is mostly for error reporting.
4034 # O = orig, without patches applied
4035 # A = "applied", ie orig with H's debian/patches applied
4036 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4037 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4038 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4042 foreach my $b (qw(01 02)) {
4043 foreach my $v (qw(H2O O2A H2A)) {
4044 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4047 printdebug "differences \@dl @dl.\n";
4050 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4051 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4052 $dl[0], $dl[1], $dl[3], $dl[4],
4056 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4057 push @failsuggestion, "This might be a patches-unapplied branch.";
4058 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4059 push @failsuggestion, "This might be a patches-applied branch.";
4061 push @failsuggestion, "Maybe you need to specify one of".
4062 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4064 if (quiltmode_splitbrain()) {
4065 quiltify_splitbrain($clogp, $unapplied, $headref,
4066 $diffbits, \%editedignores,
4067 $splitbrain_cachekey);
4071 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4072 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4074 if (!open P, '>>', ".pc/applied-patches") {
4075 $!==&ENOENT or die $!;
4080 commit_quilty_patch();
4082 if ($mustdeletepc) {
4083 quilt_fixup_delete_pc();
4087 sub quilt_fixup_editor () {
4088 my $descfn = $ENV{$fakeeditorenv};
4089 my $editing = $ARGV[$#ARGV];
4090 open I1, '<', $descfn or die "$descfn: $!";
4091 open I2, '<', $editing or die "$editing: $!";
4092 unlink $editing or die "$editing: $!";
4093 open O, '>', $editing or die "$editing: $!";
4094 while (<I1>) { print O or die $!; } I1->error and die $!;
4097 $copying ||= m/^\-\-\- /;
4098 next unless $copying;
4101 I2->error and die $!;
4106 sub maybe_apply_patches_dirtily () {
4107 return unless $quilt_mode =~ m/gbp|unapplied/;
4108 print STDERR <<END or die $!;
4110 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4111 dgit: Have to apply the patches - making the tree dirty.
4112 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4115 $patches_applied_dirtily = 01;
4116 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4117 runcmd qw(dpkg-source --before-build .);
4120 sub maybe_unapply_patches_again () {
4121 progress "dgit: Unapplying patches again to tidy up the tree."
4122 if $patches_applied_dirtily;
4123 runcmd qw(dpkg-source --after-build .)
4124 if $patches_applied_dirtily & 01;
4126 if $patches_applied_dirtily & 02;
4127 $patches_applied_dirtily = 0;
4130 #----- other building -----
4132 our $clean_using_builder;
4133 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4134 # clean the tree before building (perhaps invoked indirectly by
4135 # whatever we are using to run the build), rather than separately
4136 # and explicitly by us.
4139 return if $clean_using_builder;
4140 if ($cleanmode eq 'dpkg-source') {
4141 maybe_apply_patches_dirtily();
4142 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4143 } elsif ($cleanmode eq 'dpkg-source-d') {
4144 maybe_apply_patches_dirtily();
4145 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4146 } elsif ($cleanmode eq 'git') {
4147 runcmd_ordryrun_local @git, qw(clean -xdf);
4148 } elsif ($cleanmode eq 'git-ff') {
4149 runcmd_ordryrun_local @git, qw(clean -xdff);
4150 } elsif ($cleanmode eq 'check') {
4151 my $leftovers = cmdoutput @git, qw(clean -xdn);
4152 if (length $leftovers) {
4153 print STDERR $leftovers, "\n" or die $!;
4154 fail "tree contains uncommitted files and --clean=check specified";
4156 } elsif ($cleanmode eq 'none') {
4163 badusage "clean takes no additional arguments" if @ARGV;
4166 maybe_unapply_patches_again();
4171 badusage "-p is not allowed when building" if defined $package;
4174 my $clogp = parsechangelog();
4175 $isuite = getfield $clogp, 'Distribution';
4176 $package = getfield $clogp, 'Source';
4177 $version = getfield $clogp, 'Version';
4178 build_maybe_quilt_fixup();
4180 my $pat = changespat $version;
4181 foreach my $f (glob "$buildproductsdir/$pat") {
4183 unlink $f or fail "remove old changes file $f: $!";
4185 progress "would remove $f";
4191 sub changesopts_initial () {
4192 my @opts =@changesopts[1..$#changesopts];
4195 sub changesopts_version () {
4196 if (!defined $changes_since_version) {
4197 my @vsns = archive_query('archive_query');
4198 my @quirk = access_quirk();
4199 if ($quirk[0] eq 'backports') {
4200 local $isuite = $quirk[2];
4202 canonicalise_suite();
4203 push @vsns, archive_query('archive_query');
4206 @vsns = map { $_->[0] } @vsns;
4207 @vsns = sort { -version_compare($a, $b) } @vsns;
4208 $changes_since_version = $vsns[0];
4209 progress "changelog will contain changes since $vsns[0]";
4211 $changes_since_version = '_';
4212 progress "package seems new, not specifying -v<version>";
4215 if ($changes_since_version ne '_') {
4216 return ("-v$changes_since_version");
4222 sub changesopts () {
4223 return (changesopts_initial(), changesopts_version());
4226 sub massage_dbp_args ($;$) {
4227 my ($cmd,$xargs) = @_;
4230 # - if we're going to split the source build out so we can
4231 # do strange things to it, massage the arguments to dpkg-buildpackage
4232 # so that the main build doessn't build source (or add an argument
4233 # to stop it building source by default).
4235 # - add -nc to stop dpkg-source cleaning the source tree,
4236 # unless we're not doing a split build and want dpkg-source
4237 # as cleanmode, in which case we can do nothing
4240 # 0 - source will NOT need to be built separately by caller
4241 # +1 - source will need to be built separately by caller
4242 # +2 - source will need to be built separately by caller AND
4243 # dpkg-buildpackage should not in fact be run at all!
4244 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4245 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4246 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4247 $clean_using_builder = 1;
4250 # -nc has the side effect of specifying -b if nothing else specified
4251 # and some combinations of -S, -b, et al, are errors, rather than
4252 # later simply overriding earlie. So we need to:
4253 # - search the command line for these options
4254 # - pick the last one
4255 # - perhaps add our own as a default
4256 # - perhaps adjust it to the corresponding non-source-building version
4258 foreach my $l ($cmd, $xargs) {
4260 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4263 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4265 if ($need_split_build_invocation) {
4266 printdebug "massage split $dmode.\n";
4267 $r = $dmode =~ m/[S]/ ? +2 :
4268 $dmode =~ y/gGF/ABb/ ? +1 :
4269 $dmode =~ m/[ABb]/ ? 0 :
4272 printdebug "massage done $r $dmode.\n";
4274 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4279 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4280 my $wantsrc = massage_dbp_args \@dbp;
4287 push @dbp, changesopts_version();
4288 maybe_apply_patches_dirtily();
4289 runcmd_ordryrun_local @dbp;
4291 maybe_unapply_patches_again();
4292 printdone "build successful\n";
4296 my @dbp = @dpkgbuildpackage;
4298 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4301 if (length executable_on_path('git-buildpackage')) {
4302 @cmd = qw(git-buildpackage);
4304 @cmd = qw(gbp buildpackage);
4306 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4311 if (!$clean_using_builder) {
4312 push @cmd, '--git-cleaner=true';
4316 maybe_unapply_patches_again();
4318 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4319 canonicalise_suite();
4320 push @cmd, "--git-debian-branch=".lbranch();
4322 push @cmd, changesopts();
4323 runcmd_ordryrun_local @cmd, @ARGV;
4325 printdone "build successful\n";
4327 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4330 my $our_cleanmode = $cleanmode;
4331 if ($need_split_build_invocation) {
4332 # Pretend that clean is being done some other way. This
4333 # forces us not to try to use dpkg-buildpackage to clean and
4334 # build source all in one go; and instead we run dpkg-source
4335 # (and build_prep() will do the clean since $clean_using_builder
4337 $our_cleanmode = 'ELSEWHERE';
4339 if ($our_cleanmode =~ m/^dpkg-source/) {
4340 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4341 $clean_using_builder = 1;
4344 $sourcechanges = changespat $version,'source';
4346 unlink "../$sourcechanges" or $!==ENOENT
4347 or fail "remove $sourcechanges: $!";
4349 $dscfn = dscfn($version);
4350 if ($our_cleanmode eq 'dpkg-source') {
4351 maybe_apply_patches_dirtily();
4352 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4354 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4355 maybe_apply_patches_dirtily();
4356 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4359 my @cmd = (@dpkgsource, qw(-b --));
4362 runcmd_ordryrun_local @cmd, "work";
4363 my @udfiles = <${package}_*>;
4364 changedir "../../..";
4365 foreach my $f (@udfiles) {
4366 printdebug "source copy, found $f\n";
4369 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4370 $f eq srcfn($version, $&));
4371 printdebug "source copy, found $f - renaming\n";
4372 rename "$ud/$f", "../$f" or $!==ENOENT
4373 or fail "put in place new source file ($f): $!";
4376 my $pwd = must_getcwd();
4377 my $leafdir = basename $pwd;
4379 runcmd_ordryrun_local @cmd, $leafdir;
4382 runcmd_ordryrun_local qw(sh -ec),
4383 'exec >$1; shift; exec "$@"','x',
4384 "../$sourcechanges",
4385 @dpkggenchanges, qw(-S), changesopts();
4389 sub cmd_build_source {
4390 badusage "build-source takes no additional arguments" if @ARGV;
4392 maybe_unapply_patches_again();
4393 printdone "source built, results in $dscfn and $sourcechanges";
4398 my $pat = changespat $version;
4400 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4401 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4402 fail "changes files other than source matching $pat".
4403 " already present (@unwanted);".
4404 " building would result in ambiguity about the intended results"
4407 my $wasdir = must_getcwd();
4410 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4411 stat_exists $sourcechanges
4412 or fail "$sourcechanges (in parent directory): $!";
4414 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4415 my @changesfiles = glob $pat;
4416 @changesfiles = sort {
4417 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4420 fail "wrong number of different changes files (@changesfiles)"
4421 unless @changesfiles==2;
4422 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4423 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4424 fail "$l found in binaries changes file $binchanges"
4427 runcmd_ordryrun_local @mergechanges, @changesfiles;
4428 my $multichanges = changespat $version,'multi';
4430 stat_exists $multichanges or fail "$multichanges: $!";
4431 foreach my $cf (glob $pat) {
4432 next if $cf eq $multichanges;
4433 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4437 maybe_unapply_patches_again();
4438 printdone "build successful, results in $multichanges\n" or die $!;
4441 sub cmd_quilt_fixup {
4442 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4443 my $clogp = parsechangelog();
4444 $version = getfield $clogp, 'Version';
4445 $package = getfield $clogp, 'Source';
4448 build_maybe_quilt_fixup();
4451 sub cmd_archive_api_query {
4452 badusage "need only 1 subpath argument" unless @ARGV==1;
4453 my ($subpath) = @ARGV;
4454 my @cmd = archive_api_query_cmd($subpath);
4456 exec @cmd or fail "exec curl: $!\n";
4459 sub cmd_clone_dgit_repos_server {
4460 badusage "need destination argument" unless @ARGV==1;
4461 my ($destdir) = @ARGV;
4462 $package = '_dgit-repos-server';
4463 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4465 exec @cmd or fail "exec git clone: $!\n";
4468 sub cmd_setup_mergechangelogs {
4469 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4470 setup_mergechangelogs(1);
4473 sub cmd_setup_useremail {
4474 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4478 sub cmd_setup_new_tree {
4479 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4483 #---------- argument parsing and main program ----------
4486 print "dgit version $our_version\n" or die $!;
4490 our (%valopts_long, %valopts_short);
4493 sub defvalopt ($$$$) {
4494 my ($long,$short,$val_re,$how) = @_;
4495 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4496 $valopts_long{$long} = $oi;
4497 $valopts_short{$short} = $oi;
4498 # $how subref should:
4499 # do whatever assignemnt or thing it likes with $_[0]
4500 # if the option should not be passed on to remote, @rvalopts=()
4501 # or $how can be a scalar ref, meaning simply assign the value
4504 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4505 defvalopt '--distro', '-d', '.+', \$idistro;
4506 defvalopt '', '-k', '.+', \$keyid;
4507 defvalopt '--existing-package','', '.*', \$existing_package;
4508 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4509 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4510 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4512 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4514 defvalopt '', '-C', '.+', sub {
4515 ($changesfile) = (@_);
4516 if ($changesfile =~ s#^(.*)/##) {
4517 $buildproductsdir = $1;
4521 defvalopt '--initiator-tempdir','','.*', sub {
4522 ($initiator_tempdir) = (@_);
4523 $initiator_tempdir =~ m#^/# or
4524 badusage "--initiator-tempdir must be used specify an".
4525 " absolute, not relative, directory."
4531 if (defined $ENV{'DGIT_SSH'}) {
4532 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4533 } elsif (defined $ENV{'GIT_SSH'}) {
4534 @ssh = ($ENV{'GIT_SSH'});
4542 if (!defined $val) {
4543 badusage "$what needs a value" unless @ARGV;
4545 push @rvalopts, $val;
4547 badusage "bad value \`$val' for $what" unless
4548 $val =~ m/^$oi->{Re}$(?!\n)/s;
4549 my $how = $oi->{How};
4550 if (ref($how) eq 'SCALAR') {
4555 push @ropts, @rvalopts;
4559 last unless $ARGV[0] =~ m/^-/;
4563 if (m/^--dry-run$/) {
4566 } elsif (m/^--damp-run$/) {
4569 } elsif (m/^--no-sign$/) {
4572 } elsif (m/^--help$/) {
4574 } elsif (m/^--version$/) {
4576 } elsif (m/^--new$/) {
4579 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4580 ($om = $opts_opt_map{$1}) &&
4584 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4585 !$opts_opt_cmdonly{$1} &&
4586 ($om = $opts_opt_map{$1})) {
4589 } elsif (m/^--ignore-dirty$/s) {
4592 } elsif (m/^--no-quilt-fixup$/s) {
4594 $quilt_mode = 'nocheck';
4595 } elsif (m/^--no-rm-on-error$/s) {
4598 } elsif (m/^--overwrite$/s) {
4600 $overwrite_version = '';
4601 } elsif (m/^--overwrite=(.+)$/s) {
4603 $overwrite_version = $1;
4604 } elsif (m/^--(no-)?rm-old-changes$/s) {
4607 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4609 push @deliberatelies, $&;
4610 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4611 # undocumented, for testing
4613 $tagformat_want = [ $1, 'command line', 1 ];
4614 # 1 menas overrides distro configuration
4615 } elsif (m/^--always-split-source-build$/s) {
4616 # undocumented, for testing
4618 $need_split_build_invocation = 1;
4619 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4620 $val = $2 ? $' : undef; #';
4621 $valopt->($oi->{Long});
4623 badusage "unknown long option \`$_'";
4630 } elsif (s/^-L/-/) {
4633 } elsif (s/^-h/-/) {
4635 } elsif (s/^-D/-/) {
4639 } elsif (s/^-N/-/) {
4644 push @changesopts, $_;
4646 } elsif (s/^-wn$//s) {
4648 $cleanmode = 'none';
4649 } elsif (s/^-wg$//s) {
4652 } elsif (s/^-wgf$//s) {
4654 $cleanmode = 'git-ff';
4655 } elsif (s/^-wd$//s) {
4657 $cleanmode = 'dpkg-source';
4658 } elsif (s/^-wdd$//s) {
4660 $cleanmode = 'dpkg-source-d';
4661 } elsif (s/^-wc$//s) {
4663 $cleanmode = 'check';
4664 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4666 $val = undef unless length $val;
4667 $valopt->($oi->{Short});
4670 badusage "unknown short option \`$_'";
4677 sub finalise_opts_opts () {
4678 foreach my $k (keys %opts_opt_map) {
4679 my $om = $opts_opt_map{$k};
4681 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4683 badcfg "cannot set command for $k"
4684 unless length $om->[0];
4688 foreach my $c (access_cfg_cfgs("opts-$k")) {
4689 my $vl = $gitcfg{$c};
4690 printdebug "CL $c ",
4691 ($vl ? join " ", map { shellquote } @$vl : ""),
4692 "\n" if $debuglevel >= 4;
4694 badcfg "cannot configure options for $k"
4695 if $opts_opt_cmdonly{$k};
4696 my $insertpos = $opts_cfg_insertpos{$k};
4697 @$om = ( @$om[0..$insertpos-1],
4699 @$om[$insertpos..$#$om] );
4704 if ($ENV{$fakeeditorenv}) {
4706 quilt_fixup_editor();
4712 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4713 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4714 if $dryrun_level == 1;
4716 print STDERR $helpmsg or die $!;
4719 my $cmd = shift @ARGV;
4722 if (!defined $rmchanges) {
4723 local $access_forpush;
4724 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4727 if (!defined $quilt_mode) {
4728 local $access_forpush;
4729 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4730 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4732 $quilt_mode =~ m/^($quilt_modes_re)$/
4733 or badcfg "unknown quilt-mode \`$quilt_mode'";
4737 $need_split_build_invocation ||= quiltmode_splitbrain();
4739 if (!defined $cleanmode) {
4740 local $access_forpush;
4741 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4742 $cleanmode //= 'dpkg-source';
4744 badcfg "unknown clean-mode \`$cleanmode'" unless
4745 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4748 my $fn = ${*::}{"cmd_$cmd"};
4749 $fn or badusage "unknown operation $cmd";