3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 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);
39 use Text::Glob qw(match_glob);
40 use Fcntl qw(:DEFAULT :flock);
45 our $our_version = 'UNRELEASED'; ###substituted###
46 our $absurdity = undef; ###substituted###
48 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
51 our $isuite = 'unstable';
57 our $dryrun_level = 0;
59 our $buildproductsdir = '..';
65 our $existing_package = 'dpkg';
67 our $changes_since_version;
69 our $overwrite_version; # undef: not specified; '': check changelog
71 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
73 our $dodep14tag_re = 'want|no|always';
74 our $split_brain_save;
75 our $we_are_responder;
76 our $initiator_tempdir;
77 our $patches_applied_dirtily = 00;
82 our %forceopts = map { $_=>0 }
83 qw(unrepresentable unsupported-source-format
84 dsc-changes-mismatch changes-origs-exactly
85 import-gitapply-absurd
86 import-gitapply-no-absurd
87 import-dsc-with-dgit-field);
89 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
91 our $suite_re = '[-+.0-9a-z]+';
92 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
93 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
94 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
95 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
97 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
98 our $splitbraincache = 'dgit-intern/quilt-cache';
99 our $rewritemap = 'dgit-rewrite/map';
101 our (@git) = qw(git);
102 our (@dget) = qw(dget);
103 our (@curl) = qw(curl);
104 our (@dput) = qw(dput);
105 our (@debsign) = qw(debsign);
106 our (@gpg) = qw(gpg);
107 our (@sbuild) = qw(sbuild);
109 our (@dgit) = qw(dgit);
110 our (@aptget) = qw(apt-get);
111 our (@aptcache) = qw(apt-cache);
112 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
113 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
114 our (@dpkggenchanges) = qw(dpkg-genchanges);
115 our (@mergechanges) = qw(mergechanges -f);
116 our (@gbp_build) = ('');
117 our (@gbp_pq) = ('gbp pq');
118 our (@changesopts) = ('');
120 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
123 'debsign' => \@debsign,
125 'sbuild' => \@sbuild,
129 'apt-get' => \@aptget,
130 'apt-cache' => \@aptcache,
131 'dpkg-source' => \@dpkgsource,
132 'dpkg-buildpackage' => \@dpkgbuildpackage,
133 'dpkg-genchanges' => \@dpkggenchanges,
134 'gbp-build' => \@gbp_build,
135 'gbp-pq' => \@gbp_pq,
136 'ch' => \@changesopts,
137 'mergechanges' => \@mergechanges);
139 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
140 our %opts_cfg_insertpos = map {
142 scalar @{ $opts_opt_map{$_} }
143 } keys %opts_opt_map;
145 sub parseopts_late_defaults();
151 our $supplementary_message = '';
152 our $need_split_build_invocation = 0;
153 our $split_brain = 0;
157 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
160 our $remotename = 'dgit';
161 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
165 if (!defined $absurdity) {
167 $absurdity =~ s{/[^/]+$}{/absurd} or die;
171 my ($v,$distro) = @_;
172 return $tagformatfn->($v, $distro);
175 sub debiantag_maintview ($$) {
176 my ($v,$distro) = @_;
177 return "$distro/".dep14_version_mangle $v;
180 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
182 sub lbranch () { return "$branchprefix/$csuite"; }
183 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
184 sub lref () { return "refs/heads/".lbranch(); }
185 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
186 sub rrref () { return server_ref($csuite); }
188 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
189 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
191 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
192 # locally fetched refs because they have unhelpful names and clutter
193 # up gitk etc. So we track whether we have "used up" head ref (ie,
194 # whether we have made another local ref which refers to this object).
196 # (If we deleted them unconditionally, then we might end up
197 # re-fetching the same git objects each time dgit fetch was run.)
199 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
200 # in git_fetch_us to fetch the refs in question, and possibly a call
201 # to lrfetchref_used.
203 our (%lrfetchrefs_f, %lrfetchrefs_d);
204 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
206 sub lrfetchref_used ($) {
207 my ($fullrefname) = @_;
208 my $objid = $lrfetchrefs_f{$fullrefname};
209 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
220 return "${package}_".(stripepoch $vsn).$sfx
225 return srcfn($vsn,".dsc");
228 sub changespat ($;$) {
229 my ($vsn, $arch) = @_;
230 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
233 sub upstreamversion ($) {
245 foreach my $f (@end) {
247 print STDERR "$us: cleanup: $@" if length $@;
251 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
253 sub forceable_fail ($$) {
254 my ($forceoptsl, $msg) = @_;
255 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
256 print STDERR "warning: overriding problem due to --force:\n". $msg;
260 my ($forceoptsl) = @_;
261 my @got = grep { $forceopts{$_} } @$forceoptsl;
262 return 0 unless @got;
264 "warning: skipping checks or functionality due to --force-$got[0]\n";
267 sub no_such_package () {
268 print STDERR "$us: package $package does not exist in suite $isuite\n";
274 printdebug "CD $newdir\n";
275 chdir $newdir or confess "chdir: $newdir: $!";
278 sub deliberately ($) {
280 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
283 sub deliberately_not_fast_forward () {
284 foreach (qw(not-fast-forward fresh-repo)) {
285 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
289 sub quiltmode_splitbrain () {
290 $quilt_mode =~ m/gbp|dpm|unapplied/;
293 sub opts_opt_multi_cmd {
295 push @cmd, split /\s+/, shift @_;
301 return opts_opt_multi_cmd @gbp_pq;
304 #---------- remote protocol support, common ----------
306 # remote push initiator/responder protocol:
307 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
308 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
309 # < dgit-remote-push-ready <actual-proto-vsn>
316 # > supplementary-message NBYTES # $protovsn >= 3
321 # > file parsed-changelog
322 # [indicates that output of dpkg-parsechangelog follows]
323 # > data-block NBYTES
324 # > [NBYTES bytes of data (no newline)]
325 # [maybe some more blocks]
334 # > param head DGIT-VIEW-HEAD
335 # > param csuite SUITE
336 # > param tagformat old|new
337 # > param maint-view MAINT-VIEW-HEAD
339 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
340 # # goes into tag, for replay prevention
343 # [indicates that signed tag is wanted]
344 # < data-block NBYTES
345 # < [NBYTES bytes of data (no newline)]
346 # [maybe some more blocks]
350 # > want signed-dsc-changes
351 # < data-block NBYTES [transfer of signed dsc]
353 # < data-block NBYTES [transfer of signed changes]
361 sub i_child_report () {
362 # Sees if our child has died, and reap it if so. Returns a string
363 # describing how it died if it failed, or undef otherwise.
364 return undef unless $i_child_pid;
365 my $got = waitpid $i_child_pid, WNOHANG;
366 return undef if $got <= 0;
367 die unless $got == $i_child_pid;
368 $i_child_pid = undef;
369 return undef unless $?;
370 return "build host child ".waitstatusmsg();
375 fail "connection lost: $!" if $fh->error;
376 fail "protocol violation; $m not expected";
379 sub badproto_badread ($$) {
381 fail "connection lost: $!" if $!;
382 my $report = i_child_report();
383 fail $report if defined $report;
384 badproto $fh, "eof (reading $wh)";
387 sub protocol_expect (&$) {
388 my ($match, $fh) = @_;
391 defined && chomp or badproto_badread $fh, "protocol message";
399 badproto $fh, "\`$_'";
402 sub protocol_send_file ($$) {
403 my ($fh, $ourfn) = @_;
404 open PF, "<", $ourfn or die "$ourfn: $!";
407 my $got = read PF, $d, 65536;
408 die "$ourfn: $!" unless defined $got;
410 print $fh "data-block ".length($d)."\n" or die $!;
411 print $fh $d or die $!;
413 PF->error and die "$ourfn $!";
414 print $fh "data-end\n" or die $!;
418 sub protocol_read_bytes ($$) {
419 my ($fh, $nbytes) = @_;
420 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
422 my $got = read $fh, $d, $nbytes;
423 $got==$nbytes or badproto_badread $fh, "data block";
427 sub protocol_receive_file ($$) {
428 my ($fh, $ourfn) = @_;
429 printdebug "() $ourfn\n";
430 open PF, ">", $ourfn or die "$ourfn: $!";
432 my ($y,$l) = protocol_expect {
433 m/^data-block (.*)$/ ? (1,$1) :
434 m/^data-end$/ ? (0,) :
438 my $d = protocol_read_bytes $fh, $l;
439 print PF $d or die $!;
444 #---------- remote protocol support, responder ----------
446 sub responder_send_command ($) {
448 return unless $we_are_responder;
449 # called even without $we_are_responder
450 printdebug ">> $command\n";
451 print PO $command, "\n" or die $!;
454 sub responder_send_file ($$) {
455 my ($keyword, $ourfn) = @_;
456 return unless $we_are_responder;
457 printdebug "]] $keyword $ourfn\n";
458 responder_send_command "file $keyword";
459 protocol_send_file \*PO, $ourfn;
462 sub responder_receive_files ($@) {
463 my ($keyword, @ourfns) = @_;
464 die unless $we_are_responder;
465 printdebug "[[ $keyword @ourfns\n";
466 responder_send_command "want $keyword";
467 foreach my $fn (@ourfns) {
468 protocol_receive_file \*PI, $fn;
471 protocol_expect { m/^files-end$/ } \*PI;
474 #---------- remote protocol support, initiator ----------
476 sub initiator_expect (&) {
478 protocol_expect { &$match } \*RO;
481 #---------- end remote code ----------
484 if ($we_are_responder) {
486 responder_send_command "progress ".length($m) or die $!;
487 print PO $m or die $!;
497 $ua = LWP::UserAgent->new();
501 progress "downloading $what...";
502 my $r = $ua->get(@_) or die $!;
503 return undef if $r->code == 404;
504 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
505 return $r->decoded_content(charset => 'none');
508 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
513 failedcmd @_ if system @_;
516 sub act_local () { return $dryrun_level <= 1; }
517 sub act_scary () { return !$dryrun_level; }
520 if (!$dryrun_level) {
521 progress "$us ok: @_";
523 progress "would be ok: @_ (but dry run only)";
528 printcmd(\*STDERR,$debugprefix."#",@_);
531 sub runcmd_ordryrun {
539 sub runcmd_ordryrun_local {
548 my ($first_shell, @cmd) = @_;
549 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
552 our $helpmsg = <<END;
554 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
555 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
556 dgit [dgit-opts] build [dpkg-buildpackage-opts]
557 dgit [dgit-opts] sbuild [sbuild-opts]
558 dgit [dgit-opts] push [dgit-opts] [suite]
559 dgit [dgit-opts] rpush build-host:build-dir ...
560 important dgit options:
561 -k<keyid> sign tag and package with <keyid> instead of default
562 --dry-run -n do not change anything, but go through the motions
563 --damp-run -L like --dry-run but make local changes, without signing
564 --new -N allow introducing a new package
565 --debug -D increase debug level
566 -c<name>=<value> set git config option (used directly by dgit too)
569 our $later_warning_msg = <<END;
570 Perhaps the upload is stuck in incoming. Using the version from git.
574 print STDERR "$us: @_\n", $helpmsg or die $!;
579 @ARGV or badusage "too few arguments";
580 return scalar shift @ARGV;
584 print $helpmsg or die $!;
588 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
590 our %defcfg = ('dgit.default.distro' => 'debian',
591 'dgit-suite.*-security.distro' => 'debian-security',
592 'dgit.default.username' => '',
593 'dgit.default.archive-query-default-component' => 'main',
594 'dgit.default.ssh' => 'ssh',
595 'dgit.default.archive-query' => 'madison:',
596 'dgit.default.sshpsql-dbname' => 'service=projectb',
597 'dgit.default.aptget-components' => 'main',
598 'dgit.default.dgit-tag-format' => 'new,old,maint',
599 # old means "repo server accepts pushes with old dgit tags"
600 # new means "repo server accepts pushes with new dgit tags"
601 # maint means "repo server accepts split brain pushes"
602 # hist means "repo server may have old pushes without new tag"
603 # ("hist" is implied by "old")
604 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
605 'dgit-distro.debian.git-check' => 'url',
606 'dgit-distro.debian.git-check-suffix' => '/info/refs',
607 'dgit-distro.debian.new-private-pushers' => 't',
608 'dgit-distro.debian/push.git-url' => '',
609 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
610 'dgit-distro.debian/push.git-user-force' => 'dgit',
611 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
612 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
613 'dgit-distro.debian/push.git-create' => 'true',
614 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
615 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
616 # 'dgit-distro.debian.archive-query-tls-key',
617 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
618 # ^ this does not work because curl is broken nowadays
619 # Fixing #790093 properly will involve providing providing the key
620 # in some pacagke and maybe updating these paths.
622 # 'dgit-distro.debian.archive-query-tls-curl-args',
623 # '--ca-path=/etc/ssl/ca-debian',
624 # ^ this is a workaround but works (only) on DSA-administered machines
625 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
626 'dgit-distro.debian.git-url-suffix' => '',
627 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
628 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
629 'dgit-distro.debian-security.archive-query' => 'aptget:',
630 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
631 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
632 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
633 'dgit-distro.debian-security.nominal-distro' => 'debian',
634 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
635 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
636 'dgit-distro.ubuntu.git-check' => 'false',
637 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
638 'dgit-distro.test-dummy.ssh' => "$td/ssh",
639 'dgit-distro.test-dummy.username' => "alice",
640 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
641 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
642 'dgit-distro.test-dummy.git-url' => "$td/git",
643 'dgit-distro.test-dummy.git-host' => "git",
644 'dgit-distro.test-dummy.git-path' => "$td/git",
645 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
646 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
647 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
648 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
652 our @gitcfgsources = qw(cmdline local global system);
654 sub git_slurp_config () {
655 local ($debuglevel) = $debuglevel-2;
658 # This algoritm is a bit subtle, but this is needed so that for
659 # options which we want to be single-valued, we allow the
660 # different config sources to override properly. See #835858.
661 foreach my $src (@gitcfgsources) {
662 next if $src eq 'cmdline';
663 # we do this ourselves since git doesn't handle it
665 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
668 open GITS, "-|", @cmd or die $!;
671 printdebug "=> ", (messagequote $_), "\n";
673 push @{ $gitcfgs{$src}{$`} }, $'; #';
677 or ($!==0 && $?==256)
682 sub git_get_config ($) {
684 foreach my $src (@gitcfgsources) {
685 my $l = $gitcfgs{$src}{$c};
686 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
689 @$l==1 or badcfg "multiple values for $c".
690 " (in $src git config)" if @$l > 1;
698 return undef if $c =~ /RETURN-UNDEF/;
699 my $v = git_get_config($c);
700 return $v if defined $v;
701 my $dv = $defcfg{$c};
702 return $dv if defined $dv;
704 badcfg "need value for one of: @_\n".
705 "$us: distro or suite appears not to be (properly) supported";
708 sub access_basedistro () {
709 if (defined $idistro) {
712 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
713 return $def if defined $def;
714 foreach my $src (@gitcfgsources, 'internal') {
715 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
717 foreach my $k (keys %$kl) {
718 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
720 next unless match_glob $dpat, $isuite;
724 return cfg("dgit.default.distro");
728 sub access_nomdistro () {
729 my $base = access_basedistro();
730 return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
733 sub access_quirk () {
734 # returns (quirk name, distro to use instead or undef, quirk-specific info)
735 my $basedistro = access_basedistro();
736 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
738 if (defined $backports_quirk) {
739 my $re = $backports_quirk;
740 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
742 $re =~ s/\%/([-0-9a-z_]+)/
743 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
744 if ($isuite =~ m/^$re$/) {
745 return ('backports',"$basedistro-backports",$1);
748 return ('none',undef);
753 sub parse_cfg_bool ($$$) {
754 my ($what,$def,$v) = @_;
757 $v =~ m/^[ty1]/ ? 1 :
758 $v =~ m/^[fn0]/ ? 0 :
759 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
762 sub access_forpush_config () {
763 my $d = access_basedistro();
767 parse_cfg_bool('new-private-pushers', 0,
768 cfg("dgit-distro.$d.new-private-pushers",
771 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
774 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
775 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
776 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
777 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
780 sub access_forpush () {
781 $access_forpush //= access_forpush_config();
782 return $access_forpush;
786 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
787 badcfg "pushing but distro is configured readonly"
788 if access_forpush_config() eq '0';
790 $supplementary_message = <<'END' unless $we_are_responder;
791 Push failed, before we got started.
792 You can retry the push, after fixing the problem, if you like.
794 parseopts_late_defaults();
798 parseopts_late_defaults();
801 sub supplementary_message ($) {
803 if (!$we_are_responder) {
804 $supplementary_message = $msg;
806 } elsif ($protovsn >= 3) {
807 responder_send_command "supplementary-message ".length($msg)
809 print PO $msg or die $!;
813 sub access_distros () {
814 # Returns list of distros to try, in order
817 # 0. `instead of' distro name(s) we have been pointed to
818 # 1. the access_quirk distro, if any
819 # 2a. the user's specified distro, or failing that } basedistro
820 # 2b. the distro calculated from the suite }
821 my @l = access_basedistro();
823 my (undef,$quirkdistro) = access_quirk();
824 unshift @l, $quirkdistro;
825 unshift @l, $instead_distro;
826 @l = grep { defined } @l;
828 push @l, access_nomdistro();
830 if (access_forpush()) {
831 @l = map { ("$_/push", $_) } @l;
836 sub access_cfg_cfgs (@) {
839 # The nesting of these loops determines the search order. We put
840 # the key loop on the outside so that we search all the distros
841 # for each key, before going on to the next key. That means that
842 # if access_cfg is called with a more specific, and then a less
843 # specific, key, an earlier distro can override the less specific
844 # without necessarily overriding any more specific keys. (If the
845 # distro wants to override the more specific keys it can simply do
846 # so; whereas if we did the loop the other way around, it would be
847 # impossible to for an earlier distro to override a less specific
848 # key but not the more specific ones without restating the unknown
849 # values of the more specific keys.
852 # We have to deal with RETURN-UNDEF specially, so that we don't
853 # terminate the search prematurely.
855 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
858 foreach my $d (access_distros()) {
859 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
861 push @cfgs, map { "dgit.default.$_" } @realkeys;
868 my (@cfgs) = access_cfg_cfgs(@keys);
869 my $value = cfg(@cfgs);
873 sub access_cfg_bool ($$) {
874 my ($def, @keys) = @_;
875 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
878 sub string_to_ssh ($) {
880 if ($spec =~ m/\s/) {
881 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
887 sub access_cfg_ssh () {
888 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
889 if (!defined $gitssh) {
892 return string_to_ssh $gitssh;
896 sub access_runeinfo ($) {
898 return ": dgit ".access_basedistro()." $info ;";
901 sub access_someuserhost ($) {
903 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
904 defined($user) && length($user) or
905 $user = access_cfg("$some-user",'username');
906 my $host = access_cfg("$some-host");
907 return length($user) ? "$user\@$host" : $host;
910 sub access_gituserhost () {
911 return access_someuserhost('git');
914 sub access_giturl (;$) {
916 my $url = access_cfg('git-url','RETURN-UNDEF');
919 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
920 return undef unless defined $proto;
923 access_gituserhost().
924 access_cfg('git-path');
926 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
929 return "$url/$package$suffix";
932 sub parsecontrolfh ($$;$) {
933 my ($fh, $desc, $allowsigned) = @_;
934 our $dpkgcontrolhash_noissigned;
937 my %opts = ('name' => $desc);
938 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
939 $c = Dpkg::Control::Hash->new(%opts);
940 $c->parse($fh,$desc) or die "parsing of $desc failed";
941 last if $allowsigned;
942 last if $dpkgcontrolhash_noissigned;
943 my $issigned= $c->get_option('is_pgp_signed');
944 if (!defined $issigned) {
945 $dpkgcontrolhash_noissigned= 1;
946 seek $fh, 0,0 or die "seek $desc: $!";
947 } elsif ($issigned) {
948 fail "control file $desc is (already) PGP-signed. ".
949 " Note that dgit push needs to modify the .dsc and then".
950 " do the signature itself";
959 my ($file, $desc, $allowsigned) = @_;
960 my $fh = new IO::Handle;
961 open $fh, '<', $file or die "$file: $!";
962 my $c = parsecontrolfh($fh,$desc,$allowsigned);
963 $fh->error and die $!;
969 my ($dctrl,$field) = @_;
970 my $v = $dctrl->{$field};
971 return $v if defined $v;
972 fail "missing field $field in ".$dctrl->get_option('name');
976 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
977 my $p = new IO::Handle;
978 my @cmd = (qw(dpkg-parsechangelog), @_);
979 open $p, '-|', @cmd or die $!;
981 $?=0; $!=0; close $p or failedcmd @cmd;
985 sub commit_getclogp ($) {
986 # Returns the parsed changelog hashref for a particular commit
988 our %commit_getclogp_memo;
989 my $memo = $commit_getclogp_memo{$objid};
990 return $memo if $memo;
992 my $mclog = ".git/dgit/clog-$objid";
993 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
994 "$objid:debian/changelog";
995 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1000 defined $d or fail "getcwd failed: $!";
1004 sub parse_dscdata () {
1005 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1006 printdebug Dumper($dscdata) if $debuglevel>1;
1007 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1008 printdebug Dumper($dsc) if $debuglevel>1;
1013 sub archive_query ($;@) {
1014 my ($method) = shift @_;
1015 fail "this operation does not support multiple comma-separated suites"
1017 my $query = access_cfg('archive-query','RETURN-UNDEF');
1018 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1021 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1024 sub archive_query_prepend_mirror {
1025 my $m = access_cfg('mirror');
1026 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1029 sub pool_dsc_subpath ($$) {
1030 my ($vsn,$component) = @_; # $package is implict arg
1031 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1032 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1035 sub cfg_apply_map ($$$) {
1036 my ($varref, $what, $mapspec) = @_;
1037 return unless $mapspec;
1039 printdebug "config $what EVAL{ $mapspec; }\n";
1041 eval "package Dgit::Config; $mapspec;";
1046 #---------- `ftpmasterapi' archive query method (nascent) ----------
1048 sub archive_api_query_cmd ($) {
1050 my @cmd = (@curl, qw(-sS));
1051 my $url = access_cfg('archive-query-url');
1052 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1054 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1055 foreach my $key (split /\:/, $keys) {
1056 $key =~ s/\%HOST\%/$host/g;
1058 fail "for $url: stat $key: $!" unless $!==ENOENT;
1061 fail "config requested specific TLS key but do not know".
1062 " how to get curl to use exactly that EE key ($key)";
1063 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1064 # # Sadly the above line does not work because of changes
1065 # # to gnutls. The real fix for #790093 may involve
1066 # # new curl options.
1069 # Fixing #790093 properly will involve providing a value
1070 # for this on clients.
1071 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1072 push @cmd, split / /, $kargs if defined $kargs;
1074 push @cmd, $url.$subpath;
1078 sub api_query ($$;$) {
1080 my ($data, $subpath, $ok404) = @_;
1081 badcfg "ftpmasterapi archive query method takes no data part"
1083 my @cmd = archive_api_query_cmd($subpath);
1084 my $url = $cmd[$#cmd];
1085 push @cmd, qw(-w %{http_code});
1086 my $json = cmdoutput @cmd;
1087 unless ($json =~ s/\d+\d+\d$//) {
1088 failedcmd_report_cmd undef, @cmd;
1089 fail "curl failed to print 3-digit HTTP code";
1092 return undef if $code eq '404' && $ok404;
1093 fail "fetch of $url gave HTTP code $code"
1094 unless $url =~ m#^file://# or $code =~ m/^2/;
1095 return decode_json($json);
1098 sub canonicalise_suite_ftpmasterapi {
1099 my ($proto,$data) = @_;
1100 my $suites = api_query($data, 'suites');
1102 foreach my $entry (@$suites) {
1104 my $v = $entry->{$_};
1105 defined $v && $v eq $isuite;
1106 } qw(codename name);
1107 push @matched, $entry;
1109 fail "unknown suite $isuite" unless @matched;
1112 @matched==1 or die "multiple matches for suite $isuite\n";
1113 $cn = "$matched[0]{codename}";
1114 defined $cn or die "suite $isuite info has no codename\n";
1115 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1117 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1122 sub archive_query_ftpmasterapi {
1123 my ($proto,$data) = @_;
1124 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1126 my $digester = Digest::SHA->new(256);
1127 foreach my $entry (@$info) {
1129 my $vsn = "$entry->{version}";
1130 my ($ok,$msg) = version_check $vsn;
1131 die "bad version: $msg\n" unless $ok;
1132 my $component = "$entry->{component}";
1133 $component =~ m/^$component_re$/ or die "bad component";
1134 my $filename = "$entry->{filename}";
1135 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1136 or die "bad filename";
1137 my $sha256sum = "$entry->{sha256sum}";
1138 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1139 push @rows, [ $vsn, "/pool/$component/$filename",
1140 $digester, $sha256sum ];
1142 die "bad ftpmaster api response: $@\n".Dumper($entry)
1145 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1146 return archive_query_prepend_mirror @rows;
1149 sub file_in_archive_ftpmasterapi {
1150 my ($proto,$data,$filename) = @_;
1151 my $pat = $filename;
1154 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1155 my $info = api_query($data, "file_in_archive/$pat", 1);
1158 #---------- `aptget' archive query method ----------
1161 our $aptget_releasefile;
1162 our $aptget_configpath;
1164 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1165 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1167 sub aptget_cache_clean {
1168 runcmd_ordryrun_local qw(sh -ec),
1169 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1173 sub aptget_lock_acquire () {
1174 my $lockfile = "$aptget_base/lock";
1175 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1176 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1179 sub aptget_prep ($) {
1181 return if defined $aptget_base;
1183 badcfg "aptget archive query method takes no data part"
1186 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1189 ensuredir "$cache/dgit";
1191 access_cfg('aptget-cachekey','RETURN-UNDEF')
1192 // access_nomdistro();
1194 $aptget_base = "$cache/dgit/aptget";
1195 ensuredir $aptget_base;
1197 my $quoted_base = $aptget_base;
1198 die "$quoted_base contains bad chars, cannot continue"
1199 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1201 ensuredir $aptget_base;
1203 aptget_lock_acquire();
1205 aptget_cache_clean();
1207 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1208 my $sourceslist = "source.list#$cachekey";
1210 my $aptsuites = $isuite;
1211 cfg_apply_map(\$aptsuites, 'suite map',
1212 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1214 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1215 printf SRCS "deb-src %s %s %s\n",
1216 access_cfg('mirror'),
1218 access_cfg('aptget-components')
1221 ensuredir "$aptget_base/cache";
1222 ensuredir "$aptget_base/lists";
1224 open CONF, ">", $aptget_configpath or die $!;
1226 Debug::NoLocking "true";
1227 APT::Get::List-Cleanup "false";
1228 #clear APT::Update::Post-Invoke-Success;
1229 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1230 Dir::State::Lists "$quoted_base/lists";
1231 Dir::Etc::preferences "$quoted_base/preferences";
1232 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1233 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1236 foreach my $key (qw(
1239 Dir::Cache::Archives
1240 Dir::Etc::SourceParts
1241 Dir::Etc::preferencesparts
1243 ensuredir "$aptget_base/$key";
1244 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1247 my $oldatime = (time // die $!) - 1;
1248 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1249 next unless stat_exists $oldlist;
1250 my ($mtime) = (stat _)[9];
1251 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1254 runcmd_ordryrun_local aptget_aptget(), qw(update);
1257 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1258 next unless stat_exists $oldlist;
1259 my ($atime) = (stat _)[8];
1260 next if $atime == $oldatime;
1261 push @releasefiles, $oldlist;
1263 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1264 @releasefiles = @inreleasefiles if @inreleasefiles;
1265 die "apt updated wrong number of Release files (@releasefiles), erk"
1266 unless @releasefiles == 1;
1268 ($aptget_releasefile) = @releasefiles;
1271 sub canonicalise_suite_aptget {
1272 my ($proto,$data) = @_;
1275 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1277 foreach my $name (qw(Codename Suite)) {
1278 my $val = $release->{$name};
1280 printdebug "release file $name: $val\n";
1281 $val =~ m/^$suite_re$/o or fail
1282 "Release file ($aptget_releasefile) specifies intolerable $name";
1283 cfg_apply_map(\$val, 'suite rmap',
1284 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1291 sub archive_query_aptget {
1292 my ($proto,$data) = @_;
1295 ensuredir "$aptget_base/source";
1296 foreach my $old (<$aptget_base/source/*.dsc>) {
1297 unlink $old or die "$old: $!";
1300 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1301 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1302 # avoids apt-get source failing with ambiguous error code
1304 runcmd_ordryrun_local
1305 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1306 aptget_aptget(), qw(--download-only --only-source source), $package;
1308 my @dscs = <$aptget_base/source/*.dsc>;
1309 fail "apt-get source did not produce a .dsc" unless @dscs;
1310 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1312 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1315 my $uri = "file://". uri_escape $dscs[0];
1316 $uri =~ s{\%2f}{/}gi;
1317 return [ (getfield $pre_dsc, 'Version'), $uri ];
1320 #---------- `dummyapicat' archive query method ----------
1322 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1323 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1325 sub file_in_archive_dummycatapi ($$$) {
1326 my ($proto,$data,$filename) = @_;
1327 my $mirror = access_cfg('mirror');
1328 $mirror =~ s#^file://#/# or die "$mirror ?";
1330 my @cmd = (qw(sh -ec), '
1332 find -name "$2" -print0 |
1334 ', qw(x), $mirror, $filename);
1335 debugcmd "-|", @cmd;
1336 open FIA, "-|", @cmd or die $!;
1339 printdebug "| $_\n";
1340 m/^(\w+) (\S+)$/ or die "$_ ?";
1341 push @out, { sha256sum => $1, filename => $2 };
1343 close FIA or die failedcmd @cmd;
1347 #---------- `madison' archive query method ----------
1349 sub archive_query_madison {
1350 return archive_query_prepend_mirror
1351 map { [ @$_[0..1] ] } madison_get_parse(@_);
1354 sub madison_get_parse {
1355 my ($proto,$data) = @_;
1356 die unless $proto eq 'madison';
1357 if (!length $data) {
1358 $data= access_cfg('madison-distro','RETURN-UNDEF');
1359 $data //= access_basedistro();
1361 $rmad{$proto,$data,$package} ||= cmdoutput
1362 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1363 my $rmad = $rmad{$proto,$data,$package};
1366 foreach my $l (split /\n/, $rmad) {
1367 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1368 \s*( [^ \t|]+ )\s* \|
1369 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1370 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1371 $1 eq $package or die "$rmad $package ?";
1378 $component = access_cfg('archive-query-default-component');
1380 $5 eq 'source' or die "$rmad ?";
1381 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1383 return sort { -version_compare($a->[0],$b->[0]); } @out;
1386 sub canonicalise_suite_madison {
1387 # madison canonicalises for us
1388 my @r = madison_get_parse(@_);
1390 "unable to canonicalise suite using package $package".
1391 " which does not appear to exist in suite $isuite;".
1392 " --existing-package may help";
1396 sub file_in_archive_madison { return undef; }
1398 #---------- `sshpsql' archive query method ----------
1401 my ($data,$runeinfo,$sql) = @_;
1402 if (!length $data) {
1403 $data= access_someuserhost('sshpsql').':'.
1404 access_cfg('sshpsql-dbname');
1406 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1407 my ($userhost,$dbname) = ($`,$'); #';
1409 my @cmd = (access_cfg_ssh, $userhost,
1410 access_runeinfo("ssh-psql $runeinfo").
1411 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1412 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1414 open P, "-|", @cmd or die $!;
1417 printdebug(">|$_|\n");
1420 $!=0; $?=0; close P or failedcmd @cmd;
1422 my $nrows = pop @rows;
1423 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1424 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1425 @rows = map { [ split /\|/, $_ ] } @rows;
1426 my $ncols = scalar @{ shift @rows };
1427 die if grep { scalar @$_ != $ncols } @rows;
1431 sub sql_injection_check {
1432 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1435 sub archive_query_sshpsql ($$) {
1436 my ($proto,$data) = @_;
1437 sql_injection_check $isuite, $package;
1438 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1439 SELECT source.version, component.name, files.filename, files.sha256sum
1441 JOIN src_associations ON source.id = src_associations.source
1442 JOIN suite ON suite.id = src_associations.suite
1443 JOIN dsc_files ON dsc_files.source = source.id
1444 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1445 JOIN component ON component.id = files_archive_map.component_id
1446 JOIN files ON files.id = dsc_files.file
1447 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1448 AND source.source='$package'
1449 AND files.filename LIKE '%.dsc';
1451 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1452 my $digester = Digest::SHA->new(256);
1454 my ($vsn,$component,$filename,$sha256sum) = @$_;
1455 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1457 return archive_query_prepend_mirror @rows;
1460 sub canonicalise_suite_sshpsql ($$) {
1461 my ($proto,$data) = @_;
1462 sql_injection_check $isuite;
1463 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1464 SELECT suite.codename
1465 FROM suite where suite_name='$isuite' or codename='$isuite';
1467 @rows = map { $_->[0] } @rows;
1468 fail "unknown suite $isuite" unless @rows;
1469 die "ambiguous $isuite: @rows ?" if @rows>1;
1473 sub file_in_archive_sshpsql ($$$) { return undef; }
1475 #---------- `dummycat' archive query method ----------
1477 sub canonicalise_suite_dummycat ($$) {
1478 my ($proto,$data) = @_;
1479 my $dpath = "$data/suite.$isuite";
1480 if (!open C, "<", $dpath) {
1481 $!==ENOENT or die "$dpath: $!";
1482 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1486 chomp or die "$dpath: $!";
1488 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1492 sub archive_query_dummycat ($$) {
1493 my ($proto,$data) = @_;
1494 canonicalise_suite();
1495 my $dpath = "$data/package.$csuite.$package";
1496 if (!open C, "<", $dpath) {
1497 $!==ENOENT or die "$dpath: $!";
1498 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1506 printdebug "dummycat query $csuite $package $dpath | $_\n";
1507 my @row = split /\s+/, $_;
1508 @row==2 or die "$dpath: $_ ?";
1511 C->error and die "$dpath: $!";
1513 return archive_query_prepend_mirror
1514 sort { -version_compare($a->[0],$b->[0]); } @rows;
1517 sub file_in_archive_dummycat () { return undef; }
1519 #---------- tag format handling ----------
1521 sub access_cfg_tagformats () {
1522 split /\,/, access_cfg('dgit-tag-format');
1525 sub access_cfg_tagformats_can_splitbrain () {
1526 my %y = map { $_ => 1 } access_cfg_tagformats;
1527 foreach my $needtf (qw(new maint)) {
1528 next if $y{$needtf};
1534 sub need_tagformat ($$) {
1535 my ($fmt, $why) = @_;
1536 fail "need to use tag format $fmt ($why) but also need".
1537 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1538 " - no way to proceed"
1539 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1540 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1543 sub select_tagformat () {
1545 return if $tagformatfn && !$tagformat_want;
1546 die 'bug' if $tagformatfn && $tagformat_want;
1547 # ... $tagformat_want assigned after previous select_tagformat
1549 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1550 printdebug "select_tagformat supported @supported\n";
1552 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1553 printdebug "select_tagformat specified @$tagformat_want\n";
1555 my ($fmt,$why,$override) = @$tagformat_want;
1557 fail "target distro supports tag formats @supported".
1558 " but have to use $fmt ($why)"
1560 or grep { $_ eq $fmt } @supported;
1562 $tagformat_want = undef;
1564 $tagformatfn = ${*::}{"debiantag_$fmt"};
1566 fail "trying to use unknown tag format \`$fmt' ($why) !"
1567 unless $tagformatfn;
1570 #---------- archive query entrypoints and rest of program ----------
1572 sub canonicalise_suite () {
1573 return if defined $csuite;
1574 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1575 $csuite = archive_query('canonicalise_suite');
1576 if ($isuite ne $csuite) {
1577 progress "canonical suite name for $isuite is $csuite";
1579 progress "canonical suite name is $csuite";
1583 sub get_archive_dsc () {
1584 canonicalise_suite();
1585 my @vsns = archive_query('archive_query');
1586 foreach my $vinfo (@vsns) {
1587 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1588 $dscurl = $vsn_dscurl;
1589 $dscdata = url_get($dscurl);
1591 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1596 $digester->add($dscdata);
1597 my $got = $digester->hexdigest();
1599 fail "$dscurl has hash $got but".
1600 " archive told us to expect $digest";
1603 my $fmt = getfield $dsc, 'Format';
1604 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1605 "unsupported source format $fmt, sorry";
1607 $dsc_checked = !!$digester;
1608 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1612 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1615 sub check_for_git ();
1616 sub check_for_git () {
1618 my $how = access_cfg('git-check');
1619 if ($how eq 'ssh-cmd') {
1621 (access_cfg_ssh, access_gituserhost(),
1622 access_runeinfo("git-check $package").
1623 " set -e; cd ".access_cfg('git-path').";".
1624 " if test -d $package.git; then echo 1; else echo 0; fi");
1625 my $r= cmdoutput @cmd;
1626 if (defined $r and $r =~ m/^divert (\w+)$/) {
1628 my ($usedistro,) = access_distros();
1629 # NB that if we are pushing, $usedistro will be $distro/push
1630 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1631 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1632 progress "diverting to $divert (using config for $instead_distro)";
1633 return check_for_git();
1635 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1637 } elsif ($how eq 'url') {
1638 my $prefix = access_cfg('git-check-url','git-url');
1639 my $suffix = access_cfg('git-check-suffix','git-suffix',
1640 'RETURN-UNDEF') // '.git';
1641 my $url = "$prefix/$package$suffix";
1642 my @cmd = (@curl, qw(-sS -I), $url);
1643 my $result = cmdoutput @cmd;
1644 $result =~ s/^\S+ 200 .*\n\r?\n//;
1645 # curl -sS -I with https_proxy prints
1646 # HTTP/1.0 200 Connection established
1647 $result =~ m/^\S+ (404|200) /s or
1648 fail "unexpected results from git check query - ".
1649 Dumper($prefix, $result);
1651 if ($code eq '404') {
1653 } elsif ($code eq '200') {
1658 } elsif ($how eq 'true') {
1660 } elsif ($how eq 'false') {
1663 badcfg "unknown git-check \`$how'";
1667 sub create_remote_git_repo () {
1668 my $how = access_cfg('git-create');
1669 if ($how eq 'ssh-cmd') {
1671 (access_cfg_ssh, access_gituserhost(),
1672 access_runeinfo("git-create $package").
1673 "set -e; cd ".access_cfg('git-path').";".
1674 " cp -a _template $package.git");
1675 } elsif ($how eq 'true') {
1678 badcfg "unknown git-create \`$how'";
1682 our ($dsc_hash,$lastpush_mergeinput);
1684 our $ud = '.git/dgit/unpack';
1694 sub mktree_in_ud_here () {
1695 runcmd qw(git init -q);
1696 runcmd qw(git config gc.auto 0);
1697 rmtree('.git/objects');
1698 symlink '../../../../objects','.git/objects' or die $!;
1701 sub git_write_tree () {
1702 my $tree = cmdoutput @git, qw(write-tree);
1703 $tree =~ m/^\w+$/ or die "$tree ?";
1707 sub git_add_write_tree () {
1708 runcmd @git, qw(add -Af .);
1709 return git_write_tree();
1712 sub remove_stray_gits ($) {
1714 my @gitscmd = qw(find -name .git -prune -print0);
1715 debugcmd "|",@gitscmd;
1716 open GITS, "-|", @gitscmd or die $!;
1721 print STDERR "$us: warning: removing from $what: ",
1722 (messagequote $_), "\n";
1726 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1729 sub mktree_in_ud_from_only_subdir ($;$) {
1730 my ($what,$raw) = @_;
1732 # changes into the subdir
1734 die "expected one subdir but found @dirs ?" unless @dirs==1;
1735 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1739 remove_stray_gits($what);
1740 mktree_in_ud_here();
1742 my ($format, $fopts) = get_source_format();
1743 if (madformat($format)) {
1748 my $tree=git_add_write_tree();
1749 return ($tree,$dir);
1752 our @files_csum_info_fields =
1753 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1754 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1755 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1757 sub dsc_files_info () {
1758 foreach my $csumi (@files_csum_info_fields) {
1759 my ($fname, $module, $method) = @$csumi;
1760 my $field = $dsc->{$fname};
1761 next unless defined $field;
1762 eval "use $module; 1;" or die $@;
1764 foreach (split /\n/, $field) {
1766 m/^(\w+) (\d+) (\S+)$/ or
1767 fail "could not parse .dsc $fname line \`$_'";
1768 my $digester = eval "$module"."->$method;" or die $@;
1773 Digester => $digester,
1778 fail "missing any supported Checksums-* or Files field in ".
1779 $dsc->get_option('name');
1783 map { $_->{Filename} } dsc_files_info();
1786 sub files_compare_inputs (@) {
1791 my $showinputs = sub {
1792 return join "; ", map { $_->get_option('name') } @$inputs;
1795 foreach my $in (@$inputs) {
1797 my $in_name = $in->get_option('name');
1799 printdebug "files_compare_inputs $in_name\n";
1801 foreach my $csumi (@files_csum_info_fields) {
1802 my ($fname) = @$csumi;
1803 printdebug "files_compare_inputs $in_name $fname\n";
1805 my $field = $in->{$fname};
1806 next unless defined $field;
1809 foreach (split /\n/, $field) {
1812 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1813 fail "could not parse $in_name $fname line \`$_'";
1815 printdebug "files_compare_inputs $in_name $fname $f\n";
1819 my $re = \ $record{$f}{$fname};
1821 $fchecked{$f}{$in_name} = 1;
1823 fail "hash or size of $f varies in $fname fields".
1824 " (between: ".$showinputs->().")";
1829 @files = sort @files;
1830 $expected_files //= \@files;
1831 "@$expected_files" eq "@files" or
1832 fail "file list in $in_name varies between hash fields!";
1835 fail "$in_name has no files list field(s)";
1837 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1840 grep { keys %$_ == @$inputs-1 } values %fchecked
1841 or fail "no file appears in all file lists".
1842 " (looked in: ".$showinputs->().")";
1845 sub is_orig_file_in_dsc ($$) {
1846 my ($f, $dsc_files_info) = @_;
1847 return 0 if @$dsc_files_info <= 1;
1848 # One file means no origs, and the filename doesn't have a "what
1849 # part of dsc" component. (Consider versions ending `.orig'.)
1850 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1854 sub is_orig_file_of_vsn ($$) {
1855 my ($f, $upstreamvsn) = @_;
1856 my $base = srcfn $upstreamvsn, '';
1857 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1861 sub changes_update_origs_from_dsc ($$$$) {
1862 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1864 printdebug "checking origs needed ($upstreamvsn)...\n";
1865 $_ = getfield $changes, 'Files';
1866 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1867 fail "cannot find section/priority from .changes Files field";
1868 my $placementinfo = $1;
1870 printdebug "checking origs needed placement '$placementinfo'...\n";
1871 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1872 $l =~ m/\S+$/ or next;
1874 printdebug "origs $file | $l\n";
1875 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1876 printdebug "origs $file is_orig\n";
1877 my $have = archive_query('file_in_archive', $file);
1878 if (!defined $have) {
1880 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1886 printdebug "origs $file \$#\$have=$#$have\n";
1887 foreach my $h (@$have) {
1890 foreach my $csumi (@files_csum_info_fields) {
1891 my ($fname, $module, $method, $archivefield) = @$csumi;
1892 next unless defined $h->{$archivefield};
1893 $_ = $dsc->{$fname};
1894 next unless defined;
1895 m/^(\w+) .* \Q$file\E$/m or
1896 fail ".dsc $fname missing entry for $file";
1897 if ($h->{$archivefield} eq $1) {
1901 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1904 die "$file ".Dumper($h)." ?!" if $same && @differ;
1907 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1910 printdebug "origs $file f.same=$found_same".
1911 " #f._differ=$#found_differ\n";
1912 if (@found_differ && !$found_same) {
1914 "archive contains $file with different checksum",
1917 # Now we edit the changes file to add or remove it
1918 foreach my $csumi (@files_csum_info_fields) {
1919 my ($fname, $module, $method, $archivefield) = @$csumi;
1920 next unless defined $changes->{$fname};
1922 # in archive, delete from .changes if it's there
1923 $changed{$file} = "removed" if
1924 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1925 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1926 # not in archive, but it's here in the .changes
1928 my $dsc_data = getfield $dsc, $fname;
1929 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1931 $extra =~ s/ \d+ /$&$placementinfo /
1932 or die "$fname $extra >$dsc_data< ?"
1933 if $fname eq 'Files';
1934 $changes->{$fname} .= "\n". $extra;
1935 $changed{$file} = "added";
1940 foreach my $file (keys %changed) {
1942 "edited .changes for archive .orig contents: %s %s",
1943 $changed{$file}, $file;
1945 my $chtmp = "$changesfile.tmp";
1946 $changes->save($chtmp);
1948 rename $chtmp,$changesfile or die "$changesfile $!";
1950 progress "[new .changes left in $changesfile]";
1953 progress "$changesfile already has appropriate .orig(s) (if any)";
1957 sub make_commit ($) {
1959 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1962 sub make_commit_text ($) {
1965 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1967 print Dumper($text) if $debuglevel > 1;
1968 my $child = open2($out, $in, @cmd) or die $!;
1971 print $in $text or die $!;
1972 close $in or die $!;
1974 $h =~ m/^\w+$/ or die;
1976 printdebug "=> $h\n";
1979 waitpid $child, 0 == $child or die "$child $!";
1980 $? and failedcmd @cmd;
1984 sub clogp_authline ($) {
1986 my $author = getfield $clogp, 'Maintainer';
1987 $author =~ s#,.*##ms;
1988 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1989 my $authline = "$author $date";
1990 $authline =~ m/$git_authline_re/o or
1991 fail "unexpected commit author line format \`$authline'".
1992 " (was generated from changelog Maintainer field)";
1993 return ($1,$2,$3) if wantarray;
1997 sub vendor_patches_distro ($$) {
1998 my ($checkdistro, $what) = @_;
1999 return unless defined $checkdistro;
2001 my $series = "debian/patches/\L$checkdistro\E.series";
2002 printdebug "checking for vendor-specific $series ($what)\n";
2004 if (!open SERIES, "<", $series) {
2005 die "$series $!" unless $!==ENOENT;
2014 Unfortunately, this source package uses a feature of dpkg-source where
2015 the same source package unpacks to different source code on different
2016 distros. dgit cannot safely operate on such packages on affected
2017 distros, because the meaning of source packages is not stable.
2019 Please ask the distro/maintainer to remove the distro-specific series
2020 files and use a different technique (if necessary, uploading actually
2021 different packages, if different distros are supposed to have
2025 fail "Found active distro-specific series file for".
2026 " $checkdistro ($what): $series, cannot continue";
2028 die "$series $!" if SERIES->error;
2032 sub check_for_vendor_patches () {
2033 # This dpkg-source feature doesn't seem to be documented anywhere!
2034 # But it can be found in the changelog (reformatted):
2036 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2037 # Author: Raphael Hertzog <hertzog@debian.org>
2038 # Date: Sun Oct 3 09:36:48 2010 +0200
2040 # dpkg-source: correctly create .pc/.quilt_series with alternate
2043 # If you have debian/patches/ubuntu.series and you were
2044 # unpacking the source package on ubuntu, quilt was still
2045 # directed to debian/patches/series instead of
2046 # debian/patches/ubuntu.series.
2048 # debian/changelog | 3 +++
2049 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2050 # 2 files changed, 6 insertions(+), 1 deletion(-)
2053 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2054 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2055 "Dpkg::Vendor \`current vendor'");
2056 vendor_patches_distro(access_basedistro(),
2057 "(base) distro being accessed");
2058 vendor_patches_distro(access_nomdistro(),
2059 "(nominal) distro being accessed");
2062 sub generate_commits_from_dsc () {
2063 # See big comment in fetch_from_archive, below.
2064 # See also README.dsc-import.
2068 my @dfi = dsc_files_info();
2069 foreach my $fi (@dfi) {
2070 my $f = $fi->{Filename};
2071 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2073 printdebug "considering linking $f: ";
2075 link_ltarget "../../../../$f", $f
2076 or ((printdebug "($!) "), 0)
2080 printdebug "linked.\n";
2082 complete_file_from_dsc('.', $fi)
2085 if (is_orig_file_in_dsc($f, \@dfi)) {
2086 link $f, "../../../../$f"
2092 # We unpack and record the orig tarballs first, so that we only
2093 # need disk space for one private copy of the unpacked source.
2094 # But we can't make them into commits until we have the metadata
2095 # from the debian/changelog, so we record the tree objects now and
2096 # make them into commits later.
2098 my $upstreamv = upstreamversion $dsc->{version};
2099 my $orig_f_base = srcfn $upstreamv, '';
2101 foreach my $fi (@dfi) {
2102 # We actually import, and record as a commit, every tarball
2103 # (unless there is only one file, in which case there seems
2106 my $f = $fi->{Filename};
2107 printdebug "import considering $f ";
2108 (printdebug "only one dfi\n"), next if @dfi == 1;
2109 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2110 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2114 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2116 printdebug "Y ", (join ' ', map { $_//"(none)" }
2117 $compr_ext, $orig_f_part
2120 my $input = new IO::File $f, '<' or die "$f $!";
2124 if (defined $compr_ext) {
2126 Dpkg::Compression::compression_guess_from_filename $f;
2127 fail "Dpkg::Compression cannot handle file $f in source package"
2128 if defined $compr_ext && !defined $cname;
2130 new Dpkg::Compression::Process compression => $cname;
2131 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2132 my $compr_fh = new IO::Handle;
2133 my $compr_pid = open $compr_fh, "-|" // die $!;
2135 open STDIN, "<&", $input or die $!;
2137 die "dgit (child): exec $compr_cmd[0]: $!\n";
2142 rmtree "_unpack-tar";
2143 mkdir "_unpack-tar" or die $!;
2144 my @tarcmd = qw(tar -x -f -
2145 --no-same-owner --no-same-permissions
2146 --no-acls --no-xattrs --no-selinux);
2147 my $tar_pid = fork // die $!;
2149 chdir "_unpack-tar" or die $!;
2150 open STDIN, "<&", $input or die $!;
2152 die "dgit (child): exec $tarcmd[0]: $!";
2154 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2155 !$? or failedcmd @tarcmd;
2158 (@compr_cmd ? failedcmd @compr_cmd
2160 # finally, we have the results in "tarball", but maybe
2161 # with the wrong permissions
2163 runcmd qw(chmod -R +rwX _unpack-tar);
2164 changedir "_unpack-tar";
2165 remove_stray_gits($f);
2166 mktree_in_ud_here();
2168 my ($tree) = git_add_write_tree();
2169 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2170 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2172 printdebug "one subtree $1\n";
2174 printdebug "multiple subtrees\n";
2177 rmtree "_unpack-tar";
2179 my $ent = [ $f, $tree ];
2181 Orig => !!$orig_f_part,
2182 Sort => (!$orig_f_part ? 2 :
2183 $orig_f_part =~ m/-/g ? 1 :
2191 # put any without "_" first (spec is not clear whether files
2192 # are always in the usual order). Tarballs without "_" are
2193 # the main orig or the debian tarball.
2194 $a->{Sort} <=> $b->{Sort} or
2198 my $any_orig = grep { $_->{Orig} } @tartrees;
2200 my $dscfn = "$package.dsc";
2202 my $treeimporthow = 'package';
2204 open D, ">", $dscfn or die "$dscfn: $!";
2205 print D $dscdata or die "$dscfn: $!";
2206 close D or die "$dscfn: $!";
2207 my @cmd = qw(dpkg-source);
2208 push @cmd, '--no-check' if $dsc_checked;
2209 if (madformat $dsc->{format}) {
2210 push @cmd, '--skip-patches';
2211 $treeimporthow = 'unpatched';
2213 push @cmd, qw(-x --), $dscfn;
2216 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2217 if (madformat $dsc->{format}) {
2218 check_for_vendor_patches();
2222 if (madformat $dsc->{format}) {
2223 my @pcmd = qw(dpkg-source --before-build .);
2224 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2226 $dappliedtree = git_add_write_tree();
2229 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2230 debugcmd "|",@clogcmd;
2231 open CLOGS, "-|", @clogcmd or die $!;
2236 printdebug "import clog search...\n";
2239 my $stanzatext = do { local $/=""; <CLOGS>; };
2240 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2241 last if !defined $stanzatext;
2243 my $desc = "package changelog, entry no.$.";
2244 open my $stanzafh, "<", \$stanzatext or die;
2245 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2246 $clogp //= $thisstanza;
2248 printdebug "import clog $thisstanza->{version} $desc...\n";
2250 last if !$any_orig; # we don't need $r1clogp
2252 # We look for the first (most recent) changelog entry whose
2253 # version number is lower than the upstream version of this
2254 # package. Then the last (least recent) previous changelog
2255 # entry is treated as the one which introduced this upstream
2256 # version and used for the synthetic commits for the upstream
2259 # One might think that a more sophisticated algorithm would be
2260 # necessary. But: we do not want to scan the whole changelog
2261 # file. Stopping when we see an earlier version, which
2262 # necessarily then is an earlier upstream version, is the only
2263 # realistic way to do that. Then, either the earliest
2264 # changelog entry we have seen so far is indeed the earliest
2265 # upload of this upstream version; or there are only changelog
2266 # entries relating to later upstream versions (which is not
2267 # possible unless the changelog and .dsc disagree about the
2268 # version). Then it remains to choose between the physically
2269 # last entry in the file, and the one with the lowest version
2270 # number. If these are not the same, we guess that the
2271 # versions were created in a non-monotic order rather than
2272 # that the changelog entries have been misordered.
2274 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2276 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2277 $r1clogp = $thisstanza;
2279 printdebug "import clog $r1clogp->{version} becomes r1\n";
2281 die $! if CLOGS->error;
2282 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2284 $clogp or fail "package changelog has no entries!";
2286 my $authline = clogp_authline $clogp;
2287 my $changes = getfield $clogp, 'Changes';
2288 my $cversion = getfield $clogp, 'Version';
2291 $r1clogp //= $clogp; # maybe there's only one entry;
2292 my $r1authline = clogp_authline $r1clogp;
2293 # Strictly, r1authline might now be wrong if it's going to be
2294 # unused because !$any_orig. Whatever.
2296 printdebug "import tartrees authline $authline\n";
2297 printdebug "import tartrees r1authline $r1authline\n";
2299 foreach my $tt (@tartrees) {
2300 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2302 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2305 committer $r1authline
2309 [dgit import orig $tt->{F}]
2317 [dgit import tarball $package $cversion $tt->{F}]
2322 printdebug "import main commit\n";
2324 open C, ">../commit.tmp" or die $!;
2325 print C <<END or die $!;
2328 print C <<END or die $! foreach @tartrees;
2331 print C <<END or die $!;
2337 [dgit import $treeimporthow $package $cversion]
2341 my $rawimport_hash = make_commit qw(../commit.tmp);
2343 if (madformat $dsc->{format}) {
2344 printdebug "import apply patches...\n";
2346 # regularise the state of the working tree so that
2347 # the checkout of $rawimport_hash works nicely.
2348 my $dappliedcommit = make_commit_text(<<END);
2355 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2357 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2359 # We need the answers to be reproducible
2360 my @authline = clogp_authline($clogp);
2361 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2362 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2363 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2364 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2365 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2366 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2368 my $path = $ENV{PATH} or die;
2370 foreach my $use_absurd (qw(0 1)) {
2371 runcmd @git, qw(checkout -q unpa);
2372 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2373 local $ENV{PATH} = $path;
2376 progress "warning: $@";
2377 $path = "$absurdity:$path";
2378 progress "$us: trying slow absurd-git-apply...";
2379 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2384 die "forbid absurd git-apply\n" if $use_absurd
2385 && forceing [qw(import-gitapply-no-absurd)];
2386 die "only absurd git-apply!\n" if !$use_absurd
2387 && forceing [qw(import-gitapply-absurd)];
2389 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2390 local $ENV{PATH} = $path if $use_absurd;
2392 my @showcmd = (gbp_pq, qw(import));
2393 my @realcmd = shell_cmd
2394 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2395 debugcmd "+",@realcmd;
2396 if (system @realcmd) {
2397 die +(shellquote @showcmd).
2399 failedcmd_waitstatus()."\n";
2402 my $gapplied = git_rev_parse('HEAD');
2403 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2404 $gappliedtree eq $dappliedtree or
2406 gbp-pq import and dpkg-source disagree!
2407 gbp-pq import gave commit $gapplied
2408 gbp-pq import gave tree $gappliedtree
2409 dpkg-source --before-build gave tree $dappliedtree
2411 $rawimport_hash = $gapplied;
2416 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2421 progress "synthesised git commit from .dsc $cversion";
2423 my $rawimport_mergeinput = {
2424 Commit => $rawimport_hash,
2425 Info => "Import of source package",
2427 my @output = ($rawimport_mergeinput);
2429 if ($lastpush_mergeinput) {
2430 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2431 my $oversion = getfield $oldclogp, 'Version';
2433 version_compare($oversion, $cversion);
2435 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2436 { Message => <<END, ReverseParents => 1 });
2437 Record $package ($cversion) in archive suite $csuite
2439 } elsif ($vcmp > 0) {
2440 print STDERR <<END or die $!;
2442 Version actually in archive: $cversion (older)
2443 Last version pushed with dgit: $oversion (newer or same)
2446 @output = $lastpush_mergeinput;
2448 # Same version. Use what's in the server git branch,
2449 # discarding our own import. (This could happen if the
2450 # server automatically imports all packages into git.)
2451 @output = $lastpush_mergeinput;
2454 changedir '../../../..';
2459 sub complete_file_from_dsc ($$) {
2460 our ($dstdir, $fi) = @_;
2461 # Ensures that we have, in $dir, the file $fi, with the correct
2462 # contents. (Downloading it from alongside $dscurl if necessary.)
2464 my $f = $fi->{Filename};
2465 my $tf = "$dstdir/$f";
2468 if (stat_exists $tf) {
2469 progress "using existing $f";
2471 printdebug "$tf does not exist, need to fetch\n";
2473 $furl =~ s{/[^/]+$}{};
2475 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2476 die "$f ?" if $f =~ m#/#;
2477 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2478 return 0 if !act_local();
2482 open F, "<", "$tf" or die "$tf: $!";
2483 $fi->{Digester}->reset();
2484 $fi->{Digester}->addfile(*F);
2485 F->error and die $!;
2486 my $got = $fi->{Digester}->hexdigest();
2487 $got eq $fi->{Hash} or
2488 fail "file $f has hash $got but .dsc".
2489 " demands hash $fi->{Hash} ".
2490 ($downloaded ? "(got wrong file from archive!)"
2491 : "(perhaps you should delete this file?)");
2496 sub ensure_we_have_orig () {
2497 my @dfi = dsc_files_info();
2498 foreach my $fi (@dfi) {
2499 my $f = $fi->{Filename};
2500 next unless is_orig_file_in_dsc($f, \@dfi);
2501 complete_file_from_dsc('..', $fi)
2506 sub git_fetch_us () {
2507 # Want to fetch only what we are going to use, unless
2508 # deliberately-not-ff, in which case we must fetch everything.
2510 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2512 (quiltmode_splitbrain
2513 ? (map { $_->('*',access_nomdistro) }
2514 \&debiantag_new, \&debiantag_maintview)
2515 : debiantags('*',access_nomdistro));
2516 push @specs, server_branch($csuite);
2517 push @specs, $rewritemap;
2518 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2520 # This is rather miserable:
2521 # When git fetch --prune is passed a fetchspec ending with a *,
2522 # it does a plausible thing. If there is no * then:
2523 # - it matches subpaths too, even if the supplied refspec
2524 # starts refs, and behaves completely madly if the source
2525 # has refs/refs/something. (See, for example, Debian #NNNN.)
2526 # - if there is no matching remote ref, it bombs out the whole
2528 # We want to fetch a fixed ref, and we don't know in advance
2529 # if it exists, so this is not suitable.
2531 # Our workaround is to use git ls-remote. git ls-remote has its
2532 # own qairks. Notably, it has the absurd multi-tail-matching
2533 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2534 # refs/refs/foo etc.
2536 # Also, we want an idempotent snapshot, but we have to make two
2537 # calls to the remote: one to git ls-remote and to git fetch. The
2538 # solution is use git ls-remote to obtain a target state, and
2539 # git fetch to try to generate it. If we don't manage to generate
2540 # the target state, we try again.
2542 printdebug "git_fetch_us specs @specs\n";
2544 my $specre = join '|', map {
2550 printdebug "git_fetch_us specre=$specre\n";
2551 my $wanted_rref = sub {
2553 return m/^(?:$specre)$/o;
2556 my $fetch_iteration = 0;
2559 printdebug "git_fetch_us iteration $fetch_iteration\n";
2560 if (++$fetch_iteration > 10) {
2561 fail "too many iterations trying to get sane fetch!";
2564 my @look = map { "refs/$_" } @specs;
2565 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2569 open GITLS, "-|", @lcmd or die $!;
2571 printdebug "=> ", $_;
2572 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2573 my ($objid,$rrefname) = ($1,$2);
2574 if (!$wanted_rref->($rrefname)) {
2576 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2580 $wantr{$rrefname} = $objid;
2583 close GITLS or failedcmd @lcmd;
2585 # OK, now %want is exactly what we want for refs in @specs
2587 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2588 "+refs/$_:".lrfetchrefs."/$_";
2591 printdebug "git_fetch_us fspecs @fspecs\n";
2593 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2594 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2597 %lrfetchrefs_f = ();
2600 git_for_each_ref(lrfetchrefs, sub {
2601 my ($objid,$objtype,$lrefname,$reftail) = @_;
2602 $lrfetchrefs_f{$lrefname} = $objid;
2603 $objgot{$objid} = 1;
2606 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2607 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2608 if (!exists $wantr{$rrefname}) {
2609 if ($wanted_rref->($rrefname)) {
2611 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2615 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2618 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2619 delete $lrfetchrefs_f{$lrefname};
2623 foreach my $rrefname (sort keys %wantr) {
2624 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2625 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2626 my $want = $wantr{$rrefname};
2627 next if $got eq $want;
2628 if (!defined $objgot{$want}) {
2630 warning: git ls-remote suggests we want $lrefname
2631 warning: and it should refer to $want
2632 warning: but git fetch didn't fetch that object to any relevant ref.
2633 warning: This may be due to a race with someone updating the server.
2634 warning: Will try again...
2636 next FETCH_ITERATION;
2639 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2641 runcmd_ordryrun_local @git, qw(update-ref -m),
2642 "dgit fetch git fetch fixup", $lrefname, $want;
2643 $lrfetchrefs_f{$lrefname} = $want;
2647 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2648 Dumper(\%lrfetchrefs_f);
2651 my @tagpats = debiantags('*',access_nomdistro);
2653 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2654 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2655 printdebug "currently $fullrefname=$objid\n";
2656 $here{$fullrefname} = $objid;
2658 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2659 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2660 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2661 printdebug "offered $lref=$objid\n";
2662 if (!defined $here{$lref}) {
2663 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2664 runcmd_ordryrun_local @upd;
2665 lrfetchref_used $fullrefname;
2666 } elsif ($here{$lref} eq $objid) {
2667 lrfetchref_used $fullrefname;
2670 "Not updateting $lref from $here{$lref} to $objid.\n";
2675 sub mergeinfo_getclogp ($) {
2676 # Ensures thit $mi->{Clogp} exists and returns it
2678 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2681 sub mergeinfo_version ($) {
2682 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2685 sub fetch_from_archive_record_1 ($) {
2687 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2688 'DGIT_ARCHIVE', $hash;
2689 cmdoutput @git, qw(log -n2), $hash;
2690 # ... gives git a chance to complain if our commit is malformed
2693 sub fetch_from_archive_record_2 ($) {
2695 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2699 dryrun_report @upd_cmd;
2703 sub fetch_from_archive () {
2704 ensure_setup_existing_tree();
2706 # Ensures that lrref() is what is actually in the archive, one way
2707 # or another, according to us - ie this client's
2708 # appropritaely-updated archive view. Also returns the commit id.
2709 # If there is nothing in the archive, leaves lrref alone and
2710 # returns undef. git_fetch_us must have already been called.
2714 foreach my $field (@ourdscfield) {
2715 $dsc_hash = $dsc->{$field};
2716 last if defined $dsc_hash;
2718 if (defined $dsc_hash) {
2719 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2721 progress "last upload to archive specified git hash";
2723 progress "last upload to archive has NO git hash";
2726 progress "no version available from the archive";
2729 my $rewritemapdata = git_cat_file lrfetchrefs."/".$rewritemap.':map';
2730 if (defined $rewritemapdata
2731 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2732 progress "server's git history rewrite map contains a relevant entry!";
2734 if (defined $dsc_hash) {
2735 progress "using rewritten git hash in place of .dsc value";
2737 progress "server data says .dsc hash is to be disregarded";
2741 # If the archive's .dsc has a Dgit field, there are three
2742 # relevant git commitids we need to choose between and/or merge
2744 # 1. $dsc_hash: the Dgit field from the archive
2745 # 2. $lastpush_hash: the suite branch on the dgit git server
2746 # 3. $lastfetch_hash: our local tracking brach for the suite
2748 # These may all be distinct and need not be in any fast forward
2751 # If the dsc was pushed to this suite, then the server suite
2752 # branch will have been updated; but it might have been pushed to
2753 # a different suite and copied by the archive. Conversely a more
2754 # recent version may have been pushed with dgit but not appeared
2755 # in the archive (yet).
2757 # $lastfetch_hash may be awkward because archive imports
2758 # (particularly, imports of Dgit-less .dscs) are performed only as
2759 # needed on individual clients, so different clients may perform a
2760 # different subset of them - and these imports are only made
2761 # public during push. So $lastfetch_hash may represent a set of
2762 # imports different to a subsequent upload by a different dgit
2765 # Our approach is as follows:
2767 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2768 # descendant of $dsc_hash, then it was pushed by a dgit user who
2769 # had based their work on $dsc_hash, so we should prefer it.
2770 # Otherwise, $dsc_hash was installed into this suite in the
2771 # archive other than by a dgit push, and (necessarily) after the
2772 # last dgit push into that suite (since a dgit push would have
2773 # been descended from the dgit server git branch); thus, in that
2774 # case, we prefer the archive's version (and produce a
2775 # pseudo-merge to overwrite the dgit server git branch).
2777 # (If there is no Dgit field in the archive's .dsc then
2778 # generate_commit_from_dsc uses the version numbers to decide
2779 # whether the suite branch or the archive is newer. If the suite
2780 # branch is newer it ignores the archive's .dsc; otherwise it
2781 # generates an import of the .dsc, and produces a pseudo-merge to
2782 # overwrite the suite branch with the archive contents.)
2784 # The outcome of that part of the algorithm is the `public view',
2785 # and is same for all dgit clients: it does not depend on any
2786 # unpublished history in the local tracking branch.
2788 # As between the public view and the local tracking branch: The
2789 # local tracking branch is only updated by dgit fetch, and
2790 # whenever dgit fetch runs it includes the public view in the
2791 # local tracking branch. Therefore if the public view is not
2792 # descended from the local tracking branch, the local tracking
2793 # branch must contain history which was imported from the archive
2794 # but never pushed; and, its tip is now out of date. So, we make
2795 # a pseudo-merge to overwrite the old imports and stitch the old
2798 # Finally: we do not necessarily reify the public view (as
2799 # described above). This is so that we do not end up stacking two
2800 # pseudo-merges. So what we actually do is figure out the inputs
2801 # to any public view pseudo-merge and put them in @mergeinputs.
2804 # $mergeinputs[]{Commit}
2805 # $mergeinputs[]{Info}
2806 # $mergeinputs[0] is the one whose tree we use
2807 # @mergeinputs is in the order we use in the actual commit)
2810 # $mergeinputs[]{Message} is a commit message to use
2811 # $mergeinputs[]{ReverseParents} if def specifies that parent
2812 # list should be in opposite order
2813 # Such an entry has no Commit or Info. It applies only when found
2814 # in the last entry. (This ugliness is to support making
2815 # identical imports to previous dgit versions.)
2817 my $lastpush_hash = git_get_ref(lrfetchref());
2818 printdebug "previous reference hash=$lastpush_hash\n";
2819 $lastpush_mergeinput = $lastpush_hash && {
2820 Commit => $lastpush_hash,
2821 Info => "dgit suite branch on dgit git server",
2824 my $lastfetch_hash = git_get_ref(lrref());
2825 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2826 my $lastfetch_mergeinput = $lastfetch_hash && {
2827 Commit => $lastfetch_hash,
2828 Info => "dgit client's archive history view",
2831 my $dsc_mergeinput = $dsc_hash && {
2832 Commit => $dsc_hash,
2833 Info => "Dgit field in .dsc from archive",
2837 my $del_lrfetchrefs = sub {
2840 printdebug "del_lrfetchrefs...\n";
2841 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2842 my $objid = $lrfetchrefs_d{$fullrefname};
2843 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2845 $gur ||= new IO::Handle;
2846 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2848 printf $gur "delete %s %s\n", $fullrefname, $objid;
2851 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2855 if (defined $dsc_hash) {
2856 ensure_we_have_orig();
2857 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2858 @mergeinputs = $dsc_mergeinput
2859 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2860 print STDERR <<END or die $!;
2862 Git commit in archive is behind the last version allegedly pushed/uploaded.
2863 Commit referred to by archive: $dsc_hash
2864 Last version pushed with dgit: $lastpush_hash
2867 @mergeinputs = ($lastpush_mergeinput);
2869 # Archive has .dsc which is not a descendant of the last dgit
2870 # push. This can happen if the archive moves .dscs about.
2871 # Just follow its lead.
2872 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2873 progress "archive .dsc names newer git commit";
2874 @mergeinputs = ($dsc_mergeinput);
2876 progress "archive .dsc names other git commit, fixing up";
2877 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2881 @mergeinputs = generate_commits_from_dsc();
2882 # We have just done an import. Now, our import algorithm might
2883 # have been improved. But even so we do not want to generate
2884 # a new different import of the same package. So if the
2885 # version numbers are the same, just use our existing version.
2886 # If the version numbers are different, the archive has changed
2887 # (perhaps, rewound).
2888 if ($lastfetch_mergeinput &&
2889 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2890 (mergeinfo_version $mergeinputs[0]) )) {
2891 @mergeinputs = ($lastfetch_mergeinput);
2893 } elsif ($lastpush_hash) {
2894 # only in git, not in the archive yet
2895 @mergeinputs = ($lastpush_mergeinput);
2896 print STDERR <<END or die $!;
2898 Package not found in the archive, but has allegedly been pushed using dgit.
2902 printdebug "nothing found!\n";
2903 if (defined $skew_warning_vsn) {
2904 print STDERR <<END or die $!;
2906 Warning: relevant archive skew detected.
2907 Archive allegedly contains $skew_warning_vsn
2908 But we were not able to obtain any version from the archive or git.
2912 unshift @end, $del_lrfetchrefs;
2916 if ($lastfetch_hash &&
2918 my $h = $_->{Commit};
2919 $h and is_fast_fwd($lastfetch_hash, $h);
2920 # If true, one of the existing parents of this commit
2921 # is a descendant of the $lastfetch_hash, so we'll
2922 # be ff from that automatically.
2926 push @mergeinputs, $lastfetch_mergeinput;
2929 printdebug "fetch mergeinfos:\n";
2930 foreach my $mi (@mergeinputs) {
2932 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2934 printdebug sprintf " ReverseParents=%d Message=%s",
2935 $mi->{ReverseParents}, $mi->{Message};
2939 my $compat_info= pop @mergeinputs
2940 if $mergeinputs[$#mergeinputs]{Message};
2942 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2945 if (@mergeinputs > 1) {
2947 my $tree_commit = $mergeinputs[0]{Commit};
2949 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2950 $tree =~ m/\n\n/; $tree = $`;
2951 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2954 # We use the changelog author of the package in question the
2955 # author of this pseudo-merge. This is (roughly) correct if
2956 # this commit is simply representing aa non-dgit upload.
2957 # (Roughly because it does not record sponsorship - but we
2958 # don't have sponsorship info because that's in the .changes,
2959 # which isn't in the archivw.)
2961 # But, it might be that we are representing archive history
2962 # updates (including in-archive copies). These are not really
2963 # the responsibility of the person who created the .dsc, but
2964 # there is no-one whose name we should better use. (The
2965 # author of the .dsc-named commit is clearly worse.)
2967 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2968 my $author = clogp_authline $useclogp;
2969 my $cversion = getfield $useclogp, 'Version';
2971 my $mcf = ".git/dgit/mergecommit";
2972 open MC, ">", $mcf or die "$mcf $!";
2973 print MC <<END or die $!;
2977 my @parents = grep { $_->{Commit} } @mergeinputs;
2978 @parents = reverse @parents if $compat_info->{ReverseParents};
2979 print MC <<END or die $! foreach @parents;
2983 print MC <<END or die $!;
2989 if (defined $compat_info->{Message}) {
2990 print MC $compat_info->{Message} or die $!;
2992 print MC <<END or die $!;
2993 Record $package ($cversion) in archive suite $csuite
2997 my $message_add_info = sub {
2999 my $mversion = mergeinfo_version $mi;
3000 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3004 $message_add_info->($mergeinputs[0]);
3005 print MC <<END or die $!;
3006 should be treated as descended from
3008 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3012 $hash = make_commit $mcf;
3014 $hash = $mergeinputs[0]{Commit};
3016 printdebug "fetch hash=$hash\n";
3019 my ($lasth, $what) = @_;
3020 return unless $lasth;
3021 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3024 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3026 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3028 fetch_from_archive_record_1($hash);
3030 if (defined $skew_warning_vsn) {
3032 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3033 my $gotclogp = commit_getclogp($hash);
3034 my $got_vsn = getfield $gotclogp, 'Version';
3035 printdebug "SKEW CHECK GOT $got_vsn\n";
3036 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3037 print STDERR <<END or die $!;
3039 Warning: archive skew detected. Using the available version:
3040 Archive allegedly contains $skew_warning_vsn
3041 We were able to obtain only $got_vsn
3047 if ($lastfetch_hash ne $hash) {
3048 fetch_from_archive_record_2($hash);
3051 lrfetchref_used lrfetchref();
3053 unshift @end, $del_lrfetchrefs;
3057 sub set_local_git_config ($$) {
3059 runcmd @git, qw(config), $k, $v;
3062 sub setup_mergechangelogs (;$) {
3064 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3066 my $driver = 'dpkg-mergechangelogs';
3067 my $cb = "merge.$driver";
3068 my $attrs = '.git/info/attributes';
3069 ensuredir '.git/info';
3071 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3072 if (!open ATTRS, "<", $attrs) {
3073 $!==ENOENT or die "$attrs: $!";
3077 next if m{^debian/changelog\s};
3078 print NATTRS $_, "\n" or die $!;
3080 ATTRS->error and die $!;
3083 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3086 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3087 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3089 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3092 sub setup_useremail (;$) {
3094 return unless $always || access_cfg_bool(1, 'setup-useremail');
3097 my ($k, $envvar) = @_;
3098 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3099 return unless defined $v;
3100 set_local_git_config "user.$k", $v;
3103 $setup->('email', 'DEBEMAIL');
3104 $setup->('name', 'DEBFULLNAME');
3107 sub ensure_setup_existing_tree () {
3108 my $k = "remote.$remotename.skipdefaultupdate";
3109 my $c = git_get_config $k;
3110 return if defined $c;
3111 set_local_git_config $k, 'true';
3114 sub setup_new_tree () {
3115 setup_mergechangelogs();
3119 sub multisuite_suite_child ($$$) {
3120 my ($tsuite, $merginputs, $fn) = @_;
3121 # in child, sets things up, calls $fn->(), and returns undef
3122 # in parent, returns canonical suite name for $tsuite
3123 my $canonsuitefh = IO::File::new_tmpfile;
3124 my $pid = fork // die $!;
3127 $us .= " [$isuite]";
3128 $debugprefix .= " ";
3129 progress "fetching $tsuite...";
3130 canonicalise_suite();
3131 print $canonsuitefh $csuite, "\n" or die $!;
3132 close $canonsuitefh or die $!;
3136 waitpid $pid,0 == $pid or die $!;
3137 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3138 seek $canonsuitefh,0,0 or die $!;
3139 local $csuite = <$canonsuitefh>;
3140 die $! unless defined $csuite && chomp $csuite;
3142 printdebug "multisuite $tsuite missing\n";
3145 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3146 push @$merginputs, {
3153 sub fork_for_multisuite ($) {
3154 my ($before_fetch_merge) = @_;
3155 # if nothing unusual, just returns ''
3158 # returns 0 to caller in child, to do first of the specified suites
3159 # in child, $csuite is not yet set
3161 # returns 1 to caller in parent, to finish up anything needed after
3162 # in parent, $csuite is set to canonicalised portmanteau
3164 my $org_isuite = $isuite;
3165 my @suites = split /\,/, $isuite;
3166 return '' unless @suites > 1;
3167 printdebug "fork_for_multisuite: @suites\n";
3171 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3173 return 0 unless defined $cbasesuite;
3175 fail "package $package missing in (base suite) $cbasesuite"
3176 unless @mergeinputs;
3178 my @csuites = ($cbasesuite);
3180 $before_fetch_merge->();
3182 foreach my $tsuite (@suites[1..$#suites]) {
3183 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3189 # xxx collecte the ref here
3191 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3192 push @csuites, $csubsuite;
3195 foreach my $mi (@mergeinputs) {
3196 my $ref = git_get_ref $mi->{Ref};
3197 die "$mi->{Ref} ?" unless length $ref;
3198 $mi->{Commit} = $ref;
3201 $csuite = join ",", @csuites;
3203 my $previous = git_get_ref lrref;
3205 unshift @mergeinputs, {
3206 Commit => $previous,
3207 Info => "local combined tracking branch",
3209 "archive seems to have rewound: local tracking branch is ahead!",
3213 foreach my $ix (0..$#mergeinputs) {
3214 $mergeinputs[$ix]{Index} = $ix;
3217 @mergeinputs = sort {
3218 -version_compare(mergeinfo_version $a,
3219 mergeinfo_version $b) # highest version first
3221 $a->{Index} <=> $b->{Index}; # earliest in spec first
3227 foreach my $mi (@mergeinputs) {
3228 printdebug "multisuite merge check $mi->{Info}\n";
3229 foreach my $previous (@needed) {
3230 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3231 printdebug "multisuite merge un-needed $previous->{Info}\n";
3235 printdebug "multisuite merge this-needed\n";
3236 $mi->{Character} = '+';
3239 $needed[0]{Character} = '*';
3241 my $output = $needed[0]{Commit};
3244 printdebug "multisuite merge nontrivial\n";
3245 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3247 my $commit = "tree $tree\n";
3248 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3249 "Input branches:\n";
3251 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3252 printdebug "multisuite merge include $mi->{Info}\n";
3253 $mi->{Character} //= ' ';
3254 $commit .= "parent $mi->{Commit}\n";
3255 $msg .= sprintf " %s %-25s %s\n",
3257 (mergeinfo_version $mi),
3260 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3262 " * marks the highest version branch, which choose to use\n".
3263 " + marks each branch which was not already an ancestor\n\n".
3264 "[dgit multi-suite $csuite]\n";
3266 "author $authline\n".
3267 "committer $authline\n\n";
3268 $output = make_commit_text $commit.$msg;
3269 printdebug "multisuite merge generated $output\n";
3272 fetch_from_archive_record_1($output);
3273 fetch_from_archive_record_2($output);
3275 progress "calculated combined tracking suite $csuite";
3280 sub clone_set_head () {
3281 open H, "> .git/HEAD" or die $!;
3282 print H "ref: ".lref()."\n" or die $!;
3285 sub clone_finish ($) {
3287 runcmd @git, qw(reset --hard), lrref();
3288 runcmd qw(bash -ec), <<'END';
3290 git ls-tree -r --name-only -z HEAD | \
3291 xargs -0r touch -h -r . --
3293 printdone "ready for work in $dstdir";
3298 badusage "dry run makes no sense with clone" unless act_local();
3300 my $multi_fetched = fork_for_multisuite(sub {
3301 printdebug "multi clone before fetch merge\n";
3304 if ($multi_fetched) {
3305 printdebug "multi clone after fetch merge\n";
3307 clone_finish($dstdir);
3310 printdebug "clone main body\n";
3312 canonicalise_suite();
3313 my $hasgit = check_for_git();
3314 mkdir $dstdir or fail "create \`$dstdir': $!";
3316 runcmd @git, qw(init -q);
3318 my $giturl = access_giturl(1);
3319 if (defined $giturl) {
3320 runcmd @git, qw(remote add), 'origin', $giturl;
3323 progress "fetching existing git history";
3325 runcmd_ordryrun_local @git, qw(fetch origin);
3327 progress "starting new git history";
3329 fetch_from_archive() or no_such_package;
3330 my $vcsgiturl = $dsc->{'Vcs-Git'};
3331 if (length $vcsgiturl) {
3332 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3333 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3336 clone_finish($dstdir);
3340 canonicalise_suite();
3341 if (check_for_git()) {
3344 fetch_from_archive() or no_such_package();
3345 printdone "fetched into ".lrref();
3349 my $multi_fetched = fork_for_multisuite(sub { });
3350 fetch() unless $multi_fetched; # parent
3351 return if $multi_fetched eq '0'; # child
3352 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3354 printdone "fetched to ".lrref()." and merged into HEAD";
3357 sub check_not_dirty () {
3358 foreach my $f (qw(local-options local-patch-header)) {
3359 if (stat_exists "debian/source/$f") {
3360 fail "git tree contains debian/source/$f";
3364 return if $ignoredirty;
3366 my @cmd = (@git, qw(diff --quiet HEAD));
3368 $!=0; $?=-1; system @cmd;
3371 fail "working tree is dirty (does not match HEAD)";
3377 sub commit_admin ($) {
3380 runcmd_ordryrun_local @git, qw(commit -m), $m;
3383 sub commit_quilty_patch () {
3384 my $output = cmdoutput @git, qw(status --porcelain);
3386 foreach my $l (split /\n/, $output) {
3387 next unless $l =~ m/\S/;
3388 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3392 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3394 progress "nothing quilty to commit, ok.";
3397 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3398 runcmd_ordryrun_local @git, qw(add -f), @adds;
3400 Commit Debian 3.0 (quilt) metadata
3402 [dgit ($our_version) quilt-fixup]
3406 sub get_source_format () {
3408 if (open F, "debian/source/options") {
3412 s/\s+$//; # ignore missing final newline
3414 my ($k, $v) = ($`, $'); #');
3415 $v =~ s/^"(.*)"$/$1/;
3421 F->error and die $!;
3424 die $! unless $!==&ENOENT;
3427 if (!open F, "debian/source/format") {
3428 die $! unless $!==&ENOENT;
3432 F->error and die $!;
3434 return ($_, \%options);
3437 sub madformat_wantfixup ($) {
3439 return 0 unless $format eq '3.0 (quilt)';
3440 our $quilt_mode_warned;
3441 if ($quilt_mode eq 'nocheck') {
3442 progress "Not doing any fixup of \`$format' due to".
3443 " ----no-quilt-fixup or --quilt=nocheck"
3444 unless $quilt_mode_warned++;
3447 progress "Format \`$format', need to check/update patch stack"
3448 unless $quilt_mode_warned++;
3452 sub maybe_split_brain_save ($$$) {
3453 my ($headref, $dgitview, $msg) = @_;
3454 # => message fragment "$saved" describing disposition of $dgitview
3455 return "commit id $dgitview" unless defined $split_brain_save;
3456 my @cmd = (shell_cmd "cd ../../../..",
3457 @git, qw(update-ref -m),
3458 "dgit --dgit-view-save $msg HEAD=$headref",
3459 $split_brain_save, $dgitview);
3461 return "and left in $split_brain_save";
3464 # An "infopair" is a tuple [ $thing, $what ]
3465 # (often $thing is a commit hash; $what is a description)
3467 sub infopair_cond_equal ($$) {
3469 $x->[0] eq $y->[0] or fail <<END;
3470 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3474 sub infopair_lrf_tag_lookup ($$) {
3475 my ($tagnames, $what) = @_;
3476 # $tagname may be an array ref
3477 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3478 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3479 foreach my $tagname (@tagnames) {
3480 my $lrefname = lrfetchrefs."/tags/$tagname";
3481 my $tagobj = $lrfetchrefs_f{$lrefname};
3482 next unless defined $tagobj;
3483 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3484 return [ git_rev_parse($tagobj), $what ];
3486 fail @tagnames==1 ? <<END : <<END;
3487 Wanted tag $what (@tagnames) on dgit server, but not found
3489 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3493 sub infopair_cond_ff ($$) {
3494 my ($anc,$desc) = @_;
3495 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3496 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3500 sub pseudomerge_version_check ($$) {
3501 my ($clogp, $archive_hash) = @_;
3503 my $arch_clogp = commit_getclogp $archive_hash;
3504 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3505 'version currently in archive' ];
3506 if (defined $overwrite_version) {
3507 if (length $overwrite_version) {
3508 infopair_cond_equal([ $overwrite_version,
3509 '--overwrite= version' ],
3512 my $v = $i_arch_v->[0];
3513 progress "Checking package changelog for archive version $v ...";
3515 my @xa = ("-f$v", "-t$v");
3516 my $vclogp = parsechangelog @xa;
3517 my $cv = [ (getfield $vclogp, 'Version'),
3518 "Version field from dpkg-parsechangelog @xa" ];
3519 infopair_cond_equal($i_arch_v, $cv);
3522 $@ =~ s/^dgit: //gm;
3524 "Perhaps debian/changelog does not mention $v ?";
3529 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3533 sub pseudomerge_make_commit ($$$$ $$) {
3534 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3535 $msg_cmd, $msg_msg) = @_;
3536 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3538 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3539 my $authline = clogp_authline $clogp;
3543 !defined $overwrite_version ? ""
3544 : !length $overwrite_version ? " --overwrite"
3545 : " --overwrite=".$overwrite_version;
3548 my $pmf = ".git/dgit/pseudomerge";
3549 open MC, ">", $pmf or die "$pmf $!";
3550 print MC <<END or die $!;
3553 parent $archive_hash
3563 return make_commit($pmf);
3566 sub splitbrain_pseudomerge ($$$$) {
3567 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3568 # => $merged_dgitview
3569 printdebug "splitbrain_pseudomerge...\n";
3571 # We: debian/PREVIOUS HEAD($maintview)
3572 # expect: o ----------------- o
3575 # a/d/PREVIOUS $dgitview
3578 # we do: `------------------ o
3582 return $dgitview unless defined $archive_hash;
3584 printdebug "splitbrain_pseudomerge...\n";
3586 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3588 if (!defined $overwrite_version) {
3589 progress "Checking that HEAD inciudes all changes in archive...";
3592 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3594 if (defined $overwrite_version) {
3596 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3597 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3598 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3599 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3600 my $i_archive = [ $archive_hash, "current archive contents" ];
3602 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3604 infopair_cond_equal($i_dgit, $i_archive);
3605 infopair_cond_ff($i_dep14, $i_dgit);
3606 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3610 $us: check failed (maybe --overwrite is needed, consult documentation)
3615 my $r = pseudomerge_make_commit
3616 $clogp, $dgitview, $archive_hash, $i_arch_v,
3617 "dgit --quilt=$quilt_mode",
3618 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3619 Declare fast forward from $i_arch_v->[0]
3621 Make fast forward from $i_arch_v->[0]
3624 maybe_split_brain_save $maintview, $r, "pseudomerge";
3626 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3630 sub plain_overwrite_pseudomerge ($$$) {
3631 my ($clogp, $head, $archive_hash) = @_;
3633 printdebug "plain_overwrite_pseudomerge...";
3635 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3637 return $head if is_fast_fwd $archive_hash, $head;
3639 my $m = "Declare fast forward from $i_arch_v->[0]";
3641 my $r = pseudomerge_make_commit
3642 $clogp, $head, $archive_hash, $i_arch_v,
3645 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3647 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3651 sub push_parse_changelog ($) {
3654 my $clogp = Dpkg::Control::Hash->new();
3655 $clogp->load($clogpfn) or die;
3657 my $clogpackage = getfield $clogp, 'Source';
3658 $package //= $clogpackage;
3659 fail "-p specified $package but changelog specified $clogpackage"
3660 unless $package eq $clogpackage;
3661 my $cversion = getfield $clogp, 'Version';
3662 my $tag = debiantag($cversion, access_nomdistro);
3663 runcmd @git, qw(check-ref-format), $tag;
3665 my $dscfn = dscfn($cversion);
3667 return ($clogp, $cversion, $dscfn);
3670 sub push_parse_dsc ($$$) {
3671 my ($dscfn,$dscfnwhat, $cversion) = @_;
3672 $dsc = parsecontrol($dscfn,$dscfnwhat);
3673 my $dversion = getfield $dsc, 'Version';
3674 my $dscpackage = getfield $dsc, 'Source';
3675 ($dscpackage eq $package && $dversion eq $cversion) or
3676 fail "$dscfn is for $dscpackage $dversion".
3677 " but debian/changelog is for $package $cversion";
3680 sub push_tagwants ($$$$) {
3681 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3684 TagFn => \&debiantag,
3689 if (defined $maintviewhead) {
3691 TagFn => \&debiantag_maintview,
3692 Objid => $maintviewhead,
3693 TfSuffix => '-maintview',
3696 } elsif ($dodep14tag eq 'no' ? 0
3697 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3698 : $dodep14tag eq 'always'
3699 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3700 --dep14tag-always (or equivalent in config) means server must support
3701 both "new" and "maint" tag formats, but config says it doesn't.
3703 : die "$dodep14tag ?") {
3705 TagFn => \&debiantag_maintview,
3707 TfSuffix => '-dgit',
3711 foreach my $tw (@tagwants) {
3712 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3713 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3715 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3719 sub push_mktags ($$ $$ $) {
3721 $changesfile,$changesfilewhat,
3724 die unless $tagwants->[0]{View} eq 'dgit';
3726 my $declaredistro = access_nomdistro();
3727 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
3728 $dsc->{$ourdscfield[0]} = join " ",
3729 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
3731 $dsc->save("$dscfn.tmp") or die $!;
3733 my $changes = parsecontrol($changesfile,$changesfilewhat);
3734 foreach my $field (qw(Source Distribution Version)) {
3735 $changes->{$field} eq $clogp->{$field} or
3736 fail "changes field $field \`$changes->{$field}'".
3737 " does not match changelog \`$clogp->{$field}'";
3740 my $cversion = getfield $clogp, 'Version';
3741 my $clogsuite = getfield $clogp, 'Distribution';
3743 # We make the git tag by hand because (a) that makes it easier
3744 # to control the "tagger" (b) we can do remote signing
3745 my $authline = clogp_authline $clogp;
3746 my $delibs = join(" ", "",@deliberatelies);
3750 my $tfn = $tw->{Tfn};
3751 my $head = $tw->{Objid};
3752 my $tag = $tw->{Tag};
3754 open TO, '>', $tfn->('.tmp') or die $!;
3755 print TO <<END or die $!;
3762 if ($tw->{View} eq 'dgit') {
3763 print TO <<END or die $!;
3764 $package release $cversion for $clogsuite ($csuite) [dgit]
3765 [dgit distro=$declaredistro$delibs]
3767 foreach my $ref (sort keys %previously) {
3768 print TO <<END or die $!;
3769 [dgit previously:$ref=$previously{$ref}]
3772 } elsif ($tw->{View} eq 'maint') {
3773 print TO <<END or die $!;
3774 $package release $cversion for $clogsuite ($csuite)
3775 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3778 die Dumper($tw)."?";
3783 my $tagobjfn = $tfn->('.tmp');
3785 if (!defined $keyid) {
3786 $keyid = access_cfg('keyid','RETURN-UNDEF');
3788 if (!defined $keyid) {
3789 $keyid = getfield $clogp, 'Maintainer';
3791 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3792 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3793 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3794 push @sign_cmd, $tfn->('.tmp');
3795 runcmd_ordryrun @sign_cmd;
3797 $tagobjfn = $tfn->('.signed.tmp');
3798 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3799 $tfn->('.tmp'), $tfn->('.tmp.asc');
3805 my @r = map { $mktag->($_); } @$tagwants;
3809 sub sign_changes ($) {
3810 my ($changesfile) = @_;
3812 my @debsign_cmd = @debsign;
3813 push @debsign_cmd, "-k$keyid" if defined $keyid;
3814 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3815 push @debsign_cmd, $changesfile;
3816 runcmd_ordryrun @debsign_cmd;
3821 printdebug "actually entering push\n";
3823 supplementary_message(<<'END');
3824 Push failed, while checking state of the archive.
3825 You can retry the push, after fixing the problem, if you like.
3827 if (check_for_git()) {
3830 my $archive_hash = fetch_from_archive();
3831 if (!$archive_hash) {
3833 fail "package appears to be new in this suite;".
3834 " if this is intentional, use --new";
3837 supplementary_message(<<'END');
3838 Push failed, while preparing your push.
3839 You can retry the push, after fixing the problem, if you like.
3842 need_tagformat 'new', "quilt mode $quilt_mode"
3843 if quiltmode_splitbrain;
3847 access_giturl(); # check that success is vaguely likely
3850 my $clogpfn = ".git/dgit/changelog.822.tmp";
3851 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3853 responder_send_file('parsed-changelog', $clogpfn);
3855 my ($clogp, $cversion, $dscfn) =
3856 push_parse_changelog("$clogpfn");
3858 my $dscpath = "$buildproductsdir/$dscfn";
3859 stat_exists $dscpath or
3860 fail "looked for .dsc $dscpath, but $!;".
3861 " maybe you forgot to build";
3863 responder_send_file('dsc', $dscpath);
3865 push_parse_dsc($dscpath, $dscfn, $cversion);
3867 my $format = getfield $dsc, 'Format';
3868 printdebug "format $format\n";
3870 my $actualhead = git_rev_parse('HEAD');
3871 my $dgithead = $actualhead;
3872 my $maintviewhead = undef;
3874 my $upstreamversion = upstreamversion $clogp->{Version};
3876 if (madformat_wantfixup($format)) {
3877 # user might have not used dgit build, so maybe do this now:
3878 if (quiltmode_splitbrain()) {
3880 quilt_make_fake_dsc($upstreamversion);
3882 ($dgithead, $cachekey) =
3883 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3885 "--quilt=$quilt_mode but no cached dgit view:
3886 perhaps tree changed since dgit build[-source] ?";
3888 $dgithead = splitbrain_pseudomerge($clogp,
3889 $actualhead, $dgithead,
3891 $maintviewhead = $actualhead;
3892 changedir '../../../..';
3893 prep_ud(); # so _only_subdir() works, below
3895 commit_quilty_patch();
3899 if (defined $overwrite_version && !defined $maintviewhead) {
3900 $dgithead = plain_overwrite_pseudomerge($clogp,
3908 if ($archive_hash) {
3909 if (is_fast_fwd($archive_hash, $dgithead)) {
3911 } elsif (deliberately_not_fast_forward) {
3914 fail "dgit push: HEAD is not a descendant".
3915 " of the archive's version.\n".
3916 "To overwrite the archive's contents,".
3917 " pass --overwrite[=VERSION].\n".
3918 "To rewind history, if permitted by the archive,".
3919 " use --deliberately-not-fast-forward.";
3924 progress "checking that $dscfn corresponds to HEAD";
3925 runcmd qw(dpkg-source -x --),
3926 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3927 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
3928 check_for_vendor_patches() if madformat($dsc->{format});
3929 changedir '../../../..';
3930 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3931 debugcmd "+",@diffcmd;
3933 my $r = system @diffcmd;
3936 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3938 HEAD specifies a different tree to $dscfn:
3940 Perhaps you forgot to build. Or perhaps there is a problem with your
3941 source tree (see dgit(7) for some hints). To see a full diff, run
3948 if (!$changesfile) {
3949 my $pat = changespat $cversion;
3950 my @cs = glob "$buildproductsdir/$pat";
3951 fail "failed to find unique changes file".
3952 " (looked for $pat in $buildproductsdir);".
3953 " perhaps you need to use dgit -C"
3955 ($changesfile) = @cs;
3957 $changesfile = "$buildproductsdir/$changesfile";
3960 # Check that changes and .dsc agree enough
3961 $changesfile =~ m{[^/]*$};
3962 my $changes = parsecontrol($changesfile,$&);
3963 files_compare_inputs($dsc, $changes)
3964 unless forceing [qw(dsc-changes-mismatch)];
3966 # Perhaps adjust .dsc to contain right set of origs
3967 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3969 unless forceing [qw(changes-origs-exactly)];
3971 # Checks complete, we're going to try and go ahead:
3973 responder_send_file('changes',$changesfile);
3974 responder_send_command("param head $dgithead");
3975 responder_send_command("param csuite $csuite");
3976 responder_send_command("param tagformat $tagformat");
3977 if (defined $maintviewhead) {
3978 die unless ($protovsn//4) >= 4;
3979 responder_send_command("param maint-view $maintviewhead");
3982 if (deliberately_not_fast_forward) {
3983 git_for_each_ref(lrfetchrefs, sub {
3984 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3985 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3986 responder_send_command("previously $rrefname=$objid");
3987 $previously{$rrefname} = $objid;
3991 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3995 supplementary_message(<<'END');
3996 Push failed, while signing the tag.
3997 You can retry the push, after fixing the problem, if you like.
3999 # If we manage to sign but fail to record it anywhere, it's fine.
4000 if ($we_are_responder) {
4001 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4002 responder_receive_files('signed-tag', @tagobjfns);
4004 @tagobjfns = push_mktags($clogp,$dscpath,
4005 $changesfile,$changesfile,
4008 supplementary_message(<<'END');
4009 Push failed, *after* signing the tag.
4010 If you want to try again, you should use a new version number.
4013 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4015 foreach my $tw (@tagwants) {
4016 my $tag = $tw->{Tag};
4017 my $tagobjfn = $tw->{TagObjFn};
4019 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4020 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4021 runcmd_ordryrun_local
4022 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4025 supplementary_message(<<'END');
4026 Push failed, while updating the remote git repository - see messages above.
4027 If you want to try again, you should use a new version number.
4029 if (!check_for_git()) {
4030 create_remote_git_repo();
4033 my @pushrefs = $forceflag.$dgithead.":".rrref();
4034 foreach my $tw (@tagwants) {
4035 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4038 runcmd_ordryrun @git,
4039 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4040 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4042 supplementary_message(<<'END');
4043 Push failed, while obtaining signatures on the .changes and .dsc.
4044 If it was just that the signature failed, you may try again by using
4045 debsign by hand to sign the changes
4047 and then dput to complete the upload.
4048 If you need to change the package, you must use a new version number.
4050 if ($we_are_responder) {
4051 my $dryrunsuffix = act_local() ? "" : ".tmp";
4052 responder_receive_files('signed-dsc-changes',
4053 "$dscpath$dryrunsuffix",
4054 "$changesfile$dryrunsuffix");
4057 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4059 progress "[new .dsc left in $dscpath.tmp]";
4061 sign_changes $changesfile;
4064 supplementary_message(<<END);
4065 Push failed, while uploading package(s) to the archive server.
4066 You can retry the upload of exactly these same files with dput of:
4068 If that .changes file is broken, you will need to use a new version
4069 number for your next attempt at the upload.
4071 my $host = access_cfg('upload-host','RETURN-UNDEF');
4072 my @hostarg = defined($host) ? ($host,) : ();
4073 runcmd_ordryrun @dput, @hostarg, $changesfile;
4074 printdone "pushed and uploaded $cversion";
4076 supplementary_message('');
4077 responder_send_command("complete");
4083 badusage "-p is not allowed with clone; specify as argument instead"
4084 if defined $package;
4087 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4088 ($package,$isuite) = @ARGV;
4089 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4090 ($package,$dstdir) = @ARGV;
4091 } elsif (@ARGV==3) {
4092 ($package,$isuite,$dstdir) = @ARGV;
4094 badusage "incorrect arguments to dgit clone";
4098 $dstdir ||= "$package";
4099 if (stat_exists $dstdir) {
4100 fail "$dstdir already exists";
4104 if ($rmonerror && !$dryrun_level) {
4105 $cwd_remove= getcwd();
4107 return unless defined $cwd_remove;
4108 if (!chdir "$cwd_remove") {
4109 return if $!==&ENOENT;
4110 die "chdir $cwd_remove: $!";
4112 printdebug "clone rmonerror removing $dstdir\n";
4114 rmtree($dstdir) or die "remove $dstdir: $!\n";
4115 } elsif (grep { $! == $_ }
4116 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4118 print STDERR "check whether to remove $dstdir: $!\n";
4124 $cwd_remove = undef;
4127 sub branchsuite () {
4128 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4129 if ($branch =~ m#$lbranch_re#o) {
4136 sub fetchpullargs () {
4137 if (!defined $package) {
4138 my $sourcep = parsecontrol('debian/control','debian/control');
4139 $package = getfield $sourcep, 'Source';
4142 $isuite = branchsuite();
4144 my $clogp = parsechangelog();
4145 $isuite = getfield $clogp, 'Distribution';
4147 } elsif (@ARGV==1) {
4150 badusage "incorrect arguments to dgit fetch or dgit pull";
4158 my $multi_fetched = fork_for_multisuite(sub { });
4159 exit 0 if $multi_fetched;
4166 if (quiltmode_splitbrain()) {
4167 my ($format, $fopts) = get_source_format();
4168 madformat($format) and fail <<END
4169 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4178 badusage "-p is not allowed with dgit push" if defined $package;
4180 my $clogp = parsechangelog();
4181 $package = getfield $clogp, 'Source';
4184 } elsif (@ARGV==1) {
4185 ($specsuite) = (@ARGV);
4187 badusage "incorrect arguments to dgit push";
4189 $isuite = getfield $clogp, 'Distribution';
4191 local ($package) = $existing_package; # this is a hack
4192 canonicalise_suite();
4194 canonicalise_suite();
4196 if (defined $specsuite &&
4197 $specsuite ne $isuite &&
4198 $specsuite ne $csuite) {
4199 fail "dgit push: changelog specifies $isuite ($csuite)".
4200 " but command line specifies $specsuite";
4205 #---------- remote commands' implementation ----------
4207 sub cmd_remote_push_build_host {
4208 my ($nrargs) = shift @ARGV;
4209 my (@rargs) = @ARGV[0..$nrargs-1];
4210 @ARGV = @ARGV[$nrargs..$#ARGV];
4212 my ($dir,$vsnwant) = @rargs;
4213 # vsnwant is a comma-separated list; we report which we have
4214 # chosen in our ready response (so other end can tell if they
4217 $we_are_responder = 1;
4218 $us .= " (build host)";
4222 open PI, "<&STDIN" or die $!;
4223 open STDIN, "/dev/null" or die $!;
4224 open PO, ">&STDOUT" or die $!;
4226 open STDOUT, ">&STDERR" or die $!;
4230 ($protovsn) = grep {
4231 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4232 } @rpushprotovsn_support;
4234 fail "build host has dgit rpush protocol versions ".
4235 (join ",", @rpushprotovsn_support).
4236 " but invocation host has $vsnwant"
4237 unless defined $protovsn;
4239 responder_send_command("dgit-remote-push-ready $protovsn");
4240 rpush_handle_protovsn_bothends();
4245 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4246 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4247 # a good error message)
4249 sub rpush_handle_protovsn_bothends () {
4250 if ($protovsn < 4) {
4251 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4260 my $report = i_child_report();
4261 if (defined $report) {
4262 printdebug "($report)\n";
4263 } elsif ($i_child_pid) {
4264 printdebug "(killing build host child $i_child_pid)\n";
4265 kill 15, $i_child_pid;
4267 if (defined $i_tmp && !defined $initiator_tempdir) {
4269 eval { rmtree $i_tmp; };
4273 END { i_cleanup(); }
4276 my ($base,$selector,@args) = @_;
4277 $selector =~ s/\-/_/g;
4278 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4285 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4293 push @rargs, join ",", @rpushprotovsn_support;
4296 push @rdgit, @ropts;
4297 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4299 my @cmd = (@ssh, $host, shellquote @rdgit);
4302 if (defined $initiator_tempdir) {
4303 rmtree $initiator_tempdir;
4304 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4305 $i_tmp = $initiator_tempdir;
4309 $i_child_pid = open2(\*RO, \*RI, @cmd);
4311 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4312 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4313 $supplementary_message = '' unless $protovsn >= 3;
4315 fail "rpush negotiated protocol version $protovsn".
4316 " which does not support quilt mode $quilt_mode"
4317 if quiltmode_splitbrain;
4319 rpush_handle_protovsn_bothends();
4321 my ($icmd,$iargs) = initiator_expect {
4322 m/^(\S+)(?: (.*))?$/;
4325 i_method "i_resp", $icmd, $iargs;
4329 sub i_resp_progress ($) {
4331 my $msg = protocol_read_bytes \*RO, $rhs;
4335 sub i_resp_supplementary_message ($) {
4337 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4340 sub i_resp_complete {
4341 my $pid = $i_child_pid;
4342 $i_child_pid = undef; # prevents killing some other process with same pid
4343 printdebug "waiting for build host child $pid...\n";
4344 my $got = waitpid $pid, 0;
4345 die $! unless $got == $pid;
4346 die "build host child failed $?" if $?;
4349 printdebug "all done\n";
4353 sub i_resp_file ($) {
4355 my $localname = i_method "i_localname", $keyword;
4356 my $localpath = "$i_tmp/$localname";
4357 stat_exists $localpath and
4358 badproto \*RO, "file $keyword ($localpath) twice";
4359 protocol_receive_file \*RO, $localpath;
4360 i_method "i_file", $keyword;
4365 sub i_resp_param ($) {
4366 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4370 sub i_resp_previously ($) {
4371 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4372 or badproto \*RO, "bad previously spec";
4373 my $r = system qw(git check-ref-format), $1;
4374 die "bad previously ref spec ($r)" if $r;
4375 $previously{$1} = $2;
4380 sub i_resp_want ($) {
4382 die "$keyword ?" if $i_wanted{$keyword}++;
4383 my @localpaths = i_method "i_want", $keyword;
4384 printdebug "[[ $keyword @localpaths\n";
4385 foreach my $localpath (@localpaths) {
4386 protocol_send_file \*RI, $localpath;
4388 print RI "files-end\n" or die $!;
4391 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4393 sub i_localname_parsed_changelog {
4394 return "remote-changelog.822";
4396 sub i_file_parsed_changelog {
4397 ($i_clogp, $i_version, $i_dscfn) =
4398 push_parse_changelog "$i_tmp/remote-changelog.822";
4399 die if $i_dscfn =~ m#/|^\W#;
4402 sub i_localname_dsc {
4403 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4408 sub i_localname_changes {
4409 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4410 $i_changesfn = $i_dscfn;
4411 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4412 return $i_changesfn;
4414 sub i_file_changes { }
4416 sub i_want_signed_tag {
4417 printdebug Dumper(\%i_param, $i_dscfn);
4418 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4419 && defined $i_param{'csuite'}
4420 or badproto \*RO, "premature desire for signed-tag";
4421 my $head = $i_param{'head'};
4422 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4424 my $maintview = $i_param{'maint-view'};
4425 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4428 if ($protovsn >= 4) {
4429 my $p = $i_param{'tagformat'} // '<undef>';
4431 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4434 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4436 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4438 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4441 push_mktags $i_clogp, $i_dscfn,
4442 $i_changesfn, 'remote changes',
4446 sub i_want_signed_dsc_changes {
4447 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4448 sign_changes $i_changesfn;
4449 return ($i_dscfn, $i_changesfn);
4452 #---------- building etc. ----------
4458 #----- `3.0 (quilt)' handling -----
4460 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4462 sub quiltify_dpkg_commit ($$$;$) {
4463 my ($patchname,$author,$msg, $xinfo) = @_;
4467 my $descfn = ".git/dgit/quilt-description.tmp";
4468 open O, '>', $descfn or die "$descfn: $!";
4469 $msg =~ s/\n+/\n\n/;
4470 print O <<END or die $!;
4472 ${xinfo}Subject: $msg
4479 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4480 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4481 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4482 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4486 sub quiltify_trees_differ ($$;$$$) {
4487 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4488 # returns true iff the two tree objects differ other than in debian/
4489 # with $finegrained,
4490 # returns bitmask 01 - differ in upstream files except .gitignore
4491 # 02 - differ in .gitignore
4492 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4493 # is set for each modified .gitignore filename $fn
4494 # if $unrepres is defined, array ref to which is appeneded
4495 # a list of unrepresentable changes (removals of upstream files
4498 my @cmd = (@git, qw(diff-tree -z));
4499 push @cmd, qw(--name-only) unless $unrepres;
4500 push @cmd, qw(-r) if $finegrained || $unrepres;
4502 my $diffs= cmdoutput @cmd;
4505 foreach my $f (split /\0/, $diffs) {
4506 if ($unrepres && !@lmodes) {
4507 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4510 my ($oldmode,$newmode) = @lmodes;
4513 next if $f =~ m#^debian(?:/.*)?$#s;
4517 die "not a plain file\n"
4518 unless $newmode =~ m/^10\d{4}$/ ||
4519 $oldmode =~ m/^10\d{4}$/;
4520 if ($oldmode =~ m/[^0]/ &&
4521 $newmode =~ m/[^0]/) {
4522 die "mode changed\n" if $oldmode ne $newmode;
4524 die "non-default mode\n"
4525 unless $newmode =~ m/^100644$/ ||
4526 $oldmode =~ m/^100644$/;
4530 local $/="\n"; chomp $@;
4531 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4535 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4536 $r |= $isignore ? 02 : 01;
4537 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4539 printdebug "quiltify_trees_differ $x $y => $r\n";
4543 sub quiltify_tree_sentinelfiles ($) {
4544 # lists the `sentinel' files present in the tree
4546 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4547 qw(-- debian/rules debian/control);
4552 sub quiltify_splitbrain_needed () {
4553 if (!$split_brain) {
4554 progress "dgit view: changes are required...";
4555 runcmd @git, qw(checkout -q -b dgit-view);
4560 sub quiltify_splitbrain ($$$$$$) {
4561 my ($clogp, $unapplied, $headref, $diffbits,
4562 $editedignores, $cachekey) = @_;
4563 if ($quilt_mode !~ m/gbp|dpm/) {
4564 # treat .gitignore just like any other upstream file
4565 $diffbits = { %$diffbits };
4566 $_ = !!$_ foreach values %$diffbits;
4568 # We would like any commits we generate to be reproducible
4569 my @authline = clogp_authline($clogp);
4570 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4571 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4572 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4573 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4574 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4575 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4577 if ($quilt_mode =~ m/gbp|unapplied/ &&
4578 ($diffbits->{O2H} & 01)) {
4580 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4581 " but git tree differs from orig in upstream files.";
4582 if (!stat_exists "debian/patches") {
4584 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4588 if ($quilt_mode =~ m/dpm/ &&
4589 ($diffbits->{H2A} & 01)) {
4591 --quilt=$quilt_mode specified, implying patches-applied git tree
4592 but git tree differs from result of applying debian/patches to upstream
4595 if ($quilt_mode =~ m/gbp|unapplied/ &&
4596 ($diffbits->{O2A} & 01)) { # some patches
4597 quiltify_splitbrain_needed();
4598 progress "dgit view: creating patches-applied version using gbp pq";
4599 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4600 # gbp pq import creates a fresh branch; push back to dgit-view
4601 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4602 runcmd @git, qw(checkout -q dgit-view);
4604 if ($quilt_mode =~ m/gbp|dpm/ &&
4605 ($diffbits->{O2A} & 02)) {
4607 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4608 tool which does not create patches for changes to upstream
4609 .gitignores: but, such patches exist in debian/patches.
4612 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4613 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4614 quiltify_splitbrain_needed();
4615 progress "dgit view: creating patch to represent .gitignore changes";
4616 ensuredir "debian/patches";
4617 my $gipatch = "debian/patches/auto-gitignore";
4618 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4619 stat GIPATCH or die "$gipatch: $!";
4620 fail "$gipatch already exists; but want to create it".
4621 " to record .gitignore changes" if (stat _)[7];
4622 print GIPATCH <<END or die "$gipatch: $!";
4623 Subject: Update .gitignore from Debian packaging branch
4625 The Debian packaging git branch contains these updates to the upstream
4626 .gitignore file(s). This patch is autogenerated, to provide these
4627 updates to users of the official Debian archive view of the package.
4629 [dgit ($our_version) update-gitignore]
4632 close GIPATCH or die "$gipatch: $!";
4633 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4634 $unapplied, $headref, "--", sort keys %$editedignores;
4635 open SERIES, "+>>", "debian/patches/series" or die $!;
4636 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4638 defined read SERIES, $newline, 1 or die $!;
4639 print SERIES "\n" or die $! unless $newline eq "\n";
4640 print SERIES "auto-gitignore\n" or die $!;
4641 close SERIES or die $!;
4642 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4644 Commit patch to update .gitignore
4646 [dgit ($our_version) update-gitignore-quilt-fixup]
4650 my $dgitview = git_rev_parse 'HEAD';
4652 changedir '../../../..';
4653 # When we no longer need to support squeeze, use --create-reflog
4655 ensuredir ".git/logs/refs/dgit-intern";
4656 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4659 my $oldcache = git_get_ref "refs/$splitbraincache";
4660 if ($oldcache eq $dgitview) {
4661 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4662 # git update-ref doesn't always update, in this case. *sigh*
4663 my $dummy = make_commit_text <<END;
4666 author Dgit <dgit\@example.com> 1000000000 +0000
4667 committer Dgit <dgit\@example.com> 1000000000 +0000
4669 Dummy commit - do not use
4671 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4672 "refs/$splitbraincache", $dummy;
4674 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4677 changedir '.git/dgit/unpack/work';
4679 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4680 progress "dgit view: created ($saved)";
4683 sub quiltify ($$$$) {
4684 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4686 # Quilt patchification algorithm
4688 # We search backwards through the history of the main tree's HEAD
4689 # (T) looking for a start commit S whose tree object is identical
4690 # to to the patch tip tree (ie the tree corresponding to the
4691 # current dpkg-committed patch series). For these purposes
4692 # `identical' disregards anything in debian/ - this wrinkle is
4693 # necessary because dpkg-source treates debian/ specially.
4695 # We can only traverse edges where at most one of the ancestors'
4696 # trees differs (in changes outside in debian/). And we cannot
4697 # handle edges which change .pc/ or debian/patches. To avoid
4698 # going down a rathole we avoid traversing edges which introduce
4699 # debian/rules or debian/control. And we set a limit on the
4700 # number of edges we are willing to look at.
4702 # If we succeed, we walk forwards again. For each traversed edge
4703 # PC (with P parent, C child) (starting with P=S and ending with
4704 # C=T) to we do this:
4706 # - dpkg-source --commit with a patch name and message derived from C
4707 # After traversing PT, we git commit the changes which
4708 # should be contained within debian/patches.
4710 # The search for the path S..T is breadth-first. We maintain a
4711 # todo list containing search nodes. A search node identifies a
4712 # commit, and looks something like this:
4714 # Commit => $git_commit_id,
4715 # Child => $c, # or undef if P=T
4716 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4717 # Nontrivial => true iff $p..$c has relevant changes
4724 my %considered; # saves being exponential on some weird graphs
4726 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4729 my ($search,$whynot) = @_;
4730 printdebug " search NOT $search->{Commit} $whynot\n";
4731 $search->{Whynot} = $whynot;
4732 push @nots, $search;
4733 no warnings qw(exiting);
4742 my $c = shift @todo;
4743 next if $considered{$c->{Commit}}++;
4745 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4747 printdebug "quiltify investigate $c->{Commit}\n";
4750 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4751 printdebug " search finished hooray!\n";
4756 if ($quilt_mode eq 'nofix') {
4757 fail "quilt fixup required but quilt mode is \`nofix'\n".
4758 "HEAD commit $c->{Commit} differs from tree implied by ".
4759 " debian/patches (tree object $oldtiptree)";
4761 if ($quilt_mode eq 'smash') {
4762 printdebug " search quitting smash\n";
4766 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4767 $not->($c, "has $c_sentinels not $t_sentinels")
4768 if $c_sentinels ne $t_sentinels;
4770 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4771 $commitdata =~ m/\n\n/;
4773 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4774 @parents = map { { Commit => $_, Child => $c } } @parents;
4776 $not->($c, "root commit") if !@parents;
4778 foreach my $p (@parents) {
4779 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4781 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4782 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4784 foreach my $p (@parents) {
4785 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4787 my @cmd= (@git, qw(diff-tree -r --name-only),
4788 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4789 my $patchstackchange = cmdoutput @cmd;
4790 if (length $patchstackchange) {
4791 $patchstackchange =~ s/\n/,/g;
4792 $not->($p, "changed $patchstackchange");
4795 printdebug " search queue P=$p->{Commit} ",
4796 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4802 printdebug "quiltify want to smash\n";
4805 my $x = $_[0]{Commit};
4806 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4809 my $reportnot = sub {
4811 my $s = $abbrev->($notp);
4812 my $c = $notp->{Child};
4813 $s .= "..".$abbrev->($c) if $c;
4814 $s .= ": ".$notp->{Whynot};
4817 if ($quilt_mode eq 'linear') {
4818 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4819 foreach my $notp (@nots) {
4820 print STDERR "$us: ", $reportnot->($notp), "\n";
4822 print STDERR "$us: $_\n" foreach @$failsuggestion;
4823 fail "quilt fixup naive history linearisation failed.\n".
4824 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4825 } elsif ($quilt_mode eq 'smash') {
4826 } elsif ($quilt_mode eq 'auto') {
4827 progress "quilt fixup cannot be linear, smashing...";
4829 die "$quilt_mode ?";
4832 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4833 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4835 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4837 quiltify_dpkg_commit "auto-$version-$target-$time",
4838 (getfield $clogp, 'Maintainer'),
4839 "Automatically generated patch ($clogp->{Version})\n".
4840 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4844 progress "quiltify linearisation planning successful, executing...";
4846 for (my $p = $sref_S;
4847 my $c = $p->{Child};
4849 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4850 next unless $p->{Nontrivial};
4852 my $cc = $c->{Commit};
4854 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4855 $commitdata =~ m/\n\n/ or die "$c ?";
4858 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4861 my $commitdate = cmdoutput
4862 @git, qw(log -n1 --pretty=format:%aD), $cc;
4864 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4866 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4873 my $gbp_check_suitable = sub {
4878 die "contains unexpected slashes\n" if m{//} || m{/$};
4879 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4880 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4881 die "too long" if length > 200;
4883 return $_ unless $@;
4884 print STDERR "quiltifying commit $cc:".
4885 " ignoring/dropping Gbp-Pq $what: $@";
4889 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4891 (\S+) \s* \n //ixm) {
4892 $patchname = $gbp_check_suitable->($1, 'Name');
4894 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4896 (\S+) \s* \n //ixm) {
4897 $patchdir = $gbp_check_suitable->($1, 'Topic');
4902 if (!defined $patchname) {
4903 $patchname = $title;
4904 $patchname =~ s/[.:]$//;
4907 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4908 my $translitname = $converter->convert($patchname);
4909 die unless defined $translitname;
4910 $patchname = $translitname;
4913 "dgit: patch title transliteration error: $@"
4915 $patchname =~ y/ A-Z/-a-z/;
4916 $patchname =~ y/-a-z0-9_.+=~//cd;
4917 $patchname =~ s/^\W/x-$&/;
4918 $patchname = substr($patchname,0,40);
4920 if (!defined $patchdir) {
4923 if (length $patchdir) {
4924 $patchname = "$patchdir/$patchname";
4926 if ($patchname =~ m{^(.*)/}) {
4927 mkpath "debian/patches/$1";
4932 stat "debian/patches/$patchname$index";
4934 $!==ENOENT or die "$patchname$index $!";
4936 runcmd @git, qw(checkout -q), $cc;
4938 # We use the tip's changelog so that dpkg-source doesn't
4939 # produce complaining messages from dpkg-parsechangelog. None
4940 # of the information dpkg-source gets from the changelog is
4941 # actually relevant - it gets put into the original message
4942 # which dpkg-source provides our stunt editor, and then
4944 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4946 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4947 "Date: $commitdate\n".
4948 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4950 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4953 runcmd @git, qw(checkout -q master);
4956 sub build_maybe_quilt_fixup () {
4957 my ($format,$fopts) = get_source_format;
4958 return unless madformat_wantfixup $format;
4961 check_for_vendor_patches();
4963 if (quiltmode_splitbrain) {
4964 fail <<END unless access_cfg_tagformats_can_splitbrain;
4965 quilt mode $quilt_mode requires split view so server needs to support
4966 both "new" and "maint" tag formats, but config says it doesn't.
4970 my $clogp = parsechangelog();
4971 my $headref = git_rev_parse('HEAD');
4976 my $upstreamversion = upstreamversion $version;
4978 if ($fopts->{'single-debian-patch'}) {
4979 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4981 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4984 die 'bug' if $split_brain && !$need_split_build_invocation;
4986 changedir '../../../..';
4987 runcmd_ordryrun_local
4988 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4991 sub quilt_fixup_mkwork ($) {
4994 mkdir "work" or die $!;
4996 mktree_in_ud_here();
4997 runcmd @git, qw(reset -q --hard), $headref;
5000 sub quilt_fixup_linkorigs ($$) {
5001 my ($upstreamversion, $fn) = @_;
5002 # calls $fn->($leafname);
5004 foreach my $f (<../../../../*>) { #/){
5005 my $b=$f; $b =~ s{.*/}{};
5007 local ($debuglevel) = $debuglevel-1;
5008 printdebug "QF linkorigs $b, $f ?\n";
5010 next unless is_orig_file_of_vsn $b, $upstreamversion;
5011 printdebug "QF linkorigs $b, $f Y\n";
5012 link_ltarget $f, $b or die "$b $!";
5017 sub quilt_fixup_delete_pc () {
5018 runcmd @git, qw(rm -rqf .pc);
5020 Commit removal of .pc (quilt series tracking data)
5022 [dgit ($our_version) upgrade quilt-remove-pc]
5026 sub quilt_fixup_singlepatch ($$$) {
5027 my ($clogp, $headref, $upstreamversion) = @_;
5029 progress "starting quiltify (single-debian-patch)";
5031 # dpkg-source --commit generates new patches even if
5032 # single-debian-patch is in debian/source/options. In order to
5033 # get it to generate debian/patches/debian-changes, it is
5034 # necessary to build the source package.
5036 quilt_fixup_linkorigs($upstreamversion, sub { });
5037 quilt_fixup_mkwork($headref);
5039 rmtree("debian/patches");
5041 runcmd @dpkgsource, qw(-b .);
5043 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5044 rename srcfn("$upstreamversion", "/debian/patches"),
5045 "work/debian/patches";
5048 commit_quilty_patch();
5051 sub quilt_make_fake_dsc ($) {
5052 my ($upstreamversion) = @_;
5054 my $fakeversion="$upstreamversion-~~DGITFAKE";
5056 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5057 print $fakedsc <<END or die $!;
5060 Version: $fakeversion
5064 my $dscaddfile=sub {
5067 my $md = new Digest::MD5;
5069 my $fh = new IO::File $b, '<' or die "$b $!";
5074 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5077 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5079 my @files=qw(debian/source/format debian/rules
5080 debian/control debian/changelog);
5081 foreach my $maybe (qw(debian/patches debian/source/options
5082 debian/tests/control)) {
5083 next unless stat_exists "../../../$maybe";
5084 push @files, $maybe;
5087 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5088 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5090 $dscaddfile->($debtar);
5091 close $fakedsc or die $!;
5094 sub quilt_check_splitbrain_cache ($$) {
5095 my ($headref, $upstreamversion) = @_;
5096 # Called only if we are in (potentially) split brain mode.
5098 # Computes the cache key and looks in the cache.
5099 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5101 my $splitbrain_cachekey;
5104 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5105 # we look in the reflog of dgit-intern/quilt-cache
5106 # we look for an entry whose message is the key for the cache lookup
5107 my @cachekey = (qw(dgit), $our_version);
5108 push @cachekey, $upstreamversion;
5109 push @cachekey, $quilt_mode;
5110 push @cachekey, $headref;
5112 push @cachekey, hashfile('fake.dsc');
5114 my $srcshash = Digest::SHA->new(256);
5115 my %sfs = ( %INC, '$0(dgit)' => $0 );
5116 foreach my $sfk (sort keys %sfs) {
5117 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5118 $srcshash->add($sfk," ");
5119 $srcshash->add(hashfile($sfs{$sfk}));
5120 $srcshash->add("\n");
5122 push @cachekey, $srcshash->hexdigest();
5123 $splitbrain_cachekey = "@cachekey";
5125 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5127 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5128 debugcmd "|(probably)",@cmd;
5129 my $child = open GC, "-|"; defined $child or die $!;
5131 chdir '../../..' or die $!;
5132 if (!stat ".git/logs/refs/$splitbraincache") {
5133 $! == ENOENT or die $!;
5134 printdebug ">(no reflog)\n";
5141 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5142 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5145 quilt_fixup_mkwork($headref);
5146 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5147 if ($cachehit ne $headref) {
5148 progress "dgit view: found cached ($saved)";
5149 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5151 return ($cachehit, $splitbrain_cachekey);
5153 progress "dgit view: found cached, no changes required";
5154 return ($headref, $splitbrain_cachekey);
5156 die $! if GC->error;
5157 failedcmd unless close GC;
5159 printdebug "splitbrain cache miss\n";
5160 return (undef, $splitbrain_cachekey);
5163 sub quilt_fixup_multipatch ($$$) {
5164 my ($clogp, $headref, $upstreamversion) = @_;
5166 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5169 # - honour any existing .pc in case it has any strangeness
5170 # - determine the git commit corresponding to the tip of
5171 # the patch stack (if there is one)
5172 # - if there is such a git commit, convert each subsequent
5173 # git commit into a quilt patch with dpkg-source --commit
5174 # - otherwise convert all the differences in the tree into
5175 # a single git commit
5179 # Our git tree doesn't necessarily contain .pc. (Some versions of
5180 # dgit would include the .pc in the git tree.) If there isn't
5181 # one, we need to generate one by unpacking the patches that we
5184 # We first look for a .pc in the git tree. If there is one, we
5185 # will use it. (This is not the normal case.)
5187 # Otherwise need to regenerate .pc so that dpkg-source --commit
5188 # can work. We do this as follows:
5189 # 1. Collect all relevant .orig from parent directory
5190 # 2. Generate a debian.tar.gz out of
5191 # debian/{patches,rules,source/format,source/options}
5192 # 3. Generate a fake .dsc containing just these fields:
5193 # Format Source Version Files
5194 # 4. Extract the fake .dsc
5195 # Now the fake .dsc has a .pc directory.
5196 # (In fact we do this in every case, because in future we will
5197 # want to search for a good base commit for generating patches.)
5199 # Then we can actually do the dpkg-source --commit
5200 # 1. Make a new working tree with the same object
5201 # store as our main tree and check out the main
5203 # 2. Copy .pc from the fake's extraction, if necessary
5204 # 3. Run dpkg-source --commit
5205 # 4. If the result has changes to debian/, then
5206 # - git add them them
5207 # - git add .pc if we had a .pc in-tree
5209 # 5. If we had a .pc in-tree, delete it, and git commit
5210 # 6. Back in the main tree, fast forward to the new HEAD
5212 # Another situation we may have to cope with is gbp-style
5213 # patches-unapplied trees.
5215 # We would want to detect these, so we know to escape into
5216 # quilt_fixup_gbp. However, this is in general not possible.
5217 # Consider a package with a one patch which the dgit user reverts
5218 # (with git revert or the moral equivalent).
5220 # That is indistinguishable in contents from a patches-unapplied
5221 # tree. And looking at the history to distinguish them is not
5222 # useful because the user might have made a confusing-looking git
5223 # history structure (which ought to produce an error if dgit can't
5224 # cope, not a silent reintroduction of an unwanted patch).
5226 # So gbp users will have to pass an option. But we can usually
5227 # detect their failure to do so: if the tree is not a clean
5228 # patches-applied tree, quilt linearisation fails, but the tree
5229 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5230 # they want --quilt=unapplied.
5232 # To help detect this, when we are extracting the fake dsc, we
5233 # first extract it with --skip-patches, and then apply the patches
5234 # afterwards with dpkg-source --before-build. That lets us save a
5235 # tree object corresponding to .origs.
5237 my $splitbrain_cachekey;
5239 quilt_make_fake_dsc($upstreamversion);
5241 if (quiltmode_splitbrain()) {
5243 ($cachehit, $splitbrain_cachekey) =
5244 quilt_check_splitbrain_cache($headref, $upstreamversion);
5245 return if $cachehit;
5249 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5251 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5252 rename $fakexdir, "fake" or die "$fakexdir $!";
5256 remove_stray_gits("source package");
5257 mktree_in_ud_here();
5261 my $unapplied=git_add_write_tree();
5262 printdebug "fake orig tree object $unapplied\n";
5266 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5268 if (system @bbcmd) {
5269 failedcmd @bbcmd if $? < 0;
5271 failed to apply your git tree's patch stack (from debian/patches/) to
5272 the corresponding upstream tarball(s). Your source tree and .orig
5273 are probably too inconsistent. dgit can only fix up certain kinds of
5274 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5280 quilt_fixup_mkwork($headref);
5283 if (stat_exists ".pc") {
5285 progress "Tree already contains .pc - will use it then delete it.";
5288 rename '../fake/.pc','.pc' or die $!;
5291 changedir '../fake';
5293 my $oldtiptree=git_add_write_tree();
5294 printdebug "fake o+d/p tree object $unapplied\n";
5295 changedir '../work';
5298 # We calculate some guesswork now about what kind of tree this might
5299 # be. This is mostly for error reporting.
5305 # O = orig, without patches applied
5306 # A = "applied", ie orig with H's debian/patches applied
5307 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5308 \%editedignores, \@unrepres),
5309 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5310 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5314 foreach my $b (qw(01 02)) {
5315 foreach my $v (qw(O2H O2A H2A)) {
5316 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5319 printdebug "differences \@dl @dl.\n";
5322 "$us: base trees orig=%.20s o+d/p=%.20s",
5323 $unapplied, $oldtiptree;
5325 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5326 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5327 $dl[0], $dl[1], $dl[3], $dl[4],
5331 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5333 forceable_fail [qw(unrepresentable)], <<END;
5334 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5339 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5340 push @failsuggestion, "This might be a patches-unapplied branch.";
5341 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5342 push @failsuggestion, "This might be a patches-applied branch.";
5344 push @failsuggestion, "Maybe you need to specify one of".
5345 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5347 if (quiltmode_splitbrain()) {
5348 quiltify_splitbrain($clogp, $unapplied, $headref,
5349 $diffbits, \%editedignores,
5350 $splitbrain_cachekey);
5354 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5355 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5357 if (!open P, '>>', ".pc/applied-patches") {
5358 $!==&ENOENT or die $!;
5363 commit_quilty_patch();
5365 if ($mustdeletepc) {
5366 quilt_fixup_delete_pc();
5370 sub quilt_fixup_editor () {
5371 my $descfn = $ENV{$fakeeditorenv};
5372 my $editing = $ARGV[$#ARGV];
5373 open I1, '<', $descfn or die "$descfn: $!";
5374 open I2, '<', $editing or die "$editing: $!";
5375 unlink $editing or die "$editing: $!";
5376 open O, '>', $editing or die "$editing: $!";
5377 while (<I1>) { print O or die $!; } I1->error and die $!;
5380 $copying ||= m/^\-\-\- /;
5381 next unless $copying;
5384 I2->error and die $!;
5389 sub maybe_apply_patches_dirtily () {
5390 return unless $quilt_mode =~ m/gbp|unapplied/;
5391 print STDERR <<END or die $!;
5393 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5394 dgit: Have to apply the patches - making the tree dirty.
5395 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5398 $patches_applied_dirtily = 01;
5399 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5400 runcmd qw(dpkg-source --before-build .);
5403 sub maybe_unapply_patches_again () {
5404 progress "dgit: Unapplying patches again to tidy up the tree."
5405 if $patches_applied_dirtily;
5406 runcmd qw(dpkg-source --after-build .)
5407 if $patches_applied_dirtily & 01;
5409 if $patches_applied_dirtily & 02;
5410 $patches_applied_dirtily = 0;
5413 #----- other building -----
5415 our $clean_using_builder;
5416 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5417 # clean the tree before building (perhaps invoked indirectly by
5418 # whatever we are using to run the build), rather than separately
5419 # and explicitly by us.
5422 return if $clean_using_builder;
5423 if ($cleanmode eq 'dpkg-source') {
5424 maybe_apply_patches_dirtily();
5425 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5426 } elsif ($cleanmode eq 'dpkg-source-d') {
5427 maybe_apply_patches_dirtily();
5428 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5429 } elsif ($cleanmode eq 'git') {
5430 runcmd_ordryrun_local @git, qw(clean -xdf);
5431 } elsif ($cleanmode eq 'git-ff') {
5432 runcmd_ordryrun_local @git, qw(clean -xdff);
5433 } elsif ($cleanmode eq 'check') {
5434 my $leftovers = cmdoutput @git, qw(clean -xdn);
5435 if (length $leftovers) {
5436 print STDERR $leftovers, "\n" or die $!;
5437 fail "tree contains uncommitted files and --clean=check specified";
5439 } elsif ($cleanmode eq 'none') {
5446 badusage "clean takes no additional arguments" if @ARGV;
5449 maybe_unapply_patches_again();
5452 sub build_prep_early () {
5453 our $build_prep_early_done //= 0;
5454 return if $build_prep_early_done++;
5456 badusage "-p is not allowed when building" if defined $package;
5457 my $clogp = parsechangelog();
5458 $isuite = getfield $clogp, 'Distribution';
5459 $package = getfield $clogp, 'Source';
5460 $version = getfield $clogp, 'Version';
5467 build_maybe_quilt_fixup();
5469 my $pat = changespat $version;
5470 foreach my $f (glob "$buildproductsdir/$pat") {
5472 unlink $f or fail "remove old changes file $f: $!";
5474 progress "would remove $f";
5480 sub changesopts_initial () {
5481 my @opts =@changesopts[1..$#changesopts];
5484 sub changesopts_version () {
5485 if (!defined $changes_since_version) {
5486 my @vsns = archive_query('archive_query');
5487 my @quirk = access_quirk();
5488 if ($quirk[0] eq 'backports') {
5489 local $isuite = $quirk[2];
5491 canonicalise_suite();
5492 push @vsns, archive_query('archive_query');
5495 @vsns = map { $_->[0] } @vsns;
5496 @vsns = sort { -version_compare($a, $b) } @vsns;
5497 $changes_since_version = $vsns[0];
5498 progress "changelog will contain changes since $vsns[0]";
5500 $changes_since_version = '_';
5501 progress "package seems new, not specifying -v<version>";
5504 if ($changes_since_version ne '_') {
5505 return ("-v$changes_since_version");
5511 sub changesopts () {
5512 return (changesopts_initial(), changesopts_version());
5515 sub massage_dbp_args ($;$) {
5516 my ($cmd,$xargs) = @_;
5519 # - if we're going to split the source build out so we can
5520 # do strange things to it, massage the arguments to dpkg-buildpackage
5521 # so that the main build doessn't build source (or add an argument
5522 # to stop it building source by default).
5524 # - add -nc to stop dpkg-source cleaning the source tree,
5525 # unless we're not doing a split build and want dpkg-source
5526 # as cleanmode, in which case we can do nothing
5529 # 0 - source will NOT need to be built separately by caller
5530 # +1 - source will need to be built separately by caller
5531 # +2 - source will need to be built separately by caller AND
5532 # dpkg-buildpackage should not in fact be run at all!
5533 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5534 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5535 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5536 $clean_using_builder = 1;
5539 # -nc has the side effect of specifying -b if nothing else specified
5540 # and some combinations of -S, -b, et al, are errors, rather than
5541 # later simply overriding earlie. So we need to:
5542 # - search the command line for these options
5543 # - pick the last one
5544 # - perhaps add our own as a default
5545 # - perhaps adjust it to the corresponding non-source-building version
5547 foreach my $l ($cmd, $xargs) {
5549 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5552 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5554 if ($need_split_build_invocation) {
5555 printdebug "massage split $dmode.\n";
5556 $r = $dmode =~ m/[S]/ ? +2 :
5557 $dmode =~ y/gGF/ABb/ ? +1 :
5558 $dmode =~ m/[ABb]/ ? 0 :
5561 printdebug "massage done $r $dmode.\n";
5563 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5569 my $wasdir = must_getcwd();
5575 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5576 my ($msg_if_onlyone) = @_;
5577 # If there is only one .changes file, fail with $msg_if_onlyone,
5578 # or if that is undef, be a no-op.
5579 # Returns the changes file to report to the user.
5580 my $pat = changespat $version;
5581 my @changesfiles = glob $pat;
5582 @changesfiles = sort {
5583 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5587 if (@changesfiles==1) {
5588 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5589 only one changes file from build (@changesfiles)
5591 $result = $changesfiles[0];
5592 } elsif (@changesfiles==2) {
5593 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5594 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5595 fail "$l found in binaries changes file $binchanges"
5598 runcmd_ordryrun_local @mergechanges, @changesfiles;
5599 my $multichanges = changespat $version,'multi';
5601 stat_exists $multichanges or fail "$multichanges: $!";
5602 foreach my $cf (glob $pat) {
5603 next if $cf eq $multichanges;
5604 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5607 $result = $multichanges;
5609 fail "wrong number of different changes files (@changesfiles)";
5611 printdone "build successful, results in $result\n" or die $!;
5614 sub midbuild_checkchanges () {
5615 my $pat = changespat $version;
5616 return if $rmchanges;
5617 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5618 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5620 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5621 Suggest you delete @unwanted.
5626 sub midbuild_checkchanges_vanilla ($) {
5628 midbuild_checkchanges() if $wantsrc == 1;
5631 sub postbuild_mergechanges_vanilla ($) {
5633 if ($wantsrc == 1) {
5635 postbuild_mergechanges(undef);
5638 printdone "build successful\n";
5644 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5645 my $wantsrc = massage_dbp_args \@dbp;
5648 midbuild_checkchanges_vanilla $wantsrc;
5653 push @dbp, changesopts_version();
5654 maybe_apply_patches_dirtily();
5655 runcmd_ordryrun_local @dbp;
5657 maybe_unapply_patches_again();
5658 postbuild_mergechanges_vanilla $wantsrc;
5662 $quilt_mode //= 'gbp';
5668 # gbp can make .origs out of thin air. In my tests it does this
5669 # even for a 1.0 format package, with no origs present. So I
5670 # guess it keys off just the version number. We don't know
5671 # exactly what .origs ought to exist, but let's assume that we
5672 # should run gbp if: the version has an upstream part and the main
5674 my $upstreamversion = upstreamversion $version;
5675 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5676 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5678 if ($gbp_make_orig) {
5680 $cleanmode = 'none'; # don't do it again
5681 $need_split_build_invocation = 1;
5684 my @dbp = @dpkgbuildpackage;
5686 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5688 if (!length $gbp_build[0]) {
5689 if (length executable_on_path('git-buildpackage')) {
5690 $gbp_build[0] = qw(git-buildpackage);
5692 $gbp_build[0] = 'gbp buildpackage';
5695 my @cmd = opts_opt_multi_cmd @gbp_build;
5697 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5699 if ($gbp_make_orig) {
5700 ensuredir '.git/dgit';
5701 my $ok = '.git/dgit/origs-gen-ok';
5702 unlink $ok or $!==&ENOENT or die $!;
5703 my @origs_cmd = @cmd;
5704 push @origs_cmd, qw(--git-cleaner=true);
5705 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5706 push @origs_cmd, @ARGV;
5708 debugcmd @origs_cmd;
5710 do { local $!; stat_exists $ok; }
5711 or failedcmd @origs_cmd;
5713 dryrun_report @origs_cmd;
5719 midbuild_checkchanges_vanilla $wantsrc;
5721 if (!$clean_using_builder) {
5722 push @cmd, '--git-cleaner=true';
5726 maybe_unapply_patches_again();
5728 push @cmd, changesopts();
5729 runcmd_ordryrun_local @cmd, @ARGV;
5731 postbuild_mergechanges_vanilla $wantsrc;
5733 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5737 my $our_cleanmode = $cleanmode;
5738 if ($need_split_build_invocation) {
5739 # Pretend that clean is being done some other way. This
5740 # forces us not to try to use dpkg-buildpackage to clean and
5741 # build source all in one go; and instead we run dpkg-source
5742 # (and build_prep() will do the clean since $clean_using_builder
5744 $our_cleanmode = 'ELSEWHERE';
5746 if ($our_cleanmode =~ m/^dpkg-source/) {
5747 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5748 $clean_using_builder = 1;
5751 $sourcechanges = changespat $version,'source';
5753 unlink "../$sourcechanges" or $!==ENOENT
5754 or fail "remove $sourcechanges: $!";
5756 $dscfn = dscfn($version);
5757 if ($our_cleanmode eq 'dpkg-source') {
5758 maybe_apply_patches_dirtily();
5759 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5761 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5762 maybe_apply_patches_dirtily();
5763 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5766 my @cmd = (@dpkgsource, qw(-b --));
5769 runcmd_ordryrun_local @cmd, "work";
5770 my @udfiles = <${package}_*>;
5771 changedir "../../..";
5772 foreach my $f (@udfiles) {
5773 printdebug "source copy, found $f\n";
5776 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5777 $f eq srcfn($version, $&));
5778 printdebug "source copy, found $f - renaming\n";
5779 rename "$ud/$f", "../$f" or $!==ENOENT
5780 or fail "put in place new source file ($f): $!";
5783 my $pwd = must_getcwd();
5784 my $leafdir = basename $pwd;
5786 runcmd_ordryrun_local @cmd, $leafdir;
5789 runcmd_ordryrun_local qw(sh -ec),
5790 'exec >$1; shift; exec "$@"','x',
5791 "../$sourcechanges",
5792 @dpkggenchanges, qw(-S), changesopts();
5796 sub cmd_build_source {
5798 badusage "build-source takes no additional arguments" if @ARGV;
5800 maybe_unapply_patches_again();
5801 printdone "source built, results in $dscfn and $sourcechanges";
5806 midbuild_checkchanges();
5809 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5810 stat_exists $sourcechanges
5811 or fail "$sourcechanges (in parent directory): $!";
5813 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5815 maybe_unapply_patches_again();
5817 postbuild_mergechanges(<<END);
5818 perhaps you need to pass -A ? (sbuild's default is to build only
5819 arch-specific binaries; dgit 1.4 used to override that.)
5824 sub cmd_quilt_fixup {
5825 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5828 build_maybe_quilt_fixup();
5831 sub cmd_import_dsc {
5835 last unless $ARGV[0] =~ m/^-/;
5838 if (m/^--require-valid-signature$/) {
5841 badusage "unknown dgit import-dsc sub-option \`$_'";
5845 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5846 my ($dscfn, $dstbranch) = @ARGV;
5848 badusage "dry run makes no sense with import-dsc" unless act_local();
5850 my $force = $dstbranch =~ s/^\+// ? +1 :
5851 $dstbranch =~ s/^\.\.// ? -1 :
5853 my $info = $force ? " $&" : '';
5854 $info = "$dscfn$info";
5856 my $specbranch = $dstbranch;
5857 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5858 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5860 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5861 my $chead = cmdoutput_errok @symcmd;
5862 defined $chead or $?==256 or failedcmd @symcmd;
5864 fail "$dstbranch is checked out - will not update it"
5865 if defined $chead and $chead eq $dstbranch;
5867 my $oldhash = git_get_ref $dstbranch;
5869 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5870 $dscdata = do { local $/ = undef; <D>; };
5871 D->error and fail "read $dscfn: $!";
5874 # we don't normally need this so import it here
5875 use Dpkg::Source::Package;
5876 my $dp = new Dpkg::Source::Package filename => $dscfn,
5877 require_valid_signature => $needsig;
5879 local $SIG{__WARN__} = sub {
5881 return unless $needsig;
5882 fail "import-dsc signature check failed";
5884 if (!$dp->is_signed()) {
5885 warn "$us: warning: importing unsigned .dsc\n";
5887 my $r = $dp->check_signature();
5888 die "->check_signature => $r" if $needsig && $r;
5894 my $dgit_commit = $dsc->{$ourdscfield[0]};
5895 if (defined $dgit_commit
5896 && !forceing [qw(import-dsc-with-dgit-field)]) {
5897 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5899 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5900 my @cmd = (qw(sh -ec),
5901 "echo $dgit_commit | git cat-file --batch-check");
5902 my $objgot = cmdoutput @cmd;
5903 if ($objgot =~ m#^\w+ missing\b#) {
5905 .dsc contains Dgit field referring to object $dgit_commit
5906 Your git tree does not have that object. Try `git fetch' from a
5907 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5910 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5912 progress "Not fast forward, forced update.";
5914 fail "Not fast forward to $dgit_commit";
5917 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5918 $dstbranch, $dgit_commit);
5920 progress "dgit: import-dsc updated git ref $dstbranch";
5925 Branch $dstbranch already exists
5926 Specify ..$specbranch for a pseudo-merge, binding in existing history
5927 Specify +$specbranch to overwrite, discarding existing history
5929 if $oldhash && !$force;
5931 $package = getfield $dsc, 'Source';
5932 my @dfi = dsc_files_info();
5933 foreach my $fi (@dfi) {
5934 my $f = $fi->{Filename};
5936 next if lstat $here;
5937 fail "stat $here: $!" unless $! == ENOENT;
5939 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5941 } elsif ($dscfn =~ m#^/#) {
5944 fail "cannot import $dscfn which seems to be inside working tree!";
5946 $there =~ s#/+[^/]+$## or
5947 fail "cannot import $dscfn which seems to not have a basename";
5949 symlink $there, $here or fail "symlink $there to $here: $!";
5950 progress "made symlink $here -> $there";
5951 # print STDERR Dumper($fi);
5953 my @mergeinputs = generate_commits_from_dsc();
5954 die unless @mergeinputs == 1;
5956 my $newhash = $mergeinputs[0]{Commit};
5960 progress "Import, forced update - synthetic orphan git history.";
5961 } elsif ($force < 0) {
5962 progress "Import, merging.";
5963 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5964 my $version = getfield $dsc, 'Version';
5965 my $clogp = commit_getclogp $newhash;
5966 my $authline = clogp_authline $clogp;
5967 $newhash = make_commit_text <<END;
5974 Merge $package ($version) import into $dstbranch
5977 die; # caught earlier
5981 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5982 $dstbranch, $newhash);
5984 progress "dgit: import-dsc results are in in git ref $dstbranch";
5987 sub cmd_archive_api_query {
5988 badusage "need only 1 subpath argument" unless @ARGV==1;
5989 my ($subpath) = @ARGV;
5990 my @cmd = archive_api_query_cmd($subpath);
5993 exec @cmd or fail "exec curl: $!\n";
5996 sub cmd_clone_dgit_repos_server {
5997 badusage "need destination argument" unless @ARGV==1;
5998 my ($destdir) = @ARGV;
5999 $package = '_dgit-repos-server';
6000 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6002 exec @cmd or fail "exec git clone: $!\n";
6005 sub cmd_setup_mergechangelogs {
6006 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6007 setup_mergechangelogs(1);
6010 sub cmd_setup_useremail {
6011 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6015 sub cmd_setup_new_tree {
6016 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6020 #---------- argument parsing and main program ----------
6023 print "dgit version $our_version\n" or die $!;
6027 our (%valopts_long, %valopts_short);
6030 sub defvalopt ($$$$) {
6031 my ($long,$short,$val_re,$how) = @_;
6032 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6033 $valopts_long{$long} = $oi;
6034 $valopts_short{$short} = $oi;
6035 # $how subref should:
6036 # do whatever assignemnt or thing it likes with $_[0]
6037 # if the option should not be passed on to remote, @rvalopts=()
6038 # or $how can be a scalar ref, meaning simply assign the value
6041 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6042 defvalopt '--distro', '-d', '.+', \$idistro;
6043 defvalopt '', '-k', '.+', \$keyid;
6044 defvalopt '--existing-package','', '.*', \$existing_package;
6045 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6046 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6047 defvalopt '--package', '-p', $package_re, \$package;
6048 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6050 defvalopt '', '-C', '.+', sub {
6051 ($changesfile) = (@_);
6052 if ($changesfile =~ s#^(.*)/##) {
6053 $buildproductsdir = $1;
6057 defvalopt '--initiator-tempdir','','.*', sub {
6058 ($initiator_tempdir) = (@_);
6059 $initiator_tempdir =~ m#^/# or
6060 badusage "--initiator-tempdir must be used specify an".
6061 " absolute, not relative, directory."
6067 if (defined $ENV{'DGIT_SSH'}) {
6068 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6069 } elsif (defined $ENV{'GIT_SSH'}) {
6070 @ssh = ($ENV{'GIT_SSH'});
6078 if (!defined $val) {
6079 badusage "$what needs a value" unless @ARGV;
6081 push @rvalopts, $val;
6083 badusage "bad value \`$val' for $what" unless
6084 $val =~ m/^$oi->{Re}$(?!\n)/s;
6085 my $how = $oi->{How};
6086 if (ref($how) eq 'SCALAR') {
6091 push @ropts, @rvalopts;
6095 last unless $ARGV[0] =~ m/^-/;
6099 if (m/^--dry-run$/) {
6102 } elsif (m/^--damp-run$/) {
6105 } elsif (m/^--no-sign$/) {
6108 } elsif (m/^--help$/) {
6110 } elsif (m/^--version$/) {
6112 } elsif (m/^--new$/) {
6115 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6116 ($om = $opts_opt_map{$1}) &&
6120 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6121 !$opts_opt_cmdonly{$1} &&
6122 ($om = $opts_opt_map{$1})) {
6125 } elsif (m/^--(gbp|dpm)$/s) {
6126 push @ropts, "--quilt=$1";
6128 } elsif (m/^--ignore-dirty$/s) {
6131 } elsif (m/^--no-quilt-fixup$/s) {
6133 $quilt_mode = 'nocheck';
6134 } elsif (m/^--no-rm-on-error$/s) {
6137 } elsif (m/^--overwrite$/s) {
6139 $overwrite_version = '';
6140 } elsif (m/^--overwrite=(.+)$/s) {
6142 $overwrite_version = $1;
6143 } elsif (m/^--dep14tag$/s) {
6145 $dodep14tag= 'want';
6146 } elsif (m/^--no-dep14tag$/s) {
6149 } elsif (m/^--always-dep14tag$/s) {
6151 $dodep14tag= 'always';
6152 } elsif (m/^--delayed=(\d+)$/s) {
6155 } elsif (m/^--dgit-view-save=(.+)$/s) {
6157 $split_brain_save = $1;
6158 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6159 } elsif (m/^--(no-)?rm-old-changes$/s) {
6162 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6164 push @deliberatelies, $&;
6165 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6169 } elsif (m/^--force-/) {
6171 "$us: warning: ignoring unknown force option $_\n";
6173 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6174 # undocumented, for testing
6176 $tagformat_want = [ $1, 'command line', 1 ];
6177 # 1 menas overrides distro configuration
6178 } elsif (m/^--always-split-source-build$/s) {
6179 # undocumented, for testing
6181 $need_split_build_invocation = 1;
6182 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6183 $val = $2 ? $' : undef; #';
6184 $valopt->($oi->{Long});
6186 badusage "unknown long option \`$_'";
6193 } elsif (s/^-L/-/) {
6196 } elsif (s/^-h/-/) {
6198 } elsif (s/^-D/-/) {
6202 } elsif (s/^-N/-/) {
6207 push @changesopts, $_;
6209 } elsif (s/^-wn$//s) {
6211 $cleanmode = 'none';
6212 } elsif (s/^-wg$//s) {
6215 } elsif (s/^-wgf$//s) {
6217 $cleanmode = 'git-ff';
6218 } elsif (s/^-wd$//s) {
6220 $cleanmode = 'dpkg-source';
6221 } elsif (s/^-wdd$//s) {
6223 $cleanmode = 'dpkg-source-d';
6224 } elsif (s/^-wc$//s) {
6226 $cleanmode = 'check';
6227 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6228 push @git, '-c', $&;
6229 $gitcfgs{cmdline}{$1} = [ $2 ];
6230 } elsif (s/^-c([^=]+)$//s) {
6231 push @git, '-c', $&;
6232 $gitcfgs{cmdline}{$1} = [ 'true' ];
6233 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6235 $val = undef unless length $val;
6236 $valopt->($oi->{Short});
6239 badusage "unknown short option \`$_'";
6246 sub check_env_sanity () {
6247 my $blocked = new POSIX::SigSet;
6248 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6251 foreach my $name (qw(PIPE CHLD)) {
6252 my $signame = "SIG$name";
6253 my $signum = eval "POSIX::$signame" // die;
6254 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6255 die "$signame is set to something other than SIG_DFL\n";
6256 $blocked->ismember($signum) and
6257 die "$signame is blocked\n";
6263 On entry to dgit, $@
6264 This is a bug produced by something in in your execution environment.
6270 sub parseopts_late_defaults () {
6271 foreach my $k (keys %opts_opt_map) {
6272 my $om = $opts_opt_map{$k};
6274 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6276 badcfg "cannot set command for $k"
6277 unless length $om->[0];
6281 foreach my $c (access_cfg_cfgs("opts-$k")) {
6283 map { $_ ? @$_ : () }
6284 map { $gitcfgs{$_}{$c} }
6285 reverse @gitcfgsources;
6286 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6287 "\n" if $debuglevel >= 4;
6289 badcfg "cannot configure options for $k"
6290 if $opts_opt_cmdonly{$k};
6291 my $insertpos = $opts_cfg_insertpos{$k};
6292 @$om = ( @$om[0..$insertpos-1],
6294 @$om[$insertpos..$#$om] );
6298 if (!defined $rmchanges) {
6299 local $access_forpush;
6300 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6303 if (!defined $quilt_mode) {
6304 local $access_forpush;
6305 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6306 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6308 $quilt_mode =~ m/^($quilt_modes_re)$/
6309 or badcfg "unknown quilt-mode \`$quilt_mode'";
6313 if (!defined $dodep14tag) {
6314 local $access_forpush;
6315 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6316 $dodep14tag =~ m/^($dodep14tag_re)$/
6317 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6321 $need_split_build_invocation ||= quiltmode_splitbrain();
6323 if (!defined $cleanmode) {
6324 local $access_forpush;
6325 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6326 $cleanmode //= 'dpkg-source';
6328 badcfg "unknown clean-mode \`$cleanmode'" unless
6329 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6333 if ($ENV{$fakeeditorenv}) {
6335 quilt_fixup_editor();
6342 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6343 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6344 if $dryrun_level == 1;
6346 print STDERR $helpmsg or die $!;
6349 my $cmd = shift @ARGV;
6352 my $pre_fn = ${*::}{"pre_$cmd"};
6353 $pre_fn->() if $pre_fn;
6355 my $fn = ${*::}{"cmd_$cmd"};
6356 $fn or badusage "unknown operation $cmd";