3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
48 our $isuite = 'unstable';
54 our $dryrun_level = 0;
56 our $buildproductsdir = '..';
62 our $existing_package = 'dpkg';
64 our $changes_since_version;
66 our $overwrite_version; # undef: not specified; '': check changelog
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
81 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
82 our $splitbraincache = 'dgit-intern/quilt-cache';
85 our (@dget) = qw(dget);
86 our (@curl) = qw(curl -f);
87 our (@dput) = qw(dput);
88 our (@debsign) = qw(debsign);
90 our (@sbuild) = qw(sbuild);
92 our (@dgit) = qw(dgit);
93 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
94 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
95 our (@dpkggenchanges) = qw(dpkg-genchanges);
96 our (@mergechanges) = qw(mergechanges -f);
98 our (@changesopts) = ('');
100 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
103 'debsign' => \@debsign,
105 'sbuild' => \@sbuild,
109 'dpkg-source' => \@dpkgsource,
110 'dpkg-buildpackage' => \@dpkgbuildpackage,
111 'dpkg-genchanges' => \@dpkggenchanges,
113 'ch' => \@changesopts,
114 'mergechanges' => \@mergechanges);
116 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
117 our %opts_cfg_insertpos = map {
119 scalar @{ $opts_opt_map{$_} }
120 } keys %opts_opt_map;
122 sub finalise_opts_opts();
128 our $supplementary_message = '';
129 our $need_split_build_invocation = 0;
130 our $split_brain = 0;
134 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
137 our $remotename = 'dgit';
138 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
143 my ($v,$distro) = @_;
144 return $tagformatfn->($v, $distro);
147 sub debiantag_maintview ($$) {
148 my ($v,$distro) = @_;
153 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
155 sub lbranch () { return "$branchprefix/$csuite"; }
156 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
157 sub lref () { return "refs/heads/".lbranch(); }
158 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
159 sub rrref () { return server_ref($csuite); }
161 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
162 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
164 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
165 # locally fetched refs because they have unhelpful names and clutter
166 # up gitk etc. So we track whether we have "used up" head ref (ie,
167 # whether we have made another local ref which refers to this object).
169 # (If we deleted them unconditionally, then we might end up
170 # re-fetching the same git objects each time dgit fetch was run.)
172 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
173 # in git_fetch_us to fetch the refs in question, and possibly a call
174 # to lrfetchref_used.
176 our (%lrfetchrefs_f, %lrfetchrefs_d);
177 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
179 sub lrfetchref_used ($) {
180 my ($fullrefname) = @_;
181 my $objid = $lrfetchrefs_f{$fullrefname};
182 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
193 return "${package}_".(stripepoch $vsn).$sfx
198 return srcfn($vsn,".dsc");
201 sub changespat ($;$) {
202 my ($vsn, $arch) = @_;
203 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
212 foreach my $f (@end) {
214 print STDERR "$us: cleanup: $@" if length $@;
218 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
220 sub no_such_package () {
221 print STDERR "$us: package $package does not exist in suite $isuite\n";
227 printdebug "CD $newdir\n";
228 chdir $newdir or confess "chdir: $newdir: $!";
231 sub deliberately ($) {
233 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
236 sub deliberately_not_fast_forward () {
237 foreach (qw(not-fast-forward fresh-repo)) {
238 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
242 sub quiltmode_splitbrain () {
243 $quilt_mode =~ m/gbp|dpm|unapplied/;
246 #---------- remote protocol support, common ----------
248 # remote push initiator/responder protocol:
249 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
250 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
251 # < dgit-remote-push-ready <actual-proto-vsn>
258 # > supplementary-message NBYTES # $protovsn >= 3
263 # > file parsed-changelog
264 # [indicates that output of dpkg-parsechangelog follows]
265 # > data-block NBYTES
266 # > [NBYTES bytes of data (no newline)]
267 # [maybe some more blocks]
276 # > param head DGIT-VIEW-HEAD
277 # > param csuite SUITE
278 # > param tagformat old|new
279 # > param maint-view MAINT-VIEW-HEAD
281 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
282 # # goes into tag, for replay prevention
285 # [indicates that signed tag is wanted]
286 # < data-block NBYTES
287 # < [NBYTES bytes of data (no newline)]
288 # [maybe some more blocks]
292 # > want signed-dsc-changes
293 # < data-block NBYTES [transfer of signed dsc]
295 # < data-block NBYTES [transfer of signed changes]
303 sub i_child_report () {
304 # Sees if our child has died, and reap it if so. Returns a string
305 # describing how it died if it failed, or undef otherwise.
306 return undef unless $i_child_pid;
307 my $got = waitpid $i_child_pid, WNOHANG;
308 return undef if $got <= 0;
309 die unless $got == $i_child_pid;
310 $i_child_pid = undef;
311 return undef unless $?;
312 return "build host child ".waitstatusmsg();
317 fail "connection lost: $!" if $fh->error;
318 fail "protocol violation; $m not expected";
321 sub badproto_badread ($$) {
323 fail "connection lost: $!" if $!;
324 my $report = i_child_report();
325 fail $report if defined $report;
326 badproto $fh, "eof (reading $wh)";
329 sub protocol_expect (&$) {
330 my ($match, $fh) = @_;
333 defined && chomp or badproto_badread $fh, "protocol message";
341 badproto $fh, "\`$_'";
344 sub protocol_send_file ($$) {
345 my ($fh, $ourfn) = @_;
346 open PF, "<", $ourfn or die "$ourfn: $!";
349 my $got = read PF, $d, 65536;
350 die "$ourfn: $!" unless defined $got;
352 print $fh "data-block ".length($d)."\n" or die $!;
353 print $fh $d or die $!;
355 PF->error and die "$ourfn $!";
356 print $fh "data-end\n" or die $!;
360 sub protocol_read_bytes ($$) {
361 my ($fh, $nbytes) = @_;
362 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
364 my $got = read $fh, $d, $nbytes;
365 $got==$nbytes or badproto_badread $fh, "data block";
369 sub protocol_receive_file ($$) {
370 my ($fh, $ourfn) = @_;
371 printdebug "() $ourfn\n";
372 open PF, ">", $ourfn or die "$ourfn: $!";
374 my ($y,$l) = protocol_expect {
375 m/^data-block (.*)$/ ? (1,$1) :
376 m/^data-end$/ ? (0,) :
380 my $d = protocol_read_bytes $fh, $l;
381 print PF $d or die $!;
386 #---------- remote protocol support, responder ----------
388 sub responder_send_command ($) {
390 return unless $we_are_responder;
391 # called even without $we_are_responder
392 printdebug ">> $command\n";
393 print PO $command, "\n" or die $!;
396 sub responder_send_file ($$) {
397 my ($keyword, $ourfn) = @_;
398 return unless $we_are_responder;
399 printdebug "]] $keyword $ourfn\n";
400 responder_send_command "file $keyword";
401 protocol_send_file \*PO, $ourfn;
404 sub responder_receive_files ($@) {
405 my ($keyword, @ourfns) = @_;
406 die unless $we_are_responder;
407 printdebug "[[ $keyword @ourfns\n";
408 responder_send_command "want $keyword";
409 foreach my $fn (@ourfns) {
410 protocol_receive_file \*PI, $fn;
413 protocol_expect { m/^files-end$/ } \*PI;
416 #---------- remote protocol support, initiator ----------
418 sub initiator_expect (&) {
420 protocol_expect { &$match } \*RO;
423 #---------- end remote code ----------
426 if ($we_are_responder) {
428 responder_send_command "progress ".length($m) or die $!;
429 print PO $m or die $!;
439 $ua = LWP::UserAgent->new();
443 progress "downloading $what...";
444 my $r = $ua->get(@_) or die $!;
445 return undef if $r->code == 404;
446 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
447 return $r->decoded_content(charset => 'none');
450 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
455 failedcmd @_ if system @_;
458 sub act_local () { return $dryrun_level <= 1; }
459 sub act_scary () { return !$dryrun_level; }
462 if (!$dryrun_level) {
463 progress "dgit ok: @_";
465 progress "would be ok: @_ (but dry run only)";
470 printcmd(\*STDERR,$debugprefix."#",@_);
473 sub runcmd_ordryrun {
481 sub runcmd_ordryrun_local {
490 my ($first_shell, @cmd) = @_;
491 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
494 our $helpmsg = <<END;
496 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
497 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
498 dgit [dgit-opts] build [dpkg-buildpackage-opts]
499 dgit [dgit-opts] sbuild [sbuild-opts]
500 dgit [dgit-opts] push [dgit-opts] [suite]
501 dgit [dgit-opts] rpush build-host:build-dir ...
502 important dgit options:
503 -k<keyid> sign tag and package with <keyid> instead of default
504 --dry-run -n do not change anything, but go through the motions
505 --damp-run -L like --dry-run but make local changes, without signing
506 --new -N allow introducing a new package
507 --debug -D increase debug level
508 -c<name>=<value> set git config option (used directly by dgit too)
511 our $later_warning_msg = <<END;
512 Perhaps the upload is stuck in incoming. Using the version from git.
516 print STDERR "$us: @_\n", $helpmsg or die $!;
521 @ARGV or badusage "too few arguments";
522 return scalar shift @ARGV;
526 print $helpmsg or die $!;
530 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
532 our %defcfg = ('dgit.default.distro' => 'debian',
533 'dgit.default.username' => '',
534 'dgit.default.archive-query-default-component' => 'main',
535 'dgit.default.ssh' => 'ssh',
536 'dgit.default.archive-query' => 'madison:',
537 'dgit.default.sshpsql-dbname' => 'service=projectb',
538 'dgit.default.dgit-tag-format' => 'old,new,maint',
539 # old means "repo server accepts pushes with old dgit tags"
540 # new means "repo server accepts pushes with new dgit tags"
541 # maint means "repo server accepts split brain pushes"
542 # hist means "repo server may have old pushes without new tag"
543 # ("hist" is implied by "old")
544 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
545 'dgit-distro.debian.git-check' => 'url',
546 'dgit-distro.debian.git-check-suffix' => '/info/refs',
547 'dgit-distro.debian.new-private-pushers' => 't',
548 'dgit-distro.debian.dgit-tag-format' => 'new',
549 'dgit-distro.debian/push.git-url' => '',
550 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
551 'dgit-distro.debian/push.git-user-force' => 'dgit',
552 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
553 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
554 'dgit-distro.debian/push.git-create' => 'true',
555 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
556 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
557 # 'dgit-distro.debian.archive-query-tls-key',
558 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
559 # ^ this does not work because curl is broken nowadays
560 # Fixing #790093 properly will involve providing providing the key
561 # in some pacagke and maybe updating these paths.
563 # 'dgit-distro.debian.archive-query-tls-curl-args',
564 # '--ca-path=/etc/ssl/ca-debian',
565 # ^ this is a workaround but works (only) on DSA-administered machines
566 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
567 'dgit-distro.debian.git-url-suffix' => '',
568 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
569 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
570 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
571 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
572 'dgit-distro.ubuntu.git-check' => 'false',
573 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
574 'dgit-distro.test-dummy.ssh' => "$td/ssh",
575 'dgit-distro.test-dummy.username' => "alice",
576 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
577 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
578 'dgit-distro.test-dummy.git-url' => "$td/git",
579 'dgit-distro.test-dummy.git-host' => "git",
580 'dgit-distro.test-dummy.git-path' => "$td/git",
581 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
582 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
583 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
584 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
589 sub git_slurp_config () {
590 local ($debuglevel) = $debuglevel-2;
593 my @cmd = (@git, qw(config -z --get-regexp .*));
596 open GITS, "-|", @cmd or die $!;
599 printdebug "=> ", (messagequote $_), "\n";
601 push @{ $gitcfg{$`} }, $'; #';
605 or ($!==0 && $?==256)
609 sub git_get_config ($) {
612 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
615 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
621 return undef if $c =~ /RETURN-UNDEF/;
622 my $v = git_get_config($c);
623 return $v if defined $v;
624 my $dv = $defcfg{$c};
625 return $dv if defined $dv;
627 badcfg "need value for one of: @_\n".
628 "$us: distro or suite appears not to be (properly) supported";
631 sub access_basedistro () {
632 if (defined $idistro) {
635 return cfg("dgit-suite.$isuite.distro",
636 "dgit.default.distro");
640 sub access_quirk () {
641 # returns (quirk name, distro to use instead or undef, quirk-specific info)
642 my $basedistro = access_basedistro();
643 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
645 if (defined $backports_quirk) {
646 my $re = $backports_quirk;
647 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
649 $re =~ s/\%/([-0-9a-z_]+)/
650 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
651 if ($isuite =~ m/^$re$/) {
652 return ('backports',"$basedistro-backports",$1);
655 return ('none',undef);
660 sub parse_cfg_bool ($$$) {
661 my ($what,$def,$v) = @_;
664 $v =~ m/^[ty1]/ ? 1 :
665 $v =~ m/^[fn0]/ ? 0 :
666 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
669 sub access_forpush_config () {
670 my $d = access_basedistro();
674 parse_cfg_bool('new-private-pushers', 0,
675 cfg("dgit-distro.$d.new-private-pushers",
678 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
681 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
682 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
683 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
684 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
687 sub access_forpush () {
688 $access_forpush //= access_forpush_config();
689 return $access_forpush;
693 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
694 badcfg "pushing but distro is configured readonly"
695 if access_forpush_config() eq '0';
697 $supplementary_message = <<'END' unless $we_are_responder;
698 Push failed, before we got started.
699 You can retry the push, after fixing the problem, if you like.
701 finalise_opts_opts();
705 finalise_opts_opts();
708 sub supplementary_message ($) {
710 if (!$we_are_responder) {
711 $supplementary_message = $msg;
713 } elsif ($protovsn >= 3) {
714 responder_send_command "supplementary-message ".length($msg)
716 print PO $msg or die $!;
720 sub access_distros () {
721 # Returns list of distros to try, in order
724 # 0. `instead of' distro name(s) we have been pointed to
725 # 1. the access_quirk distro, if any
726 # 2a. the user's specified distro, or failing that } basedistro
727 # 2b. the distro calculated from the suite }
728 my @l = access_basedistro();
730 my (undef,$quirkdistro) = access_quirk();
731 unshift @l, $quirkdistro;
732 unshift @l, $instead_distro;
733 @l = grep { defined } @l;
735 if (access_forpush()) {
736 @l = map { ("$_/push", $_) } @l;
741 sub access_cfg_cfgs (@) {
744 # The nesting of these loops determines the search order. We put
745 # the key loop on the outside so that we search all the distros
746 # for each key, before going on to the next key. That means that
747 # if access_cfg is called with a more specific, and then a less
748 # specific, key, an earlier distro can override the less specific
749 # without necessarily overriding any more specific keys. (If the
750 # distro wants to override the more specific keys it can simply do
751 # so; whereas if we did the loop the other way around, it would be
752 # impossible to for an earlier distro to override a less specific
753 # key but not the more specific ones without restating the unknown
754 # values of the more specific keys.
757 # We have to deal with RETURN-UNDEF specially, so that we don't
758 # terminate the search prematurely.
760 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
763 foreach my $d (access_distros()) {
764 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
766 push @cfgs, map { "dgit.default.$_" } @realkeys;
773 my (@cfgs) = access_cfg_cfgs(@keys);
774 my $value = cfg(@cfgs);
778 sub access_cfg_bool ($$) {
779 my ($def, @keys) = @_;
780 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
783 sub string_to_ssh ($) {
785 if ($spec =~ m/\s/) {
786 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
792 sub access_cfg_ssh () {
793 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
794 if (!defined $gitssh) {
797 return string_to_ssh $gitssh;
801 sub access_runeinfo ($) {
803 return ": dgit ".access_basedistro()." $info ;";
806 sub access_someuserhost ($) {
808 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
809 defined($user) && length($user) or
810 $user = access_cfg("$some-user",'username');
811 my $host = access_cfg("$some-host");
812 return length($user) ? "$user\@$host" : $host;
815 sub access_gituserhost () {
816 return access_someuserhost('git');
819 sub access_giturl (;$) {
821 my $url = access_cfg('git-url','RETURN-UNDEF');
824 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
825 return undef unless defined $proto;
828 access_gituserhost().
829 access_cfg('git-path');
831 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
834 return "$url/$package$suffix";
837 sub parsecontrolfh ($$;$) {
838 my ($fh, $desc, $allowsigned) = @_;
839 our $dpkgcontrolhash_noissigned;
842 my %opts = ('name' => $desc);
843 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
844 $c = Dpkg::Control::Hash->new(%opts);
845 $c->parse($fh,$desc) or die "parsing of $desc failed";
846 last if $allowsigned;
847 last if $dpkgcontrolhash_noissigned;
848 my $issigned= $c->get_option('is_pgp_signed');
849 if (!defined $issigned) {
850 $dpkgcontrolhash_noissigned= 1;
851 seek $fh, 0,0 or die "seek $desc: $!";
852 } elsif ($issigned) {
853 fail "control file $desc is (already) PGP-signed. ".
854 " Note that dgit push needs to modify the .dsc and then".
855 " do the signature itself";
864 my ($file, $desc) = @_;
865 my $fh = new IO::Handle;
866 open $fh, '<', $file or die "$file: $!";
867 my $c = parsecontrolfh($fh,$desc);
868 $fh->error and die $!;
874 my ($dctrl,$field) = @_;
875 my $v = $dctrl->{$field};
876 return $v if defined $v;
877 fail "missing field $field in ".$dctrl->get_option('name');
881 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
882 my $p = new IO::Handle;
883 my @cmd = (qw(dpkg-parsechangelog), @_);
884 open $p, '-|', @cmd or die $!;
886 $?=0; $!=0; close $p or failedcmd @cmd;
890 sub commit_getclogp ($) {
891 # Returns the parsed changelog hashref for a particular commit
893 our %commit_getclogp_memo;
894 my $memo = $commit_getclogp_memo{$objid};
895 return $memo if $memo;
897 my $mclog = ".git/dgit/clog-$objid";
898 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
899 "$objid:debian/changelog";
900 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
905 defined $d or fail "getcwd failed: $!";
911 sub archive_query ($) {
913 my $query = access_cfg('archive-query','RETURN-UNDEF');
914 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
917 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
920 sub pool_dsc_subpath ($$) {
921 my ($vsn,$component) = @_; # $package is implict arg
922 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
923 return "/pool/$component/$prefix/$package/".dscfn($vsn);
926 #---------- `ftpmasterapi' archive query method (nascent) ----------
928 sub archive_api_query_cmd ($) {
930 my @cmd = qw(curl -sS);
931 my $url = access_cfg('archive-query-url');
932 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
934 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
935 foreach my $key (split /\:/, $keys) {
936 $key =~ s/\%HOST\%/$host/g;
938 fail "for $url: stat $key: $!" unless $!==ENOENT;
941 fail "config requested specific TLS key but do not know".
942 " how to get curl to use exactly that EE key ($key)";
943 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
944 # # Sadly the above line does not work because of changes
945 # # to gnutls. The real fix for #790093 may involve
946 # # new curl options.
949 # Fixing #790093 properly will involve providing a value
950 # for this on clients.
951 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
952 push @cmd, split / /, $kargs if defined $kargs;
954 push @cmd, $url.$subpath;
960 my ($data, $subpath) = @_;
961 badcfg "ftpmasterapi archive query method takes no data part"
963 my @cmd = archive_api_query_cmd($subpath);
964 my $json = cmdoutput @cmd;
965 return decode_json($json);
968 sub canonicalise_suite_ftpmasterapi () {
969 my ($proto,$data) = @_;
970 my $suites = api_query($data, 'suites');
972 foreach my $entry (@$suites) {
974 my $v = $entry->{$_};
975 defined $v && $v eq $isuite;
977 push @matched, $entry;
979 fail "unknown suite $isuite" unless @matched;
982 @matched==1 or die "multiple matches for suite $isuite\n";
983 $cn = "$matched[0]{codename}";
984 defined $cn or die "suite $isuite info has no codename\n";
985 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
987 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
992 sub archive_query_ftpmasterapi () {
993 my ($proto,$data) = @_;
994 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
996 my $digester = Digest::SHA->new(256);
997 foreach my $entry (@$info) {
999 my $vsn = "$entry->{version}";
1000 my ($ok,$msg) = version_check $vsn;
1001 die "bad version: $msg\n" unless $ok;
1002 my $component = "$entry->{component}";
1003 $component =~ m/^$component_re$/ or die "bad component";
1004 my $filename = "$entry->{filename}";
1005 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1006 or die "bad filename";
1007 my $sha256sum = "$entry->{sha256sum}";
1008 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1009 push @rows, [ $vsn, "/pool/$component/$filename",
1010 $digester, $sha256sum ];
1012 die "bad ftpmaster api response: $@\n".Dumper($entry)
1015 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1019 #---------- `madison' archive query method ----------
1021 sub archive_query_madison {
1022 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1025 sub madison_get_parse {
1026 my ($proto,$data) = @_;
1027 die unless $proto eq 'madison';
1028 if (!length $data) {
1029 $data= access_cfg('madison-distro','RETURN-UNDEF');
1030 $data //= access_basedistro();
1032 $rmad{$proto,$data,$package} ||= cmdoutput
1033 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1034 my $rmad = $rmad{$proto,$data,$package};
1037 foreach my $l (split /\n/, $rmad) {
1038 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1039 \s*( [^ \t|]+ )\s* \|
1040 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1041 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1042 $1 eq $package or die "$rmad $package ?";
1049 $component = access_cfg('archive-query-default-component');
1051 $5 eq 'source' or die "$rmad ?";
1052 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1054 return sort { -version_compare($a->[0],$b->[0]); } @out;
1057 sub canonicalise_suite_madison {
1058 # madison canonicalises for us
1059 my @r = madison_get_parse(@_);
1061 "unable to canonicalise suite using package $package".
1062 " which does not appear to exist in suite $isuite;".
1063 " --existing-package may help";
1067 #---------- `sshpsql' archive query method ----------
1070 my ($data,$runeinfo,$sql) = @_;
1071 if (!length $data) {
1072 $data= access_someuserhost('sshpsql').':'.
1073 access_cfg('sshpsql-dbname');
1075 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1076 my ($userhost,$dbname) = ($`,$'); #';
1078 my @cmd = (access_cfg_ssh, $userhost,
1079 access_runeinfo("ssh-psql $runeinfo").
1080 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1081 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1083 open P, "-|", @cmd or die $!;
1086 printdebug(">|$_|\n");
1089 $!=0; $?=0; close P or failedcmd @cmd;
1091 my $nrows = pop @rows;
1092 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1093 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1094 @rows = map { [ split /\|/, $_ ] } @rows;
1095 my $ncols = scalar @{ shift @rows };
1096 die if grep { scalar @$_ != $ncols } @rows;
1100 sub sql_injection_check {
1101 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1104 sub archive_query_sshpsql ($$) {
1105 my ($proto,$data) = @_;
1106 sql_injection_check $isuite, $package;
1107 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1108 SELECT source.version, component.name, files.filename, files.sha256sum
1110 JOIN src_associations ON source.id = src_associations.source
1111 JOIN suite ON suite.id = src_associations.suite
1112 JOIN dsc_files ON dsc_files.source = source.id
1113 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1114 JOIN component ON component.id = files_archive_map.component_id
1115 JOIN files ON files.id = dsc_files.file
1116 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1117 AND source.source='$package'
1118 AND files.filename LIKE '%.dsc';
1120 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1121 my $digester = Digest::SHA->new(256);
1123 my ($vsn,$component,$filename,$sha256sum) = @$_;
1124 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1129 sub canonicalise_suite_sshpsql ($$) {
1130 my ($proto,$data) = @_;
1131 sql_injection_check $isuite;
1132 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1133 SELECT suite.codename
1134 FROM suite where suite_name='$isuite' or codename='$isuite';
1136 @rows = map { $_->[0] } @rows;
1137 fail "unknown suite $isuite" unless @rows;
1138 die "ambiguous $isuite: @rows ?" if @rows>1;
1142 #---------- `dummycat' archive query method ----------
1144 sub canonicalise_suite_dummycat ($$) {
1145 my ($proto,$data) = @_;
1146 my $dpath = "$data/suite.$isuite";
1147 if (!open C, "<", $dpath) {
1148 $!==ENOENT or die "$dpath: $!";
1149 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1153 chomp or die "$dpath: $!";
1155 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1159 sub archive_query_dummycat ($$) {
1160 my ($proto,$data) = @_;
1161 canonicalise_suite();
1162 my $dpath = "$data/package.$csuite.$package";
1163 if (!open C, "<", $dpath) {
1164 $!==ENOENT or die "$dpath: $!";
1165 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1173 printdebug "dummycat query $csuite $package $dpath | $_\n";
1174 my @row = split /\s+/, $_;
1175 @row==2 or die "$dpath: $_ ?";
1178 C->error and die "$dpath: $!";
1180 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1183 #---------- tag format handling ----------
1185 sub access_cfg_tagformats () {
1186 split /\,/, access_cfg('dgit-tag-format');
1189 sub need_tagformat ($$) {
1190 my ($fmt, $why) = @_;
1191 fail "need to use tag format $fmt ($why) but also need".
1192 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1193 " - no way to proceed"
1194 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1195 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1198 sub select_tagformat () {
1200 return if $tagformatfn && !$tagformat_want;
1201 die 'bug' if $tagformatfn && $tagformat_want;
1202 # ... $tagformat_want assigned after previous select_tagformat
1204 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1205 printdebug "select_tagformat supported @supported\n";
1207 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1208 printdebug "select_tagformat specified @$tagformat_want\n";
1210 my ($fmt,$why,$override) = @$tagformat_want;
1212 fail "target distro supports tag formats @supported".
1213 " but have to use $fmt ($why)"
1215 or grep { $_ eq $fmt } @supported;
1217 $tagformat_want = undef;
1219 $tagformatfn = ${*::}{"debiantag_$fmt"};
1221 fail "trying to use unknown tag format \`$fmt' ($why) !"
1222 unless $tagformatfn;
1225 #---------- archive query entrypoints and rest of program ----------
1227 sub canonicalise_suite () {
1228 return if defined $csuite;
1229 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1230 $csuite = archive_query('canonicalise_suite');
1231 if ($isuite ne $csuite) {
1232 progress "canonical suite name for $isuite is $csuite";
1236 sub get_archive_dsc () {
1237 canonicalise_suite();
1238 my @vsns = archive_query('archive_query');
1239 foreach my $vinfo (@vsns) {
1240 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1241 $dscurl = access_cfg('mirror').$subpath;
1242 $dscdata = url_get($dscurl);
1244 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1249 $digester->add($dscdata);
1250 my $got = $digester->hexdigest();
1252 fail "$dscurl has hash $got but".
1253 " archive told us to expect $digest";
1255 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1256 printdebug Dumper($dscdata) if $debuglevel>1;
1257 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1258 printdebug Dumper($dsc) if $debuglevel>1;
1259 my $fmt = getfield $dsc, 'Format';
1260 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1261 $dsc_checked = !!$digester;
1262 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1266 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1269 sub check_for_git ();
1270 sub check_for_git () {
1272 my $how = access_cfg('git-check');
1273 if ($how eq 'ssh-cmd') {
1275 (access_cfg_ssh, access_gituserhost(),
1276 access_runeinfo("git-check $package").
1277 " set -e; cd ".access_cfg('git-path').";".
1278 " if test -d $package.git; then echo 1; else echo 0; fi");
1279 my $r= cmdoutput @cmd;
1280 if (defined $r and $r =~ m/^divert (\w+)$/) {
1282 my ($usedistro,) = access_distros();
1283 # NB that if we are pushing, $usedistro will be $distro/push
1284 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1285 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1286 progress "diverting to $divert (using config for $instead_distro)";
1287 return check_for_git();
1289 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1291 } elsif ($how eq 'url') {
1292 my $prefix = access_cfg('git-check-url','git-url');
1293 my $suffix = access_cfg('git-check-suffix','git-suffix',
1294 'RETURN-UNDEF') // '.git';
1295 my $url = "$prefix/$package$suffix";
1296 my @cmd = (qw(curl -sS -I), $url);
1297 my $result = cmdoutput @cmd;
1298 $result =~ s/^\S+ 200 .*\n\r?\n//;
1299 # curl -sS -I with https_proxy prints
1300 # HTTP/1.0 200 Connection established
1301 $result =~ m/^\S+ (404|200) /s or
1302 fail "unexpected results from git check query - ".
1303 Dumper($prefix, $result);
1305 if ($code eq '404') {
1307 } elsif ($code eq '200') {
1312 } elsif ($how eq 'true') {
1314 } elsif ($how eq 'false') {
1317 badcfg "unknown git-check \`$how'";
1321 sub create_remote_git_repo () {
1322 my $how = access_cfg('git-create');
1323 if ($how eq 'ssh-cmd') {
1325 (access_cfg_ssh, access_gituserhost(),
1326 access_runeinfo("git-create $package").
1327 "set -e; cd ".access_cfg('git-path').";".
1328 " cp -a _template $package.git");
1329 } elsif ($how eq 'true') {
1332 badcfg "unknown git-create \`$how'";
1336 our ($dsc_hash,$lastpush_mergeinput);
1338 our $ud = '.git/dgit/unpack';
1348 sub mktree_in_ud_here () {
1349 runcmd qw(git init -q);
1350 runcmd qw(git config gc.auto 0);
1351 rmtree('.git/objects');
1352 symlink '../../../../objects','.git/objects' or die $!;
1355 sub git_write_tree () {
1356 my $tree = cmdoutput @git, qw(write-tree);
1357 $tree =~ m/^\w+$/ or die "$tree ?";
1361 sub remove_stray_gits () {
1362 my @gitscmd = qw(find -name .git -prune -print0);
1363 debugcmd "|",@gitscmd;
1364 open GITS, "-|", @gitscmd or die $!;
1369 print STDERR "$us: warning: removing from source package: ",
1370 (messagequote $_), "\n";
1374 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1377 sub mktree_in_ud_from_only_subdir (;$) {
1380 # changes into the subdir
1382 die "expected one subdir but found @dirs ?" unless @dirs==1;
1383 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1387 remove_stray_gits();
1388 mktree_in_ud_here();
1390 my ($format, $fopts) = get_source_format();
1391 if (madformat($format)) {
1396 runcmd @git, qw(add -Af);
1397 my $tree=git_write_tree();
1398 return ($tree,$dir);
1401 sub dsc_files_info () {
1402 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1403 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1404 ['Files', 'Digest::MD5', 'new()']) {
1405 my ($fname, $module, $method) = @$csumi;
1406 my $field = $dsc->{$fname};
1407 next unless defined $field;
1408 eval "use $module; 1;" or die $@;
1410 foreach (split /\n/, $field) {
1412 m/^(\w+) (\d+) (\S+)$/ or
1413 fail "could not parse .dsc $fname line \`$_'";
1414 my $digester = eval "$module"."->$method;" or die $@;
1419 Digester => $digester,
1424 fail "missing any supported Checksums-* or Files field in ".
1425 $dsc->get_option('name');
1429 map { $_->{Filename} } dsc_files_info();
1432 sub is_orig_file_in_dsc ($$) {
1433 my ($f, $dsc_files_info) = @_;
1434 return 0 if @$dsc_files_info <= 1;
1435 # One file means no origs, and the filename doesn't have a "what
1436 # part of dsc" component. (Consider versions ending `.orig'.)
1437 return 0 unless $f =~ m/\.orig(?:-\w+)?\.tar(?:\.\w+)?$/;
1441 sub is_orig_file_of_vsn ($$) {
1442 my ($f, $upstreamvsn) = @_;
1443 my $base = srcfn $upstreamvsn, '';
1444 return 0 unless $f =~ m/^\Q$base\E\.orig(?:-\w+)?\.tar(?:\.\w+)?$/;
1448 sub make_commit ($) {
1450 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1453 sub make_commit_text ($) {
1456 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1458 print Dumper($text) if $debuglevel > 1;
1459 my $child = open2($out, $in, @cmd) or die $!;
1462 print $in $text or die $!;
1463 close $in or die $!;
1465 $h =~ m/^\w+$/ or die;
1467 printdebug "=> $h\n";
1470 waitpid $child, 0 == $child or die "$child $!";
1471 $? and failedcmd @cmd;
1475 sub clogp_authline ($) {
1477 my $author = getfield $clogp, 'Maintainer';
1478 $author =~ s#,.*##ms;
1479 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1480 my $authline = "$author $date";
1481 $authline =~ m/$git_authline_re/o or
1482 fail "unexpected commit author line format \`$authline'".
1483 " (was generated from changelog Maintainer field)";
1484 return ($1,$2,$3) if wantarray;
1488 sub vendor_patches_distro ($$) {
1489 my ($checkdistro, $what) = @_;
1490 return unless defined $checkdistro;
1492 my $series = "debian/patches/\L$checkdistro\E.series";
1493 printdebug "checking for vendor-specific $series ($what)\n";
1495 if (!open SERIES, "<", $series) {
1496 die "$series $!" unless $!==ENOENT;
1505 Unfortunately, this source package uses a feature of dpkg-source where
1506 the same source package unpacks to different source code on different
1507 distros. dgit cannot safely operate on such packages on affected
1508 distros, because the meaning of source packages is not stable.
1510 Please ask the distro/maintainer to remove the distro-specific series
1511 files and use a different technique (if necessary, uploading actually
1512 different packages, if different distros are supposed to have
1516 fail "Found active distro-specific series file for".
1517 " $checkdistro ($what): $series, cannot continue";
1519 die "$series $!" if SERIES->error;
1523 sub check_for_vendor_patches () {
1524 # This dpkg-source feature doesn't seem to be documented anywhere!
1525 # But it can be found in the changelog (reformatted):
1527 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1528 # Author: Raphael Hertzog <hertzog@debian.org>
1529 # Date: Sun Oct 3 09:36:48 2010 +0200
1531 # dpkg-source: correctly create .pc/.quilt_series with alternate
1534 # If you have debian/patches/ubuntu.series and you were
1535 # unpacking the source package on ubuntu, quilt was still
1536 # directed to debian/patches/series instead of
1537 # debian/patches/ubuntu.series.
1539 # debian/changelog | 3 +++
1540 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1541 # 2 files changed, 6 insertions(+), 1 deletion(-)
1544 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1545 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1546 "Dpkg::Vendor \`current vendor'");
1547 vendor_patches_distro(access_basedistro(),
1548 "distro being accessed");
1551 sub generate_commits_from_dsc () {
1552 # See big comment in fetch_from_archive, below.
1556 my @dfi = dsc_files_info();
1557 foreach my $fi (@dfi) {
1558 my $f = $fi->{Filename};
1559 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1561 link_ltarget "../../../$f", $f
1565 complete_file_from_dsc('.', $fi)
1568 if (is_orig_file_in_dsc($f, \@dfi)) {
1569 link $f, "../../../../$f"
1575 my $dscfn = "$package.dsc";
1577 open D, ">", $dscfn or die "$dscfn: $!";
1578 print D $dscdata or die "$dscfn: $!";
1579 close D or die "$dscfn: $!";
1580 my @cmd = qw(dpkg-source);
1581 push @cmd, '--no-check' if $dsc_checked;
1582 push @cmd, qw(-x --), $dscfn;
1585 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1586 check_for_vendor_patches() if madformat($dsc->{format});
1587 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1588 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1589 my $authline = clogp_authline $clogp;
1590 my $changes = getfield $clogp, 'Changes';
1591 open C, ">../commit.tmp" or die $!;
1592 print C <<END or die $!;
1599 # imported from the archive
1602 my $rawimport_hash = make_commit qw(../commit.tmp);
1603 my $cversion = getfield $clogp, 'Version';
1604 progress "synthesised git commit from .dsc $cversion";
1606 my $rawimport_mergeinput = {
1607 Commit => $rawimport_hash,
1608 Info => "Import of source package",
1610 my @output = ($rawimport_mergeinput);
1612 if ($lastpush_mergeinput) {
1613 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1614 my $oversion = getfield $oldclogp, 'Version';
1616 version_compare($oversion, $cversion);
1618 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1619 { Message => <<END, ReverseParents => 1 });
1620 Record $package ($cversion) in archive suite $csuite
1622 } elsif ($vcmp > 0) {
1623 print STDERR <<END or die $!;
1625 Version actually in archive: $cversion (older)
1626 Last version pushed with dgit: $oversion (newer or same)
1629 @output = $lastpush_mergeinput;
1631 # Same version. Use what's in the server git branch,
1632 # discarding our own import. (This could happen if the
1633 # server automatically imports all packages into git.)
1634 @output = $lastpush_mergeinput;
1637 changedir '../../../..';
1642 sub complete_file_from_dsc ($$) {
1643 our ($dstdir, $fi) = @_;
1644 # Ensures that we have, in $dir, the file $fi, with the correct
1645 # contents. (Downloading it from alongside $dscurl if necessary.)
1647 my $f = $fi->{Filename};
1648 my $tf = "$dstdir/$f";
1651 if (stat_exists $tf) {
1652 progress "using existing $f";
1655 $furl =~ s{/[^/]+$}{};
1657 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1658 die "$f ?" if $f =~ m#/#;
1659 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1660 return 0 if !act_local();
1664 open F, "<", "$tf" or die "$tf: $!";
1665 $fi->{Digester}->reset();
1666 $fi->{Digester}->addfile(*F);
1667 F->error and die $!;
1668 my $got = $fi->{Digester}->hexdigest();
1669 $got eq $fi->{Hash} or
1670 fail "file $f has hash $got but .dsc".
1671 " demands hash $fi->{Hash} ".
1672 ($downloaded ? "(got wrong file from archive!)"
1673 : "(perhaps you should delete this file?)");
1678 sub ensure_we_have_orig () {
1679 my @dfi = dsc_files_info();
1680 foreach my $fi (@dfi) {
1681 my $f = $fi->{Filename};
1682 next unless is_orig_file_in_dsc($f, \@dfi);
1683 complete_file_from_dsc('..', $fi)
1688 sub git_fetch_us () {
1689 # Want to fetch only what we are going to use, unless
1690 # deliberately-not-ff, in which case we must fetch everything.
1692 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1694 (quiltmode_splitbrain
1695 ? (map { $_->('*',access_basedistro) }
1696 \&debiantag_new, \&debiantag_maintview)
1697 : debiantags('*',access_basedistro));
1698 push @specs, server_branch($csuite);
1699 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1701 # This is rather miserable:
1702 # When git-fetch --prune is passed a fetchspec ending with a *,
1703 # it does a plausible thing. If there is no * then:
1704 # - it matches subpaths too, even if the supplied refspec
1705 # starts refs, and behaves completely madly if the source
1706 # has refs/refs/something. (See, for example, Debian #NNNN.)
1707 # - if there is no matching remote ref, it bombs out the whole
1709 # We want to fetch a fixed ref, and we don't know in advance
1710 # if it exists, so this is not suitable.
1712 # Our workaround is to use git-ls-remote. git-ls-remote has its
1713 # own qairks. Notably, it has the absurd multi-tail-matching
1714 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1715 # refs/refs/foo etc.
1717 # Also, we want an idempotent snapshot, but we have to make two
1718 # calls to the remote: one to git-ls-remote and to git-fetch. The
1719 # solution is use git-ls-remote to obtain a target state, and
1720 # git-fetch to try to generate it. If we don't manage to generate
1721 # the target state, we try again.
1723 my $specre = join '|', map {
1729 printdebug "git_fetch_us specre=$specre\n";
1730 my $wanted_rref = sub {
1732 return m/^(?:$specre)$/o;
1735 my $fetch_iteration = 0;
1738 if (++$fetch_iteration > 10) {
1739 fail "too many iterations trying to get sane fetch!";
1742 my @look = map { "refs/$_" } @specs;
1743 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1747 open GITLS, "-|", @lcmd or die $!;
1749 printdebug "=> ", $_;
1750 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1751 my ($objid,$rrefname) = ($1,$2);
1752 if (!$wanted_rref->($rrefname)) {
1754 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1758 $wantr{$rrefname} = $objid;
1761 close GITLS or failedcmd @lcmd;
1763 # OK, now %want is exactly what we want for refs in @specs
1765 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1766 "+refs/$_:".lrfetchrefs."/$_";
1769 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1770 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1773 %lrfetchrefs_f = ();
1776 git_for_each_ref(lrfetchrefs, sub {
1777 my ($objid,$objtype,$lrefname,$reftail) = @_;
1778 $lrfetchrefs_f{$lrefname} = $objid;
1779 $objgot{$objid} = 1;
1782 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1783 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1784 if (!exists $wantr{$rrefname}) {
1785 if ($wanted_rref->($rrefname)) {
1787 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1791 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1794 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1795 delete $lrfetchrefs_f{$lrefname};
1799 foreach my $rrefname (sort keys %wantr) {
1800 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1801 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1802 my $want = $wantr{$rrefname};
1803 next if $got eq $want;
1804 if (!defined $objgot{$want}) {
1806 warning: git-ls-remote suggests we want $lrefname
1807 warning: and it should refer to $want
1808 warning: but git-fetch didn't fetch that object to any relevant ref.
1809 warning: This may be due to a race with someone updating the server.
1810 warning: Will try again...
1812 next FETCH_ITERATION;
1815 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1817 runcmd_ordryrun_local @git, qw(update-ref -m),
1818 "dgit fetch git-fetch fixup", $lrefname, $want;
1819 $lrfetchrefs_f{$lrefname} = $want;
1823 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1824 Dumper(\%lrfetchrefs_f);
1827 my @tagpats = debiantags('*',access_basedistro);
1829 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1830 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1831 printdebug "currently $fullrefname=$objid\n";
1832 $here{$fullrefname} = $objid;
1834 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1835 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1836 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1837 printdebug "offered $lref=$objid\n";
1838 if (!defined $here{$lref}) {
1839 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1840 runcmd_ordryrun_local @upd;
1841 lrfetchref_used $fullrefname;
1842 } elsif ($here{$lref} eq $objid) {
1843 lrfetchref_used $fullrefname;
1846 "Not updateting $lref from $here{$lref} to $objid.\n";
1851 sub mergeinfo_getclogp ($) {
1852 # Ensures thit $mi->{Clogp} exists and returns it
1854 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1857 sub mergeinfo_version ($) {
1858 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1861 sub fetch_from_archive () {
1862 # Ensures that lrref() is what is actually in the archive, one way
1863 # or another, according to us - ie this client's
1864 # appropritaely-updated archive view. Also returns the commit id.
1865 # If there is nothing in the archive, leaves lrref alone and
1866 # returns undef. git_fetch_us must have already been called.
1870 foreach my $field (@ourdscfield) {
1871 $dsc_hash = $dsc->{$field};
1872 last if defined $dsc_hash;
1874 if (defined $dsc_hash) {
1875 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1877 progress "last upload to archive specified git hash";
1879 progress "last upload to archive has NO git hash";
1882 progress "no version available from the archive";
1885 # If the archive's .dsc has a Dgit field, there are three
1886 # relevant git commitids we need to choose between and/or merge
1888 # 1. $dsc_hash: the Dgit field from the archive
1889 # 2. $lastpush_hash: the suite branch on the dgit git server
1890 # 3. $lastfetch_hash: our local tracking brach for the suite
1892 # These may all be distinct and need not be in any fast forward
1895 # If the dsc was pushed to this suite, then the server suite
1896 # branch will have been updated; but it might have been pushed to
1897 # a different suite and copied by the archive. Conversely a more
1898 # recent version may have been pushed with dgit but not appeared
1899 # in the archive (yet).
1901 # $lastfetch_hash may be awkward because archive imports
1902 # (particularly, imports of Dgit-less .dscs) are performed only as
1903 # needed on individual clients, so different clients may perform a
1904 # different subset of them - and these imports are only made
1905 # public during push. So $lastfetch_hash may represent a set of
1906 # imports different to a subsequent upload by a different dgit
1909 # Our approach is as follows:
1911 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1912 # descendant of $dsc_hash, then it was pushed by a dgit user who
1913 # had based their work on $dsc_hash, so we should prefer it.
1914 # Otherwise, $dsc_hash was installed into this suite in the
1915 # archive other than by a dgit push, and (necessarily) after the
1916 # last dgit push into that suite (since a dgit push would have
1917 # been descended from the dgit server git branch); thus, in that
1918 # case, we prefer the archive's version (and produce a
1919 # pseudo-merge to overwrite the dgit server git branch).
1921 # (If there is no Dgit field in the archive's .dsc then
1922 # generate_commit_from_dsc uses the version numbers to decide
1923 # whether the suite branch or the archive is newer. If the suite
1924 # branch is newer it ignores the archive's .dsc; otherwise it
1925 # generates an import of the .dsc, and produces a pseudo-merge to
1926 # overwrite the suite branch with the archive contents.)
1928 # The outcome of that part of the algorithm is the `public view',
1929 # and is same for all dgit clients: it does not depend on any
1930 # unpublished history in the local tracking branch.
1932 # As between the public view and the local tracking branch: The
1933 # local tracking branch is only updated by dgit fetch, and
1934 # whenever dgit fetch runs it includes the public view in the
1935 # local tracking branch. Therefore if the public view is not
1936 # descended from the local tracking branch, the local tracking
1937 # branch must contain history which was imported from the archive
1938 # but never pushed; and, its tip is now out of date. So, we make
1939 # a pseudo-merge to overwrite the old imports and stitch the old
1942 # Finally: we do not necessarily reify the public view (as
1943 # described above). This is so that we do not end up stacking two
1944 # pseudo-merges. So what we actually do is figure out the inputs
1945 # to any public view pseudo-merge and put them in @mergeinputs.
1948 # $mergeinputs[]{Commit}
1949 # $mergeinputs[]{Info}
1950 # $mergeinputs[0] is the one whose tree we use
1951 # @mergeinputs is in the order we use in the actual commit)
1954 # $mergeinputs[]{Message} is a commit message to use
1955 # $mergeinputs[]{ReverseParents} if def specifies that parent
1956 # list should be in opposite order
1957 # Such an entry has no Commit or Info. It applies only when found
1958 # in the last entry. (This ugliness is to support making
1959 # identical imports to previous dgit versions.)
1961 my $lastpush_hash = git_get_ref(lrfetchref());
1962 printdebug "previous reference hash=$lastpush_hash\n";
1963 $lastpush_mergeinput = $lastpush_hash && {
1964 Commit => $lastpush_hash,
1965 Info => "dgit suite branch on dgit git server",
1968 my $lastfetch_hash = git_get_ref(lrref());
1969 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1970 my $lastfetch_mergeinput = $lastfetch_hash && {
1971 Commit => $lastfetch_hash,
1972 Info => "dgit client's archive history view",
1975 my $dsc_mergeinput = $dsc_hash && {
1976 Commit => $dsc_hash,
1977 Info => "Dgit field in .dsc from archive",
1981 my $del_lrfetchrefs = sub {
1984 printdebug "del_lrfetchrefs...\n";
1985 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1986 my $objid = $lrfetchrefs_d{$fullrefname};
1987 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1989 $gur ||= new IO::Handle;
1990 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1992 printf $gur "delete %s %s\n", $fullrefname, $objid;
1995 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1999 if (defined $dsc_hash) {
2000 fail "missing remote git history even though dsc has hash -".
2001 " could not find ref ".rref()." at ".access_giturl()
2002 unless $lastpush_hash;
2003 ensure_we_have_orig();
2004 if ($dsc_hash eq $lastpush_hash) {
2005 @mergeinputs = $dsc_mergeinput
2006 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2007 print STDERR <<END or die $!;
2009 Git commit in archive is behind the last version allegedly pushed/uploaded.
2010 Commit referred to by archive: $dsc_hash
2011 Last version pushed with dgit: $lastpush_hash
2014 @mergeinputs = ($lastpush_mergeinput);
2016 # Archive has .dsc which is not a descendant of the last dgit
2017 # push. This can happen if the archive moves .dscs about.
2018 # Just follow its lead.
2019 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2020 progress "archive .dsc names newer git commit";
2021 @mergeinputs = ($dsc_mergeinput);
2023 progress "archive .dsc names other git commit, fixing up";
2024 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2028 @mergeinputs = generate_commits_from_dsc();
2029 # We have just done an import. Now, our import algorithm might
2030 # have been improved. But even so we do not want to generate
2031 # a new different import of the same package. So if the
2032 # version numbers are the same, just use our existing version.
2033 # If the version numbers are different, the archive has changed
2034 # (perhaps, rewound).
2035 if ($lastfetch_mergeinput &&
2036 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2037 (mergeinfo_version $mergeinputs[0]) )) {
2038 @mergeinputs = ($lastfetch_mergeinput);
2040 } elsif ($lastpush_hash) {
2041 # only in git, not in the archive yet
2042 @mergeinputs = ($lastpush_mergeinput);
2043 print STDERR <<END or die $!;
2045 Package not found in the archive, but has allegedly been pushed using dgit.
2049 printdebug "nothing found!\n";
2050 if (defined $skew_warning_vsn) {
2051 print STDERR <<END or die $!;
2053 Warning: relevant archive skew detected.
2054 Archive allegedly contains $skew_warning_vsn
2055 But we were not able to obtain any version from the archive or git.
2059 unshift @end, $del_lrfetchrefs;
2063 if ($lastfetch_hash &&
2065 my $h = $_->{Commit};
2066 $h and is_fast_fwd($lastfetch_hash, $h);
2067 # If true, one of the existing parents of this commit
2068 # is a descendant of the $lastfetch_hash, so we'll
2069 # be ff from that automatically.
2073 push @mergeinputs, $lastfetch_mergeinput;
2076 printdebug "fetch mergeinfos:\n";
2077 foreach my $mi (@mergeinputs) {
2079 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2081 printdebug sprintf " ReverseParents=%d Message=%s",
2082 $mi->{ReverseParents}, $mi->{Message};
2086 my $compat_info= pop @mergeinputs
2087 if $mergeinputs[$#mergeinputs]{Message};
2089 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2092 if (@mergeinputs > 1) {
2094 my $tree_commit = $mergeinputs[0]{Commit};
2096 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2097 $tree =~ m/\n\n/; $tree = $`;
2098 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2101 # We use the changelog author of the package in question the
2102 # author of this pseudo-merge. This is (roughly) correct if
2103 # this commit is simply representing aa non-dgit upload.
2104 # (Roughly because it does not record sponsorship - but we
2105 # don't have sponsorship info because that's in the .changes,
2106 # which isn't in the archivw.)
2108 # But, it might be that we are representing archive history
2109 # updates (including in-archive copies). These are not really
2110 # the responsibility of the person who created the .dsc, but
2111 # there is no-one whose name we should better use. (The
2112 # author of the .dsc-named commit is clearly worse.)
2114 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2115 my $author = clogp_authline $useclogp;
2116 my $cversion = getfield $useclogp, 'Version';
2118 my $mcf = ".git/dgit/mergecommit";
2119 open MC, ">", $mcf or die "$mcf $!";
2120 print MC <<END or die $!;
2124 my @parents = grep { $_->{Commit} } @mergeinputs;
2125 @parents = reverse @parents if $compat_info->{ReverseParents};
2126 print MC <<END or die $! foreach @parents;
2130 print MC <<END or die $!;
2136 if (defined $compat_info->{Message}) {
2137 print MC $compat_info->{Message} or die $!;
2139 print MC <<END or die $!;
2140 Record $package ($cversion) in archive suite $csuite
2144 my $message_add_info = sub {
2146 my $mversion = mergeinfo_version $mi;
2147 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2151 $message_add_info->($mergeinputs[0]);
2152 print MC <<END or die $!;
2153 should be treated as descended from
2155 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2159 $hash = make_commit $mcf;
2161 $hash = $mergeinputs[0]{Commit};
2163 progress "fetch hash=$hash\n";
2166 my ($lasth, $what) = @_;
2167 return unless $lasth;
2168 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2171 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2172 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2174 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2175 'DGIT_ARCHIVE', $hash;
2176 cmdoutput @git, qw(log -n2), $hash;
2177 # ... gives git a chance to complain if our commit is malformed
2179 if (defined $skew_warning_vsn) {
2181 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2182 my $gotclogp = commit_getclogp($hash);
2183 my $got_vsn = getfield $gotclogp, 'Version';
2184 printdebug "SKEW CHECK GOT $got_vsn\n";
2185 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2186 print STDERR <<END or die $!;
2188 Warning: archive skew detected. Using the available version:
2189 Archive allegedly contains $skew_warning_vsn
2190 We were able to obtain only $got_vsn
2196 if ($lastfetch_hash ne $hash) {
2197 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2201 dryrun_report @upd_cmd;
2205 lrfetchref_used lrfetchref();
2207 unshift @end, $del_lrfetchrefs;
2211 sub set_local_git_config ($$) {
2213 runcmd @git, qw(config), $k, $v;
2216 sub setup_mergechangelogs (;$) {
2218 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2220 my $driver = 'dpkg-mergechangelogs';
2221 my $cb = "merge.$driver";
2222 my $attrs = '.git/info/attributes';
2223 ensuredir '.git/info';
2225 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2226 if (!open ATTRS, "<", $attrs) {
2227 $!==ENOENT or die "$attrs: $!";
2231 next if m{^debian/changelog\s};
2232 print NATTRS $_, "\n" or die $!;
2234 ATTRS->error and die $!;
2237 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2240 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2241 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2243 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2246 sub setup_useremail (;$) {
2248 return unless $always || access_cfg_bool(1, 'setup-useremail');
2251 my ($k, $envvar) = @_;
2252 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2253 return unless defined $v;
2254 set_local_git_config "user.$k", $v;
2257 $setup->('email', 'DEBEMAIL');
2258 $setup->('name', 'DEBFULLNAME');
2261 sub setup_new_tree () {
2262 setup_mergechangelogs();
2268 canonicalise_suite();
2269 badusage "dry run makes no sense with clone" unless act_local();
2270 my $hasgit = check_for_git();
2271 mkdir $dstdir or fail "create \`$dstdir': $!";
2273 runcmd @git, qw(init -q);
2274 my $giturl = access_giturl(1);
2275 if (defined $giturl) {
2276 open H, "> .git/HEAD" or die $!;
2277 print H "ref: ".lref()."\n" or die $!;
2279 runcmd @git, qw(remote add), 'origin', $giturl;
2282 progress "fetching existing git history";
2284 runcmd_ordryrun_local @git, qw(fetch origin);
2286 progress "starting new git history";
2288 fetch_from_archive() or no_such_package;
2289 my $vcsgiturl = $dsc->{'Vcs-Git'};
2290 if (length $vcsgiturl) {
2291 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2292 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2295 runcmd @git, qw(reset --hard), lrref();
2296 printdone "ready for work in $dstdir";
2300 if (check_for_git()) {
2303 fetch_from_archive() or no_such_package();
2304 printdone "fetched into ".lrref();
2309 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2311 printdone "fetched to ".lrref()." and merged into HEAD";
2314 sub check_not_dirty () {
2315 foreach my $f (qw(local-options local-patch-header)) {
2316 if (stat_exists "debian/source/$f") {
2317 fail "git tree contains debian/source/$f";
2321 return if $ignoredirty;
2323 my @cmd = (@git, qw(diff --quiet HEAD));
2325 $!=0; $?=-1; system @cmd;
2328 fail "working tree is dirty (does not match HEAD)";
2334 sub commit_admin ($) {
2337 runcmd_ordryrun_local @git, qw(commit -m), $m;
2340 sub commit_quilty_patch () {
2341 my $output = cmdoutput @git, qw(status --porcelain);
2343 foreach my $l (split /\n/, $output) {
2344 next unless $l =~ m/\S/;
2345 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2349 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2351 progress "nothing quilty to commit, ok.";
2354 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2355 runcmd_ordryrun_local @git, qw(add -f), @adds;
2356 commit_admin "Commit Debian 3.0 (quilt) metadata";
2359 sub get_source_format () {
2361 if (open F, "debian/source/options") {
2365 s/\s+$//; # ignore missing final newline
2367 my ($k, $v) = ($`, $'); #');
2368 $v =~ s/^"(.*)"$/$1/;
2374 F->error and die $!;
2377 die $! unless $!==&ENOENT;
2380 if (!open F, "debian/source/format") {
2381 die $! unless $!==&ENOENT;
2385 F->error and die $!;
2387 return ($_, \%options);
2390 sub madformat_wantfixup ($) {
2392 return 0 unless $format eq '3.0 (quilt)';
2393 our $quilt_mode_warned;
2394 if ($quilt_mode eq 'nocheck') {
2395 progress "Not doing any fixup of \`$format' due to".
2396 " ----no-quilt-fixup or --quilt=nocheck"
2397 unless $quilt_mode_warned++;
2400 progress "Format \`$format', need to check/update patch stack"
2401 unless $quilt_mode_warned++;
2405 # An "infopair" is a tuple [ $thing, $what ]
2406 # (often $thing is a commit hash; $what is a description)
2408 sub infopair_cond_equal ($$) {
2410 $x->[0] eq $y->[0] or fail <<END;
2411 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2415 sub infopair_lrf_tag_lookup ($$) {
2416 my ($tagnames, $what) = @_;
2417 # $tagname may be an array ref
2418 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2419 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2420 foreach my $tagname (@tagnames) {
2421 my $lrefname = lrfetchrefs."/tags/$tagname";
2422 my $tagobj = $lrfetchrefs_f{$lrefname};
2423 next unless defined $tagobj;
2424 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2425 return [ git_rev_parse($tagobj), $what ];
2427 fail @tagnames==1 ? <<END : <<END;
2428 Wanted tag $what (@tagnames) on dgit server, but not found
2430 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2434 sub infopair_cond_ff ($$) {
2435 my ($anc,$desc) = @_;
2436 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2437 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2441 sub pseudomerge_version_check ($$) {
2442 my ($clogp, $archive_hash) = @_;
2444 my $arch_clogp = commit_getclogp $archive_hash;
2445 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2446 'version currently in archive' ];
2447 if (defined $overwrite_version) {
2448 if (length $overwrite_version) {
2449 infopair_cond_equal([ $overwrite_version,
2450 '--overwrite= version' ],
2453 my $v = $i_arch_v->[0];
2454 progress "Checking package changelog for archive version $v ...";
2456 my @xa = ("-f$v", "-t$v");
2457 my $vclogp = parsechangelog @xa;
2458 my $cv = [ (getfield $vclogp, 'Version'),
2459 "Version field from dpkg-parsechangelog @xa" ];
2460 infopair_cond_equal($i_arch_v, $cv);
2463 $@ =~ s/^dgit: //gm;
2465 "Perhaps debian/changelog does not mention $v ?";
2470 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2474 sub pseudomerge_make_commit ($$$$ $$) {
2475 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2476 $msg_cmd, $msg_msg) = @_;
2477 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2479 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2480 my $authline = clogp_authline $clogp;
2484 !defined $overwrite_version ? ""
2485 : !length $overwrite_version ? " --overwrite"
2486 : " --overwrite=".$overwrite_version;
2489 my $pmf = ".git/dgit/pseudomerge";
2490 open MC, ">", $pmf or die "$pmf $!";
2491 print MC <<END or die $!;
2494 parent $archive_hash
2504 return make_commit($pmf);
2507 sub splitbrain_pseudomerge ($$$$) {
2508 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2509 # => $merged_dgitview
2510 printdebug "splitbrain_pseudomerge...\n";
2512 # We: debian/PREVIOUS HEAD($maintview)
2513 # expect: o ----------------- o
2516 # a/d/PREVIOUS $dgitview
2519 # we do: `------------------ o
2523 printdebug "splitbrain_pseudomerge...\n";
2525 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2527 return $dgitview unless defined $archive_hash;
2529 if (!defined $overwrite_version) {
2530 progress "Checking that HEAD inciudes all changes in archive...";
2533 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2535 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2536 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2537 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2538 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2539 my $i_archive = [ $archive_hash, "current archive contents" ];
2541 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2543 infopair_cond_equal($i_dgit, $i_archive);
2544 infopair_cond_ff($i_dep14, $i_dgit);
2545 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2547 my $r = pseudomerge_make_commit
2548 $clogp, $dgitview, $archive_hash, $i_arch_v,
2549 "dgit --quilt=$quilt_mode",
2550 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2551 Declare fast forward from $overwrite_version
2553 Make fast forward from $i_arch_v->[0]
2556 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2560 sub plain_overwrite_pseudomerge ($$$) {
2561 my ($clogp, $head, $archive_hash) = @_;
2563 printdebug "plain_overwrite_pseudomerge...";
2565 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2567 my @tagformats = access_cfg_tagformats();
2569 map { $_->($i_arch_v->[0], access_basedistro) }
2570 (grep { m/^(?:old|hist)$/ } @tagformats)
2571 ? \&debiantags : \&debiantag_new;
2572 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2573 my $i_archive = [ $archive_hash, "current archive contents" ];
2575 infopair_cond_equal($i_overwr, $i_archive);
2577 return $head if is_fast_fwd $archive_hash, $head;
2579 my $m = "Declare fast forward from $i_arch_v->[0]";
2581 my $r = pseudomerge_make_commit
2582 $clogp, $head, $archive_hash, $i_arch_v,
2585 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2587 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2591 sub push_parse_changelog ($) {
2594 my $clogp = Dpkg::Control::Hash->new();
2595 $clogp->load($clogpfn) or die;
2597 $package = getfield $clogp, 'Source';
2598 my $cversion = getfield $clogp, 'Version';
2599 my $tag = debiantag($cversion, access_basedistro);
2600 runcmd @git, qw(check-ref-format), $tag;
2602 my $dscfn = dscfn($cversion);
2604 return ($clogp, $cversion, $dscfn);
2607 sub push_parse_dsc ($$$) {
2608 my ($dscfn,$dscfnwhat, $cversion) = @_;
2609 $dsc = parsecontrol($dscfn,$dscfnwhat);
2610 my $dversion = getfield $dsc, 'Version';
2611 my $dscpackage = getfield $dsc, 'Source';
2612 ($dscpackage eq $package && $dversion eq $cversion) or
2613 fail "$dscfn is for $dscpackage $dversion".
2614 " but debian/changelog is for $package $cversion";
2617 sub push_tagwants ($$$$) {
2618 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2621 TagFn => \&debiantag,
2626 if (defined $maintviewhead) {
2628 TagFn => \&debiantag_maintview,
2629 Objid => $maintviewhead,
2630 TfSuffix => '-maintview',
2634 foreach my $tw (@tagwants) {
2635 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2636 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2638 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2642 sub push_mktags ($$ $$ $) {
2644 $changesfile,$changesfilewhat,
2647 die unless $tagwants->[0]{View} eq 'dgit';
2649 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2650 $dsc->save("$dscfn.tmp") or die $!;
2652 my $changes = parsecontrol($changesfile,$changesfilewhat);
2653 foreach my $field (qw(Source Distribution Version)) {
2654 $changes->{$field} eq $clogp->{$field} or
2655 fail "changes field $field \`$changes->{$field}'".
2656 " does not match changelog \`$clogp->{$field}'";
2659 my $cversion = getfield $clogp, 'Version';
2660 my $clogsuite = getfield $clogp, 'Distribution';
2662 # We make the git tag by hand because (a) that makes it easier
2663 # to control the "tagger" (b) we can do remote signing
2664 my $authline = clogp_authline $clogp;
2665 my $delibs = join(" ", "",@deliberatelies);
2666 my $declaredistro = access_basedistro();
2670 my $tfn = $tw->{Tfn};
2671 my $head = $tw->{Objid};
2672 my $tag = $tw->{Tag};
2674 open TO, '>', $tfn->('.tmp') or die $!;
2675 print TO <<END or die $!;
2682 if ($tw->{View} eq 'dgit') {
2683 print TO <<END or die $!;
2684 $package release $cversion for $clogsuite ($csuite) [dgit]
2685 [dgit distro=$declaredistro$delibs]
2687 foreach my $ref (sort keys %previously) {
2688 print TO <<END or die $!;
2689 [dgit previously:$ref=$previously{$ref}]
2692 } elsif ($tw->{View} eq 'maint') {
2693 print TO <<END or die $!;
2694 $package release $cversion for $clogsuite ($csuite)
2695 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2698 die Dumper($tw)."?";
2703 my $tagobjfn = $tfn->('.tmp');
2705 if (!defined $keyid) {
2706 $keyid = access_cfg('keyid','RETURN-UNDEF');
2708 if (!defined $keyid) {
2709 $keyid = getfield $clogp, 'Maintainer';
2711 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2712 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2713 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2714 push @sign_cmd, $tfn->('.tmp');
2715 runcmd_ordryrun @sign_cmd;
2717 $tagobjfn = $tfn->('.signed.tmp');
2718 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2719 $tfn->('.tmp'), $tfn->('.tmp.asc');
2725 my @r = map { $mktag->($_); } @$tagwants;
2729 sub sign_changes ($) {
2730 my ($changesfile) = @_;
2732 my @debsign_cmd = @debsign;
2733 push @debsign_cmd, "-k$keyid" if defined $keyid;
2734 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2735 push @debsign_cmd, $changesfile;
2736 runcmd_ordryrun @debsign_cmd;
2741 printdebug "actually entering push\n";
2743 supplementary_message(<<'END');
2744 Push failed, while checking state of the archive.
2745 You can retry the push, after fixing the problem, if you like.
2747 if (check_for_git()) {
2750 my $archive_hash = fetch_from_archive();
2751 if (!$archive_hash) {
2753 fail "package appears to be new in this suite;".
2754 " if this is intentional, use --new";
2757 supplementary_message(<<'END');
2758 Push failed, while preparing your push.
2759 You can retry the push, after fixing the problem, if you like.
2762 need_tagformat 'new', "quilt mode $quilt_mode"
2763 if quiltmode_splitbrain;
2767 access_giturl(); # check that success is vaguely likely
2770 my $clogpfn = ".git/dgit/changelog.822.tmp";
2771 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2773 responder_send_file('parsed-changelog', $clogpfn);
2775 my ($clogp, $cversion, $dscfn) =
2776 push_parse_changelog("$clogpfn");
2778 my $dscpath = "$buildproductsdir/$dscfn";
2779 stat_exists $dscpath or
2780 fail "looked for .dsc $dscfn, but $!;".
2781 " maybe you forgot to build";
2783 responder_send_file('dsc', $dscpath);
2785 push_parse_dsc($dscpath, $dscfn, $cversion);
2787 my $format = getfield $dsc, 'Format';
2788 printdebug "format $format\n";
2790 my $actualhead = git_rev_parse('HEAD');
2791 my $dgithead = $actualhead;
2792 my $maintviewhead = undef;
2794 if (madformat_wantfixup($format)) {
2795 # user might have not used dgit build, so maybe do this now:
2796 if (quiltmode_splitbrain()) {
2797 my $upstreamversion = $clogp->{Version};
2798 $upstreamversion =~ s/-[^-]*$//;
2800 quilt_make_fake_dsc($upstreamversion);
2801 my ($dgitview, $cachekey) =
2802 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2804 "--quilt=$quilt_mode but no cached dgit view:
2805 perhaps tree changed since dgit build[-source] ?";
2807 $dgithead = splitbrain_pseudomerge($clogp,
2808 $actualhead, $dgitview,
2810 $maintviewhead = $actualhead;
2811 changedir '../../../..';
2812 prep_ud(); # so _only_subdir() works, below
2814 commit_quilty_patch();
2818 if (defined $overwrite_version && !defined $maintviewhead) {
2819 $dgithead = plain_overwrite_pseudomerge($clogp,
2827 if ($archive_hash) {
2828 if (is_fast_fwd($archive_hash, $dgithead)) {
2830 } elsif (deliberately_not_fast_forward) {
2833 fail "dgit push: HEAD is not a descendant".
2834 " of the archive's version.\n".
2835 "To overwrite the archive's contents,".
2836 " pass --overwrite[=VERSION].\n".
2837 "To rewind history, if permitted by the archive,".
2838 " use --deliberately-not-fast-forward.";
2843 progress "checking that $dscfn corresponds to HEAD";
2844 runcmd qw(dpkg-source -x --),
2845 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2846 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2847 check_for_vendor_patches() if madformat($dsc->{format});
2848 changedir '../../../..';
2849 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2850 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2851 debugcmd "+",@diffcmd;
2853 my $r = system @diffcmd;
2856 fail "$dscfn specifies a different tree to your HEAD commit;".
2857 " perhaps you forgot to build".
2858 ($diffopt eq '--exit-code' ? "" :
2859 " (run with -D to see full diff output)");
2864 if (!$changesfile) {
2865 my $pat = changespat $cversion;
2866 my @cs = glob "$buildproductsdir/$pat";
2867 fail "failed to find unique changes file".
2868 " (looked for $pat in $buildproductsdir);".
2869 " perhaps you need to use dgit -C"
2871 ($changesfile) = @cs;
2873 $changesfile = "$buildproductsdir/$changesfile";
2876 # Checks complete, we're going to try and go ahead:
2878 responder_send_file('changes',$changesfile);
2879 responder_send_command("param head $dgithead");
2880 responder_send_command("param csuite $csuite");
2881 responder_send_command("param tagformat $tagformat");
2882 if (defined $maintviewhead) {
2883 die unless ($protovsn//4) >= 4;
2884 responder_send_command("param maint-view $maintviewhead");
2887 if (deliberately_not_fast_forward) {
2888 git_for_each_ref(lrfetchrefs, sub {
2889 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2890 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2891 responder_send_command("previously $rrefname=$objid");
2892 $previously{$rrefname} = $objid;
2896 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2900 supplementary_message(<<'END');
2901 Push failed, while signing the tag.
2902 You can retry the push, after fixing the problem, if you like.
2904 # If we manage to sign but fail to record it anywhere, it's fine.
2905 if ($we_are_responder) {
2906 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2907 responder_receive_files('signed-tag', @tagobjfns);
2909 @tagobjfns = push_mktags($clogp,$dscpath,
2910 $changesfile,$changesfile,
2913 supplementary_message(<<'END');
2914 Push failed, *after* signing the tag.
2915 If you want to try again, you should use a new version number.
2918 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2920 foreach my $tw (@tagwants) {
2921 my $tag = $tw->{Tag};
2922 my $tagobjfn = $tw->{TagObjFn};
2924 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2925 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2926 runcmd_ordryrun_local
2927 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2930 supplementary_message(<<'END');
2931 Push failed, while updating the remote git repository - see messages above.
2932 If you want to try again, you should use a new version number.
2934 if (!check_for_git()) {
2935 create_remote_git_repo();
2938 my @pushrefs = $forceflag.$dgithead.":".rrref();
2939 foreach my $tw (@tagwants) {
2940 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2943 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2944 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2946 supplementary_message(<<'END');
2947 Push failed, after updating the remote git repository.
2948 If you want to try again, you must use a new version number.
2950 if ($we_are_responder) {
2951 my $dryrunsuffix = act_local() ? "" : ".tmp";
2952 responder_receive_files('signed-dsc-changes',
2953 "$dscpath$dryrunsuffix",
2954 "$changesfile$dryrunsuffix");
2957 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2959 progress "[new .dsc left in $dscpath.tmp]";
2961 sign_changes $changesfile;
2964 supplementary_message(<<END);
2965 Push failed, while uploading package(s) to the archive server.
2966 You can retry the upload of exactly these same files with dput of:
2968 If that .changes file is broken, you will need to use a new version
2969 number for your next attempt at the upload.
2971 my $host = access_cfg('upload-host','RETURN-UNDEF');
2972 my @hostarg = defined($host) ? ($host,) : ();
2973 runcmd_ordryrun @dput, @hostarg, $changesfile;
2974 printdone "pushed and uploaded $cversion";
2976 supplementary_message('');
2977 responder_send_command("complete");
2984 badusage "-p is not allowed with clone; specify as argument instead"
2985 if defined $package;
2988 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2989 ($package,$isuite) = @ARGV;
2990 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2991 ($package,$dstdir) = @ARGV;
2992 } elsif (@ARGV==3) {
2993 ($package,$isuite,$dstdir) = @ARGV;
2995 badusage "incorrect arguments to dgit clone";
2997 $dstdir ||= "$package";
2999 if (stat_exists $dstdir) {
3000 fail "$dstdir already exists";
3004 if ($rmonerror && !$dryrun_level) {
3005 $cwd_remove= getcwd();
3007 return unless defined $cwd_remove;
3008 if (!chdir "$cwd_remove") {
3009 return if $!==&ENOENT;
3010 die "chdir $cwd_remove: $!";
3013 rmtree($dstdir) or die "remove $dstdir: $!\n";
3014 } elsif (!grep { $! == $_ }
3015 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3017 print STDERR "check whether to remove $dstdir: $!\n";
3023 $cwd_remove = undef;
3026 sub branchsuite () {
3027 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3028 if ($branch =~ m#$lbranch_re#o) {
3035 sub fetchpullargs () {
3037 if (!defined $package) {
3038 my $sourcep = parsecontrol('debian/control','debian/control');
3039 $package = getfield $sourcep, 'Source';
3042 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3044 my $clogp = parsechangelog();
3045 $isuite = getfield $clogp, 'Distribution';
3047 canonicalise_suite();
3048 progress "fetching from suite $csuite";
3049 } elsif (@ARGV==1) {
3051 canonicalise_suite();
3053 badusage "incorrect arguments to dgit fetch or dgit pull";
3072 badusage "-p is not allowed with dgit push" if defined $package;
3074 my $clogp = parsechangelog();
3075 $package = getfield $clogp, 'Source';
3078 } elsif (@ARGV==1) {
3079 ($specsuite) = (@ARGV);
3081 badusage "incorrect arguments to dgit push";
3083 $isuite = getfield $clogp, 'Distribution';
3085 local ($package) = $existing_package; # this is a hack
3086 canonicalise_suite();
3088 canonicalise_suite();
3090 if (defined $specsuite &&
3091 $specsuite ne $isuite &&
3092 $specsuite ne $csuite) {
3093 fail "dgit push: changelog specifies $isuite ($csuite)".
3094 " but command line specifies $specsuite";
3099 #---------- remote commands' implementation ----------
3101 sub cmd_remote_push_build_host {
3102 my ($nrargs) = shift @ARGV;
3103 my (@rargs) = @ARGV[0..$nrargs-1];
3104 @ARGV = @ARGV[$nrargs..$#ARGV];
3106 my ($dir,$vsnwant) = @rargs;
3107 # vsnwant is a comma-separated list; we report which we have
3108 # chosen in our ready response (so other end can tell if they
3111 $we_are_responder = 1;
3112 $us .= " (build host)";
3116 open PI, "<&STDIN" or die $!;
3117 open STDIN, "/dev/null" or die $!;
3118 open PO, ">&STDOUT" or die $!;
3120 open STDOUT, ">&STDERR" or die $!;
3124 ($protovsn) = grep {
3125 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3126 } @rpushprotovsn_support;
3128 fail "build host has dgit rpush protocol versions ".
3129 (join ",", @rpushprotovsn_support).
3130 " but invocation host has $vsnwant"
3131 unless defined $protovsn;
3133 responder_send_command("dgit-remote-push-ready $protovsn");
3134 rpush_handle_protovsn_bothends();
3139 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3140 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3141 # a good error message)
3143 sub rpush_handle_protovsn_bothends () {
3144 if ($protovsn < 4) {
3145 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3154 my $report = i_child_report();
3155 if (defined $report) {
3156 printdebug "($report)\n";
3157 } elsif ($i_child_pid) {
3158 printdebug "(killing build host child $i_child_pid)\n";
3159 kill 15, $i_child_pid;
3161 if (defined $i_tmp && !defined $initiator_tempdir) {
3163 eval { rmtree $i_tmp; };
3167 END { i_cleanup(); }
3170 my ($base,$selector,@args) = @_;
3171 $selector =~ s/\-/_/g;
3172 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3179 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3187 push @rargs, join ",", @rpushprotovsn_support;
3190 push @rdgit, @ropts;
3191 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3193 my @cmd = (@ssh, $host, shellquote @rdgit);
3196 if (defined $initiator_tempdir) {
3197 rmtree $initiator_tempdir;
3198 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3199 $i_tmp = $initiator_tempdir;
3203 $i_child_pid = open2(\*RO, \*RI, @cmd);
3205 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3206 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3207 $supplementary_message = '' unless $protovsn >= 3;
3209 fail "rpush negotiated protocol version $protovsn".
3210 " which does not support quilt mode $quilt_mode"
3211 if quiltmode_splitbrain;
3213 rpush_handle_protovsn_bothends();
3215 my ($icmd,$iargs) = initiator_expect {
3216 m/^(\S+)(?: (.*))?$/;
3219 i_method "i_resp", $icmd, $iargs;
3223 sub i_resp_progress ($) {
3225 my $msg = protocol_read_bytes \*RO, $rhs;
3229 sub i_resp_supplementary_message ($) {
3231 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3234 sub i_resp_complete {
3235 my $pid = $i_child_pid;
3236 $i_child_pid = undef; # prevents killing some other process with same pid
3237 printdebug "waiting for build host child $pid...\n";
3238 my $got = waitpid $pid, 0;
3239 die $! unless $got == $pid;
3240 die "build host child failed $?" if $?;
3243 printdebug "all done\n";
3247 sub i_resp_file ($) {
3249 my $localname = i_method "i_localname", $keyword;
3250 my $localpath = "$i_tmp/$localname";
3251 stat_exists $localpath and
3252 badproto \*RO, "file $keyword ($localpath) twice";
3253 protocol_receive_file \*RO, $localpath;
3254 i_method "i_file", $keyword;
3259 sub i_resp_param ($) {
3260 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3264 sub i_resp_previously ($) {
3265 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3266 or badproto \*RO, "bad previously spec";
3267 my $r = system qw(git check-ref-format), $1;
3268 die "bad previously ref spec ($r)" if $r;
3269 $previously{$1} = $2;
3274 sub i_resp_want ($) {
3276 die "$keyword ?" if $i_wanted{$keyword}++;
3277 my @localpaths = i_method "i_want", $keyword;
3278 printdebug "[[ $keyword @localpaths\n";
3279 foreach my $localpath (@localpaths) {
3280 protocol_send_file \*RI, $localpath;
3282 print RI "files-end\n" or die $!;
3285 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3287 sub i_localname_parsed_changelog {
3288 return "remote-changelog.822";
3290 sub i_file_parsed_changelog {
3291 ($i_clogp, $i_version, $i_dscfn) =
3292 push_parse_changelog "$i_tmp/remote-changelog.822";
3293 die if $i_dscfn =~ m#/|^\W#;
3296 sub i_localname_dsc {
3297 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3302 sub i_localname_changes {
3303 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3304 $i_changesfn = $i_dscfn;
3305 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3306 return $i_changesfn;
3308 sub i_file_changes { }
3310 sub i_want_signed_tag {
3311 printdebug Dumper(\%i_param, $i_dscfn);
3312 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3313 && defined $i_param{'csuite'}
3314 or badproto \*RO, "premature desire for signed-tag";
3315 my $head = $i_param{'head'};
3316 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3318 my $maintview = $i_param{'maint-view'};
3319 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3322 if ($protovsn >= 4) {
3323 my $p = $i_param{'tagformat'} // '<undef>';
3325 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3328 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3330 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3332 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3335 push_mktags $i_clogp, $i_dscfn,
3336 $i_changesfn, 'remote changes',
3340 sub i_want_signed_dsc_changes {
3341 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3342 sign_changes $i_changesfn;
3343 return ($i_dscfn, $i_changesfn);
3346 #---------- building etc. ----------
3352 #----- `3.0 (quilt)' handling -----
3354 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3356 sub quiltify_dpkg_commit ($$$;$) {
3357 my ($patchname,$author,$msg, $xinfo) = @_;
3361 my $descfn = ".git/dgit/quilt-description.tmp";
3362 open O, '>', $descfn or die "$descfn: $!";
3365 $msg =~ s/^\s+$/ ./mg;
3366 print O <<END or die $!;
3376 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3377 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3378 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3379 runcmd @dpkgsource, qw(--commit .), $patchname;
3383 sub quiltify_trees_differ ($$;$$) {
3384 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3385 # returns true iff the two tree objects differ other than in debian/
3386 # with $finegrained,
3387 # returns bitmask 01 - differ in upstream files except .gitignore
3388 # 02 - differ in .gitignore
3389 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3390 # is set for each modified .gitignore filename $fn
3392 my @cmd = (@git, qw(diff-tree --name-only -z));
3393 push @cmd, qw(-r) if $finegrained;
3395 my $diffs= cmdoutput @cmd;
3397 foreach my $f (split /\0/, $diffs) {
3398 next if $f =~ m#^debian(?:/.*)?$#s;
3399 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3400 $r |= $isignore ? 02 : 01;
3401 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3403 printdebug "quiltify_trees_differ $x $y => $r\n";
3407 sub quiltify_tree_sentinelfiles ($) {
3408 # lists the `sentinel' files present in the tree
3410 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3411 qw(-- debian/rules debian/control);
3416 sub quiltify_splitbrain_needed () {
3417 if (!$split_brain) {
3418 progress "dgit view: changes are required...";
3419 runcmd @git, qw(checkout -q -b dgit-view);
3424 sub quiltify_splitbrain ($$$$$$) {
3425 my ($clogp, $unapplied, $headref, $diffbits,
3426 $editedignores, $cachekey) = @_;
3427 if ($quilt_mode !~ m/gbp|dpm/) {
3428 # treat .gitignore just like any other upstream file
3429 $diffbits = { %$diffbits };
3430 $_ = !!$_ foreach values %$diffbits;
3432 # We would like any commits we generate to be reproducible
3433 my @authline = clogp_authline($clogp);
3434 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3435 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3436 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3438 if ($quilt_mode =~ m/gbp|unapplied/ &&
3439 ($diffbits->{H2O} & 01)) {
3441 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3442 " but git tree differs from orig in upstream files.";
3443 if (!stat_exists "debian/patches") {
3445 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3449 if ($quilt_mode =~ m/dpm/ &&
3450 ($diffbits->{H2A} & 01)) {
3452 --quilt=$quilt_mode specified, implying patches-applied git tree
3453 but git tree differs from result of applying debian/patches to upstream
3456 if ($quilt_mode =~ m/gbp|unapplied/ &&
3457 ($diffbits->{O2A} & 01)) { # some patches
3458 quiltify_splitbrain_needed();
3459 progress "dgit view: creating patches-applied version using gbp pq";
3460 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3461 # gbp pq import creates a fresh branch; push back to dgit-view
3462 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3463 runcmd @git, qw(checkout -q dgit-view);
3465 if ($quilt_mode =~ m/gbp|dpm/ &&
3466 ($diffbits->{O2A} & 02)) {
3468 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3469 tool which does not create patches for changes to upstream
3470 .gitignores: but, such patches exist in debian/patches.
3473 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3474 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3475 quiltify_splitbrain_needed();
3476 progress "dgit view: creating patch to represent .gitignore changes";
3477 ensuredir "debian/patches";
3478 my $gipatch = "debian/patches/auto-gitignore";
3479 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3480 stat GIPATCH or die "$gipatch: $!";
3481 fail "$gipatch already exists; but want to create it".
3482 " to record .gitignore changes" if (stat _)[7];
3483 print GIPATCH <<END or die "$gipatch: $!";
3484 Subject: Update .gitignore from Debian packaging branch
3486 The Debian packaging git branch contains these updates to the upstream
3487 .gitignore file(s). This patch is autogenerated, to provide these
3488 updates to users of the official Debian archive view of the package.
3490 [dgit version $our_version]
3493 close GIPATCH or die "$gipatch: $!";
3494 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3495 $unapplied, $headref, "--", sort keys %$editedignores;
3496 open SERIES, "+>>", "debian/patches/series" or die $!;
3497 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3499 defined read SERIES, $newline, 1 or die $!;
3500 print SERIES "\n" or die $! unless $newline eq "\n";
3501 print SERIES "auto-gitignore\n" or die $!;
3502 close SERIES or die $!;
3503 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3504 commit_admin "Commit patch to update .gitignore";
3507 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3509 changedir '../../../..';
3510 ensuredir ".git/logs/refs/dgit-intern";
3511 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3513 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3516 progress "dgit view: created (commit id $dgitview)";
3518 changedir '.git/dgit/unpack/work';
3521 sub quiltify ($$$$) {
3522 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3524 # Quilt patchification algorithm
3526 # We search backwards through the history of the main tree's HEAD
3527 # (T) looking for a start commit S whose tree object is identical
3528 # to to the patch tip tree (ie the tree corresponding to the
3529 # current dpkg-committed patch series). For these purposes
3530 # `identical' disregards anything in debian/ - this wrinkle is
3531 # necessary because dpkg-source treates debian/ specially.
3533 # We can only traverse edges where at most one of the ancestors'
3534 # trees differs (in changes outside in debian/). And we cannot
3535 # handle edges which change .pc/ or debian/patches. To avoid
3536 # going down a rathole we avoid traversing edges which introduce
3537 # debian/rules or debian/control. And we set a limit on the
3538 # number of edges we are willing to look at.
3540 # If we succeed, we walk forwards again. For each traversed edge
3541 # PC (with P parent, C child) (starting with P=S and ending with
3542 # C=T) to we do this:
3544 # - dpkg-source --commit with a patch name and message derived from C
3545 # After traversing PT, we git commit the changes which
3546 # should be contained within debian/patches.
3548 # The search for the path S..T is breadth-first. We maintain a
3549 # todo list containing search nodes. A search node identifies a
3550 # commit, and looks something like this:
3552 # Commit => $git_commit_id,
3553 # Child => $c, # or undef if P=T
3554 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3555 # Nontrivial => true iff $p..$c has relevant changes
3562 my %considered; # saves being exponential on some weird graphs
3564 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3567 my ($search,$whynot) = @_;
3568 printdebug " search NOT $search->{Commit} $whynot\n";
3569 $search->{Whynot} = $whynot;
3570 push @nots, $search;
3571 no warnings qw(exiting);
3580 my $c = shift @todo;
3581 next if $considered{$c->{Commit}}++;
3583 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3585 printdebug "quiltify investigate $c->{Commit}\n";
3588 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3589 printdebug " search finished hooray!\n";
3594 if ($quilt_mode eq 'nofix') {
3595 fail "quilt fixup required but quilt mode is \`nofix'\n".
3596 "HEAD commit $c->{Commit} differs from tree implied by ".
3597 " debian/patches (tree object $oldtiptree)";
3599 if ($quilt_mode eq 'smash') {
3600 printdebug " search quitting smash\n";
3604 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3605 $not->($c, "has $c_sentinels not $t_sentinels")
3606 if $c_sentinels ne $t_sentinels;
3608 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3609 $commitdata =~ m/\n\n/;
3611 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3612 @parents = map { { Commit => $_, Child => $c } } @parents;
3614 $not->($c, "root commit") if !@parents;
3616 foreach my $p (@parents) {
3617 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3619 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3620 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3622 foreach my $p (@parents) {
3623 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3625 my @cmd= (@git, qw(diff-tree -r --name-only),
3626 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3627 my $patchstackchange = cmdoutput @cmd;
3628 if (length $patchstackchange) {
3629 $patchstackchange =~ s/\n/,/g;
3630 $not->($p, "changed $patchstackchange");
3633 printdebug " search queue P=$p->{Commit} ",
3634 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3640 printdebug "quiltify want to smash\n";
3643 my $x = $_[0]{Commit};
3644 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3647 my $reportnot = sub {
3649 my $s = $abbrev->($notp);
3650 my $c = $notp->{Child};
3651 $s .= "..".$abbrev->($c) if $c;
3652 $s .= ": ".$notp->{Whynot};
3655 if ($quilt_mode eq 'linear') {
3656 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3657 foreach my $notp (@nots) {
3658 print STDERR "$us: ", $reportnot->($notp), "\n";
3660 print STDERR "$us: $_\n" foreach @$failsuggestion;
3661 fail "quilt fixup naive history linearisation failed.\n".
3662 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3663 } elsif ($quilt_mode eq 'smash') {
3664 } elsif ($quilt_mode eq 'auto') {
3665 progress "quilt fixup cannot be linear, smashing...";
3667 die "$quilt_mode ?";
3670 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3671 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3673 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3675 quiltify_dpkg_commit "auto-$version-$target-$time",
3676 (getfield $clogp, 'Maintainer'),
3677 "Automatically generated patch ($clogp->{Version})\n".
3678 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3682 progress "quiltify linearisation planning successful, executing...";
3684 for (my $p = $sref_S;
3685 my $c = $p->{Child};
3687 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3688 next unless $p->{Nontrivial};
3690 my $cc = $c->{Commit};
3692 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3693 $commitdata =~ m/\n\n/ or die "$c ?";
3696 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3699 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3702 my $patchname = $title;
3703 $patchname =~ s/[.:]$//;
3704 $patchname =~ y/ A-Z/-a-z/;
3705 $patchname =~ y/-a-z0-9_.+=~//cd;
3706 $patchname =~ s/^\W/x-$&/;
3707 $patchname = substr($patchname,0,40);
3710 stat "debian/patches/$patchname$index";
3712 $!==ENOENT or die "$patchname$index $!";
3714 runcmd @git, qw(checkout -q), $cc;
3716 # We use the tip's changelog so that dpkg-source doesn't
3717 # produce complaining messages from dpkg-parsechangelog. None
3718 # of the information dpkg-source gets from the changelog is
3719 # actually relevant - it gets put into the original message
3720 # which dpkg-source provides our stunt editor, and then
3722 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3724 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3725 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3727 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3730 runcmd @git, qw(checkout -q master);
3733 sub build_maybe_quilt_fixup () {
3734 my ($format,$fopts) = get_source_format;
3735 return unless madformat_wantfixup $format;
3738 check_for_vendor_patches();
3740 if (quiltmode_splitbrain) {
3741 foreach my $needtf (qw(new maint)) {
3742 next if grep { $_ eq $needtf } access_cfg_tagformats;
3744 quilt mode $quilt_mode requires split view so server needs to support
3745 both "new" and "maint" tag formats, but config says it doesn't.
3750 my $clogp = parsechangelog();
3751 my $headref = git_rev_parse('HEAD');
3756 my $upstreamversion=$version;
3757 $upstreamversion =~ s/-[^-]*$//;
3759 if ($fopts->{'single-debian-patch'}) {
3760 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3762 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3765 die 'bug' if $split_brain && !$need_split_build_invocation;
3767 changedir '../../../..';
3768 runcmd_ordryrun_local
3769 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3772 sub quilt_fixup_mkwork ($) {
3775 mkdir "work" or die $!;
3777 mktree_in_ud_here();
3778 runcmd @git, qw(reset -q --hard), $headref;
3781 sub quilt_fixup_linkorigs ($$) {
3782 my ($upstreamversion, $fn) = @_;
3783 # calls $fn->($leafname);
3785 foreach my $f (<../../../../*>) { #/){
3786 my $b=$f; $b =~ s{.*/}{};
3788 local ($debuglevel) = $debuglevel-1;
3789 printdebug "QF linkorigs $b, $f ?\n";
3791 next unless is_orig_file_of_vsn $b, $upstreamversion;
3792 printdebug "QF linkorigs $b, $f Y\n";
3793 link_ltarget $f, $b or die "$b $!";
3798 sub quilt_fixup_delete_pc () {
3799 runcmd @git, qw(rm -rqf .pc);
3800 commit_admin "Commit removal of .pc (quilt series tracking data)";
3803 sub quilt_fixup_singlepatch ($$$) {
3804 my ($clogp, $headref, $upstreamversion) = @_;
3806 progress "starting quiltify (single-debian-patch)";
3808 # dpkg-source --commit generates new patches even if
3809 # single-debian-patch is in debian/source/options. In order to
3810 # get it to generate debian/patches/debian-changes, it is
3811 # necessary to build the source package.
3813 quilt_fixup_linkorigs($upstreamversion, sub { });
3814 quilt_fixup_mkwork($headref);
3816 rmtree("debian/patches");
3818 runcmd @dpkgsource, qw(-b .);
3820 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3821 rename srcfn("$upstreamversion", "/debian/patches"),
3822 "work/debian/patches";
3825 commit_quilty_patch();
3828 sub quilt_make_fake_dsc ($) {
3829 my ($upstreamversion) = @_;
3831 my $fakeversion="$upstreamversion-~~DGITFAKE";
3833 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3834 print $fakedsc <<END or die $!;
3837 Version: $fakeversion
3841 my $dscaddfile=sub {
3844 my $md = new Digest::MD5;
3846 my $fh = new IO::File $b, '<' or die "$b $!";
3851 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3854 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3856 my @files=qw(debian/source/format debian/rules
3857 debian/control debian/changelog);
3858 foreach my $maybe (qw(debian/patches debian/source/options
3859 debian/tests/control)) {
3860 next unless stat_exists "../../../$maybe";
3861 push @files, $maybe;
3864 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3865 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3867 $dscaddfile->($debtar);
3868 close $fakedsc or die $!;
3871 sub quilt_check_splitbrain_cache ($$) {
3872 my ($headref, $upstreamversion) = @_;
3873 # Called only if we are in (potentially) split brain mode.
3875 # Computes the cache key and looks in the cache.
3876 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3878 my $splitbrain_cachekey;
3881 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3882 # we look in the reflog of dgit-intern/quilt-cache
3883 # we look for an entry whose message is the key for the cache lookup
3884 my @cachekey = (qw(dgit), $our_version);
3885 push @cachekey, $upstreamversion;
3886 push @cachekey, $quilt_mode;
3887 push @cachekey, $headref;
3889 push @cachekey, hashfile('fake.dsc');
3891 my $srcshash = Digest::SHA->new(256);
3892 my %sfs = ( %INC, '$0(dgit)' => $0 );
3893 foreach my $sfk (sort keys %sfs) {
3894 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3895 $srcshash->add($sfk," ");
3896 $srcshash->add(hashfile($sfs{$sfk}));
3897 $srcshash->add("\n");
3899 push @cachekey, $srcshash->hexdigest();
3900 $splitbrain_cachekey = "@cachekey";
3902 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3904 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3905 debugcmd "|(probably)",@cmd;
3906 my $child = open GC, "-|"; defined $child or die $!;
3908 chdir '../../..' or die $!;
3909 if (!stat ".git/logs/refs/$splitbraincache") {
3910 $! == ENOENT or die $!;
3911 printdebug ">(no reflog)\n";
3918 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3919 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3922 quilt_fixup_mkwork($headref);
3923 if ($cachehit ne $headref) {
3924 progress "dgit view: found cached (commit id $cachehit)";
3925 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3927 return ($cachehit, $splitbrain_cachekey);
3929 progress "dgit view: found cached, no changes required";
3930 return ($headref, $splitbrain_cachekey);
3932 die $! if GC->error;
3933 failedcmd unless close GC;
3935 printdebug "splitbrain cache miss\n";
3936 return (undef, $splitbrain_cachekey);
3939 sub quilt_fixup_multipatch ($$$) {
3940 my ($clogp, $headref, $upstreamversion) = @_;
3942 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3945 # - honour any existing .pc in case it has any strangeness
3946 # - determine the git commit corresponding to the tip of
3947 # the patch stack (if there is one)
3948 # - if there is such a git commit, convert each subsequent
3949 # git commit into a quilt patch with dpkg-source --commit
3950 # - otherwise convert all the differences in the tree into
3951 # a single git commit
3955 # Our git tree doesn't necessarily contain .pc. (Some versions of
3956 # dgit would include the .pc in the git tree.) If there isn't
3957 # one, we need to generate one by unpacking the patches that we
3960 # We first look for a .pc in the git tree. If there is one, we
3961 # will use it. (This is not the normal case.)
3963 # Otherwise need to regenerate .pc so that dpkg-source --commit
3964 # can work. We do this as follows:
3965 # 1. Collect all relevant .orig from parent directory
3966 # 2. Generate a debian.tar.gz out of
3967 # debian/{patches,rules,source/format,source/options}
3968 # 3. Generate a fake .dsc containing just these fields:
3969 # Format Source Version Files
3970 # 4. Extract the fake .dsc
3971 # Now the fake .dsc has a .pc directory.
3972 # (In fact we do this in every case, because in future we will
3973 # want to search for a good base commit for generating patches.)
3975 # Then we can actually do the dpkg-source --commit
3976 # 1. Make a new working tree with the same object
3977 # store as our main tree and check out the main
3979 # 2. Copy .pc from the fake's extraction, if necessary
3980 # 3. Run dpkg-source --commit
3981 # 4. If the result has changes to debian/, then
3982 # - git-add them them
3983 # - git-add .pc if we had a .pc in-tree
3985 # 5. If we had a .pc in-tree, delete it, and git-commit
3986 # 6. Back in the main tree, fast forward to the new HEAD
3988 # Another situation we may have to cope with is gbp-style
3989 # patches-unapplied trees.
3991 # We would want to detect these, so we know to escape into
3992 # quilt_fixup_gbp. However, this is in general not possible.
3993 # Consider a package with a one patch which the dgit user reverts
3994 # (with git-revert or the moral equivalent).
3996 # That is indistinguishable in contents from a patches-unapplied
3997 # tree. And looking at the history to distinguish them is not
3998 # useful because the user might have made a confusing-looking git
3999 # history structure (which ought to produce an error if dgit can't
4000 # cope, not a silent reintroduction of an unwanted patch).
4002 # So gbp users will have to pass an option. But we can usually
4003 # detect their failure to do so: if the tree is not a clean
4004 # patches-applied tree, quilt linearisation fails, but the tree
4005 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4006 # they want --quilt=unapplied.
4008 # To help detect this, when we are extracting the fake dsc, we
4009 # first extract it with --skip-patches, and then apply the patches
4010 # afterwards with dpkg-source --before-build. That lets us save a
4011 # tree object corresponding to .origs.
4013 my $splitbrain_cachekey;
4015 quilt_make_fake_dsc($upstreamversion);
4017 if (quiltmode_splitbrain()) {
4019 ($cachehit, $splitbrain_cachekey) =
4020 quilt_check_splitbrain_cache($headref, $upstreamversion);
4021 return if $cachehit;
4025 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4027 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4028 rename $fakexdir, "fake" or die "$fakexdir $!";
4032 remove_stray_gits();
4033 mktree_in_ud_here();
4037 runcmd @git, qw(add -Af .);
4038 my $unapplied=git_write_tree();
4039 printdebug "fake orig tree object $unapplied\n";
4044 'exec dpkg-source --before-build . >/dev/null';
4048 quilt_fixup_mkwork($headref);
4051 if (stat_exists ".pc") {
4053 progress "Tree already contains .pc - will use it then delete it.";
4056 rename '../fake/.pc','.pc' or die $!;
4059 changedir '../fake';
4061 runcmd @git, qw(add -Af .);
4062 my $oldtiptree=git_write_tree();
4063 printdebug "fake o+d/p tree object $unapplied\n";
4064 changedir '../work';
4067 # We calculate some guesswork now about what kind of tree this might
4068 # be. This is mostly for error reporting.
4073 # O = orig, without patches applied
4074 # A = "applied", ie orig with H's debian/patches applied
4075 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4076 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4077 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4081 foreach my $b (qw(01 02)) {
4082 foreach my $v (qw(H2O O2A H2A)) {
4083 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4086 printdebug "differences \@dl @dl.\n";
4089 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4090 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4091 $dl[0], $dl[1], $dl[3], $dl[4],
4095 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4096 push @failsuggestion, "This might be a patches-unapplied branch.";
4097 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4098 push @failsuggestion, "This might be a patches-applied branch.";
4100 push @failsuggestion, "Maybe you need to specify one of".
4101 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4103 if (quiltmode_splitbrain()) {
4104 quiltify_splitbrain($clogp, $unapplied, $headref,
4105 $diffbits, \%editedignores,
4106 $splitbrain_cachekey);
4110 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4111 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4113 if (!open P, '>>', ".pc/applied-patches") {
4114 $!==&ENOENT or die $!;
4119 commit_quilty_patch();
4121 if ($mustdeletepc) {
4122 quilt_fixup_delete_pc();
4126 sub quilt_fixup_editor () {
4127 my $descfn = $ENV{$fakeeditorenv};
4128 my $editing = $ARGV[$#ARGV];
4129 open I1, '<', $descfn or die "$descfn: $!";
4130 open I2, '<', $editing or die "$editing: $!";
4131 unlink $editing or die "$editing: $!";
4132 open O, '>', $editing or die "$editing: $!";
4133 while (<I1>) { print O or die $!; } I1->error and die $!;
4136 $copying ||= m/^\-\-\- /;
4137 next unless $copying;
4140 I2->error and die $!;
4145 sub maybe_apply_patches_dirtily () {
4146 return unless $quilt_mode =~ m/gbp|unapplied/;
4147 print STDERR <<END or die $!;
4149 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4150 dgit: Have to apply the patches - making the tree dirty.
4151 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4154 $patches_applied_dirtily = 01;
4155 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4156 runcmd qw(dpkg-source --before-build .);
4159 sub maybe_unapply_patches_again () {
4160 progress "dgit: Unapplying patches again to tidy up the tree."
4161 if $patches_applied_dirtily;
4162 runcmd qw(dpkg-source --after-build .)
4163 if $patches_applied_dirtily & 01;
4165 if $patches_applied_dirtily & 02;
4166 $patches_applied_dirtily = 0;
4169 #----- other building -----
4171 our $clean_using_builder;
4172 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4173 # clean the tree before building (perhaps invoked indirectly by
4174 # whatever we are using to run the build), rather than separately
4175 # and explicitly by us.
4178 return if $clean_using_builder;
4179 if ($cleanmode eq 'dpkg-source') {
4180 maybe_apply_patches_dirtily();
4181 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4182 } elsif ($cleanmode eq 'dpkg-source-d') {
4183 maybe_apply_patches_dirtily();
4184 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4185 } elsif ($cleanmode eq 'git') {
4186 runcmd_ordryrun_local @git, qw(clean -xdf);
4187 } elsif ($cleanmode eq 'git-ff') {
4188 runcmd_ordryrun_local @git, qw(clean -xdff);
4189 } elsif ($cleanmode eq 'check') {
4190 my $leftovers = cmdoutput @git, qw(clean -xdn);
4191 if (length $leftovers) {
4192 print STDERR $leftovers, "\n" or die $!;
4193 fail "tree contains uncommitted files and --clean=check specified";
4195 } elsif ($cleanmode eq 'none') {
4202 badusage "clean takes no additional arguments" if @ARGV;
4205 maybe_unapply_patches_again();
4210 badusage "-p is not allowed when building" if defined $package;
4213 my $clogp = parsechangelog();
4214 $isuite = getfield $clogp, 'Distribution';
4215 $package = getfield $clogp, 'Source';
4216 $version = getfield $clogp, 'Version';
4217 build_maybe_quilt_fixup();
4219 my $pat = changespat $version;
4220 foreach my $f (glob "$buildproductsdir/$pat") {
4222 unlink $f or fail "remove old changes file $f: $!";
4224 progress "would remove $f";
4230 sub changesopts_initial () {
4231 my @opts =@changesopts[1..$#changesopts];
4234 sub changesopts_version () {
4235 if (!defined $changes_since_version) {
4236 my @vsns = archive_query('archive_query');
4237 my @quirk = access_quirk();
4238 if ($quirk[0] eq 'backports') {
4239 local $isuite = $quirk[2];
4241 canonicalise_suite();
4242 push @vsns, archive_query('archive_query');
4245 @vsns = map { $_->[0] } @vsns;
4246 @vsns = sort { -version_compare($a, $b) } @vsns;
4247 $changes_since_version = $vsns[0];
4248 progress "changelog will contain changes since $vsns[0]";
4250 $changes_since_version = '_';
4251 progress "package seems new, not specifying -v<version>";
4254 if ($changes_since_version ne '_') {
4255 return ("-v$changes_since_version");
4261 sub changesopts () {
4262 return (changesopts_initial(), changesopts_version());
4265 sub massage_dbp_args ($;$) {
4266 my ($cmd,$xargs) = @_;
4269 # - if we're going to split the source build out so we can
4270 # do strange things to it, massage the arguments to dpkg-buildpackage
4271 # so that the main build doessn't build source (or add an argument
4272 # to stop it building source by default).
4274 # - add -nc to stop dpkg-source cleaning the source tree,
4275 # unless we're not doing a split build and want dpkg-source
4276 # as cleanmode, in which case we can do nothing
4279 # 0 - source will NOT need to be built separately by caller
4280 # +1 - source will need to be built separately by caller
4281 # +2 - source will need to be built separately by caller AND
4282 # dpkg-buildpackage should not in fact be run at all!
4283 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4284 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4285 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4286 $clean_using_builder = 1;
4289 # -nc has the side effect of specifying -b if nothing else specified
4290 # and some combinations of -S, -b, et al, are errors, rather than
4291 # later simply overriding earlie. So we need to:
4292 # - search the command line for these options
4293 # - pick the last one
4294 # - perhaps add our own as a default
4295 # - perhaps adjust it to the corresponding non-source-building version
4297 foreach my $l ($cmd, $xargs) {
4299 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4302 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4304 if ($need_split_build_invocation) {
4305 printdebug "massage split $dmode.\n";
4306 $r = $dmode =~ m/[S]/ ? +2 :
4307 $dmode =~ y/gGF/ABb/ ? +1 :
4308 $dmode =~ m/[ABb]/ ? 0 :
4311 printdebug "massage done $r $dmode.\n";
4313 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4318 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4319 my $wantsrc = massage_dbp_args \@dbp;
4326 push @dbp, changesopts_version();
4327 maybe_apply_patches_dirtily();
4328 runcmd_ordryrun_local @dbp;
4330 maybe_unapply_patches_again();
4331 printdone "build successful\n";
4335 my @dbp = @dpkgbuildpackage;
4337 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4340 if (length executable_on_path('git-buildpackage')) {
4341 @cmd = qw(git-buildpackage);
4343 @cmd = qw(gbp buildpackage);
4345 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4350 if (!$clean_using_builder) {
4351 push @cmd, '--git-cleaner=true';
4355 maybe_unapply_patches_again();
4357 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4358 canonicalise_suite();
4359 push @cmd, "--git-debian-branch=".lbranch();
4361 push @cmd, changesopts();
4362 runcmd_ordryrun_local @cmd, @ARGV;
4364 printdone "build successful\n";
4366 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4369 my $our_cleanmode = $cleanmode;
4370 if ($need_split_build_invocation) {
4371 # Pretend that clean is being done some other way. This
4372 # forces us not to try to use dpkg-buildpackage to clean and
4373 # build source all in one go; and instead we run dpkg-source
4374 # (and build_prep() will do the clean since $clean_using_builder
4376 $our_cleanmode = 'ELSEWHERE';
4378 if ($our_cleanmode =~ m/^dpkg-source/) {
4379 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4380 $clean_using_builder = 1;
4383 $sourcechanges = changespat $version,'source';
4385 unlink "../$sourcechanges" or $!==ENOENT
4386 or fail "remove $sourcechanges: $!";
4388 $dscfn = dscfn($version);
4389 if ($our_cleanmode eq 'dpkg-source') {
4390 maybe_apply_patches_dirtily();
4391 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4393 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4394 maybe_apply_patches_dirtily();
4395 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4398 my @cmd = (@dpkgsource, qw(-b --));
4401 runcmd_ordryrun_local @cmd, "work";
4402 my @udfiles = <${package}_*>;
4403 changedir "../../..";
4404 foreach my $f (@udfiles) {
4405 printdebug "source copy, found $f\n";
4408 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4409 $f eq srcfn($version, $&));
4410 printdebug "source copy, found $f - renaming\n";
4411 rename "$ud/$f", "../$f" or $!==ENOENT
4412 or fail "put in place new source file ($f): $!";
4415 my $pwd = must_getcwd();
4416 my $leafdir = basename $pwd;
4418 runcmd_ordryrun_local @cmd, $leafdir;
4421 runcmd_ordryrun_local qw(sh -ec),
4422 'exec >$1; shift; exec "$@"','x',
4423 "../$sourcechanges",
4424 @dpkggenchanges, qw(-S), changesopts();
4428 sub cmd_build_source {
4429 badusage "build-source takes no additional arguments" if @ARGV;
4431 maybe_unapply_patches_again();
4432 printdone "source built, results in $dscfn and $sourcechanges";
4437 my $pat = changespat $version;
4439 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4440 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4441 fail "changes files other than source matching $pat".
4442 " already present (@unwanted);".
4443 " building would result in ambiguity about the intended results"
4446 my $wasdir = must_getcwd();
4449 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4450 stat_exists $sourcechanges
4451 or fail "$sourcechanges (in parent directory): $!";
4453 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4454 my @changesfiles = glob $pat;
4455 @changesfiles = sort {
4456 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4459 fail "wrong number of different changes files (@changesfiles)"
4460 unless @changesfiles==2;
4461 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4462 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4463 fail "$l found in binaries changes file $binchanges"
4466 runcmd_ordryrun_local @mergechanges, @changesfiles;
4467 my $multichanges = changespat $version,'multi';
4469 stat_exists $multichanges or fail "$multichanges: $!";
4470 foreach my $cf (glob $pat) {
4471 next if $cf eq $multichanges;
4472 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4476 maybe_unapply_patches_again();
4477 printdone "build successful, results in $multichanges\n" or die $!;
4480 sub cmd_quilt_fixup {
4481 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4482 my $clogp = parsechangelog();
4483 $version = getfield $clogp, 'Version';
4484 $package = getfield $clogp, 'Source';
4487 build_maybe_quilt_fixup();
4490 sub cmd_archive_api_query {
4491 badusage "need only 1 subpath argument" unless @ARGV==1;
4492 my ($subpath) = @ARGV;
4493 my @cmd = archive_api_query_cmd($subpath);
4495 exec @cmd or fail "exec curl: $!\n";
4498 sub cmd_clone_dgit_repos_server {
4499 badusage "need destination argument" unless @ARGV==1;
4500 my ($destdir) = @ARGV;
4501 $package = '_dgit-repos-server';
4502 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4504 exec @cmd or fail "exec git clone: $!\n";
4507 sub cmd_setup_mergechangelogs {
4508 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4509 setup_mergechangelogs(1);
4512 sub cmd_setup_useremail {
4513 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4517 sub cmd_setup_new_tree {
4518 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4522 #---------- argument parsing and main program ----------
4525 print "dgit version $our_version\n" or die $!;
4529 our (%valopts_long, %valopts_short);
4532 sub defvalopt ($$$$) {
4533 my ($long,$short,$val_re,$how) = @_;
4534 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4535 $valopts_long{$long} = $oi;
4536 $valopts_short{$short} = $oi;
4537 # $how subref should:
4538 # do whatever assignemnt or thing it likes with $_[0]
4539 # if the option should not be passed on to remote, @rvalopts=()
4540 # or $how can be a scalar ref, meaning simply assign the value
4543 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4544 defvalopt '--distro', '-d', '.+', \$idistro;
4545 defvalopt '', '-k', '.+', \$keyid;
4546 defvalopt '--existing-package','', '.*', \$existing_package;
4547 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4548 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4549 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4551 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4553 defvalopt '', '-C', '.+', sub {
4554 ($changesfile) = (@_);
4555 if ($changesfile =~ s#^(.*)/##) {
4556 $buildproductsdir = $1;
4560 defvalopt '--initiator-tempdir','','.*', sub {
4561 ($initiator_tempdir) = (@_);
4562 $initiator_tempdir =~ m#^/# or
4563 badusage "--initiator-tempdir must be used specify an".
4564 " absolute, not relative, directory."
4570 if (defined $ENV{'DGIT_SSH'}) {
4571 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4572 } elsif (defined $ENV{'GIT_SSH'}) {
4573 @ssh = ($ENV{'GIT_SSH'});
4581 if (!defined $val) {
4582 badusage "$what needs a value" unless @ARGV;
4584 push @rvalopts, $val;
4586 badusage "bad value \`$val' for $what" unless
4587 $val =~ m/^$oi->{Re}$(?!\n)/s;
4588 my $how = $oi->{How};
4589 if (ref($how) eq 'SCALAR') {
4594 push @ropts, @rvalopts;
4598 last unless $ARGV[0] =~ m/^-/;
4602 if (m/^--dry-run$/) {
4605 } elsif (m/^--damp-run$/) {
4608 } elsif (m/^--no-sign$/) {
4611 } elsif (m/^--help$/) {
4613 } elsif (m/^--version$/) {
4615 } elsif (m/^--new$/) {
4618 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4619 ($om = $opts_opt_map{$1}) &&
4623 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4624 !$opts_opt_cmdonly{$1} &&
4625 ($om = $opts_opt_map{$1})) {
4628 } elsif (m/^--ignore-dirty$/s) {
4631 } elsif (m/^--no-quilt-fixup$/s) {
4633 $quilt_mode = 'nocheck';
4634 } elsif (m/^--no-rm-on-error$/s) {
4637 } elsif (m/^--overwrite$/s) {
4639 $overwrite_version = '';
4640 } elsif (m/^--overwrite=(.+)$/s) {
4642 $overwrite_version = $1;
4643 } elsif (m/^--(no-)?rm-old-changes$/s) {
4646 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4648 push @deliberatelies, $&;
4649 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4650 # undocumented, for testing
4652 $tagformat_want = [ $1, 'command line', 1 ];
4653 # 1 menas overrides distro configuration
4654 } elsif (m/^--always-split-source-build$/s) {
4655 # undocumented, for testing
4657 $need_split_build_invocation = 1;
4658 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4659 $val = $2 ? $' : undef; #';
4660 $valopt->($oi->{Long});
4662 badusage "unknown long option \`$_'";
4669 } elsif (s/^-L/-/) {
4672 } elsif (s/^-h/-/) {
4674 } elsif (s/^-D/-/) {
4678 } elsif (s/^-N/-/) {
4683 push @changesopts, $_;
4685 } elsif (s/^-wn$//s) {
4687 $cleanmode = 'none';
4688 } elsif (s/^-wg$//s) {
4691 } elsif (s/^-wgf$//s) {
4693 $cleanmode = 'git-ff';
4694 } elsif (s/^-wd$//s) {
4696 $cleanmode = 'dpkg-source';
4697 } elsif (s/^-wdd$//s) {
4699 $cleanmode = 'dpkg-source-d';
4700 } elsif (s/^-wc$//s) {
4702 $cleanmode = 'check';
4703 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4705 $val = undef unless length $val;
4706 $valopt->($oi->{Short});
4709 badusage "unknown short option \`$_'";
4716 sub finalise_opts_opts () {
4717 foreach my $k (keys %opts_opt_map) {
4718 my $om = $opts_opt_map{$k};
4720 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4722 badcfg "cannot set command for $k"
4723 unless length $om->[0];
4727 foreach my $c (access_cfg_cfgs("opts-$k")) {
4728 my $vl = $gitcfg{$c};
4729 printdebug "CL $c ",
4730 ($vl ? join " ", map { shellquote } @$vl : ""),
4731 "\n" if $debuglevel >= 4;
4733 badcfg "cannot configure options for $k"
4734 if $opts_opt_cmdonly{$k};
4735 my $insertpos = $opts_cfg_insertpos{$k};
4736 @$om = ( @$om[0..$insertpos-1],
4738 @$om[$insertpos..$#$om] );
4743 if ($ENV{$fakeeditorenv}) {
4745 quilt_fixup_editor();
4751 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4752 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4753 if $dryrun_level == 1;
4755 print STDERR $helpmsg or die $!;
4758 my $cmd = shift @ARGV;
4761 if (!defined $rmchanges) {
4762 local $access_forpush;
4763 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4766 if (!defined $quilt_mode) {
4767 local $access_forpush;
4768 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4769 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4771 $quilt_mode =~ m/^($quilt_modes_re)$/
4772 or badcfg "unknown quilt-mode \`$quilt_mode'";
4776 $need_split_build_invocation ||= quiltmode_splitbrain();
4778 if (!defined $cleanmode) {
4779 local $access_forpush;
4780 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4781 $cleanmode //= 'dpkg-source';
4783 badcfg "unknown clean-mode \`$cleanmode'" unless
4784 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4787 my $fn = ${*::}{"cmd_$cmd"};
4788 $fn or badusage "unknown operation $cmd";