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 my $child = open2($out, $in, @cmd) or die $!;
1461 print $in $text or die $!;
1462 close $in or die $!;
1464 $h =~ m/^\w+$/ or die;
1466 printdebug "=> $h\n";
1469 waitpid $child, 0 == $child or die "$child $!";
1470 $? and failedcmd @cmd;
1474 sub clogp_authline ($) {
1476 my $author = getfield $clogp, 'Maintainer';
1477 $author =~ s#,.*##ms;
1478 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1479 my $authline = "$author $date";
1480 $authline =~ m/$git_authline_re/o or
1481 fail "unexpected commit author line format \`$authline'".
1482 " (was generated from changelog Maintainer field)";
1483 return ($1,$2,$3) if wantarray;
1487 sub vendor_patches_distro ($$) {
1488 my ($checkdistro, $what) = @_;
1489 return unless defined $checkdistro;
1491 my $series = "debian/patches/\L$checkdistro\E.series";
1492 printdebug "checking for vendor-specific $series ($what)\n";
1494 if (!open SERIES, "<", $series) {
1495 die "$series $!" unless $!==ENOENT;
1504 Unfortunately, this source package uses a feature of dpkg-source where
1505 the same source package unpacks to different source code on different
1506 distros. dgit cannot safely operate on such packages on affected
1507 distros, because the meaning of source packages is not stable.
1509 Please ask the distro/maintainer to remove the distro-specific series
1510 files and use a different technique (if necessary, uploading actually
1511 different packages, if different distros are supposed to have
1515 fail "Found active distro-specific series file for".
1516 " $checkdistro ($what): $series, cannot continue";
1518 die "$series $!" if SERIES->error;
1522 sub check_for_vendor_patches () {
1523 # This dpkg-source feature doesn't seem to be documented anywhere!
1524 # But it can be found in the changelog (reformatted):
1526 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1527 # Author: Raphael Hertzog <hertzog@debian.org>
1528 # Date: Sun Oct 3 09:36:48 2010 +0200
1530 # dpkg-source: correctly create .pc/.quilt_series with alternate
1533 # If you have debian/patches/ubuntu.series and you were
1534 # unpacking the source package on ubuntu, quilt was still
1535 # directed to debian/patches/series instead of
1536 # debian/patches/ubuntu.series.
1538 # debian/changelog | 3 +++
1539 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1540 # 2 files changed, 6 insertions(+), 1 deletion(-)
1543 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1544 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1545 "Dpkg::Vendor \`current vendor'");
1546 vendor_patches_distro(access_basedistro(),
1547 "distro being accessed");
1550 sub generate_commits_from_dsc () {
1551 # See big comment in fetch_from_archive, below.
1555 my @dfi = dsc_files_info();
1556 foreach my $fi (@dfi) {
1557 my $f = $fi->{Filename};
1558 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1560 link_ltarget "../../../$f", $f
1564 complete_file_from_dsc('.', $fi)
1567 if (is_orig_file_in_dsc($f, \@dfi)) {
1568 link $f, "../../../../$f"
1574 my $dscfn = "$package.dsc";
1576 open D, ">", $dscfn or die "$dscfn: $!";
1577 print D $dscdata or die "$dscfn: $!";
1578 close D or die "$dscfn: $!";
1579 my @cmd = qw(dpkg-source);
1580 push @cmd, '--no-check' if $dsc_checked;
1581 push @cmd, qw(-x --), $dscfn;
1584 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1585 check_for_vendor_patches() if madformat($dsc->{format});
1586 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1587 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1588 my $authline = clogp_authline $clogp;
1589 my $changes = getfield $clogp, 'Changes';
1590 open C, ">../commit.tmp" or die $!;
1591 print C <<END or die $!;
1598 # imported from the archive
1601 my $rawimport_hash = make_commit qw(../commit.tmp);
1602 my $cversion = getfield $clogp, 'Version';
1603 progress "synthesised git commit from .dsc $cversion";
1605 my $rawimport_mergeinput = {
1606 Commit => $rawimport_hash,
1607 Info => "Import of source package",
1609 my @output = ($rawimport_mergeinput);
1611 if ($lastpush_mergeinput) {
1612 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1613 my $oversion = getfield $oldclogp, 'Version';
1615 version_compare($oversion, $cversion);
1617 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1618 { Message => <<END, ReverseParents => 1 });
1619 Record $package ($cversion) in archive suite $csuite
1621 } elsif ($vcmp > 0) {
1622 print STDERR <<END or die $!;
1624 Version actually in archive: $cversion (older)
1625 Last version pushed with dgit: $oversion (newer or same)
1628 @output = $lastpush_mergeinput;
1630 # Same version. Use what's in the server git branch,
1631 # discarding our own import. (This could happen if the
1632 # server automatically imports all packages into git.)
1633 @output = $lastpush_mergeinput;
1636 changedir '../../../..';
1641 sub complete_file_from_dsc ($$) {
1642 our ($dstdir, $fi) = @_;
1643 # Ensures that we have, in $dir, the file $fi, with the correct
1644 # contents. (Downloading it from alongside $dscurl if necessary.)
1646 my $f = $fi->{Filename};
1647 my $tf = "$dstdir/$f";
1650 if (stat_exists $tf) {
1651 progress "using existing $f";
1654 $furl =~ s{/[^/]+$}{};
1656 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1657 die "$f ?" if $f =~ m#/#;
1658 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1659 return 0 if !act_local();
1663 open F, "<", "$tf" or die "$tf: $!";
1664 $fi->{Digester}->reset();
1665 $fi->{Digester}->addfile(*F);
1666 F->error and die $!;
1667 my $got = $fi->{Digester}->hexdigest();
1668 $got eq $fi->{Hash} or
1669 fail "file $f has hash $got but .dsc".
1670 " demands hash $fi->{Hash} ".
1671 ($downloaded ? "(got wrong file from archive!)"
1672 : "(perhaps you should delete this file?)");
1677 sub ensure_we_have_orig () {
1678 my @dfi = dsc_files_info();
1679 foreach my $fi (@dfi) {
1680 my $f = $fi->{Filename};
1681 next unless is_orig_file_in_dsc($f, \@dfi);
1682 complete_file_from_dsc('..', $fi)
1687 sub git_fetch_us () {
1688 # Want to fetch only what we are going to use, unless
1689 # deliberately-not-ff, in which case we must fetch everything.
1691 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1693 (quiltmode_splitbrain
1694 ? (map { $_->('*',access_basedistro) }
1695 \&debiantag_new, \&debiantag_maintview)
1696 : debiantags('*',access_basedistro));
1697 push @specs, server_branch($csuite);
1698 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1700 # This is rather miserable:
1701 # When git-fetch --prune is passed a fetchspec ending with a *,
1702 # it does a plausible thing. If there is no * then:
1703 # - it matches subpaths too, even if the supplied refspec
1704 # starts refs, and behaves completely madly if the source
1705 # has refs/refs/something. (See, for example, Debian #NNNN.)
1706 # - if there is no matching remote ref, it bombs out the whole
1708 # We want to fetch a fixed ref, and we don't know in advance
1709 # if it exists, so this is not suitable.
1711 # Our workaround is to use git-ls-remote. git-ls-remote has its
1712 # own qairks. Notably, it has the absurd multi-tail-matching
1713 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1714 # refs/refs/foo etc.
1716 # Also, we want an idempotent snapshot, but we have to make two
1717 # calls to the remote: one to git-ls-remote and to git-fetch. The
1718 # solution is use git-ls-remote to obtain a target state, and
1719 # git-fetch to try to generate it. If we don't manage to generate
1720 # the target state, we try again.
1722 my $specre = join '|', map {
1728 printdebug "git_fetch_us specre=$specre\n";
1729 my $wanted_rref = sub {
1731 return m/^(?:$specre)$/o;
1734 my $fetch_iteration = 0;
1737 if (++$fetch_iteration > 10) {
1738 fail "too many iterations trying to get sane fetch!";
1741 my @look = map { "refs/$_" } @specs;
1742 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1746 open GITLS, "-|", @lcmd or die $!;
1748 printdebug "=> ", $_;
1749 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1750 my ($objid,$rrefname) = ($1,$2);
1751 if (!$wanted_rref->($rrefname)) {
1753 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1757 $wantr{$rrefname} = $objid;
1760 close GITLS or failedcmd @lcmd;
1762 # OK, now %want is exactly what we want for refs in @specs
1764 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1765 "+refs/$_:".lrfetchrefs."/$_";
1768 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1769 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1772 %lrfetchrefs_f = ();
1775 git_for_each_ref(lrfetchrefs, sub {
1776 my ($objid,$objtype,$lrefname,$reftail) = @_;
1777 $lrfetchrefs_f{$lrefname} = $objid;
1778 $objgot{$objid} = 1;
1781 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1782 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1783 if (!exists $wantr{$rrefname}) {
1784 if ($wanted_rref->($rrefname)) {
1786 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1790 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1793 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1794 delete $lrfetchrefs_f{$lrefname};
1798 foreach my $rrefname (sort keys %wantr) {
1799 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1800 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1801 my $want = $wantr{$rrefname};
1802 next if $got eq $want;
1803 if (!defined $objgot{$want}) {
1805 warning: git-ls-remote suggests we want $lrefname
1806 warning: and it should refer to $want
1807 warning: but git-fetch didn't fetch that object to any relevant ref.
1808 warning: This may be due to a race with someone updating the server.
1809 warning: Will try again...
1811 next FETCH_ITERATION;
1814 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1816 runcmd_ordryrun_local @git, qw(update-ref -m),
1817 "dgit fetch git-fetch fixup", $lrefname, $want;
1818 $lrfetchrefs_f{$lrefname} = $want;
1822 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1823 Dumper(\%lrfetchrefs_f);
1826 my @tagpats = debiantags('*',access_basedistro);
1828 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1829 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1830 printdebug "currently $fullrefname=$objid\n";
1831 $here{$fullrefname} = $objid;
1833 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1834 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1835 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1836 printdebug "offered $lref=$objid\n";
1837 if (!defined $here{$lref}) {
1838 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1839 runcmd_ordryrun_local @upd;
1840 lrfetchref_used $fullrefname;
1841 } elsif ($here{$lref} eq $objid) {
1842 lrfetchref_used $fullrefname;
1845 "Not updateting $lref from $here{$lref} to $objid.\n";
1850 sub mergeinfo_getclogp ($) {
1851 # Ensures thit $mi->{Clogp} exists and returns it
1853 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1856 sub mergeinfo_version ($) {
1857 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1860 sub fetch_from_archive () {
1861 # Ensures that lrref() is what is actually in the archive, one way
1862 # or another, according to us - ie this client's
1863 # appropritaely-updated archive view. Also returns the commit id.
1864 # If there is nothing in the archive, leaves lrref alone and
1865 # returns undef. git_fetch_us must have already been called.
1869 foreach my $field (@ourdscfield) {
1870 $dsc_hash = $dsc->{$field};
1871 last if defined $dsc_hash;
1873 if (defined $dsc_hash) {
1874 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1876 progress "last upload to archive specified git hash";
1878 progress "last upload to archive has NO git hash";
1881 progress "no version available from the archive";
1884 # If the archive's .dsc has a Dgit field, there are three
1885 # relevant git commitids we need to choose between and/or merge
1887 # 1. $dsc_hash: the Dgit field from the archive
1888 # 2. $lastpush_hash: the suite branch on the dgit git server
1889 # 3. $lastfetch_hash: our local tracking brach for the suite
1891 # These may all be distinct and need not be in any fast forward
1894 # If the dsc was pushed to this suite, then the server suite
1895 # branch will have been updated; but it might have been pushed to
1896 # a different suite and copied by the archive. Conversely a more
1897 # recent version may have been pushed with dgit but not appeared
1898 # in the archive (yet).
1900 # $lastfetch_hash may be awkward because archive imports
1901 # (particularly, imports of Dgit-less .dscs) are performed only as
1902 # needed on individual clients, so different clients may perform a
1903 # different subset of them - and these imports are only made
1904 # public during push. So $lastfetch_hash may represent a set of
1905 # imports different to a subsequent upload by a different dgit
1908 # Our approach is as follows:
1910 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1911 # descendant of $dsc_hash, then it was pushed by a dgit user who
1912 # had based their work on $dsc_hash, so we should prefer it.
1913 # Otherwise, $dsc_hash was installed into this suite in the
1914 # archive other than by a dgit push, and (necessarily) after the
1915 # last dgit push into that suite (since a dgit push would have
1916 # been descended from the dgit server git branch); thus, in that
1917 # case, we prefer the archive's version (and produce a
1918 # pseudo-merge to overwrite the dgit server git branch).
1920 # (If there is no Dgit field in the archive's .dsc then
1921 # generate_commit_from_dsc uses the version numbers to decide
1922 # whether the suite branch or the archive is newer. If the suite
1923 # branch is newer it ignores the archive's .dsc; otherwise it
1924 # generates an import of the .dsc, and produces a pseudo-merge to
1925 # overwrite the suite branch with the archive contents.)
1927 # The outcome of that part of the algorithm is the `public view',
1928 # and is same for all dgit clients: it does not depend on any
1929 # unpublished history in the local tracking branch.
1931 # As between the public view and the local tracking branch: The
1932 # local tracking branch is only updated by dgit fetch, and
1933 # whenever dgit fetch runs it includes the public view in the
1934 # local tracking branch. Therefore if the public view is not
1935 # descended from the local tracking branch, the local tracking
1936 # branch must contain history which was imported from the archive
1937 # but never pushed; and, its tip is now out of date. So, we make
1938 # a pseudo-merge to overwrite the old imports and stitch the old
1941 # Finally: we do not necessarily reify the public view (as
1942 # described above). This is so that we do not end up stacking two
1943 # pseudo-merges. So what we actually do is figure out the inputs
1944 # to any public view pseudo-merge and put them in @mergeinputs.
1947 # $mergeinputs[]{Commit}
1948 # $mergeinputs[]{Info}
1949 # $mergeinputs[0] is the one whose tree we use
1950 # @mergeinputs is in the order we use in the actual commit)
1953 # $mergeinputs[]{Message} is a commit message to use
1954 # $mergeinputs[]{ReverseParents} if def specifies that parent
1955 # list should be in opposite order
1956 # Such an entry has no Commit or Info. It applies only when found
1957 # in the last entry. (This ugliness is to support making
1958 # identical imports to previous dgit versions.)
1960 my $lastpush_hash = git_get_ref(lrfetchref());
1961 printdebug "previous reference hash=$lastpush_hash\n";
1962 $lastpush_mergeinput = $lastpush_hash && {
1963 Commit => $lastpush_hash,
1964 Info => "dgit suite branch on dgit git server",
1967 my $lastfetch_hash = git_get_ref(lrref());
1968 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1969 my $lastfetch_mergeinput = $lastfetch_hash && {
1970 Commit => $lastfetch_hash,
1971 Info => "dgit client's archive history view",
1974 my $dsc_mergeinput = $dsc_hash && {
1975 Commit => $dsc_hash,
1976 Info => "Dgit field in .dsc from archive",
1980 my $del_lrfetchrefs = sub {
1983 printdebug "del_lrfetchrefs...\n";
1984 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1985 my $objid = $lrfetchrefs_d{$fullrefname};
1986 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1988 $gur ||= new IO::Handle;
1989 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1991 printf $gur "delete %s %s\n", $fullrefname, $objid;
1994 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1998 if (defined $dsc_hash) {
1999 fail "missing remote git history even though dsc has hash -".
2000 " could not find ref ".rref()." at ".access_giturl()
2001 unless $lastpush_hash;
2002 ensure_we_have_orig();
2003 if ($dsc_hash eq $lastpush_hash) {
2004 @mergeinputs = $dsc_mergeinput
2005 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2006 print STDERR <<END or die $!;
2008 Git commit in archive is behind the last version allegedly pushed/uploaded.
2009 Commit referred to by archive: $dsc_hash
2010 Last version pushed with dgit: $lastpush_hash
2013 @mergeinputs = ($lastpush_mergeinput);
2015 # Archive has .dsc which is not a descendant of the last dgit
2016 # push. This can happen if the archive moves .dscs about.
2017 # Just follow its lead.
2018 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2019 progress "archive .dsc names newer git commit";
2020 @mergeinputs = ($dsc_mergeinput);
2022 progress "archive .dsc names other git commit, fixing up";
2023 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2027 @mergeinputs = generate_commits_from_dsc();
2028 # We have just done an import. Now, our import algorithm might
2029 # have been improved. But even so we do not want to generate
2030 # a new different import of the same package. So if the
2031 # version numbers are the same, just use our existing version.
2032 # If the version numbers are different, the archive has changed
2033 # (perhaps, rewound).
2034 if ($lastfetch_mergeinput &&
2035 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2036 (mergeinfo_version $mergeinputs[0]) )) {
2037 @mergeinputs = ($lastfetch_mergeinput);
2039 } elsif ($lastpush_hash) {
2040 # only in git, not in the archive yet
2041 @mergeinputs = ($lastpush_mergeinput);
2042 print STDERR <<END or die $!;
2044 Package not found in the archive, but has allegedly been pushed using dgit.
2048 printdebug "nothing found!\n";
2049 if (defined $skew_warning_vsn) {
2050 print STDERR <<END or die $!;
2052 Warning: relevant archive skew detected.
2053 Archive allegedly contains $skew_warning_vsn
2054 But we were not able to obtain any version from the archive or git.
2058 unshift @end, $del_lrfetchrefs;
2062 if ($lastfetch_hash &&
2064 my $h = $_->{Commit};
2065 $h and is_fast_fwd($lastfetch_hash, $h);
2066 # If true, one of the existing parents of this commit
2067 # is a descendant of the $lastfetch_hash, so we'll
2068 # be ff from that automatically.
2072 push @mergeinputs, $lastfetch_mergeinput;
2075 printdebug "fetch mergeinfos:\n";
2076 foreach my $mi (@mergeinputs) {
2078 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2080 printdebug sprintf " ReverseParents=%d Message=%s",
2081 $mi->{ReverseParents}, $mi->{Message};
2085 my $compat_info= pop @mergeinputs
2086 if $mergeinputs[$#mergeinputs]{Message};
2088 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2091 if (@mergeinputs > 1) {
2093 my $tree_commit = $mergeinputs[0]{Commit};
2095 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2096 $tree =~ m/\n\n/; $tree = $`;
2097 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2100 # We use the changelog author of the package in question the
2101 # author of this pseudo-merge. This is (roughly) correct if
2102 # this commit is simply representing aa non-dgit upload.
2103 # (Roughly because it does not record sponsorship - but we
2104 # don't have sponsorship info because that's in the .changes,
2105 # which isn't in the archivw.)
2107 # But, it might be that we are representing archive history
2108 # updates (including in-archive copies). These are not really
2109 # the responsibility of the person who created the .dsc, but
2110 # there is no-one whose name we should better use. (The
2111 # author of the .dsc-named commit is clearly worse.)
2113 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2114 my $author = clogp_authline $useclogp;
2115 my $cversion = getfield $useclogp, 'Version';
2117 my $mcf = ".git/dgit/mergecommit";
2118 open MC, ">", $mcf or die "$mcf $!";
2119 print MC <<END or die $!;
2123 my @parents = grep { $_->{Commit} } @mergeinputs;
2124 @parents = reverse @parents if $compat_info->{ReverseParents};
2125 print MC <<END or die $! foreach @parents;
2129 print MC <<END or die $!;
2135 if (defined $compat_info->{Message}) {
2136 print MC $compat_info->{Message} or die $!;
2138 print MC <<END or die $!;
2139 Record $package ($cversion) in archive suite $csuite
2143 my $message_add_info = sub {
2145 my $mversion = mergeinfo_version $mi;
2146 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2150 $message_add_info->($mergeinputs[0]);
2151 print MC <<END or die $!;
2152 should be treated as descended from
2154 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2158 $hash = make_commit $mcf;
2160 $hash = $mergeinputs[0]{Commit};
2162 progress "fetch hash=$hash\n";
2165 my ($lasth, $what) = @_;
2166 return unless $lasth;
2167 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2170 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2171 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2173 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2174 'DGIT_ARCHIVE', $hash;
2175 cmdoutput @git, qw(log -n2), $hash;
2176 # ... gives git a chance to complain if our commit is malformed
2178 if (defined $skew_warning_vsn) {
2180 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2181 my $gotclogp = commit_getclogp($hash);
2182 my $got_vsn = getfield $gotclogp, 'Version';
2183 printdebug "SKEW CHECK GOT $got_vsn\n";
2184 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2185 print STDERR <<END or die $!;
2187 Warning: archive skew detected. Using the available version:
2188 Archive allegedly contains $skew_warning_vsn
2189 We were able to obtain only $got_vsn
2195 if ($lastfetch_hash ne $hash) {
2196 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2200 dryrun_report @upd_cmd;
2204 lrfetchref_used lrfetchref();
2206 unshift @end, $del_lrfetchrefs;
2210 sub set_local_git_config ($$) {
2212 runcmd @git, qw(config), $k, $v;
2215 sub setup_mergechangelogs (;$) {
2217 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2219 my $driver = 'dpkg-mergechangelogs';
2220 my $cb = "merge.$driver";
2221 my $attrs = '.git/info/attributes';
2222 ensuredir '.git/info';
2224 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2225 if (!open ATTRS, "<", $attrs) {
2226 $!==ENOENT or die "$attrs: $!";
2230 next if m{^debian/changelog\s};
2231 print NATTRS $_, "\n" or die $!;
2233 ATTRS->error and die $!;
2236 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2239 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2240 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2242 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2245 sub setup_useremail (;$) {
2247 return unless $always || access_cfg_bool(1, 'setup-useremail');
2250 my ($k, $envvar) = @_;
2251 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2252 return unless defined $v;
2253 set_local_git_config "user.$k", $v;
2256 $setup->('email', 'DEBEMAIL');
2257 $setup->('name', 'DEBFULLNAME');
2260 sub setup_new_tree () {
2261 setup_mergechangelogs();
2267 canonicalise_suite();
2268 badusage "dry run makes no sense with clone" unless act_local();
2269 my $hasgit = check_for_git();
2270 mkdir $dstdir or fail "create \`$dstdir': $!";
2272 runcmd @git, qw(init -q);
2273 my $giturl = access_giturl(1);
2274 if (defined $giturl) {
2275 open H, "> .git/HEAD" or die $!;
2276 print H "ref: ".lref()."\n" or die $!;
2278 runcmd @git, qw(remote add), 'origin', $giturl;
2281 progress "fetching existing git history";
2283 runcmd_ordryrun_local @git, qw(fetch origin);
2285 progress "starting new git history";
2287 fetch_from_archive() or no_such_package;
2288 my $vcsgiturl = $dsc->{'Vcs-Git'};
2289 if (length $vcsgiturl) {
2290 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2291 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2294 runcmd @git, qw(reset --hard), lrref();
2295 printdone "ready for work in $dstdir";
2299 if (check_for_git()) {
2302 fetch_from_archive() or no_such_package();
2303 printdone "fetched into ".lrref();
2308 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2310 printdone "fetched to ".lrref()." and merged into HEAD";
2313 sub check_not_dirty () {
2314 foreach my $f (qw(local-options local-patch-header)) {
2315 if (stat_exists "debian/source/$f") {
2316 fail "git tree contains debian/source/$f";
2320 return if $ignoredirty;
2322 my @cmd = (@git, qw(diff --quiet HEAD));
2324 $!=0; $?=-1; system @cmd;
2327 fail "working tree is dirty (does not match HEAD)";
2333 sub commit_admin ($) {
2336 runcmd_ordryrun_local @git, qw(commit -m), $m;
2339 sub commit_quilty_patch () {
2340 my $output = cmdoutput @git, qw(status --porcelain);
2342 foreach my $l (split /\n/, $output) {
2343 next unless $l =~ m/\S/;
2344 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2348 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2350 progress "nothing quilty to commit, ok.";
2353 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2354 runcmd_ordryrun_local @git, qw(add -f), @adds;
2355 commit_admin "Commit Debian 3.0 (quilt) metadata";
2358 sub get_source_format () {
2360 if (open F, "debian/source/options") {
2364 s/\s+$//; # ignore missing final newline
2366 my ($k, $v) = ($`, $'); #');
2367 $v =~ s/^"(.*)"$/$1/;
2373 F->error and die $!;
2376 die $! unless $!==&ENOENT;
2379 if (!open F, "debian/source/format") {
2380 die $! unless $!==&ENOENT;
2384 F->error and die $!;
2386 return ($_, \%options);
2389 sub madformat_wantfixup ($) {
2391 return 0 unless $format eq '3.0 (quilt)';
2392 our $quilt_mode_warned;
2393 if ($quilt_mode eq 'nocheck') {
2394 progress "Not doing any fixup of \`$format' due to".
2395 " ----no-quilt-fixup or --quilt=nocheck"
2396 unless $quilt_mode_warned++;
2399 progress "Format \`$format', need to check/update patch stack"
2400 unless $quilt_mode_warned++;
2404 # An "infopair" is a tuple [ $thing, $what ]
2405 # (often $thing is a commit hash; $what is a description)
2407 sub infopair_cond_equal ($$) {
2409 $x->[0] eq $y->[0] or fail <<END;
2410 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2414 sub infopair_lrf_tag_lookup ($$) {
2415 my ($tagnames, $what) = @_;
2416 # $tagname may be an array ref
2417 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2418 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2419 foreach my $tagname (@tagnames) {
2420 my $lrefname = lrfetchrefs."/tags/$tagname";
2421 my $tagobj = $lrfetchrefs_f{$lrefname};
2422 next unless defined $tagobj;
2423 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2424 return [ git_rev_parse($tagobj), $what ];
2426 fail @tagnames==1 ? <<END : <<END;
2427 Wanted tag $what (@tagnames) on dgit server, but not found
2429 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2433 sub infopair_cond_ff ($$) {
2434 my ($anc,$desc) = @_;
2435 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2436 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2440 sub pseudomerge_version_check ($$) {
2441 my ($clogp, $archive_hash) = @_;
2443 my $arch_clogp = commit_getclogp $archive_hash;
2444 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2445 'version currently in archive' ];
2446 if (defined $overwrite_version) {
2447 if (length $overwrite_version) {
2448 infopair_cond_equal([ $overwrite_version,
2449 '--overwrite= version' ],
2452 my $v = $i_arch_v->[0];
2453 progress "Checking package changelog for archive version $v ...";
2455 my @xa = ("-f$v", "-t$v");
2456 my $vclogp = parsechangelog @xa;
2457 my $cv = [ (getfield $vclogp, 'Version'),
2458 "Version field from dpkg-parsechangelog @xa" ];
2459 infopair_cond_equal($i_arch_v, $cv);
2462 $@ =~ s/^dgit: //gm;
2464 "Perhaps debian/changelog does not mention $v ?";
2469 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2473 sub pseudomerge_make_commit ($$$$ $$) {
2474 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2475 $msg_cmd, $msg_msg) = @_;
2476 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2478 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2479 my $authline = clogp_authline $clogp;
2483 !defined $overwrite_version ? ""
2484 : !length $overwrite_version ? " --overwrite"
2485 : " --overwrite=".$overwrite_version;
2488 my $pmf = ".git/dgit/pseudomerge";
2489 open MC, ">", $pmf or die "$pmf $!";
2490 print MC <<END or die $!;
2493 parent $archive_hash
2503 return make_commit($pmf);
2506 sub splitbrain_pseudomerge ($$$$) {
2507 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2508 # => $merged_dgitview
2509 printdebug "splitbrain_pseudomerge...\n";
2511 # We: debian/PREVIOUS HEAD($maintview)
2512 # expect: o ----------------- o
2515 # a/d/PREVIOUS $dgitview
2518 # we do: `------------------ o
2522 printdebug "splitbrain_pseudomerge...\n";
2524 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2526 return $dgitview unless defined $archive_hash;
2528 if (!defined $overwrite_version) {
2529 progress "Checking that HEAD inciudes all changes in archive...";
2532 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2534 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2535 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2536 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2537 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2538 my $i_archive = [ $archive_hash, "current archive contents" ];
2540 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2542 infopair_cond_equal($i_dgit, $i_archive);
2543 infopair_cond_ff($i_dep14, $i_dgit);
2544 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2546 my $r = pseudomerge_make_commit
2547 $clogp, $dgitview, $archive_hash, $i_arch_v,
2548 "dgit --quilt=$quilt_mode",
2549 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2550 Declare fast forward from $overwrite_version
2552 Make fast forward from $i_arch_v->[0]
2555 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2559 sub plain_overwrite_pseudomerge ($$$) {
2560 my ($clogp, $head, $archive_hash) = @_;
2562 printdebug "plain_overwrite_pseudomerge...";
2564 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2566 my @tagformats = access_cfg_tagformats();
2568 map { $_->($i_arch_v->[0], access_basedistro) }
2569 (grep { m/^(?:old|hist)$/ } @tagformats)
2570 ? \&debiantags : \&debiantag_new;
2571 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2572 my $i_archive = [ $archive_hash, "current archive contents" ];
2574 infopair_cond_equal($i_overwr, $i_archive);
2576 return $head if is_fast_fwd $archive_hash, $head;
2578 my $m = "Declare fast forward from $i_arch_v->[0]";
2580 my $r = pseudomerge_make_commit
2581 $clogp, $head, $archive_hash, $i_arch_v,
2584 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2586 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2590 sub push_parse_changelog ($) {
2593 my $clogp = Dpkg::Control::Hash->new();
2594 $clogp->load($clogpfn) or die;
2596 $package = getfield $clogp, 'Source';
2597 my $cversion = getfield $clogp, 'Version';
2598 my $tag = debiantag($cversion, access_basedistro);
2599 runcmd @git, qw(check-ref-format), $tag;
2601 my $dscfn = dscfn($cversion);
2603 return ($clogp, $cversion, $dscfn);
2606 sub push_parse_dsc ($$$) {
2607 my ($dscfn,$dscfnwhat, $cversion) = @_;
2608 $dsc = parsecontrol($dscfn,$dscfnwhat);
2609 my $dversion = getfield $dsc, 'Version';
2610 my $dscpackage = getfield $dsc, 'Source';
2611 ($dscpackage eq $package && $dversion eq $cversion) or
2612 fail "$dscfn is for $dscpackage $dversion".
2613 " but debian/changelog is for $package $cversion";
2616 sub push_tagwants ($$$$) {
2617 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2620 TagFn => \&debiantag,
2625 if (defined $maintviewhead) {
2627 TagFn => \&debiantag_maintview,
2628 Objid => $maintviewhead,
2629 TfSuffix => '-maintview',
2633 foreach my $tw (@tagwants) {
2634 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2635 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2637 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2641 sub push_mktags ($$ $$ $) {
2643 $changesfile,$changesfilewhat,
2646 die unless $tagwants->[0]{View} eq 'dgit';
2648 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2649 $dsc->save("$dscfn.tmp") or die $!;
2651 my $changes = parsecontrol($changesfile,$changesfilewhat);
2652 foreach my $field (qw(Source Distribution Version)) {
2653 $changes->{$field} eq $clogp->{$field} or
2654 fail "changes field $field \`$changes->{$field}'".
2655 " does not match changelog \`$clogp->{$field}'";
2658 my $cversion = getfield $clogp, 'Version';
2659 my $clogsuite = getfield $clogp, 'Distribution';
2661 # We make the git tag by hand because (a) that makes it easier
2662 # to control the "tagger" (b) we can do remote signing
2663 my $authline = clogp_authline $clogp;
2664 my $delibs = join(" ", "",@deliberatelies);
2665 my $declaredistro = access_basedistro();
2669 my $tfn = $tw->{Tfn};
2670 my $head = $tw->{Objid};
2671 my $tag = $tw->{Tag};
2673 open TO, '>', $tfn->('.tmp') or die $!;
2674 print TO <<END or die $!;
2681 if ($tw->{View} eq 'dgit') {
2682 print TO <<END or die $!;
2683 $package release $cversion for $clogsuite ($csuite) [dgit]
2684 [dgit distro=$declaredistro$delibs]
2686 foreach my $ref (sort keys %previously) {
2687 print TO <<END or die $!;
2688 [dgit previously:$ref=$previously{$ref}]
2691 } elsif ($tw->{View} eq 'maint') {
2692 print TO <<END or die $!;
2693 $package release $cversion for $clogsuite ($csuite)
2694 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2697 die Dumper($tw)."?";
2702 my $tagobjfn = $tfn->('.tmp');
2704 if (!defined $keyid) {
2705 $keyid = access_cfg('keyid','RETURN-UNDEF');
2707 if (!defined $keyid) {
2708 $keyid = getfield $clogp, 'Maintainer';
2710 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2711 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2712 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2713 push @sign_cmd, $tfn->('.tmp');
2714 runcmd_ordryrun @sign_cmd;
2716 $tagobjfn = $tfn->('.signed.tmp');
2717 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2718 $tfn->('.tmp'), $tfn->('.tmp.asc');
2724 my @r = map { $mktag->($_); } @$tagwants;
2728 sub sign_changes ($) {
2729 my ($changesfile) = @_;
2731 my @debsign_cmd = @debsign;
2732 push @debsign_cmd, "-k$keyid" if defined $keyid;
2733 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2734 push @debsign_cmd, $changesfile;
2735 runcmd_ordryrun @debsign_cmd;
2740 printdebug "actually entering push\n";
2742 supplementary_message(<<'END');
2743 Push failed, while checking state of the archive.
2744 You can retry the push, after fixing the problem, if you like.
2746 if (check_for_git()) {
2749 my $archive_hash = fetch_from_archive();
2750 if (!$archive_hash) {
2752 fail "package appears to be new in this suite;".
2753 " if this is intentional, use --new";
2756 supplementary_message(<<'END');
2757 Push failed, while preparing your push.
2758 You can retry the push, after fixing the problem, if you like.
2761 need_tagformat 'new', "quilt mode $quilt_mode"
2762 if quiltmode_splitbrain;
2766 access_giturl(); # check that success is vaguely likely
2769 my $clogpfn = ".git/dgit/changelog.822.tmp";
2770 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2772 responder_send_file('parsed-changelog', $clogpfn);
2774 my ($clogp, $cversion, $dscfn) =
2775 push_parse_changelog("$clogpfn");
2777 my $dscpath = "$buildproductsdir/$dscfn";
2778 stat_exists $dscpath or
2779 fail "looked for .dsc $dscfn, but $!;".
2780 " maybe you forgot to build";
2782 responder_send_file('dsc', $dscpath);
2784 push_parse_dsc($dscpath, $dscfn, $cversion);
2786 my $format = getfield $dsc, 'Format';
2787 printdebug "format $format\n";
2789 my $actualhead = git_rev_parse('HEAD');
2790 my $dgithead = $actualhead;
2791 my $maintviewhead = undef;
2793 if (madformat_wantfixup($format)) {
2794 # user might have not used dgit build, so maybe do this now:
2795 if (quiltmode_splitbrain()) {
2796 my $upstreamversion = $clogp->{Version};
2797 $upstreamversion =~ s/-[^-]*$//;
2799 quilt_make_fake_dsc($upstreamversion);
2800 my ($dgitview, $cachekey) =
2801 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2803 "--quilt=$quilt_mode but no cached dgit view:
2804 perhaps tree changed since dgit build[-source] ?";
2806 $dgithead = splitbrain_pseudomerge($clogp,
2807 $actualhead, $dgitview,
2809 $maintviewhead = $actualhead;
2810 changedir '../../../..';
2811 prep_ud(); # so _only_subdir() works, below
2813 commit_quilty_patch();
2817 if (defined $overwrite_version && !defined $maintviewhead) {
2818 $dgithead = plain_overwrite_pseudomerge($clogp,
2826 if ($archive_hash) {
2827 if (is_fast_fwd($archive_hash, $dgithead)) {
2829 } elsif (deliberately_not_fast_forward) {
2832 fail "dgit push: HEAD is not a descendant".
2833 " of the archive's version.\n".
2834 "To overwrite the archive's contents,".
2835 " pass --overwrite[=VERSION].\n".
2836 "To rewind history, if permitted by the archive,".
2837 " use --deliberately-not-fast-forward.";
2842 progress "checking that $dscfn corresponds to HEAD";
2843 runcmd qw(dpkg-source -x --),
2844 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2845 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2846 check_for_vendor_patches() if madformat($dsc->{format});
2847 changedir '../../../..';
2848 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2849 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2850 debugcmd "+",@diffcmd;
2852 my $r = system @diffcmd;
2855 fail "$dscfn specifies a different tree to your HEAD commit;".
2856 " perhaps you forgot to build".
2857 ($diffopt eq '--exit-code' ? "" :
2858 " (run with -D to see full diff output)");
2863 if (!$changesfile) {
2864 my $pat = changespat $cversion;
2865 my @cs = glob "$buildproductsdir/$pat";
2866 fail "failed to find unique changes file".
2867 " (looked for $pat in $buildproductsdir);".
2868 " perhaps you need to use dgit -C"
2870 ($changesfile) = @cs;
2872 $changesfile = "$buildproductsdir/$changesfile";
2875 # Checks complete, we're going to try and go ahead:
2877 responder_send_file('changes',$changesfile);
2878 responder_send_command("param head $dgithead");
2879 responder_send_command("param csuite $csuite");
2880 responder_send_command("param tagformat $tagformat");
2881 if (defined $maintviewhead) {
2882 die unless ($protovsn//4) >= 4;
2883 responder_send_command("param maint-view $maintviewhead");
2886 if (deliberately_not_fast_forward) {
2887 git_for_each_ref(lrfetchrefs, sub {
2888 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2889 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2890 responder_send_command("previously $rrefname=$objid");
2891 $previously{$rrefname} = $objid;
2895 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2899 supplementary_message(<<'END');
2900 Push failed, while signing the tag.
2901 You can retry the push, after fixing the problem, if you like.
2903 # If we manage to sign but fail to record it anywhere, it's fine.
2904 if ($we_are_responder) {
2905 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2906 responder_receive_files('signed-tag', @tagobjfns);
2908 @tagobjfns = push_mktags($clogp,$dscpath,
2909 $changesfile,$changesfile,
2912 supplementary_message(<<'END');
2913 Push failed, *after* signing the tag.
2914 If you want to try again, you should use a new version number.
2917 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2919 foreach my $tw (@tagwants) {
2920 my $tag = $tw->{Tag};
2921 my $tagobjfn = $tw->{TagObjFn};
2923 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2924 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2925 runcmd_ordryrun_local
2926 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2929 supplementary_message(<<'END');
2930 Push failed, while updating the remote git repository - see messages above.
2931 If you want to try again, you should use a new version number.
2933 if (!check_for_git()) {
2934 create_remote_git_repo();
2937 my @pushrefs = $forceflag.$dgithead.":".rrref();
2938 foreach my $tw (@tagwants) {
2939 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2942 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2943 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2945 supplementary_message(<<'END');
2946 Push failed, after updating the remote git repository.
2947 If you want to try again, you must use a new version number.
2949 if ($we_are_responder) {
2950 my $dryrunsuffix = act_local() ? "" : ".tmp";
2951 responder_receive_files('signed-dsc-changes',
2952 "$dscpath$dryrunsuffix",
2953 "$changesfile$dryrunsuffix");
2956 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2958 progress "[new .dsc left in $dscpath.tmp]";
2960 sign_changes $changesfile;
2963 supplementary_message(<<END);
2964 Push failed, while uploading package(s) to the archive server.
2965 You can retry the upload of exactly these same files with dput of:
2967 If that .changes file is broken, you will need to use a new version
2968 number for your next attempt at the upload.
2970 my $host = access_cfg('upload-host','RETURN-UNDEF');
2971 my @hostarg = defined($host) ? ($host,) : ();
2972 runcmd_ordryrun @dput, @hostarg, $changesfile;
2973 printdone "pushed and uploaded $cversion";
2975 supplementary_message('');
2976 responder_send_command("complete");
2983 badusage "-p is not allowed with clone; specify as argument instead"
2984 if defined $package;
2987 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2988 ($package,$isuite) = @ARGV;
2989 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2990 ($package,$dstdir) = @ARGV;
2991 } elsif (@ARGV==3) {
2992 ($package,$isuite,$dstdir) = @ARGV;
2994 badusage "incorrect arguments to dgit clone";
2996 $dstdir ||= "$package";
2998 if (stat_exists $dstdir) {
2999 fail "$dstdir already exists";
3003 if ($rmonerror && !$dryrun_level) {
3004 $cwd_remove= getcwd();
3006 return unless defined $cwd_remove;
3007 if (!chdir "$cwd_remove") {
3008 return if $!==&ENOENT;
3009 die "chdir $cwd_remove: $!";
3012 rmtree($dstdir) or die "remove $dstdir: $!\n";
3013 } elsif (!grep { $! == $_ }
3014 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3016 print STDERR "check whether to remove $dstdir: $!\n";
3022 $cwd_remove = undef;
3025 sub branchsuite () {
3026 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3027 if ($branch =~ m#$lbranch_re#o) {
3034 sub fetchpullargs () {
3036 if (!defined $package) {
3037 my $sourcep = parsecontrol('debian/control','debian/control');
3038 $package = getfield $sourcep, 'Source';
3041 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3043 my $clogp = parsechangelog();
3044 $isuite = getfield $clogp, 'Distribution';
3046 canonicalise_suite();
3047 progress "fetching from suite $csuite";
3048 } elsif (@ARGV==1) {
3050 canonicalise_suite();
3052 badusage "incorrect arguments to dgit fetch or dgit pull";
3071 badusage "-p is not allowed with dgit push" if defined $package;
3073 my $clogp = parsechangelog();
3074 $package = getfield $clogp, 'Source';
3077 } elsif (@ARGV==1) {
3078 ($specsuite) = (@ARGV);
3080 badusage "incorrect arguments to dgit push";
3082 $isuite = getfield $clogp, 'Distribution';
3084 local ($package) = $existing_package; # this is a hack
3085 canonicalise_suite();
3087 canonicalise_suite();
3089 if (defined $specsuite &&
3090 $specsuite ne $isuite &&
3091 $specsuite ne $csuite) {
3092 fail "dgit push: changelog specifies $isuite ($csuite)".
3093 " but command line specifies $specsuite";
3098 #---------- remote commands' implementation ----------
3100 sub cmd_remote_push_build_host {
3101 my ($nrargs) = shift @ARGV;
3102 my (@rargs) = @ARGV[0..$nrargs-1];
3103 @ARGV = @ARGV[$nrargs..$#ARGV];
3105 my ($dir,$vsnwant) = @rargs;
3106 # vsnwant is a comma-separated list; we report which we have
3107 # chosen in our ready response (so other end can tell if they
3110 $we_are_responder = 1;
3111 $us .= " (build host)";
3115 open PI, "<&STDIN" or die $!;
3116 open STDIN, "/dev/null" or die $!;
3117 open PO, ">&STDOUT" or die $!;
3119 open STDOUT, ">&STDERR" or die $!;
3123 ($protovsn) = grep {
3124 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3125 } @rpushprotovsn_support;
3127 fail "build host has dgit rpush protocol versions ".
3128 (join ",", @rpushprotovsn_support).
3129 " but invocation host has $vsnwant"
3130 unless defined $protovsn;
3132 responder_send_command("dgit-remote-push-ready $protovsn");
3133 rpush_handle_protovsn_bothends();
3138 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3139 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3140 # a good error message)
3142 sub rpush_handle_protovsn_bothends () {
3143 if ($protovsn < 4) {
3144 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3153 my $report = i_child_report();
3154 if (defined $report) {
3155 printdebug "($report)\n";
3156 } elsif ($i_child_pid) {
3157 printdebug "(killing build host child $i_child_pid)\n";
3158 kill 15, $i_child_pid;
3160 if (defined $i_tmp && !defined $initiator_tempdir) {
3162 eval { rmtree $i_tmp; };
3166 END { i_cleanup(); }
3169 my ($base,$selector,@args) = @_;
3170 $selector =~ s/\-/_/g;
3171 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3178 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3186 push @rargs, join ",", @rpushprotovsn_support;
3189 push @rdgit, @ropts;
3190 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3192 my @cmd = (@ssh, $host, shellquote @rdgit);
3195 if (defined $initiator_tempdir) {
3196 rmtree $initiator_tempdir;
3197 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3198 $i_tmp = $initiator_tempdir;
3202 $i_child_pid = open2(\*RO, \*RI, @cmd);
3204 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3205 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3206 $supplementary_message = '' unless $protovsn >= 3;
3208 fail "rpush negotiated protocol version $protovsn".
3209 " which does not support quilt mode $quilt_mode"
3210 if quiltmode_splitbrain;
3212 rpush_handle_protovsn_bothends();
3214 my ($icmd,$iargs) = initiator_expect {
3215 m/^(\S+)(?: (.*))?$/;
3218 i_method "i_resp", $icmd, $iargs;
3222 sub i_resp_progress ($) {
3224 my $msg = protocol_read_bytes \*RO, $rhs;
3228 sub i_resp_supplementary_message ($) {
3230 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3233 sub i_resp_complete {
3234 my $pid = $i_child_pid;
3235 $i_child_pid = undef; # prevents killing some other process with same pid
3236 printdebug "waiting for build host child $pid...\n";
3237 my $got = waitpid $pid, 0;
3238 die $! unless $got == $pid;
3239 die "build host child failed $?" if $?;
3242 printdebug "all done\n";
3246 sub i_resp_file ($) {
3248 my $localname = i_method "i_localname", $keyword;
3249 my $localpath = "$i_tmp/$localname";
3250 stat_exists $localpath and
3251 badproto \*RO, "file $keyword ($localpath) twice";
3252 protocol_receive_file \*RO, $localpath;
3253 i_method "i_file", $keyword;
3258 sub i_resp_param ($) {
3259 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3263 sub i_resp_previously ($) {
3264 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3265 or badproto \*RO, "bad previously spec";
3266 my $r = system qw(git check-ref-format), $1;
3267 die "bad previously ref spec ($r)" if $r;
3268 $previously{$1} = $2;
3273 sub i_resp_want ($) {
3275 die "$keyword ?" if $i_wanted{$keyword}++;
3276 my @localpaths = i_method "i_want", $keyword;
3277 printdebug "[[ $keyword @localpaths\n";
3278 foreach my $localpath (@localpaths) {
3279 protocol_send_file \*RI, $localpath;
3281 print RI "files-end\n" or die $!;
3284 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3286 sub i_localname_parsed_changelog {
3287 return "remote-changelog.822";
3289 sub i_file_parsed_changelog {
3290 ($i_clogp, $i_version, $i_dscfn) =
3291 push_parse_changelog "$i_tmp/remote-changelog.822";
3292 die if $i_dscfn =~ m#/|^\W#;
3295 sub i_localname_dsc {
3296 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3301 sub i_localname_changes {
3302 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3303 $i_changesfn = $i_dscfn;
3304 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3305 return $i_changesfn;
3307 sub i_file_changes { }
3309 sub i_want_signed_tag {
3310 printdebug Dumper(\%i_param, $i_dscfn);
3311 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3312 && defined $i_param{'csuite'}
3313 or badproto \*RO, "premature desire for signed-tag";
3314 my $head = $i_param{'head'};
3315 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3317 my $maintview = $i_param{'maint-view'};
3318 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3321 if ($protovsn >= 4) {
3322 my $p = $i_param{'tagformat'} // '<undef>';
3324 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3327 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3329 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3331 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3334 push_mktags $i_clogp, $i_dscfn,
3335 $i_changesfn, 'remote changes',
3339 sub i_want_signed_dsc_changes {
3340 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3341 sign_changes $i_changesfn;
3342 return ($i_dscfn, $i_changesfn);
3345 #---------- building etc. ----------
3351 #----- `3.0 (quilt)' handling -----
3353 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3355 sub quiltify_dpkg_commit ($$$;$) {
3356 my ($patchname,$author,$msg, $xinfo) = @_;
3360 my $descfn = ".git/dgit/quilt-description.tmp";
3361 open O, '>', $descfn or die "$descfn: $!";
3364 $msg =~ s/^\s+$/ ./mg;
3365 print O <<END or die $!;
3375 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3376 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3377 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3378 runcmd @dpkgsource, qw(--commit .), $patchname;
3382 sub quiltify_trees_differ ($$;$$) {
3383 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3384 # returns true iff the two tree objects differ other than in debian/
3385 # with $finegrained,
3386 # returns bitmask 01 - differ in upstream files except .gitignore
3387 # 02 - differ in .gitignore
3388 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3389 # is set for each modified .gitignore filename $fn
3391 my @cmd = (@git, qw(diff-tree --name-only -z));
3392 push @cmd, qw(-r) if $finegrained;
3394 my $diffs= cmdoutput @cmd;
3396 foreach my $f (split /\0/, $diffs) {
3397 next if $f =~ m#^debian(?:/.*)?$#s;
3398 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3399 $r |= $isignore ? 02 : 01;
3400 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3402 printdebug "quiltify_trees_differ $x $y => $r\n";
3406 sub quiltify_tree_sentinelfiles ($) {
3407 # lists the `sentinel' files present in the tree
3409 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3410 qw(-- debian/rules debian/control);
3415 sub quiltify_splitbrain_needed () {
3416 if (!$split_brain) {
3417 progress "dgit view: changes are required...";
3418 runcmd @git, qw(checkout -q -b dgit-view);
3423 sub quiltify_splitbrain ($$$$$$) {
3424 my ($clogp, $unapplied, $headref, $diffbits,
3425 $editedignores, $cachekey) = @_;
3426 if ($quilt_mode !~ m/gbp|dpm/) {
3427 # treat .gitignore just like any other upstream file
3428 $diffbits = { %$diffbits };
3429 $_ = !!$_ foreach values %$diffbits;
3431 # We would like any commits we generate to be reproducible
3432 my @authline = clogp_authline($clogp);
3433 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3434 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3435 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3437 if ($quilt_mode =~ m/gbp|unapplied/ &&
3438 ($diffbits->{H2O} & 01)) {
3440 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3441 " but git tree differs from orig in upstream files.";
3442 if (!stat_exists "debian/patches") {
3444 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3448 if ($quilt_mode =~ m/dpm/ &&
3449 ($diffbits->{H2A} & 01)) {
3451 --quilt=$quilt_mode specified, implying patches-applied git tree
3452 but git tree differs from result of applying debian/patches to upstream
3455 if ($quilt_mode =~ m/gbp|unapplied/ &&
3456 ($diffbits->{O2A} & 01)) { # some patches
3457 quiltify_splitbrain_needed();
3458 progress "dgit view: creating patches-applied version using gbp pq";
3459 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3460 # gbp pq import creates a fresh branch; push back to dgit-view
3461 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3462 runcmd @git, qw(checkout -q dgit-view);
3464 if ($quilt_mode =~ m/gbp|dpm/ &&
3465 ($diffbits->{O2A} & 02)) {
3467 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3468 tool which does not create patches for changes to upstream
3469 .gitignores: but, such patches exist in debian/patches.
3472 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3473 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3474 quiltify_splitbrain_needed();
3475 progress "dgit view: creating patch to represent .gitignore changes";
3476 ensuredir "debian/patches";
3477 my $gipatch = "debian/patches/auto-gitignore";
3478 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3479 stat GIPATCH or die "$gipatch: $!";
3480 fail "$gipatch already exists; but want to create it".
3481 " to record .gitignore changes" if (stat _)[7];
3482 print GIPATCH <<END or die "$gipatch: $!";
3483 Subject: Update .gitignore from Debian packaging branch
3485 The Debian packaging git branch contains these updates to the upstream
3486 .gitignore file(s). This patch is autogenerated, to provide these
3487 updates to users of the official Debian archive view of the package.
3489 [dgit version $our_version]
3492 close GIPATCH or die "$gipatch: $!";
3493 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3494 $unapplied, $headref, "--", sort keys %$editedignores;
3495 open SERIES, "+>>", "debian/patches/series" or die $!;
3496 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3498 defined read SERIES, $newline, 1 or die $!;
3499 print SERIES "\n" or die $! unless $newline eq "\n";
3500 print SERIES "auto-gitignore\n" or die $!;
3501 close SERIES or die $!;
3502 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3503 commit_admin "Commit patch to update .gitignore";
3506 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3508 changedir '../../../..';
3509 ensuredir ".git/logs/refs/dgit-intern";
3510 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3512 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3515 progress "dgit view: created (commit id $dgitview)";
3517 changedir '.git/dgit/unpack/work';
3520 sub quiltify ($$$$) {
3521 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3523 # Quilt patchification algorithm
3525 # We search backwards through the history of the main tree's HEAD
3526 # (T) looking for a start commit S whose tree object is identical
3527 # to to the patch tip tree (ie the tree corresponding to the
3528 # current dpkg-committed patch series). For these purposes
3529 # `identical' disregards anything in debian/ - this wrinkle is
3530 # necessary because dpkg-source treates debian/ specially.
3532 # We can only traverse edges where at most one of the ancestors'
3533 # trees differs (in changes outside in debian/). And we cannot
3534 # handle edges which change .pc/ or debian/patches. To avoid
3535 # going down a rathole we avoid traversing edges which introduce
3536 # debian/rules or debian/control. And we set a limit on the
3537 # number of edges we are willing to look at.
3539 # If we succeed, we walk forwards again. For each traversed edge
3540 # PC (with P parent, C child) (starting with P=S and ending with
3541 # C=T) to we do this:
3543 # - dpkg-source --commit with a patch name and message derived from C
3544 # After traversing PT, we git commit the changes which
3545 # should be contained within debian/patches.
3547 # The search for the path S..T is breadth-first. We maintain a
3548 # todo list containing search nodes. A search node identifies a
3549 # commit, and looks something like this:
3551 # Commit => $git_commit_id,
3552 # Child => $c, # or undef if P=T
3553 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3554 # Nontrivial => true iff $p..$c has relevant changes
3561 my %considered; # saves being exponential on some weird graphs
3563 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3566 my ($search,$whynot) = @_;
3567 printdebug " search NOT $search->{Commit} $whynot\n";
3568 $search->{Whynot} = $whynot;
3569 push @nots, $search;
3570 no warnings qw(exiting);
3579 my $c = shift @todo;
3580 next if $considered{$c->{Commit}}++;
3582 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3584 printdebug "quiltify investigate $c->{Commit}\n";
3587 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3588 printdebug " search finished hooray!\n";
3593 if ($quilt_mode eq 'nofix') {
3594 fail "quilt fixup required but quilt mode is \`nofix'\n".
3595 "HEAD commit $c->{Commit} differs from tree implied by ".
3596 " debian/patches (tree object $oldtiptree)";
3598 if ($quilt_mode eq 'smash') {
3599 printdebug " search quitting smash\n";
3603 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3604 $not->($c, "has $c_sentinels not $t_sentinels")
3605 if $c_sentinels ne $t_sentinels;
3607 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3608 $commitdata =~ m/\n\n/;
3610 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3611 @parents = map { { Commit => $_, Child => $c } } @parents;
3613 $not->($c, "root commit") if !@parents;
3615 foreach my $p (@parents) {
3616 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3618 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3619 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3621 foreach my $p (@parents) {
3622 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3624 my @cmd= (@git, qw(diff-tree -r --name-only),
3625 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3626 my $patchstackchange = cmdoutput @cmd;
3627 if (length $patchstackchange) {
3628 $patchstackchange =~ s/\n/,/g;
3629 $not->($p, "changed $patchstackchange");
3632 printdebug " search queue P=$p->{Commit} ",
3633 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3639 printdebug "quiltify want to smash\n";
3642 my $x = $_[0]{Commit};
3643 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3646 my $reportnot = sub {
3648 my $s = $abbrev->($notp);
3649 my $c = $notp->{Child};
3650 $s .= "..".$abbrev->($c) if $c;
3651 $s .= ": ".$notp->{Whynot};
3654 if ($quilt_mode eq 'linear') {
3655 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3656 foreach my $notp (@nots) {
3657 print STDERR "$us: ", $reportnot->($notp), "\n";
3659 print STDERR "$us: $_\n" foreach @$failsuggestion;
3660 fail "quilt fixup naive history linearisation failed.\n".
3661 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3662 } elsif ($quilt_mode eq 'smash') {
3663 } elsif ($quilt_mode eq 'auto') {
3664 progress "quilt fixup cannot be linear, smashing...";
3666 die "$quilt_mode ?";
3669 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3670 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3672 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3674 quiltify_dpkg_commit "auto-$version-$target-$time",
3675 (getfield $clogp, 'Maintainer'),
3676 "Automatically generated patch ($clogp->{Version})\n".
3677 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3681 progress "quiltify linearisation planning successful, executing...";
3683 for (my $p = $sref_S;
3684 my $c = $p->{Child};
3686 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3687 next unless $p->{Nontrivial};
3689 my $cc = $c->{Commit};
3691 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3692 $commitdata =~ m/\n\n/ or die "$c ?";
3695 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3698 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3701 my $patchname = $title;
3702 $patchname =~ s/[.:]$//;
3703 $patchname =~ y/ A-Z/-a-z/;
3704 $patchname =~ y/-a-z0-9_.+=~//cd;
3705 $patchname =~ s/^\W/x-$&/;
3706 $patchname = substr($patchname,0,40);
3709 stat "debian/patches/$patchname$index";
3711 $!==ENOENT or die "$patchname$index $!";
3713 runcmd @git, qw(checkout -q), $cc;
3715 # We use the tip's changelog so that dpkg-source doesn't
3716 # produce complaining messages from dpkg-parsechangelog. None
3717 # of the information dpkg-source gets from the changelog is
3718 # actually relevant - it gets put into the original message
3719 # which dpkg-source provides our stunt editor, and then
3721 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3723 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3724 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3726 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3729 runcmd @git, qw(checkout -q master);
3732 sub build_maybe_quilt_fixup () {
3733 my ($format,$fopts) = get_source_format;
3734 return unless madformat_wantfixup $format;
3737 check_for_vendor_patches();
3739 if (quiltmode_splitbrain) {
3740 foreach my $needtf (qw(new maint)) {
3741 next if grep { $_ eq $needtf } access_cfg_tagformats;
3743 quilt mode $quilt_mode requires split view so server needs to support
3744 both "new" and "maint" tag formats, but config says it doesn't.
3749 my $clogp = parsechangelog();
3750 my $headref = git_rev_parse('HEAD');
3755 my $upstreamversion=$version;
3756 $upstreamversion =~ s/-[^-]*$//;
3758 if ($fopts->{'single-debian-patch'}) {
3759 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3761 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3764 die 'bug' if $split_brain && !$need_split_build_invocation;
3766 changedir '../../../..';
3767 runcmd_ordryrun_local
3768 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3771 sub quilt_fixup_mkwork ($) {
3774 mkdir "work" or die $!;
3776 mktree_in_ud_here();
3777 runcmd @git, qw(reset -q --hard), $headref;
3780 sub quilt_fixup_linkorigs ($$) {
3781 my ($upstreamversion, $fn) = @_;
3782 # calls $fn->($leafname);
3784 foreach my $f (<../../../../*>) { #/){
3785 my $b=$f; $b =~ s{.*/}{};
3787 local ($debuglevel) = $debuglevel-1;
3788 printdebug "QF linkorigs $b, $f ?\n";
3790 next unless is_orig_file_of_vsn $b, $upstreamversion;
3791 printdebug "QF linkorigs $b, $f Y\n";
3792 link_ltarget $f, $b or die "$b $!";
3797 sub quilt_fixup_delete_pc () {
3798 runcmd @git, qw(rm -rqf .pc);
3799 commit_admin "Commit removal of .pc (quilt series tracking data)";
3802 sub quilt_fixup_singlepatch ($$$) {
3803 my ($clogp, $headref, $upstreamversion) = @_;
3805 progress "starting quiltify (single-debian-patch)";
3807 # dpkg-source --commit generates new patches even if
3808 # single-debian-patch is in debian/source/options. In order to
3809 # get it to generate debian/patches/debian-changes, it is
3810 # necessary to build the source package.
3812 quilt_fixup_linkorigs($upstreamversion, sub { });
3813 quilt_fixup_mkwork($headref);
3815 rmtree("debian/patches");
3817 runcmd @dpkgsource, qw(-b .);
3819 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3820 rename srcfn("$upstreamversion", "/debian/patches"),
3821 "work/debian/patches";
3824 commit_quilty_patch();
3827 sub quilt_make_fake_dsc ($) {
3828 my ($upstreamversion) = @_;
3830 my $fakeversion="$upstreamversion-~~DGITFAKE";
3832 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3833 print $fakedsc <<END or die $!;
3836 Version: $fakeversion
3840 my $dscaddfile=sub {
3843 my $md = new Digest::MD5;
3845 my $fh = new IO::File $b, '<' or die "$b $!";
3850 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3853 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3855 my @files=qw(debian/source/format debian/rules
3856 debian/control debian/changelog);
3857 foreach my $maybe (qw(debian/patches debian/source/options
3858 debian/tests/control)) {
3859 next unless stat_exists "../../../$maybe";
3860 push @files, $maybe;
3863 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3864 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3866 $dscaddfile->($debtar);
3867 close $fakedsc or die $!;
3870 sub quilt_check_splitbrain_cache ($$) {
3871 my ($headref, $upstreamversion) = @_;
3872 # Called only if we are in (potentially) split brain mode.
3874 # Computes the cache key and looks in the cache.
3875 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3877 my $splitbrain_cachekey;
3880 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3881 # we look in the reflog of dgit-intern/quilt-cache
3882 # we look for an entry whose message is the key for the cache lookup
3883 my @cachekey = (qw(dgit), $our_version);
3884 push @cachekey, $upstreamversion;
3885 push @cachekey, $quilt_mode;
3886 push @cachekey, $headref;
3888 push @cachekey, hashfile('fake.dsc');
3890 my $srcshash = Digest::SHA->new(256);
3891 my %sfs = ( %INC, '$0(dgit)' => $0 );
3892 foreach my $sfk (sort keys %sfs) {
3893 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3894 $srcshash->add($sfk," ");
3895 $srcshash->add(hashfile($sfs{$sfk}));
3896 $srcshash->add("\n");
3898 push @cachekey, $srcshash->hexdigest();
3899 $splitbrain_cachekey = "@cachekey";
3901 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3903 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3904 debugcmd "|(probably)",@cmd;
3905 my $child = open GC, "-|"; defined $child or die $!;
3907 chdir '../../..' or die $!;
3908 if (!stat ".git/logs/refs/$splitbraincache") {
3909 $! == ENOENT or die $!;
3910 printdebug ">(no reflog)\n";
3917 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3918 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3921 quilt_fixup_mkwork($headref);
3922 if ($cachehit ne $headref) {
3923 progress "dgit view: found cached (commit id $cachehit)";
3924 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3926 return ($cachehit, $splitbrain_cachekey);
3928 progress "dgit view: found cached, no changes required";
3929 return ($headref, $splitbrain_cachekey);
3931 die $! if GC->error;
3932 failedcmd unless close GC;
3934 printdebug "splitbrain cache miss\n";
3935 return (undef, $splitbrain_cachekey);
3938 sub quilt_fixup_multipatch ($$$) {
3939 my ($clogp, $headref, $upstreamversion) = @_;
3941 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3944 # - honour any existing .pc in case it has any strangeness
3945 # - determine the git commit corresponding to the tip of
3946 # the patch stack (if there is one)
3947 # - if there is such a git commit, convert each subsequent
3948 # git commit into a quilt patch with dpkg-source --commit
3949 # - otherwise convert all the differences in the tree into
3950 # a single git commit
3954 # Our git tree doesn't necessarily contain .pc. (Some versions of
3955 # dgit would include the .pc in the git tree.) If there isn't
3956 # one, we need to generate one by unpacking the patches that we
3959 # We first look for a .pc in the git tree. If there is one, we
3960 # will use it. (This is not the normal case.)
3962 # Otherwise need to regenerate .pc so that dpkg-source --commit
3963 # can work. We do this as follows:
3964 # 1. Collect all relevant .orig from parent directory
3965 # 2. Generate a debian.tar.gz out of
3966 # debian/{patches,rules,source/format,source/options}
3967 # 3. Generate a fake .dsc containing just these fields:
3968 # Format Source Version Files
3969 # 4. Extract the fake .dsc
3970 # Now the fake .dsc has a .pc directory.
3971 # (In fact we do this in every case, because in future we will
3972 # want to search for a good base commit for generating patches.)
3974 # Then we can actually do the dpkg-source --commit
3975 # 1. Make a new working tree with the same object
3976 # store as our main tree and check out the main
3978 # 2. Copy .pc from the fake's extraction, if necessary
3979 # 3. Run dpkg-source --commit
3980 # 4. If the result has changes to debian/, then
3981 # - git-add them them
3982 # - git-add .pc if we had a .pc in-tree
3984 # 5. If we had a .pc in-tree, delete it, and git-commit
3985 # 6. Back in the main tree, fast forward to the new HEAD
3987 # Another situation we may have to cope with is gbp-style
3988 # patches-unapplied trees.
3990 # We would want to detect these, so we know to escape into
3991 # quilt_fixup_gbp. However, this is in general not possible.
3992 # Consider a package with a one patch which the dgit user reverts
3993 # (with git-revert or the moral equivalent).
3995 # That is indistinguishable in contents from a patches-unapplied
3996 # tree. And looking at the history to distinguish them is not
3997 # useful because the user might have made a confusing-looking git
3998 # history structure (which ought to produce an error if dgit can't
3999 # cope, not a silent reintroduction of an unwanted patch).
4001 # So gbp users will have to pass an option. But we can usually
4002 # detect their failure to do so: if the tree is not a clean
4003 # patches-applied tree, quilt linearisation fails, but the tree
4004 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4005 # they want --quilt=unapplied.
4007 # To help detect this, when we are extracting the fake dsc, we
4008 # first extract it with --skip-patches, and then apply the patches
4009 # afterwards with dpkg-source --before-build. That lets us save a
4010 # tree object corresponding to .origs.
4012 my $splitbrain_cachekey;
4014 quilt_make_fake_dsc($upstreamversion);
4016 if (quiltmode_splitbrain()) {
4018 ($cachehit, $splitbrain_cachekey) =
4019 quilt_check_splitbrain_cache($headref, $upstreamversion);
4020 return if $cachehit;
4024 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4026 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4027 rename $fakexdir, "fake" or die "$fakexdir $!";
4031 remove_stray_gits();
4032 mktree_in_ud_here();
4036 runcmd @git, qw(add -Af .);
4037 my $unapplied=git_write_tree();
4038 printdebug "fake orig tree object $unapplied\n";
4043 'exec dpkg-source --before-build . >/dev/null';
4047 quilt_fixup_mkwork($headref);
4050 if (stat_exists ".pc") {
4052 progress "Tree already contains .pc - will use it then delete it.";
4055 rename '../fake/.pc','.pc' or die $!;
4058 changedir '../fake';
4060 runcmd @git, qw(add -Af .);
4061 my $oldtiptree=git_write_tree();
4062 printdebug "fake o+d/p tree object $unapplied\n";
4063 changedir '../work';
4066 # We calculate some guesswork now about what kind of tree this might
4067 # be. This is mostly for error reporting.
4072 # O = orig, without patches applied
4073 # A = "applied", ie orig with H's debian/patches applied
4074 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4075 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4076 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4080 foreach my $b (qw(01 02)) {
4081 foreach my $v (qw(H2O O2A H2A)) {
4082 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4085 printdebug "differences \@dl @dl.\n";
4088 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4089 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4090 $dl[0], $dl[1], $dl[3], $dl[4],
4094 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4095 push @failsuggestion, "This might be a patches-unapplied branch.";
4096 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4097 push @failsuggestion, "This might be a patches-applied branch.";
4099 push @failsuggestion, "Maybe you need to specify one of".
4100 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4102 if (quiltmode_splitbrain()) {
4103 quiltify_splitbrain($clogp, $unapplied, $headref,
4104 $diffbits, \%editedignores,
4105 $splitbrain_cachekey);
4109 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4110 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4112 if (!open P, '>>', ".pc/applied-patches") {
4113 $!==&ENOENT or die $!;
4118 commit_quilty_patch();
4120 if ($mustdeletepc) {
4121 quilt_fixup_delete_pc();
4125 sub quilt_fixup_editor () {
4126 my $descfn = $ENV{$fakeeditorenv};
4127 my $editing = $ARGV[$#ARGV];
4128 open I1, '<', $descfn or die "$descfn: $!";
4129 open I2, '<', $editing or die "$editing: $!";
4130 unlink $editing or die "$editing: $!";
4131 open O, '>', $editing or die "$editing: $!";
4132 while (<I1>) { print O or die $!; } I1->error and die $!;
4135 $copying ||= m/^\-\-\- /;
4136 next unless $copying;
4139 I2->error and die $!;
4144 sub maybe_apply_patches_dirtily () {
4145 return unless $quilt_mode =~ m/gbp|unapplied/;
4146 print STDERR <<END or die $!;
4148 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4149 dgit: Have to apply the patches - making the tree dirty.
4150 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4153 $patches_applied_dirtily = 01;
4154 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4155 runcmd qw(dpkg-source --before-build .);
4158 sub maybe_unapply_patches_again () {
4159 progress "dgit: Unapplying patches again to tidy up the tree."
4160 if $patches_applied_dirtily;
4161 runcmd qw(dpkg-source --after-build .)
4162 if $patches_applied_dirtily & 01;
4164 if $patches_applied_dirtily & 02;
4165 $patches_applied_dirtily = 0;
4168 #----- other building -----
4170 our $clean_using_builder;
4171 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4172 # clean the tree before building (perhaps invoked indirectly by
4173 # whatever we are using to run the build), rather than separately
4174 # and explicitly by us.
4177 return if $clean_using_builder;
4178 if ($cleanmode eq 'dpkg-source') {
4179 maybe_apply_patches_dirtily();
4180 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4181 } elsif ($cleanmode eq 'dpkg-source-d') {
4182 maybe_apply_patches_dirtily();
4183 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4184 } elsif ($cleanmode eq 'git') {
4185 runcmd_ordryrun_local @git, qw(clean -xdf);
4186 } elsif ($cleanmode eq 'git-ff') {
4187 runcmd_ordryrun_local @git, qw(clean -xdff);
4188 } elsif ($cleanmode eq 'check') {
4189 my $leftovers = cmdoutput @git, qw(clean -xdn);
4190 if (length $leftovers) {
4191 print STDERR $leftovers, "\n" or die $!;
4192 fail "tree contains uncommitted files and --clean=check specified";
4194 } elsif ($cleanmode eq 'none') {
4201 badusage "clean takes no additional arguments" if @ARGV;
4204 maybe_unapply_patches_again();
4209 badusage "-p is not allowed when building" if defined $package;
4212 my $clogp = parsechangelog();
4213 $isuite = getfield $clogp, 'Distribution';
4214 $package = getfield $clogp, 'Source';
4215 $version = getfield $clogp, 'Version';
4216 build_maybe_quilt_fixup();
4218 my $pat = changespat $version;
4219 foreach my $f (glob "$buildproductsdir/$pat") {
4221 unlink $f or fail "remove old changes file $f: $!";
4223 progress "would remove $f";
4229 sub changesopts_initial () {
4230 my @opts =@changesopts[1..$#changesopts];
4233 sub changesopts_version () {
4234 if (!defined $changes_since_version) {
4235 my @vsns = archive_query('archive_query');
4236 my @quirk = access_quirk();
4237 if ($quirk[0] eq 'backports') {
4238 local $isuite = $quirk[2];
4240 canonicalise_suite();
4241 push @vsns, archive_query('archive_query');
4244 @vsns = map { $_->[0] } @vsns;
4245 @vsns = sort { -version_compare($a, $b) } @vsns;
4246 $changes_since_version = $vsns[0];
4247 progress "changelog will contain changes since $vsns[0]";
4249 $changes_since_version = '_';
4250 progress "package seems new, not specifying -v<version>";
4253 if ($changes_since_version ne '_') {
4254 return ("-v$changes_since_version");
4260 sub changesopts () {
4261 return (changesopts_initial(), changesopts_version());
4264 sub massage_dbp_args ($;$) {
4265 my ($cmd,$xargs) = @_;
4268 # - if we're going to split the source build out so we can
4269 # do strange things to it, massage the arguments to dpkg-buildpackage
4270 # so that the main build doessn't build source (or add an argument
4271 # to stop it building source by default).
4273 # - add -nc to stop dpkg-source cleaning the source tree,
4274 # unless we're not doing a split build and want dpkg-source
4275 # as cleanmode, in which case we can do nothing
4278 # 0 - source will NOT need to be built separately by caller
4279 # +1 - source will need to be built separately by caller
4280 # +2 - source will need to be built separately by caller AND
4281 # dpkg-buildpackage should not in fact be run at all!
4282 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4283 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4284 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4285 $clean_using_builder = 1;
4288 # -nc has the side effect of specifying -b if nothing else specified
4289 # and some combinations of -S, -b, et al, are errors, rather than
4290 # later simply overriding earlie. So we need to:
4291 # - search the command line for these options
4292 # - pick the last one
4293 # - perhaps add our own as a default
4294 # - perhaps adjust it to the corresponding non-source-building version
4296 foreach my $l ($cmd, $xargs) {
4298 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4301 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4303 if ($need_split_build_invocation) {
4304 printdebug "massage split $dmode.\n";
4305 $r = $dmode =~ m/[S]/ ? +2 :
4306 $dmode =~ y/gGF/ABb/ ? +1 :
4307 $dmode =~ m/[ABb]/ ? 0 :
4310 printdebug "massage done $r $dmode.\n";
4312 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4317 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4318 my $wantsrc = massage_dbp_args \@dbp;
4325 push @dbp, changesopts_version();
4326 maybe_apply_patches_dirtily();
4327 runcmd_ordryrun_local @dbp;
4329 maybe_unapply_patches_again();
4330 printdone "build successful\n";
4334 my @dbp = @dpkgbuildpackage;
4336 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4339 if (length executable_on_path('git-buildpackage')) {
4340 @cmd = qw(git-buildpackage);
4342 @cmd = qw(gbp buildpackage);
4344 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4349 if (!$clean_using_builder) {
4350 push @cmd, '--git-cleaner=true';
4354 maybe_unapply_patches_again();
4356 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4357 canonicalise_suite();
4358 push @cmd, "--git-debian-branch=".lbranch();
4360 push @cmd, changesopts();
4361 runcmd_ordryrun_local @cmd, @ARGV;
4363 printdone "build successful\n";
4365 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4368 my $our_cleanmode = $cleanmode;
4369 if ($need_split_build_invocation) {
4370 # Pretend that clean is being done some other way. This
4371 # forces us not to try to use dpkg-buildpackage to clean and
4372 # build source all in one go; and instead we run dpkg-source
4373 # (and build_prep() will do the clean since $clean_using_builder
4375 $our_cleanmode = 'ELSEWHERE';
4377 if ($our_cleanmode =~ m/^dpkg-source/) {
4378 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4379 $clean_using_builder = 1;
4382 $sourcechanges = changespat $version,'source';
4384 unlink "../$sourcechanges" or $!==ENOENT
4385 or fail "remove $sourcechanges: $!";
4387 $dscfn = dscfn($version);
4388 if ($our_cleanmode eq 'dpkg-source') {
4389 maybe_apply_patches_dirtily();
4390 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4392 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4393 maybe_apply_patches_dirtily();
4394 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4397 my @cmd = (@dpkgsource, qw(-b --));
4400 runcmd_ordryrun_local @cmd, "work";
4401 my @udfiles = <${package}_*>;
4402 changedir "../../..";
4403 foreach my $f (@udfiles) {
4404 printdebug "source copy, found $f\n";
4407 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4408 $f eq srcfn($version, $&));
4409 printdebug "source copy, found $f - renaming\n";
4410 rename "$ud/$f", "../$f" or $!==ENOENT
4411 or fail "put in place new source file ($f): $!";
4414 my $pwd = must_getcwd();
4415 my $leafdir = basename $pwd;
4417 runcmd_ordryrun_local @cmd, $leafdir;
4420 runcmd_ordryrun_local qw(sh -ec),
4421 'exec >$1; shift; exec "$@"','x',
4422 "../$sourcechanges",
4423 @dpkggenchanges, qw(-S), changesopts();
4427 sub cmd_build_source {
4428 badusage "build-source takes no additional arguments" if @ARGV;
4430 maybe_unapply_patches_again();
4431 printdone "source built, results in $dscfn and $sourcechanges";
4436 my $pat = changespat $version;
4438 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4439 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4440 fail "changes files other than source matching $pat".
4441 " already present (@unwanted);".
4442 " building would result in ambiguity about the intended results"
4445 my $wasdir = must_getcwd();
4448 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4449 stat_exists $sourcechanges
4450 or fail "$sourcechanges (in parent directory): $!";
4452 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4453 my @changesfiles = glob $pat;
4454 @changesfiles = sort {
4455 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4458 fail "wrong number of different changes files (@changesfiles)"
4459 unless @changesfiles==2;
4460 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4461 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4462 fail "$l found in binaries changes file $binchanges"
4465 runcmd_ordryrun_local @mergechanges, @changesfiles;
4466 my $multichanges = changespat $version,'multi';
4468 stat_exists $multichanges or fail "$multichanges: $!";
4469 foreach my $cf (glob $pat) {
4470 next if $cf eq $multichanges;
4471 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4475 maybe_unapply_patches_again();
4476 printdone "build successful, results in $multichanges\n" or die $!;
4479 sub cmd_quilt_fixup {
4480 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4481 my $clogp = parsechangelog();
4482 $version = getfield $clogp, 'Version';
4483 $package = getfield $clogp, 'Source';
4486 build_maybe_quilt_fixup();
4489 sub cmd_archive_api_query {
4490 badusage "need only 1 subpath argument" unless @ARGV==1;
4491 my ($subpath) = @ARGV;
4492 my @cmd = archive_api_query_cmd($subpath);
4494 exec @cmd or fail "exec curl: $!\n";
4497 sub cmd_clone_dgit_repos_server {
4498 badusage "need destination argument" unless @ARGV==1;
4499 my ($destdir) = @ARGV;
4500 $package = '_dgit-repos-server';
4501 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4503 exec @cmd or fail "exec git clone: $!\n";
4506 sub cmd_setup_mergechangelogs {
4507 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4508 setup_mergechangelogs(1);
4511 sub cmd_setup_useremail {
4512 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4516 sub cmd_setup_new_tree {
4517 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4521 #---------- argument parsing and main program ----------
4524 print "dgit version $our_version\n" or die $!;
4528 our (%valopts_long, %valopts_short);
4531 sub defvalopt ($$$$) {
4532 my ($long,$short,$val_re,$how) = @_;
4533 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4534 $valopts_long{$long} = $oi;
4535 $valopts_short{$short} = $oi;
4536 # $how subref should:
4537 # do whatever assignemnt or thing it likes with $_[0]
4538 # if the option should not be passed on to remote, @rvalopts=()
4539 # or $how can be a scalar ref, meaning simply assign the value
4542 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4543 defvalopt '--distro', '-d', '.+', \$idistro;
4544 defvalopt '', '-k', '.+', \$keyid;
4545 defvalopt '--existing-package','', '.*', \$existing_package;
4546 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4547 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4548 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4550 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4552 defvalopt '', '-C', '.+', sub {
4553 ($changesfile) = (@_);
4554 if ($changesfile =~ s#^(.*)/##) {
4555 $buildproductsdir = $1;
4559 defvalopt '--initiator-tempdir','','.*', sub {
4560 ($initiator_tempdir) = (@_);
4561 $initiator_tempdir =~ m#^/# or
4562 badusage "--initiator-tempdir must be used specify an".
4563 " absolute, not relative, directory."
4569 if (defined $ENV{'DGIT_SSH'}) {
4570 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4571 } elsif (defined $ENV{'GIT_SSH'}) {
4572 @ssh = ($ENV{'GIT_SSH'});
4580 if (!defined $val) {
4581 badusage "$what needs a value" unless @ARGV;
4583 push @rvalopts, $val;
4585 badusage "bad value \`$val' for $what" unless
4586 $val =~ m/^$oi->{Re}$(?!\n)/s;
4587 my $how = $oi->{How};
4588 if (ref($how) eq 'SCALAR') {
4593 push @ropts, @rvalopts;
4597 last unless $ARGV[0] =~ m/^-/;
4601 if (m/^--dry-run$/) {
4604 } elsif (m/^--damp-run$/) {
4607 } elsif (m/^--no-sign$/) {
4610 } elsif (m/^--help$/) {
4612 } elsif (m/^--version$/) {
4614 } elsif (m/^--new$/) {
4617 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4618 ($om = $opts_opt_map{$1}) &&
4622 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4623 !$opts_opt_cmdonly{$1} &&
4624 ($om = $opts_opt_map{$1})) {
4627 } elsif (m/^--ignore-dirty$/s) {
4630 } elsif (m/^--no-quilt-fixup$/s) {
4632 $quilt_mode = 'nocheck';
4633 } elsif (m/^--no-rm-on-error$/s) {
4636 } elsif (m/^--overwrite$/s) {
4638 $overwrite_version = '';
4639 } elsif (m/^--overwrite=(.+)$/s) {
4641 $overwrite_version = $1;
4642 } elsif (m/^--(no-)?rm-old-changes$/s) {
4645 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4647 push @deliberatelies, $&;
4648 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4649 # undocumented, for testing
4651 $tagformat_want = [ $1, 'command line', 1 ];
4652 # 1 menas overrides distro configuration
4653 } elsif (m/^--always-split-source-build$/s) {
4654 # undocumented, for testing
4656 $need_split_build_invocation = 1;
4657 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4658 $val = $2 ? $' : undef; #';
4659 $valopt->($oi->{Long});
4661 badusage "unknown long option \`$_'";
4668 } elsif (s/^-L/-/) {
4671 } elsif (s/^-h/-/) {
4673 } elsif (s/^-D/-/) {
4677 } elsif (s/^-N/-/) {
4682 push @changesopts, $_;
4684 } elsif (s/^-wn$//s) {
4686 $cleanmode = 'none';
4687 } elsif (s/^-wg$//s) {
4690 } elsif (s/^-wgf$//s) {
4692 $cleanmode = 'git-ff';
4693 } elsif (s/^-wd$//s) {
4695 $cleanmode = 'dpkg-source';
4696 } elsif (s/^-wdd$//s) {
4698 $cleanmode = 'dpkg-source-d';
4699 } elsif (s/^-wc$//s) {
4701 $cleanmode = 'check';
4702 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4704 $val = undef unless length $val;
4705 $valopt->($oi->{Short});
4708 badusage "unknown short option \`$_'";
4715 sub finalise_opts_opts () {
4716 foreach my $k (keys %opts_opt_map) {
4717 my $om = $opts_opt_map{$k};
4719 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4721 badcfg "cannot set command for $k"
4722 unless length $om->[0];
4726 foreach my $c (access_cfg_cfgs("opts-$k")) {
4727 my $vl = $gitcfg{$c};
4728 printdebug "CL $c ",
4729 ($vl ? join " ", map { shellquote } @$vl : ""),
4730 "\n" if $debuglevel >= 4;
4732 badcfg "cannot configure options for $k"
4733 if $opts_opt_cmdonly{$k};
4734 my $insertpos = $opts_cfg_insertpos{$k};
4735 @$om = ( @$om[0..$insertpos-1],
4737 @$om[$insertpos..$#$om] );
4742 if ($ENV{$fakeeditorenv}) {
4744 quilt_fixup_editor();
4750 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4751 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4752 if $dryrun_level == 1;
4754 print STDERR $helpmsg or die $!;
4757 my $cmd = shift @ARGV;
4760 if (!defined $rmchanges) {
4761 local $access_forpush;
4762 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4765 if (!defined $quilt_mode) {
4766 local $access_forpush;
4767 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4768 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4770 $quilt_mode =~ m/^($quilt_modes_re)$/
4771 or badcfg "unknown quilt-mode \`$quilt_mode'";
4775 $need_split_build_invocation ||= quiltmode_splitbrain();
4777 if (!defined $cleanmode) {
4778 local $access_forpush;
4779 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4780 $cleanmode //= 'dpkg-source';
4782 badcfg "unknown clean-mode \`$cleanmode'" unless
4783 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4786 my $fn = ${*::}{"cmd_$cmd"};
4787 $fn or badusage "unknown operation $cmd";