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 finalise_opts_opts();
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 finalise_opts_opts();
798 finalise_opts_opts();
801 sub supplementary_message ($) {
803 if (!$we_are_responder) {
804 $supplementary_message = $msg;
806 } elsif ($protovsn >= 3) {
807 responder_send_command "supplementary-message ".length($msg)
809 print PO $msg or die $!;
813 sub access_distros () {
814 # Returns list of distros to try, in order
817 # 0. `instead of' distro name(s) we have been pointed to
818 # 1. the access_quirk distro, if any
819 # 2a. the user's specified distro, or failing that } basedistro
820 # 2b. the distro calculated from the suite }
821 my @l = access_basedistro();
823 my (undef,$quirkdistro) = access_quirk();
824 unshift @l, $quirkdistro;
825 unshift @l, $instead_distro;
826 @l = grep { defined } @l;
828 push @l, access_nomdistro();
830 if (access_forpush()) {
831 @l = map { ("$_/push", $_) } @l;
836 sub access_cfg_cfgs (@) {
839 # The nesting of these loops determines the search order. We put
840 # the key loop on the outside so that we search all the distros
841 # for each key, before going on to the next key. That means that
842 # if access_cfg is called with a more specific, and then a less
843 # specific, key, an earlier distro can override the less specific
844 # without necessarily overriding any more specific keys. (If the
845 # distro wants to override the more specific keys it can simply do
846 # so; whereas if we did the loop the other way around, it would be
847 # impossible to for an earlier distro to override a less specific
848 # key but not the more specific ones without restating the unknown
849 # values of the more specific keys.
852 # We have to deal with RETURN-UNDEF specially, so that we don't
853 # terminate the search prematurely.
855 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
858 foreach my $d (access_distros()) {
859 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
861 push @cfgs, map { "dgit.default.$_" } @realkeys;
868 my (@cfgs) = access_cfg_cfgs(@keys);
869 my $value = cfg(@cfgs);
873 sub access_cfg_bool ($$) {
874 my ($def, @keys) = @_;
875 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
878 sub string_to_ssh ($) {
880 if ($spec =~ m/\s/) {
881 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
887 sub access_cfg_ssh () {
888 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
889 if (!defined $gitssh) {
892 return string_to_ssh $gitssh;
896 sub access_runeinfo ($) {
898 return ": dgit ".access_basedistro()." $info ;";
901 sub access_someuserhost ($) {
903 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
904 defined($user) && length($user) or
905 $user = access_cfg("$some-user",'username');
906 my $host = access_cfg("$some-host");
907 return length($user) ? "$user\@$host" : $host;
910 sub access_gituserhost () {
911 return access_someuserhost('git');
914 sub access_giturl (;$) {
916 my $url = access_cfg('git-url','RETURN-UNDEF');
919 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
920 return undef unless defined $proto;
923 access_gituserhost().
924 access_cfg('git-path');
926 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
929 return "$url/$package$suffix";
932 sub parsecontrolfh ($$;$) {
933 my ($fh, $desc, $allowsigned) = @_;
934 our $dpkgcontrolhash_noissigned;
937 my %opts = ('name' => $desc);
938 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
939 $c = Dpkg::Control::Hash->new(%opts);
940 $c->parse($fh,$desc) or die "parsing of $desc failed";
941 last if $allowsigned;
942 last if $dpkgcontrolhash_noissigned;
943 my $issigned= $c->get_option('is_pgp_signed');
944 if (!defined $issigned) {
945 $dpkgcontrolhash_noissigned= 1;
946 seek $fh, 0,0 or die "seek $desc: $!";
947 } elsif ($issigned) {
948 fail "control file $desc is (already) PGP-signed. ".
949 " Note that dgit push needs to modify the .dsc and then".
950 " do the signature itself";
959 my ($file, $desc, $allowsigned) = @_;
960 my $fh = new IO::Handle;
961 open $fh, '<', $file or die "$file: $!";
962 my $c = parsecontrolfh($fh,$desc,$allowsigned);
963 $fh->error and die $!;
969 my ($dctrl,$field) = @_;
970 my $v = $dctrl->{$field};
971 return $v if defined $v;
972 fail "missing field $field in ".$dctrl->get_option('name');
976 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
977 my $p = new IO::Handle;
978 my @cmd = (qw(dpkg-parsechangelog), @_);
979 open $p, '-|', @cmd or die $!;
981 $?=0; $!=0; close $p or failedcmd @cmd;
985 sub commit_getclogp ($) {
986 # Returns the parsed changelog hashref for a particular commit
988 our %commit_getclogp_memo;
989 my $memo = $commit_getclogp_memo{$objid};
990 return $memo if $memo;
992 my $mclog = ".git/dgit/clog-$objid";
993 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
994 "$objid:debian/changelog";
995 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1000 defined $d or fail "getcwd failed: $!";
1004 sub parse_dscdata () {
1005 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1006 printdebug Dumper($dscdata) if $debuglevel>1;
1007 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1008 printdebug Dumper($dsc) if $debuglevel>1;
1013 sub archive_query ($;@) {
1014 my ($method) = shift @_;
1015 fail "this operation does not support multiple comma-separated suites"
1017 my $query = access_cfg('archive-query','RETURN-UNDEF');
1018 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1021 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1024 sub archive_query_prepend_mirror {
1025 my $m = access_cfg('mirror');
1026 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1029 sub pool_dsc_subpath ($$) {
1030 my ($vsn,$component) = @_; # $package is implict arg
1031 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1032 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1035 sub cfg_apply_map ($$$) {
1036 my ($varref, $what, $mapspec) = @_;
1037 return unless $mapspec;
1039 printdebug "config $what EVAL{ $mapspec; }\n";
1041 eval "package Dgit::Config; $mapspec;";
1046 #---------- `ftpmasterapi' archive query method (nascent) ----------
1048 sub archive_api_query_cmd ($) {
1050 my @cmd = (@curl, qw(-sS));
1051 my $url = access_cfg('archive-query-url');
1052 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1054 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1055 foreach my $key (split /\:/, $keys) {
1056 $key =~ s/\%HOST\%/$host/g;
1058 fail "for $url: stat $key: $!" unless $!==ENOENT;
1061 fail "config requested specific TLS key but do not know".
1062 " how to get curl to use exactly that EE key ($key)";
1063 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1064 # # Sadly the above line does not work because of changes
1065 # # to gnutls. The real fix for #790093 may involve
1066 # # new curl options.
1069 # Fixing #790093 properly will involve providing a value
1070 # for this on clients.
1071 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1072 push @cmd, split / /, $kargs if defined $kargs;
1074 push @cmd, $url.$subpath;
1078 sub api_query ($$;$) {
1080 my ($data, $subpath, $ok404) = @_;
1081 badcfg "ftpmasterapi archive query method takes no data part"
1083 my @cmd = archive_api_query_cmd($subpath);
1084 my $url = $cmd[$#cmd];
1085 push @cmd, qw(-w %{http_code});
1086 my $json = cmdoutput @cmd;
1087 unless ($json =~ s/\d+\d+\d$//) {
1088 failedcmd_report_cmd undef, @cmd;
1089 fail "curl failed to print 3-digit HTTP code";
1092 return undef if $code eq '404' && $ok404;
1093 fail "fetch of $url gave HTTP code $code"
1094 unless $url =~ m#^file://# or $code =~ m/^2/;
1095 return decode_json($json);
1098 sub canonicalise_suite_ftpmasterapi {
1099 my ($proto,$data) = @_;
1100 my $suites = api_query($data, 'suites');
1102 foreach my $entry (@$suites) {
1104 my $v = $entry->{$_};
1105 defined $v && $v eq $isuite;
1106 } qw(codename name);
1107 push @matched, $entry;
1109 fail "unknown suite $isuite" unless @matched;
1112 @matched==1 or die "multiple matches for suite $isuite\n";
1113 $cn = "$matched[0]{codename}";
1114 defined $cn or die "suite $isuite info has no codename\n";
1115 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1117 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1122 sub archive_query_ftpmasterapi {
1123 my ($proto,$data) = @_;
1124 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1126 my $digester = Digest::SHA->new(256);
1127 foreach my $entry (@$info) {
1129 my $vsn = "$entry->{version}";
1130 my ($ok,$msg) = version_check $vsn;
1131 die "bad version: $msg\n" unless $ok;
1132 my $component = "$entry->{component}";
1133 $component =~ m/^$component_re$/ or die "bad component";
1134 my $filename = "$entry->{filename}";
1135 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1136 or die "bad filename";
1137 my $sha256sum = "$entry->{sha256sum}";
1138 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1139 push @rows, [ $vsn, "/pool/$component/$filename",
1140 $digester, $sha256sum ];
1142 die "bad ftpmaster api response: $@\n".Dumper($entry)
1145 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1146 return archive_query_prepend_mirror @rows;
1149 sub file_in_archive_ftpmasterapi {
1150 my ($proto,$data,$filename) = @_;
1151 my $pat = $filename;
1154 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1155 my $info = api_query($data, "file_in_archive/$pat", 1);
1158 #---------- `aptget' archive query method ----------
1161 our $aptget_releasefile;
1162 our $aptget_configpath;
1164 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1165 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1167 sub aptget_cache_clean {
1168 runcmd_ordryrun_local qw(sh -ec),
1169 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1173 sub aptget_lock_acquire () {
1174 my $lockfile = "$aptget_base/lock";
1175 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1176 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1179 sub aptget_prep ($) {
1181 return if defined $aptget_base;
1183 badcfg "aptget archive query method takes no data part"
1186 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1189 ensuredir "$cache/dgit";
1191 access_cfg('aptget-cachekey','RETURN-UNDEF')
1192 // access_nomdistro();
1194 $aptget_base = "$cache/dgit/aptget";
1195 ensuredir $aptget_base;
1197 my $quoted_base = $aptget_base;
1198 die "$quoted_base contains bad chars, cannot continue"
1199 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1201 ensuredir $aptget_base;
1203 aptget_lock_acquire();
1205 aptget_cache_clean();
1207 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1208 my $sourceslist = "source.list#$cachekey";
1210 my $aptsuites = $isuite;
1211 cfg_apply_map(\$aptsuites, 'suite map',
1212 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1214 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1215 printf SRCS "deb-src %s %s %s\n",
1216 access_cfg('mirror'),
1218 access_cfg('aptget-components')
1221 ensuredir "$aptget_base/cache";
1222 ensuredir "$aptget_base/lists";
1224 open CONF, ">", $aptget_configpath or die $!;
1226 Debug::NoLocking "true";
1227 APT::Get::List-Cleanup "false";
1228 #clear APT::Update::Post-Invoke-Success;
1229 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1230 Dir::State::Lists "$quoted_base/lists";
1231 Dir::Etc::preferences "$quoted_base/preferences";
1232 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1233 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1236 foreach my $key (qw(
1239 Dir::Cache::Archives
1240 Dir::Etc::SourceParts
1241 Dir::Etc::preferencesparts
1243 ensuredir "$aptget_base/$key";
1244 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1247 my $oldatime = (time // die $!) - 1;
1248 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1249 next unless stat_exists $oldlist;
1250 my ($mtime) = (stat _)[9];
1251 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1254 runcmd_ordryrun_local aptget_aptget(), qw(update);
1257 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1258 next unless stat_exists $oldlist;
1259 my ($atime) = (stat _)[8];
1260 next if $atime == $oldatime;
1261 push @releasefiles, $oldlist;
1263 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1264 @releasefiles = @inreleasefiles if @inreleasefiles;
1265 die "apt updated wrong number of Release files (@releasefiles), erk"
1266 unless @releasefiles == 1;
1268 ($aptget_releasefile) = @releasefiles;
1271 sub canonicalise_suite_aptget {
1272 my ($proto,$data) = @_;
1275 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1277 foreach my $name (qw(Codename Suite)) {
1278 my $val = $release->{$name};
1280 printdebug "release file $name: $val\n";
1281 $val =~ m/^$suite_re$/o or fail
1282 "Release file ($aptget_releasefile) specifies intolerable $name";
1283 cfg_apply_map(\$val, 'suite rmap',
1284 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1291 sub archive_query_aptget {
1292 my ($proto,$data) = @_;
1295 ensuredir "$aptget_base/source";
1296 foreach my $old (<$aptget_base/source/*.dsc>) {
1297 unlink $old or die "$old: $!";
1300 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1301 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1302 # avoids apt-get source failing with ambiguous error code
1304 runcmd_ordryrun_local
1305 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1306 aptget_aptget(), qw(--download-only --only-source source), $package;
1308 my @dscs = <$aptget_base/source/*.dsc>;
1309 fail "apt-get source did not produce a .dsc" unless @dscs;
1310 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1312 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1315 my $uri = "file://". uri_escape $dscs[0];
1316 $uri =~ s{\%2f}{/}gi;
1317 return [ (getfield $pre_dsc, 'Version'), $uri ];
1320 #---------- `dummyapicat' archive query method ----------
1322 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1323 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1325 sub file_in_archive_dummycatapi ($$$) {
1326 my ($proto,$data,$filename) = @_;
1327 my $mirror = access_cfg('mirror');
1328 $mirror =~ s#^file://#/# or die "$mirror ?";
1330 my @cmd = (qw(sh -ec), '
1332 find -name "$2" -print0 |
1334 ', qw(x), $mirror, $filename);
1335 debugcmd "-|", @cmd;
1336 open FIA, "-|", @cmd or die $!;
1339 printdebug "| $_\n";
1340 m/^(\w+) (\S+)$/ or die "$_ ?";
1341 push @out, { sha256sum => $1, filename => $2 };
1343 close FIA or die failedcmd @cmd;
1347 #---------- `madison' archive query method ----------
1349 sub archive_query_madison {
1350 return archive_query_prepend_mirror
1351 map { [ @$_[0..1] ] } madison_get_parse(@_);
1354 sub madison_get_parse {
1355 my ($proto,$data) = @_;
1356 die unless $proto eq 'madison';
1357 if (!length $data) {
1358 $data= access_cfg('madison-distro','RETURN-UNDEF');
1359 $data //= access_basedistro();
1361 $rmad{$proto,$data,$package} ||= cmdoutput
1362 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1363 my $rmad = $rmad{$proto,$data,$package};
1366 foreach my $l (split /\n/, $rmad) {
1367 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1368 \s*( [^ \t|]+ )\s* \|
1369 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1370 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1371 $1 eq $package or die "$rmad $package ?";
1378 $component = access_cfg('archive-query-default-component');
1380 $5 eq 'source' or die "$rmad ?";
1381 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1383 return sort { -version_compare($a->[0],$b->[0]); } @out;
1386 sub canonicalise_suite_madison {
1387 # madison canonicalises for us
1388 my @r = madison_get_parse(@_);
1390 "unable to canonicalise suite using package $package".
1391 " which does not appear to exist in suite $isuite;".
1392 " --existing-package may help";
1396 sub file_in_archive_madison { return undef; }
1398 #---------- `sshpsql' archive query method ----------
1401 my ($data,$runeinfo,$sql) = @_;
1402 if (!length $data) {
1403 $data= access_someuserhost('sshpsql').':'.
1404 access_cfg('sshpsql-dbname');
1406 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1407 my ($userhost,$dbname) = ($`,$'); #';
1409 my @cmd = (access_cfg_ssh, $userhost,
1410 access_runeinfo("ssh-psql $runeinfo").
1411 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1412 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1414 open P, "-|", @cmd or die $!;
1417 printdebug(">|$_|\n");
1420 $!=0; $?=0; close P or failedcmd @cmd;
1422 my $nrows = pop @rows;
1423 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1424 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1425 @rows = map { [ split /\|/, $_ ] } @rows;
1426 my $ncols = scalar @{ shift @rows };
1427 die if grep { scalar @$_ != $ncols } @rows;
1431 sub sql_injection_check {
1432 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1435 sub archive_query_sshpsql ($$) {
1436 my ($proto,$data) = @_;
1437 sql_injection_check $isuite, $package;
1438 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1439 SELECT source.version, component.name, files.filename, files.sha256sum
1441 JOIN src_associations ON source.id = src_associations.source
1442 JOIN suite ON suite.id = src_associations.suite
1443 JOIN dsc_files ON dsc_files.source = source.id
1444 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1445 JOIN component ON component.id = files_archive_map.component_id
1446 JOIN files ON files.id = dsc_files.file
1447 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1448 AND source.source='$package'
1449 AND files.filename LIKE '%.dsc';
1451 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1452 my $digester = Digest::SHA->new(256);
1454 my ($vsn,$component,$filename,$sha256sum) = @$_;
1455 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1457 return archive_query_prepend_mirror @rows;
1460 sub canonicalise_suite_sshpsql ($$) {
1461 my ($proto,$data) = @_;
1462 sql_injection_check $isuite;
1463 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1464 SELECT suite.codename
1465 FROM suite where suite_name='$isuite' or codename='$isuite';
1467 @rows = map { $_->[0] } @rows;
1468 fail "unknown suite $isuite" unless @rows;
1469 die "ambiguous $isuite: @rows ?" if @rows>1;
1473 sub file_in_archive_sshpsql ($$$) { return undef; }
1475 #---------- `dummycat' archive query method ----------
1477 sub canonicalise_suite_dummycat ($$) {
1478 my ($proto,$data) = @_;
1479 my $dpath = "$data/suite.$isuite";
1480 if (!open C, "<", $dpath) {
1481 $!==ENOENT or die "$dpath: $!";
1482 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1486 chomp or die "$dpath: $!";
1488 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1492 sub archive_query_dummycat ($$) {
1493 my ($proto,$data) = @_;
1494 canonicalise_suite();
1495 my $dpath = "$data/package.$csuite.$package";
1496 if (!open C, "<", $dpath) {
1497 $!==ENOENT or die "$dpath: $!";
1498 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1506 printdebug "dummycat query $csuite $package $dpath | $_\n";
1507 my @row = split /\s+/, $_;
1508 @row==2 or die "$dpath: $_ ?";
1511 C->error and die "$dpath: $!";
1513 return archive_query_prepend_mirror
1514 sort { -version_compare($a->[0],$b->[0]); } @rows;
1517 sub file_in_archive_dummycat () { return undef; }
1519 #---------- tag format handling ----------
1521 sub access_cfg_tagformats () {
1522 split /\,/, access_cfg('dgit-tag-format');
1525 sub access_cfg_tagformats_can_splitbrain () {
1526 my %y = map { $_ => 1 } access_cfg_tagformats;
1527 foreach my $needtf (qw(new maint)) {
1528 next if $y{$needtf};
1534 sub need_tagformat ($$) {
1535 my ($fmt, $why) = @_;
1536 fail "need to use tag format $fmt ($why) but also need".
1537 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1538 " - no way to proceed"
1539 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1540 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1543 sub select_tagformat () {
1545 return if $tagformatfn && !$tagformat_want;
1546 die 'bug' if $tagformatfn && $tagformat_want;
1547 # ... $tagformat_want assigned after previous select_tagformat
1549 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1550 printdebug "select_tagformat supported @supported\n";
1552 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1553 printdebug "select_tagformat specified @$tagformat_want\n";
1555 my ($fmt,$why,$override) = @$tagformat_want;
1557 fail "target distro supports tag formats @supported".
1558 " but have to use $fmt ($why)"
1560 or grep { $_ eq $fmt } @supported;
1562 $tagformat_want = undef;
1564 $tagformatfn = ${*::}{"debiantag_$fmt"};
1566 fail "trying to use unknown tag format \`$fmt' ($why) !"
1567 unless $tagformatfn;
1570 #---------- archive query entrypoints and rest of program ----------
1572 sub canonicalise_suite () {
1573 return if defined $csuite;
1574 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1575 $csuite = archive_query('canonicalise_suite');
1576 if ($isuite ne $csuite) {
1577 progress "canonical suite name for $isuite is $csuite";
1579 progress "canonical suite name is $csuite";
1583 sub get_archive_dsc () {
1584 canonicalise_suite();
1585 my @vsns = archive_query('archive_query');
1586 foreach my $vinfo (@vsns) {
1587 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1588 $dscurl = $vsn_dscurl;
1589 $dscdata = url_get($dscurl);
1591 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1596 $digester->add($dscdata);
1597 my $got = $digester->hexdigest();
1599 fail "$dscurl has hash $got but".
1600 " archive told us to expect $digest";
1603 my $fmt = getfield $dsc, 'Format';
1604 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1605 "unsupported source format $fmt, sorry";
1607 $dsc_checked = !!$digester;
1608 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1612 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1615 sub check_for_git ();
1616 sub check_for_git () {
1618 my $how = access_cfg('git-check');
1619 if ($how eq 'ssh-cmd') {
1621 (access_cfg_ssh, access_gituserhost(),
1622 access_runeinfo("git-check $package").
1623 " set -e; cd ".access_cfg('git-path').";".
1624 " if test -d $package.git; then echo 1; else echo 0; fi");
1625 my $r= cmdoutput @cmd;
1626 if (defined $r and $r =~ m/^divert (\w+)$/) {
1628 my ($usedistro,) = access_distros();
1629 # NB that if we are pushing, $usedistro will be $distro/push
1630 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1631 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1632 progress "diverting to $divert (using config for $instead_distro)";
1633 return check_for_git();
1635 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1637 } elsif ($how eq 'url') {
1638 my $prefix = access_cfg('git-check-url','git-url');
1639 my $suffix = access_cfg('git-check-suffix','git-suffix',
1640 'RETURN-UNDEF') // '.git';
1641 my $url = "$prefix/$package$suffix";
1642 my @cmd = (@curl, qw(-sS -I), $url);
1643 my $result = cmdoutput @cmd;
1644 $result =~ s/^\S+ 200 .*\n\r?\n//;
1645 # curl -sS -I with https_proxy prints
1646 # HTTP/1.0 200 Connection established
1647 $result =~ m/^\S+ (404|200) /s or
1648 fail "unexpected results from git check query - ".
1649 Dumper($prefix, $result);
1651 if ($code eq '404') {
1653 } elsif ($code eq '200') {
1658 } elsif ($how eq 'true') {
1660 } elsif ($how eq 'false') {
1663 badcfg "unknown git-check \`$how'";
1667 sub create_remote_git_repo () {
1668 my $how = access_cfg('git-create');
1669 if ($how eq 'ssh-cmd') {
1671 (access_cfg_ssh, access_gituserhost(),
1672 access_runeinfo("git-create $package").
1673 "set -e; cd ".access_cfg('git-path').";".
1674 " cp -a _template $package.git");
1675 } elsif ($how eq 'true') {
1678 badcfg "unknown git-create \`$how'";
1682 our ($dsc_hash,$lastpush_mergeinput);
1684 our $ud = '.git/dgit/unpack';
1694 sub mktree_in_ud_here () {
1695 runcmd qw(git init -q);
1696 runcmd qw(git config gc.auto 0);
1697 rmtree('.git/objects');
1698 symlink '../../../../objects','.git/objects' or die $!;
1701 sub git_write_tree () {
1702 my $tree = cmdoutput @git, qw(write-tree);
1703 $tree =~ m/^\w+$/ or die "$tree ?";
1707 sub git_add_write_tree () {
1708 runcmd @git, qw(add -Af .);
1709 return git_write_tree();
1712 sub remove_stray_gits ($) {
1714 my @gitscmd = qw(find -name .git -prune -print0);
1715 debugcmd "|",@gitscmd;
1716 open GITS, "-|", @gitscmd or die $!;
1721 print STDERR "$us: warning: removing from $what: ",
1722 (messagequote $_), "\n";
1726 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1729 sub mktree_in_ud_from_only_subdir ($;$) {
1730 my ($what,$raw) = @_;
1732 # changes into the subdir
1734 die "expected one subdir but found @dirs ?" unless @dirs==1;
1735 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1739 remove_stray_gits($what);
1740 mktree_in_ud_here();
1742 my ($format, $fopts) = get_source_format();
1743 if (madformat($format)) {
1748 my $tree=git_add_write_tree();
1749 return ($tree,$dir);
1752 our @files_csum_info_fields =
1753 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1754 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1755 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1757 sub dsc_files_info () {
1758 foreach my $csumi (@files_csum_info_fields) {
1759 my ($fname, $module, $method) = @$csumi;
1760 my $field = $dsc->{$fname};
1761 next unless defined $field;
1762 eval "use $module; 1;" or die $@;
1764 foreach (split /\n/, $field) {
1766 m/^(\w+) (\d+) (\S+)$/ or
1767 fail "could not parse .dsc $fname line \`$_'";
1768 my $digester = eval "$module"."->$method;" or die $@;
1773 Digester => $digester,
1778 fail "missing any supported Checksums-* or Files field in ".
1779 $dsc->get_option('name');
1783 map { $_->{Filename} } dsc_files_info();
1786 sub files_compare_inputs (@) {
1791 my $showinputs = sub {
1792 return join "; ", map { $_->get_option('name') } @$inputs;
1795 foreach my $in (@$inputs) {
1797 my $in_name = $in->get_option('name');
1799 printdebug "files_compare_inputs $in_name\n";
1801 foreach my $csumi (@files_csum_info_fields) {
1802 my ($fname) = @$csumi;
1803 printdebug "files_compare_inputs $in_name $fname\n";
1805 my $field = $in->{$fname};
1806 next unless defined $field;
1809 foreach (split /\n/, $field) {
1812 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1813 fail "could not parse $in_name $fname line \`$_'";
1815 printdebug "files_compare_inputs $in_name $fname $f\n";
1819 my $re = \ $record{$f}{$fname};
1821 $fchecked{$f}{$in_name} = 1;
1823 fail "hash or size of $f varies in $fname fields".
1824 " (between: ".$showinputs->().")";
1829 @files = sort @files;
1830 $expected_files //= \@files;
1831 "@$expected_files" eq "@files" or
1832 fail "file list in $in_name varies between hash fields!";
1835 fail "$in_name has no files list field(s)";
1837 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1840 grep { keys %$_ == @$inputs-1 } values %fchecked
1841 or fail "no file appears in all file lists".
1842 " (looked in: ".$showinputs->().")";
1845 sub is_orig_file_in_dsc ($$) {
1846 my ($f, $dsc_files_info) = @_;
1847 return 0 if @$dsc_files_info <= 1;
1848 # One file means no origs, and the filename doesn't have a "what
1849 # part of dsc" component. (Consider versions ending `.orig'.)
1850 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1854 sub is_orig_file_of_vsn ($$) {
1855 my ($f, $upstreamvsn) = @_;
1856 my $base = srcfn $upstreamvsn, '';
1857 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1861 sub changes_update_origs_from_dsc ($$$$) {
1862 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1864 printdebug "checking origs needed ($upstreamvsn)...\n";
1865 $_ = getfield $changes, 'Files';
1866 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1867 fail "cannot find section/priority from .changes Files field";
1868 my $placementinfo = $1;
1870 printdebug "checking origs needed placement '$placementinfo'...\n";
1871 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1872 $l =~ m/\S+$/ or next;
1874 printdebug "origs $file | $l\n";
1875 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1876 printdebug "origs $file is_orig\n";
1877 my $have = archive_query('file_in_archive', $file);
1878 if (!defined $have) {
1880 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1886 printdebug "origs $file \$#\$have=$#$have\n";
1887 foreach my $h (@$have) {
1890 foreach my $csumi (@files_csum_info_fields) {
1891 my ($fname, $module, $method, $archivefield) = @$csumi;
1892 next unless defined $h->{$archivefield};
1893 $_ = $dsc->{$fname};
1894 next unless defined;
1895 m/^(\w+) .* \Q$file\E$/m or
1896 fail ".dsc $fname missing entry for $file";
1897 if ($h->{$archivefield} eq $1) {
1901 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1904 die "$file ".Dumper($h)." ?!" if $same && @differ;
1907 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1910 printdebug "origs $file f.same=$found_same".
1911 " #f._differ=$#found_differ\n";
1912 if (@found_differ && !$found_same) {
1914 "archive contains $file with different checksum",
1917 # Now we edit the changes file to add or remove it
1918 foreach my $csumi (@files_csum_info_fields) {
1919 my ($fname, $module, $method, $archivefield) = @$csumi;
1920 next unless defined $changes->{$fname};
1922 # in archive, delete from .changes if it's there
1923 $changed{$file} = "removed" if
1924 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1925 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1926 # not in archive, but it's here in the .changes
1928 my $dsc_data = getfield $dsc, $fname;
1929 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1931 $extra =~ s/ \d+ /$&$placementinfo /
1932 or die "$fname $extra >$dsc_data< ?"
1933 if $fname eq 'Files';
1934 $changes->{$fname} .= "\n". $extra;
1935 $changed{$file} = "added";
1940 foreach my $file (keys %changed) {
1942 "edited .changes for archive .orig contents: %s %s",
1943 $changed{$file}, $file;
1945 my $chtmp = "$changesfile.tmp";
1946 $changes->save($chtmp);
1948 rename $chtmp,$changesfile or die "$changesfile $!";
1950 progress "[new .changes left in $changesfile]";
1953 progress "$changesfile already has appropriate .orig(s) (if any)";
1957 sub make_commit ($) {
1959 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1962 sub make_commit_text ($) {
1965 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1967 print Dumper($text) if $debuglevel > 1;
1968 my $child = open2($out, $in, @cmd) or die $!;
1971 print $in $text or die $!;
1972 close $in or die $!;
1974 $h =~ m/^\w+$/ or die;
1976 printdebug "=> $h\n";
1979 waitpid $child, 0 == $child or die "$child $!";
1980 $? and failedcmd @cmd;
1984 sub clogp_authline ($) {
1986 my $author = getfield $clogp, 'Maintainer';
1987 $author =~ s#,.*##ms;
1988 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1989 my $authline = "$author $date";
1990 $authline =~ m/$git_authline_re/o or
1991 fail "unexpected commit author line format \`$authline'".
1992 " (was generated from changelog Maintainer field)";
1993 return ($1,$2,$3) if wantarray;
1997 sub vendor_patches_distro ($$) {
1998 my ($checkdistro, $what) = @_;
1999 return unless defined $checkdistro;
2001 my $series = "debian/patches/\L$checkdistro\E.series";
2002 printdebug "checking for vendor-specific $series ($what)\n";
2004 if (!open SERIES, "<", $series) {
2005 die "$series $!" unless $!==ENOENT;
2014 Unfortunately, this source package uses a feature of dpkg-source where
2015 the same source package unpacks to different source code on different
2016 distros. dgit cannot safely operate on such packages on affected
2017 distros, because the meaning of source packages is not stable.
2019 Please ask the distro/maintainer to remove the distro-specific series
2020 files and use a different technique (if necessary, uploading actually
2021 different packages, if different distros are supposed to have
2025 fail "Found active distro-specific series file for".
2026 " $checkdistro ($what): $series, cannot continue";
2028 die "$series $!" if SERIES->error;
2032 sub check_for_vendor_patches () {
2033 # This dpkg-source feature doesn't seem to be documented anywhere!
2034 # But it can be found in the changelog (reformatted):
2036 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2037 # Author: Raphael Hertzog <hertzog@debian.org>
2038 # Date: Sun Oct 3 09:36:48 2010 +0200
2040 # dpkg-source: correctly create .pc/.quilt_series with alternate
2043 # If you have debian/patches/ubuntu.series and you were
2044 # unpacking the source package on ubuntu, quilt was still
2045 # directed to debian/patches/series instead of
2046 # debian/patches/ubuntu.series.
2048 # debian/changelog | 3 +++
2049 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2050 # 2 files changed, 6 insertions(+), 1 deletion(-)
2053 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2054 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2055 "Dpkg::Vendor \`current vendor'");
2056 vendor_patches_distro(access_basedistro(),
2057 "(base) distro being accessed");
2058 vendor_patches_distro(access_nomdistro(),
2059 "(nominal) distro being accessed");
2062 sub generate_commits_from_dsc () {
2063 # See big comment in fetch_from_archive, below.
2064 # See also README.dsc-import.
2068 my @dfi = dsc_files_info();
2069 foreach my $fi (@dfi) {
2070 my $f = $fi->{Filename};
2071 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2073 printdebug "considering linking $f: ";
2075 link_ltarget "../../../../$f", $f
2076 or ((printdebug "($!) "), 0)
2080 printdebug "linked.\n";
2082 complete_file_from_dsc('.', $fi)
2085 if (is_orig_file_in_dsc($f, \@dfi)) {
2086 link $f, "../../../../$f"
2092 # We unpack and record the orig tarballs first, so that we only
2093 # need disk space for one private copy of the unpacked source.
2094 # But we can't make them into commits until we have the metadata
2095 # from the debian/changelog, so we record the tree objects now and
2096 # make them into commits later.
2098 my $upstreamv = upstreamversion $dsc->{version};
2099 my $orig_f_base = srcfn $upstreamv, '';
2101 foreach my $fi (@dfi) {
2102 # We actually import, and record as a commit, every tarball
2103 # (unless there is only one file, in which case there seems
2106 my $f = $fi->{Filename};
2107 printdebug "import considering $f ";
2108 (printdebug "only one dfi\n"), next if @dfi == 1;
2109 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2110 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2114 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2116 printdebug "Y ", (join ' ', map { $_//"(none)" }
2117 $compr_ext, $orig_f_part
2120 my $input = new IO::File $f, '<' or die "$f $!";
2124 if (defined $compr_ext) {
2126 Dpkg::Compression::compression_guess_from_filename $f;
2127 fail "Dpkg::Compression cannot handle file $f in source package"
2128 if defined $compr_ext && !defined $cname;
2130 new Dpkg::Compression::Process compression => $cname;
2131 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2132 my $compr_fh = new IO::Handle;
2133 my $compr_pid = open $compr_fh, "-|" // die $!;
2135 open STDIN, "<&", $input or die $!;
2137 die "dgit (child): exec $compr_cmd[0]: $!\n";
2142 rmtree "_unpack-tar";
2143 mkdir "_unpack-tar" or die $!;
2144 my @tarcmd = qw(tar -x -f -
2145 --no-same-owner --no-same-permissions
2146 --no-acls --no-xattrs --no-selinux);
2147 my $tar_pid = fork // die $!;
2149 chdir "_unpack-tar" or die $!;
2150 open STDIN, "<&", $input or die $!;
2152 die "dgit (child): exec $tarcmd[0]: $!";
2154 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2155 !$? or failedcmd @tarcmd;
2158 (@compr_cmd ? failedcmd @compr_cmd
2160 # finally, we have the results in "tarball", but maybe
2161 # with the wrong permissions
2163 runcmd qw(chmod -R +rwX _unpack-tar);
2164 changedir "_unpack-tar";
2165 remove_stray_gits($f);
2166 mktree_in_ud_here();
2168 my ($tree) = git_add_write_tree();
2169 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2170 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2172 printdebug "one subtree $1\n";
2174 printdebug "multiple subtrees\n";
2177 rmtree "_unpack-tar";
2179 my $ent = [ $f, $tree ];
2181 Orig => !!$orig_f_part,
2182 Sort => (!$orig_f_part ? 2 :
2183 $orig_f_part =~ m/-/g ? 1 :
2191 # put any without "_" first (spec is not clear whether files
2192 # are always in the usual order). Tarballs without "_" are
2193 # the main orig or the debian tarball.
2194 $a->{Sort} <=> $b->{Sort} or
2198 my $any_orig = grep { $_->{Orig} } @tartrees;
2200 my $dscfn = "$package.dsc";
2202 my $treeimporthow = 'package';
2204 open D, ">", $dscfn or die "$dscfn: $!";
2205 print D $dscdata or die "$dscfn: $!";
2206 close D or die "$dscfn: $!";
2207 my @cmd = qw(dpkg-source);
2208 push @cmd, '--no-check' if $dsc_checked;
2209 if (madformat $dsc->{format}) {
2210 push @cmd, '--skip-patches';
2211 $treeimporthow = 'unpatched';
2213 push @cmd, qw(-x --), $dscfn;
2216 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2217 if (madformat $dsc->{format}) {
2218 check_for_vendor_patches();
2222 if (madformat $dsc->{format}) {
2223 my @pcmd = qw(dpkg-source --before-build .);
2224 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2226 $dappliedtree = git_add_write_tree();
2229 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2230 debugcmd "|",@clogcmd;
2231 open CLOGS, "-|", @clogcmd or die $!;
2236 printdebug "import clog search...\n";
2239 my $stanzatext = do { local $/=""; <CLOGS>; };
2240 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2241 last if !defined $stanzatext;
2243 my $desc = "package changelog, entry no.$.";
2244 open my $stanzafh, "<", \$stanzatext or die;
2245 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2246 $clogp //= $thisstanza;
2248 printdebug "import clog $thisstanza->{version} $desc...\n";
2250 last if !$any_orig; # we don't need $r1clogp
2252 # We look for the first (most recent) changelog entry whose
2253 # version number is lower than the upstream version of this
2254 # package. Then the last (least recent) previous changelog
2255 # entry is treated as the one which introduced this upstream
2256 # version and used for the synthetic commits for the upstream
2259 # One might think that a more sophisticated algorithm would be
2260 # necessary. But: we do not want to scan the whole changelog
2261 # file. Stopping when we see an earlier version, which
2262 # necessarily then is an earlier upstream version, is the only
2263 # realistic way to do that. Then, either the earliest
2264 # changelog entry we have seen so far is indeed the earliest
2265 # upload of this upstream version; or there are only changelog
2266 # entries relating to later upstream versions (which is not
2267 # possible unless the changelog and .dsc disagree about the
2268 # version). Then it remains to choose between the physically
2269 # last entry in the file, and the one with the lowest version
2270 # number. If these are not the same, we guess that the
2271 # versions were created in a non-monotic order rather than
2272 # that the changelog entries have been misordered.
2274 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2276 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2277 $r1clogp = $thisstanza;
2279 printdebug "import clog $r1clogp->{version} becomes r1\n";
2281 die $! if CLOGS->error;
2282 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2284 $clogp or fail "package changelog has no entries!";
2286 my $authline = clogp_authline $clogp;
2287 my $changes = getfield $clogp, 'Changes';
2288 my $cversion = getfield $clogp, 'Version';
2291 $r1clogp //= $clogp; # maybe there's only one entry;
2292 my $r1authline = clogp_authline $r1clogp;
2293 # Strictly, r1authline might now be wrong if it's going to be
2294 # unused because !$any_orig. Whatever.
2296 printdebug "import tartrees authline $authline\n";
2297 printdebug "import tartrees r1authline $r1authline\n";
2299 foreach my $tt (@tartrees) {
2300 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2302 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2305 committer $r1authline
2309 [dgit import orig $tt->{F}]
2317 [dgit import tarball $package $cversion $tt->{F}]
2322 printdebug "import main commit\n";
2324 open C, ">../commit.tmp" or die $!;
2325 print C <<END or die $!;
2328 print C <<END or die $! foreach @tartrees;
2331 print C <<END or die $!;
2337 [dgit import $treeimporthow $package $cversion]
2341 my $rawimport_hash = make_commit qw(../commit.tmp);
2343 if (madformat $dsc->{format}) {
2344 printdebug "import apply patches...\n";
2346 # regularise the state of the working tree so that
2347 # the checkout of $rawimport_hash works nicely.
2348 my $dappliedcommit = make_commit_text(<<END);
2355 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2357 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2359 # We need the answers to be reproducible
2360 my @authline = clogp_authline($clogp);
2361 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2362 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2363 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2364 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2365 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2366 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2368 my $path = $ENV{PATH} or die;
2370 foreach my $use_absurd (qw(0 1)) {
2371 runcmd @git, qw(checkout -q unpa);
2372 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2373 local $ENV{PATH} = $path;
2376 progress "warning: $@";
2377 $path = "$absurdity:$path";
2378 progress "$us: trying slow absurd-git-apply...";
2379 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2384 die "forbid absurd git-apply\n" if $use_absurd
2385 && forceing [qw(import-gitapply-no-absurd)];
2386 die "only absurd git-apply!\n" if !$use_absurd
2387 && forceing [qw(import-gitapply-absurd)];
2389 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2390 local $ENV{PATH} = $path if $use_absurd;
2392 my @showcmd = (gbp_pq, qw(import));
2393 my @realcmd = shell_cmd
2394 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2395 debugcmd "+",@realcmd;
2396 if (system @realcmd) {
2397 die +(shellquote @showcmd).
2399 failedcmd_waitstatus()."\n";
2402 my $gapplied = git_rev_parse('HEAD');
2403 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2404 $gappliedtree eq $dappliedtree or
2406 gbp-pq import and dpkg-source disagree!
2407 gbp-pq import gave commit $gapplied
2408 gbp-pq import gave tree $gappliedtree
2409 dpkg-source --before-build gave tree $dappliedtree
2411 $rawimport_hash = $gapplied;
2416 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2421 progress "synthesised git commit from .dsc $cversion";
2423 my $rawimport_mergeinput = {
2424 Commit => $rawimport_hash,
2425 Info => "Import of source package",
2427 my @output = ($rawimport_mergeinput);
2429 if ($lastpush_mergeinput) {
2430 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2431 my $oversion = getfield $oldclogp, 'Version';
2433 version_compare($oversion, $cversion);
2435 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2436 { Message => <<END, ReverseParents => 1 });
2437 Record $package ($cversion) in archive suite $csuite
2439 } elsif ($vcmp > 0) {
2440 print STDERR <<END or die $!;
2442 Version actually in archive: $cversion (older)
2443 Last version pushed with dgit: $oversion (newer or same)
2446 @output = $lastpush_mergeinput;
2448 # Same version. Use what's in the server git branch,
2449 # discarding our own import. (This could happen if the
2450 # server automatically imports all packages into git.)
2451 @output = $lastpush_mergeinput;
2454 changedir '../../../..';
2459 sub complete_file_from_dsc ($$) {
2460 our ($dstdir, $fi) = @_;
2461 # Ensures that we have, in $dir, the file $fi, with the correct
2462 # contents. (Downloading it from alongside $dscurl if necessary.)
2464 my $f = $fi->{Filename};
2465 my $tf = "$dstdir/$f";
2468 if (stat_exists $tf) {
2469 progress "using existing $f";
2471 printdebug "$tf does not exist, need to fetch\n";
2473 $furl =~ s{/[^/]+$}{};
2475 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2476 die "$f ?" if $f =~ m#/#;
2477 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2478 return 0 if !act_local();
2482 open F, "<", "$tf" or die "$tf: $!";
2483 $fi->{Digester}->reset();
2484 $fi->{Digester}->addfile(*F);
2485 F->error and die $!;
2486 my $got = $fi->{Digester}->hexdigest();
2487 $got eq $fi->{Hash} or
2488 fail "file $f has hash $got but .dsc".
2489 " demands hash $fi->{Hash} ".
2490 ($downloaded ? "(got wrong file from archive!)"
2491 : "(perhaps you should delete this file?)");
2496 sub ensure_we_have_orig () {
2497 my @dfi = dsc_files_info();
2498 foreach my $fi (@dfi) {
2499 my $f = $fi->{Filename};
2500 next unless is_orig_file_in_dsc($f, \@dfi);
2501 complete_file_from_dsc('..', $fi)
2506 sub git_fetch_us () {
2507 # Want to fetch only what we are going to use, unless
2508 # deliberately-not-ff, in which case we must fetch everything.
2510 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2512 (quiltmode_splitbrain
2513 ? (map { $_->('*',access_nomdistro) }
2514 \&debiantag_new, \&debiantag_maintview)
2515 : debiantags('*',access_nomdistro));
2516 push @specs, server_branch($csuite);
2517 push @specs, $rewritemap;
2518 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2520 # This is rather miserable:
2521 # When git fetch --prune is passed a fetchspec ending with a *,
2522 # it does a plausible thing. If there is no * then:
2523 # - it matches subpaths too, even if the supplied refspec
2524 # starts refs, and behaves completely madly if the source
2525 # has refs/refs/something. (See, for example, Debian #NNNN.)
2526 # - if there is no matching remote ref, it bombs out the whole
2528 # We want to fetch a fixed ref, and we don't know in advance
2529 # if it exists, so this is not suitable.
2531 # Our workaround is to use git ls-remote. git ls-remote has its
2532 # own qairks. Notably, it has the absurd multi-tail-matching
2533 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2534 # refs/refs/foo etc.
2536 # Also, we want an idempotent snapshot, but we have to make two
2537 # calls to the remote: one to git ls-remote and to git fetch. The
2538 # solution is use git ls-remote to obtain a target state, and
2539 # git fetch to try to generate it. If we don't manage to generate
2540 # the target state, we try again.
2542 printdebug "git_fetch_us specs @specs\n";
2544 my $specre = join '|', map {
2550 printdebug "git_fetch_us specre=$specre\n";
2551 my $wanted_rref = sub {
2553 return m/^(?:$specre)$/o;
2556 my $fetch_iteration = 0;
2559 printdebug "git_fetch_us iteration $fetch_iteration\n";
2560 if (++$fetch_iteration > 10) {
2561 fail "too many iterations trying to get sane fetch!";
2564 my @look = map { "refs/$_" } @specs;
2565 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2569 open GITLS, "-|", @lcmd or die $!;
2571 printdebug "=> ", $_;
2572 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2573 my ($objid,$rrefname) = ($1,$2);
2574 if (!$wanted_rref->($rrefname)) {
2576 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2580 $wantr{$rrefname} = $objid;
2583 close GITLS or failedcmd @lcmd;
2585 # OK, now %want is exactly what we want for refs in @specs
2587 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2588 "+refs/$_:".lrfetchrefs."/$_";
2591 printdebug "git_fetch_us fspecs @fspecs\n";
2593 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2594 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2597 %lrfetchrefs_f = ();
2600 git_for_each_ref(lrfetchrefs, sub {
2601 my ($objid,$objtype,$lrefname,$reftail) = @_;
2602 $lrfetchrefs_f{$lrefname} = $objid;
2603 $objgot{$objid} = 1;
2606 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2607 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2608 if (!exists $wantr{$rrefname}) {
2609 if ($wanted_rref->($rrefname)) {
2611 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2615 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2618 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2619 delete $lrfetchrefs_f{$lrefname};
2623 foreach my $rrefname (sort keys %wantr) {
2624 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2625 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2626 my $want = $wantr{$rrefname};
2627 next if $got eq $want;
2628 if (!defined $objgot{$want}) {
2630 warning: git ls-remote suggests we want $lrefname
2631 warning: and it should refer to $want
2632 warning: but git fetch didn't fetch that object to any relevant ref.
2633 warning: This may be due to a race with someone updating the server.
2634 warning: Will try again...
2636 next FETCH_ITERATION;
2639 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2641 runcmd_ordryrun_local @git, qw(update-ref -m),
2642 "dgit fetch git fetch fixup", $lrefname, $want;
2643 $lrfetchrefs_f{$lrefname} = $want;
2647 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2648 Dumper(\%lrfetchrefs_f);
2651 my @tagpats = debiantags('*',access_nomdistro);
2653 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2654 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2655 printdebug "currently $fullrefname=$objid\n";
2656 $here{$fullrefname} = $objid;
2658 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2659 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2660 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2661 printdebug "offered $lref=$objid\n";
2662 if (!defined $here{$lref}) {
2663 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2664 runcmd_ordryrun_local @upd;
2665 lrfetchref_used $fullrefname;
2666 } elsif ($here{$lref} eq $objid) {
2667 lrfetchref_used $fullrefname;
2670 "Not updateting $lref from $here{$lref} to $objid.\n";
2675 sub mergeinfo_getclogp ($) {
2676 # Ensures thit $mi->{Clogp} exists and returns it
2678 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2681 sub mergeinfo_version ($) {
2682 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2685 sub fetch_from_archive_record_1 ($) {
2687 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2688 'DGIT_ARCHIVE', $hash;
2689 cmdoutput @git, qw(log -n2), $hash;
2690 # ... gives git a chance to complain if our commit is malformed
2693 sub fetch_from_archive_record_2 ($) {
2695 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2699 dryrun_report @upd_cmd;
2703 sub fetch_from_archive () {
2704 ensure_setup_existing_tree();
2706 # Ensures that lrref() is what is actually in the archive, one way
2707 # or another, according to us - ie this client's
2708 # appropritaely-updated archive view. Also returns the commit id.
2709 # If there is nothing in the archive, leaves lrref alone and
2710 # returns undef. git_fetch_us must have already been called.
2714 foreach my $field (@ourdscfield) {
2715 $dsc_hash = $dsc->{$field};
2716 last if defined $dsc_hash;
2718 if (defined $dsc_hash) {
2719 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2721 progress "last upload to archive specified git hash";
2723 progress "last upload to archive has NO git hash";
2726 progress "no version available from the archive";
2729 my $rewritemapdata = git_cat_file lrfetchrefs."/".$rewritemap.':map';
2730 if (defined $rewritemapdata
2731 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2732 progress "server's git history rewrite map contains a relevant entry!";
2734 if (defined $dsc_hash) {
2735 progress "using rewritten git hash in place of .dsc value";
2737 progress "server data says .dsc hash is to be disregarded";
2741 # If the archive's .dsc has a Dgit field, there are three
2742 # relevant git commitids we need to choose between and/or merge
2744 # 1. $dsc_hash: the Dgit field from the archive
2745 # 2. $lastpush_hash: the suite branch on the dgit git server
2746 # 3. $lastfetch_hash: our local tracking brach for the suite
2748 # These may all be distinct and need not be in any fast forward
2751 # If the dsc was pushed to this suite, then the server suite
2752 # branch will have been updated; but it might have been pushed to
2753 # a different suite and copied by the archive. Conversely a more
2754 # recent version may have been pushed with dgit but not appeared
2755 # in the archive (yet).
2757 # $lastfetch_hash may be awkward because archive imports
2758 # (particularly, imports of Dgit-less .dscs) are performed only as
2759 # needed on individual clients, so different clients may perform a
2760 # different subset of them - and these imports are only made
2761 # public during push. So $lastfetch_hash may represent a set of
2762 # imports different to a subsequent upload by a different dgit
2765 # Our approach is as follows:
2767 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2768 # descendant of $dsc_hash, then it was pushed by a dgit user who
2769 # had based their work on $dsc_hash, so we should prefer it.
2770 # Otherwise, $dsc_hash was installed into this suite in the
2771 # archive other than by a dgit push, and (necessarily) after the
2772 # last dgit push into that suite (since a dgit push would have
2773 # been descended from the dgit server git branch); thus, in that
2774 # case, we prefer the archive's version (and produce a
2775 # pseudo-merge to overwrite the dgit server git branch).
2777 # (If there is no Dgit field in the archive's .dsc then
2778 # generate_commit_from_dsc uses the version numbers to decide
2779 # whether the suite branch or the archive is newer. If the suite
2780 # branch is newer it ignores the archive's .dsc; otherwise it
2781 # generates an import of the .dsc, and produces a pseudo-merge to
2782 # overwrite the suite branch with the archive contents.)
2784 # The outcome of that part of the algorithm is the `public view',
2785 # and is same for all dgit clients: it does not depend on any
2786 # unpublished history in the local tracking branch.
2788 # As between the public view and the local tracking branch: The
2789 # local tracking branch is only updated by dgit fetch, and
2790 # whenever dgit fetch runs it includes the public view in the
2791 # local tracking branch. Therefore if the public view is not
2792 # descended from the local tracking branch, the local tracking
2793 # branch must contain history which was imported from the archive
2794 # but never pushed; and, its tip is now out of date. So, we make
2795 # a pseudo-merge to overwrite the old imports and stitch the old
2798 # Finally: we do not necessarily reify the public view (as
2799 # described above). This is so that we do not end up stacking two
2800 # pseudo-merges. So what we actually do is figure out the inputs
2801 # to any public view pseudo-merge and put them in @mergeinputs.
2804 # $mergeinputs[]{Commit}
2805 # $mergeinputs[]{Info}
2806 # $mergeinputs[0] is the one whose tree we use
2807 # @mergeinputs is in the order we use in the actual commit)
2810 # $mergeinputs[]{Message} is a commit message to use
2811 # $mergeinputs[]{ReverseParents} if def specifies that parent
2812 # list should be in opposite order
2813 # Such an entry has no Commit or Info. It applies only when found
2814 # in the last entry. (This ugliness is to support making
2815 # identical imports to previous dgit versions.)
2817 my $lastpush_hash = git_get_ref(lrfetchref());
2818 printdebug "previous reference hash=$lastpush_hash\n";
2819 $lastpush_mergeinput = $lastpush_hash && {
2820 Commit => $lastpush_hash,
2821 Info => "dgit suite branch on dgit git server",
2824 my $lastfetch_hash = git_get_ref(lrref());
2825 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2826 my $lastfetch_mergeinput = $lastfetch_hash && {
2827 Commit => $lastfetch_hash,
2828 Info => "dgit client's archive history view",
2831 my $dsc_mergeinput = $dsc_hash && {
2832 Commit => $dsc_hash,
2833 Info => "Dgit field in .dsc from archive",
2837 my $del_lrfetchrefs = sub {
2840 printdebug "del_lrfetchrefs...\n";
2841 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2842 my $objid = $lrfetchrefs_d{$fullrefname};
2843 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2845 $gur ||= new IO::Handle;
2846 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2848 printf $gur "delete %s %s\n", $fullrefname, $objid;
2851 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2855 if (defined $dsc_hash) {
2856 ensure_we_have_orig();
2857 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2858 @mergeinputs = $dsc_mergeinput
2859 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2860 print STDERR <<END or die $!;
2862 Git commit in archive is behind the last version allegedly pushed/uploaded.
2863 Commit referred to by archive: $dsc_hash
2864 Last version pushed with dgit: $lastpush_hash
2867 @mergeinputs = ($lastpush_mergeinput);
2869 # Archive has .dsc which is not a descendant of the last dgit
2870 # push. This can happen if the archive moves .dscs about.
2871 # Just follow its lead.
2872 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2873 progress "archive .dsc names newer git commit";
2874 @mergeinputs = ($dsc_mergeinput);
2876 progress "archive .dsc names other git commit, fixing up";
2877 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2881 @mergeinputs = generate_commits_from_dsc();
2882 # We have just done an import. Now, our import algorithm might
2883 # have been improved. But even so we do not want to generate
2884 # a new different import of the same package. So if the
2885 # version numbers are the same, just use our existing version.
2886 # If the version numbers are different, the archive has changed
2887 # (perhaps, rewound).
2888 if ($lastfetch_mergeinput &&
2889 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2890 (mergeinfo_version $mergeinputs[0]) )) {
2891 @mergeinputs = ($lastfetch_mergeinput);
2893 } elsif ($lastpush_hash) {
2894 # only in git, not in the archive yet
2895 @mergeinputs = ($lastpush_mergeinput);
2896 print STDERR <<END or die $!;
2898 Package not found in the archive, but has allegedly been pushed using dgit.
2902 printdebug "nothing found!\n";
2903 if (defined $skew_warning_vsn) {
2904 print STDERR <<END or die $!;
2906 Warning: relevant archive skew detected.
2907 Archive allegedly contains $skew_warning_vsn
2908 But we were not able to obtain any version from the archive or git.
2912 unshift @end, $del_lrfetchrefs;
2916 if ($lastfetch_hash &&
2918 my $h = $_->{Commit};
2919 $h and is_fast_fwd($lastfetch_hash, $h);
2920 # If true, one of the existing parents of this commit
2921 # is a descendant of the $lastfetch_hash, so we'll
2922 # be ff from that automatically.
2926 push @mergeinputs, $lastfetch_mergeinput;
2929 printdebug "fetch mergeinfos:\n";
2930 foreach my $mi (@mergeinputs) {
2932 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2934 printdebug sprintf " ReverseParents=%d Message=%s",
2935 $mi->{ReverseParents}, $mi->{Message};
2939 my $compat_info= pop @mergeinputs
2940 if $mergeinputs[$#mergeinputs]{Message};
2942 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2945 if (@mergeinputs > 1) {
2947 my $tree_commit = $mergeinputs[0]{Commit};
2949 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2950 $tree =~ m/\n\n/; $tree = $`;
2951 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2954 # We use the changelog author of the package in question the
2955 # author of this pseudo-merge. This is (roughly) correct if
2956 # this commit is simply representing aa non-dgit upload.
2957 # (Roughly because it does not record sponsorship - but we
2958 # don't have sponsorship info because that's in the .changes,
2959 # which isn't in the archivw.)
2961 # But, it might be that we are representing archive history
2962 # updates (including in-archive copies). These are not really
2963 # the responsibility of the person who created the .dsc, but
2964 # there is no-one whose name we should better use. (The
2965 # author of the .dsc-named commit is clearly worse.)
2967 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2968 my $author = clogp_authline $useclogp;
2969 my $cversion = getfield $useclogp, 'Version';
2971 my $mcf = ".git/dgit/mergecommit";
2972 open MC, ">", $mcf or die "$mcf $!";
2973 print MC <<END or die $!;
2977 my @parents = grep { $_->{Commit} } @mergeinputs;
2978 @parents = reverse @parents if $compat_info->{ReverseParents};
2979 print MC <<END or die $! foreach @parents;
2983 print MC <<END or die $!;
2989 if (defined $compat_info->{Message}) {
2990 print MC $compat_info->{Message} or die $!;
2992 print MC <<END or die $!;
2993 Record $package ($cversion) in archive suite $csuite
2997 my $message_add_info = sub {
2999 my $mversion = mergeinfo_version $mi;
3000 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3004 $message_add_info->($mergeinputs[0]);
3005 print MC <<END or die $!;
3006 should be treated as descended from
3008 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3012 $hash = make_commit $mcf;
3014 $hash = $mergeinputs[0]{Commit};
3016 printdebug "fetch hash=$hash\n";
3019 my ($lasth, $what) = @_;
3020 return unless $lasth;
3021 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3024 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3026 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3028 fetch_from_archive_record_1($hash);
3030 if (defined $skew_warning_vsn) {
3032 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3033 my $gotclogp = commit_getclogp($hash);
3034 my $got_vsn = getfield $gotclogp, 'Version';
3035 printdebug "SKEW CHECK GOT $got_vsn\n";
3036 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3037 print STDERR <<END or die $!;
3039 Warning: archive skew detected. Using the available version:
3040 Archive allegedly contains $skew_warning_vsn
3041 We were able to obtain only $got_vsn
3047 if ($lastfetch_hash ne $hash) {
3048 fetch_from_archive_record_2($hash);
3051 lrfetchref_used lrfetchref();
3053 unshift @end, $del_lrfetchrefs;
3057 sub set_local_git_config ($$) {
3059 runcmd @git, qw(config), $k, $v;
3062 sub setup_mergechangelogs (;$) {
3064 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3066 my $driver = 'dpkg-mergechangelogs';
3067 my $cb = "merge.$driver";
3068 my $attrs = '.git/info/attributes';
3069 ensuredir '.git/info';
3071 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3072 if (!open ATTRS, "<", $attrs) {
3073 $!==ENOENT or die "$attrs: $!";
3077 next if m{^debian/changelog\s};
3078 print NATTRS $_, "\n" or die $!;
3080 ATTRS->error and die $!;
3083 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3086 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3087 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3089 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3092 sub setup_useremail (;$) {
3094 return unless $always || access_cfg_bool(1, 'setup-useremail');
3097 my ($k, $envvar) = @_;
3098 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3099 return unless defined $v;
3100 set_local_git_config "user.$k", $v;
3103 $setup->('email', 'DEBEMAIL');
3104 $setup->('name', 'DEBFULLNAME');
3107 sub ensure_setup_existing_tree () {
3108 my $k = "remote.$remotename.skipdefaultupdate";
3109 my $c = git_get_config $k;
3110 return if defined $c;
3111 set_local_git_config $k, 'true';
3114 sub setup_new_tree () {
3115 setup_mergechangelogs();
3119 sub multisuite_suite_child ($$$) {
3120 my ($tsuite, $merginputs, $fn) = @_;
3121 # in child, sets things up, calls $fn->(), and returns undef
3122 # in parent, returns canonical suite name for $tsuite
3123 my $canonsuitefh = IO::File::new_tmpfile;
3124 my $pid = fork // die $!;
3127 $us .= " [$isuite]";
3128 $debugprefix .= " ";
3129 progress "fetching $tsuite...";
3130 canonicalise_suite();
3131 print $canonsuitefh $csuite, "\n" or die $!;
3132 close $canonsuitefh or die $!;
3136 waitpid $pid,0 == $pid or die $!;
3137 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3138 seek $canonsuitefh,0,0 or die $!;
3139 local $csuite = <$canonsuitefh>;
3140 die $! unless defined $csuite && chomp $csuite;
3142 printdebug "multisuite $tsuite missing\n";
3145 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3146 push @$merginputs, {
3153 sub fork_for_multisuite ($) {
3154 my ($before_fetch_merge) = @_;
3155 # if nothing unusual, just returns ''
3158 # returns 0 to caller in child, to do first of the specified suites
3159 # in child, $csuite is not yet set
3161 # returns 1 to caller in parent, to finish up anything needed after
3162 # in parent, $csuite is set to canonicalised portmanteau
3164 my $org_isuite = $isuite;
3165 my @suites = split /\,/, $isuite;
3166 return '' unless @suites > 1;
3167 printdebug "fork_for_multisuite: @suites\n";
3171 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3173 return 0 unless defined $cbasesuite;
3175 fail "package $package missing in (base suite) $cbasesuite"
3176 unless @mergeinputs;
3178 my @csuites = ($cbasesuite);
3180 $before_fetch_merge->();
3182 foreach my $tsuite (@suites[1..$#suites]) {
3183 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3189 # xxx collecte the ref here
3191 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3192 push @csuites, $csubsuite;
3195 foreach my $mi (@mergeinputs) {
3196 my $ref = git_get_ref $mi->{Ref};
3197 die "$mi->{Ref} ?" unless length $ref;
3198 $mi->{Commit} = $ref;
3201 $csuite = join ",", @csuites;
3203 my $previous = git_get_ref lrref;
3205 unshift @mergeinputs, {
3206 Commit => $previous,
3207 Info => "local combined tracking branch",
3209 "archive seems to have rewound: local tracking branch is ahead!",
3213 foreach my $ix (0..$#mergeinputs) {
3214 $mergeinputs[$ix]{Index} = $ix;
3217 @mergeinputs = sort {
3218 -version_compare(mergeinfo_version $a,
3219 mergeinfo_version $b) # highest version first
3221 $a->{Index} <=> $b->{Index}; # earliest in spec first
3227 foreach my $mi (@mergeinputs) {
3228 printdebug "multisuite merge check $mi->{Info}\n";
3229 foreach my $previous (@needed) {
3230 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3231 printdebug "multisuite merge un-needed $previous->{Info}\n";
3235 printdebug "multisuite merge this-needed\n";
3236 $mi->{Character} = '+';
3239 $needed[0]{Character} = '*';
3241 my $output = $needed[0]{Commit};
3244 printdebug "multisuite merge nontrivial\n";
3245 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3247 my $commit = "tree $tree\n";
3248 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3249 "Input branches:\n";
3251 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3252 printdebug "multisuite merge include $mi->{Info}\n";
3253 $mi->{Character} //= ' ';
3254 $commit .= "parent $mi->{Commit}\n";
3255 $msg .= sprintf " %s %-25s %s\n",
3257 (mergeinfo_version $mi),
3260 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3262 " * marks the highest version branch, which choose to use\n".
3263 " + marks each branch which was not already an ancestor\n\n".
3264 "[dgit multi-suite $csuite]\n";
3266 "author $authline\n".
3267 "committer $authline\n\n";
3268 $output = make_commit_text $commit.$msg;
3269 printdebug "multisuite merge generated $output\n";
3272 fetch_from_archive_record_1($output);
3273 fetch_from_archive_record_2($output);
3275 progress "calculated combined tracking suite $csuite";
3280 sub clone_set_head () {
3281 open H, "> .git/HEAD" or die $!;
3282 print H "ref: ".lref()."\n" or die $!;
3285 sub clone_finish ($) {
3287 runcmd @git, qw(reset --hard), lrref();
3288 runcmd qw(bash -ec), <<'END';
3290 git ls-tree -r --name-only -z HEAD | \
3291 xargs -0r touch -h -r . --
3293 printdone "ready for work in $dstdir";
3298 badusage "dry run makes no sense with clone" unless act_local();
3300 my $multi_fetched = fork_for_multisuite(sub {
3301 printdebug "multi clone before fetch merge\n";
3304 if ($multi_fetched) {
3305 printdebug "multi clone after fetch merge\n";
3307 clone_finish($dstdir);
3310 printdebug "clone main body\n";
3312 canonicalise_suite();
3313 my $hasgit = check_for_git();
3314 mkdir $dstdir or fail "create \`$dstdir': $!";
3316 runcmd @git, qw(init -q);
3318 my $giturl = access_giturl(1);
3319 if (defined $giturl) {
3320 runcmd @git, qw(remote add), 'origin', $giturl;
3323 progress "fetching existing git history";
3325 runcmd_ordryrun_local @git, qw(fetch origin);
3327 progress "starting new git history";
3329 fetch_from_archive() or no_such_package;
3330 my $vcsgiturl = $dsc->{'Vcs-Git'};
3331 if (length $vcsgiturl) {
3332 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3333 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3336 clone_finish($dstdir);
3340 canonicalise_suite();
3341 if (check_for_git()) {
3344 fetch_from_archive() or no_such_package();
3345 printdone "fetched into ".lrref();
3349 my $multi_fetched = fork_for_multisuite(sub { });
3350 fetch() unless $multi_fetched; # parent
3351 return if $multi_fetched eq '0'; # child
3352 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3354 printdone "fetched to ".lrref()." and merged into HEAD";
3357 sub check_not_dirty () {
3358 foreach my $f (qw(local-options local-patch-header)) {
3359 if (stat_exists "debian/source/$f") {
3360 fail "git tree contains debian/source/$f";
3364 return if $ignoredirty;
3366 my @cmd = (@git, qw(diff --quiet HEAD));
3368 $!=0; $?=-1; system @cmd;
3371 fail "working tree is dirty (does not match HEAD)";
3377 sub commit_admin ($) {
3380 runcmd_ordryrun_local @git, qw(commit -m), $m;
3383 sub commit_quilty_patch () {
3384 my $output = cmdoutput @git, qw(status --porcelain);
3386 foreach my $l (split /\n/, $output) {
3387 next unless $l =~ m/\S/;
3388 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3392 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3394 progress "nothing quilty to commit, ok.";
3397 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3398 runcmd_ordryrun_local @git, qw(add -f), @adds;
3400 Commit Debian 3.0 (quilt) metadata
3402 [dgit ($our_version) quilt-fixup]
3406 sub get_source_format () {
3408 if (open F, "debian/source/options") {
3412 s/\s+$//; # ignore missing final newline
3414 my ($k, $v) = ($`, $'); #');
3415 $v =~ s/^"(.*)"$/$1/;
3421 F->error and die $!;
3424 die $! unless $!==&ENOENT;
3427 if (!open F, "debian/source/format") {
3428 die $! unless $!==&ENOENT;
3432 F->error and die $!;
3434 return ($_, \%options);
3437 sub madformat_wantfixup ($) {
3439 return 0 unless $format eq '3.0 (quilt)';
3440 our $quilt_mode_warned;
3441 if ($quilt_mode eq 'nocheck') {
3442 progress "Not doing any fixup of \`$format' due to".
3443 " ----no-quilt-fixup or --quilt=nocheck"
3444 unless $quilt_mode_warned++;
3447 progress "Format \`$format', need to check/update patch stack"
3448 unless $quilt_mode_warned++;
3452 sub maybe_split_brain_save ($$$) {
3453 my ($headref, $dgitview, $msg) = @_;
3454 # => message fragment "$saved" describing disposition of $dgitview
3455 return "commit id $dgitview" unless defined $split_brain_save;
3456 my @cmd = (shell_cmd "cd ../../../..",
3457 @git, qw(update-ref -m),
3458 "dgit --dgit-view-save $msg HEAD=$headref",
3459 $split_brain_save, $dgitview);
3461 return "and left in $split_brain_save";
3464 # An "infopair" is a tuple [ $thing, $what ]
3465 # (often $thing is a commit hash; $what is a description)
3467 sub infopair_cond_equal ($$) {
3469 $x->[0] eq $y->[0] or fail <<END;
3470 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3474 sub infopair_lrf_tag_lookup ($$) {
3475 my ($tagnames, $what) = @_;
3476 # $tagname may be an array ref
3477 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3478 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3479 foreach my $tagname (@tagnames) {
3480 my $lrefname = lrfetchrefs."/tags/$tagname";
3481 my $tagobj = $lrfetchrefs_f{$lrefname};
3482 next unless defined $tagobj;
3483 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3484 return [ git_rev_parse($tagobj), $what ];
3486 fail @tagnames==1 ? <<END : <<END;
3487 Wanted tag $what (@tagnames) on dgit server, but not found
3489 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3493 sub infopair_cond_ff ($$) {
3494 my ($anc,$desc) = @_;
3495 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3496 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3500 sub pseudomerge_version_check ($$) {
3501 my ($clogp, $archive_hash) = @_;
3503 my $arch_clogp = commit_getclogp $archive_hash;
3504 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3505 'version currently in archive' ];
3506 if (defined $overwrite_version) {
3507 if (length $overwrite_version) {
3508 infopair_cond_equal([ $overwrite_version,
3509 '--overwrite= version' ],
3512 my $v = $i_arch_v->[0];
3513 progress "Checking package changelog for archive version $v ...";
3515 my @xa = ("-f$v", "-t$v");
3516 my $vclogp = parsechangelog @xa;
3517 my $cv = [ (getfield $vclogp, 'Version'),
3518 "Version field from dpkg-parsechangelog @xa" ];
3519 infopair_cond_equal($i_arch_v, $cv);
3522 $@ =~ s/^dgit: //gm;
3524 "Perhaps debian/changelog does not mention $v ?";
3529 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3533 sub pseudomerge_make_commit ($$$$ $$) {
3534 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3535 $msg_cmd, $msg_msg) = @_;
3536 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3538 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3539 my $authline = clogp_authline $clogp;
3543 !defined $overwrite_version ? ""
3544 : !length $overwrite_version ? " --overwrite"
3545 : " --overwrite=".$overwrite_version;
3548 my $pmf = ".git/dgit/pseudomerge";
3549 open MC, ">", $pmf or die "$pmf $!";
3550 print MC <<END or die $!;
3553 parent $archive_hash
3563 return make_commit($pmf);
3566 sub splitbrain_pseudomerge ($$$$) {
3567 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3568 # => $merged_dgitview
3569 printdebug "splitbrain_pseudomerge...\n";
3571 # We: debian/PREVIOUS HEAD($maintview)
3572 # expect: o ----------------- o
3575 # a/d/PREVIOUS $dgitview
3578 # we do: `------------------ o
3582 return $dgitview unless defined $archive_hash;
3584 printdebug "splitbrain_pseudomerge...\n";
3586 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3588 if (!defined $overwrite_version) {
3589 progress "Checking that HEAD inciudes all changes in archive...";
3592 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3594 if (defined $overwrite_version) {
3596 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3597 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3598 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3599 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3600 my $i_archive = [ $archive_hash, "current archive contents" ];
3602 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3604 infopair_cond_equal($i_dgit, $i_archive);
3605 infopair_cond_ff($i_dep14, $i_dgit);
3606 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3610 $us: check failed (maybe --overwrite is needed, consult documentation)
3615 my $r = pseudomerge_make_commit
3616 $clogp, $dgitview, $archive_hash, $i_arch_v,
3617 "dgit --quilt=$quilt_mode",
3618 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3619 Declare fast forward from $i_arch_v->[0]
3621 Make fast forward from $i_arch_v->[0]
3624 maybe_split_brain_save $maintview, $r, "pseudomerge";
3626 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3630 sub plain_overwrite_pseudomerge ($$$) {
3631 my ($clogp, $head, $archive_hash) = @_;
3633 printdebug "plain_overwrite_pseudomerge...";
3635 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3637 return $head if is_fast_fwd $archive_hash, $head;
3639 my $m = "Declare fast forward from $i_arch_v->[0]";
3641 my $r = pseudomerge_make_commit
3642 $clogp, $head, $archive_hash, $i_arch_v,
3645 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3647 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3651 sub push_parse_changelog ($) {
3654 my $clogp = Dpkg::Control::Hash->new();
3655 $clogp->load($clogpfn) or die;
3657 my $clogpackage = getfield $clogp, 'Source';
3658 $package //= $clogpackage;
3659 fail "-p specified $package but changelog specified $clogpackage"
3660 unless $package eq $clogpackage;
3661 my $cversion = getfield $clogp, 'Version';
3662 my $tag = debiantag($cversion, access_nomdistro);
3663 runcmd @git, qw(check-ref-format), $tag;
3665 my $dscfn = dscfn($cversion);
3667 return ($clogp, $cversion, $dscfn);
3670 sub push_parse_dsc ($$$) {
3671 my ($dscfn,$dscfnwhat, $cversion) = @_;
3672 $dsc = parsecontrol($dscfn,$dscfnwhat);
3673 my $dversion = getfield $dsc, 'Version';
3674 my $dscpackage = getfield $dsc, 'Source';
3675 ($dscpackage eq $package && $dversion eq $cversion) or
3676 fail "$dscfn is for $dscpackage $dversion".
3677 " but debian/changelog is for $package $cversion";
3680 sub push_tagwants ($$$$) {
3681 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3684 TagFn => \&debiantag,
3689 if (defined $maintviewhead) {
3691 TagFn => \&debiantag_maintview,
3692 Objid => $maintviewhead,
3693 TfSuffix => '-maintview',
3696 } elsif ($dodep14tag eq 'no' ? 0
3697 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3698 : $dodep14tag eq 'always'
3699 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3700 --dep14tag-always (or equivalent in config) means server must support
3701 both "new" and "maint" tag formats, but config says it doesn't.
3703 : die "$dodep14tag ?") {
3705 TagFn => \&debiantag_maintview,
3707 TfSuffix => '-dgit',
3711 foreach my $tw (@tagwants) {
3712 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3713 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3715 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3719 sub push_mktags ($$ $$ $) {
3721 $changesfile,$changesfilewhat,
3724 die unless $tagwants->[0]{View} eq 'dgit';
3726 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3727 $dsc->save("$dscfn.tmp") or die $!;
3729 my $changes = parsecontrol($changesfile,$changesfilewhat);
3730 foreach my $field (qw(Source Distribution Version)) {
3731 $changes->{$field} eq $clogp->{$field} or
3732 fail "changes field $field \`$changes->{$field}'".
3733 " does not match changelog \`$clogp->{$field}'";
3736 my $cversion = getfield $clogp, 'Version';
3737 my $clogsuite = getfield $clogp, 'Distribution';
3739 # We make the git tag by hand because (a) that makes it easier
3740 # to control the "tagger" (b) we can do remote signing
3741 my $authline = clogp_authline $clogp;
3742 my $delibs = join(" ", "",@deliberatelies);
3743 my $declaredistro = access_nomdistro();
3747 my $tfn = $tw->{Tfn};
3748 my $head = $tw->{Objid};
3749 my $tag = $tw->{Tag};
3751 open TO, '>', $tfn->('.tmp') or die $!;
3752 print TO <<END or die $!;
3759 if ($tw->{View} eq 'dgit') {
3760 print TO <<END or die $!;
3761 $package release $cversion for $clogsuite ($csuite) [dgit]
3762 [dgit distro=$declaredistro$delibs]
3764 foreach my $ref (sort keys %previously) {
3765 print TO <<END or die $!;
3766 [dgit previously:$ref=$previously{$ref}]
3769 } elsif ($tw->{View} eq 'maint') {
3770 print TO <<END or die $!;
3771 $package release $cversion for $clogsuite ($csuite)
3772 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3775 die Dumper($tw)."?";
3780 my $tagobjfn = $tfn->('.tmp');
3782 if (!defined $keyid) {
3783 $keyid = access_cfg('keyid','RETURN-UNDEF');
3785 if (!defined $keyid) {
3786 $keyid = getfield $clogp, 'Maintainer';
3788 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3789 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3790 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3791 push @sign_cmd, $tfn->('.tmp');
3792 runcmd_ordryrun @sign_cmd;
3794 $tagobjfn = $tfn->('.signed.tmp');
3795 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3796 $tfn->('.tmp'), $tfn->('.tmp.asc');
3802 my @r = map { $mktag->($_); } @$tagwants;
3806 sub sign_changes ($) {
3807 my ($changesfile) = @_;
3809 my @debsign_cmd = @debsign;
3810 push @debsign_cmd, "-k$keyid" if defined $keyid;
3811 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3812 push @debsign_cmd, $changesfile;
3813 runcmd_ordryrun @debsign_cmd;
3818 printdebug "actually entering push\n";
3820 supplementary_message(<<'END');
3821 Push failed, while checking state of the archive.
3822 You can retry the push, after fixing the problem, if you like.
3824 if (check_for_git()) {
3827 my $archive_hash = fetch_from_archive();
3828 if (!$archive_hash) {
3830 fail "package appears to be new in this suite;".
3831 " if this is intentional, use --new";
3834 supplementary_message(<<'END');
3835 Push failed, while preparing your push.
3836 You can retry the push, after fixing the problem, if you like.
3839 need_tagformat 'new', "quilt mode $quilt_mode"
3840 if quiltmode_splitbrain;
3844 access_giturl(); # check that success is vaguely likely
3847 my $clogpfn = ".git/dgit/changelog.822.tmp";
3848 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3850 responder_send_file('parsed-changelog', $clogpfn);
3852 my ($clogp, $cversion, $dscfn) =
3853 push_parse_changelog("$clogpfn");
3855 my $dscpath = "$buildproductsdir/$dscfn";
3856 stat_exists $dscpath or
3857 fail "looked for .dsc $dscpath, but $!;".
3858 " maybe you forgot to build";
3860 responder_send_file('dsc', $dscpath);
3862 push_parse_dsc($dscpath, $dscfn, $cversion);
3864 my $format = getfield $dsc, 'Format';
3865 printdebug "format $format\n";
3867 my $actualhead = git_rev_parse('HEAD');
3868 my $dgithead = $actualhead;
3869 my $maintviewhead = undef;
3871 my $upstreamversion = upstreamversion $clogp->{Version};
3873 if (madformat_wantfixup($format)) {
3874 # user might have not used dgit build, so maybe do this now:
3875 if (quiltmode_splitbrain()) {
3877 quilt_make_fake_dsc($upstreamversion);
3879 ($dgithead, $cachekey) =
3880 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3882 "--quilt=$quilt_mode but no cached dgit view:
3883 perhaps tree changed since dgit build[-source] ?";
3885 $dgithead = splitbrain_pseudomerge($clogp,
3886 $actualhead, $dgithead,
3888 $maintviewhead = $actualhead;
3889 changedir '../../../..';
3890 prep_ud(); # so _only_subdir() works, below
3892 commit_quilty_patch();
3896 if (defined $overwrite_version && !defined $maintviewhead) {
3897 $dgithead = plain_overwrite_pseudomerge($clogp,
3905 if ($archive_hash) {
3906 if (is_fast_fwd($archive_hash, $dgithead)) {
3908 } elsif (deliberately_not_fast_forward) {
3911 fail "dgit push: HEAD is not a descendant".
3912 " of the archive's version.\n".
3913 "To overwrite the archive's contents,".
3914 " pass --overwrite[=VERSION].\n".
3915 "To rewind history, if permitted by the archive,".
3916 " use --deliberately-not-fast-forward.";
3921 progress "checking that $dscfn corresponds to HEAD";
3922 runcmd qw(dpkg-source -x --),
3923 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3924 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
3925 check_for_vendor_patches() if madformat($dsc->{format});
3926 changedir '../../../..';
3927 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3928 debugcmd "+",@diffcmd;
3930 my $r = system @diffcmd;
3933 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3935 HEAD specifies a different tree to $dscfn:
3937 Perhaps you forgot to build. Or perhaps there is a problem with your
3938 source tree (see dgit(7) for some hints). To see a full diff, run
3945 if (!$changesfile) {
3946 my $pat = changespat $cversion;
3947 my @cs = glob "$buildproductsdir/$pat";
3948 fail "failed to find unique changes file".
3949 " (looked for $pat in $buildproductsdir);".
3950 " perhaps you need to use dgit -C"
3952 ($changesfile) = @cs;
3954 $changesfile = "$buildproductsdir/$changesfile";
3957 # Check that changes and .dsc agree enough
3958 $changesfile =~ m{[^/]*$};
3959 my $changes = parsecontrol($changesfile,$&);
3960 files_compare_inputs($dsc, $changes)
3961 unless forceing [qw(dsc-changes-mismatch)];
3963 # Perhaps adjust .dsc to contain right set of origs
3964 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3966 unless forceing [qw(changes-origs-exactly)];
3968 # Checks complete, we're going to try and go ahead:
3970 responder_send_file('changes',$changesfile);
3971 responder_send_command("param head $dgithead");
3972 responder_send_command("param csuite $csuite");
3973 responder_send_command("param tagformat $tagformat");
3974 if (defined $maintviewhead) {
3975 die unless ($protovsn//4) >= 4;
3976 responder_send_command("param maint-view $maintviewhead");
3979 if (deliberately_not_fast_forward) {
3980 git_for_each_ref(lrfetchrefs, sub {
3981 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3982 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3983 responder_send_command("previously $rrefname=$objid");
3984 $previously{$rrefname} = $objid;
3988 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3992 supplementary_message(<<'END');
3993 Push failed, while signing the tag.
3994 You can retry the push, after fixing the problem, if you like.
3996 # If we manage to sign but fail to record it anywhere, it's fine.
3997 if ($we_are_responder) {
3998 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3999 responder_receive_files('signed-tag', @tagobjfns);
4001 @tagobjfns = push_mktags($clogp,$dscpath,
4002 $changesfile,$changesfile,
4005 supplementary_message(<<'END');
4006 Push failed, *after* signing the tag.
4007 If you want to try again, you should use a new version number.
4010 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4012 foreach my $tw (@tagwants) {
4013 my $tag = $tw->{Tag};
4014 my $tagobjfn = $tw->{TagObjFn};
4016 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4017 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4018 runcmd_ordryrun_local
4019 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4022 supplementary_message(<<'END');
4023 Push failed, while updating the remote git repository - see messages above.
4024 If you want to try again, you should use a new version number.
4026 if (!check_for_git()) {
4027 create_remote_git_repo();
4030 my @pushrefs = $forceflag.$dgithead.":".rrref();
4031 foreach my $tw (@tagwants) {
4032 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4035 runcmd_ordryrun @git,
4036 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4037 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4039 supplementary_message(<<'END');
4040 Push failed, while obtaining signatures on the .changes and .dsc.
4041 If it was just that the signature failed, you may try again by using
4042 debsign by hand to sign the changes
4044 and then dput to complete the upload.
4045 If you need to change the package, you must use a new version number.
4047 if ($we_are_responder) {
4048 my $dryrunsuffix = act_local() ? "" : ".tmp";
4049 responder_receive_files('signed-dsc-changes',
4050 "$dscpath$dryrunsuffix",
4051 "$changesfile$dryrunsuffix");
4054 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4056 progress "[new .dsc left in $dscpath.tmp]";
4058 sign_changes $changesfile;
4061 supplementary_message(<<END);
4062 Push failed, while uploading package(s) to the archive server.
4063 You can retry the upload of exactly these same files with dput of:
4065 If that .changes file is broken, you will need to use a new version
4066 number for your next attempt at the upload.
4068 my $host = access_cfg('upload-host','RETURN-UNDEF');
4069 my @hostarg = defined($host) ? ($host,) : ();
4070 runcmd_ordryrun @dput, @hostarg, $changesfile;
4071 printdone "pushed and uploaded $cversion";
4073 supplementary_message('');
4074 responder_send_command("complete");
4081 badusage "-p is not allowed with clone; specify as argument instead"
4082 if defined $package;
4085 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4086 ($package,$isuite) = @ARGV;
4087 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4088 ($package,$dstdir) = @ARGV;
4089 } elsif (@ARGV==3) {
4090 ($package,$isuite,$dstdir) = @ARGV;
4092 badusage "incorrect arguments to dgit clone";
4094 $dstdir ||= "$package";
4096 if (stat_exists $dstdir) {
4097 fail "$dstdir already exists";
4101 if ($rmonerror && !$dryrun_level) {
4102 $cwd_remove= getcwd();
4104 return unless defined $cwd_remove;
4105 if (!chdir "$cwd_remove") {
4106 return if $!==&ENOENT;
4107 die "chdir $cwd_remove: $!";
4109 printdebug "clone rmonerror removing $dstdir\n";
4111 rmtree($dstdir) or die "remove $dstdir: $!\n";
4112 } elsif (grep { $! == $_ }
4113 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4115 print STDERR "check whether to remove $dstdir: $!\n";
4121 $cwd_remove = undef;
4124 sub branchsuite () {
4125 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4126 if ($branch =~ m#$lbranch_re#o) {
4133 sub fetchpullargs () {
4135 if (!defined $package) {
4136 my $sourcep = parsecontrol('debian/control','debian/control');
4137 $package = getfield $sourcep, 'Source';
4140 $isuite = branchsuite();
4142 my $clogp = parsechangelog();
4143 $isuite = getfield $clogp, 'Distribution';
4145 } elsif (@ARGV==1) {
4148 badusage "incorrect arguments to dgit fetch or dgit pull";
4155 my $multi_fetched = fork_for_multisuite(sub { });
4156 exit 0 if $multi_fetched;
4163 if (quiltmode_splitbrain()) {
4164 my ($format, $fopts) = get_source_format();
4165 madformat($format) and fail <<END
4166 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4175 badusage "-p is not allowed with dgit push" if defined $package;
4177 my $clogp = parsechangelog();
4178 $package = getfield $clogp, 'Source';
4181 } elsif (@ARGV==1) {
4182 ($specsuite) = (@ARGV);
4184 badusage "incorrect arguments to dgit push";
4186 $isuite = getfield $clogp, 'Distribution';
4188 local ($package) = $existing_package; # this is a hack
4189 canonicalise_suite();
4191 canonicalise_suite();
4193 if (defined $specsuite &&
4194 $specsuite ne $isuite &&
4195 $specsuite ne $csuite) {
4196 fail "dgit push: changelog specifies $isuite ($csuite)".
4197 " but command line specifies $specsuite";
4202 #---------- remote commands' implementation ----------
4204 sub cmd_remote_push_build_host {
4205 my ($nrargs) = shift @ARGV;
4206 my (@rargs) = @ARGV[0..$nrargs-1];
4207 @ARGV = @ARGV[$nrargs..$#ARGV];
4209 my ($dir,$vsnwant) = @rargs;
4210 # vsnwant is a comma-separated list; we report which we have
4211 # chosen in our ready response (so other end can tell if they
4214 $we_are_responder = 1;
4215 $us .= " (build host)";
4219 open PI, "<&STDIN" or die $!;
4220 open STDIN, "/dev/null" or die $!;
4221 open PO, ">&STDOUT" or die $!;
4223 open STDOUT, ">&STDERR" or die $!;
4227 ($protovsn) = grep {
4228 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4229 } @rpushprotovsn_support;
4231 fail "build host has dgit rpush protocol versions ".
4232 (join ",", @rpushprotovsn_support).
4233 " but invocation host has $vsnwant"
4234 unless defined $protovsn;
4236 responder_send_command("dgit-remote-push-ready $protovsn");
4237 rpush_handle_protovsn_bothends();
4242 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4243 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4244 # a good error message)
4246 sub rpush_handle_protovsn_bothends () {
4247 if ($protovsn < 4) {
4248 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4257 my $report = i_child_report();
4258 if (defined $report) {
4259 printdebug "($report)\n";
4260 } elsif ($i_child_pid) {
4261 printdebug "(killing build host child $i_child_pid)\n";
4262 kill 15, $i_child_pid;
4264 if (defined $i_tmp && !defined $initiator_tempdir) {
4266 eval { rmtree $i_tmp; };
4270 END { i_cleanup(); }
4273 my ($base,$selector,@args) = @_;
4274 $selector =~ s/\-/_/g;
4275 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4282 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4290 push @rargs, join ",", @rpushprotovsn_support;
4293 push @rdgit, @ropts;
4294 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4296 my @cmd = (@ssh, $host, shellquote @rdgit);
4299 if (defined $initiator_tempdir) {
4300 rmtree $initiator_tempdir;
4301 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4302 $i_tmp = $initiator_tempdir;
4306 $i_child_pid = open2(\*RO, \*RI, @cmd);
4308 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4309 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4310 $supplementary_message = '' unless $protovsn >= 3;
4312 fail "rpush negotiated protocol version $protovsn".
4313 " which does not support quilt mode $quilt_mode"
4314 if quiltmode_splitbrain;
4316 rpush_handle_protovsn_bothends();
4318 my ($icmd,$iargs) = initiator_expect {
4319 m/^(\S+)(?: (.*))?$/;
4322 i_method "i_resp", $icmd, $iargs;
4326 sub i_resp_progress ($) {
4328 my $msg = protocol_read_bytes \*RO, $rhs;
4332 sub i_resp_supplementary_message ($) {
4334 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4337 sub i_resp_complete {
4338 my $pid = $i_child_pid;
4339 $i_child_pid = undef; # prevents killing some other process with same pid
4340 printdebug "waiting for build host child $pid...\n";
4341 my $got = waitpid $pid, 0;
4342 die $! unless $got == $pid;
4343 die "build host child failed $?" if $?;
4346 printdebug "all done\n";
4350 sub i_resp_file ($) {
4352 my $localname = i_method "i_localname", $keyword;
4353 my $localpath = "$i_tmp/$localname";
4354 stat_exists $localpath and
4355 badproto \*RO, "file $keyword ($localpath) twice";
4356 protocol_receive_file \*RO, $localpath;
4357 i_method "i_file", $keyword;
4362 sub i_resp_param ($) {
4363 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4367 sub i_resp_previously ($) {
4368 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4369 or badproto \*RO, "bad previously spec";
4370 my $r = system qw(git check-ref-format), $1;
4371 die "bad previously ref spec ($r)" if $r;
4372 $previously{$1} = $2;
4377 sub i_resp_want ($) {
4379 die "$keyword ?" if $i_wanted{$keyword}++;
4380 my @localpaths = i_method "i_want", $keyword;
4381 printdebug "[[ $keyword @localpaths\n";
4382 foreach my $localpath (@localpaths) {
4383 protocol_send_file \*RI, $localpath;
4385 print RI "files-end\n" or die $!;
4388 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4390 sub i_localname_parsed_changelog {
4391 return "remote-changelog.822";
4393 sub i_file_parsed_changelog {
4394 ($i_clogp, $i_version, $i_dscfn) =
4395 push_parse_changelog "$i_tmp/remote-changelog.822";
4396 die if $i_dscfn =~ m#/|^\W#;
4399 sub i_localname_dsc {
4400 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4405 sub i_localname_changes {
4406 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4407 $i_changesfn = $i_dscfn;
4408 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4409 return $i_changesfn;
4411 sub i_file_changes { }
4413 sub i_want_signed_tag {
4414 printdebug Dumper(\%i_param, $i_dscfn);
4415 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4416 && defined $i_param{'csuite'}
4417 or badproto \*RO, "premature desire for signed-tag";
4418 my $head = $i_param{'head'};
4419 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4421 my $maintview = $i_param{'maint-view'};
4422 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4425 if ($protovsn >= 4) {
4426 my $p = $i_param{'tagformat'} // '<undef>';
4428 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4431 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4433 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4435 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4438 push_mktags $i_clogp, $i_dscfn,
4439 $i_changesfn, 'remote changes',
4443 sub i_want_signed_dsc_changes {
4444 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4445 sign_changes $i_changesfn;
4446 return ($i_dscfn, $i_changesfn);
4449 #---------- building etc. ----------
4455 #----- `3.0 (quilt)' handling -----
4457 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4459 sub quiltify_dpkg_commit ($$$;$) {
4460 my ($patchname,$author,$msg, $xinfo) = @_;
4464 my $descfn = ".git/dgit/quilt-description.tmp";
4465 open O, '>', $descfn or die "$descfn: $!";
4466 $msg =~ s/\n+/\n\n/;
4467 print O <<END or die $!;
4469 ${xinfo}Subject: $msg
4476 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4477 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4478 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4479 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4483 sub quiltify_trees_differ ($$;$$$) {
4484 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4485 # returns true iff the two tree objects differ other than in debian/
4486 # with $finegrained,
4487 # returns bitmask 01 - differ in upstream files except .gitignore
4488 # 02 - differ in .gitignore
4489 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4490 # is set for each modified .gitignore filename $fn
4491 # if $unrepres is defined, array ref to which is appeneded
4492 # a list of unrepresentable changes (removals of upstream files
4495 my @cmd = (@git, qw(diff-tree -z));
4496 push @cmd, qw(--name-only) unless $unrepres;
4497 push @cmd, qw(-r) if $finegrained || $unrepres;
4499 my $diffs= cmdoutput @cmd;
4502 foreach my $f (split /\0/, $diffs) {
4503 if ($unrepres && !@lmodes) {
4504 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4507 my ($oldmode,$newmode) = @lmodes;
4510 next if $f =~ m#^debian(?:/.*)?$#s;
4514 die "not a plain file\n"
4515 unless $newmode =~ m/^10\d{4}$/ ||
4516 $oldmode =~ m/^10\d{4}$/;
4517 if ($oldmode =~ m/[^0]/ &&
4518 $newmode =~ m/[^0]/) {
4519 die "mode changed\n" if $oldmode ne $newmode;
4521 die "non-default mode\n"
4522 unless $newmode =~ m/^100644$/ ||
4523 $oldmode =~ m/^100644$/;
4527 local $/="\n"; chomp $@;
4528 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4532 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4533 $r |= $isignore ? 02 : 01;
4534 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4536 printdebug "quiltify_trees_differ $x $y => $r\n";
4540 sub quiltify_tree_sentinelfiles ($) {
4541 # lists the `sentinel' files present in the tree
4543 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4544 qw(-- debian/rules debian/control);
4549 sub quiltify_splitbrain_needed () {
4550 if (!$split_brain) {
4551 progress "dgit view: changes are required...";
4552 runcmd @git, qw(checkout -q -b dgit-view);
4557 sub quiltify_splitbrain ($$$$$$) {
4558 my ($clogp, $unapplied, $headref, $diffbits,
4559 $editedignores, $cachekey) = @_;
4560 if ($quilt_mode !~ m/gbp|dpm/) {
4561 # treat .gitignore just like any other upstream file
4562 $diffbits = { %$diffbits };
4563 $_ = !!$_ foreach values %$diffbits;
4565 # We would like any commits we generate to be reproducible
4566 my @authline = clogp_authline($clogp);
4567 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4568 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4569 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4570 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4571 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4572 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4574 if ($quilt_mode =~ m/gbp|unapplied/ &&
4575 ($diffbits->{O2H} & 01)) {
4577 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4578 " but git tree differs from orig in upstream files.";
4579 if (!stat_exists "debian/patches") {
4581 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4585 if ($quilt_mode =~ m/dpm/ &&
4586 ($diffbits->{H2A} & 01)) {
4588 --quilt=$quilt_mode specified, implying patches-applied git tree
4589 but git tree differs from result of applying debian/patches to upstream
4592 if ($quilt_mode =~ m/gbp|unapplied/ &&
4593 ($diffbits->{O2A} & 01)) { # some patches
4594 quiltify_splitbrain_needed();
4595 progress "dgit view: creating patches-applied version using gbp pq";
4596 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4597 # gbp pq import creates a fresh branch; push back to dgit-view
4598 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4599 runcmd @git, qw(checkout -q dgit-view);
4601 if ($quilt_mode =~ m/gbp|dpm/ &&
4602 ($diffbits->{O2A} & 02)) {
4604 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4605 tool which does not create patches for changes to upstream
4606 .gitignores: but, such patches exist in debian/patches.
4609 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4610 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4611 quiltify_splitbrain_needed();
4612 progress "dgit view: creating patch to represent .gitignore changes";
4613 ensuredir "debian/patches";
4614 my $gipatch = "debian/patches/auto-gitignore";
4615 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4616 stat GIPATCH or die "$gipatch: $!";
4617 fail "$gipatch already exists; but want to create it".
4618 " to record .gitignore changes" if (stat _)[7];
4619 print GIPATCH <<END or die "$gipatch: $!";
4620 Subject: Update .gitignore from Debian packaging branch
4622 The Debian packaging git branch contains these updates to the upstream
4623 .gitignore file(s). This patch is autogenerated, to provide these
4624 updates to users of the official Debian archive view of the package.
4626 [dgit ($our_version) update-gitignore]
4629 close GIPATCH or die "$gipatch: $!";
4630 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4631 $unapplied, $headref, "--", sort keys %$editedignores;
4632 open SERIES, "+>>", "debian/patches/series" or die $!;
4633 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4635 defined read SERIES, $newline, 1 or die $!;
4636 print SERIES "\n" or die $! unless $newline eq "\n";
4637 print SERIES "auto-gitignore\n" or die $!;
4638 close SERIES or die $!;
4639 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4641 Commit patch to update .gitignore
4643 [dgit ($our_version) update-gitignore-quilt-fixup]
4647 my $dgitview = git_rev_parse 'HEAD';
4649 changedir '../../../..';
4650 # When we no longer need to support squeeze, use --create-reflog
4652 ensuredir ".git/logs/refs/dgit-intern";
4653 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4656 my $oldcache = git_get_ref "refs/$splitbraincache";
4657 if ($oldcache eq $dgitview) {
4658 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4659 # git update-ref doesn't always update, in this case. *sigh*
4660 my $dummy = make_commit_text <<END;
4663 author Dgit <dgit\@example.com> 1000000000 +0000
4664 committer Dgit <dgit\@example.com> 1000000000 +0000
4666 Dummy commit - do not use
4668 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4669 "refs/$splitbraincache", $dummy;
4671 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4674 changedir '.git/dgit/unpack/work';
4676 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4677 progress "dgit view: created ($saved)";
4680 sub quiltify ($$$$) {
4681 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4683 # Quilt patchification algorithm
4685 # We search backwards through the history of the main tree's HEAD
4686 # (T) looking for a start commit S whose tree object is identical
4687 # to to the patch tip tree (ie the tree corresponding to the
4688 # current dpkg-committed patch series). For these purposes
4689 # `identical' disregards anything in debian/ - this wrinkle is
4690 # necessary because dpkg-source treates debian/ specially.
4692 # We can only traverse edges where at most one of the ancestors'
4693 # trees differs (in changes outside in debian/). And we cannot
4694 # handle edges which change .pc/ or debian/patches. To avoid
4695 # going down a rathole we avoid traversing edges which introduce
4696 # debian/rules or debian/control. And we set a limit on the
4697 # number of edges we are willing to look at.
4699 # If we succeed, we walk forwards again. For each traversed edge
4700 # PC (with P parent, C child) (starting with P=S and ending with
4701 # C=T) to we do this:
4703 # - dpkg-source --commit with a patch name and message derived from C
4704 # After traversing PT, we git commit the changes which
4705 # should be contained within debian/patches.
4707 # The search for the path S..T is breadth-first. We maintain a
4708 # todo list containing search nodes. A search node identifies a
4709 # commit, and looks something like this:
4711 # Commit => $git_commit_id,
4712 # Child => $c, # or undef if P=T
4713 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4714 # Nontrivial => true iff $p..$c has relevant changes
4721 my %considered; # saves being exponential on some weird graphs
4723 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4726 my ($search,$whynot) = @_;
4727 printdebug " search NOT $search->{Commit} $whynot\n";
4728 $search->{Whynot} = $whynot;
4729 push @nots, $search;
4730 no warnings qw(exiting);
4739 my $c = shift @todo;
4740 next if $considered{$c->{Commit}}++;
4742 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4744 printdebug "quiltify investigate $c->{Commit}\n";
4747 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4748 printdebug " search finished hooray!\n";
4753 if ($quilt_mode eq 'nofix') {
4754 fail "quilt fixup required but quilt mode is \`nofix'\n".
4755 "HEAD commit $c->{Commit} differs from tree implied by ".
4756 " debian/patches (tree object $oldtiptree)";
4758 if ($quilt_mode eq 'smash') {
4759 printdebug " search quitting smash\n";
4763 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4764 $not->($c, "has $c_sentinels not $t_sentinels")
4765 if $c_sentinels ne $t_sentinels;
4767 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4768 $commitdata =~ m/\n\n/;
4770 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4771 @parents = map { { Commit => $_, Child => $c } } @parents;
4773 $not->($c, "root commit") if !@parents;
4775 foreach my $p (@parents) {
4776 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4778 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4779 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4781 foreach my $p (@parents) {
4782 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4784 my @cmd= (@git, qw(diff-tree -r --name-only),
4785 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4786 my $patchstackchange = cmdoutput @cmd;
4787 if (length $patchstackchange) {
4788 $patchstackchange =~ s/\n/,/g;
4789 $not->($p, "changed $patchstackchange");
4792 printdebug " search queue P=$p->{Commit} ",
4793 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4799 printdebug "quiltify want to smash\n";
4802 my $x = $_[0]{Commit};
4803 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4806 my $reportnot = sub {
4808 my $s = $abbrev->($notp);
4809 my $c = $notp->{Child};
4810 $s .= "..".$abbrev->($c) if $c;
4811 $s .= ": ".$notp->{Whynot};
4814 if ($quilt_mode eq 'linear') {
4815 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4816 foreach my $notp (@nots) {
4817 print STDERR "$us: ", $reportnot->($notp), "\n";
4819 print STDERR "$us: $_\n" foreach @$failsuggestion;
4820 fail "quilt fixup naive history linearisation failed.\n".
4821 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4822 } elsif ($quilt_mode eq 'smash') {
4823 } elsif ($quilt_mode eq 'auto') {
4824 progress "quilt fixup cannot be linear, smashing...";
4826 die "$quilt_mode ?";
4829 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4830 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4832 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4834 quiltify_dpkg_commit "auto-$version-$target-$time",
4835 (getfield $clogp, 'Maintainer'),
4836 "Automatically generated patch ($clogp->{Version})\n".
4837 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4841 progress "quiltify linearisation planning successful, executing...";
4843 for (my $p = $sref_S;
4844 my $c = $p->{Child};
4846 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4847 next unless $p->{Nontrivial};
4849 my $cc = $c->{Commit};
4851 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4852 $commitdata =~ m/\n\n/ or die "$c ?";
4855 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4858 my $commitdate = cmdoutput
4859 @git, qw(log -n1 --pretty=format:%aD), $cc;
4861 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4863 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4870 my $gbp_check_suitable = sub {
4875 die "contains unexpected slashes\n" if m{//} || m{/$};
4876 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4877 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4878 die "too long" if length > 200;
4880 return $_ unless $@;
4881 print STDERR "quiltifying commit $cc:".
4882 " ignoring/dropping Gbp-Pq $what: $@";
4886 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4888 (\S+) \s* \n //ixm) {
4889 $patchname = $gbp_check_suitable->($1, 'Name');
4891 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4893 (\S+) \s* \n //ixm) {
4894 $patchdir = $gbp_check_suitable->($1, 'Topic');
4899 if (!defined $patchname) {
4900 $patchname = $title;
4901 $patchname =~ s/[.:]$//;
4904 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4905 my $translitname = $converter->convert($patchname);
4906 die unless defined $translitname;
4907 $patchname = $translitname;
4910 "dgit: patch title transliteration error: $@"
4912 $patchname =~ y/ A-Z/-a-z/;
4913 $patchname =~ y/-a-z0-9_.+=~//cd;
4914 $patchname =~ s/^\W/x-$&/;
4915 $patchname = substr($patchname,0,40);
4917 if (!defined $patchdir) {
4920 if (length $patchdir) {
4921 $patchname = "$patchdir/$patchname";
4923 if ($patchname =~ m{^(.*)/}) {
4924 mkpath "debian/patches/$1";
4929 stat "debian/patches/$patchname$index";
4931 $!==ENOENT or die "$patchname$index $!";
4933 runcmd @git, qw(checkout -q), $cc;
4935 # We use the tip's changelog so that dpkg-source doesn't
4936 # produce complaining messages from dpkg-parsechangelog. None
4937 # of the information dpkg-source gets from the changelog is
4938 # actually relevant - it gets put into the original message
4939 # which dpkg-source provides our stunt editor, and then
4941 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4943 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4944 "Date: $commitdate\n".
4945 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4947 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4950 runcmd @git, qw(checkout -q master);
4953 sub build_maybe_quilt_fixup () {
4954 my ($format,$fopts) = get_source_format;
4955 return unless madformat_wantfixup $format;
4958 check_for_vendor_patches();
4960 if (quiltmode_splitbrain) {
4961 fail <<END unless access_cfg_tagformats_can_splitbrain;
4962 quilt mode $quilt_mode requires split view so server needs to support
4963 both "new" and "maint" tag formats, but config says it doesn't.
4967 my $clogp = parsechangelog();
4968 my $headref = git_rev_parse('HEAD');
4973 my $upstreamversion = upstreamversion $version;
4975 if ($fopts->{'single-debian-patch'}) {
4976 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4978 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4981 die 'bug' if $split_brain && !$need_split_build_invocation;
4983 changedir '../../../..';
4984 runcmd_ordryrun_local
4985 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4988 sub quilt_fixup_mkwork ($) {
4991 mkdir "work" or die $!;
4993 mktree_in_ud_here();
4994 runcmd @git, qw(reset -q --hard), $headref;
4997 sub quilt_fixup_linkorigs ($$) {
4998 my ($upstreamversion, $fn) = @_;
4999 # calls $fn->($leafname);
5001 foreach my $f (<../../../../*>) { #/){
5002 my $b=$f; $b =~ s{.*/}{};
5004 local ($debuglevel) = $debuglevel-1;
5005 printdebug "QF linkorigs $b, $f ?\n";
5007 next unless is_orig_file_of_vsn $b, $upstreamversion;
5008 printdebug "QF linkorigs $b, $f Y\n";
5009 link_ltarget $f, $b or die "$b $!";
5014 sub quilt_fixup_delete_pc () {
5015 runcmd @git, qw(rm -rqf .pc);
5017 Commit removal of .pc (quilt series tracking data)
5019 [dgit ($our_version) upgrade quilt-remove-pc]
5023 sub quilt_fixup_singlepatch ($$$) {
5024 my ($clogp, $headref, $upstreamversion) = @_;
5026 progress "starting quiltify (single-debian-patch)";
5028 # dpkg-source --commit generates new patches even if
5029 # single-debian-patch is in debian/source/options. In order to
5030 # get it to generate debian/patches/debian-changes, it is
5031 # necessary to build the source package.
5033 quilt_fixup_linkorigs($upstreamversion, sub { });
5034 quilt_fixup_mkwork($headref);
5036 rmtree("debian/patches");
5038 runcmd @dpkgsource, qw(-b .);
5040 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5041 rename srcfn("$upstreamversion", "/debian/patches"),
5042 "work/debian/patches";
5045 commit_quilty_patch();
5048 sub quilt_make_fake_dsc ($) {
5049 my ($upstreamversion) = @_;
5051 my $fakeversion="$upstreamversion-~~DGITFAKE";
5053 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5054 print $fakedsc <<END or die $!;
5057 Version: $fakeversion
5061 my $dscaddfile=sub {
5064 my $md = new Digest::MD5;
5066 my $fh = new IO::File $b, '<' or die "$b $!";
5071 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5074 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5076 my @files=qw(debian/source/format debian/rules
5077 debian/control debian/changelog);
5078 foreach my $maybe (qw(debian/patches debian/source/options
5079 debian/tests/control)) {
5080 next unless stat_exists "../../../$maybe";
5081 push @files, $maybe;
5084 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5085 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5087 $dscaddfile->($debtar);
5088 close $fakedsc or die $!;
5091 sub quilt_check_splitbrain_cache ($$) {
5092 my ($headref, $upstreamversion) = @_;
5093 # Called only if we are in (potentially) split brain mode.
5095 # Computes the cache key and looks in the cache.
5096 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5098 my $splitbrain_cachekey;
5101 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5102 # we look in the reflog of dgit-intern/quilt-cache
5103 # we look for an entry whose message is the key for the cache lookup
5104 my @cachekey = (qw(dgit), $our_version);
5105 push @cachekey, $upstreamversion;
5106 push @cachekey, $quilt_mode;
5107 push @cachekey, $headref;
5109 push @cachekey, hashfile('fake.dsc');
5111 my $srcshash = Digest::SHA->new(256);
5112 my %sfs = ( %INC, '$0(dgit)' => $0 );
5113 foreach my $sfk (sort keys %sfs) {
5114 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5115 $srcshash->add($sfk," ");
5116 $srcshash->add(hashfile($sfs{$sfk}));
5117 $srcshash->add("\n");
5119 push @cachekey, $srcshash->hexdigest();
5120 $splitbrain_cachekey = "@cachekey";
5122 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5124 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5125 debugcmd "|(probably)",@cmd;
5126 my $child = open GC, "-|"; defined $child or die $!;
5128 chdir '../../..' or die $!;
5129 if (!stat ".git/logs/refs/$splitbraincache") {
5130 $! == ENOENT or die $!;
5131 printdebug ">(no reflog)\n";
5138 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5139 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5142 quilt_fixup_mkwork($headref);
5143 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5144 if ($cachehit ne $headref) {
5145 progress "dgit view: found cached ($saved)";
5146 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5148 return ($cachehit, $splitbrain_cachekey);
5150 progress "dgit view: found cached, no changes required";
5151 return ($headref, $splitbrain_cachekey);
5153 die $! if GC->error;
5154 failedcmd unless close GC;
5156 printdebug "splitbrain cache miss\n";
5157 return (undef, $splitbrain_cachekey);
5160 sub quilt_fixup_multipatch ($$$) {
5161 my ($clogp, $headref, $upstreamversion) = @_;
5163 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5166 # - honour any existing .pc in case it has any strangeness
5167 # - determine the git commit corresponding to the tip of
5168 # the patch stack (if there is one)
5169 # - if there is such a git commit, convert each subsequent
5170 # git commit into a quilt patch with dpkg-source --commit
5171 # - otherwise convert all the differences in the tree into
5172 # a single git commit
5176 # Our git tree doesn't necessarily contain .pc. (Some versions of
5177 # dgit would include the .pc in the git tree.) If there isn't
5178 # one, we need to generate one by unpacking the patches that we
5181 # We first look for a .pc in the git tree. If there is one, we
5182 # will use it. (This is not the normal case.)
5184 # Otherwise need to regenerate .pc so that dpkg-source --commit
5185 # can work. We do this as follows:
5186 # 1. Collect all relevant .orig from parent directory
5187 # 2. Generate a debian.tar.gz out of
5188 # debian/{patches,rules,source/format,source/options}
5189 # 3. Generate a fake .dsc containing just these fields:
5190 # Format Source Version Files
5191 # 4. Extract the fake .dsc
5192 # Now the fake .dsc has a .pc directory.
5193 # (In fact we do this in every case, because in future we will
5194 # want to search for a good base commit for generating patches.)
5196 # Then we can actually do the dpkg-source --commit
5197 # 1. Make a new working tree with the same object
5198 # store as our main tree and check out the main
5200 # 2. Copy .pc from the fake's extraction, if necessary
5201 # 3. Run dpkg-source --commit
5202 # 4. If the result has changes to debian/, then
5203 # - git add them them
5204 # - git add .pc if we had a .pc in-tree
5206 # 5. If we had a .pc in-tree, delete it, and git commit
5207 # 6. Back in the main tree, fast forward to the new HEAD
5209 # Another situation we may have to cope with is gbp-style
5210 # patches-unapplied trees.
5212 # We would want to detect these, so we know to escape into
5213 # quilt_fixup_gbp. However, this is in general not possible.
5214 # Consider a package with a one patch which the dgit user reverts
5215 # (with git revert or the moral equivalent).
5217 # That is indistinguishable in contents from a patches-unapplied
5218 # tree. And looking at the history to distinguish them is not
5219 # useful because the user might have made a confusing-looking git
5220 # history structure (which ought to produce an error if dgit can't
5221 # cope, not a silent reintroduction of an unwanted patch).
5223 # So gbp users will have to pass an option. But we can usually
5224 # detect their failure to do so: if the tree is not a clean
5225 # patches-applied tree, quilt linearisation fails, but the tree
5226 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5227 # they want --quilt=unapplied.
5229 # To help detect this, when we are extracting the fake dsc, we
5230 # first extract it with --skip-patches, and then apply the patches
5231 # afterwards with dpkg-source --before-build. That lets us save a
5232 # tree object corresponding to .origs.
5234 my $splitbrain_cachekey;
5236 quilt_make_fake_dsc($upstreamversion);
5238 if (quiltmode_splitbrain()) {
5240 ($cachehit, $splitbrain_cachekey) =
5241 quilt_check_splitbrain_cache($headref, $upstreamversion);
5242 return if $cachehit;
5246 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5248 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5249 rename $fakexdir, "fake" or die "$fakexdir $!";
5253 remove_stray_gits("source package");
5254 mktree_in_ud_here();
5258 my $unapplied=git_add_write_tree();
5259 printdebug "fake orig tree object $unapplied\n";
5263 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5265 if (system @bbcmd) {
5266 failedcmd @bbcmd if $? < 0;
5268 failed to apply your git tree's patch stack (from debian/patches/) to
5269 the corresponding upstream tarball(s). Your source tree and .orig
5270 are probably too inconsistent. dgit can only fix up certain kinds of
5271 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5277 quilt_fixup_mkwork($headref);
5280 if (stat_exists ".pc") {
5282 progress "Tree already contains .pc - will use it then delete it.";
5285 rename '../fake/.pc','.pc' or die $!;
5288 changedir '../fake';
5290 my $oldtiptree=git_add_write_tree();
5291 printdebug "fake o+d/p tree object $unapplied\n";
5292 changedir '../work';
5295 # We calculate some guesswork now about what kind of tree this might
5296 # be. This is mostly for error reporting.
5302 # O = orig, without patches applied
5303 # A = "applied", ie orig with H's debian/patches applied
5304 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5305 \%editedignores, \@unrepres),
5306 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5307 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5311 foreach my $b (qw(01 02)) {
5312 foreach my $v (qw(O2H O2A H2A)) {
5313 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5316 printdebug "differences \@dl @dl.\n";
5319 "$us: base trees orig=%.20s o+d/p=%.20s",
5320 $unapplied, $oldtiptree;
5322 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5323 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5324 $dl[0], $dl[1], $dl[3], $dl[4],
5328 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5330 forceable_fail [qw(unrepresentable)], <<END;
5331 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5336 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5337 push @failsuggestion, "This might be a patches-unapplied branch.";
5338 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5339 push @failsuggestion, "This might be a patches-applied branch.";
5341 push @failsuggestion, "Maybe you need to specify one of".
5342 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5344 if (quiltmode_splitbrain()) {
5345 quiltify_splitbrain($clogp, $unapplied, $headref,
5346 $diffbits, \%editedignores,
5347 $splitbrain_cachekey);
5351 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5352 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5354 if (!open P, '>>', ".pc/applied-patches") {
5355 $!==&ENOENT or die $!;
5360 commit_quilty_patch();
5362 if ($mustdeletepc) {
5363 quilt_fixup_delete_pc();
5367 sub quilt_fixup_editor () {
5368 my $descfn = $ENV{$fakeeditorenv};
5369 my $editing = $ARGV[$#ARGV];
5370 open I1, '<', $descfn or die "$descfn: $!";
5371 open I2, '<', $editing or die "$editing: $!";
5372 unlink $editing or die "$editing: $!";
5373 open O, '>', $editing or die "$editing: $!";
5374 while (<I1>) { print O or die $!; } I1->error and die $!;
5377 $copying ||= m/^\-\-\- /;
5378 next unless $copying;
5381 I2->error and die $!;
5386 sub maybe_apply_patches_dirtily () {
5387 return unless $quilt_mode =~ m/gbp|unapplied/;
5388 print STDERR <<END or die $!;
5390 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5391 dgit: Have to apply the patches - making the tree dirty.
5392 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5395 $patches_applied_dirtily = 01;
5396 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5397 runcmd qw(dpkg-source --before-build .);
5400 sub maybe_unapply_patches_again () {
5401 progress "dgit: Unapplying patches again to tidy up the tree."
5402 if $patches_applied_dirtily;
5403 runcmd qw(dpkg-source --after-build .)
5404 if $patches_applied_dirtily & 01;
5406 if $patches_applied_dirtily & 02;
5407 $patches_applied_dirtily = 0;
5410 #----- other building -----
5412 our $clean_using_builder;
5413 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5414 # clean the tree before building (perhaps invoked indirectly by
5415 # whatever we are using to run the build), rather than separately
5416 # and explicitly by us.
5419 return if $clean_using_builder;
5420 if ($cleanmode eq 'dpkg-source') {
5421 maybe_apply_patches_dirtily();
5422 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5423 } elsif ($cleanmode eq 'dpkg-source-d') {
5424 maybe_apply_patches_dirtily();
5425 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5426 } elsif ($cleanmode eq 'git') {
5427 runcmd_ordryrun_local @git, qw(clean -xdf);
5428 } elsif ($cleanmode eq 'git-ff') {
5429 runcmd_ordryrun_local @git, qw(clean -xdff);
5430 } elsif ($cleanmode eq 'check') {
5431 my $leftovers = cmdoutput @git, qw(clean -xdn);
5432 if (length $leftovers) {
5433 print STDERR $leftovers, "\n" or die $!;
5434 fail "tree contains uncommitted files and --clean=check specified";
5436 } elsif ($cleanmode eq 'none') {
5443 badusage "clean takes no additional arguments" if @ARGV;
5446 maybe_unapply_patches_again();
5449 sub build_prep_early () {
5450 our $build_prep_early_done //= 0;
5451 return if $build_prep_early_done++;
5453 badusage "-p is not allowed when building" if defined $package;
5454 my $clogp = parsechangelog();
5455 $isuite = getfield $clogp, 'Distribution';
5456 $package = getfield $clogp, 'Source';
5457 $version = getfield $clogp, 'Version';
5464 build_maybe_quilt_fixup();
5466 my $pat = changespat $version;
5467 foreach my $f (glob "$buildproductsdir/$pat") {
5469 unlink $f or fail "remove old changes file $f: $!";
5471 progress "would remove $f";
5477 sub changesopts_initial () {
5478 my @opts =@changesopts[1..$#changesopts];
5481 sub changesopts_version () {
5482 if (!defined $changes_since_version) {
5483 my @vsns = archive_query('archive_query');
5484 my @quirk = access_quirk();
5485 if ($quirk[0] eq 'backports') {
5486 local $isuite = $quirk[2];
5488 canonicalise_suite();
5489 push @vsns, archive_query('archive_query');
5492 @vsns = map { $_->[0] } @vsns;
5493 @vsns = sort { -version_compare($a, $b) } @vsns;
5494 $changes_since_version = $vsns[0];
5495 progress "changelog will contain changes since $vsns[0]";
5497 $changes_since_version = '_';
5498 progress "package seems new, not specifying -v<version>";
5501 if ($changes_since_version ne '_') {
5502 return ("-v$changes_since_version");
5508 sub changesopts () {
5509 return (changesopts_initial(), changesopts_version());
5512 sub massage_dbp_args ($;$) {
5513 my ($cmd,$xargs) = @_;
5516 # - if we're going to split the source build out so we can
5517 # do strange things to it, massage the arguments to dpkg-buildpackage
5518 # so that the main build doessn't build source (or add an argument
5519 # to stop it building source by default).
5521 # - add -nc to stop dpkg-source cleaning the source tree,
5522 # unless we're not doing a split build and want dpkg-source
5523 # as cleanmode, in which case we can do nothing
5526 # 0 - source will NOT need to be built separately by caller
5527 # +1 - source will need to be built separately by caller
5528 # +2 - source will need to be built separately by caller AND
5529 # dpkg-buildpackage should not in fact be run at all!
5530 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5531 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5532 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5533 $clean_using_builder = 1;
5536 # -nc has the side effect of specifying -b if nothing else specified
5537 # and some combinations of -S, -b, et al, are errors, rather than
5538 # later simply overriding earlie. So we need to:
5539 # - search the command line for these options
5540 # - pick the last one
5541 # - perhaps add our own as a default
5542 # - perhaps adjust it to the corresponding non-source-building version
5544 foreach my $l ($cmd, $xargs) {
5546 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5549 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5551 if ($need_split_build_invocation) {
5552 printdebug "massage split $dmode.\n";
5553 $r = $dmode =~ m/[S]/ ? +2 :
5554 $dmode =~ y/gGF/ABb/ ? +1 :
5555 $dmode =~ m/[ABb]/ ? 0 :
5558 printdebug "massage done $r $dmode.\n";
5560 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5566 my $wasdir = must_getcwd();
5572 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5573 my ($msg_if_onlyone) = @_;
5574 # If there is only one .changes file, fail with $msg_if_onlyone,
5575 # or if that is undef, be a no-op.
5576 # Returns the changes file to report to the user.
5577 my $pat = changespat $version;
5578 my @changesfiles = glob $pat;
5579 @changesfiles = sort {
5580 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5584 if (@changesfiles==1) {
5585 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5586 only one changes file from build (@changesfiles)
5588 $result = $changesfiles[0];
5589 } elsif (@changesfiles==2) {
5590 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5591 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5592 fail "$l found in binaries changes file $binchanges"
5595 runcmd_ordryrun_local @mergechanges, @changesfiles;
5596 my $multichanges = changespat $version,'multi';
5598 stat_exists $multichanges or fail "$multichanges: $!";
5599 foreach my $cf (glob $pat) {
5600 next if $cf eq $multichanges;
5601 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5604 $result = $multichanges;
5606 fail "wrong number of different changes files (@changesfiles)";
5608 printdone "build successful, results in $result\n" or die $!;
5611 sub midbuild_checkchanges () {
5612 my $pat = changespat $version;
5613 return if $rmchanges;
5614 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5615 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5617 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5618 Suggest you delete @unwanted.
5623 sub midbuild_checkchanges_vanilla ($) {
5625 midbuild_checkchanges() if $wantsrc == 1;
5628 sub postbuild_mergechanges_vanilla ($) {
5630 if ($wantsrc == 1) {
5632 postbuild_mergechanges(undef);
5635 printdone "build successful\n";
5640 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5641 my $wantsrc = massage_dbp_args \@dbp;
5644 midbuild_checkchanges_vanilla $wantsrc;
5649 push @dbp, changesopts_version();
5650 maybe_apply_patches_dirtily();
5651 runcmd_ordryrun_local @dbp;
5653 maybe_unapply_patches_again();
5654 postbuild_mergechanges_vanilla $wantsrc;
5658 $quilt_mode //= 'gbp';
5664 # gbp can make .origs out of thin air. In my tests it does this
5665 # even for a 1.0 format package, with no origs present. So I
5666 # guess it keys off just the version number. We don't know
5667 # exactly what .origs ought to exist, but let's assume that we
5668 # should run gbp if: the version has an upstream part and the main
5670 my $upstreamversion = upstreamversion $version;
5671 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5672 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5674 if ($gbp_make_orig) {
5676 $cleanmode = 'none'; # don't do it again
5677 $need_split_build_invocation = 1;
5680 my @dbp = @dpkgbuildpackage;
5682 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5684 if (!length $gbp_build[0]) {
5685 if (length executable_on_path('git-buildpackage')) {
5686 $gbp_build[0] = qw(git-buildpackage);
5688 $gbp_build[0] = 'gbp buildpackage';
5691 my @cmd = opts_opt_multi_cmd @gbp_build;
5693 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5695 if ($gbp_make_orig) {
5696 ensuredir '.git/dgit';
5697 my $ok = '.git/dgit/origs-gen-ok';
5698 unlink $ok or $!==&ENOENT or die $!;
5699 my @origs_cmd = @cmd;
5700 push @origs_cmd, qw(--git-cleaner=true);
5701 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5702 push @origs_cmd, @ARGV;
5704 debugcmd @origs_cmd;
5706 do { local $!; stat_exists $ok; }
5707 or failedcmd @origs_cmd;
5709 dryrun_report @origs_cmd;
5715 midbuild_checkchanges_vanilla $wantsrc;
5717 if (!$clean_using_builder) {
5718 push @cmd, '--git-cleaner=true';
5722 maybe_unapply_patches_again();
5724 push @cmd, changesopts();
5725 runcmd_ordryrun_local @cmd, @ARGV;
5727 postbuild_mergechanges_vanilla $wantsrc;
5729 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5732 my $our_cleanmode = $cleanmode;
5733 if ($need_split_build_invocation) {
5734 # Pretend that clean is being done some other way. This
5735 # forces us not to try to use dpkg-buildpackage to clean and
5736 # build source all in one go; and instead we run dpkg-source
5737 # (and build_prep() will do the clean since $clean_using_builder
5739 $our_cleanmode = 'ELSEWHERE';
5741 if ($our_cleanmode =~ m/^dpkg-source/) {
5742 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5743 $clean_using_builder = 1;
5746 $sourcechanges = changespat $version,'source';
5748 unlink "../$sourcechanges" or $!==ENOENT
5749 or fail "remove $sourcechanges: $!";
5751 $dscfn = dscfn($version);
5752 if ($our_cleanmode eq 'dpkg-source') {
5753 maybe_apply_patches_dirtily();
5754 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5756 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5757 maybe_apply_patches_dirtily();
5758 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5761 my @cmd = (@dpkgsource, qw(-b --));
5764 runcmd_ordryrun_local @cmd, "work";
5765 my @udfiles = <${package}_*>;
5766 changedir "../../..";
5767 foreach my $f (@udfiles) {
5768 printdebug "source copy, found $f\n";
5771 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5772 $f eq srcfn($version, $&));
5773 printdebug "source copy, found $f - renaming\n";
5774 rename "$ud/$f", "../$f" or $!==ENOENT
5775 or fail "put in place new source file ($f): $!";
5778 my $pwd = must_getcwd();
5779 my $leafdir = basename $pwd;
5781 runcmd_ordryrun_local @cmd, $leafdir;
5784 runcmd_ordryrun_local qw(sh -ec),
5785 'exec >$1; shift; exec "$@"','x',
5786 "../$sourcechanges",
5787 @dpkggenchanges, qw(-S), changesopts();
5791 sub cmd_build_source {
5792 badusage "build-source takes no additional arguments" if @ARGV;
5794 maybe_unapply_patches_again();
5795 printdone "source built, results in $dscfn and $sourcechanges";
5800 midbuild_checkchanges();
5803 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5804 stat_exists $sourcechanges
5805 or fail "$sourcechanges (in parent directory): $!";
5807 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5809 maybe_unapply_patches_again();
5811 postbuild_mergechanges(<<END);
5812 perhaps you need to pass -A ? (sbuild's default is to build only
5813 arch-specific binaries; dgit 1.4 used to override that.)
5818 sub cmd_quilt_fixup {
5819 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5820 my $clogp = parsechangelog();
5821 $version = getfield $clogp, 'Version';
5822 $package = getfield $clogp, 'Source';
5825 build_maybe_quilt_fixup();
5828 sub cmd_import_dsc {
5832 last unless $ARGV[0] =~ m/^-/;
5835 if (m/^--require-valid-signature$/) {
5838 badusage "unknown dgit import-dsc sub-option \`$_'";
5842 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5843 my ($dscfn, $dstbranch) = @ARGV;
5845 badusage "dry run makes no sense with import-dsc" unless act_local();
5847 my $force = $dstbranch =~ s/^\+// ? +1 :
5848 $dstbranch =~ s/^\.\.// ? -1 :
5850 my $info = $force ? " $&" : '';
5851 $info = "$dscfn$info";
5853 my $specbranch = $dstbranch;
5854 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5855 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5857 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5858 my $chead = cmdoutput_errok @symcmd;
5859 defined $chead or $?==256 or failedcmd @symcmd;
5861 fail "$dstbranch is checked out - will not update it"
5862 if defined $chead and $chead eq $dstbranch;
5864 my $oldhash = git_get_ref $dstbranch;
5866 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5867 $dscdata = do { local $/ = undef; <D>; };
5868 D->error and fail "read $dscfn: $!";
5871 # we don't normally need this so import it here
5872 use Dpkg::Source::Package;
5873 my $dp = new Dpkg::Source::Package filename => $dscfn,
5874 require_valid_signature => $needsig;
5876 local $SIG{__WARN__} = sub {
5878 return unless $needsig;
5879 fail "import-dsc signature check failed";
5881 if (!$dp->is_signed()) {
5882 warn "$us: warning: importing unsigned .dsc\n";
5884 my $r = $dp->check_signature();
5885 die "->check_signature => $r" if $needsig && $r;
5891 my $dgit_commit = $dsc->{$ourdscfield[0]};
5892 if (defined $dgit_commit &&
5893 !forceing [qw(import-dsc-with-dgit-field)]) {
5894 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5895 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5896 my @cmd = (qw(sh -ec),
5897 "echo $dgit_commit | git cat-file --batch-check");
5898 my $objgot = cmdoutput @cmd;
5899 if ($objgot =~ m#^\w+ missing\b#) {
5901 .dsc contains Dgit field referring to object $dgit_commit
5902 Your git tree does not have that object. Try `git fetch' from a
5903 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5906 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5908 progress "Not fast forward, forced update.";
5910 fail "Not fast forward to $dgit_commit";
5913 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5914 $dstbranch, $dgit_commit);
5916 progress "dgit: import-dsc updated git ref $dstbranch";
5921 Branch $dstbranch already exists
5922 Specify ..$specbranch for a pseudo-merge, binding in existing history
5923 Specify +$specbranch to overwrite, discarding existing history
5925 if $oldhash && !$force;
5927 $package = getfield $dsc, 'Source';
5928 my @dfi = dsc_files_info();
5929 foreach my $fi (@dfi) {
5930 my $f = $fi->{Filename};
5932 next if lstat $here;
5933 fail "stat $here: $!" unless $! == ENOENT;
5935 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5937 } elsif ($dscfn =~ m#^/#) {
5940 fail "cannot import $dscfn which seems to be inside working tree!";
5942 $there =~ s#/+[^/]+$## or
5943 fail "cannot import $dscfn which seems to not have a basename";
5945 symlink $there, $here or fail "symlink $there to $here: $!";
5946 progress "made symlink $here -> $there";
5947 # print STDERR Dumper($fi);
5949 my @mergeinputs = generate_commits_from_dsc();
5950 die unless @mergeinputs == 1;
5952 my $newhash = $mergeinputs[0]{Commit};
5956 progress "Import, forced update - synthetic orphan git history.";
5957 } elsif ($force < 0) {
5958 progress "Import, merging.";
5959 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5960 my $version = getfield $dsc, 'Version';
5961 my $clogp = commit_getclogp $newhash;
5962 my $authline = clogp_authline $clogp;
5963 $newhash = make_commit_text <<END;
5970 Merge $package ($version) import into $dstbranch
5973 die; # caught earlier
5977 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5978 $dstbranch, $newhash);
5980 progress "dgit: import-dsc results are in in git ref $dstbranch";
5983 sub cmd_archive_api_query {
5984 badusage "need only 1 subpath argument" unless @ARGV==1;
5985 my ($subpath) = @ARGV;
5986 my @cmd = archive_api_query_cmd($subpath);
5989 exec @cmd or fail "exec curl: $!\n";
5992 sub cmd_clone_dgit_repos_server {
5993 badusage "need destination argument" unless @ARGV==1;
5994 my ($destdir) = @ARGV;
5995 $package = '_dgit-repos-server';
5996 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5998 exec @cmd or fail "exec git clone: $!\n";
6001 sub cmd_setup_mergechangelogs {
6002 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6003 setup_mergechangelogs(1);
6006 sub cmd_setup_useremail {
6007 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6011 sub cmd_setup_new_tree {
6012 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6016 #---------- argument parsing and main program ----------
6019 print "dgit version $our_version\n" or die $!;
6023 our (%valopts_long, %valopts_short);
6026 sub defvalopt ($$$$) {
6027 my ($long,$short,$val_re,$how) = @_;
6028 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6029 $valopts_long{$long} = $oi;
6030 $valopts_short{$short} = $oi;
6031 # $how subref should:
6032 # do whatever assignemnt or thing it likes with $_[0]
6033 # if the option should not be passed on to remote, @rvalopts=()
6034 # or $how can be a scalar ref, meaning simply assign the value
6037 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6038 defvalopt '--distro', '-d', '.+', \$idistro;
6039 defvalopt '', '-k', '.+', \$keyid;
6040 defvalopt '--existing-package','', '.*', \$existing_package;
6041 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6042 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6043 defvalopt '--package', '-p', $package_re, \$package;
6044 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6046 defvalopt '', '-C', '.+', sub {
6047 ($changesfile) = (@_);
6048 if ($changesfile =~ s#^(.*)/##) {
6049 $buildproductsdir = $1;
6053 defvalopt '--initiator-tempdir','','.*', sub {
6054 ($initiator_tempdir) = (@_);
6055 $initiator_tempdir =~ m#^/# or
6056 badusage "--initiator-tempdir must be used specify an".
6057 " absolute, not relative, directory."
6063 if (defined $ENV{'DGIT_SSH'}) {
6064 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6065 } elsif (defined $ENV{'GIT_SSH'}) {
6066 @ssh = ($ENV{'GIT_SSH'});
6074 if (!defined $val) {
6075 badusage "$what needs a value" unless @ARGV;
6077 push @rvalopts, $val;
6079 badusage "bad value \`$val' for $what" unless
6080 $val =~ m/^$oi->{Re}$(?!\n)/s;
6081 my $how = $oi->{How};
6082 if (ref($how) eq 'SCALAR') {
6087 push @ropts, @rvalopts;
6091 last unless $ARGV[0] =~ m/^-/;
6095 if (m/^--dry-run$/) {
6098 } elsif (m/^--damp-run$/) {
6101 } elsif (m/^--no-sign$/) {
6104 } elsif (m/^--help$/) {
6106 } elsif (m/^--version$/) {
6108 } elsif (m/^--new$/) {
6111 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6112 ($om = $opts_opt_map{$1}) &&
6116 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6117 !$opts_opt_cmdonly{$1} &&
6118 ($om = $opts_opt_map{$1})) {
6121 } elsif (m/^--(gbp|dpm)$/s) {
6122 push @ropts, "--quilt=$1";
6124 } elsif (m/^--ignore-dirty$/s) {
6127 } elsif (m/^--no-quilt-fixup$/s) {
6129 $quilt_mode = 'nocheck';
6130 } elsif (m/^--no-rm-on-error$/s) {
6133 } elsif (m/^--overwrite$/s) {
6135 $overwrite_version = '';
6136 } elsif (m/^--overwrite=(.+)$/s) {
6138 $overwrite_version = $1;
6139 } elsif (m/^--dep14tag$/s) {
6141 $dodep14tag= 'want';
6142 } elsif (m/^--no-dep14tag$/s) {
6145 } elsif (m/^--always-dep14tag$/s) {
6147 $dodep14tag= 'always';
6148 } elsif (m/^--delayed=(\d+)$/s) {
6151 } elsif (m/^--dgit-view-save=(.+)$/s) {
6153 $split_brain_save = $1;
6154 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6155 } elsif (m/^--(no-)?rm-old-changes$/s) {
6158 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6160 push @deliberatelies, $&;
6161 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6165 } elsif (m/^--force-/) {
6167 "$us: warning: ignoring unknown force option $_\n";
6169 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6170 # undocumented, for testing
6172 $tagformat_want = [ $1, 'command line', 1 ];
6173 # 1 menas overrides distro configuration
6174 } elsif (m/^--always-split-source-build$/s) {
6175 # undocumented, for testing
6177 $need_split_build_invocation = 1;
6178 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6179 $val = $2 ? $' : undef; #';
6180 $valopt->($oi->{Long});
6182 badusage "unknown long option \`$_'";
6189 } elsif (s/^-L/-/) {
6192 } elsif (s/^-h/-/) {
6194 } elsif (s/^-D/-/) {
6198 } elsif (s/^-N/-/) {
6203 push @changesopts, $_;
6205 } elsif (s/^-wn$//s) {
6207 $cleanmode = 'none';
6208 } elsif (s/^-wg$//s) {
6211 } elsif (s/^-wgf$//s) {
6213 $cleanmode = 'git-ff';
6214 } elsif (s/^-wd$//s) {
6216 $cleanmode = 'dpkg-source';
6217 } elsif (s/^-wdd$//s) {
6219 $cleanmode = 'dpkg-source-d';
6220 } elsif (s/^-wc$//s) {
6222 $cleanmode = 'check';
6223 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6224 push @git, '-c', $&;
6225 $gitcfgs{cmdline}{$1} = [ $2 ];
6226 } elsif (s/^-c([^=]+)$//s) {
6227 push @git, '-c', $&;
6228 $gitcfgs{cmdline}{$1} = [ 'true' ];
6229 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6231 $val = undef unless length $val;
6232 $valopt->($oi->{Short});
6235 badusage "unknown short option \`$_'";
6242 sub check_env_sanity () {
6243 my $blocked = new POSIX::SigSet;
6244 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6247 foreach my $name (qw(PIPE CHLD)) {
6248 my $signame = "SIG$name";
6249 my $signum = eval "POSIX::$signame" // die;
6250 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6251 die "$signame is set to something other than SIG_DFL\n";
6252 $blocked->ismember($signum) and
6253 die "$signame is blocked\n";
6259 On entry to dgit, $@
6260 This is a bug produced by something in in your execution environment.
6266 sub finalise_opts_opts () {
6267 foreach my $k (keys %opts_opt_map) {
6268 my $om = $opts_opt_map{$k};
6270 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6272 badcfg "cannot set command for $k"
6273 unless length $om->[0];
6277 foreach my $c (access_cfg_cfgs("opts-$k")) {
6279 map { $_ ? @$_ : () }
6280 map { $gitcfgs{$_}{$c} }
6281 reverse @gitcfgsources;
6282 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6283 "\n" if $debuglevel >= 4;
6285 badcfg "cannot configure options for $k"
6286 if $opts_opt_cmdonly{$k};
6287 my $insertpos = $opts_cfg_insertpos{$k};
6288 @$om = ( @$om[0..$insertpos-1],
6290 @$om[$insertpos..$#$om] );
6295 if ($ENV{$fakeeditorenv}) {
6297 quilt_fixup_editor();
6304 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6305 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6306 if $dryrun_level == 1;
6308 print STDERR $helpmsg or die $!;
6311 my $cmd = shift @ARGV;
6314 my $pre_fn = ${*::}{"pre_$cmd"};
6315 $pre_fn->() if $pre_fn;
6317 if (!defined $rmchanges) {
6318 local $access_forpush;
6319 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6322 if (!defined $quilt_mode) {
6323 local $access_forpush;
6324 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6325 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6327 $quilt_mode =~ m/^($quilt_modes_re)$/
6328 or badcfg "unknown quilt-mode \`$quilt_mode'";
6332 if (!defined $dodep14tag) {
6333 local $access_forpush;
6334 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6335 $dodep14tag =~ m/^($dodep14tag_re)$/
6336 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6340 $need_split_build_invocation ||= quiltmode_splitbrain();
6342 if (!defined $cleanmode) {
6343 local $access_forpush;
6344 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6345 $cleanmode //= 'dpkg-source';
6347 badcfg "unknown clean-mode \`$cleanmode'" unless
6348 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6351 my $fn = ${*::}{"cmd_$cmd"};
6352 $fn or badusage "unknown operation $cmd";