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();
146 sub parseopts_late_defaults();
152 our $supplementary_message = '';
153 our $need_split_build_invocation = 0;
154 our $split_brain = 0;
158 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
161 our $remotename = 'dgit';
162 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
166 if (!defined $absurdity) {
168 $absurdity =~ s{/[^/]+$}{/absurd} or die;
172 my ($v,$distro) = @_;
173 return $tagformatfn->($v, $distro);
176 sub debiantag_maintview ($$) {
177 my ($v,$distro) = @_;
178 return "$distro/".dep14_version_mangle $v;
181 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
183 sub lbranch () { return "$branchprefix/$csuite"; }
184 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
185 sub lref () { return "refs/heads/".lbranch(); }
186 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
187 sub rrref () { return server_ref($csuite); }
189 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
190 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
192 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
193 # locally fetched refs because they have unhelpful names and clutter
194 # up gitk etc. So we track whether we have "used up" head ref (ie,
195 # whether we have made another local ref which refers to this object).
197 # (If we deleted them unconditionally, then we might end up
198 # re-fetching the same git objects each time dgit fetch was run.)
200 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
201 # in git_fetch_us to fetch the refs in question, and possibly a call
202 # to lrfetchref_used.
204 our (%lrfetchrefs_f, %lrfetchrefs_d);
205 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
207 sub lrfetchref_used ($) {
208 my ($fullrefname) = @_;
209 my $objid = $lrfetchrefs_f{$fullrefname};
210 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
221 return "${package}_".(stripepoch $vsn).$sfx
226 return srcfn($vsn,".dsc");
229 sub changespat ($;$) {
230 my ($vsn, $arch) = @_;
231 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
234 sub upstreamversion ($) {
246 foreach my $f (@end) {
248 print STDERR "$us: cleanup: $@" if length $@;
252 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
254 sub forceable_fail ($$) {
255 my ($forceoptsl, $msg) = @_;
256 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
257 print STDERR "warning: overriding problem due to --force:\n". $msg;
261 my ($forceoptsl) = @_;
262 my @got = grep { $forceopts{$_} } @$forceoptsl;
263 return 0 unless @got;
265 "warning: skipping checks or functionality due to --force-$got[0]\n";
268 sub no_such_package () {
269 print STDERR "$us: package $package does not exist in suite $isuite\n";
275 printdebug "CD $newdir\n";
276 chdir $newdir or confess "chdir: $newdir: $!";
279 sub deliberately ($) {
281 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
284 sub deliberately_not_fast_forward () {
285 foreach (qw(not-fast-forward fresh-repo)) {
286 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
290 sub quiltmode_splitbrain () {
291 $quilt_mode =~ m/gbp|dpm|unapplied/;
294 sub opts_opt_multi_cmd {
296 push @cmd, split /\s+/, shift @_;
302 return opts_opt_multi_cmd @gbp_pq;
305 #---------- remote protocol support, common ----------
307 # remote push initiator/responder protocol:
308 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
309 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
310 # < dgit-remote-push-ready <actual-proto-vsn>
317 # > supplementary-message NBYTES # $protovsn >= 3
322 # > file parsed-changelog
323 # [indicates that output of dpkg-parsechangelog follows]
324 # > data-block NBYTES
325 # > [NBYTES bytes of data (no newline)]
326 # [maybe some more blocks]
335 # > param head DGIT-VIEW-HEAD
336 # > param csuite SUITE
337 # > param tagformat old|new
338 # > param maint-view MAINT-VIEW-HEAD
340 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
341 # # goes into tag, for replay prevention
344 # [indicates that signed tag is wanted]
345 # < data-block NBYTES
346 # < [NBYTES bytes of data (no newline)]
347 # [maybe some more blocks]
351 # > want signed-dsc-changes
352 # < data-block NBYTES [transfer of signed dsc]
354 # < data-block NBYTES [transfer of signed changes]
362 sub i_child_report () {
363 # Sees if our child has died, and reap it if so. Returns a string
364 # describing how it died if it failed, or undef otherwise.
365 return undef unless $i_child_pid;
366 my $got = waitpid $i_child_pid, WNOHANG;
367 return undef if $got <= 0;
368 die unless $got == $i_child_pid;
369 $i_child_pid = undef;
370 return undef unless $?;
371 return "build host child ".waitstatusmsg();
376 fail "connection lost: $!" if $fh->error;
377 fail "protocol violation; $m not expected";
380 sub badproto_badread ($$) {
382 fail "connection lost: $!" if $!;
383 my $report = i_child_report();
384 fail $report if defined $report;
385 badproto $fh, "eof (reading $wh)";
388 sub protocol_expect (&$) {
389 my ($match, $fh) = @_;
392 defined && chomp or badproto_badread $fh, "protocol message";
400 badproto $fh, "\`$_'";
403 sub protocol_send_file ($$) {
404 my ($fh, $ourfn) = @_;
405 open PF, "<", $ourfn or die "$ourfn: $!";
408 my $got = read PF, $d, 65536;
409 die "$ourfn: $!" unless defined $got;
411 print $fh "data-block ".length($d)."\n" or die $!;
412 print $fh $d or die $!;
414 PF->error and die "$ourfn $!";
415 print $fh "data-end\n" or die $!;
419 sub protocol_read_bytes ($$) {
420 my ($fh, $nbytes) = @_;
421 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
423 my $got = read $fh, $d, $nbytes;
424 $got==$nbytes or badproto_badread $fh, "data block";
428 sub protocol_receive_file ($$) {
429 my ($fh, $ourfn) = @_;
430 printdebug "() $ourfn\n";
431 open PF, ">", $ourfn or die "$ourfn: $!";
433 my ($y,$l) = protocol_expect {
434 m/^data-block (.*)$/ ? (1,$1) :
435 m/^data-end$/ ? (0,) :
439 my $d = protocol_read_bytes $fh, $l;
440 print PF $d or die $!;
445 #---------- remote protocol support, responder ----------
447 sub responder_send_command ($) {
449 return unless $we_are_responder;
450 # called even without $we_are_responder
451 printdebug ">> $command\n";
452 print PO $command, "\n" or die $!;
455 sub responder_send_file ($$) {
456 my ($keyword, $ourfn) = @_;
457 return unless $we_are_responder;
458 printdebug "]] $keyword $ourfn\n";
459 responder_send_command "file $keyword";
460 protocol_send_file \*PO, $ourfn;
463 sub responder_receive_files ($@) {
464 my ($keyword, @ourfns) = @_;
465 die unless $we_are_responder;
466 printdebug "[[ $keyword @ourfns\n";
467 responder_send_command "want $keyword";
468 foreach my $fn (@ourfns) {
469 protocol_receive_file \*PI, $fn;
472 protocol_expect { m/^files-end$/ } \*PI;
475 #---------- remote protocol support, initiator ----------
477 sub initiator_expect (&) {
479 protocol_expect { &$match } \*RO;
482 #---------- end remote code ----------
485 if ($we_are_responder) {
487 responder_send_command "progress ".length($m) or die $!;
488 print PO $m or die $!;
498 $ua = LWP::UserAgent->new();
502 progress "downloading $what...";
503 my $r = $ua->get(@_) or die $!;
504 return undef if $r->code == 404;
505 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
506 return $r->decoded_content(charset => 'none');
509 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
514 failedcmd @_ if system @_;
517 sub act_local () { return $dryrun_level <= 1; }
518 sub act_scary () { return !$dryrun_level; }
521 if (!$dryrun_level) {
522 progress "$us ok: @_";
524 progress "would be ok: @_ (but dry run only)";
529 printcmd(\*STDERR,$debugprefix."#",@_);
532 sub runcmd_ordryrun {
540 sub runcmd_ordryrun_local {
549 my ($first_shell, @cmd) = @_;
550 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
553 our $helpmsg = <<END;
555 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
556 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
557 dgit [dgit-opts] build [dpkg-buildpackage-opts]
558 dgit [dgit-opts] sbuild [sbuild-opts]
559 dgit [dgit-opts] push [dgit-opts] [suite]
560 dgit [dgit-opts] rpush build-host:build-dir ...
561 important dgit options:
562 -k<keyid> sign tag and package with <keyid> instead of default
563 --dry-run -n do not change anything, but go through the motions
564 --damp-run -L like --dry-run but make local changes, without signing
565 --new -N allow introducing a new package
566 --debug -D increase debug level
567 -c<name>=<value> set git config option (used directly by dgit too)
570 our $later_warning_msg = <<END;
571 Perhaps the upload is stuck in incoming. Using the version from git.
575 print STDERR "$us: @_\n", $helpmsg or die $!;
580 @ARGV or badusage "too few arguments";
581 return scalar shift @ARGV;
585 print $helpmsg or die $!;
589 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
591 our %defcfg = ('dgit.default.distro' => 'debian',
592 'dgit-suite.*-security.distro' => 'debian-security',
593 'dgit.default.username' => '',
594 'dgit.default.archive-query-default-component' => 'main',
595 'dgit.default.ssh' => 'ssh',
596 'dgit.default.archive-query' => 'madison:',
597 'dgit.default.sshpsql-dbname' => 'service=projectb',
598 'dgit.default.aptget-components' => 'main',
599 'dgit.default.dgit-tag-format' => 'new,old,maint',
600 # old means "repo server accepts pushes with old dgit tags"
601 # new means "repo server accepts pushes with new dgit tags"
602 # maint means "repo server accepts split brain pushes"
603 # hist means "repo server may have old pushes without new tag"
604 # ("hist" is implied by "old")
605 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
606 'dgit-distro.debian.git-check' => 'url',
607 'dgit-distro.debian.git-check-suffix' => '/info/refs',
608 'dgit-distro.debian.new-private-pushers' => 't',
609 'dgit-distro.debian/push.git-url' => '',
610 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
611 'dgit-distro.debian/push.git-user-force' => 'dgit',
612 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
613 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
614 'dgit-distro.debian/push.git-create' => 'true',
615 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
616 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
617 # 'dgit-distro.debian.archive-query-tls-key',
618 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
619 # ^ this does not work because curl is broken nowadays
620 # Fixing #790093 properly will involve providing providing the key
621 # in some pacagke and maybe updating these paths.
623 # 'dgit-distro.debian.archive-query-tls-curl-args',
624 # '--ca-path=/etc/ssl/ca-debian',
625 # ^ this is a workaround but works (only) on DSA-administered machines
626 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
627 'dgit-distro.debian.git-url-suffix' => '',
628 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
629 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
630 'dgit-distro.debian-security.archive-query' => 'aptget:',
631 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
632 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
633 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
634 'dgit-distro.debian-security.nominal-distro' => 'debian',
635 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
636 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
637 'dgit-distro.ubuntu.git-check' => 'false',
638 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
639 'dgit-distro.test-dummy.ssh' => "$td/ssh",
640 'dgit-distro.test-dummy.username' => "alice",
641 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
642 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
643 'dgit-distro.test-dummy.git-url' => "$td/git",
644 'dgit-distro.test-dummy.git-host' => "git",
645 'dgit-distro.test-dummy.git-path' => "$td/git",
646 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
647 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
648 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
649 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
653 our @gitcfgsources = qw(cmdline local global system);
655 sub git_slurp_config () {
656 local ($debuglevel) = $debuglevel-2;
659 # This algoritm is a bit subtle, but this is needed so that for
660 # options which we want to be single-valued, we allow the
661 # different config sources to override properly. See #835858.
662 foreach my $src (@gitcfgsources) {
663 next if $src eq 'cmdline';
664 # we do this ourselves since git doesn't handle it
666 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
669 open GITS, "-|", @cmd or die $!;
672 printdebug "=> ", (messagequote $_), "\n";
674 push @{ $gitcfgs{$src}{$`} }, $'; #';
678 or ($!==0 && $?==256)
683 sub git_get_config ($) {
685 foreach my $src (@gitcfgsources) {
686 my $l = $gitcfgs{$src}{$c};
687 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
690 @$l==1 or badcfg "multiple values for $c".
691 " (in $src git config)" if @$l > 1;
699 return undef if $c =~ /RETURN-UNDEF/;
700 my $v = git_get_config($c);
701 return $v if defined $v;
702 my $dv = $defcfg{$c};
703 return $dv if defined $dv;
705 badcfg "need value for one of: @_\n".
706 "$us: distro or suite appears not to be (properly) supported";
709 sub access_basedistro () {
710 if (defined $idistro) {
713 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
714 return $def if defined $def;
715 foreach my $src (@gitcfgsources, 'internal') {
716 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
718 foreach my $k (keys %$kl) {
719 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
721 next unless match_glob $dpat, $isuite;
725 return cfg("dgit.default.distro");
729 sub access_nomdistro () {
730 my $base = access_basedistro();
731 return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
734 sub access_quirk () {
735 # returns (quirk name, distro to use instead or undef, quirk-specific info)
736 my $basedistro = access_basedistro();
737 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
739 if (defined $backports_quirk) {
740 my $re = $backports_quirk;
741 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
743 $re =~ s/\%/([-0-9a-z_]+)/
744 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
745 if ($isuite =~ m/^$re$/) {
746 return ('backports',"$basedistro-backports",$1);
749 return ('none',undef);
754 sub parse_cfg_bool ($$$) {
755 my ($what,$def,$v) = @_;
758 $v =~ m/^[ty1]/ ? 1 :
759 $v =~ m/^[fn0]/ ? 0 :
760 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
763 sub access_forpush_config () {
764 my $d = access_basedistro();
768 parse_cfg_bool('new-private-pushers', 0,
769 cfg("dgit-distro.$d.new-private-pushers",
772 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
775 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
776 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
777 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
778 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
781 sub access_forpush () {
782 $access_forpush //= access_forpush_config();
783 return $access_forpush;
787 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
788 badcfg "pushing but distro is configured readonly"
789 if access_forpush_config() eq '0';
791 $supplementary_message = <<'END' unless $we_are_responder;
792 Push failed, before we got started.
793 You can retry the push, after fixing the problem, if you like.
795 finalise_opts_opts();
799 finalise_opts_opts();
802 sub supplementary_message ($) {
804 if (!$we_are_responder) {
805 $supplementary_message = $msg;
807 } elsif ($protovsn >= 3) {
808 responder_send_command "supplementary-message ".length($msg)
810 print PO $msg or die $!;
814 sub access_distros () {
815 # Returns list of distros to try, in order
818 # 0. `instead of' distro name(s) we have been pointed to
819 # 1. the access_quirk distro, if any
820 # 2a. the user's specified distro, or failing that } basedistro
821 # 2b. the distro calculated from the suite }
822 my @l = access_basedistro();
824 my (undef,$quirkdistro) = access_quirk();
825 unshift @l, $quirkdistro;
826 unshift @l, $instead_distro;
827 @l = grep { defined } @l;
829 push @l, access_nomdistro();
831 if (access_forpush()) {
832 @l = map { ("$_/push", $_) } @l;
837 sub access_cfg_cfgs (@) {
840 # The nesting of these loops determines the search order. We put
841 # the key loop on the outside so that we search all the distros
842 # for each key, before going on to the next key. That means that
843 # if access_cfg is called with a more specific, and then a less
844 # specific, key, an earlier distro can override the less specific
845 # without necessarily overriding any more specific keys. (If the
846 # distro wants to override the more specific keys it can simply do
847 # so; whereas if we did the loop the other way around, it would be
848 # impossible to for an earlier distro to override a less specific
849 # key but not the more specific ones without restating the unknown
850 # values of the more specific keys.
853 # We have to deal with RETURN-UNDEF specially, so that we don't
854 # terminate the search prematurely.
856 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
859 foreach my $d (access_distros()) {
860 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
862 push @cfgs, map { "dgit.default.$_" } @realkeys;
869 my (@cfgs) = access_cfg_cfgs(@keys);
870 my $value = cfg(@cfgs);
874 sub access_cfg_bool ($$) {
875 my ($def, @keys) = @_;
876 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
879 sub string_to_ssh ($) {
881 if ($spec =~ m/\s/) {
882 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
888 sub access_cfg_ssh () {
889 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
890 if (!defined $gitssh) {
893 return string_to_ssh $gitssh;
897 sub access_runeinfo ($) {
899 return ": dgit ".access_basedistro()." $info ;";
902 sub access_someuserhost ($) {
904 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
905 defined($user) && length($user) or
906 $user = access_cfg("$some-user",'username');
907 my $host = access_cfg("$some-host");
908 return length($user) ? "$user\@$host" : $host;
911 sub access_gituserhost () {
912 return access_someuserhost('git');
915 sub access_giturl (;$) {
917 my $url = access_cfg('git-url','RETURN-UNDEF');
920 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
921 return undef unless defined $proto;
924 access_gituserhost().
925 access_cfg('git-path');
927 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
930 return "$url/$package$suffix";
933 sub parsecontrolfh ($$;$) {
934 my ($fh, $desc, $allowsigned) = @_;
935 our $dpkgcontrolhash_noissigned;
938 my %opts = ('name' => $desc);
939 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
940 $c = Dpkg::Control::Hash->new(%opts);
941 $c->parse($fh,$desc) or die "parsing of $desc failed";
942 last if $allowsigned;
943 last if $dpkgcontrolhash_noissigned;
944 my $issigned= $c->get_option('is_pgp_signed');
945 if (!defined $issigned) {
946 $dpkgcontrolhash_noissigned= 1;
947 seek $fh, 0,0 or die "seek $desc: $!";
948 } elsif ($issigned) {
949 fail "control file $desc is (already) PGP-signed. ".
950 " Note that dgit push needs to modify the .dsc and then".
951 " do the signature itself";
960 my ($file, $desc, $allowsigned) = @_;
961 my $fh = new IO::Handle;
962 open $fh, '<', $file or die "$file: $!";
963 my $c = parsecontrolfh($fh,$desc,$allowsigned);
964 $fh->error and die $!;
970 my ($dctrl,$field) = @_;
971 my $v = $dctrl->{$field};
972 return $v if defined $v;
973 fail "missing field $field in ".$dctrl->get_option('name');
977 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
978 my $p = new IO::Handle;
979 my @cmd = (qw(dpkg-parsechangelog), @_);
980 open $p, '-|', @cmd or die $!;
982 $?=0; $!=0; close $p or failedcmd @cmd;
986 sub commit_getclogp ($) {
987 # Returns the parsed changelog hashref for a particular commit
989 our %commit_getclogp_memo;
990 my $memo = $commit_getclogp_memo{$objid};
991 return $memo if $memo;
993 my $mclog = ".git/dgit/clog-$objid";
994 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
995 "$objid:debian/changelog";
996 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1001 defined $d or fail "getcwd failed: $!";
1005 sub parse_dscdata () {
1006 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1007 printdebug Dumper($dscdata) if $debuglevel>1;
1008 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1009 printdebug Dumper($dsc) if $debuglevel>1;
1014 sub archive_query ($;@) {
1015 my ($method) = shift @_;
1016 fail "this operation does not support multiple comma-separated suites"
1018 my $query = access_cfg('archive-query','RETURN-UNDEF');
1019 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1022 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1025 sub archive_query_prepend_mirror {
1026 my $m = access_cfg('mirror');
1027 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1030 sub pool_dsc_subpath ($$) {
1031 my ($vsn,$component) = @_; # $package is implict arg
1032 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1033 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1036 sub cfg_apply_map ($$$) {
1037 my ($varref, $what, $mapspec) = @_;
1038 return unless $mapspec;
1040 printdebug "config $what EVAL{ $mapspec; }\n";
1042 eval "package Dgit::Config; $mapspec;";
1047 #---------- `ftpmasterapi' archive query method (nascent) ----------
1049 sub archive_api_query_cmd ($) {
1051 my @cmd = (@curl, qw(-sS));
1052 my $url = access_cfg('archive-query-url');
1053 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1055 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1056 foreach my $key (split /\:/, $keys) {
1057 $key =~ s/\%HOST\%/$host/g;
1059 fail "for $url: stat $key: $!" unless $!==ENOENT;
1062 fail "config requested specific TLS key but do not know".
1063 " how to get curl to use exactly that EE key ($key)";
1064 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1065 # # Sadly the above line does not work because of changes
1066 # # to gnutls. The real fix for #790093 may involve
1067 # # new curl options.
1070 # Fixing #790093 properly will involve providing a value
1071 # for this on clients.
1072 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1073 push @cmd, split / /, $kargs if defined $kargs;
1075 push @cmd, $url.$subpath;
1079 sub api_query ($$;$) {
1081 my ($data, $subpath, $ok404) = @_;
1082 badcfg "ftpmasterapi archive query method takes no data part"
1084 my @cmd = archive_api_query_cmd($subpath);
1085 my $url = $cmd[$#cmd];
1086 push @cmd, qw(-w %{http_code});
1087 my $json = cmdoutput @cmd;
1088 unless ($json =~ s/\d+\d+\d$//) {
1089 failedcmd_report_cmd undef, @cmd;
1090 fail "curl failed to print 3-digit HTTP code";
1093 return undef if $code eq '404' && $ok404;
1094 fail "fetch of $url gave HTTP code $code"
1095 unless $url =~ m#^file://# or $code =~ m/^2/;
1096 return decode_json($json);
1099 sub canonicalise_suite_ftpmasterapi {
1100 my ($proto,$data) = @_;
1101 my $suites = api_query($data, 'suites');
1103 foreach my $entry (@$suites) {
1105 my $v = $entry->{$_};
1106 defined $v && $v eq $isuite;
1107 } qw(codename name);
1108 push @matched, $entry;
1110 fail "unknown suite $isuite" unless @matched;
1113 @matched==1 or die "multiple matches for suite $isuite\n";
1114 $cn = "$matched[0]{codename}";
1115 defined $cn or die "suite $isuite info has no codename\n";
1116 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1118 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1123 sub archive_query_ftpmasterapi {
1124 my ($proto,$data) = @_;
1125 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1127 my $digester = Digest::SHA->new(256);
1128 foreach my $entry (@$info) {
1130 my $vsn = "$entry->{version}";
1131 my ($ok,$msg) = version_check $vsn;
1132 die "bad version: $msg\n" unless $ok;
1133 my $component = "$entry->{component}";
1134 $component =~ m/^$component_re$/ or die "bad component";
1135 my $filename = "$entry->{filename}";
1136 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1137 or die "bad filename";
1138 my $sha256sum = "$entry->{sha256sum}";
1139 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1140 push @rows, [ $vsn, "/pool/$component/$filename",
1141 $digester, $sha256sum ];
1143 die "bad ftpmaster api response: $@\n".Dumper($entry)
1146 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1147 return archive_query_prepend_mirror @rows;
1150 sub file_in_archive_ftpmasterapi {
1151 my ($proto,$data,$filename) = @_;
1152 my $pat = $filename;
1155 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1156 my $info = api_query($data, "file_in_archive/$pat", 1);
1159 #---------- `aptget' archive query method ----------
1162 our $aptget_releasefile;
1163 our $aptget_configpath;
1165 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1166 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1168 sub aptget_cache_clean {
1169 runcmd_ordryrun_local qw(sh -ec),
1170 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1174 sub aptget_lock_acquire () {
1175 my $lockfile = "$aptget_base/lock";
1176 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1177 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1180 sub aptget_prep ($) {
1182 return if defined $aptget_base;
1184 badcfg "aptget archive query method takes no data part"
1187 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1190 ensuredir "$cache/dgit";
1192 access_cfg('aptget-cachekey','RETURN-UNDEF')
1193 // access_nomdistro();
1195 $aptget_base = "$cache/dgit/aptget";
1196 ensuredir $aptget_base;
1198 my $quoted_base = $aptget_base;
1199 die "$quoted_base contains bad chars, cannot continue"
1200 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1202 ensuredir $aptget_base;
1204 aptget_lock_acquire();
1206 aptget_cache_clean();
1208 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1209 my $sourceslist = "source.list#$cachekey";
1211 my $aptsuites = $isuite;
1212 cfg_apply_map(\$aptsuites, 'suite map',
1213 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1215 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1216 printf SRCS "deb-src %s %s %s\n",
1217 access_cfg('mirror'),
1219 access_cfg('aptget-components')
1222 ensuredir "$aptget_base/cache";
1223 ensuredir "$aptget_base/lists";
1225 open CONF, ">", $aptget_configpath or die $!;
1227 Debug::NoLocking "true";
1228 APT::Get::List-Cleanup "false";
1229 #clear APT::Update::Post-Invoke-Success;
1230 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1231 Dir::State::Lists "$quoted_base/lists";
1232 Dir::Etc::preferences "$quoted_base/preferences";
1233 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1234 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1237 foreach my $key (qw(
1240 Dir::Cache::Archives
1241 Dir::Etc::SourceParts
1242 Dir::Etc::preferencesparts
1244 ensuredir "$aptget_base/$key";
1245 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1248 my $oldatime = (time // die $!) - 1;
1249 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1250 next unless stat_exists $oldlist;
1251 my ($mtime) = (stat _)[9];
1252 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1255 runcmd_ordryrun_local aptget_aptget(), qw(update);
1258 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1259 next unless stat_exists $oldlist;
1260 my ($atime) = (stat _)[8];
1261 next if $atime == $oldatime;
1262 push @releasefiles, $oldlist;
1264 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1265 @releasefiles = @inreleasefiles if @inreleasefiles;
1266 die "apt updated wrong number of Release files (@releasefiles), erk"
1267 unless @releasefiles == 1;
1269 ($aptget_releasefile) = @releasefiles;
1272 sub canonicalise_suite_aptget {
1273 my ($proto,$data) = @_;
1276 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1278 foreach my $name (qw(Codename Suite)) {
1279 my $val = $release->{$name};
1281 printdebug "release file $name: $val\n";
1282 $val =~ m/^$suite_re$/o or fail
1283 "Release file ($aptget_releasefile) specifies intolerable $name";
1284 cfg_apply_map(\$val, 'suite rmap',
1285 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1292 sub archive_query_aptget {
1293 my ($proto,$data) = @_;
1296 ensuredir "$aptget_base/source";
1297 foreach my $old (<$aptget_base/source/*.dsc>) {
1298 unlink $old or die "$old: $!";
1301 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1302 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1303 # avoids apt-get source failing with ambiguous error code
1305 runcmd_ordryrun_local
1306 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1307 aptget_aptget(), qw(--download-only --only-source source), $package;
1309 my @dscs = <$aptget_base/source/*.dsc>;
1310 fail "apt-get source did not produce a .dsc" unless @dscs;
1311 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1313 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1316 my $uri = "file://". uri_escape $dscs[0];
1317 $uri =~ s{\%2f}{/}gi;
1318 return [ (getfield $pre_dsc, 'Version'), $uri ];
1321 #---------- `dummyapicat' archive query method ----------
1323 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1324 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1326 sub file_in_archive_dummycatapi ($$$) {
1327 my ($proto,$data,$filename) = @_;
1328 my $mirror = access_cfg('mirror');
1329 $mirror =~ s#^file://#/# or die "$mirror ?";
1331 my @cmd = (qw(sh -ec), '
1333 find -name "$2" -print0 |
1335 ', qw(x), $mirror, $filename);
1336 debugcmd "-|", @cmd;
1337 open FIA, "-|", @cmd or die $!;
1340 printdebug "| $_\n";
1341 m/^(\w+) (\S+)$/ or die "$_ ?";
1342 push @out, { sha256sum => $1, filename => $2 };
1344 close FIA or die failedcmd @cmd;
1348 #---------- `madison' archive query method ----------
1350 sub archive_query_madison {
1351 return archive_query_prepend_mirror
1352 map { [ @$_[0..1] ] } madison_get_parse(@_);
1355 sub madison_get_parse {
1356 my ($proto,$data) = @_;
1357 die unless $proto eq 'madison';
1358 if (!length $data) {
1359 $data= access_cfg('madison-distro','RETURN-UNDEF');
1360 $data //= access_basedistro();
1362 $rmad{$proto,$data,$package} ||= cmdoutput
1363 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1364 my $rmad = $rmad{$proto,$data,$package};
1367 foreach my $l (split /\n/, $rmad) {
1368 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1369 \s*( [^ \t|]+ )\s* \|
1370 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1371 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1372 $1 eq $package or die "$rmad $package ?";
1379 $component = access_cfg('archive-query-default-component');
1381 $5 eq 'source' or die "$rmad ?";
1382 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1384 return sort { -version_compare($a->[0],$b->[0]); } @out;
1387 sub canonicalise_suite_madison {
1388 # madison canonicalises for us
1389 my @r = madison_get_parse(@_);
1391 "unable to canonicalise suite using package $package".
1392 " which does not appear to exist in suite $isuite;".
1393 " --existing-package may help";
1397 sub file_in_archive_madison { return undef; }
1399 #---------- `sshpsql' archive query method ----------
1402 my ($data,$runeinfo,$sql) = @_;
1403 if (!length $data) {
1404 $data= access_someuserhost('sshpsql').':'.
1405 access_cfg('sshpsql-dbname');
1407 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1408 my ($userhost,$dbname) = ($`,$'); #';
1410 my @cmd = (access_cfg_ssh, $userhost,
1411 access_runeinfo("ssh-psql $runeinfo").
1412 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1413 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1415 open P, "-|", @cmd or die $!;
1418 printdebug(">|$_|\n");
1421 $!=0; $?=0; close P or failedcmd @cmd;
1423 my $nrows = pop @rows;
1424 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1425 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1426 @rows = map { [ split /\|/, $_ ] } @rows;
1427 my $ncols = scalar @{ shift @rows };
1428 die if grep { scalar @$_ != $ncols } @rows;
1432 sub sql_injection_check {
1433 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1436 sub archive_query_sshpsql ($$) {
1437 my ($proto,$data) = @_;
1438 sql_injection_check $isuite, $package;
1439 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1440 SELECT source.version, component.name, files.filename, files.sha256sum
1442 JOIN src_associations ON source.id = src_associations.source
1443 JOIN suite ON suite.id = src_associations.suite
1444 JOIN dsc_files ON dsc_files.source = source.id
1445 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1446 JOIN component ON component.id = files_archive_map.component_id
1447 JOIN files ON files.id = dsc_files.file
1448 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1449 AND source.source='$package'
1450 AND files.filename LIKE '%.dsc';
1452 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1453 my $digester = Digest::SHA->new(256);
1455 my ($vsn,$component,$filename,$sha256sum) = @$_;
1456 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1458 return archive_query_prepend_mirror @rows;
1461 sub canonicalise_suite_sshpsql ($$) {
1462 my ($proto,$data) = @_;
1463 sql_injection_check $isuite;
1464 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1465 SELECT suite.codename
1466 FROM suite where suite_name='$isuite' or codename='$isuite';
1468 @rows = map { $_->[0] } @rows;
1469 fail "unknown suite $isuite" unless @rows;
1470 die "ambiguous $isuite: @rows ?" if @rows>1;
1474 sub file_in_archive_sshpsql ($$$) { return undef; }
1476 #---------- `dummycat' archive query method ----------
1478 sub canonicalise_suite_dummycat ($$) {
1479 my ($proto,$data) = @_;
1480 my $dpath = "$data/suite.$isuite";
1481 if (!open C, "<", $dpath) {
1482 $!==ENOENT or die "$dpath: $!";
1483 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1487 chomp or die "$dpath: $!";
1489 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1493 sub archive_query_dummycat ($$) {
1494 my ($proto,$data) = @_;
1495 canonicalise_suite();
1496 my $dpath = "$data/package.$csuite.$package";
1497 if (!open C, "<", $dpath) {
1498 $!==ENOENT or die "$dpath: $!";
1499 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1507 printdebug "dummycat query $csuite $package $dpath | $_\n";
1508 my @row = split /\s+/, $_;
1509 @row==2 or die "$dpath: $_ ?";
1512 C->error and die "$dpath: $!";
1514 return archive_query_prepend_mirror
1515 sort { -version_compare($a->[0],$b->[0]); } @rows;
1518 sub file_in_archive_dummycat () { return undef; }
1520 #---------- tag format handling ----------
1522 sub access_cfg_tagformats () {
1523 split /\,/, access_cfg('dgit-tag-format');
1526 sub access_cfg_tagformats_can_splitbrain () {
1527 my %y = map { $_ => 1 } access_cfg_tagformats;
1528 foreach my $needtf (qw(new maint)) {
1529 next if $y{$needtf};
1535 sub need_tagformat ($$) {
1536 my ($fmt, $why) = @_;
1537 fail "need to use tag format $fmt ($why) but also need".
1538 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1539 " - no way to proceed"
1540 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1541 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1544 sub select_tagformat () {
1546 return if $tagformatfn && !$tagformat_want;
1547 die 'bug' if $tagformatfn && $tagformat_want;
1548 # ... $tagformat_want assigned after previous select_tagformat
1550 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1551 printdebug "select_tagformat supported @supported\n";
1553 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1554 printdebug "select_tagformat specified @$tagformat_want\n";
1556 my ($fmt,$why,$override) = @$tagformat_want;
1558 fail "target distro supports tag formats @supported".
1559 " but have to use $fmt ($why)"
1561 or grep { $_ eq $fmt } @supported;
1563 $tagformat_want = undef;
1565 $tagformatfn = ${*::}{"debiantag_$fmt"};
1567 fail "trying to use unknown tag format \`$fmt' ($why) !"
1568 unless $tagformatfn;
1571 #---------- archive query entrypoints and rest of program ----------
1573 sub canonicalise_suite () {
1574 return if defined $csuite;
1575 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1576 $csuite = archive_query('canonicalise_suite');
1577 if ($isuite ne $csuite) {
1578 progress "canonical suite name for $isuite is $csuite";
1580 progress "canonical suite name is $csuite";
1584 sub get_archive_dsc () {
1585 canonicalise_suite();
1586 my @vsns = archive_query('archive_query');
1587 foreach my $vinfo (@vsns) {
1588 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1589 $dscurl = $vsn_dscurl;
1590 $dscdata = url_get($dscurl);
1592 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1597 $digester->add($dscdata);
1598 my $got = $digester->hexdigest();
1600 fail "$dscurl has hash $got but".
1601 " archive told us to expect $digest";
1604 my $fmt = getfield $dsc, 'Format';
1605 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1606 "unsupported source format $fmt, sorry";
1608 $dsc_checked = !!$digester;
1609 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1613 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1616 sub check_for_git ();
1617 sub check_for_git () {
1619 my $how = access_cfg('git-check');
1620 if ($how eq 'ssh-cmd') {
1622 (access_cfg_ssh, access_gituserhost(),
1623 access_runeinfo("git-check $package").
1624 " set -e; cd ".access_cfg('git-path').";".
1625 " if test -d $package.git; then echo 1; else echo 0; fi");
1626 my $r= cmdoutput @cmd;
1627 if (defined $r and $r =~ m/^divert (\w+)$/) {
1629 my ($usedistro,) = access_distros();
1630 # NB that if we are pushing, $usedistro will be $distro/push
1631 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1632 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1633 progress "diverting to $divert (using config for $instead_distro)";
1634 return check_for_git();
1636 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1638 } elsif ($how eq 'url') {
1639 my $prefix = access_cfg('git-check-url','git-url');
1640 my $suffix = access_cfg('git-check-suffix','git-suffix',
1641 'RETURN-UNDEF') // '.git';
1642 my $url = "$prefix/$package$suffix";
1643 my @cmd = (@curl, qw(-sS -I), $url);
1644 my $result = cmdoutput @cmd;
1645 $result =~ s/^\S+ 200 .*\n\r?\n//;
1646 # curl -sS -I with https_proxy prints
1647 # HTTP/1.0 200 Connection established
1648 $result =~ m/^\S+ (404|200) /s or
1649 fail "unexpected results from git check query - ".
1650 Dumper($prefix, $result);
1652 if ($code eq '404') {
1654 } elsif ($code eq '200') {
1659 } elsif ($how eq 'true') {
1661 } elsif ($how eq 'false') {
1664 badcfg "unknown git-check \`$how'";
1668 sub create_remote_git_repo () {
1669 my $how = access_cfg('git-create');
1670 if ($how eq 'ssh-cmd') {
1672 (access_cfg_ssh, access_gituserhost(),
1673 access_runeinfo("git-create $package").
1674 "set -e; cd ".access_cfg('git-path').";".
1675 " cp -a _template $package.git");
1676 } elsif ($how eq 'true') {
1679 badcfg "unknown git-create \`$how'";
1683 our ($dsc_hash,$lastpush_mergeinput);
1685 our $ud = '.git/dgit/unpack';
1695 sub mktree_in_ud_here () {
1696 runcmd qw(git init -q);
1697 runcmd qw(git config gc.auto 0);
1698 rmtree('.git/objects');
1699 symlink '../../../../objects','.git/objects' or die $!;
1702 sub git_write_tree () {
1703 my $tree = cmdoutput @git, qw(write-tree);
1704 $tree =~ m/^\w+$/ or die "$tree ?";
1708 sub git_add_write_tree () {
1709 runcmd @git, qw(add -Af .);
1710 return git_write_tree();
1713 sub remove_stray_gits ($) {
1715 my @gitscmd = qw(find -name .git -prune -print0);
1716 debugcmd "|",@gitscmd;
1717 open GITS, "-|", @gitscmd or die $!;
1722 print STDERR "$us: warning: removing from $what: ",
1723 (messagequote $_), "\n";
1727 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1730 sub mktree_in_ud_from_only_subdir ($;$) {
1731 my ($what,$raw) = @_;
1733 # changes into the subdir
1735 die "expected one subdir but found @dirs ?" unless @dirs==1;
1736 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1740 remove_stray_gits($what);
1741 mktree_in_ud_here();
1743 my ($format, $fopts) = get_source_format();
1744 if (madformat($format)) {
1749 my $tree=git_add_write_tree();
1750 return ($tree,$dir);
1753 our @files_csum_info_fields =
1754 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1755 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1756 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1758 sub dsc_files_info () {
1759 foreach my $csumi (@files_csum_info_fields) {
1760 my ($fname, $module, $method) = @$csumi;
1761 my $field = $dsc->{$fname};
1762 next unless defined $field;
1763 eval "use $module; 1;" or die $@;
1765 foreach (split /\n/, $field) {
1767 m/^(\w+) (\d+) (\S+)$/ or
1768 fail "could not parse .dsc $fname line \`$_'";
1769 my $digester = eval "$module"."->$method;" or die $@;
1774 Digester => $digester,
1779 fail "missing any supported Checksums-* or Files field in ".
1780 $dsc->get_option('name');
1784 map { $_->{Filename} } dsc_files_info();
1787 sub files_compare_inputs (@) {
1792 my $showinputs = sub {
1793 return join "; ", map { $_->get_option('name') } @$inputs;
1796 foreach my $in (@$inputs) {
1798 my $in_name = $in->get_option('name');
1800 printdebug "files_compare_inputs $in_name\n";
1802 foreach my $csumi (@files_csum_info_fields) {
1803 my ($fname) = @$csumi;
1804 printdebug "files_compare_inputs $in_name $fname\n";
1806 my $field = $in->{$fname};
1807 next unless defined $field;
1810 foreach (split /\n/, $field) {
1813 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1814 fail "could not parse $in_name $fname line \`$_'";
1816 printdebug "files_compare_inputs $in_name $fname $f\n";
1820 my $re = \ $record{$f}{$fname};
1822 $fchecked{$f}{$in_name} = 1;
1824 fail "hash or size of $f varies in $fname fields".
1825 " (between: ".$showinputs->().")";
1830 @files = sort @files;
1831 $expected_files //= \@files;
1832 "@$expected_files" eq "@files" or
1833 fail "file list in $in_name varies between hash fields!";
1836 fail "$in_name has no files list field(s)";
1838 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1841 grep { keys %$_ == @$inputs-1 } values %fchecked
1842 or fail "no file appears in all file lists".
1843 " (looked in: ".$showinputs->().")";
1846 sub is_orig_file_in_dsc ($$) {
1847 my ($f, $dsc_files_info) = @_;
1848 return 0 if @$dsc_files_info <= 1;
1849 # One file means no origs, and the filename doesn't have a "what
1850 # part of dsc" component. (Consider versions ending `.orig'.)
1851 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1855 sub is_orig_file_of_vsn ($$) {
1856 my ($f, $upstreamvsn) = @_;
1857 my $base = srcfn $upstreamvsn, '';
1858 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1862 sub changes_update_origs_from_dsc ($$$$) {
1863 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1865 printdebug "checking origs needed ($upstreamvsn)...\n";
1866 $_ = getfield $changes, 'Files';
1867 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1868 fail "cannot find section/priority from .changes Files field";
1869 my $placementinfo = $1;
1871 printdebug "checking origs needed placement '$placementinfo'...\n";
1872 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1873 $l =~ m/\S+$/ or next;
1875 printdebug "origs $file | $l\n";
1876 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1877 printdebug "origs $file is_orig\n";
1878 my $have = archive_query('file_in_archive', $file);
1879 if (!defined $have) {
1881 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1887 printdebug "origs $file \$#\$have=$#$have\n";
1888 foreach my $h (@$have) {
1891 foreach my $csumi (@files_csum_info_fields) {
1892 my ($fname, $module, $method, $archivefield) = @$csumi;
1893 next unless defined $h->{$archivefield};
1894 $_ = $dsc->{$fname};
1895 next unless defined;
1896 m/^(\w+) .* \Q$file\E$/m or
1897 fail ".dsc $fname missing entry for $file";
1898 if ($h->{$archivefield} eq $1) {
1902 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1905 die "$file ".Dumper($h)." ?!" if $same && @differ;
1908 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1911 printdebug "origs $file f.same=$found_same".
1912 " #f._differ=$#found_differ\n";
1913 if (@found_differ && !$found_same) {
1915 "archive contains $file with different checksum",
1918 # Now we edit the changes file to add or remove it
1919 foreach my $csumi (@files_csum_info_fields) {
1920 my ($fname, $module, $method, $archivefield) = @$csumi;
1921 next unless defined $changes->{$fname};
1923 # in archive, delete from .changes if it's there
1924 $changed{$file} = "removed" if
1925 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1926 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1927 # not in archive, but it's here in the .changes
1929 my $dsc_data = getfield $dsc, $fname;
1930 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1932 $extra =~ s/ \d+ /$&$placementinfo /
1933 or die "$fname $extra >$dsc_data< ?"
1934 if $fname eq 'Files';
1935 $changes->{$fname} .= "\n". $extra;
1936 $changed{$file} = "added";
1941 foreach my $file (keys %changed) {
1943 "edited .changes for archive .orig contents: %s %s",
1944 $changed{$file}, $file;
1946 my $chtmp = "$changesfile.tmp";
1947 $changes->save($chtmp);
1949 rename $chtmp,$changesfile or die "$changesfile $!";
1951 progress "[new .changes left in $changesfile]";
1954 progress "$changesfile already has appropriate .orig(s) (if any)";
1958 sub make_commit ($) {
1960 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1963 sub make_commit_text ($) {
1966 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1968 print Dumper($text) if $debuglevel > 1;
1969 my $child = open2($out, $in, @cmd) or die $!;
1972 print $in $text or die $!;
1973 close $in or die $!;
1975 $h =~ m/^\w+$/ or die;
1977 printdebug "=> $h\n";
1980 waitpid $child, 0 == $child or die "$child $!";
1981 $? and failedcmd @cmd;
1985 sub clogp_authline ($) {
1987 my $author = getfield $clogp, 'Maintainer';
1988 $author =~ s#,.*##ms;
1989 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1990 my $authline = "$author $date";
1991 $authline =~ m/$git_authline_re/o or
1992 fail "unexpected commit author line format \`$authline'".
1993 " (was generated from changelog Maintainer field)";
1994 return ($1,$2,$3) if wantarray;
1998 sub vendor_patches_distro ($$) {
1999 my ($checkdistro, $what) = @_;
2000 return unless defined $checkdistro;
2002 my $series = "debian/patches/\L$checkdistro\E.series";
2003 printdebug "checking for vendor-specific $series ($what)\n";
2005 if (!open SERIES, "<", $series) {
2006 die "$series $!" unless $!==ENOENT;
2015 Unfortunately, this source package uses a feature of dpkg-source where
2016 the same source package unpacks to different source code on different
2017 distros. dgit cannot safely operate on such packages on affected
2018 distros, because the meaning of source packages is not stable.
2020 Please ask the distro/maintainer to remove the distro-specific series
2021 files and use a different technique (if necessary, uploading actually
2022 different packages, if different distros are supposed to have
2026 fail "Found active distro-specific series file for".
2027 " $checkdistro ($what): $series, cannot continue";
2029 die "$series $!" if SERIES->error;
2033 sub check_for_vendor_patches () {
2034 # This dpkg-source feature doesn't seem to be documented anywhere!
2035 # But it can be found in the changelog (reformatted):
2037 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2038 # Author: Raphael Hertzog <hertzog@debian.org>
2039 # Date: Sun Oct 3 09:36:48 2010 +0200
2041 # dpkg-source: correctly create .pc/.quilt_series with alternate
2044 # If you have debian/patches/ubuntu.series and you were
2045 # unpacking the source package on ubuntu, quilt was still
2046 # directed to debian/patches/series instead of
2047 # debian/patches/ubuntu.series.
2049 # debian/changelog | 3 +++
2050 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2051 # 2 files changed, 6 insertions(+), 1 deletion(-)
2054 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2055 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2056 "Dpkg::Vendor \`current vendor'");
2057 vendor_patches_distro(access_basedistro(),
2058 "(base) distro being accessed");
2059 vendor_patches_distro(access_nomdistro(),
2060 "(nominal) distro being accessed");
2063 sub generate_commits_from_dsc () {
2064 # See big comment in fetch_from_archive, below.
2065 # See also README.dsc-import.
2069 my @dfi = dsc_files_info();
2070 foreach my $fi (@dfi) {
2071 my $f = $fi->{Filename};
2072 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2074 printdebug "considering linking $f: ";
2076 link_ltarget "../../../../$f", $f
2077 or ((printdebug "($!) "), 0)
2081 printdebug "linked.\n";
2083 complete_file_from_dsc('.', $fi)
2086 if (is_orig_file_in_dsc($f, \@dfi)) {
2087 link $f, "../../../../$f"
2093 # We unpack and record the orig tarballs first, so that we only
2094 # need disk space for one private copy of the unpacked source.
2095 # But we can't make them into commits until we have the metadata
2096 # from the debian/changelog, so we record the tree objects now and
2097 # make them into commits later.
2099 my $upstreamv = upstreamversion $dsc->{version};
2100 my $orig_f_base = srcfn $upstreamv, '';
2102 foreach my $fi (@dfi) {
2103 # We actually import, and record as a commit, every tarball
2104 # (unless there is only one file, in which case there seems
2107 my $f = $fi->{Filename};
2108 printdebug "import considering $f ";
2109 (printdebug "only one dfi\n"), next if @dfi == 1;
2110 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2111 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2115 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2117 printdebug "Y ", (join ' ', map { $_//"(none)" }
2118 $compr_ext, $orig_f_part
2121 my $input = new IO::File $f, '<' or die "$f $!";
2125 if (defined $compr_ext) {
2127 Dpkg::Compression::compression_guess_from_filename $f;
2128 fail "Dpkg::Compression cannot handle file $f in source package"
2129 if defined $compr_ext && !defined $cname;
2131 new Dpkg::Compression::Process compression => $cname;
2132 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2133 my $compr_fh = new IO::Handle;
2134 my $compr_pid = open $compr_fh, "-|" // die $!;
2136 open STDIN, "<&", $input or die $!;
2138 die "dgit (child): exec $compr_cmd[0]: $!\n";
2143 rmtree "_unpack-tar";
2144 mkdir "_unpack-tar" or die $!;
2145 my @tarcmd = qw(tar -x -f -
2146 --no-same-owner --no-same-permissions
2147 --no-acls --no-xattrs --no-selinux);
2148 my $tar_pid = fork // die $!;
2150 chdir "_unpack-tar" or die $!;
2151 open STDIN, "<&", $input or die $!;
2153 die "dgit (child): exec $tarcmd[0]: $!";
2155 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2156 !$? or failedcmd @tarcmd;
2159 (@compr_cmd ? failedcmd @compr_cmd
2161 # finally, we have the results in "tarball", but maybe
2162 # with the wrong permissions
2164 runcmd qw(chmod -R +rwX _unpack-tar);
2165 changedir "_unpack-tar";
2166 remove_stray_gits($f);
2167 mktree_in_ud_here();
2169 my ($tree) = git_add_write_tree();
2170 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2171 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2173 printdebug "one subtree $1\n";
2175 printdebug "multiple subtrees\n";
2178 rmtree "_unpack-tar";
2180 my $ent = [ $f, $tree ];
2182 Orig => !!$orig_f_part,
2183 Sort => (!$orig_f_part ? 2 :
2184 $orig_f_part =~ m/-/g ? 1 :
2192 # put any without "_" first (spec is not clear whether files
2193 # are always in the usual order). Tarballs without "_" are
2194 # the main orig or the debian tarball.
2195 $a->{Sort} <=> $b->{Sort} or
2199 my $any_orig = grep { $_->{Orig} } @tartrees;
2201 my $dscfn = "$package.dsc";
2203 my $treeimporthow = 'package';
2205 open D, ">", $dscfn or die "$dscfn: $!";
2206 print D $dscdata or die "$dscfn: $!";
2207 close D or die "$dscfn: $!";
2208 my @cmd = qw(dpkg-source);
2209 push @cmd, '--no-check' if $dsc_checked;
2210 if (madformat $dsc->{format}) {
2211 push @cmd, '--skip-patches';
2212 $treeimporthow = 'unpatched';
2214 push @cmd, qw(-x --), $dscfn;
2217 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2218 if (madformat $dsc->{format}) {
2219 check_for_vendor_patches();
2223 if (madformat $dsc->{format}) {
2224 my @pcmd = qw(dpkg-source --before-build .);
2225 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2227 $dappliedtree = git_add_write_tree();
2230 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2231 debugcmd "|",@clogcmd;
2232 open CLOGS, "-|", @clogcmd or die $!;
2237 printdebug "import clog search...\n";
2240 my $stanzatext = do { local $/=""; <CLOGS>; };
2241 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2242 last if !defined $stanzatext;
2244 my $desc = "package changelog, entry no.$.";
2245 open my $stanzafh, "<", \$stanzatext or die;
2246 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2247 $clogp //= $thisstanza;
2249 printdebug "import clog $thisstanza->{version} $desc...\n";
2251 last if !$any_orig; # we don't need $r1clogp
2253 # We look for the first (most recent) changelog entry whose
2254 # version number is lower than the upstream version of this
2255 # package. Then the last (least recent) previous changelog
2256 # entry is treated as the one which introduced this upstream
2257 # version and used for the synthetic commits for the upstream
2260 # One might think that a more sophisticated algorithm would be
2261 # necessary. But: we do not want to scan the whole changelog
2262 # file. Stopping when we see an earlier version, which
2263 # necessarily then is an earlier upstream version, is the only
2264 # realistic way to do that. Then, either the earliest
2265 # changelog entry we have seen so far is indeed the earliest
2266 # upload of this upstream version; or there are only changelog
2267 # entries relating to later upstream versions (which is not
2268 # possible unless the changelog and .dsc disagree about the
2269 # version). Then it remains to choose between the physically
2270 # last entry in the file, and the one with the lowest version
2271 # number. If these are not the same, we guess that the
2272 # versions were created in a non-monotic order rather than
2273 # that the changelog entries have been misordered.
2275 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2277 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2278 $r1clogp = $thisstanza;
2280 printdebug "import clog $r1clogp->{version} becomes r1\n";
2282 die $! if CLOGS->error;
2283 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2285 $clogp or fail "package changelog has no entries!";
2287 my $authline = clogp_authline $clogp;
2288 my $changes = getfield $clogp, 'Changes';
2289 my $cversion = getfield $clogp, 'Version';
2292 $r1clogp //= $clogp; # maybe there's only one entry;
2293 my $r1authline = clogp_authline $r1clogp;
2294 # Strictly, r1authline might now be wrong if it's going to be
2295 # unused because !$any_orig. Whatever.
2297 printdebug "import tartrees authline $authline\n";
2298 printdebug "import tartrees r1authline $r1authline\n";
2300 foreach my $tt (@tartrees) {
2301 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2303 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2306 committer $r1authline
2310 [dgit import orig $tt->{F}]
2318 [dgit import tarball $package $cversion $tt->{F}]
2323 printdebug "import main commit\n";
2325 open C, ">../commit.tmp" or die $!;
2326 print C <<END or die $!;
2329 print C <<END or die $! foreach @tartrees;
2332 print C <<END or die $!;
2338 [dgit import $treeimporthow $package $cversion]
2342 my $rawimport_hash = make_commit qw(../commit.tmp);
2344 if (madformat $dsc->{format}) {
2345 printdebug "import apply patches...\n";
2347 # regularise the state of the working tree so that
2348 # the checkout of $rawimport_hash works nicely.
2349 my $dappliedcommit = make_commit_text(<<END);
2356 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2358 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2360 # We need the answers to be reproducible
2361 my @authline = clogp_authline($clogp);
2362 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2363 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2364 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2365 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2366 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2367 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2369 my $path = $ENV{PATH} or die;
2371 foreach my $use_absurd (qw(0 1)) {
2372 runcmd @git, qw(checkout -q unpa);
2373 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2374 local $ENV{PATH} = $path;
2377 progress "warning: $@";
2378 $path = "$absurdity:$path";
2379 progress "$us: trying slow absurd-git-apply...";
2380 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2385 die "forbid absurd git-apply\n" if $use_absurd
2386 && forceing [qw(import-gitapply-no-absurd)];
2387 die "only absurd git-apply!\n" if !$use_absurd
2388 && forceing [qw(import-gitapply-absurd)];
2390 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2391 local $ENV{PATH} = $path if $use_absurd;
2393 my @showcmd = (gbp_pq, qw(import));
2394 my @realcmd = shell_cmd
2395 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2396 debugcmd "+",@realcmd;
2397 if (system @realcmd) {
2398 die +(shellquote @showcmd).
2400 failedcmd_waitstatus()."\n";
2403 my $gapplied = git_rev_parse('HEAD');
2404 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2405 $gappliedtree eq $dappliedtree or
2407 gbp-pq import and dpkg-source disagree!
2408 gbp-pq import gave commit $gapplied
2409 gbp-pq import gave tree $gappliedtree
2410 dpkg-source --before-build gave tree $dappliedtree
2412 $rawimport_hash = $gapplied;
2417 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2422 progress "synthesised git commit from .dsc $cversion";
2424 my $rawimport_mergeinput = {
2425 Commit => $rawimport_hash,
2426 Info => "Import of source package",
2428 my @output = ($rawimport_mergeinput);
2430 if ($lastpush_mergeinput) {
2431 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2432 my $oversion = getfield $oldclogp, 'Version';
2434 version_compare($oversion, $cversion);
2436 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2437 { Message => <<END, ReverseParents => 1 });
2438 Record $package ($cversion) in archive suite $csuite
2440 } elsif ($vcmp > 0) {
2441 print STDERR <<END or die $!;
2443 Version actually in archive: $cversion (older)
2444 Last version pushed with dgit: $oversion (newer or same)
2447 @output = $lastpush_mergeinput;
2449 # Same version. Use what's in the server git branch,
2450 # discarding our own import. (This could happen if the
2451 # server automatically imports all packages into git.)
2452 @output = $lastpush_mergeinput;
2455 changedir '../../../..';
2460 sub complete_file_from_dsc ($$) {
2461 our ($dstdir, $fi) = @_;
2462 # Ensures that we have, in $dir, the file $fi, with the correct
2463 # contents. (Downloading it from alongside $dscurl if necessary.)
2465 my $f = $fi->{Filename};
2466 my $tf = "$dstdir/$f";
2469 if (stat_exists $tf) {
2470 progress "using existing $f";
2472 printdebug "$tf does not exist, need to fetch\n";
2474 $furl =~ s{/[^/]+$}{};
2476 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2477 die "$f ?" if $f =~ m#/#;
2478 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2479 return 0 if !act_local();
2483 open F, "<", "$tf" or die "$tf: $!";
2484 $fi->{Digester}->reset();
2485 $fi->{Digester}->addfile(*F);
2486 F->error and die $!;
2487 my $got = $fi->{Digester}->hexdigest();
2488 $got eq $fi->{Hash} or
2489 fail "file $f has hash $got but .dsc".
2490 " demands hash $fi->{Hash} ".
2491 ($downloaded ? "(got wrong file from archive!)"
2492 : "(perhaps you should delete this file?)");
2497 sub ensure_we_have_orig () {
2498 my @dfi = dsc_files_info();
2499 foreach my $fi (@dfi) {
2500 my $f = $fi->{Filename};
2501 next unless is_orig_file_in_dsc($f, \@dfi);
2502 complete_file_from_dsc('..', $fi)
2507 sub git_fetch_us () {
2508 # Want to fetch only what we are going to use, unless
2509 # deliberately-not-ff, in which case we must fetch everything.
2511 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2513 (quiltmode_splitbrain
2514 ? (map { $_->('*',access_nomdistro) }
2515 \&debiantag_new, \&debiantag_maintview)
2516 : debiantags('*',access_nomdistro));
2517 push @specs, server_branch($csuite);
2518 push @specs, $rewritemap;
2519 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2521 # This is rather miserable:
2522 # When git fetch --prune is passed a fetchspec ending with a *,
2523 # it does a plausible thing. If there is no * then:
2524 # - it matches subpaths too, even if the supplied refspec
2525 # starts refs, and behaves completely madly if the source
2526 # has refs/refs/something. (See, for example, Debian #NNNN.)
2527 # - if there is no matching remote ref, it bombs out the whole
2529 # We want to fetch a fixed ref, and we don't know in advance
2530 # if it exists, so this is not suitable.
2532 # Our workaround is to use git ls-remote. git ls-remote has its
2533 # own qairks. Notably, it has the absurd multi-tail-matching
2534 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2535 # refs/refs/foo etc.
2537 # Also, we want an idempotent snapshot, but we have to make two
2538 # calls to the remote: one to git ls-remote and to git fetch. The
2539 # solution is use git ls-remote to obtain a target state, and
2540 # git fetch to try to generate it. If we don't manage to generate
2541 # the target state, we try again.
2543 printdebug "git_fetch_us specs @specs\n";
2545 my $specre = join '|', map {
2551 printdebug "git_fetch_us specre=$specre\n";
2552 my $wanted_rref = sub {
2554 return m/^(?:$specre)$/o;
2557 my $fetch_iteration = 0;
2560 printdebug "git_fetch_us iteration $fetch_iteration\n";
2561 if (++$fetch_iteration > 10) {
2562 fail "too many iterations trying to get sane fetch!";
2565 my @look = map { "refs/$_" } @specs;
2566 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2570 open GITLS, "-|", @lcmd or die $!;
2572 printdebug "=> ", $_;
2573 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2574 my ($objid,$rrefname) = ($1,$2);
2575 if (!$wanted_rref->($rrefname)) {
2577 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2581 $wantr{$rrefname} = $objid;
2584 close GITLS or failedcmd @lcmd;
2586 # OK, now %want is exactly what we want for refs in @specs
2588 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2589 "+refs/$_:".lrfetchrefs."/$_";
2592 printdebug "git_fetch_us fspecs @fspecs\n";
2594 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2595 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2598 %lrfetchrefs_f = ();
2601 git_for_each_ref(lrfetchrefs, sub {
2602 my ($objid,$objtype,$lrefname,$reftail) = @_;
2603 $lrfetchrefs_f{$lrefname} = $objid;
2604 $objgot{$objid} = 1;
2607 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2608 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2609 if (!exists $wantr{$rrefname}) {
2610 if ($wanted_rref->($rrefname)) {
2612 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2616 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2619 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2620 delete $lrfetchrefs_f{$lrefname};
2624 foreach my $rrefname (sort keys %wantr) {
2625 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2626 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2627 my $want = $wantr{$rrefname};
2628 next if $got eq $want;
2629 if (!defined $objgot{$want}) {
2631 warning: git ls-remote suggests we want $lrefname
2632 warning: and it should refer to $want
2633 warning: but git fetch didn't fetch that object to any relevant ref.
2634 warning: This may be due to a race with someone updating the server.
2635 warning: Will try again...
2637 next FETCH_ITERATION;
2640 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2642 runcmd_ordryrun_local @git, qw(update-ref -m),
2643 "dgit fetch git fetch fixup", $lrefname, $want;
2644 $lrfetchrefs_f{$lrefname} = $want;
2648 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2649 Dumper(\%lrfetchrefs_f);
2652 my @tagpats = debiantags('*',access_nomdistro);
2654 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2655 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2656 printdebug "currently $fullrefname=$objid\n";
2657 $here{$fullrefname} = $objid;
2659 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2660 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2661 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2662 printdebug "offered $lref=$objid\n";
2663 if (!defined $here{$lref}) {
2664 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2665 runcmd_ordryrun_local @upd;
2666 lrfetchref_used $fullrefname;
2667 } elsif ($here{$lref} eq $objid) {
2668 lrfetchref_used $fullrefname;
2671 "Not updateting $lref from $here{$lref} to $objid.\n";
2676 sub mergeinfo_getclogp ($) {
2677 # Ensures thit $mi->{Clogp} exists and returns it
2679 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2682 sub mergeinfo_version ($) {
2683 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2686 sub fetch_from_archive_record_1 ($) {
2688 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2689 'DGIT_ARCHIVE', $hash;
2690 cmdoutput @git, qw(log -n2), $hash;
2691 # ... gives git a chance to complain if our commit is malformed
2694 sub fetch_from_archive_record_2 ($) {
2696 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2700 dryrun_report @upd_cmd;
2704 sub fetch_from_archive () {
2705 ensure_setup_existing_tree();
2707 # Ensures that lrref() is what is actually in the archive, one way
2708 # or another, according to us - ie this client's
2709 # appropritaely-updated archive view. Also returns the commit id.
2710 # If there is nothing in the archive, leaves lrref alone and
2711 # returns undef. git_fetch_us must have already been called.
2715 foreach my $field (@ourdscfield) {
2716 $dsc_hash = $dsc->{$field};
2717 last if defined $dsc_hash;
2719 if (defined $dsc_hash) {
2720 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2722 progress "last upload to archive specified git hash";
2724 progress "last upload to archive has NO git hash";
2727 progress "no version available from the archive";
2730 my $rewritemapdata = git_cat_file lrfetchrefs."/".$rewritemap.':map';
2731 if (defined $rewritemapdata
2732 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2733 progress "server's git history rewrite map contains a relevant entry!";
2735 if (defined $dsc_hash) {
2736 progress "using rewritten git hash in place of .dsc value";
2738 progress "server data says .dsc hash is to be disregarded";
2742 # If the archive's .dsc has a Dgit field, there are three
2743 # relevant git commitids we need to choose between and/or merge
2745 # 1. $dsc_hash: the Dgit field from the archive
2746 # 2. $lastpush_hash: the suite branch on the dgit git server
2747 # 3. $lastfetch_hash: our local tracking brach for the suite
2749 # These may all be distinct and need not be in any fast forward
2752 # If the dsc was pushed to this suite, then the server suite
2753 # branch will have been updated; but it might have been pushed to
2754 # a different suite and copied by the archive. Conversely a more
2755 # recent version may have been pushed with dgit but not appeared
2756 # in the archive (yet).
2758 # $lastfetch_hash may be awkward because archive imports
2759 # (particularly, imports of Dgit-less .dscs) are performed only as
2760 # needed on individual clients, so different clients may perform a
2761 # different subset of them - and these imports are only made
2762 # public during push. So $lastfetch_hash may represent a set of
2763 # imports different to a subsequent upload by a different dgit
2766 # Our approach is as follows:
2768 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2769 # descendant of $dsc_hash, then it was pushed by a dgit user who
2770 # had based their work on $dsc_hash, so we should prefer it.
2771 # Otherwise, $dsc_hash was installed into this suite in the
2772 # archive other than by a dgit push, and (necessarily) after the
2773 # last dgit push into that suite (since a dgit push would have
2774 # been descended from the dgit server git branch); thus, in that
2775 # case, we prefer the archive's version (and produce a
2776 # pseudo-merge to overwrite the dgit server git branch).
2778 # (If there is no Dgit field in the archive's .dsc then
2779 # generate_commit_from_dsc uses the version numbers to decide
2780 # whether the suite branch or the archive is newer. If the suite
2781 # branch is newer it ignores the archive's .dsc; otherwise it
2782 # generates an import of the .dsc, and produces a pseudo-merge to
2783 # overwrite the suite branch with the archive contents.)
2785 # The outcome of that part of the algorithm is the `public view',
2786 # and is same for all dgit clients: it does not depend on any
2787 # unpublished history in the local tracking branch.
2789 # As between the public view and the local tracking branch: The
2790 # local tracking branch is only updated by dgit fetch, and
2791 # whenever dgit fetch runs it includes the public view in the
2792 # local tracking branch. Therefore if the public view is not
2793 # descended from the local tracking branch, the local tracking
2794 # branch must contain history which was imported from the archive
2795 # but never pushed; and, its tip is now out of date. So, we make
2796 # a pseudo-merge to overwrite the old imports and stitch the old
2799 # Finally: we do not necessarily reify the public view (as
2800 # described above). This is so that we do not end up stacking two
2801 # pseudo-merges. So what we actually do is figure out the inputs
2802 # to any public view pseudo-merge and put them in @mergeinputs.
2805 # $mergeinputs[]{Commit}
2806 # $mergeinputs[]{Info}
2807 # $mergeinputs[0] is the one whose tree we use
2808 # @mergeinputs is in the order we use in the actual commit)
2811 # $mergeinputs[]{Message} is a commit message to use
2812 # $mergeinputs[]{ReverseParents} if def specifies that parent
2813 # list should be in opposite order
2814 # Such an entry has no Commit or Info. It applies only when found
2815 # in the last entry. (This ugliness is to support making
2816 # identical imports to previous dgit versions.)
2818 my $lastpush_hash = git_get_ref(lrfetchref());
2819 printdebug "previous reference hash=$lastpush_hash\n";
2820 $lastpush_mergeinput = $lastpush_hash && {
2821 Commit => $lastpush_hash,
2822 Info => "dgit suite branch on dgit git server",
2825 my $lastfetch_hash = git_get_ref(lrref());
2826 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2827 my $lastfetch_mergeinput = $lastfetch_hash && {
2828 Commit => $lastfetch_hash,
2829 Info => "dgit client's archive history view",
2832 my $dsc_mergeinput = $dsc_hash && {
2833 Commit => $dsc_hash,
2834 Info => "Dgit field in .dsc from archive",
2838 my $del_lrfetchrefs = sub {
2841 printdebug "del_lrfetchrefs...\n";
2842 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2843 my $objid = $lrfetchrefs_d{$fullrefname};
2844 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2846 $gur ||= new IO::Handle;
2847 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2849 printf $gur "delete %s %s\n", $fullrefname, $objid;
2852 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2856 if (defined $dsc_hash) {
2857 ensure_we_have_orig();
2858 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2859 @mergeinputs = $dsc_mergeinput
2860 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2861 print STDERR <<END or die $!;
2863 Git commit in archive is behind the last version allegedly pushed/uploaded.
2864 Commit referred to by archive: $dsc_hash
2865 Last version pushed with dgit: $lastpush_hash
2868 @mergeinputs = ($lastpush_mergeinput);
2870 # Archive has .dsc which is not a descendant of the last dgit
2871 # push. This can happen if the archive moves .dscs about.
2872 # Just follow its lead.
2873 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2874 progress "archive .dsc names newer git commit";
2875 @mergeinputs = ($dsc_mergeinput);
2877 progress "archive .dsc names other git commit, fixing up";
2878 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2882 @mergeinputs = generate_commits_from_dsc();
2883 # We have just done an import. Now, our import algorithm might
2884 # have been improved. But even so we do not want to generate
2885 # a new different import of the same package. So if the
2886 # version numbers are the same, just use our existing version.
2887 # If the version numbers are different, the archive has changed
2888 # (perhaps, rewound).
2889 if ($lastfetch_mergeinput &&
2890 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2891 (mergeinfo_version $mergeinputs[0]) )) {
2892 @mergeinputs = ($lastfetch_mergeinput);
2894 } elsif ($lastpush_hash) {
2895 # only in git, not in the archive yet
2896 @mergeinputs = ($lastpush_mergeinput);
2897 print STDERR <<END or die $!;
2899 Package not found in the archive, but has allegedly been pushed using dgit.
2903 printdebug "nothing found!\n";
2904 if (defined $skew_warning_vsn) {
2905 print STDERR <<END or die $!;
2907 Warning: relevant archive skew detected.
2908 Archive allegedly contains $skew_warning_vsn
2909 But we were not able to obtain any version from the archive or git.
2913 unshift @end, $del_lrfetchrefs;
2917 if ($lastfetch_hash &&
2919 my $h = $_->{Commit};
2920 $h and is_fast_fwd($lastfetch_hash, $h);
2921 # If true, one of the existing parents of this commit
2922 # is a descendant of the $lastfetch_hash, so we'll
2923 # be ff from that automatically.
2927 push @mergeinputs, $lastfetch_mergeinput;
2930 printdebug "fetch mergeinfos:\n";
2931 foreach my $mi (@mergeinputs) {
2933 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2935 printdebug sprintf " ReverseParents=%d Message=%s",
2936 $mi->{ReverseParents}, $mi->{Message};
2940 my $compat_info= pop @mergeinputs
2941 if $mergeinputs[$#mergeinputs]{Message};
2943 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2946 if (@mergeinputs > 1) {
2948 my $tree_commit = $mergeinputs[0]{Commit};
2950 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2951 $tree =~ m/\n\n/; $tree = $`;
2952 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2955 # We use the changelog author of the package in question the
2956 # author of this pseudo-merge. This is (roughly) correct if
2957 # this commit is simply representing aa non-dgit upload.
2958 # (Roughly because it does not record sponsorship - but we
2959 # don't have sponsorship info because that's in the .changes,
2960 # which isn't in the archivw.)
2962 # But, it might be that we are representing archive history
2963 # updates (including in-archive copies). These are not really
2964 # the responsibility of the person who created the .dsc, but
2965 # there is no-one whose name we should better use. (The
2966 # author of the .dsc-named commit is clearly worse.)
2968 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2969 my $author = clogp_authline $useclogp;
2970 my $cversion = getfield $useclogp, 'Version';
2972 my $mcf = ".git/dgit/mergecommit";
2973 open MC, ">", $mcf or die "$mcf $!";
2974 print MC <<END or die $!;
2978 my @parents = grep { $_->{Commit} } @mergeinputs;
2979 @parents = reverse @parents if $compat_info->{ReverseParents};
2980 print MC <<END or die $! foreach @parents;
2984 print MC <<END or die $!;
2990 if (defined $compat_info->{Message}) {
2991 print MC $compat_info->{Message} or die $!;
2993 print MC <<END or die $!;
2994 Record $package ($cversion) in archive suite $csuite
2998 my $message_add_info = sub {
3000 my $mversion = mergeinfo_version $mi;
3001 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3005 $message_add_info->($mergeinputs[0]);
3006 print MC <<END or die $!;
3007 should be treated as descended from
3009 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3013 $hash = make_commit $mcf;
3015 $hash = $mergeinputs[0]{Commit};
3017 printdebug "fetch hash=$hash\n";
3020 my ($lasth, $what) = @_;
3021 return unless $lasth;
3022 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3025 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3027 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3029 fetch_from_archive_record_1($hash);
3031 if (defined $skew_warning_vsn) {
3033 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3034 my $gotclogp = commit_getclogp($hash);
3035 my $got_vsn = getfield $gotclogp, 'Version';
3036 printdebug "SKEW CHECK GOT $got_vsn\n";
3037 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3038 print STDERR <<END or die $!;
3040 Warning: archive skew detected. Using the available version:
3041 Archive allegedly contains $skew_warning_vsn
3042 We were able to obtain only $got_vsn
3048 if ($lastfetch_hash ne $hash) {
3049 fetch_from_archive_record_2($hash);
3052 lrfetchref_used lrfetchref();
3054 unshift @end, $del_lrfetchrefs;
3058 sub set_local_git_config ($$) {
3060 runcmd @git, qw(config), $k, $v;
3063 sub setup_mergechangelogs (;$) {
3065 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3067 my $driver = 'dpkg-mergechangelogs';
3068 my $cb = "merge.$driver";
3069 my $attrs = '.git/info/attributes';
3070 ensuredir '.git/info';
3072 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3073 if (!open ATTRS, "<", $attrs) {
3074 $!==ENOENT or die "$attrs: $!";
3078 next if m{^debian/changelog\s};
3079 print NATTRS $_, "\n" or die $!;
3081 ATTRS->error and die $!;
3084 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3087 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3088 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3090 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3093 sub setup_useremail (;$) {
3095 return unless $always || access_cfg_bool(1, 'setup-useremail');
3098 my ($k, $envvar) = @_;
3099 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3100 return unless defined $v;
3101 set_local_git_config "user.$k", $v;
3104 $setup->('email', 'DEBEMAIL');
3105 $setup->('name', 'DEBFULLNAME');
3108 sub ensure_setup_existing_tree () {
3109 my $k = "remote.$remotename.skipdefaultupdate";
3110 my $c = git_get_config $k;
3111 return if defined $c;
3112 set_local_git_config $k, 'true';
3115 sub setup_new_tree () {
3116 setup_mergechangelogs();
3120 sub multisuite_suite_child ($$$) {
3121 my ($tsuite, $merginputs, $fn) = @_;
3122 # in child, sets things up, calls $fn->(), and returns undef
3123 # in parent, returns canonical suite name for $tsuite
3124 my $canonsuitefh = IO::File::new_tmpfile;
3125 my $pid = fork // die $!;
3128 $us .= " [$isuite]";
3129 $debugprefix .= " ";
3130 progress "fetching $tsuite...";
3131 canonicalise_suite();
3132 print $canonsuitefh $csuite, "\n" or die $!;
3133 close $canonsuitefh or die $!;
3137 waitpid $pid,0 == $pid or die $!;
3138 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3139 seek $canonsuitefh,0,0 or die $!;
3140 local $csuite = <$canonsuitefh>;
3141 die $! unless defined $csuite && chomp $csuite;
3143 printdebug "multisuite $tsuite missing\n";
3146 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3147 push @$merginputs, {
3154 sub fork_for_multisuite ($) {
3155 my ($before_fetch_merge) = @_;
3156 # if nothing unusual, just returns ''
3159 # returns 0 to caller in child, to do first of the specified suites
3160 # in child, $csuite is not yet set
3162 # returns 1 to caller in parent, to finish up anything needed after
3163 # in parent, $csuite is set to canonicalised portmanteau
3165 my $org_isuite = $isuite;
3166 my @suites = split /\,/, $isuite;
3167 return '' unless @suites > 1;
3168 printdebug "fork_for_multisuite: @suites\n";
3172 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3174 return 0 unless defined $cbasesuite;
3176 fail "package $package missing in (base suite) $cbasesuite"
3177 unless @mergeinputs;
3179 my @csuites = ($cbasesuite);
3181 $before_fetch_merge->();
3183 foreach my $tsuite (@suites[1..$#suites]) {
3184 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3190 # xxx collecte the ref here
3192 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3193 push @csuites, $csubsuite;
3196 foreach my $mi (@mergeinputs) {
3197 my $ref = git_get_ref $mi->{Ref};
3198 die "$mi->{Ref} ?" unless length $ref;
3199 $mi->{Commit} = $ref;
3202 $csuite = join ",", @csuites;
3204 my $previous = git_get_ref lrref;
3206 unshift @mergeinputs, {
3207 Commit => $previous,
3208 Info => "local combined tracking branch",
3210 "archive seems to have rewound: local tracking branch is ahead!",
3214 foreach my $ix (0..$#mergeinputs) {
3215 $mergeinputs[$ix]{Index} = $ix;
3218 @mergeinputs = sort {
3219 -version_compare(mergeinfo_version $a,
3220 mergeinfo_version $b) # highest version first
3222 $a->{Index} <=> $b->{Index}; # earliest in spec first
3228 foreach my $mi (@mergeinputs) {
3229 printdebug "multisuite merge check $mi->{Info}\n";
3230 foreach my $previous (@needed) {
3231 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3232 printdebug "multisuite merge un-needed $previous->{Info}\n";
3236 printdebug "multisuite merge this-needed\n";
3237 $mi->{Character} = '+';
3240 $needed[0]{Character} = '*';
3242 my $output = $needed[0]{Commit};
3245 printdebug "multisuite merge nontrivial\n";
3246 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3248 my $commit = "tree $tree\n";
3249 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3250 "Input branches:\n";
3252 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3253 printdebug "multisuite merge include $mi->{Info}\n";
3254 $mi->{Character} //= ' ';
3255 $commit .= "parent $mi->{Commit}\n";
3256 $msg .= sprintf " %s %-25s %s\n",
3258 (mergeinfo_version $mi),
3261 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3263 " * marks the highest version branch, which choose to use\n".
3264 " + marks each branch which was not already an ancestor\n\n".
3265 "[dgit multi-suite $csuite]\n";
3267 "author $authline\n".
3268 "committer $authline\n\n";
3269 $output = make_commit_text $commit.$msg;
3270 printdebug "multisuite merge generated $output\n";
3273 fetch_from_archive_record_1($output);
3274 fetch_from_archive_record_2($output);
3276 progress "calculated combined tracking suite $csuite";
3281 sub clone_set_head () {
3282 open H, "> .git/HEAD" or die $!;
3283 print H "ref: ".lref()."\n" or die $!;
3286 sub clone_finish ($) {
3288 runcmd @git, qw(reset --hard), lrref();
3289 runcmd qw(bash -ec), <<'END';
3291 git ls-tree -r --name-only -z HEAD | \
3292 xargs -0r touch -h -r . --
3294 printdone "ready for work in $dstdir";
3299 badusage "dry run makes no sense with clone" unless act_local();
3301 my $multi_fetched = fork_for_multisuite(sub {
3302 printdebug "multi clone before fetch merge\n";
3305 if ($multi_fetched) {
3306 printdebug "multi clone after fetch merge\n";
3308 clone_finish($dstdir);
3311 printdebug "clone main body\n";
3313 canonicalise_suite();
3314 my $hasgit = check_for_git();
3315 mkdir $dstdir or fail "create \`$dstdir': $!";
3317 runcmd @git, qw(init -q);
3319 my $giturl = access_giturl(1);
3320 if (defined $giturl) {
3321 runcmd @git, qw(remote add), 'origin', $giturl;
3324 progress "fetching existing git history";
3326 runcmd_ordryrun_local @git, qw(fetch origin);
3328 progress "starting new git history";
3330 fetch_from_archive() or no_such_package;
3331 my $vcsgiturl = $dsc->{'Vcs-Git'};
3332 if (length $vcsgiturl) {
3333 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3334 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3337 clone_finish($dstdir);
3341 canonicalise_suite();
3342 if (check_for_git()) {
3345 fetch_from_archive() or no_such_package();
3346 printdone "fetched into ".lrref();
3350 my $multi_fetched = fork_for_multisuite(sub { });
3351 fetch() unless $multi_fetched; # parent
3352 return if $multi_fetched eq '0'; # child
3353 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3355 printdone "fetched to ".lrref()." and merged into HEAD";
3358 sub check_not_dirty () {
3359 foreach my $f (qw(local-options local-patch-header)) {
3360 if (stat_exists "debian/source/$f") {
3361 fail "git tree contains debian/source/$f";
3365 return if $ignoredirty;
3367 my @cmd = (@git, qw(diff --quiet HEAD));
3369 $!=0; $?=-1; system @cmd;
3372 fail "working tree is dirty (does not match HEAD)";
3378 sub commit_admin ($) {
3381 runcmd_ordryrun_local @git, qw(commit -m), $m;
3384 sub commit_quilty_patch () {
3385 my $output = cmdoutput @git, qw(status --porcelain);
3387 foreach my $l (split /\n/, $output) {
3388 next unless $l =~ m/\S/;
3389 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3393 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3395 progress "nothing quilty to commit, ok.";
3398 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3399 runcmd_ordryrun_local @git, qw(add -f), @adds;
3401 Commit Debian 3.0 (quilt) metadata
3403 [dgit ($our_version) quilt-fixup]
3407 sub get_source_format () {
3409 if (open F, "debian/source/options") {
3413 s/\s+$//; # ignore missing final newline
3415 my ($k, $v) = ($`, $'); #');
3416 $v =~ s/^"(.*)"$/$1/;
3422 F->error and die $!;
3425 die $! unless $!==&ENOENT;
3428 if (!open F, "debian/source/format") {
3429 die $! unless $!==&ENOENT;
3433 F->error and die $!;
3435 return ($_, \%options);
3438 sub madformat_wantfixup ($) {
3440 return 0 unless $format eq '3.0 (quilt)';
3441 our $quilt_mode_warned;
3442 if ($quilt_mode eq 'nocheck') {
3443 progress "Not doing any fixup of \`$format' due to".
3444 " ----no-quilt-fixup or --quilt=nocheck"
3445 unless $quilt_mode_warned++;
3448 progress "Format \`$format', need to check/update patch stack"
3449 unless $quilt_mode_warned++;
3453 sub maybe_split_brain_save ($$$) {
3454 my ($headref, $dgitview, $msg) = @_;
3455 # => message fragment "$saved" describing disposition of $dgitview
3456 return "commit id $dgitview" unless defined $split_brain_save;
3457 my @cmd = (shell_cmd "cd ../../../..",
3458 @git, qw(update-ref -m),
3459 "dgit --dgit-view-save $msg HEAD=$headref",
3460 $split_brain_save, $dgitview);
3462 return "and left in $split_brain_save";
3465 # An "infopair" is a tuple [ $thing, $what ]
3466 # (often $thing is a commit hash; $what is a description)
3468 sub infopair_cond_equal ($$) {
3470 $x->[0] eq $y->[0] or fail <<END;
3471 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3475 sub infopair_lrf_tag_lookup ($$) {
3476 my ($tagnames, $what) = @_;
3477 # $tagname may be an array ref
3478 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3479 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3480 foreach my $tagname (@tagnames) {
3481 my $lrefname = lrfetchrefs."/tags/$tagname";
3482 my $tagobj = $lrfetchrefs_f{$lrefname};
3483 next unless defined $tagobj;
3484 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3485 return [ git_rev_parse($tagobj), $what ];
3487 fail @tagnames==1 ? <<END : <<END;
3488 Wanted tag $what (@tagnames) on dgit server, but not found
3490 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3494 sub infopair_cond_ff ($$) {
3495 my ($anc,$desc) = @_;
3496 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3497 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3501 sub pseudomerge_version_check ($$) {
3502 my ($clogp, $archive_hash) = @_;
3504 my $arch_clogp = commit_getclogp $archive_hash;
3505 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3506 'version currently in archive' ];
3507 if (defined $overwrite_version) {
3508 if (length $overwrite_version) {
3509 infopair_cond_equal([ $overwrite_version,
3510 '--overwrite= version' ],
3513 my $v = $i_arch_v->[0];
3514 progress "Checking package changelog for archive version $v ...";
3516 my @xa = ("-f$v", "-t$v");
3517 my $vclogp = parsechangelog @xa;
3518 my $cv = [ (getfield $vclogp, 'Version'),
3519 "Version field from dpkg-parsechangelog @xa" ];
3520 infopair_cond_equal($i_arch_v, $cv);
3523 $@ =~ s/^dgit: //gm;
3525 "Perhaps debian/changelog does not mention $v ?";
3530 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3534 sub pseudomerge_make_commit ($$$$ $$) {
3535 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3536 $msg_cmd, $msg_msg) = @_;
3537 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3539 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3540 my $authline = clogp_authline $clogp;
3544 !defined $overwrite_version ? ""
3545 : !length $overwrite_version ? " --overwrite"
3546 : " --overwrite=".$overwrite_version;
3549 my $pmf = ".git/dgit/pseudomerge";
3550 open MC, ">", $pmf or die "$pmf $!";
3551 print MC <<END or die $!;
3554 parent $archive_hash
3564 return make_commit($pmf);
3567 sub splitbrain_pseudomerge ($$$$) {
3568 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3569 # => $merged_dgitview
3570 printdebug "splitbrain_pseudomerge...\n";
3572 # We: debian/PREVIOUS HEAD($maintview)
3573 # expect: o ----------------- o
3576 # a/d/PREVIOUS $dgitview
3579 # we do: `------------------ o
3583 return $dgitview unless defined $archive_hash;
3585 printdebug "splitbrain_pseudomerge...\n";
3587 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3589 if (!defined $overwrite_version) {
3590 progress "Checking that HEAD inciudes all changes in archive...";
3593 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3595 if (defined $overwrite_version) {
3597 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3598 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3599 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3600 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3601 my $i_archive = [ $archive_hash, "current archive contents" ];
3603 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3605 infopair_cond_equal($i_dgit, $i_archive);
3606 infopair_cond_ff($i_dep14, $i_dgit);
3607 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3611 $us: check failed (maybe --overwrite is needed, consult documentation)
3616 my $r = pseudomerge_make_commit
3617 $clogp, $dgitview, $archive_hash, $i_arch_v,
3618 "dgit --quilt=$quilt_mode",
3619 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3620 Declare fast forward from $i_arch_v->[0]
3622 Make fast forward from $i_arch_v->[0]
3625 maybe_split_brain_save $maintview, $r, "pseudomerge";
3627 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3631 sub plain_overwrite_pseudomerge ($$$) {
3632 my ($clogp, $head, $archive_hash) = @_;
3634 printdebug "plain_overwrite_pseudomerge...";
3636 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3638 return $head if is_fast_fwd $archive_hash, $head;
3640 my $m = "Declare fast forward from $i_arch_v->[0]";
3642 my $r = pseudomerge_make_commit
3643 $clogp, $head, $archive_hash, $i_arch_v,
3646 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3648 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3652 sub push_parse_changelog ($) {
3655 my $clogp = Dpkg::Control::Hash->new();
3656 $clogp->load($clogpfn) or die;
3658 my $clogpackage = getfield $clogp, 'Source';
3659 $package //= $clogpackage;
3660 fail "-p specified $package but changelog specified $clogpackage"
3661 unless $package eq $clogpackage;
3662 my $cversion = getfield $clogp, 'Version';
3663 my $tag = debiantag($cversion, access_nomdistro);
3664 runcmd @git, qw(check-ref-format), $tag;
3666 my $dscfn = dscfn($cversion);
3668 return ($clogp, $cversion, $dscfn);
3671 sub push_parse_dsc ($$$) {
3672 my ($dscfn,$dscfnwhat, $cversion) = @_;
3673 $dsc = parsecontrol($dscfn,$dscfnwhat);
3674 my $dversion = getfield $dsc, 'Version';
3675 my $dscpackage = getfield $dsc, 'Source';
3676 ($dscpackage eq $package && $dversion eq $cversion) or
3677 fail "$dscfn is for $dscpackage $dversion".
3678 " but debian/changelog is for $package $cversion";
3681 sub push_tagwants ($$$$) {
3682 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3685 TagFn => \&debiantag,
3690 if (defined $maintviewhead) {
3692 TagFn => \&debiantag_maintview,
3693 Objid => $maintviewhead,
3694 TfSuffix => '-maintview',
3697 } elsif ($dodep14tag eq 'no' ? 0
3698 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3699 : $dodep14tag eq 'always'
3700 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3701 --dep14tag-always (or equivalent in config) means server must support
3702 both "new" and "maint" tag formats, but config says it doesn't.
3704 : die "$dodep14tag ?") {
3706 TagFn => \&debiantag_maintview,
3708 TfSuffix => '-dgit',
3712 foreach my $tw (@tagwants) {
3713 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3714 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3716 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3720 sub push_mktags ($$ $$ $) {
3722 $changesfile,$changesfilewhat,
3725 die unless $tagwants->[0]{View} eq 'dgit';
3727 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3728 $dsc->save("$dscfn.tmp") or die $!;
3730 my $changes = parsecontrol($changesfile,$changesfilewhat);
3731 foreach my $field (qw(Source Distribution Version)) {
3732 $changes->{$field} eq $clogp->{$field} or
3733 fail "changes field $field \`$changes->{$field}'".
3734 " does not match changelog \`$clogp->{$field}'";
3737 my $cversion = getfield $clogp, 'Version';
3738 my $clogsuite = getfield $clogp, 'Distribution';
3740 # We make the git tag by hand because (a) that makes it easier
3741 # to control the "tagger" (b) we can do remote signing
3742 my $authline = clogp_authline $clogp;
3743 my $delibs = join(" ", "",@deliberatelies);
3744 my $declaredistro = access_nomdistro();
3748 my $tfn = $tw->{Tfn};
3749 my $head = $tw->{Objid};
3750 my $tag = $tw->{Tag};
3752 open TO, '>', $tfn->('.tmp') or die $!;
3753 print TO <<END or die $!;
3760 if ($tw->{View} eq 'dgit') {
3761 print TO <<END or die $!;
3762 $package release $cversion for $clogsuite ($csuite) [dgit]
3763 [dgit distro=$declaredistro$delibs]
3765 foreach my $ref (sort keys %previously) {
3766 print TO <<END or die $!;
3767 [dgit previously:$ref=$previously{$ref}]
3770 } elsif ($tw->{View} eq 'maint') {
3771 print TO <<END or die $!;
3772 $package release $cversion for $clogsuite ($csuite)
3773 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3776 die Dumper($tw)."?";
3781 my $tagobjfn = $tfn->('.tmp');
3783 if (!defined $keyid) {
3784 $keyid = access_cfg('keyid','RETURN-UNDEF');
3786 if (!defined $keyid) {
3787 $keyid = getfield $clogp, 'Maintainer';
3789 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3790 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3791 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3792 push @sign_cmd, $tfn->('.tmp');
3793 runcmd_ordryrun @sign_cmd;
3795 $tagobjfn = $tfn->('.signed.tmp');
3796 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3797 $tfn->('.tmp'), $tfn->('.tmp.asc');
3803 my @r = map { $mktag->($_); } @$tagwants;
3807 sub sign_changes ($) {
3808 my ($changesfile) = @_;
3810 my @debsign_cmd = @debsign;
3811 push @debsign_cmd, "-k$keyid" if defined $keyid;
3812 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3813 push @debsign_cmd, $changesfile;
3814 runcmd_ordryrun @debsign_cmd;
3819 printdebug "actually entering push\n";
3821 supplementary_message(<<'END');
3822 Push failed, while checking state of the archive.
3823 You can retry the push, after fixing the problem, if you like.
3825 if (check_for_git()) {
3828 my $archive_hash = fetch_from_archive();
3829 if (!$archive_hash) {
3831 fail "package appears to be new in this suite;".
3832 " if this is intentional, use --new";
3835 supplementary_message(<<'END');
3836 Push failed, while preparing your push.
3837 You can retry the push, after fixing the problem, if you like.
3840 need_tagformat 'new', "quilt mode $quilt_mode"
3841 if quiltmode_splitbrain;
3845 access_giturl(); # check that success is vaguely likely
3848 my $clogpfn = ".git/dgit/changelog.822.tmp";
3849 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3851 responder_send_file('parsed-changelog', $clogpfn);
3853 my ($clogp, $cversion, $dscfn) =
3854 push_parse_changelog("$clogpfn");
3856 my $dscpath = "$buildproductsdir/$dscfn";
3857 stat_exists $dscpath or
3858 fail "looked for .dsc $dscpath, but $!;".
3859 " maybe you forgot to build";
3861 responder_send_file('dsc', $dscpath);
3863 push_parse_dsc($dscpath, $dscfn, $cversion);
3865 my $format = getfield $dsc, 'Format';
3866 printdebug "format $format\n";
3868 my $actualhead = git_rev_parse('HEAD');
3869 my $dgithead = $actualhead;
3870 my $maintviewhead = undef;
3872 my $upstreamversion = upstreamversion $clogp->{Version};
3874 if (madformat_wantfixup($format)) {
3875 # user might have not used dgit build, so maybe do this now:
3876 if (quiltmode_splitbrain()) {
3878 quilt_make_fake_dsc($upstreamversion);
3880 ($dgithead, $cachekey) =
3881 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3883 "--quilt=$quilt_mode but no cached dgit view:
3884 perhaps tree changed since dgit build[-source] ?";
3886 $dgithead = splitbrain_pseudomerge($clogp,
3887 $actualhead, $dgithead,
3889 $maintviewhead = $actualhead;
3890 changedir '../../../..';
3891 prep_ud(); # so _only_subdir() works, below
3893 commit_quilty_patch();
3897 if (defined $overwrite_version && !defined $maintviewhead) {
3898 $dgithead = plain_overwrite_pseudomerge($clogp,
3906 if ($archive_hash) {
3907 if (is_fast_fwd($archive_hash, $dgithead)) {
3909 } elsif (deliberately_not_fast_forward) {
3912 fail "dgit push: HEAD is not a descendant".
3913 " of the archive's version.\n".
3914 "To overwrite the archive's contents,".
3915 " pass --overwrite[=VERSION].\n".
3916 "To rewind history, if permitted by the archive,".
3917 " use --deliberately-not-fast-forward.";
3922 progress "checking that $dscfn corresponds to HEAD";
3923 runcmd qw(dpkg-source -x --),
3924 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3925 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
3926 check_for_vendor_patches() if madformat($dsc->{format});
3927 changedir '../../../..';
3928 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3929 debugcmd "+",@diffcmd;
3931 my $r = system @diffcmd;
3934 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3936 HEAD specifies a different tree to $dscfn:
3938 Perhaps you forgot to build. Or perhaps there is a problem with your
3939 source tree (see dgit(7) for some hints). To see a full diff, run
3946 if (!$changesfile) {
3947 my $pat = changespat $cversion;
3948 my @cs = glob "$buildproductsdir/$pat";
3949 fail "failed to find unique changes file".
3950 " (looked for $pat in $buildproductsdir);".
3951 " perhaps you need to use dgit -C"
3953 ($changesfile) = @cs;
3955 $changesfile = "$buildproductsdir/$changesfile";
3958 # Check that changes and .dsc agree enough
3959 $changesfile =~ m{[^/]*$};
3960 my $changes = parsecontrol($changesfile,$&);
3961 files_compare_inputs($dsc, $changes)
3962 unless forceing [qw(dsc-changes-mismatch)];
3964 # Perhaps adjust .dsc to contain right set of origs
3965 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3967 unless forceing [qw(changes-origs-exactly)];
3969 # Checks complete, we're going to try and go ahead:
3971 responder_send_file('changes',$changesfile);
3972 responder_send_command("param head $dgithead");
3973 responder_send_command("param csuite $csuite");
3974 responder_send_command("param tagformat $tagformat");
3975 if (defined $maintviewhead) {
3976 die unless ($protovsn//4) >= 4;
3977 responder_send_command("param maint-view $maintviewhead");
3980 if (deliberately_not_fast_forward) {
3981 git_for_each_ref(lrfetchrefs, sub {
3982 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3983 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3984 responder_send_command("previously $rrefname=$objid");
3985 $previously{$rrefname} = $objid;
3989 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3993 supplementary_message(<<'END');
3994 Push failed, while signing the tag.
3995 You can retry the push, after fixing the problem, if you like.
3997 # If we manage to sign but fail to record it anywhere, it's fine.
3998 if ($we_are_responder) {
3999 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4000 responder_receive_files('signed-tag', @tagobjfns);
4002 @tagobjfns = push_mktags($clogp,$dscpath,
4003 $changesfile,$changesfile,
4006 supplementary_message(<<'END');
4007 Push failed, *after* signing the tag.
4008 If you want to try again, you should use a new version number.
4011 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4013 foreach my $tw (@tagwants) {
4014 my $tag = $tw->{Tag};
4015 my $tagobjfn = $tw->{TagObjFn};
4017 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4018 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4019 runcmd_ordryrun_local
4020 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4023 supplementary_message(<<'END');
4024 Push failed, while updating the remote git repository - see messages above.
4025 If you want to try again, you should use a new version number.
4027 if (!check_for_git()) {
4028 create_remote_git_repo();
4031 my @pushrefs = $forceflag.$dgithead.":".rrref();
4032 foreach my $tw (@tagwants) {
4033 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4036 runcmd_ordryrun @git,
4037 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4038 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4040 supplementary_message(<<'END');
4041 Push failed, while obtaining signatures on the .changes and .dsc.
4042 If it was just that the signature failed, you may try again by using
4043 debsign by hand to sign the changes
4045 and then dput to complete the upload.
4046 If you need to change the package, you must use a new version number.
4048 if ($we_are_responder) {
4049 my $dryrunsuffix = act_local() ? "" : ".tmp";
4050 responder_receive_files('signed-dsc-changes',
4051 "$dscpath$dryrunsuffix",
4052 "$changesfile$dryrunsuffix");
4055 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4057 progress "[new .dsc left in $dscpath.tmp]";
4059 sign_changes $changesfile;
4062 supplementary_message(<<END);
4063 Push failed, while uploading package(s) to the archive server.
4064 You can retry the upload of exactly these same files with dput of:
4066 If that .changes file is broken, you will need to use a new version
4067 number for your next attempt at the upload.
4069 my $host = access_cfg('upload-host','RETURN-UNDEF');
4070 my @hostarg = defined($host) ? ($host,) : ();
4071 runcmd_ordryrun @dput, @hostarg, $changesfile;
4072 printdone "pushed and uploaded $cversion";
4074 supplementary_message('');
4075 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";
4096 $dstdir ||= "$package";
4097 if (stat_exists $dstdir) {
4098 fail "$dstdir already exists";
4102 if ($rmonerror && !$dryrun_level) {
4103 $cwd_remove= getcwd();
4105 return unless defined $cwd_remove;
4106 if (!chdir "$cwd_remove") {
4107 return if $!==&ENOENT;
4108 die "chdir $cwd_remove: $!";
4110 printdebug "clone rmonerror removing $dstdir\n";
4112 rmtree($dstdir) or die "remove $dstdir: $!\n";
4113 } elsif (grep { $! == $_ }
4114 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4116 print STDERR "check whether to remove $dstdir: $!\n";
4122 $cwd_remove = undef;
4125 sub branchsuite () {
4126 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4127 if ($branch =~ m#$lbranch_re#o) {
4134 sub fetchpullargs () {
4136 if (!defined $package) {
4137 my $sourcep = parsecontrol('debian/control','debian/control');
4138 $package = getfield $sourcep, 'Source';
4141 $isuite = branchsuite();
4143 my $clogp = parsechangelog();
4144 $isuite = getfield $clogp, 'Distribution';
4146 } elsif (@ARGV==1) {
4149 badusage "incorrect arguments to dgit fetch or dgit pull";
4156 my $multi_fetched = fork_for_multisuite(sub { });
4157 exit 0 if $multi_fetched;
4164 if (quiltmode_splitbrain()) {
4165 my ($format, $fopts) = get_source_format();
4166 madformat($format) and fail <<END
4167 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4176 badusage "-p is not allowed with dgit push" if defined $package;
4178 my $clogp = parsechangelog();
4179 $package = getfield $clogp, 'Source';
4182 } elsif (@ARGV==1) {
4183 ($specsuite) = (@ARGV);
4185 badusage "incorrect arguments to dgit push";
4187 $isuite = getfield $clogp, 'Distribution';
4189 local ($package) = $existing_package; # this is a hack
4190 canonicalise_suite();
4192 canonicalise_suite();
4194 if (defined $specsuite &&
4195 $specsuite ne $isuite &&
4196 $specsuite ne $csuite) {
4197 fail "dgit push: changelog specifies $isuite ($csuite)".
4198 " but command line specifies $specsuite";
4203 #---------- remote commands' implementation ----------
4205 sub cmd_remote_push_build_host {
4206 my ($nrargs) = shift @ARGV;
4207 my (@rargs) = @ARGV[0..$nrargs-1];
4208 @ARGV = @ARGV[$nrargs..$#ARGV];
4210 my ($dir,$vsnwant) = @rargs;
4211 # vsnwant is a comma-separated list; we report which we have
4212 # chosen in our ready response (so other end can tell if they
4215 $we_are_responder = 1;
4216 $us .= " (build host)";
4220 open PI, "<&STDIN" or die $!;
4221 open STDIN, "/dev/null" or die $!;
4222 open PO, ">&STDOUT" or die $!;
4224 open STDOUT, ">&STDERR" or die $!;
4228 ($protovsn) = grep {
4229 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4230 } @rpushprotovsn_support;
4232 fail "build host has dgit rpush protocol versions ".
4233 (join ",", @rpushprotovsn_support).
4234 " but invocation host has $vsnwant"
4235 unless defined $protovsn;
4237 responder_send_command("dgit-remote-push-ready $protovsn");
4238 rpush_handle_protovsn_bothends();
4243 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4244 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4245 # a good error message)
4247 sub rpush_handle_protovsn_bothends () {
4248 if ($protovsn < 4) {
4249 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4258 my $report = i_child_report();
4259 if (defined $report) {
4260 printdebug "($report)\n";
4261 } elsif ($i_child_pid) {
4262 printdebug "(killing build host child $i_child_pid)\n";
4263 kill 15, $i_child_pid;
4265 if (defined $i_tmp && !defined $initiator_tempdir) {
4267 eval { rmtree $i_tmp; };
4271 END { i_cleanup(); }
4274 my ($base,$selector,@args) = @_;
4275 $selector =~ s/\-/_/g;
4276 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4283 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4291 push @rargs, join ",", @rpushprotovsn_support;
4294 push @rdgit, @ropts;
4295 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4297 my @cmd = (@ssh, $host, shellquote @rdgit);
4300 if (defined $initiator_tempdir) {
4301 rmtree $initiator_tempdir;
4302 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4303 $i_tmp = $initiator_tempdir;
4307 $i_child_pid = open2(\*RO, \*RI, @cmd);
4309 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4310 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4311 $supplementary_message = '' unless $protovsn >= 3;
4313 fail "rpush negotiated protocol version $protovsn".
4314 " which does not support quilt mode $quilt_mode"
4315 if quiltmode_splitbrain;
4317 rpush_handle_protovsn_bothends();
4319 my ($icmd,$iargs) = initiator_expect {
4320 m/^(\S+)(?: (.*))?$/;
4323 i_method "i_resp", $icmd, $iargs;
4327 sub i_resp_progress ($) {
4329 my $msg = protocol_read_bytes \*RO, $rhs;
4333 sub i_resp_supplementary_message ($) {
4335 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4338 sub i_resp_complete {
4339 my $pid = $i_child_pid;
4340 $i_child_pid = undef; # prevents killing some other process with same pid
4341 printdebug "waiting for build host child $pid...\n";
4342 my $got = waitpid $pid, 0;
4343 die $! unless $got == $pid;
4344 die "build host child failed $?" if $?;
4347 printdebug "all done\n";
4351 sub i_resp_file ($) {
4353 my $localname = i_method "i_localname", $keyword;
4354 my $localpath = "$i_tmp/$localname";
4355 stat_exists $localpath and
4356 badproto \*RO, "file $keyword ($localpath) twice";
4357 protocol_receive_file \*RO, $localpath;
4358 i_method "i_file", $keyword;
4363 sub i_resp_param ($) {
4364 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4368 sub i_resp_previously ($) {
4369 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4370 or badproto \*RO, "bad previously spec";
4371 my $r = system qw(git check-ref-format), $1;
4372 die "bad previously ref spec ($r)" if $r;
4373 $previously{$1} = $2;
4378 sub i_resp_want ($) {
4380 die "$keyword ?" if $i_wanted{$keyword}++;
4381 my @localpaths = i_method "i_want", $keyword;
4382 printdebug "[[ $keyword @localpaths\n";
4383 foreach my $localpath (@localpaths) {
4384 protocol_send_file \*RI, $localpath;
4386 print RI "files-end\n" or die $!;
4389 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4391 sub i_localname_parsed_changelog {
4392 return "remote-changelog.822";
4394 sub i_file_parsed_changelog {
4395 ($i_clogp, $i_version, $i_dscfn) =
4396 push_parse_changelog "$i_tmp/remote-changelog.822";
4397 die if $i_dscfn =~ m#/|^\W#;
4400 sub i_localname_dsc {
4401 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4406 sub i_localname_changes {
4407 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4408 $i_changesfn = $i_dscfn;
4409 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4410 return $i_changesfn;
4412 sub i_file_changes { }
4414 sub i_want_signed_tag {
4415 printdebug Dumper(\%i_param, $i_dscfn);
4416 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4417 && defined $i_param{'csuite'}
4418 or badproto \*RO, "premature desire for signed-tag";
4419 my $head = $i_param{'head'};
4420 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4422 my $maintview = $i_param{'maint-view'};
4423 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4426 if ($protovsn >= 4) {
4427 my $p = $i_param{'tagformat'} // '<undef>';
4429 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4432 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4434 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4436 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4439 push_mktags $i_clogp, $i_dscfn,
4440 $i_changesfn, 'remote changes',
4444 sub i_want_signed_dsc_changes {
4445 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4446 sign_changes $i_changesfn;
4447 return ($i_dscfn, $i_changesfn);
4450 #---------- building etc. ----------
4456 #----- `3.0 (quilt)' handling -----
4458 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4460 sub quiltify_dpkg_commit ($$$;$) {
4461 my ($patchname,$author,$msg, $xinfo) = @_;
4465 my $descfn = ".git/dgit/quilt-description.tmp";
4466 open O, '>', $descfn or die "$descfn: $!";
4467 $msg =~ s/\n+/\n\n/;
4468 print O <<END or die $!;
4470 ${xinfo}Subject: $msg
4477 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4478 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4479 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4480 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4484 sub quiltify_trees_differ ($$;$$$) {
4485 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4486 # returns true iff the two tree objects differ other than in debian/
4487 # with $finegrained,
4488 # returns bitmask 01 - differ in upstream files except .gitignore
4489 # 02 - differ in .gitignore
4490 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4491 # is set for each modified .gitignore filename $fn
4492 # if $unrepres is defined, array ref to which is appeneded
4493 # a list of unrepresentable changes (removals of upstream files
4496 my @cmd = (@git, qw(diff-tree -z));
4497 push @cmd, qw(--name-only) unless $unrepres;
4498 push @cmd, qw(-r) if $finegrained || $unrepres;
4500 my $diffs= cmdoutput @cmd;
4503 foreach my $f (split /\0/, $diffs) {
4504 if ($unrepres && !@lmodes) {
4505 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4508 my ($oldmode,$newmode) = @lmodes;
4511 next if $f =~ m#^debian(?:/.*)?$#s;
4515 die "not a plain file\n"
4516 unless $newmode =~ m/^10\d{4}$/ ||
4517 $oldmode =~ m/^10\d{4}$/;
4518 if ($oldmode =~ m/[^0]/ &&
4519 $newmode =~ m/[^0]/) {
4520 die "mode changed\n" if $oldmode ne $newmode;
4522 die "non-default mode\n"
4523 unless $newmode =~ m/^100644$/ ||
4524 $oldmode =~ m/^100644$/;
4528 local $/="\n"; chomp $@;
4529 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4533 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4534 $r |= $isignore ? 02 : 01;
4535 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4537 printdebug "quiltify_trees_differ $x $y => $r\n";
4541 sub quiltify_tree_sentinelfiles ($) {
4542 # lists the `sentinel' files present in the tree
4544 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4545 qw(-- debian/rules debian/control);
4550 sub quiltify_splitbrain_needed () {
4551 if (!$split_brain) {
4552 progress "dgit view: changes are required...";
4553 runcmd @git, qw(checkout -q -b dgit-view);
4558 sub quiltify_splitbrain ($$$$$$) {
4559 my ($clogp, $unapplied, $headref, $diffbits,
4560 $editedignores, $cachekey) = @_;
4561 if ($quilt_mode !~ m/gbp|dpm/) {
4562 # treat .gitignore just like any other upstream file
4563 $diffbits = { %$diffbits };
4564 $_ = !!$_ foreach values %$diffbits;
4566 # We would like any commits we generate to be reproducible
4567 my @authline = clogp_authline($clogp);
4568 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4569 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4570 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4571 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4572 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4573 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4575 if ($quilt_mode =~ m/gbp|unapplied/ &&
4576 ($diffbits->{O2H} & 01)) {
4578 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4579 " but git tree differs from orig in upstream files.";
4580 if (!stat_exists "debian/patches") {
4582 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4586 if ($quilt_mode =~ m/dpm/ &&
4587 ($diffbits->{H2A} & 01)) {
4589 --quilt=$quilt_mode specified, implying patches-applied git tree
4590 but git tree differs from result of applying debian/patches to upstream
4593 if ($quilt_mode =~ m/gbp|unapplied/ &&
4594 ($diffbits->{O2A} & 01)) { # some patches
4595 quiltify_splitbrain_needed();
4596 progress "dgit view: creating patches-applied version using gbp pq";
4597 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4598 # gbp pq import creates a fresh branch; push back to dgit-view
4599 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4600 runcmd @git, qw(checkout -q dgit-view);
4602 if ($quilt_mode =~ m/gbp|dpm/ &&
4603 ($diffbits->{O2A} & 02)) {
4605 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4606 tool which does not create patches for changes to upstream
4607 .gitignores: but, such patches exist in debian/patches.
4610 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4611 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4612 quiltify_splitbrain_needed();
4613 progress "dgit view: creating patch to represent .gitignore changes";
4614 ensuredir "debian/patches";
4615 my $gipatch = "debian/patches/auto-gitignore";
4616 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4617 stat GIPATCH or die "$gipatch: $!";
4618 fail "$gipatch already exists; but want to create it".
4619 " to record .gitignore changes" if (stat _)[7];
4620 print GIPATCH <<END or die "$gipatch: $!";
4621 Subject: Update .gitignore from Debian packaging branch
4623 The Debian packaging git branch contains these updates to the upstream
4624 .gitignore file(s). This patch is autogenerated, to provide these
4625 updates to users of the official Debian archive view of the package.
4627 [dgit ($our_version) update-gitignore]
4630 close GIPATCH or die "$gipatch: $!";
4631 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4632 $unapplied, $headref, "--", sort keys %$editedignores;
4633 open SERIES, "+>>", "debian/patches/series" or die $!;
4634 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4636 defined read SERIES, $newline, 1 or die $!;
4637 print SERIES "\n" or die $! unless $newline eq "\n";
4638 print SERIES "auto-gitignore\n" or die $!;
4639 close SERIES or die $!;
4640 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4642 Commit patch to update .gitignore
4644 [dgit ($our_version) update-gitignore-quilt-fixup]
4648 my $dgitview = git_rev_parse 'HEAD';
4650 changedir '../../../..';
4651 # When we no longer need to support squeeze, use --create-reflog
4653 ensuredir ".git/logs/refs/dgit-intern";
4654 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4657 my $oldcache = git_get_ref "refs/$splitbraincache";
4658 if ($oldcache eq $dgitview) {
4659 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4660 # git update-ref doesn't always update, in this case. *sigh*
4661 my $dummy = make_commit_text <<END;
4664 author Dgit <dgit\@example.com> 1000000000 +0000
4665 committer Dgit <dgit\@example.com> 1000000000 +0000
4667 Dummy commit - do not use
4669 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4670 "refs/$splitbraincache", $dummy;
4672 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4675 changedir '.git/dgit/unpack/work';
4677 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4678 progress "dgit view: created ($saved)";
4681 sub quiltify ($$$$) {
4682 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4684 # Quilt patchification algorithm
4686 # We search backwards through the history of the main tree's HEAD
4687 # (T) looking for a start commit S whose tree object is identical
4688 # to to the patch tip tree (ie the tree corresponding to the
4689 # current dpkg-committed patch series). For these purposes
4690 # `identical' disregards anything in debian/ - this wrinkle is
4691 # necessary because dpkg-source treates debian/ specially.
4693 # We can only traverse edges where at most one of the ancestors'
4694 # trees differs (in changes outside in debian/). And we cannot
4695 # handle edges which change .pc/ or debian/patches. To avoid
4696 # going down a rathole we avoid traversing edges which introduce
4697 # debian/rules or debian/control. And we set a limit on the
4698 # number of edges we are willing to look at.
4700 # If we succeed, we walk forwards again. For each traversed edge
4701 # PC (with P parent, C child) (starting with P=S and ending with
4702 # C=T) to we do this:
4704 # - dpkg-source --commit with a patch name and message derived from C
4705 # After traversing PT, we git commit the changes which
4706 # should be contained within debian/patches.
4708 # The search for the path S..T is breadth-first. We maintain a
4709 # todo list containing search nodes. A search node identifies a
4710 # commit, and looks something like this:
4712 # Commit => $git_commit_id,
4713 # Child => $c, # or undef if P=T
4714 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4715 # Nontrivial => true iff $p..$c has relevant changes
4722 my %considered; # saves being exponential on some weird graphs
4724 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4727 my ($search,$whynot) = @_;
4728 printdebug " search NOT $search->{Commit} $whynot\n";
4729 $search->{Whynot} = $whynot;
4730 push @nots, $search;
4731 no warnings qw(exiting);
4740 my $c = shift @todo;
4741 next if $considered{$c->{Commit}}++;
4743 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4745 printdebug "quiltify investigate $c->{Commit}\n";
4748 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4749 printdebug " search finished hooray!\n";
4754 if ($quilt_mode eq 'nofix') {
4755 fail "quilt fixup required but quilt mode is \`nofix'\n".
4756 "HEAD commit $c->{Commit} differs from tree implied by ".
4757 " debian/patches (tree object $oldtiptree)";
4759 if ($quilt_mode eq 'smash') {
4760 printdebug " search quitting smash\n";
4764 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4765 $not->($c, "has $c_sentinels not $t_sentinels")
4766 if $c_sentinels ne $t_sentinels;
4768 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4769 $commitdata =~ m/\n\n/;
4771 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4772 @parents = map { { Commit => $_, Child => $c } } @parents;
4774 $not->($c, "root commit") if !@parents;
4776 foreach my $p (@parents) {
4777 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4779 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4780 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4782 foreach my $p (@parents) {
4783 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4785 my @cmd= (@git, qw(diff-tree -r --name-only),
4786 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4787 my $patchstackchange = cmdoutput @cmd;
4788 if (length $patchstackchange) {
4789 $patchstackchange =~ s/\n/,/g;
4790 $not->($p, "changed $patchstackchange");
4793 printdebug " search queue P=$p->{Commit} ",
4794 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4800 printdebug "quiltify want to smash\n";
4803 my $x = $_[0]{Commit};
4804 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4807 my $reportnot = sub {
4809 my $s = $abbrev->($notp);
4810 my $c = $notp->{Child};
4811 $s .= "..".$abbrev->($c) if $c;
4812 $s .= ": ".$notp->{Whynot};
4815 if ($quilt_mode eq 'linear') {
4816 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4817 foreach my $notp (@nots) {
4818 print STDERR "$us: ", $reportnot->($notp), "\n";
4820 print STDERR "$us: $_\n" foreach @$failsuggestion;
4821 fail "quilt fixup naive history linearisation failed.\n".
4822 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4823 } elsif ($quilt_mode eq 'smash') {
4824 } elsif ($quilt_mode eq 'auto') {
4825 progress "quilt fixup cannot be linear, smashing...";
4827 die "$quilt_mode ?";
4830 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4831 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4833 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4835 quiltify_dpkg_commit "auto-$version-$target-$time",
4836 (getfield $clogp, 'Maintainer'),
4837 "Automatically generated patch ($clogp->{Version})\n".
4838 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4842 progress "quiltify linearisation planning successful, executing...";
4844 for (my $p = $sref_S;
4845 my $c = $p->{Child};
4847 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4848 next unless $p->{Nontrivial};
4850 my $cc = $c->{Commit};
4852 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4853 $commitdata =~ m/\n\n/ or die "$c ?";
4856 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4859 my $commitdate = cmdoutput
4860 @git, qw(log -n1 --pretty=format:%aD), $cc;
4862 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4864 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4871 my $gbp_check_suitable = sub {
4876 die "contains unexpected slashes\n" if m{//} || m{/$};
4877 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4878 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4879 die "too long" if length > 200;
4881 return $_ unless $@;
4882 print STDERR "quiltifying commit $cc:".
4883 " ignoring/dropping Gbp-Pq $what: $@";
4887 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4889 (\S+) \s* \n //ixm) {
4890 $patchname = $gbp_check_suitable->($1, 'Name');
4892 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4894 (\S+) \s* \n //ixm) {
4895 $patchdir = $gbp_check_suitable->($1, 'Topic');
4900 if (!defined $patchname) {
4901 $patchname = $title;
4902 $patchname =~ s/[.:]$//;
4905 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4906 my $translitname = $converter->convert($patchname);
4907 die unless defined $translitname;
4908 $patchname = $translitname;
4911 "dgit: patch title transliteration error: $@"
4913 $patchname =~ y/ A-Z/-a-z/;
4914 $patchname =~ y/-a-z0-9_.+=~//cd;
4915 $patchname =~ s/^\W/x-$&/;
4916 $patchname = substr($patchname,0,40);
4918 if (!defined $patchdir) {
4921 if (length $patchdir) {
4922 $patchname = "$patchdir/$patchname";
4924 if ($patchname =~ m{^(.*)/}) {
4925 mkpath "debian/patches/$1";
4930 stat "debian/patches/$patchname$index";
4932 $!==ENOENT or die "$patchname$index $!";
4934 runcmd @git, qw(checkout -q), $cc;
4936 # We use the tip's changelog so that dpkg-source doesn't
4937 # produce complaining messages from dpkg-parsechangelog. None
4938 # of the information dpkg-source gets from the changelog is
4939 # actually relevant - it gets put into the original message
4940 # which dpkg-source provides our stunt editor, and then
4942 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4944 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4945 "Date: $commitdate\n".
4946 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4948 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4951 runcmd @git, qw(checkout -q master);
4954 sub build_maybe_quilt_fixup () {
4955 my ($format,$fopts) = get_source_format;
4956 return unless madformat_wantfixup $format;
4959 check_for_vendor_patches();
4961 if (quiltmode_splitbrain) {
4962 fail <<END unless access_cfg_tagformats_can_splitbrain;
4963 quilt mode $quilt_mode requires split view so server needs to support
4964 both "new" and "maint" tag formats, but config says it doesn't.
4968 my $clogp = parsechangelog();
4969 my $headref = git_rev_parse('HEAD');
4974 my $upstreamversion = upstreamversion $version;
4976 if ($fopts->{'single-debian-patch'}) {
4977 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4979 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4982 die 'bug' if $split_brain && !$need_split_build_invocation;
4984 changedir '../../../..';
4985 runcmd_ordryrun_local
4986 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4989 sub quilt_fixup_mkwork ($) {
4992 mkdir "work" or die $!;
4994 mktree_in_ud_here();
4995 runcmd @git, qw(reset -q --hard), $headref;
4998 sub quilt_fixup_linkorigs ($$) {
4999 my ($upstreamversion, $fn) = @_;
5000 # calls $fn->($leafname);
5002 foreach my $f (<../../../../*>) { #/){
5003 my $b=$f; $b =~ s{.*/}{};
5005 local ($debuglevel) = $debuglevel-1;
5006 printdebug "QF linkorigs $b, $f ?\n";
5008 next unless is_orig_file_of_vsn $b, $upstreamversion;
5009 printdebug "QF linkorigs $b, $f Y\n";
5010 link_ltarget $f, $b or die "$b $!";
5015 sub quilt_fixup_delete_pc () {
5016 runcmd @git, qw(rm -rqf .pc);
5018 Commit removal of .pc (quilt series tracking data)
5020 [dgit ($our_version) upgrade quilt-remove-pc]
5024 sub quilt_fixup_singlepatch ($$$) {
5025 my ($clogp, $headref, $upstreamversion) = @_;
5027 progress "starting quiltify (single-debian-patch)";
5029 # dpkg-source --commit generates new patches even if
5030 # single-debian-patch is in debian/source/options. In order to
5031 # get it to generate debian/patches/debian-changes, it is
5032 # necessary to build the source package.
5034 quilt_fixup_linkorigs($upstreamversion, sub { });
5035 quilt_fixup_mkwork($headref);
5037 rmtree("debian/patches");
5039 runcmd @dpkgsource, qw(-b .);
5041 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5042 rename srcfn("$upstreamversion", "/debian/patches"),
5043 "work/debian/patches";
5046 commit_quilty_patch();
5049 sub quilt_make_fake_dsc ($) {
5050 my ($upstreamversion) = @_;
5052 my $fakeversion="$upstreamversion-~~DGITFAKE";
5054 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5055 print $fakedsc <<END or die $!;
5058 Version: $fakeversion
5062 my $dscaddfile=sub {
5065 my $md = new Digest::MD5;
5067 my $fh = new IO::File $b, '<' or die "$b $!";
5072 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5075 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5077 my @files=qw(debian/source/format debian/rules
5078 debian/control debian/changelog);
5079 foreach my $maybe (qw(debian/patches debian/source/options
5080 debian/tests/control)) {
5081 next unless stat_exists "../../../$maybe";
5082 push @files, $maybe;
5085 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5086 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5088 $dscaddfile->($debtar);
5089 close $fakedsc or die $!;
5092 sub quilt_check_splitbrain_cache ($$) {
5093 my ($headref, $upstreamversion) = @_;
5094 # Called only if we are in (potentially) split brain mode.
5096 # Computes the cache key and looks in the cache.
5097 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5099 my $splitbrain_cachekey;
5102 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5103 # we look in the reflog of dgit-intern/quilt-cache
5104 # we look for an entry whose message is the key for the cache lookup
5105 my @cachekey = (qw(dgit), $our_version);
5106 push @cachekey, $upstreamversion;
5107 push @cachekey, $quilt_mode;
5108 push @cachekey, $headref;
5110 push @cachekey, hashfile('fake.dsc');
5112 my $srcshash = Digest::SHA->new(256);
5113 my %sfs = ( %INC, '$0(dgit)' => $0 );
5114 foreach my $sfk (sort keys %sfs) {
5115 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5116 $srcshash->add($sfk," ");
5117 $srcshash->add(hashfile($sfs{$sfk}));
5118 $srcshash->add("\n");
5120 push @cachekey, $srcshash->hexdigest();
5121 $splitbrain_cachekey = "@cachekey";
5123 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5125 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5126 debugcmd "|(probably)",@cmd;
5127 my $child = open GC, "-|"; defined $child or die $!;
5129 chdir '../../..' or die $!;
5130 if (!stat ".git/logs/refs/$splitbraincache") {
5131 $! == ENOENT or die $!;
5132 printdebug ">(no reflog)\n";
5139 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5140 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5143 quilt_fixup_mkwork($headref);
5144 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5145 if ($cachehit ne $headref) {
5146 progress "dgit view: found cached ($saved)";
5147 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5149 return ($cachehit, $splitbrain_cachekey);
5151 progress "dgit view: found cached, no changes required";
5152 return ($headref, $splitbrain_cachekey);
5154 die $! if GC->error;
5155 failedcmd unless close GC;
5157 printdebug "splitbrain cache miss\n";
5158 return (undef, $splitbrain_cachekey);
5161 sub quilt_fixup_multipatch ($$$) {
5162 my ($clogp, $headref, $upstreamversion) = @_;
5164 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5167 # - honour any existing .pc in case it has any strangeness
5168 # - determine the git commit corresponding to the tip of
5169 # the patch stack (if there is one)
5170 # - if there is such a git commit, convert each subsequent
5171 # git commit into a quilt patch with dpkg-source --commit
5172 # - otherwise convert all the differences in the tree into
5173 # a single git commit
5177 # Our git tree doesn't necessarily contain .pc. (Some versions of
5178 # dgit would include the .pc in the git tree.) If there isn't
5179 # one, we need to generate one by unpacking the patches that we
5182 # We first look for a .pc in the git tree. If there is one, we
5183 # will use it. (This is not the normal case.)
5185 # Otherwise need to regenerate .pc so that dpkg-source --commit
5186 # can work. We do this as follows:
5187 # 1. Collect all relevant .orig from parent directory
5188 # 2. Generate a debian.tar.gz out of
5189 # debian/{patches,rules,source/format,source/options}
5190 # 3. Generate a fake .dsc containing just these fields:
5191 # Format Source Version Files
5192 # 4. Extract the fake .dsc
5193 # Now the fake .dsc has a .pc directory.
5194 # (In fact we do this in every case, because in future we will
5195 # want to search for a good base commit for generating patches.)
5197 # Then we can actually do the dpkg-source --commit
5198 # 1. Make a new working tree with the same object
5199 # store as our main tree and check out the main
5201 # 2. Copy .pc from the fake's extraction, if necessary
5202 # 3. Run dpkg-source --commit
5203 # 4. If the result has changes to debian/, then
5204 # - git add them them
5205 # - git add .pc if we had a .pc in-tree
5207 # 5. If we had a .pc in-tree, delete it, and git commit
5208 # 6. Back in the main tree, fast forward to the new HEAD
5210 # Another situation we may have to cope with is gbp-style
5211 # patches-unapplied trees.
5213 # We would want to detect these, so we know to escape into
5214 # quilt_fixup_gbp. However, this is in general not possible.
5215 # Consider a package with a one patch which the dgit user reverts
5216 # (with git revert or the moral equivalent).
5218 # That is indistinguishable in contents from a patches-unapplied
5219 # tree. And looking at the history to distinguish them is not
5220 # useful because the user might have made a confusing-looking git
5221 # history structure (which ought to produce an error if dgit can't
5222 # cope, not a silent reintroduction of an unwanted patch).
5224 # So gbp users will have to pass an option. But we can usually
5225 # detect their failure to do so: if the tree is not a clean
5226 # patches-applied tree, quilt linearisation fails, but the tree
5227 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5228 # they want --quilt=unapplied.
5230 # To help detect this, when we are extracting the fake dsc, we
5231 # first extract it with --skip-patches, and then apply the patches
5232 # afterwards with dpkg-source --before-build. That lets us save a
5233 # tree object corresponding to .origs.
5235 my $splitbrain_cachekey;
5237 quilt_make_fake_dsc($upstreamversion);
5239 if (quiltmode_splitbrain()) {
5241 ($cachehit, $splitbrain_cachekey) =
5242 quilt_check_splitbrain_cache($headref, $upstreamversion);
5243 return if $cachehit;
5247 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5249 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5250 rename $fakexdir, "fake" or die "$fakexdir $!";
5254 remove_stray_gits("source package");
5255 mktree_in_ud_here();
5259 my $unapplied=git_add_write_tree();
5260 printdebug "fake orig tree object $unapplied\n";
5264 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5266 if (system @bbcmd) {
5267 failedcmd @bbcmd if $? < 0;
5269 failed to apply your git tree's patch stack (from debian/patches/) to
5270 the corresponding upstream tarball(s). Your source tree and .orig
5271 are probably too inconsistent. dgit can only fix up certain kinds of
5272 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5278 quilt_fixup_mkwork($headref);
5281 if (stat_exists ".pc") {
5283 progress "Tree already contains .pc - will use it then delete it.";
5286 rename '../fake/.pc','.pc' or die $!;
5289 changedir '../fake';
5291 my $oldtiptree=git_add_write_tree();
5292 printdebug "fake o+d/p tree object $unapplied\n";
5293 changedir '../work';
5296 # We calculate some guesswork now about what kind of tree this might
5297 # be. This is mostly for error reporting.
5303 # O = orig, without patches applied
5304 # A = "applied", ie orig with H's debian/patches applied
5305 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5306 \%editedignores, \@unrepres),
5307 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5308 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5312 foreach my $b (qw(01 02)) {
5313 foreach my $v (qw(O2H O2A H2A)) {
5314 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5317 printdebug "differences \@dl @dl.\n";
5320 "$us: base trees orig=%.20s o+d/p=%.20s",
5321 $unapplied, $oldtiptree;
5323 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5324 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5325 $dl[0], $dl[1], $dl[3], $dl[4],
5329 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5331 forceable_fail [qw(unrepresentable)], <<END;
5332 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5337 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5338 push @failsuggestion, "This might be a patches-unapplied branch.";
5339 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5340 push @failsuggestion, "This might be a patches-applied branch.";
5342 push @failsuggestion, "Maybe you need to specify one of".
5343 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5345 if (quiltmode_splitbrain()) {
5346 quiltify_splitbrain($clogp, $unapplied, $headref,
5347 $diffbits, \%editedignores,
5348 $splitbrain_cachekey);
5352 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5353 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5355 if (!open P, '>>', ".pc/applied-patches") {
5356 $!==&ENOENT or die $!;
5361 commit_quilty_patch();
5363 if ($mustdeletepc) {
5364 quilt_fixup_delete_pc();
5368 sub quilt_fixup_editor () {
5369 my $descfn = $ENV{$fakeeditorenv};
5370 my $editing = $ARGV[$#ARGV];
5371 open I1, '<', $descfn or die "$descfn: $!";
5372 open I2, '<', $editing or die "$editing: $!";
5373 unlink $editing or die "$editing: $!";
5374 open O, '>', $editing or die "$editing: $!";
5375 while (<I1>) { print O or die $!; } I1->error and die $!;
5378 $copying ||= m/^\-\-\- /;
5379 next unless $copying;
5382 I2->error and die $!;
5387 sub maybe_apply_patches_dirtily () {
5388 return unless $quilt_mode =~ m/gbp|unapplied/;
5389 print STDERR <<END or die $!;
5391 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5392 dgit: Have to apply the patches - making the tree dirty.
5393 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5396 $patches_applied_dirtily = 01;
5397 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5398 runcmd qw(dpkg-source --before-build .);
5401 sub maybe_unapply_patches_again () {
5402 progress "dgit: Unapplying patches again to tidy up the tree."
5403 if $patches_applied_dirtily;
5404 runcmd qw(dpkg-source --after-build .)
5405 if $patches_applied_dirtily & 01;
5407 if $patches_applied_dirtily & 02;
5408 $patches_applied_dirtily = 0;
5411 #----- other building -----
5413 our $clean_using_builder;
5414 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5415 # clean the tree before building (perhaps invoked indirectly by
5416 # whatever we are using to run the build), rather than separately
5417 # and explicitly by us.
5420 return if $clean_using_builder;
5421 if ($cleanmode eq 'dpkg-source') {
5422 maybe_apply_patches_dirtily();
5423 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5424 } elsif ($cleanmode eq 'dpkg-source-d') {
5425 maybe_apply_patches_dirtily();
5426 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5427 } elsif ($cleanmode eq 'git') {
5428 runcmd_ordryrun_local @git, qw(clean -xdf);
5429 } elsif ($cleanmode eq 'git-ff') {
5430 runcmd_ordryrun_local @git, qw(clean -xdff);
5431 } elsif ($cleanmode eq 'check') {
5432 my $leftovers = cmdoutput @git, qw(clean -xdn);
5433 if (length $leftovers) {
5434 print STDERR $leftovers, "\n" or die $!;
5435 fail "tree contains uncommitted files and --clean=check specified";
5437 } elsif ($cleanmode eq 'none') {
5444 badusage "clean takes no additional arguments" if @ARGV;
5447 maybe_unapply_patches_again();
5450 sub build_prep_early () {
5451 our $build_prep_early_done //= 0;
5452 return if $build_prep_early_done++;
5454 badusage "-p is not allowed when building" if defined $package;
5455 my $clogp = parsechangelog();
5456 $isuite = getfield $clogp, 'Distribution';
5457 $package = getfield $clogp, 'Source';
5458 $version = getfield $clogp, 'Version';
5465 build_maybe_quilt_fixup();
5467 my $pat = changespat $version;
5468 foreach my $f (glob "$buildproductsdir/$pat") {
5470 unlink $f or fail "remove old changes file $f: $!";
5472 progress "would remove $f";
5478 sub changesopts_initial () {
5479 my @opts =@changesopts[1..$#changesopts];
5482 sub changesopts_version () {
5483 if (!defined $changes_since_version) {
5484 my @vsns = archive_query('archive_query');
5485 my @quirk = access_quirk();
5486 if ($quirk[0] eq 'backports') {
5487 local $isuite = $quirk[2];
5489 canonicalise_suite();
5490 push @vsns, archive_query('archive_query');
5493 @vsns = map { $_->[0] } @vsns;
5494 @vsns = sort { -version_compare($a, $b) } @vsns;
5495 $changes_since_version = $vsns[0];
5496 progress "changelog will contain changes since $vsns[0]";
5498 $changes_since_version = '_';
5499 progress "package seems new, not specifying -v<version>";
5502 if ($changes_since_version ne '_') {
5503 return ("-v$changes_since_version");
5509 sub changesopts () {
5510 return (changesopts_initial(), changesopts_version());
5513 sub massage_dbp_args ($;$) {
5514 my ($cmd,$xargs) = @_;
5517 # - if we're going to split the source build out so we can
5518 # do strange things to it, massage the arguments to dpkg-buildpackage
5519 # so that the main build doessn't build source (or add an argument
5520 # to stop it building source by default).
5522 # - add -nc to stop dpkg-source cleaning the source tree,
5523 # unless we're not doing a split build and want dpkg-source
5524 # as cleanmode, in which case we can do nothing
5527 # 0 - source will NOT need to be built separately by caller
5528 # +1 - source will need to be built separately by caller
5529 # +2 - source will need to be built separately by caller AND
5530 # dpkg-buildpackage should not in fact be run at all!
5531 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5532 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5533 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5534 $clean_using_builder = 1;
5537 # -nc has the side effect of specifying -b if nothing else specified
5538 # and some combinations of -S, -b, et al, are errors, rather than
5539 # later simply overriding earlie. So we need to:
5540 # - search the command line for these options
5541 # - pick the last one
5542 # - perhaps add our own as a default
5543 # - perhaps adjust it to the corresponding non-source-building version
5545 foreach my $l ($cmd, $xargs) {
5547 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5550 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5552 if ($need_split_build_invocation) {
5553 printdebug "massage split $dmode.\n";
5554 $r = $dmode =~ m/[S]/ ? +2 :
5555 $dmode =~ y/gGF/ABb/ ? +1 :
5556 $dmode =~ m/[ABb]/ ? 0 :
5559 printdebug "massage done $r $dmode.\n";
5561 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5567 my $wasdir = must_getcwd();
5573 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5574 my ($msg_if_onlyone) = @_;
5575 # If there is only one .changes file, fail with $msg_if_onlyone,
5576 # or if that is undef, be a no-op.
5577 # Returns the changes file to report to the user.
5578 my $pat = changespat $version;
5579 my @changesfiles = glob $pat;
5580 @changesfiles = sort {
5581 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5585 if (@changesfiles==1) {
5586 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5587 only one changes file from build (@changesfiles)
5589 $result = $changesfiles[0];
5590 } elsif (@changesfiles==2) {
5591 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5592 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5593 fail "$l found in binaries changes file $binchanges"
5596 runcmd_ordryrun_local @mergechanges, @changesfiles;
5597 my $multichanges = changespat $version,'multi';
5599 stat_exists $multichanges or fail "$multichanges: $!";
5600 foreach my $cf (glob $pat) {
5601 next if $cf eq $multichanges;
5602 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5605 $result = $multichanges;
5607 fail "wrong number of different changes files (@changesfiles)";
5609 printdone "build successful, results in $result\n" or die $!;
5612 sub midbuild_checkchanges () {
5613 my $pat = changespat $version;
5614 return if $rmchanges;
5615 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5616 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5618 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5619 Suggest you delete @unwanted.
5624 sub midbuild_checkchanges_vanilla ($) {
5626 midbuild_checkchanges() if $wantsrc == 1;
5629 sub postbuild_mergechanges_vanilla ($) {
5631 if ($wantsrc == 1) {
5633 postbuild_mergechanges(undef);
5636 printdone "build successful\n";
5642 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5643 my $wantsrc = massage_dbp_args \@dbp;
5646 midbuild_checkchanges_vanilla $wantsrc;
5651 push @dbp, changesopts_version();
5652 maybe_apply_patches_dirtily();
5653 runcmd_ordryrun_local @dbp;
5655 maybe_unapply_patches_again();
5656 postbuild_mergechanges_vanilla $wantsrc;
5660 $quilt_mode //= 'gbp';
5666 # gbp can make .origs out of thin air. In my tests it does this
5667 # even for a 1.0 format package, with no origs present. So I
5668 # guess it keys off just the version number. We don't know
5669 # exactly what .origs ought to exist, but let's assume that we
5670 # should run gbp if: the version has an upstream part and the main
5672 my $upstreamversion = upstreamversion $version;
5673 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5674 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5676 if ($gbp_make_orig) {
5678 $cleanmode = 'none'; # don't do it again
5679 $need_split_build_invocation = 1;
5682 my @dbp = @dpkgbuildpackage;
5684 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5686 if (!length $gbp_build[0]) {
5687 if (length executable_on_path('git-buildpackage')) {
5688 $gbp_build[0] = qw(git-buildpackage);
5690 $gbp_build[0] = 'gbp buildpackage';
5693 my @cmd = opts_opt_multi_cmd @gbp_build;
5695 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5697 if ($gbp_make_orig) {
5698 ensuredir '.git/dgit';
5699 my $ok = '.git/dgit/origs-gen-ok';
5700 unlink $ok or $!==&ENOENT or die $!;
5701 my @origs_cmd = @cmd;
5702 push @origs_cmd, qw(--git-cleaner=true);
5703 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5704 push @origs_cmd, @ARGV;
5706 debugcmd @origs_cmd;
5708 do { local $!; stat_exists $ok; }
5709 or failedcmd @origs_cmd;
5711 dryrun_report @origs_cmd;
5717 midbuild_checkchanges_vanilla $wantsrc;
5719 if (!$clean_using_builder) {
5720 push @cmd, '--git-cleaner=true';
5724 maybe_unapply_patches_again();
5726 push @cmd, changesopts();
5727 runcmd_ordryrun_local @cmd, @ARGV;
5729 postbuild_mergechanges_vanilla $wantsrc;
5731 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5735 my $our_cleanmode = $cleanmode;
5736 if ($need_split_build_invocation) {
5737 # Pretend that clean is being done some other way. This
5738 # forces us not to try to use dpkg-buildpackage to clean and
5739 # build source all in one go; and instead we run dpkg-source
5740 # (and build_prep() will do the clean since $clean_using_builder
5742 $our_cleanmode = 'ELSEWHERE';
5744 if ($our_cleanmode =~ m/^dpkg-source/) {
5745 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5746 $clean_using_builder = 1;
5749 $sourcechanges = changespat $version,'source';
5751 unlink "../$sourcechanges" or $!==ENOENT
5752 or fail "remove $sourcechanges: $!";
5754 $dscfn = dscfn($version);
5755 if ($our_cleanmode eq 'dpkg-source') {
5756 maybe_apply_patches_dirtily();
5757 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5759 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5760 maybe_apply_patches_dirtily();
5761 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5764 my @cmd = (@dpkgsource, qw(-b --));
5767 runcmd_ordryrun_local @cmd, "work";
5768 my @udfiles = <${package}_*>;
5769 changedir "../../..";
5770 foreach my $f (@udfiles) {
5771 printdebug "source copy, found $f\n";
5774 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5775 $f eq srcfn($version, $&));
5776 printdebug "source copy, found $f - renaming\n";
5777 rename "$ud/$f", "../$f" or $!==ENOENT
5778 or fail "put in place new source file ($f): $!";
5781 my $pwd = must_getcwd();
5782 my $leafdir = basename $pwd;
5784 runcmd_ordryrun_local @cmd, $leafdir;
5787 runcmd_ordryrun_local qw(sh -ec),
5788 'exec >$1; shift; exec "$@"','x',
5789 "../$sourcechanges",
5790 @dpkggenchanges, qw(-S), changesopts();
5794 sub cmd_build_source {
5796 badusage "build-source takes no additional arguments" if @ARGV;
5798 maybe_unapply_patches_again();
5799 printdone "source built, results in $dscfn and $sourcechanges";
5804 midbuild_checkchanges();
5807 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5808 stat_exists $sourcechanges
5809 or fail "$sourcechanges (in parent directory): $!";
5811 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5813 maybe_unapply_patches_again();
5815 postbuild_mergechanges(<<END);
5816 perhaps you need to pass -A ? (sbuild's default is to build only
5817 arch-specific binaries; dgit 1.4 used to override that.)
5822 sub cmd_quilt_fixup {
5823 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5826 build_maybe_quilt_fixup();
5829 sub cmd_import_dsc {
5833 last unless $ARGV[0] =~ m/^-/;
5836 if (m/^--require-valid-signature$/) {
5839 badusage "unknown dgit import-dsc sub-option \`$_'";
5843 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5844 my ($dscfn, $dstbranch) = @ARGV;
5846 badusage "dry run makes no sense with import-dsc" unless act_local();
5848 my $force = $dstbranch =~ s/^\+// ? +1 :
5849 $dstbranch =~ s/^\.\.// ? -1 :
5851 my $info = $force ? " $&" : '';
5852 $info = "$dscfn$info";
5854 my $specbranch = $dstbranch;
5855 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5856 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5858 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5859 my $chead = cmdoutput_errok @symcmd;
5860 defined $chead or $?==256 or failedcmd @symcmd;
5862 fail "$dstbranch is checked out - will not update it"
5863 if defined $chead and $chead eq $dstbranch;
5865 my $oldhash = git_get_ref $dstbranch;
5867 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5868 $dscdata = do { local $/ = undef; <D>; };
5869 D->error and fail "read $dscfn: $!";
5872 # we don't normally need this so import it here
5873 use Dpkg::Source::Package;
5874 my $dp = new Dpkg::Source::Package filename => $dscfn,
5875 require_valid_signature => $needsig;
5877 local $SIG{__WARN__} = sub {
5879 return unless $needsig;
5880 fail "import-dsc signature check failed";
5882 if (!$dp->is_signed()) {
5883 warn "$us: warning: importing unsigned .dsc\n";
5885 my $r = $dp->check_signature();
5886 die "->check_signature => $r" if $needsig && $r;
5892 my $dgit_commit = $dsc->{$ourdscfield[0]};
5893 if (defined $dgit_commit
5894 && !forceing [qw(import-dsc-with-dgit-field)]) {
5895 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5897 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5898 my @cmd = (qw(sh -ec),
5899 "echo $dgit_commit | git cat-file --batch-check");
5900 my $objgot = cmdoutput @cmd;
5901 if ($objgot =~ m#^\w+ missing\b#) {
5903 .dsc contains Dgit field referring to object $dgit_commit
5904 Your git tree does not have that object. Try `git fetch' from a
5905 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5908 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5910 progress "Not fast forward, forced update.";
5912 fail "Not fast forward to $dgit_commit";
5915 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5916 $dstbranch, $dgit_commit);
5918 progress "dgit: import-dsc updated git ref $dstbranch";
5923 Branch $dstbranch already exists
5924 Specify ..$specbranch for a pseudo-merge, binding in existing history
5925 Specify +$specbranch to overwrite, discarding existing history
5927 if $oldhash && !$force;
5929 $package = getfield $dsc, 'Source';
5930 my @dfi = dsc_files_info();
5931 foreach my $fi (@dfi) {
5932 my $f = $fi->{Filename};
5934 next if lstat $here;
5935 fail "stat $here: $!" unless $! == ENOENT;
5937 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5939 } elsif ($dscfn =~ m#^/#) {
5942 fail "cannot import $dscfn which seems to be inside working tree!";
5944 $there =~ s#/+[^/]+$## or
5945 fail "cannot import $dscfn which seems to not have a basename";
5947 symlink $there, $here or fail "symlink $there to $here: $!";
5948 progress "made symlink $here -> $there";
5949 # print STDERR Dumper($fi);
5951 my @mergeinputs = generate_commits_from_dsc();
5952 die unless @mergeinputs == 1;
5954 my $newhash = $mergeinputs[0]{Commit};
5958 progress "Import, forced update - synthetic orphan git history.";
5959 } elsif ($force < 0) {
5960 progress "Import, merging.";
5961 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5962 my $version = getfield $dsc, 'Version';
5963 my $clogp = commit_getclogp $newhash;
5964 my $authline = clogp_authline $clogp;
5965 $newhash = make_commit_text <<END;
5972 Merge $package ($version) import into $dstbranch
5975 die; # caught earlier
5979 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5980 $dstbranch, $newhash);
5982 progress "dgit: import-dsc results are in in git ref $dstbranch";
5985 sub cmd_archive_api_query {
5986 badusage "need only 1 subpath argument" unless @ARGV==1;
5987 my ($subpath) = @ARGV;
5988 my @cmd = archive_api_query_cmd($subpath);
5991 exec @cmd or fail "exec curl: $!\n";
5994 sub cmd_clone_dgit_repos_server {
5995 badusage "need destination argument" unless @ARGV==1;
5996 my ($destdir) = @ARGV;
5997 $package = '_dgit-repos-server';
5998 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6000 exec @cmd or fail "exec git clone: $!\n";
6003 sub cmd_setup_mergechangelogs {
6004 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6005 setup_mergechangelogs(1);
6008 sub cmd_setup_useremail {
6009 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6013 sub cmd_setup_new_tree {
6014 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6018 #---------- argument parsing and main program ----------
6021 print "dgit version $our_version\n" or die $!;
6025 our (%valopts_long, %valopts_short);
6028 sub defvalopt ($$$$) {
6029 my ($long,$short,$val_re,$how) = @_;
6030 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6031 $valopts_long{$long} = $oi;
6032 $valopts_short{$short} = $oi;
6033 # $how subref should:
6034 # do whatever assignemnt or thing it likes with $_[0]
6035 # if the option should not be passed on to remote, @rvalopts=()
6036 # or $how can be a scalar ref, meaning simply assign the value
6039 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6040 defvalopt '--distro', '-d', '.+', \$idistro;
6041 defvalopt '', '-k', '.+', \$keyid;
6042 defvalopt '--existing-package','', '.*', \$existing_package;
6043 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6044 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6045 defvalopt '--package', '-p', $package_re, \$package;
6046 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6048 defvalopt '', '-C', '.+', sub {
6049 ($changesfile) = (@_);
6050 if ($changesfile =~ s#^(.*)/##) {
6051 $buildproductsdir = $1;
6055 defvalopt '--initiator-tempdir','','.*', sub {
6056 ($initiator_tempdir) = (@_);
6057 $initiator_tempdir =~ m#^/# or
6058 badusage "--initiator-tempdir must be used specify an".
6059 " absolute, not relative, directory."
6065 if (defined $ENV{'DGIT_SSH'}) {
6066 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6067 } elsif (defined $ENV{'GIT_SSH'}) {
6068 @ssh = ($ENV{'GIT_SSH'});
6076 if (!defined $val) {
6077 badusage "$what needs a value" unless @ARGV;
6079 push @rvalopts, $val;
6081 badusage "bad value \`$val' for $what" unless
6082 $val =~ m/^$oi->{Re}$(?!\n)/s;
6083 my $how = $oi->{How};
6084 if (ref($how) eq 'SCALAR') {
6089 push @ropts, @rvalopts;
6093 last unless $ARGV[0] =~ m/^-/;
6097 if (m/^--dry-run$/) {
6100 } elsif (m/^--damp-run$/) {
6103 } elsif (m/^--no-sign$/) {
6106 } elsif (m/^--help$/) {
6108 } elsif (m/^--version$/) {
6110 } elsif (m/^--new$/) {
6113 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6114 ($om = $opts_opt_map{$1}) &&
6118 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6119 !$opts_opt_cmdonly{$1} &&
6120 ($om = $opts_opt_map{$1})) {
6123 } elsif (m/^--(gbp|dpm)$/s) {
6124 push @ropts, "--quilt=$1";
6126 } elsif (m/^--ignore-dirty$/s) {
6129 } elsif (m/^--no-quilt-fixup$/s) {
6131 $quilt_mode = 'nocheck';
6132 } elsif (m/^--no-rm-on-error$/s) {
6135 } elsif (m/^--overwrite$/s) {
6137 $overwrite_version = '';
6138 } elsif (m/^--overwrite=(.+)$/s) {
6140 $overwrite_version = $1;
6141 } elsif (m/^--dep14tag$/s) {
6143 $dodep14tag= 'want';
6144 } elsif (m/^--no-dep14tag$/s) {
6147 } elsif (m/^--always-dep14tag$/s) {
6149 $dodep14tag= 'always';
6150 } elsif (m/^--delayed=(\d+)$/s) {
6153 } elsif (m/^--dgit-view-save=(.+)$/s) {
6155 $split_brain_save = $1;
6156 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6157 } elsif (m/^--(no-)?rm-old-changes$/s) {
6160 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6162 push @deliberatelies, $&;
6163 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6167 } elsif (m/^--force-/) {
6169 "$us: warning: ignoring unknown force option $_\n";
6171 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6172 # undocumented, for testing
6174 $tagformat_want = [ $1, 'command line', 1 ];
6175 # 1 menas overrides distro configuration
6176 } elsif (m/^--always-split-source-build$/s) {
6177 # undocumented, for testing
6179 $need_split_build_invocation = 1;
6180 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6181 $val = $2 ? $' : undef; #';
6182 $valopt->($oi->{Long});
6184 badusage "unknown long option \`$_'";
6191 } elsif (s/^-L/-/) {
6194 } elsif (s/^-h/-/) {
6196 } elsif (s/^-D/-/) {
6200 } elsif (s/^-N/-/) {
6205 push @changesopts, $_;
6207 } elsif (s/^-wn$//s) {
6209 $cleanmode = 'none';
6210 } elsif (s/^-wg$//s) {
6213 } elsif (s/^-wgf$//s) {
6215 $cleanmode = 'git-ff';
6216 } elsif (s/^-wd$//s) {
6218 $cleanmode = 'dpkg-source';
6219 } elsif (s/^-wdd$//s) {
6221 $cleanmode = 'dpkg-source-d';
6222 } elsif (s/^-wc$//s) {
6224 $cleanmode = 'check';
6225 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6226 push @git, '-c', $&;
6227 $gitcfgs{cmdline}{$1} = [ $2 ];
6228 } elsif (s/^-c([^=]+)$//s) {
6229 push @git, '-c', $&;
6230 $gitcfgs{cmdline}{$1} = [ 'true' ];
6231 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6233 $val = undef unless length $val;
6234 $valopt->($oi->{Short});
6237 badusage "unknown short option \`$_'";
6244 sub check_env_sanity () {
6245 my $blocked = new POSIX::SigSet;
6246 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6249 foreach my $name (qw(PIPE CHLD)) {
6250 my $signame = "SIG$name";
6251 my $signum = eval "POSIX::$signame" // die;
6252 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6253 die "$signame is set to something other than SIG_DFL\n";
6254 $blocked->ismember($signum) and
6255 die "$signame is blocked\n";
6261 On entry to dgit, $@
6262 This is a bug produced by something in in your execution environment.
6268 sub finalise_opts_opts () {
6269 foreach my $k (keys %opts_opt_map) {
6270 my $om = $opts_opt_map{$k};
6272 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6274 badcfg "cannot set command for $k"
6275 unless length $om->[0];
6279 foreach my $c (access_cfg_cfgs("opts-$k")) {
6281 map { $_ ? @$_ : () }
6282 map { $gitcfgs{$_}{$c} }
6283 reverse @gitcfgsources;
6284 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6285 "\n" if $debuglevel >= 4;
6287 badcfg "cannot configure options for $k"
6288 if $opts_opt_cmdonly{$k};
6289 my $insertpos = $opts_cfg_insertpos{$k};
6290 @$om = ( @$om[0..$insertpos-1],
6292 @$om[$insertpos..$#$om] );
6296 parseopts_late_defaults();
6299 if ($ENV{$fakeeditorenv}) {
6301 quilt_fixup_editor();
6308 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6309 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6310 if $dryrun_level == 1;
6312 print STDERR $helpmsg or die $!;
6315 my $cmd = shift @ARGV;
6318 my $pre_fn = ${*::}{"pre_$cmd"};
6319 $pre_fn->() if $pre_fn;
6321 sub parseopts_late_defaults () {
6322 if (!defined $rmchanges) {
6323 local $access_forpush;
6324 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6327 if (!defined $quilt_mode) {
6328 local $access_forpush;
6329 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6330 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6332 $quilt_mode =~ m/^($quilt_modes_re)$/
6333 or badcfg "unknown quilt-mode \`$quilt_mode'";
6337 if (!defined $dodep14tag) {
6338 local $access_forpush;
6339 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6340 $dodep14tag =~ m/^($dodep14tag_re)$/
6341 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6345 $need_split_build_invocation ||= quiltmode_splitbrain();
6347 if (!defined $cleanmode) {
6348 local $access_forpush;
6349 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6350 $cleanmode //= 'dpkg-source';
6352 badcfg "unknown clean-mode \`$cleanmode'" unless
6353 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6357 my $fn = ${*::}{"cmd_$cmd"};
6358 $fn or badusage "unknown operation $cmd";