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 parse_dsc_field ($$) {
2704 my ($f, $what) = @_;
2706 progress "$what: NO git hash";
2707 } elsif ($f =~ m/^\w+/) {
2709 progress "$what: specified git hash";
2711 fail "$what: invalid Dgit info";
2715 sub fetch_from_archive () {
2716 ensure_setup_existing_tree();
2718 # Ensures that lrref() is what is actually in the archive, one way
2719 # or another, according to us - ie this client's
2720 # appropritaely-updated archive view. Also returns the commit id.
2721 # If there is nothing in the archive, leaves lrref alone and
2722 # returns undef. git_fetch_us must have already been called.
2727 foreach my $field (@ourdscfield) {
2728 $f = $dsc->{$field};
2731 parse_dsc_field($f, 'last upload to archive');
2733 progress "no version available from the archive";
2736 my $rewritemapdata = git_cat_file lrfetchrefs."/".$rewritemap.':map';
2737 if (defined $rewritemapdata
2738 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2739 progress "server's git history rewrite map contains a relevant entry!";
2741 if (defined $dsc_hash) {
2742 progress "using rewritten git hash in place of .dsc value";
2744 progress "server data says .dsc hash is to be disregarded";
2748 # If the archive's .dsc has a Dgit field, there are three
2749 # relevant git commitids we need to choose between and/or merge
2751 # 1. $dsc_hash: the Dgit field from the archive
2752 # 2. $lastpush_hash: the suite branch on the dgit git server
2753 # 3. $lastfetch_hash: our local tracking brach for the suite
2755 # These may all be distinct and need not be in any fast forward
2758 # If the dsc was pushed to this suite, then the server suite
2759 # branch will have been updated; but it might have been pushed to
2760 # a different suite and copied by the archive. Conversely a more
2761 # recent version may have been pushed with dgit but not appeared
2762 # in the archive (yet).
2764 # $lastfetch_hash may be awkward because archive imports
2765 # (particularly, imports of Dgit-less .dscs) are performed only as
2766 # needed on individual clients, so different clients may perform a
2767 # different subset of them - and these imports are only made
2768 # public during push. So $lastfetch_hash may represent a set of
2769 # imports different to a subsequent upload by a different dgit
2772 # Our approach is as follows:
2774 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2775 # descendant of $dsc_hash, then it was pushed by a dgit user who
2776 # had based their work on $dsc_hash, so we should prefer it.
2777 # Otherwise, $dsc_hash was installed into this suite in the
2778 # archive other than by a dgit push, and (necessarily) after the
2779 # last dgit push into that suite (since a dgit push would have
2780 # been descended from the dgit server git branch); thus, in that
2781 # case, we prefer the archive's version (and produce a
2782 # pseudo-merge to overwrite the dgit server git branch).
2784 # (If there is no Dgit field in the archive's .dsc then
2785 # generate_commit_from_dsc uses the version numbers to decide
2786 # whether the suite branch or the archive is newer. If the suite
2787 # branch is newer it ignores the archive's .dsc; otherwise it
2788 # generates an import of the .dsc, and produces a pseudo-merge to
2789 # overwrite the suite branch with the archive contents.)
2791 # The outcome of that part of the algorithm is the `public view',
2792 # and is same for all dgit clients: it does not depend on any
2793 # unpublished history in the local tracking branch.
2795 # As between the public view and the local tracking branch: The
2796 # local tracking branch is only updated by dgit fetch, and
2797 # whenever dgit fetch runs it includes the public view in the
2798 # local tracking branch. Therefore if the public view is not
2799 # descended from the local tracking branch, the local tracking
2800 # branch must contain history which was imported from the archive
2801 # but never pushed; and, its tip is now out of date. So, we make
2802 # a pseudo-merge to overwrite the old imports and stitch the old
2805 # Finally: we do not necessarily reify the public view (as
2806 # described above). This is so that we do not end up stacking two
2807 # pseudo-merges. So what we actually do is figure out the inputs
2808 # to any public view pseudo-merge and put them in @mergeinputs.
2811 # $mergeinputs[]{Commit}
2812 # $mergeinputs[]{Info}
2813 # $mergeinputs[0] is the one whose tree we use
2814 # @mergeinputs is in the order we use in the actual commit)
2817 # $mergeinputs[]{Message} is a commit message to use
2818 # $mergeinputs[]{ReverseParents} if def specifies that parent
2819 # list should be in opposite order
2820 # Such an entry has no Commit or Info. It applies only when found
2821 # in the last entry. (This ugliness is to support making
2822 # identical imports to previous dgit versions.)
2824 my $lastpush_hash = git_get_ref(lrfetchref());
2825 printdebug "previous reference hash=$lastpush_hash\n";
2826 $lastpush_mergeinput = $lastpush_hash && {
2827 Commit => $lastpush_hash,
2828 Info => "dgit suite branch on dgit git server",
2831 my $lastfetch_hash = git_get_ref(lrref());
2832 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2833 my $lastfetch_mergeinput = $lastfetch_hash && {
2834 Commit => $lastfetch_hash,
2835 Info => "dgit client's archive history view",
2838 my $dsc_mergeinput = $dsc_hash && {
2839 Commit => $dsc_hash,
2840 Info => "Dgit field in .dsc from archive",
2844 my $del_lrfetchrefs = sub {
2847 printdebug "del_lrfetchrefs...\n";
2848 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2849 my $objid = $lrfetchrefs_d{$fullrefname};
2850 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2852 $gur ||= new IO::Handle;
2853 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2855 printf $gur "delete %s %s\n", $fullrefname, $objid;
2858 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2862 if (defined $dsc_hash) {
2863 ensure_we_have_orig();
2864 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2865 @mergeinputs = $dsc_mergeinput
2866 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2867 print STDERR <<END or die $!;
2869 Git commit in archive is behind the last version allegedly pushed/uploaded.
2870 Commit referred to by archive: $dsc_hash
2871 Last version pushed with dgit: $lastpush_hash
2874 @mergeinputs = ($lastpush_mergeinput);
2876 # Archive has .dsc which is not a descendant of the last dgit
2877 # push. This can happen if the archive moves .dscs about.
2878 # Just follow its lead.
2879 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2880 progress "archive .dsc names newer git commit";
2881 @mergeinputs = ($dsc_mergeinput);
2883 progress "archive .dsc names other git commit, fixing up";
2884 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2888 @mergeinputs = generate_commits_from_dsc();
2889 # We have just done an import. Now, our import algorithm might
2890 # have been improved. But even so we do not want to generate
2891 # a new different import of the same package. So if the
2892 # version numbers are the same, just use our existing version.
2893 # If the version numbers are different, the archive has changed
2894 # (perhaps, rewound).
2895 if ($lastfetch_mergeinput &&
2896 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2897 (mergeinfo_version $mergeinputs[0]) )) {
2898 @mergeinputs = ($lastfetch_mergeinput);
2900 } elsif ($lastpush_hash) {
2901 # only in git, not in the archive yet
2902 @mergeinputs = ($lastpush_mergeinput);
2903 print STDERR <<END or die $!;
2905 Package not found in the archive, but has allegedly been pushed using dgit.
2909 printdebug "nothing found!\n";
2910 if (defined $skew_warning_vsn) {
2911 print STDERR <<END or die $!;
2913 Warning: relevant archive skew detected.
2914 Archive allegedly contains $skew_warning_vsn
2915 But we were not able to obtain any version from the archive or git.
2919 unshift @end, $del_lrfetchrefs;
2923 if ($lastfetch_hash &&
2925 my $h = $_->{Commit};
2926 $h and is_fast_fwd($lastfetch_hash, $h);
2927 # If true, one of the existing parents of this commit
2928 # is a descendant of the $lastfetch_hash, so we'll
2929 # be ff from that automatically.
2933 push @mergeinputs, $lastfetch_mergeinput;
2936 printdebug "fetch mergeinfos:\n";
2937 foreach my $mi (@mergeinputs) {
2939 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2941 printdebug sprintf " ReverseParents=%d Message=%s",
2942 $mi->{ReverseParents}, $mi->{Message};
2946 my $compat_info= pop @mergeinputs
2947 if $mergeinputs[$#mergeinputs]{Message};
2949 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2952 if (@mergeinputs > 1) {
2954 my $tree_commit = $mergeinputs[0]{Commit};
2956 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2957 $tree =~ m/\n\n/; $tree = $`;
2958 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2961 # We use the changelog author of the package in question the
2962 # author of this pseudo-merge. This is (roughly) correct if
2963 # this commit is simply representing aa non-dgit upload.
2964 # (Roughly because it does not record sponsorship - but we
2965 # don't have sponsorship info because that's in the .changes,
2966 # which isn't in the archivw.)
2968 # But, it might be that we are representing archive history
2969 # updates (including in-archive copies). These are not really
2970 # the responsibility of the person who created the .dsc, but
2971 # there is no-one whose name we should better use. (The
2972 # author of the .dsc-named commit is clearly worse.)
2974 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2975 my $author = clogp_authline $useclogp;
2976 my $cversion = getfield $useclogp, 'Version';
2978 my $mcf = ".git/dgit/mergecommit";
2979 open MC, ">", $mcf or die "$mcf $!";
2980 print MC <<END or die $!;
2984 my @parents = grep { $_->{Commit} } @mergeinputs;
2985 @parents = reverse @parents if $compat_info->{ReverseParents};
2986 print MC <<END or die $! foreach @parents;
2990 print MC <<END or die $!;
2996 if (defined $compat_info->{Message}) {
2997 print MC $compat_info->{Message} or die $!;
2999 print MC <<END or die $!;
3000 Record $package ($cversion) in archive suite $csuite
3004 my $message_add_info = sub {
3006 my $mversion = mergeinfo_version $mi;
3007 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3011 $message_add_info->($mergeinputs[0]);
3012 print MC <<END or die $!;
3013 should be treated as descended from
3015 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3019 $hash = make_commit $mcf;
3021 $hash = $mergeinputs[0]{Commit};
3023 printdebug "fetch hash=$hash\n";
3026 my ($lasth, $what) = @_;
3027 return unless $lasth;
3028 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3031 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3033 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3035 fetch_from_archive_record_1($hash);
3037 if (defined $skew_warning_vsn) {
3039 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3040 my $gotclogp = commit_getclogp($hash);
3041 my $got_vsn = getfield $gotclogp, 'Version';
3042 printdebug "SKEW CHECK GOT $got_vsn\n";
3043 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3044 print STDERR <<END or die $!;
3046 Warning: archive skew detected. Using the available version:
3047 Archive allegedly contains $skew_warning_vsn
3048 We were able to obtain only $got_vsn
3054 if ($lastfetch_hash ne $hash) {
3055 fetch_from_archive_record_2($hash);
3058 lrfetchref_used lrfetchref();
3060 unshift @end, $del_lrfetchrefs;
3064 sub set_local_git_config ($$) {
3066 runcmd @git, qw(config), $k, $v;
3069 sub setup_mergechangelogs (;$) {
3071 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3073 my $driver = 'dpkg-mergechangelogs';
3074 my $cb = "merge.$driver";
3075 my $attrs = '.git/info/attributes';
3076 ensuredir '.git/info';
3078 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3079 if (!open ATTRS, "<", $attrs) {
3080 $!==ENOENT or die "$attrs: $!";
3084 next if m{^debian/changelog\s};
3085 print NATTRS $_, "\n" or die $!;
3087 ATTRS->error and die $!;
3090 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3093 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3094 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3096 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3099 sub setup_useremail (;$) {
3101 return unless $always || access_cfg_bool(1, 'setup-useremail');
3104 my ($k, $envvar) = @_;
3105 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3106 return unless defined $v;
3107 set_local_git_config "user.$k", $v;
3110 $setup->('email', 'DEBEMAIL');
3111 $setup->('name', 'DEBFULLNAME');
3114 sub ensure_setup_existing_tree () {
3115 my $k = "remote.$remotename.skipdefaultupdate";
3116 my $c = git_get_config $k;
3117 return if defined $c;
3118 set_local_git_config $k, 'true';
3121 sub setup_new_tree () {
3122 setup_mergechangelogs();
3126 sub multisuite_suite_child ($$$) {
3127 my ($tsuite, $merginputs, $fn) = @_;
3128 # in child, sets things up, calls $fn->(), and returns undef
3129 # in parent, returns canonical suite name for $tsuite
3130 my $canonsuitefh = IO::File::new_tmpfile;
3131 my $pid = fork // die $!;
3134 $us .= " [$isuite]";
3135 $debugprefix .= " ";
3136 progress "fetching $tsuite...";
3137 canonicalise_suite();
3138 print $canonsuitefh $csuite, "\n" or die $!;
3139 close $canonsuitefh or die $!;
3143 waitpid $pid,0 == $pid or die $!;
3144 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3145 seek $canonsuitefh,0,0 or die $!;
3146 local $csuite = <$canonsuitefh>;
3147 die $! unless defined $csuite && chomp $csuite;
3149 printdebug "multisuite $tsuite missing\n";
3152 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3153 push @$merginputs, {
3160 sub fork_for_multisuite ($) {
3161 my ($before_fetch_merge) = @_;
3162 # if nothing unusual, just returns ''
3165 # returns 0 to caller in child, to do first of the specified suites
3166 # in child, $csuite is not yet set
3168 # returns 1 to caller in parent, to finish up anything needed after
3169 # in parent, $csuite is set to canonicalised portmanteau
3171 my $org_isuite = $isuite;
3172 my @suites = split /\,/, $isuite;
3173 return '' unless @suites > 1;
3174 printdebug "fork_for_multisuite: @suites\n";
3178 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3180 return 0 unless defined $cbasesuite;
3182 fail "package $package missing in (base suite) $cbasesuite"
3183 unless @mergeinputs;
3185 my @csuites = ($cbasesuite);
3187 $before_fetch_merge->();
3189 foreach my $tsuite (@suites[1..$#suites]) {
3190 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3196 # xxx collecte the ref here
3198 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3199 push @csuites, $csubsuite;
3202 foreach my $mi (@mergeinputs) {
3203 my $ref = git_get_ref $mi->{Ref};
3204 die "$mi->{Ref} ?" unless length $ref;
3205 $mi->{Commit} = $ref;
3208 $csuite = join ",", @csuites;
3210 my $previous = git_get_ref lrref;
3212 unshift @mergeinputs, {
3213 Commit => $previous,
3214 Info => "local combined tracking branch",
3216 "archive seems to have rewound: local tracking branch is ahead!",
3220 foreach my $ix (0..$#mergeinputs) {
3221 $mergeinputs[$ix]{Index} = $ix;
3224 @mergeinputs = sort {
3225 -version_compare(mergeinfo_version $a,
3226 mergeinfo_version $b) # highest version first
3228 $a->{Index} <=> $b->{Index}; # earliest in spec first
3234 foreach my $mi (@mergeinputs) {
3235 printdebug "multisuite merge check $mi->{Info}\n";
3236 foreach my $previous (@needed) {
3237 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3238 printdebug "multisuite merge un-needed $previous->{Info}\n";
3242 printdebug "multisuite merge this-needed\n";
3243 $mi->{Character} = '+';
3246 $needed[0]{Character} = '*';
3248 my $output = $needed[0]{Commit};
3251 printdebug "multisuite merge nontrivial\n";
3252 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3254 my $commit = "tree $tree\n";
3255 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3256 "Input branches:\n";
3258 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3259 printdebug "multisuite merge include $mi->{Info}\n";
3260 $mi->{Character} //= ' ';
3261 $commit .= "parent $mi->{Commit}\n";
3262 $msg .= sprintf " %s %-25s %s\n",
3264 (mergeinfo_version $mi),
3267 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3269 " * marks the highest version branch, which choose to use\n".
3270 " + marks each branch which was not already an ancestor\n\n".
3271 "[dgit multi-suite $csuite]\n";
3273 "author $authline\n".
3274 "committer $authline\n\n";
3275 $output = make_commit_text $commit.$msg;
3276 printdebug "multisuite merge generated $output\n";
3279 fetch_from_archive_record_1($output);
3280 fetch_from_archive_record_2($output);
3282 progress "calculated combined tracking suite $csuite";
3287 sub clone_set_head () {
3288 open H, "> .git/HEAD" or die $!;
3289 print H "ref: ".lref()."\n" or die $!;
3292 sub clone_finish ($) {
3294 runcmd @git, qw(reset --hard), lrref();
3295 runcmd qw(bash -ec), <<'END';
3297 git ls-tree -r --name-only -z HEAD | \
3298 xargs -0r touch -h -r . --
3300 printdone "ready for work in $dstdir";
3305 badusage "dry run makes no sense with clone" unless act_local();
3307 my $multi_fetched = fork_for_multisuite(sub {
3308 printdebug "multi clone before fetch merge\n";
3311 if ($multi_fetched) {
3312 printdebug "multi clone after fetch merge\n";
3314 clone_finish($dstdir);
3317 printdebug "clone main body\n";
3319 canonicalise_suite();
3320 my $hasgit = check_for_git();
3321 mkdir $dstdir or fail "create \`$dstdir': $!";
3323 runcmd @git, qw(init -q);
3325 my $giturl = access_giturl(1);
3326 if (defined $giturl) {
3327 runcmd @git, qw(remote add), 'origin', $giturl;
3330 progress "fetching existing git history";
3332 runcmd_ordryrun_local @git, qw(fetch origin);
3334 progress "starting new git history";
3336 fetch_from_archive() or no_such_package;
3337 my $vcsgiturl = $dsc->{'Vcs-Git'};
3338 if (length $vcsgiturl) {
3339 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3340 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3343 clone_finish($dstdir);
3347 canonicalise_suite();
3348 if (check_for_git()) {
3351 fetch_from_archive() or no_such_package();
3352 printdone "fetched into ".lrref();
3356 my $multi_fetched = fork_for_multisuite(sub { });
3357 fetch() unless $multi_fetched; # parent
3358 return if $multi_fetched eq '0'; # child
3359 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3361 printdone "fetched to ".lrref()." and merged into HEAD";
3364 sub check_not_dirty () {
3365 foreach my $f (qw(local-options local-patch-header)) {
3366 if (stat_exists "debian/source/$f") {
3367 fail "git tree contains debian/source/$f";
3371 return if $ignoredirty;
3373 my @cmd = (@git, qw(diff --quiet HEAD));
3375 $!=0; $?=-1; system @cmd;
3378 fail "working tree is dirty (does not match HEAD)";
3384 sub commit_admin ($) {
3387 runcmd_ordryrun_local @git, qw(commit -m), $m;
3390 sub commit_quilty_patch () {
3391 my $output = cmdoutput @git, qw(status --porcelain);
3393 foreach my $l (split /\n/, $output) {
3394 next unless $l =~ m/\S/;
3395 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3399 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3401 progress "nothing quilty to commit, ok.";
3404 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3405 runcmd_ordryrun_local @git, qw(add -f), @adds;
3407 Commit Debian 3.0 (quilt) metadata
3409 [dgit ($our_version) quilt-fixup]
3413 sub get_source_format () {
3415 if (open F, "debian/source/options") {
3419 s/\s+$//; # ignore missing final newline
3421 my ($k, $v) = ($`, $'); #');
3422 $v =~ s/^"(.*)"$/$1/;
3428 F->error and die $!;
3431 die $! unless $!==&ENOENT;
3434 if (!open F, "debian/source/format") {
3435 die $! unless $!==&ENOENT;
3439 F->error and die $!;
3441 return ($_, \%options);
3444 sub madformat_wantfixup ($) {
3446 return 0 unless $format eq '3.0 (quilt)';
3447 our $quilt_mode_warned;
3448 if ($quilt_mode eq 'nocheck') {
3449 progress "Not doing any fixup of \`$format' due to".
3450 " ----no-quilt-fixup or --quilt=nocheck"
3451 unless $quilt_mode_warned++;
3454 progress "Format \`$format', need to check/update patch stack"
3455 unless $quilt_mode_warned++;
3459 sub maybe_split_brain_save ($$$) {
3460 my ($headref, $dgitview, $msg) = @_;
3461 # => message fragment "$saved" describing disposition of $dgitview
3462 return "commit id $dgitview" unless defined $split_brain_save;
3463 my @cmd = (shell_cmd "cd ../../../..",
3464 @git, qw(update-ref -m),
3465 "dgit --dgit-view-save $msg HEAD=$headref",
3466 $split_brain_save, $dgitview);
3468 return "and left in $split_brain_save";
3471 # An "infopair" is a tuple [ $thing, $what ]
3472 # (often $thing is a commit hash; $what is a description)
3474 sub infopair_cond_equal ($$) {
3476 $x->[0] eq $y->[0] or fail <<END;
3477 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3481 sub infopair_lrf_tag_lookup ($$) {
3482 my ($tagnames, $what) = @_;
3483 # $tagname may be an array ref
3484 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3485 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3486 foreach my $tagname (@tagnames) {
3487 my $lrefname = lrfetchrefs."/tags/$tagname";
3488 my $tagobj = $lrfetchrefs_f{$lrefname};
3489 next unless defined $tagobj;
3490 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3491 return [ git_rev_parse($tagobj), $what ];
3493 fail @tagnames==1 ? <<END : <<END;
3494 Wanted tag $what (@tagnames) on dgit server, but not found
3496 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3500 sub infopair_cond_ff ($$) {
3501 my ($anc,$desc) = @_;
3502 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3503 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3507 sub pseudomerge_version_check ($$) {
3508 my ($clogp, $archive_hash) = @_;
3510 my $arch_clogp = commit_getclogp $archive_hash;
3511 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3512 'version currently in archive' ];
3513 if (defined $overwrite_version) {
3514 if (length $overwrite_version) {
3515 infopair_cond_equal([ $overwrite_version,
3516 '--overwrite= version' ],
3519 my $v = $i_arch_v->[0];
3520 progress "Checking package changelog for archive version $v ...";
3522 my @xa = ("-f$v", "-t$v");
3523 my $vclogp = parsechangelog @xa;
3524 my $cv = [ (getfield $vclogp, 'Version'),
3525 "Version field from dpkg-parsechangelog @xa" ];
3526 infopair_cond_equal($i_arch_v, $cv);
3529 $@ =~ s/^dgit: //gm;
3531 "Perhaps debian/changelog does not mention $v ?";
3536 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3540 sub pseudomerge_make_commit ($$$$ $$) {
3541 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3542 $msg_cmd, $msg_msg) = @_;
3543 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3545 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3546 my $authline = clogp_authline $clogp;
3550 !defined $overwrite_version ? ""
3551 : !length $overwrite_version ? " --overwrite"
3552 : " --overwrite=".$overwrite_version;
3555 my $pmf = ".git/dgit/pseudomerge";
3556 open MC, ">", $pmf or die "$pmf $!";
3557 print MC <<END or die $!;
3560 parent $archive_hash
3570 return make_commit($pmf);
3573 sub splitbrain_pseudomerge ($$$$) {
3574 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3575 # => $merged_dgitview
3576 printdebug "splitbrain_pseudomerge...\n";
3578 # We: debian/PREVIOUS HEAD($maintview)
3579 # expect: o ----------------- o
3582 # a/d/PREVIOUS $dgitview
3585 # we do: `------------------ o
3589 return $dgitview unless defined $archive_hash;
3591 printdebug "splitbrain_pseudomerge...\n";
3593 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3595 if (!defined $overwrite_version) {
3596 progress "Checking that HEAD inciudes all changes in archive...";
3599 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3601 if (defined $overwrite_version) {
3603 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3604 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3605 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3606 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3607 my $i_archive = [ $archive_hash, "current archive contents" ];
3609 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3611 infopair_cond_equal($i_dgit, $i_archive);
3612 infopair_cond_ff($i_dep14, $i_dgit);
3613 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3617 $us: check failed (maybe --overwrite is needed, consult documentation)
3622 my $r = pseudomerge_make_commit
3623 $clogp, $dgitview, $archive_hash, $i_arch_v,
3624 "dgit --quilt=$quilt_mode",
3625 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3626 Declare fast forward from $i_arch_v->[0]
3628 Make fast forward from $i_arch_v->[0]
3631 maybe_split_brain_save $maintview, $r, "pseudomerge";
3633 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3637 sub plain_overwrite_pseudomerge ($$$) {
3638 my ($clogp, $head, $archive_hash) = @_;
3640 printdebug "plain_overwrite_pseudomerge...";
3642 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3644 return $head if is_fast_fwd $archive_hash, $head;
3646 my $m = "Declare fast forward from $i_arch_v->[0]";
3648 my $r = pseudomerge_make_commit
3649 $clogp, $head, $archive_hash, $i_arch_v,
3652 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3654 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3658 sub push_parse_changelog ($) {
3661 my $clogp = Dpkg::Control::Hash->new();
3662 $clogp->load($clogpfn) or die;
3664 my $clogpackage = getfield $clogp, 'Source';
3665 $package //= $clogpackage;
3666 fail "-p specified $package but changelog specified $clogpackage"
3667 unless $package eq $clogpackage;
3668 my $cversion = getfield $clogp, 'Version';
3669 my $tag = debiantag($cversion, access_nomdistro);
3670 runcmd @git, qw(check-ref-format), $tag;
3672 my $dscfn = dscfn($cversion);
3674 return ($clogp, $cversion, $dscfn);
3677 sub push_parse_dsc ($$$) {
3678 my ($dscfn,$dscfnwhat, $cversion) = @_;
3679 $dsc = parsecontrol($dscfn,$dscfnwhat);
3680 my $dversion = getfield $dsc, 'Version';
3681 my $dscpackage = getfield $dsc, 'Source';
3682 ($dscpackage eq $package && $dversion eq $cversion) or
3683 fail "$dscfn is for $dscpackage $dversion".
3684 " but debian/changelog is for $package $cversion";
3687 sub push_tagwants ($$$$) {
3688 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3691 TagFn => \&debiantag,
3696 if (defined $maintviewhead) {
3698 TagFn => \&debiantag_maintview,
3699 Objid => $maintviewhead,
3700 TfSuffix => '-maintview',
3703 } elsif ($dodep14tag eq 'no' ? 0
3704 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3705 : $dodep14tag eq 'always'
3706 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3707 --dep14tag-always (or equivalent in config) means server must support
3708 both "new" and "maint" tag formats, but config says it doesn't.
3710 : die "$dodep14tag ?") {
3712 TagFn => \&debiantag_maintview,
3714 TfSuffix => '-dgit',
3718 foreach my $tw (@tagwants) {
3719 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3720 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3722 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3726 sub push_mktags ($$ $$ $) {
3728 $changesfile,$changesfilewhat,
3731 die unless $tagwants->[0]{View} eq 'dgit';
3733 my $declaredistro = access_nomdistro();
3734 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
3735 $dsc->{$ourdscfield[0]} = join " ",
3736 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
3738 $dsc->save("$dscfn.tmp") or die $!;
3740 my $changes = parsecontrol($changesfile,$changesfilewhat);
3741 foreach my $field (qw(Source Distribution Version)) {
3742 $changes->{$field} eq $clogp->{$field} or
3743 fail "changes field $field \`$changes->{$field}'".
3744 " does not match changelog \`$clogp->{$field}'";
3747 my $cversion = getfield $clogp, 'Version';
3748 my $clogsuite = getfield $clogp, 'Distribution';
3750 # We make the git tag by hand because (a) that makes it easier
3751 # to control the "tagger" (b) we can do remote signing
3752 my $authline = clogp_authline $clogp;
3753 my $delibs = join(" ", "",@deliberatelies);
3757 my $tfn = $tw->{Tfn};
3758 my $head = $tw->{Objid};
3759 my $tag = $tw->{Tag};
3761 open TO, '>', $tfn->('.tmp') or die $!;
3762 print TO <<END or die $!;
3769 if ($tw->{View} eq 'dgit') {
3770 print TO <<END or die $!;
3771 $package release $cversion for $clogsuite ($csuite) [dgit]
3772 [dgit distro=$declaredistro$delibs]
3774 foreach my $ref (sort keys %previously) {
3775 print TO <<END or die $!;
3776 [dgit previously:$ref=$previously{$ref}]
3779 } elsif ($tw->{View} eq 'maint') {
3780 print TO <<END or die $!;
3781 $package release $cversion for $clogsuite ($csuite)
3782 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3785 die Dumper($tw)."?";
3790 my $tagobjfn = $tfn->('.tmp');
3792 if (!defined $keyid) {
3793 $keyid = access_cfg('keyid','RETURN-UNDEF');
3795 if (!defined $keyid) {
3796 $keyid = getfield $clogp, 'Maintainer';
3798 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3799 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3800 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3801 push @sign_cmd, $tfn->('.tmp');
3802 runcmd_ordryrun @sign_cmd;
3804 $tagobjfn = $tfn->('.signed.tmp');
3805 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3806 $tfn->('.tmp'), $tfn->('.tmp.asc');
3812 my @r = map { $mktag->($_); } @$tagwants;
3816 sub sign_changes ($) {
3817 my ($changesfile) = @_;
3819 my @debsign_cmd = @debsign;
3820 push @debsign_cmd, "-k$keyid" if defined $keyid;
3821 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3822 push @debsign_cmd, $changesfile;
3823 runcmd_ordryrun @debsign_cmd;
3828 printdebug "actually entering push\n";
3830 supplementary_message(<<'END');
3831 Push failed, while checking state of the archive.
3832 You can retry the push, after fixing the problem, if you like.
3834 if (check_for_git()) {
3837 my $archive_hash = fetch_from_archive();
3838 if (!$archive_hash) {
3840 fail "package appears to be new in this suite;".
3841 " if this is intentional, use --new";
3844 supplementary_message(<<'END');
3845 Push failed, while preparing your push.
3846 You can retry the push, after fixing the problem, if you like.
3849 need_tagformat 'new', "quilt mode $quilt_mode"
3850 if quiltmode_splitbrain;
3854 access_giturl(); # check that success is vaguely likely
3857 my $clogpfn = ".git/dgit/changelog.822.tmp";
3858 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3860 responder_send_file('parsed-changelog', $clogpfn);
3862 my ($clogp, $cversion, $dscfn) =
3863 push_parse_changelog("$clogpfn");
3865 my $dscpath = "$buildproductsdir/$dscfn";
3866 stat_exists $dscpath or
3867 fail "looked for .dsc $dscpath, but $!;".
3868 " maybe you forgot to build";
3870 responder_send_file('dsc', $dscpath);
3872 push_parse_dsc($dscpath, $dscfn, $cversion);
3874 my $format = getfield $dsc, 'Format';
3875 printdebug "format $format\n";
3877 my $actualhead = git_rev_parse('HEAD');
3878 my $dgithead = $actualhead;
3879 my $maintviewhead = undef;
3881 my $upstreamversion = upstreamversion $clogp->{Version};
3883 if (madformat_wantfixup($format)) {
3884 # user might have not used dgit build, so maybe do this now:
3885 if (quiltmode_splitbrain()) {
3887 quilt_make_fake_dsc($upstreamversion);
3889 ($dgithead, $cachekey) =
3890 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3892 "--quilt=$quilt_mode but no cached dgit view:
3893 perhaps tree changed since dgit build[-source] ?";
3895 $dgithead = splitbrain_pseudomerge($clogp,
3896 $actualhead, $dgithead,
3898 $maintviewhead = $actualhead;
3899 changedir '../../../..';
3900 prep_ud(); # so _only_subdir() works, below
3902 commit_quilty_patch();
3906 if (defined $overwrite_version && !defined $maintviewhead) {
3907 $dgithead = plain_overwrite_pseudomerge($clogp,
3915 if ($archive_hash) {
3916 if (is_fast_fwd($archive_hash, $dgithead)) {
3918 } elsif (deliberately_not_fast_forward) {
3921 fail "dgit push: HEAD is not a descendant".
3922 " of the archive's version.\n".
3923 "To overwrite the archive's contents,".
3924 " pass --overwrite[=VERSION].\n".
3925 "To rewind history, if permitted by the archive,".
3926 " use --deliberately-not-fast-forward.";
3931 progress "checking that $dscfn corresponds to HEAD";
3932 runcmd qw(dpkg-source -x --),
3933 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3934 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
3935 check_for_vendor_patches() if madformat($dsc->{format});
3936 changedir '../../../..';
3937 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3938 debugcmd "+",@diffcmd;
3940 my $r = system @diffcmd;
3943 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3945 HEAD specifies a different tree to $dscfn:
3947 Perhaps you forgot to build. Or perhaps there is a problem with your
3948 source tree (see dgit(7) for some hints). To see a full diff, run
3955 if (!$changesfile) {
3956 my $pat = changespat $cversion;
3957 my @cs = glob "$buildproductsdir/$pat";
3958 fail "failed to find unique changes file".
3959 " (looked for $pat in $buildproductsdir);".
3960 " perhaps you need to use dgit -C"
3962 ($changesfile) = @cs;
3964 $changesfile = "$buildproductsdir/$changesfile";
3967 # Check that changes and .dsc agree enough
3968 $changesfile =~ m{[^/]*$};
3969 my $changes = parsecontrol($changesfile,$&);
3970 files_compare_inputs($dsc, $changes)
3971 unless forceing [qw(dsc-changes-mismatch)];
3973 # Perhaps adjust .dsc to contain right set of origs
3974 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3976 unless forceing [qw(changes-origs-exactly)];
3978 # Checks complete, we're going to try and go ahead:
3980 responder_send_file('changes',$changesfile);
3981 responder_send_command("param head $dgithead");
3982 responder_send_command("param csuite $csuite");
3983 responder_send_command("param tagformat $tagformat");
3984 if (defined $maintviewhead) {
3985 die unless ($protovsn//4) >= 4;
3986 responder_send_command("param maint-view $maintviewhead");
3989 if (deliberately_not_fast_forward) {
3990 git_for_each_ref(lrfetchrefs, sub {
3991 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3992 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3993 responder_send_command("previously $rrefname=$objid");
3994 $previously{$rrefname} = $objid;
3998 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4002 supplementary_message(<<'END');
4003 Push failed, while signing the tag.
4004 You can retry the push, after fixing the problem, if you like.
4006 # If we manage to sign but fail to record it anywhere, it's fine.
4007 if ($we_are_responder) {
4008 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4009 responder_receive_files('signed-tag', @tagobjfns);
4011 @tagobjfns = push_mktags($clogp,$dscpath,
4012 $changesfile,$changesfile,
4015 supplementary_message(<<'END');
4016 Push failed, *after* signing the tag.
4017 If you want to try again, you should use a new version number.
4020 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4022 foreach my $tw (@tagwants) {
4023 my $tag = $tw->{Tag};
4024 my $tagobjfn = $tw->{TagObjFn};
4026 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4027 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4028 runcmd_ordryrun_local
4029 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4032 supplementary_message(<<'END');
4033 Push failed, while updating the remote git repository - see messages above.
4034 If you want to try again, you should use a new version number.
4036 if (!check_for_git()) {
4037 create_remote_git_repo();
4040 my @pushrefs = $forceflag.$dgithead.":".rrref();
4041 foreach my $tw (@tagwants) {
4042 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4045 runcmd_ordryrun @git,
4046 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4047 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4049 supplementary_message(<<'END');
4050 Push failed, while obtaining signatures on the .changes and .dsc.
4051 If it was just that the signature failed, you may try again by using
4052 debsign by hand to sign the changes
4054 and then dput to complete the upload.
4055 If you need to change the package, you must use a new version number.
4057 if ($we_are_responder) {
4058 my $dryrunsuffix = act_local() ? "" : ".tmp";
4059 responder_receive_files('signed-dsc-changes',
4060 "$dscpath$dryrunsuffix",
4061 "$changesfile$dryrunsuffix");
4064 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4066 progress "[new .dsc left in $dscpath.tmp]";
4068 sign_changes $changesfile;
4071 supplementary_message(<<END);
4072 Push failed, while uploading package(s) to the archive server.
4073 You can retry the upload of exactly these same files with dput of:
4075 If that .changes file is broken, you will need to use a new version
4076 number for your next attempt at the upload.
4078 my $host = access_cfg('upload-host','RETURN-UNDEF');
4079 my @hostarg = defined($host) ? ($host,) : ();
4080 runcmd_ordryrun @dput, @hostarg, $changesfile;
4081 printdone "pushed and uploaded $cversion";
4083 supplementary_message('');
4084 responder_send_command("complete");
4090 badusage "-p is not allowed with clone; specify as argument instead"
4091 if defined $package;
4094 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4095 ($package,$isuite) = @ARGV;
4096 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4097 ($package,$dstdir) = @ARGV;
4098 } elsif (@ARGV==3) {
4099 ($package,$isuite,$dstdir) = @ARGV;
4101 badusage "incorrect arguments to dgit clone";
4105 $dstdir ||= "$package";
4106 if (stat_exists $dstdir) {
4107 fail "$dstdir already exists";
4111 if ($rmonerror && !$dryrun_level) {
4112 $cwd_remove= getcwd();
4114 return unless defined $cwd_remove;
4115 if (!chdir "$cwd_remove") {
4116 return if $!==&ENOENT;
4117 die "chdir $cwd_remove: $!";
4119 printdebug "clone rmonerror removing $dstdir\n";
4121 rmtree($dstdir) or die "remove $dstdir: $!\n";
4122 } elsif (grep { $! == $_ }
4123 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4125 print STDERR "check whether to remove $dstdir: $!\n";
4131 $cwd_remove = undef;
4134 sub branchsuite () {
4135 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4136 if ($branch =~ m#$lbranch_re#o) {
4143 sub fetchpullargs () {
4144 if (!defined $package) {
4145 my $sourcep = parsecontrol('debian/control','debian/control');
4146 $package = getfield $sourcep, 'Source';
4149 $isuite = branchsuite();
4151 my $clogp = parsechangelog();
4152 $isuite = getfield $clogp, 'Distribution';
4154 } elsif (@ARGV==1) {
4157 badusage "incorrect arguments to dgit fetch or dgit pull";
4165 my $multi_fetched = fork_for_multisuite(sub { });
4166 exit 0 if $multi_fetched;
4173 if (quiltmode_splitbrain()) {
4174 my ($format, $fopts) = get_source_format();
4175 madformat($format) and fail <<END
4176 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4185 badusage "-p is not allowed with dgit push" if defined $package;
4187 my $clogp = parsechangelog();
4188 $package = getfield $clogp, 'Source';
4191 } elsif (@ARGV==1) {
4192 ($specsuite) = (@ARGV);
4194 badusage "incorrect arguments to dgit push";
4196 $isuite = getfield $clogp, 'Distribution';
4198 local ($package) = $existing_package; # this is a hack
4199 canonicalise_suite();
4201 canonicalise_suite();
4203 if (defined $specsuite &&
4204 $specsuite ne $isuite &&
4205 $specsuite ne $csuite) {
4206 fail "dgit push: changelog specifies $isuite ($csuite)".
4207 " but command line specifies $specsuite";
4212 #---------- remote commands' implementation ----------
4214 sub cmd_remote_push_build_host {
4215 my ($nrargs) = shift @ARGV;
4216 my (@rargs) = @ARGV[0..$nrargs-1];
4217 @ARGV = @ARGV[$nrargs..$#ARGV];
4219 my ($dir,$vsnwant) = @rargs;
4220 # vsnwant is a comma-separated list; we report which we have
4221 # chosen in our ready response (so other end can tell if they
4224 $we_are_responder = 1;
4225 $us .= " (build host)";
4229 open PI, "<&STDIN" or die $!;
4230 open STDIN, "/dev/null" or die $!;
4231 open PO, ">&STDOUT" or die $!;
4233 open STDOUT, ">&STDERR" or die $!;
4237 ($protovsn) = grep {
4238 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4239 } @rpushprotovsn_support;
4241 fail "build host has dgit rpush protocol versions ".
4242 (join ",", @rpushprotovsn_support).
4243 " but invocation host has $vsnwant"
4244 unless defined $protovsn;
4246 responder_send_command("dgit-remote-push-ready $protovsn");
4247 rpush_handle_protovsn_bothends();
4252 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4253 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4254 # a good error message)
4256 sub rpush_handle_protovsn_bothends () {
4257 if ($protovsn < 4) {
4258 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4267 my $report = i_child_report();
4268 if (defined $report) {
4269 printdebug "($report)\n";
4270 } elsif ($i_child_pid) {
4271 printdebug "(killing build host child $i_child_pid)\n";
4272 kill 15, $i_child_pid;
4274 if (defined $i_tmp && !defined $initiator_tempdir) {
4276 eval { rmtree $i_tmp; };
4280 END { i_cleanup(); }
4283 my ($base,$selector,@args) = @_;
4284 $selector =~ s/\-/_/g;
4285 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4292 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4300 push @rargs, join ",", @rpushprotovsn_support;
4303 push @rdgit, @ropts;
4304 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4306 my @cmd = (@ssh, $host, shellquote @rdgit);
4309 if (defined $initiator_tempdir) {
4310 rmtree $initiator_tempdir;
4311 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4312 $i_tmp = $initiator_tempdir;
4316 $i_child_pid = open2(\*RO, \*RI, @cmd);
4318 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4319 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4320 $supplementary_message = '' unless $protovsn >= 3;
4322 fail "rpush negotiated protocol version $protovsn".
4323 " which does not support quilt mode $quilt_mode"
4324 if quiltmode_splitbrain;
4326 rpush_handle_protovsn_bothends();
4328 my ($icmd,$iargs) = initiator_expect {
4329 m/^(\S+)(?: (.*))?$/;
4332 i_method "i_resp", $icmd, $iargs;
4336 sub i_resp_progress ($) {
4338 my $msg = protocol_read_bytes \*RO, $rhs;
4342 sub i_resp_supplementary_message ($) {
4344 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4347 sub i_resp_complete {
4348 my $pid = $i_child_pid;
4349 $i_child_pid = undef; # prevents killing some other process with same pid
4350 printdebug "waiting for build host child $pid...\n";
4351 my $got = waitpid $pid, 0;
4352 die $! unless $got == $pid;
4353 die "build host child failed $?" if $?;
4356 printdebug "all done\n";
4360 sub i_resp_file ($) {
4362 my $localname = i_method "i_localname", $keyword;
4363 my $localpath = "$i_tmp/$localname";
4364 stat_exists $localpath and
4365 badproto \*RO, "file $keyword ($localpath) twice";
4366 protocol_receive_file \*RO, $localpath;
4367 i_method "i_file", $keyword;
4372 sub i_resp_param ($) {
4373 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4377 sub i_resp_previously ($) {
4378 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4379 or badproto \*RO, "bad previously spec";
4380 my $r = system qw(git check-ref-format), $1;
4381 die "bad previously ref spec ($r)" if $r;
4382 $previously{$1} = $2;
4387 sub i_resp_want ($) {
4389 die "$keyword ?" if $i_wanted{$keyword}++;
4390 my @localpaths = i_method "i_want", $keyword;
4391 printdebug "[[ $keyword @localpaths\n";
4392 foreach my $localpath (@localpaths) {
4393 protocol_send_file \*RI, $localpath;
4395 print RI "files-end\n" or die $!;
4398 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4400 sub i_localname_parsed_changelog {
4401 return "remote-changelog.822";
4403 sub i_file_parsed_changelog {
4404 ($i_clogp, $i_version, $i_dscfn) =
4405 push_parse_changelog "$i_tmp/remote-changelog.822";
4406 die if $i_dscfn =~ m#/|^\W#;
4409 sub i_localname_dsc {
4410 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4415 sub i_localname_changes {
4416 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4417 $i_changesfn = $i_dscfn;
4418 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4419 return $i_changesfn;
4421 sub i_file_changes { }
4423 sub i_want_signed_tag {
4424 printdebug Dumper(\%i_param, $i_dscfn);
4425 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4426 && defined $i_param{'csuite'}
4427 or badproto \*RO, "premature desire for signed-tag";
4428 my $head = $i_param{'head'};
4429 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4431 my $maintview = $i_param{'maint-view'};
4432 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4435 if ($protovsn >= 4) {
4436 my $p = $i_param{'tagformat'} // '<undef>';
4438 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4441 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4443 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4445 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4448 push_mktags $i_clogp, $i_dscfn,
4449 $i_changesfn, 'remote changes',
4453 sub i_want_signed_dsc_changes {
4454 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4455 sign_changes $i_changesfn;
4456 return ($i_dscfn, $i_changesfn);
4459 #---------- building etc. ----------
4465 #----- `3.0 (quilt)' handling -----
4467 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4469 sub quiltify_dpkg_commit ($$$;$) {
4470 my ($patchname,$author,$msg, $xinfo) = @_;
4474 my $descfn = ".git/dgit/quilt-description.tmp";
4475 open O, '>', $descfn or die "$descfn: $!";
4476 $msg =~ s/\n+/\n\n/;
4477 print O <<END or die $!;
4479 ${xinfo}Subject: $msg
4486 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4487 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4488 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4489 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4493 sub quiltify_trees_differ ($$;$$$) {
4494 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4495 # returns true iff the two tree objects differ other than in debian/
4496 # with $finegrained,
4497 # returns bitmask 01 - differ in upstream files except .gitignore
4498 # 02 - differ in .gitignore
4499 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4500 # is set for each modified .gitignore filename $fn
4501 # if $unrepres is defined, array ref to which is appeneded
4502 # a list of unrepresentable changes (removals of upstream files
4505 my @cmd = (@git, qw(diff-tree -z));
4506 push @cmd, qw(--name-only) unless $unrepres;
4507 push @cmd, qw(-r) if $finegrained || $unrepres;
4509 my $diffs= cmdoutput @cmd;
4512 foreach my $f (split /\0/, $diffs) {
4513 if ($unrepres && !@lmodes) {
4514 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4517 my ($oldmode,$newmode) = @lmodes;
4520 next if $f =~ m#^debian(?:/.*)?$#s;
4524 die "not a plain file\n"
4525 unless $newmode =~ m/^10\d{4}$/ ||
4526 $oldmode =~ m/^10\d{4}$/;
4527 if ($oldmode =~ m/[^0]/ &&
4528 $newmode =~ m/[^0]/) {
4529 die "mode changed\n" if $oldmode ne $newmode;
4531 die "non-default mode\n"
4532 unless $newmode =~ m/^100644$/ ||
4533 $oldmode =~ m/^100644$/;
4537 local $/="\n"; chomp $@;
4538 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4542 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4543 $r |= $isignore ? 02 : 01;
4544 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4546 printdebug "quiltify_trees_differ $x $y => $r\n";
4550 sub quiltify_tree_sentinelfiles ($) {
4551 # lists the `sentinel' files present in the tree
4553 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4554 qw(-- debian/rules debian/control);
4559 sub quiltify_splitbrain_needed () {
4560 if (!$split_brain) {
4561 progress "dgit view: changes are required...";
4562 runcmd @git, qw(checkout -q -b dgit-view);
4567 sub quiltify_splitbrain ($$$$$$) {
4568 my ($clogp, $unapplied, $headref, $diffbits,
4569 $editedignores, $cachekey) = @_;
4570 if ($quilt_mode !~ m/gbp|dpm/) {
4571 # treat .gitignore just like any other upstream file
4572 $diffbits = { %$diffbits };
4573 $_ = !!$_ foreach values %$diffbits;
4575 # We would like any commits we generate to be reproducible
4576 my @authline = clogp_authline($clogp);
4577 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4578 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4579 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4580 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4581 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4582 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4584 if ($quilt_mode =~ m/gbp|unapplied/ &&
4585 ($diffbits->{O2H} & 01)) {
4587 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4588 " but git tree differs from orig in upstream files.";
4589 if (!stat_exists "debian/patches") {
4591 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4595 if ($quilt_mode =~ m/dpm/ &&
4596 ($diffbits->{H2A} & 01)) {
4598 --quilt=$quilt_mode specified, implying patches-applied git tree
4599 but git tree differs from result of applying debian/patches to upstream
4602 if ($quilt_mode =~ m/gbp|unapplied/ &&
4603 ($diffbits->{O2A} & 01)) { # some patches
4604 quiltify_splitbrain_needed();
4605 progress "dgit view: creating patches-applied version using gbp pq";
4606 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4607 # gbp pq import creates a fresh branch; push back to dgit-view
4608 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4609 runcmd @git, qw(checkout -q dgit-view);
4611 if ($quilt_mode =~ m/gbp|dpm/ &&
4612 ($diffbits->{O2A} & 02)) {
4614 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4615 tool which does not create patches for changes to upstream
4616 .gitignores: but, such patches exist in debian/patches.
4619 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4620 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4621 quiltify_splitbrain_needed();
4622 progress "dgit view: creating patch to represent .gitignore changes";
4623 ensuredir "debian/patches";
4624 my $gipatch = "debian/patches/auto-gitignore";
4625 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4626 stat GIPATCH or die "$gipatch: $!";
4627 fail "$gipatch already exists; but want to create it".
4628 " to record .gitignore changes" if (stat _)[7];
4629 print GIPATCH <<END or die "$gipatch: $!";
4630 Subject: Update .gitignore from Debian packaging branch
4632 The Debian packaging git branch contains these updates to the upstream
4633 .gitignore file(s). This patch is autogenerated, to provide these
4634 updates to users of the official Debian archive view of the package.
4636 [dgit ($our_version) update-gitignore]
4639 close GIPATCH or die "$gipatch: $!";
4640 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4641 $unapplied, $headref, "--", sort keys %$editedignores;
4642 open SERIES, "+>>", "debian/patches/series" or die $!;
4643 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4645 defined read SERIES, $newline, 1 or die $!;
4646 print SERIES "\n" or die $! unless $newline eq "\n";
4647 print SERIES "auto-gitignore\n" or die $!;
4648 close SERIES or die $!;
4649 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4651 Commit patch to update .gitignore
4653 [dgit ($our_version) update-gitignore-quilt-fixup]
4657 my $dgitview = git_rev_parse 'HEAD';
4659 changedir '../../../..';
4660 # When we no longer need to support squeeze, use --create-reflog
4662 ensuredir ".git/logs/refs/dgit-intern";
4663 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4666 my $oldcache = git_get_ref "refs/$splitbraincache";
4667 if ($oldcache eq $dgitview) {
4668 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4669 # git update-ref doesn't always update, in this case. *sigh*
4670 my $dummy = make_commit_text <<END;
4673 author Dgit <dgit\@example.com> 1000000000 +0000
4674 committer Dgit <dgit\@example.com> 1000000000 +0000
4676 Dummy commit - do not use
4678 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4679 "refs/$splitbraincache", $dummy;
4681 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4684 changedir '.git/dgit/unpack/work';
4686 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4687 progress "dgit view: created ($saved)";
4690 sub quiltify ($$$$) {
4691 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4693 # Quilt patchification algorithm
4695 # We search backwards through the history of the main tree's HEAD
4696 # (T) looking for a start commit S whose tree object is identical
4697 # to to the patch tip tree (ie the tree corresponding to the
4698 # current dpkg-committed patch series). For these purposes
4699 # `identical' disregards anything in debian/ - this wrinkle is
4700 # necessary because dpkg-source treates debian/ specially.
4702 # We can only traverse edges where at most one of the ancestors'
4703 # trees differs (in changes outside in debian/). And we cannot
4704 # handle edges which change .pc/ or debian/patches. To avoid
4705 # going down a rathole we avoid traversing edges which introduce
4706 # debian/rules or debian/control. And we set a limit on the
4707 # number of edges we are willing to look at.
4709 # If we succeed, we walk forwards again. For each traversed edge
4710 # PC (with P parent, C child) (starting with P=S and ending with
4711 # C=T) to we do this:
4713 # - dpkg-source --commit with a patch name and message derived from C
4714 # After traversing PT, we git commit the changes which
4715 # should be contained within debian/patches.
4717 # The search for the path S..T is breadth-first. We maintain a
4718 # todo list containing search nodes. A search node identifies a
4719 # commit, and looks something like this:
4721 # Commit => $git_commit_id,
4722 # Child => $c, # or undef if P=T
4723 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4724 # Nontrivial => true iff $p..$c has relevant changes
4731 my %considered; # saves being exponential on some weird graphs
4733 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4736 my ($search,$whynot) = @_;
4737 printdebug " search NOT $search->{Commit} $whynot\n";
4738 $search->{Whynot} = $whynot;
4739 push @nots, $search;
4740 no warnings qw(exiting);
4749 my $c = shift @todo;
4750 next if $considered{$c->{Commit}}++;
4752 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4754 printdebug "quiltify investigate $c->{Commit}\n";
4757 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4758 printdebug " search finished hooray!\n";
4763 if ($quilt_mode eq 'nofix') {
4764 fail "quilt fixup required but quilt mode is \`nofix'\n".
4765 "HEAD commit $c->{Commit} differs from tree implied by ".
4766 " debian/patches (tree object $oldtiptree)";
4768 if ($quilt_mode eq 'smash') {
4769 printdebug " search quitting smash\n";
4773 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4774 $not->($c, "has $c_sentinels not $t_sentinels")
4775 if $c_sentinels ne $t_sentinels;
4777 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4778 $commitdata =~ m/\n\n/;
4780 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4781 @parents = map { { Commit => $_, Child => $c } } @parents;
4783 $not->($c, "root commit") if !@parents;
4785 foreach my $p (@parents) {
4786 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4788 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4789 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4791 foreach my $p (@parents) {
4792 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4794 my @cmd= (@git, qw(diff-tree -r --name-only),
4795 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4796 my $patchstackchange = cmdoutput @cmd;
4797 if (length $patchstackchange) {
4798 $patchstackchange =~ s/\n/,/g;
4799 $not->($p, "changed $patchstackchange");
4802 printdebug " search queue P=$p->{Commit} ",
4803 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4809 printdebug "quiltify want to smash\n";
4812 my $x = $_[0]{Commit};
4813 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4816 my $reportnot = sub {
4818 my $s = $abbrev->($notp);
4819 my $c = $notp->{Child};
4820 $s .= "..".$abbrev->($c) if $c;
4821 $s .= ": ".$notp->{Whynot};
4824 if ($quilt_mode eq 'linear') {
4825 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4826 foreach my $notp (@nots) {
4827 print STDERR "$us: ", $reportnot->($notp), "\n";
4829 print STDERR "$us: $_\n" foreach @$failsuggestion;
4830 fail "quilt fixup naive history linearisation failed.\n".
4831 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4832 } elsif ($quilt_mode eq 'smash') {
4833 } elsif ($quilt_mode eq 'auto') {
4834 progress "quilt fixup cannot be linear, smashing...";
4836 die "$quilt_mode ?";
4839 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4840 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4842 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4844 quiltify_dpkg_commit "auto-$version-$target-$time",
4845 (getfield $clogp, 'Maintainer'),
4846 "Automatically generated patch ($clogp->{Version})\n".
4847 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4851 progress "quiltify linearisation planning successful, executing...";
4853 for (my $p = $sref_S;
4854 my $c = $p->{Child};
4856 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4857 next unless $p->{Nontrivial};
4859 my $cc = $c->{Commit};
4861 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4862 $commitdata =~ m/\n\n/ or die "$c ?";
4865 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4868 my $commitdate = cmdoutput
4869 @git, qw(log -n1 --pretty=format:%aD), $cc;
4871 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4873 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4880 my $gbp_check_suitable = sub {
4885 die "contains unexpected slashes\n" if m{//} || m{/$};
4886 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4887 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4888 die "too long" if length > 200;
4890 return $_ unless $@;
4891 print STDERR "quiltifying commit $cc:".
4892 " ignoring/dropping Gbp-Pq $what: $@";
4896 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4898 (\S+) \s* \n //ixm) {
4899 $patchname = $gbp_check_suitable->($1, 'Name');
4901 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4903 (\S+) \s* \n //ixm) {
4904 $patchdir = $gbp_check_suitable->($1, 'Topic');
4909 if (!defined $patchname) {
4910 $patchname = $title;
4911 $patchname =~ s/[.:]$//;
4914 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4915 my $translitname = $converter->convert($patchname);
4916 die unless defined $translitname;
4917 $patchname = $translitname;
4920 "dgit: patch title transliteration error: $@"
4922 $patchname =~ y/ A-Z/-a-z/;
4923 $patchname =~ y/-a-z0-9_.+=~//cd;
4924 $patchname =~ s/^\W/x-$&/;
4925 $patchname = substr($patchname,0,40);
4927 if (!defined $patchdir) {
4930 if (length $patchdir) {
4931 $patchname = "$patchdir/$patchname";
4933 if ($patchname =~ m{^(.*)/}) {
4934 mkpath "debian/patches/$1";
4939 stat "debian/patches/$patchname$index";
4941 $!==ENOENT or die "$patchname$index $!";
4943 runcmd @git, qw(checkout -q), $cc;
4945 # We use the tip's changelog so that dpkg-source doesn't
4946 # produce complaining messages from dpkg-parsechangelog. None
4947 # of the information dpkg-source gets from the changelog is
4948 # actually relevant - it gets put into the original message
4949 # which dpkg-source provides our stunt editor, and then
4951 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4953 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4954 "Date: $commitdate\n".
4955 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4957 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4960 runcmd @git, qw(checkout -q master);
4963 sub build_maybe_quilt_fixup () {
4964 my ($format,$fopts) = get_source_format;
4965 return unless madformat_wantfixup $format;
4968 check_for_vendor_patches();
4970 if (quiltmode_splitbrain) {
4971 fail <<END unless access_cfg_tagformats_can_splitbrain;
4972 quilt mode $quilt_mode requires split view so server needs to support
4973 both "new" and "maint" tag formats, but config says it doesn't.
4977 my $clogp = parsechangelog();
4978 my $headref = git_rev_parse('HEAD');
4983 my $upstreamversion = upstreamversion $version;
4985 if ($fopts->{'single-debian-patch'}) {
4986 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4988 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4991 die 'bug' if $split_brain && !$need_split_build_invocation;
4993 changedir '../../../..';
4994 runcmd_ordryrun_local
4995 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4998 sub quilt_fixup_mkwork ($) {
5001 mkdir "work" or die $!;
5003 mktree_in_ud_here();
5004 runcmd @git, qw(reset -q --hard), $headref;
5007 sub quilt_fixup_linkorigs ($$) {
5008 my ($upstreamversion, $fn) = @_;
5009 # calls $fn->($leafname);
5011 foreach my $f (<../../../../*>) { #/){
5012 my $b=$f; $b =~ s{.*/}{};
5014 local ($debuglevel) = $debuglevel-1;
5015 printdebug "QF linkorigs $b, $f ?\n";
5017 next unless is_orig_file_of_vsn $b, $upstreamversion;
5018 printdebug "QF linkorigs $b, $f Y\n";
5019 link_ltarget $f, $b or die "$b $!";
5024 sub quilt_fixup_delete_pc () {
5025 runcmd @git, qw(rm -rqf .pc);
5027 Commit removal of .pc (quilt series tracking data)
5029 [dgit ($our_version) upgrade quilt-remove-pc]
5033 sub quilt_fixup_singlepatch ($$$) {
5034 my ($clogp, $headref, $upstreamversion) = @_;
5036 progress "starting quiltify (single-debian-patch)";
5038 # dpkg-source --commit generates new patches even if
5039 # single-debian-patch is in debian/source/options. In order to
5040 # get it to generate debian/patches/debian-changes, it is
5041 # necessary to build the source package.
5043 quilt_fixup_linkorigs($upstreamversion, sub { });
5044 quilt_fixup_mkwork($headref);
5046 rmtree("debian/patches");
5048 runcmd @dpkgsource, qw(-b .);
5050 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5051 rename srcfn("$upstreamversion", "/debian/patches"),
5052 "work/debian/patches";
5055 commit_quilty_patch();
5058 sub quilt_make_fake_dsc ($) {
5059 my ($upstreamversion) = @_;
5061 my $fakeversion="$upstreamversion-~~DGITFAKE";
5063 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5064 print $fakedsc <<END or die $!;
5067 Version: $fakeversion
5071 my $dscaddfile=sub {
5074 my $md = new Digest::MD5;
5076 my $fh = new IO::File $b, '<' or die "$b $!";
5081 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5084 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5086 my @files=qw(debian/source/format debian/rules
5087 debian/control debian/changelog);
5088 foreach my $maybe (qw(debian/patches debian/source/options
5089 debian/tests/control)) {
5090 next unless stat_exists "../../../$maybe";
5091 push @files, $maybe;
5094 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5095 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5097 $dscaddfile->($debtar);
5098 close $fakedsc or die $!;
5101 sub quilt_check_splitbrain_cache ($$) {
5102 my ($headref, $upstreamversion) = @_;
5103 # Called only if we are in (potentially) split brain mode.
5105 # Computes the cache key and looks in the cache.
5106 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5108 my $splitbrain_cachekey;
5111 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5112 # we look in the reflog of dgit-intern/quilt-cache
5113 # we look for an entry whose message is the key for the cache lookup
5114 my @cachekey = (qw(dgit), $our_version);
5115 push @cachekey, $upstreamversion;
5116 push @cachekey, $quilt_mode;
5117 push @cachekey, $headref;
5119 push @cachekey, hashfile('fake.dsc');
5121 my $srcshash = Digest::SHA->new(256);
5122 my %sfs = ( %INC, '$0(dgit)' => $0 );
5123 foreach my $sfk (sort keys %sfs) {
5124 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5125 $srcshash->add($sfk," ");
5126 $srcshash->add(hashfile($sfs{$sfk}));
5127 $srcshash->add("\n");
5129 push @cachekey, $srcshash->hexdigest();
5130 $splitbrain_cachekey = "@cachekey";
5132 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5134 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5135 debugcmd "|(probably)",@cmd;
5136 my $child = open GC, "-|"; defined $child or die $!;
5138 chdir '../../..' or die $!;
5139 if (!stat ".git/logs/refs/$splitbraincache") {
5140 $! == ENOENT or die $!;
5141 printdebug ">(no reflog)\n";
5148 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5149 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5152 quilt_fixup_mkwork($headref);
5153 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5154 if ($cachehit ne $headref) {
5155 progress "dgit view: found cached ($saved)";
5156 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5158 return ($cachehit, $splitbrain_cachekey);
5160 progress "dgit view: found cached, no changes required";
5161 return ($headref, $splitbrain_cachekey);
5163 die $! if GC->error;
5164 failedcmd unless close GC;
5166 printdebug "splitbrain cache miss\n";
5167 return (undef, $splitbrain_cachekey);
5170 sub quilt_fixup_multipatch ($$$) {
5171 my ($clogp, $headref, $upstreamversion) = @_;
5173 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5176 # - honour any existing .pc in case it has any strangeness
5177 # - determine the git commit corresponding to the tip of
5178 # the patch stack (if there is one)
5179 # - if there is such a git commit, convert each subsequent
5180 # git commit into a quilt patch with dpkg-source --commit
5181 # - otherwise convert all the differences in the tree into
5182 # a single git commit
5186 # Our git tree doesn't necessarily contain .pc. (Some versions of
5187 # dgit would include the .pc in the git tree.) If there isn't
5188 # one, we need to generate one by unpacking the patches that we
5191 # We first look for a .pc in the git tree. If there is one, we
5192 # will use it. (This is not the normal case.)
5194 # Otherwise need to regenerate .pc so that dpkg-source --commit
5195 # can work. We do this as follows:
5196 # 1. Collect all relevant .orig from parent directory
5197 # 2. Generate a debian.tar.gz out of
5198 # debian/{patches,rules,source/format,source/options}
5199 # 3. Generate a fake .dsc containing just these fields:
5200 # Format Source Version Files
5201 # 4. Extract the fake .dsc
5202 # Now the fake .dsc has a .pc directory.
5203 # (In fact we do this in every case, because in future we will
5204 # want to search for a good base commit for generating patches.)
5206 # Then we can actually do the dpkg-source --commit
5207 # 1. Make a new working tree with the same object
5208 # store as our main tree and check out the main
5210 # 2. Copy .pc from the fake's extraction, if necessary
5211 # 3. Run dpkg-source --commit
5212 # 4. If the result has changes to debian/, then
5213 # - git add them them
5214 # - git add .pc if we had a .pc in-tree
5216 # 5. If we had a .pc in-tree, delete it, and git commit
5217 # 6. Back in the main tree, fast forward to the new HEAD
5219 # Another situation we may have to cope with is gbp-style
5220 # patches-unapplied trees.
5222 # We would want to detect these, so we know to escape into
5223 # quilt_fixup_gbp. However, this is in general not possible.
5224 # Consider a package with a one patch which the dgit user reverts
5225 # (with git revert or the moral equivalent).
5227 # That is indistinguishable in contents from a patches-unapplied
5228 # tree. And looking at the history to distinguish them is not
5229 # useful because the user might have made a confusing-looking git
5230 # history structure (which ought to produce an error if dgit can't
5231 # cope, not a silent reintroduction of an unwanted patch).
5233 # So gbp users will have to pass an option. But we can usually
5234 # detect their failure to do so: if the tree is not a clean
5235 # patches-applied tree, quilt linearisation fails, but the tree
5236 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5237 # they want --quilt=unapplied.
5239 # To help detect this, when we are extracting the fake dsc, we
5240 # first extract it with --skip-patches, and then apply the patches
5241 # afterwards with dpkg-source --before-build. That lets us save a
5242 # tree object corresponding to .origs.
5244 my $splitbrain_cachekey;
5246 quilt_make_fake_dsc($upstreamversion);
5248 if (quiltmode_splitbrain()) {
5250 ($cachehit, $splitbrain_cachekey) =
5251 quilt_check_splitbrain_cache($headref, $upstreamversion);
5252 return if $cachehit;
5256 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5258 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5259 rename $fakexdir, "fake" or die "$fakexdir $!";
5263 remove_stray_gits("source package");
5264 mktree_in_ud_here();
5268 my $unapplied=git_add_write_tree();
5269 printdebug "fake orig tree object $unapplied\n";
5273 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5275 if (system @bbcmd) {
5276 failedcmd @bbcmd if $? < 0;
5278 failed to apply your git tree's patch stack (from debian/patches/) to
5279 the corresponding upstream tarball(s). Your source tree and .orig
5280 are probably too inconsistent. dgit can only fix up certain kinds of
5281 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5287 quilt_fixup_mkwork($headref);
5290 if (stat_exists ".pc") {
5292 progress "Tree already contains .pc - will use it then delete it.";
5295 rename '../fake/.pc','.pc' or die $!;
5298 changedir '../fake';
5300 my $oldtiptree=git_add_write_tree();
5301 printdebug "fake o+d/p tree object $unapplied\n";
5302 changedir '../work';
5305 # We calculate some guesswork now about what kind of tree this might
5306 # be. This is mostly for error reporting.
5312 # O = orig, without patches applied
5313 # A = "applied", ie orig with H's debian/patches applied
5314 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5315 \%editedignores, \@unrepres),
5316 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5317 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5321 foreach my $b (qw(01 02)) {
5322 foreach my $v (qw(O2H O2A H2A)) {
5323 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5326 printdebug "differences \@dl @dl.\n";
5329 "$us: base trees orig=%.20s o+d/p=%.20s",
5330 $unapplied, $oldtiptree;
5332 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5333 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5334 $dl[0], $dl[1], $dl[3], $dl[4],
5338 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5340 forceable_fail [qw(unrepresentable)], <<END;
5341 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5346 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5347 push @failsuggestion, "This might be a patches-unapplied branch.";
5348 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5349 push @failsuggestion, "This might be a patches-applied branch.";
5351 push @failsuggestion, "Maybe you need to specify one of".
5352 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5354 if (quiltmode_splitbrain()) {
5355 quiltify_splitbrain($clogp, $unapplied, $headref,
5356 $diffbits, \%editedignores,
5357 $splitbrain_cachekey);
5361 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5362 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5364 if (!open P, '>>', ".pc/applied-patches") {
5365 $!==&ENOENT or die $!;
5370 commit_quilty_patch();
5372 if ($mustdeletepc) {
5373 quilt_fixup_delete_pc();
5377 sub quilt_fixup_editor () {
5378 my $descfn = $ENV{$fakeeditorenv};
5379 my $editing = $ARGV[$#ARGV];
5380 open I1, '<', $descfn or die "$descfn: $!";
5381 open I2, '<', $editing or die "$editing: $!";
5382 unlink $editing or die "$editing: $!";
5383 open O, '>', $editing or die "$editing: $!";
5384 while (<I1>) { print O or die $!; } I1->error and die $!;
5387 $copying ||= m/^\-\-\- /;
5388 next unless $copying;
5391 I2->error and die $!;
5396 sub maybe_apply_patches_dirtily () {
5397 return unless $quilt_mode =~ m/gbp|unapplied/;
5398 print STDERR <<END or die $!;
5400 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5401 dgit: Have to apply the patches - making the tree dirty.
5402 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5405 $patches_applied_dirtily = 01;
5406 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5407 runcmd qw(dpkg-source --before-build .);
5410 sub maybe_unapply_patches_again () {
5411 progress "dgit: Unapplying patches again to tidy up the tree."
5412 if $patches_applied_dirtily;
5413 runcmd qw(dpkg-source --after-build .)
5414 if $patches_applied_dirtily & 01;
5416 if $patches_applied_dirtily & 02;
5417 $patches_applied_dirtily = 0;
5420 #----- other building -----
5422 our $clean_using_builder;
5423 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5424 # clean the tree before building (perhaps invoked indirectly by
5425 # whatever we are using to run the build), rather than separately
5426 # and explicitly by us.
5429 return if $clean_using_builder;
5430 if ($cleanmode eq 'dpkg-source') {
5431 maybe_apply_patches_dirtily();
5432 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5433 } elsif ($cleanmode eq 'dpkg-source-d') {
5434 maybe_apply_patches_dirtily();
5435 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5436 } elsif ($cleanmode eq 'git') {
5437 runcmd_ordryrun_local @git, qw(clean -xdf);
5438 } elsif ($cleanmode eq 'git-ff') {
5439 runcmd_ordryrun_local @git, qw(clean -xdff);
5440 } elsif ($cleanmode eq 'check') {
5441 my $leftovers = cmdoutput @git, qw(clean -xdn);
5442 if (length $leftovers) {
5443 print STDERR $leftovers, "\n" or die $!;
5444 fail "tree contains uncommitted files and --clean=check specified";
5446 } elsif ($cleanmode eq 'none') {
5453 badusage "clean takes no additional arguments" if @ARGV;
5456 maybe_unapply_patches_again();
5459 sub build_prep_early () {
5460 our $build_prep_early_done //= 0;
5461 return if $build_prep_early_done++;
5463 badusage "-p is not allowed when building" if defined $package;
5464 my $clogp = parsechangelog();
5465 $isuite = getfield $clogp, 'Distribution';
5466 $package = getfield $clogp, 'Source';
5467 $version = getfield $clogp, 'Version';
5474 build_maybe_quilt_fixup();
5476 my $pat = changespat $version;
5477 foreach my $f (glob "$buildproductsdir/$pat") {
5479 unlink $f or fail "remove old changes file $f: $!";
5481 progress "would remove $f";
5487 sub changesopts_initial () {
5488 my @opts =@changesopts[1..$#changesopts];
5491 sub changesopts_version () {
5492 if (!defined $changes_since_version) {
5493 my @vsns = archive_query('archive_query');
5494 my @quirk = access_quirk();
5495 if ($quirk[0] eq 'backports') {
5496 local $isuite = $quirk[2];
5498 canonicalise_suite();
5499 push @vsns, archive_query('archive_query');
5502 @vsns = map { $_->[0] } @vsns;
5503 @vsns = sort { -version_compare($a, $b) } @vsns;
5504 $changes_since_version = $vsns[0];
5505 progress "changelog will contain changes since $vsns[0]";
5507 $changes_since_version = '_';
5508 progress "package seems new, not specifying -v<version>";
5511 if ($changes_since_version ne '_') {
5512 return ("-v$changes_since_version");
5518 sub changesopts () {
5519 return (changesopts_initial(), changesopts_version());
5522 sub massage_dbp_args ($;$) {
5523 my ($cmd,$xargs) = @_;
5526 # - if we're going to split the source build out so we can
5527 # do strange things to it, massage the arguments to dpkg-buildpackage
5528 # so that the main build doessn't build source (or add an argument
5529 # to stop it building source by default).
5531 # - add -nc to stop dpkg-source cleaning the source tree,
5532 # unless we're not doing a split build and want dpkg-source
5533 # as cleanmode, in which case we can do nothing
5536 # 0 - source will NOT need to be built separately by caller
5537 # +1 - source will need to be built separately by caller
5538 # +2 - source will need to be built separately by caller AND
5539 # dpkg-buildpackage should not in fact be run at all!
5540 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5541 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5542 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5543 $clean_using_builder = 1;
5546 # -nc has the side effect of specifying -b if nothing else specified
5547 # and some combinations of -S, -b, et al, are errors, rather than
5548 # later simply overriding earlie. So we need to:
5549 # - search the command line for these options
5550 # - pick the last one
5551 # - perhaps add our own as a default
5552 # - perhaps adjust it to the corresponding non-source-building version
5554 foreach my $l ($cmd, $xargs) {
5556 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5559 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5561 if ($need_split_build_invocation) {
5562 printdebug "massage split $dmode.\n";
5563 $r = $dmode =~ m/[S]/ ? +2 :
5564 $dmode =~ y/gGF/ABb/ ? +1 :
5565 $dmode =~ m/[ABb]/ ? 0 :
5568 printdebug "massage done $r $dmode.\n";
5570 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5576 my $wasdir = must_getcwd();
5582 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5583 my ($msg_if_onlyone) = @_;
5584 # If there is only one .changes file, fail with $msg_if_onlyone,
5585 # or if that is undef, be a no-op.
5586 # Returns the changes file to report to the user.
5587 my $pat = changespat $version;
5588 my @changesfiles = glob $pat;
5589 @changesfiles = sort {
5590 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5594 if (@changesfiles==1) {
5595 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5596 only one changes file from build (@changesfiles)
5598 $result = $changesfiles[0];
5599 } elsif (@changesfiles==2) {
5600 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5601 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5602 fail "$l found in binaries changes file $binchanges"
5605 runcmd_ordryrun_local @mergechanges, @changesfiles;
5606 my $multichanges = changespat $version,'multi';
5608 stat_exists $multichanges or fail "$multichanges: $!";
5609 foreach my $cf (glob $pat) {
5610 next if $cf eq $multichanges;
5611 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5614 $result = $multichanges;
5616 fail "wrong number of different changes files (@changesfiles)";
5618 printdone "build successful, results in $result\n" or die $!;
5621 sub midbuild_checkchanges () {
5622 my $pat = changespat $version;
5623 return if $rmchanges;
5624 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5625 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5627 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5628 Suggest you delete @unwanted.
5633 sub midbuild_checkchanges_vanilla ($) {
5635 midbuild_checkchanges() if $wantsrc == 1;
5638 sub postbuild_mergechanges_vanilla ($) {
5640 if ($wantsrc == 1) {
5642 postbuild_mergechanges(undef);
5645 printdone "build successful\n";
5651 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5652 my $wantsrc = massage_dbp_args \@dbp;
5655 midbuild_checkchanges_vanilla $wantsrc;
5660 push @dbp, changesopts_version();
5661 maybe_apply_patches_dirtily();
5662 runcmd_ordryrun_local @dbp;
5664 maybe_unapply_patches_again();
5665 postbuild_mergechanges_vanilla $wantsrc;
5669 $quilt_mode //= 'gbp';
5675 # gbp can make .origs out of thin air. In my tests it does this
5676 # even for a 1.0 format package, with no origs present. So I
5677 # guess it keys off just the version number. We don't know
5678 # exactly what .origs ought to exist, but let's assume that we
5679 # should run gbp if: the version has an upstream part and the main
5681 my $upstreamversion = upstreamversion $version;
5682 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5683 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5685 if ($gbp_make_orig) {
5687 $cleanmode = 'none'; # don't do it again
5688 $need_split_build_invocation = 1;
5691 my @dbp = @dpkgbuildpackage;
5693 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5695 if (!length $gbp_build[0]) {
5696 if (length executable_on_path('git-buildpackage')) {
5697 $gbp_build[0] = qw(git-buildpackage);
5699 $gbp_build[0] = 'gbp buildpackage';
5702 my @cmd = opts_opt_multi_cmd @gbp_build;
5704 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5706 if ($gbp_make_orig) {
5707 ensuredir '.git/dgit';
5708 my $ok = '.git/dgit/origs-gen-ok';
5709 unlink $ok or $!==&ENOENT or die $!;
5710 my @origs_cmd = @cmd;
5711 push @origs_cmd, qw(--git-cleaner=true);
5712 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5713 push @origs_cmd, @ARGV;
5715 debugcmd @origs_cmd;
5717 do { local $!; stat_exists $ok; }
5718 or failedcmd @origs_cmd;
5720 dryrun_report @origs_cmd;
5726 midbuild_checkchanges_vanilla $wantsrc;
5728 if (!$clean_using_builder) {
5729 push @cmd, '--git-cleaner=true';
5733 maybe_unapply_patches_again();
5735 push @cmd, changesopts();
5736 runcmd_ordryrun_local @cmd, @ARGV;
5738 postbuild_mergechanges_vanilla $wantsrc;
5740 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5744 my $our_cleanmode = $cleanmode;
5745 if ($need_split_build_invocation) {
5746 # Pretend that clean is being done some other way. This
5747 # forces us not to try to use dpkg-buildpackage to clean and
5748 # build source all in one go; and instead we run dpkg-source
5749 # (and build_prep() will do the clean since $clean_using_builder
5751 $our_cleanmode = 'ELSEWHERE';
5753 if ($our_cleanmode =~ m/^dpkg-source/) {
5754 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5755 $clean_using_builder = 1;
5758 $sourcechanges = changespat $version,'source';
5760 unlink "../$sourcechanges" or $!==ENOENT
5761 or fail "remove $sourcechanges: $!";
5763 $dscfn = dscfn($version);
5764 if ($our_cleanmode eq 'dpkg-source') {
5765 maybe_apply_patches_dirtily();
5766 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5768 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5769 maybe_apply_patches_dirtily();
5770 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5773 my @cmd = (@dpkgsource, qw(-b --));
5776 runcmd_ordryrun_local @cmd, "work";
5777 my @udfiles = <${package}_*>;
5778 changedir "../../..";
5779 foreach my $f (@udfiles) {
5780 printdebug "source copy, found $f\n";
5783 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5784 $f eq srcfn($version, $&));
5785 printdebug "source copy, found $f - renaming\n";
5786 rename "$ud/$f", "../$f" or $!==ENOENT
5787 or fail "put in place new source file ($f): $!";
5790 my $pwd = must_getcwd();
5791 my $leafdir = basename $pwd;
5793 runcmd_ordryrun_local @cmd, $leafdir;
5796 runcmd_ordryrun_local qw(sh -ec),
5797 'exec >$1; shift; exec "$@"','x',
5798 "../$sourcechanges",
5799 @dpkggenchanges, qw(-S), changesopts();
5803 sub cmd_build_source {
5805 badusage "build-source takes no additional arguments" if @ARGV;
5807 maybe_unapply_patches_again();
5808 printdone "source built, results in $dscfn and $sourcechanges";
5813 midbuild_checkchanges();
5816 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5817 stat_exists $sourcechanges
5818 or fail "$sourcechanges (in parent directory): $!";
5820 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5822 maybe_unapply_patches_again();
5824 postbuild_mergechanges(<<END);
5825 perhaps you need to pass -A ? (sbuild's default is to build only
5826 arch-specific binaries; dgit 1.4 used to override that.)
5831 sub cmd_quilt_fixup {
5832 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5835 build_maybe_quilt_fixup();
5838 sub cmd_import_dsc {
5842 last unless $ARGV[0] =~ m/^-/;
5845 if (m/^--require-valid-signature$/) {
5848 badusage "unknown dgit import-dsc sub-option \`$_'";
5852 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5853 my ($dscfn, $dstbranch) = @ARGV;
5855 badusage "dry run makes no sense with import-dsc" unless act_local();
5857 my $force = $dstbranch =~ s/^\+// ? +1 :
5858 $dstbranch =~ s/^\.\.// ? -1 :
5860 my $info = $force ? " $&" : '';
5861 $info = "$dscfn$info";
5863 my $specbranch = $dstbranch;
5864 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5865 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5867 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5868 my $chead = cmdoutput_errok @symcmd;
5869 defined $chead or $?==256 or failedcmd @symcmd;
5871 fail "$dstbranch is checked out - will not update it"
5872 if defined $chead and $chead eq $dstbranch;
5874 my $oldhash = git_get_ref $dstbranch;
5876 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5877 $dscdata = do { local $/ = undef; <D>; };
5878 D->error and fail "read $dscfn: $!";
5881 # we don't normally need this so import it here
5882 use Dpkg::Source::Package;
5883 my $dp = new Dpkg::Source::Package filename => $dscfn,
5884 require_valid_signature => $needsig;
5886 local $SIG{__WARN__} = sub {
5888 return unless $needsig;
5889 fail "import-dsc signature check failed";
5891 if (!$dp->is_signed()) {
5892 warn "$us: warning: importing unsigned .dsc\n";
5894 my $r = $dp->check_signature();
5895 die "->check_signature => $r" if $needsig && $r;
5901 my $dgit_field = $dsc->{$ourdscfield[0]};
5902 parse_dsc_field($dgit_field, "$ourdscfield[0] field in .dsc");
5904 if (defined $dsc_hash
5905 && !forceing [qw(import-dsc-with-dgit-field)]) {
5906 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5907 my @cmd = (qw(sh -ec),
5908 "echo $dsc_hash | git cat-file --batch-check");
5909 my $objgot = cmdoutput @cmd;
5910 if ($objgot =~ m#^\w+ missing\b#) {
5912 .dsc contains Dgit field referring to object $dsc_hash
5913 Your git tree does not have that object. Try `git fetch' from a
5914 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5917 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
5919 progress "Not fast forward, forced update.";
5921 fail "Not fast forward to $dsc_hash";
5924 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5925 $dstbranch, $dsc_hash);
5927 progress "dgit: import-dsc updated git ref $dstbranch";
5932 Branch $dstbranch already exists
5933 Specify ..$specbranch for a pseudo-merge, binding in existing history
5934 Specify +$specbranch to overwrite, discarding existing history
5936 if $oldhash && !$force;
5938 $package = getfield $dsc, 'Source';
5939 my @dfi = dsc_files_info();
5940 foreach my $fi (@dfi) {
5941 my $f = $fi->{Filename};
5943 next if lstat $here;
5944 fail "stat $here: $!" unless $! == ENOENT;
5946 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5948 } elsif ($dscfn =~ m#^/#) {
5951 fail "cannot import $dscfn which seems to be inside working tree!";
5953 $there =~ s#/+[^/]+$## or
5954 fail "cannot import $dscfn which seems to not have a basename";
5956 symlink $there, $here or fail "symlink $there to $here: $!";
5957 progress "made symlink $here -> $there";
5958 # print STDERR Dumper($fi);
5960 my @mergeinputs = generate_commits_from_dsc();
5961 die unless @mergeinputs == 1;
5963 my $newhash = $mergeinputs[0]{Commit};
5967 progress "Import, forced update - synthetic orphan git history.";
5968 } elsif ($force < 0) {
5969 progress "Import, merging.";
5970 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5971 my $version = getfield $dsc, 'Version';
5972 my $clogp = commit_getclogp $newhash;
5973 my $authline = clogp_authline $clogp;
5974 $newhash = make_commit_text <<END;
5981 Merge $package ($version) import into $dstbranch
5984 die; # caught earlier
5988 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5989 $dstbranch, $newhash);
5991 progress "dgit: import-dsc results are in in git ref $dstbranch";
5994 sub cmd_archive_api_query {
5995 badusage "need only 1 subpath argument" unless @ARGV==1;
5996 my ($subpath) = @ARGV;
5997 my @cmd = archive_api_query_cmd($subpath);
6000 exec @cmd or fail "exec curl: $!\n";
6003 sub cmd_clone_dgit_repos_server {
6004 badusage "need destination argument" unless @ARGV==1;
6005 my ($destdir) = @ARGV;
6006 $package = '_dgit-repos-server';
6007 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6009 exec @cmd or fail "exec git clone: $!\n";
6012 sub cmd_setup_mergechangelogs {
6013 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6014 setup_mergechangelogs(1);
6017 sub cmd_setup_useremail {
6018 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6022 sub cmd_setup_new_tree {
6023 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6027 #---------- argument parsing and main program ----------
6030 print "dgit version $our_version\n" or die $!;
6034 our (%valopts_long, %valopts_short);
6037 sub defvalopt ($$$$) {
6038 my ($long,$short,$val_re,$how) = @_;
6039 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6040 $valopts_long{$long} = $oi;
6041 $valopts_short{$short} = $oi;
6042 # $how subref should:
6043 # do whatever assignemnt or thing it likes with $_[0]
6044 # if the option should not be passed on to remote, @rvalopts=()
6045 # or $how can be a scalar ref, meaning simply assign the value
6048 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6049 defvalopt '--distro', '-d', '.+', \$idistro;
6050 defvalopt '', '-k', '.+', \$keyid;
6051 defvalopt '--existing-package','', '.*', \$existing_package;
6052 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6053 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6054 defvalopt '--package', '-p', $package_re, \$package;
6055 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6057 defvalopt '', '-C', '.+', sub {
6058 ($changesfile) = (@_);
6059 if ($changesfile =~ s#^(.*)/##) {
6060 $buildproductsdir = $1;
6064 defvalopt '--initiator-tempdir','','.*', sub {
6065 ($initiator_tempdir) = (@_);
6066 $initiator_tempdir =~ m#^/# or
6067 badusage "--initiator-tempdir must be used specify an".
6068 " absolute, not relative, directory."
6074 if (defined $ENV{'DGIT_SSH'}) {
6075 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6076 } elsif (defined $ENV{'GIT_SSH'}) {
6077 @ssh = ($ENV{'GIT_SSH'});
6085 if (!defined $val) {
6086 badusage "$what needs a value" unless @ARGV;
6088 push @rvalopts, $val;
6090 badusage "bad value \`$val' for $what" unless
6091 $val =~ m/^$oi->{Re}$(?!\n)/s;
6092 my $how = $oi->{How};
6093 if (ref($how) eq 'SCALAR') {
6098 push @ropts, @rvalopts;
6102 last unless $ARGV[0] =~ m/^-/;
6106 if (m/^--dry-run$/) {
6109 } elsif (m/^--damp-run$/) {
6112 } elsif (m/^--no-sign$/) {
6115 } elsif (m/^--help$/) {
6117 } elsif (m/^--version$/) {
6119 } elsif (m/^--new$/) {
6122 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6123 ($om = $opts_opt_map{$1}) &&
6127 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6128 !$opts_opt_cmdonly{$1} &&
6129 ($om = $opts_opt_map{$1})) {
6132 } elsif (m/^--(gbp|dpm)$/s) {
6133 push @ropts, "--quilt=$1";
6135 } elsif (m/^--ignore-dirty$/s) {
6138 } elsif (m/^--no-quilt-fixup$/s) {
6140 $quilt_mode = 'nocheck';
6141 } elsif (m/^--no-rm-on-error$/s) {
6144 } elsif (m/^--overwrite$/s) {
6146 $overwrite_version = '';
6147 } elsif (m/^--overwrite=(.+)$/s) {
6149 $overwrite_version = $1;
6150 } elsif (m/^--dep14tag$/s) {
6152 $dodep14tag= 'want';
6153 } elsif (m/^--no-dep14tag$/s) {
6156 } elsif (m/^--always-dep14tag$/s) {
6158 $dodep14tag= 'always';
6159 } elsif (m/^--delayed=(\d+)$/s) {
6162 } elsif (m/^--dgit-view-save=(.+)$/s) {
6164 $split_brain_save = $1;
6165 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6166 } elsif (m/^--(no-)?rm-old-changes$/s) {
6169 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6171 push @deliberatelies, $&;
6172 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6176 } elsif (m/^--force-/) {
6178 "$us: warning: ignoring unknown force option $_\n";
6180 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6181 # undocumented, for testing
6183 $tagformat_want = [ $1, 'command line', 1 ];
6184 # 1 menas overrides distro configuration
6185 } elsif (m/^--always-split-source-build$/s) {
6186 # undocumented, for testing
6188 $need_split_build_invocation = 1;
6189 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6190 $val = $2 ? $' : undef; #';
6191 $valopt->($oi->{Long});
6193 badusage "unknown long option \`$_'";
6200 } elsif (s/^-L/-/) {
6203 } elsif (s/^-h/-/) {
6205 } elsif (s/^-D/-/) {
6209 } elsif (s/^-N/-/) {
6214 push @changesopts, $_;
6216 } elsif (s/^-wn$//s) {
6218 $cleanmode = 'none';
6219 } elsif (s/^-wg$//s) {
6222 } elsif (s/^-wgf$//s) {
6224 $cleanmode = 'git-ff';
6225 } elsif (s/^-wd$//s) {
6227 $cleanmode = 'dpkg-source';
6228 } elsif (s/^-wdd$//s) {
6230 $cleanmode = 'dpkg-source-d';
6231 } elsif (s/^-wc$//s) {
6233 $cleanmode = 'check';
6234 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6235 push @git, '-c', $&;
6236 $gitcfgs{cmdline}{$1} = [ $2 ];
6237 } elsif (s/^-c([^=]+)$//s) {
6238 push @git, '-c', $&;
6239 $gitcfgs{cmdline}{$1} = [ 'true' ];
6240 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6242 $val = undef unless length $val;
6243 $valopt->($oi->{Short});
6246 badusage "unknown short option \`$_'";
6253 sub check_env_sanity () {
6254 my $blocked = new POSIX::SigSet;
6255 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6258 foreach my $name (qw(PIPE CHLD)) {
6259 my $signame = "SIG$name";
6260 my $signum = eval "POSIX::$signame" // die;
6261 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6262 die "$signame is set to something other than SIG_DFL\n";
6263 $blocked->ismember($signum) and
6264 die "$signame is blocked\n";
6270 On entry to dgit, $@
6271 This is a bug produced by something in in your execution environment.
6277 sub parseopts_late_defaults () {
6278 foreach my $k (keys %opts_opt_map) {
6279 my $om = $opts_opt_map{$k};
6281 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6283 badcfg "cannot set command for $k"
6284 unless length $om->[0];
6288 foreach my $c (access_cfg_cfgs("opts-$k")) {
6290 map { $_ ? @$_ : () }
6291 map { $gitcfgs{$_}{$c} }
6292 reverse @gitcfgsources;
6293 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6294 "\n" if $debuglevel >= 4;
6296 badcfg "cannot configure options for $k"
6297 if $opts_opt_cmdonly{$k};
6298 my $insertpos = $opts_cfg_insertpos{$k};
6299 @$om = ( @$om[0..$insertpos-1],
6301 @$om[$insertpos..$#$om] );
6305 if (!defined $rmchanges) {
6306 local $access_forpush;
6307 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6310 if (!defined $quilt_mode) {
6311 local $access_forpush;
6312 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6313 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6315 $quilt_mode =~ m/^($quilt_modes_re)$/
6316 or badcfg "unknown quilt-mode \`$quilt_mode'";
6320 if (!defined $dodep14tag) {
6321 local $access_forpush;
6322 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6323 $dodep14tag =~ m/^($dodep14tag_re)$/
6324 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6328 $need_split_build_invocation ||= quiltmode_splitbrain();
6330 if (!defined $cleanmode) {
6331 local $access_forpush;
6332 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6333 $cleanmode //= 'dpkg-source';
6335 badcfg "unknown clean-mode \`$cleanmode'" unless
6336 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6340 if ($ENV{$fakeeditorenv}) {
6342 quilt_fixup_editor();
6349 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6350 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6351 if $dryrun_level == 1;
6353 print STDERR $helpmsg or die $!;
6356 my $cmd = shift @ARGV;
6359 my $pre_fn = ${*::}{"pre_$cmd"};
6360 $pre_fn->() if $pre_fn;
6362 my $fn = ${*::}{"cmd_$cmd"};
6363 $fn or badusage "unknown operation $cmd";