3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2017 Ian Jackson
6 # Copyright (C)2017 Sean Whitton
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
22 use Debian::Dgit::ExitStatus;
26 use Debian::Dgit qw(:DEFAULT :playground);
32 use Dpkg::Control::Hash;
34 use File::Temp qw(tempdir);
37 use Dpkg::Compression;
38 use Dpkg::Compression::Process;
43 use List::MoreUtils qw(pairwise);
44 use Text::Glob qw(match_glob);
45 use Fcntl qw(:DEFAULT :flock);
50 our $our_version = 'UNRELEASED'; ###substituted###
51 our $absurdity = undef; ###substituted###
53 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
64 our $dryrun_level = 0;
66 our $buildproductsdir = '..';
72 our $existing_package = 'dpkg';
74 our $changes_since_version;
76 our $overwrite_version; # undef: not specified; '': check changelog
78 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
80 our $split_brain_save;
81 our $we_are_responder;
82 our $we_are_initiator;
83 our $initiator_tempdir;
84 our $patches_applied_dirtily = 00;
88 our $chase_dsc_distro=1;
90 our %forceopts = map { $_=>0 }
91 qw(unrepresentable unsupported-source-format
92 dsc-changes-mismatch changes-origs-exactly
93 uploading-binaries uploading-source-only
94 import-gitapply-absurd
95 import-gitapply-no-absurd
96 import-dsc-with-dgit-field);
98 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
100 our $suite_re = '[-+.0-9a-z]+';
101 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
102 our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
103 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
104 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
106 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
107 our $splitbraincache = 'dgit-intern/quilt-cache';
108 our $rewritemap = 'dgit-rewrite/map';
110 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
112 our (@git) = qw(git);
113 our (@dget) = qw(dget);
114 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
115 our (@dput) = qw(dput);
116 our (@debsign) = qw(debsign);
117 our (@gpg) = qw(gpg);
118 our (@sbuild) = qw(sbuild);
120 our (@dgit) = qw(dgit);
121 our (@git_debrebase) = qw(git-debrebase);
122 our (@aptget) = qw(apt-get);
123 our (@aptcache) = qw(apt-cache);
124 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
125 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
126 our (@dpkggenchanges) = qw(dpkg-genchanges);
127 our (@mergechanges) = qw(mergechanges -f);
128 our (@gbp_build) = ('');
129 our (@gbp_pq) = ('gbp pq');
130 our (@changesopts) = ('');
132 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
135 'debsign' => \@debsign,
137 'sbuild' => \@sbuild,
141 'git-debrebase' => \@git_debrebase,
142 'apt-get' => \@aptget,
143 'apt-cache' => \@aptcache,
144 'dpkg-source' => \@dpkgsource,
145 'dpkg-buildpackage' => \@dpkgbuildpackage,
146 'dpkg-genchanges' => \@dpkggenchanges,
147 'gbp-build' => \@gbp_build,
148 'gbp-pq' => \@gbp_pq,
149 'ch' => \@changesopts,
150 'mergechanges' => \@mergechanges);
152 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
153 our %opts_cfg_insertpos = map {
155 scalar @{ $opts_opt_map{$_} }
156 } keys %opts_opt_map;
158 sub parseopts_late_defaults();
159 sub setup_gitattrs(;$);
160 sub check_gitattrs($$);
167 our $supplementary_message = '';
168 our $need_split_build_invocation = 0;
169 our $split_brain = 0;
173 return unless forkcheck_mainprocess();
174 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
177 our $remotename = 'dgit';
178 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
182 if (!defined $absurdity) {
184 $absurdity =~ s{/[^/]+$}{/absurd} or die;
188 my ($v,$distro) = @_;
189 return $tagformatfn->($v, $distro);
192 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
194 sub lbranch () { return "$branchprefix/$csuite"; }
195 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
196 sub lref () { return "refs/heads/".lbranch(); }
197 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
198 sub rrref () { return server_ref($csuite); }
208 return "${package}_".(stripepoch $vsn).$sfx
213 return srcfn($vsn,".dsc");
216 sub changespat ($;$) {
217 my ($vsn, $arch) = @_;
218 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
221 sub upstreamversion ($) {
233 return unless forkcheck_mainprocess();
234 foreach my $f (@end) {
236 print STDERR "$us: cleanup: $@" if length $@;
240 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
242 sub forceable_fail ($$) {
243 my ($forceoptsl, $msg) = @_;
244 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
245 print STDERR "warning: overriding problem due to --force:\n". $msg;
249 my ($forceoptsl) = @_;
250 my @got = grep { $forceopts{$_} } @$forceoptsl;
251 return 0 unless @got;
253 "warning: skipping checks or functionality due to --force-$got[0]\n";
256 sub no_such_package () {
257 print STDERR "$us: package $package does not exist in suite $isuite\n";
261 sub deliberately ($) {
263 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
266 sub deliberately_not_fast_forward () {
267 foreach (qw(not-fast-forward fresh-repo)) {
268 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
272 sub quiltmode_splitbrain () {
273 $quilt_mode =~ m/gbp|dpm|unapplied/;
276 sub opts_opt_multi_cmd {
278 push @cmd, split /\s+/, shift @_;
284 return opts_opt_multi_cmd @gbp_pq;
287 sub dgit_privdir () {
288 our $dgit_privdir_made //= ensure_a_playground 'dgit';
291 sub branch_gdr_info ($$) {
292 my ($symref, $head) = @_;
293 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
294 gdr_ffq_prev_branchinfo($symref);
295 return () unless $status eq 'branch';
296 $ffq_prev = git_get_ref $ffq_prev;
297 $gdrlast = git_get_ref $gdrlast;
298 $gdrlast &&= is_fast_fwd $gdrlast, $head;
299 return ($ffq_prev, $gdrlast);
302 sub branch_is_gdr ($$) {
303 my ($symref, $head) = @_;
304 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
305 return 0 unless $ffq_prev || $gdrlast;
309 sub branch_is_gdr_unstitched_ff ($$$) {
310 my ($symref, $head, $ancestor) = @_;
311 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
312 return 0 unless $ffq_prev;
313 return 0 unless is_fast_fwd $ancestor, $ffq_prev;
317 #---------- remote protocol support, common ----------
319 # remote push initiator/responder protocol:
320 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
321 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
322 # < dgit-remote-push-ready <actual-proto-vsn>
329 # > supplementary-message NBYTES # $protovsn >= 3
334 # > file parsed-changelog
335 # [indicates that output of dpkg-parsechangelog follows]
336 # > data-block NBYTES
337 # > [NBYTES bytes of data (no newline)]
338 # [maybe some more blocks]
347 # > param head DGIT-VIEW-HEAD
348 # > param csuite SUITE
349 # > param tagformat old|new
350 # > param maint-view MAINT-VIEW-HEAD
352 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
353 # > file buildinfo # for buildinfos to sign
355 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
356 # # goes into tag, for replay prevention
359 # [indicates that signed tag is wanted]
360 # < data-block NBYTES
361 # < [NBYTES bytes of data (no newline)]
362 # [maybe some more blocks]
366 # > want signed-dsc-changes
367 # < data-block NBYTES [transfer of signed dsc]
369 # < data-block NBYTES [transfer of signed changes]
371 # < data-block NBYTES [transfer of each signed buildinfo
372 # [etc] same number and order as "file buildinfo"]
380 sub i_child_report () {
381 # Sees if our child has died, and reap it if so. Returns a string
382 # describing how it died if it failed, or undef otherwise.
383 return undef unless $i_child_pid;
384 my $got = waitpid $i_child_pid, WNOHANG;
385 return undef if $got <= 0;
386 die unless $got == $i_child_pid;
387 $i_child_pid = undef;
388 return undef unless $?;
389 return "build host child ".waitstatusmsg();
394 fail "connection lost: $!" if $fh->error;
395 fail "protocol violation; $m not expected";
398 sub badproto_badread ($$) {
400 fail "connection lost: $!" if $!;
401 my $report = i_child_report();
402 fail $report if defined $report;
403 badproto $fh, "eof (reading $wh)";
406 sub protocol_expect (&$) {
407 my ($match, $fh) = @_;
410 defined && chomp or badproto_badread $fh, "protocol message";
418 badproto $fh, "\`$_'";
421 sub protocol_send_file ($$) {
422 my ($fh, $ourfn) = @_;
423 open PF, "<", $ourfn or die "$ourfn: $!";
426 my $got = read PF, $d, 65536;
427 die "$ourfn: $!" unless defined $got;
429 print $fh "data-block ".length($d)."\n" or die $!;
430 print $fh $d or die $!;
432 PF->error and die "$ourfn $!";
433 print $fh "data-end\n" or die $!;
437 sub protocol_read_bytes ($$) {
438 my ($fh, $nbytes) = @_;
439 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
441 my $got = read $fh, $d, $nbytes;
442 $got==$nbytes or badproto_badread $fh, "data block";
446 sub protocol_receive_file ($$) {
447 my ($fh, $ourfn) = @_;
448 printdebug "() $ourfn\n";
449 open PF, ">", $ourfn or die "$ourfn: $!";
451 my ($y,$l) = protocol_expect {
452 m/^data-block (.*)$/ ? (1,$1) :
453 m/^data-end$/ ? (0,) :
457 my $d = protocol_read_bytes $fh, $l;
458 print PF $d or die $!;
463 #---------- remote protocol support, responder ----------
465 sub responder_send_command ($) {
467 return unless $we_are_responder;
468 # called even without $we_are_responder
469 printdebug ">> $command\n";
470 print PO $command, "\n" or die $!;
473 sub responder_send_file ($$) {
474 my ($keyword, $ourfn) = @_;
475 return unless $we_are_responder;
476 printdebug "]] $keyword $ourfn\n";
477 responder_send_command "file $keyword";
478 protocol_send_file \*PO, $ourfn;
481 sub responder_receive_files ($@) {
482 my ($keyword, @ourfns) = @_;
483 die unless $we_are_responder;
484 printdebug "[[ $keyword @ourfns\n";
485 responder_send_command "want $keyword";
486 foreach my $fn (@ourfns) {
487 protocol_receive_file \*PI, $fn;
490 protocol_expect { m/^files-end$/ } \*PI;
493 #---------- remote protocol support, initiator ----------
495 sub initiator_expect (&) {
497 protocol_expect { &$match } \*RO;
500 #---------- end remote code ----------
503 if ($we_are_responder) {
505 responder_send_command "progress ".length($m) or die $!;
506 print PO $m or die $!;
516 $ua = LWP::UserAgent->new();
520 progress "downloading $what...";
521 my $r = $ua->get(@_) or die $!;
522 return undef if $r->code == 404;
523 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
524 return $r->decoded_content(charset => 'none');
527 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
529 sub act_local () { return $dryrun_level <= 1; }
530 sub act_scary () { return !$dryrun_level; }
533 if (!$dryrun_level) {
534 progress "$us ok: @_";
536 progress "would be ok: @_ (but dry run only)";
541 printcmd(\*STDERR,$debugprefix."#",@_);
544 sub runcmd_ordryrun {
552 sub runcmd_ordryrun_local {
560 our $helpmsg = <<END;
562 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
563 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
564 dgit [dgit-opts] build [dpkg-buildpackage-opts]
565 dgit [dgit-opts] sbuild [sbuild-opts]
566 dgit [dgit-opts] push [dgit-opts] [suite]
567 dgit [dgit-opts] push-source [dgit-opts] [suite]
568 dgit [dgit-opts] rpush build-host:build-dir ...
569 important dgit options:
570 -k<keyid> sign tag and package with <keyid> instead of default
571 --dry-run -n do not change anything, but go through the motions
572 --damp-run -L like --dry-run but make local changes, without signing
573 --new -N allow introducing a new package
574 --debug -D increase debug level
575 -c<name>=<value> set git config option (used directly by dgit too)
578 our $later_warning_msg = <<END;
579 Perhaps the upload is stuck in incoming. Using the version from git.
583 print STDERR "$us: @_\n", $helpmsg or die $!;
588 @ARGV or badusage "too few arguments";
589 return scalar shift @ARGV;
593 not_necessarily_a_tree();
596 print $helpmsg or die $!;
600 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
602 our %defcfg = ('dgit.default.distro' => 'debian',
603 'dgit.default.default-suite' => 'unstable',
604 'dgit.default.old-dsc-distro' => 'debian',
605 'dgit-suite.*-security.distro' => 'debian-security',
606 'dgit.default.username' => '',
607 'dgit.default.archive-query-default-component' => 'main',
608 'dgit.default.ssh' => 'ssh',
609 'dgit.default.archive-query' => 'madison:',
610 'dgit.default.sshpsql-dbname' => 'service=projectb',
611 'dgit.default.aptget-components' => 'main',
612 'dgit.default.dgit-tag-format' => 'new,old,maint',
613 'dgit.default.source-only-uploads' => 'ok',
614 'dgit.dsc-url-proto-ok.http' => 'true',
615 'dgit.dsc-url-proto-ok.https' => 'true',
616 'dgit.dsc-url-proto-ok.git' => 'true',
617 'dgit.vcs-git.suites', => 'sid', # ;-separated
618 'dgit.default.dsc-url-proto-ok' => 'false',
619 # old means "repo server accepts pushes with old dgit tags"
620 # new means "repo server accepts pushes with new dgit tags"
621 # maint means "repo server accepts split brain pushes"
622 # hist means "repo server may have old pushes without new tag"
623 # ("hist" is implied by "old")
624 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
625 'dgit-distro.debian.git-check' => 'url',
626 'dgit-distro.debian.git-check-suffix' => '/info/refs',
627 'dgit-distro.debian.new-private-pushers' => 't',
628 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
629 'dgit-distro.debian/push.git-url' => '',
630 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
631 'dgit-distro.debian/push.git-user-force' => 'dgit',
632 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
633 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
634 'dgit-distro.debian/push.git-create' => 'true',
635 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
636 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
637 # 'dgit-distro.debian.archive-query-tls-key',
638 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
639 # ^ this does not work because curl is broken nowadays
640 # Fixing #790093 properly will involve providing providing the key
641 # in some pacagke and maybe updating these paths.
643 # 'dgit-distro.debian.archive-query-tls-curl-args',
644 # '--ca-path=/etc/ssl/ca-debian',
645 # ^ this is a workaround but works (only) on DSA-administered machines
646 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
647 'dgit-distro.debian.git-url-suffix' => '',
648 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
649 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
650 'dgit-distro.debian-security.archive-query' => 'aptget:',
651 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
652 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
653 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
654 'dgit-distro.debian-security.nominal-distro' => 'debian',
655 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
656 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
657 'dgit-distro.ubuntu.git-check' => 'false',
658 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
659 'dgit-distro.test-dummy.ssh' => "$td/ssh",
660 'dgit-distro.test-dummy.username' => "alice",
661 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
662 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
663 'dgit-distro.test-dummy.git-url' => "$td/git",
664 'dgit-distro.test-dummy.git-host' => "git",
665 'dgit-distro.test-dummy.git-path' => "$td/git",
666 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
667 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
668 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
669 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
673 our @gitcfgsources = qw(cmdline local global system);
674 our $invoked_in_git_tree = 1;
676 sub git_slurp_config () {
677 # This algoritm is a bit subtle, but this is needed so that for
678 # options which we want to be single-valued, we allow the
679 # different config sources to override properly. See #835858.
680 foreach my $src (@gitcfgsources) {
681 next if $src eq 'cmdline';
682 # we do this ourselves since git doesn't handle it
684 $gitcfgs{$src} = git_slurp_config_src $src;
688 sub git_get_config ($) {
690 foreach my $src (@gitcfgsources) {
691 my $l = $gitcfgs{$src}{$c};
692 confess "internal error ($l $c)" if $l && !ref $l;
693 printdebug"C $c ".(defined $l ?
694 join " ", map { messagequote "'$_'" } @$l :
698 @$l==1 or badcfg "multiple values for $c".
699 " (in $src git config)" if @$l > 1;
707 return undef if $c =~ /RETURN-UNDEF/;
708 printdebug "C? $c\n" if $debuglevel >= 5;
709 my $v = git_get_config($c);
710 return $v if defined $v;
711 my $dv = $defcfg{$c};
713 printdebug "CD $c $dv\n" if $debuglevel >= 4;
717 badcfg "need value for one of: @_\n".
718 "$us: distro or suite appears not to be (properly) supported";
721 sub not_necessarily_a_tree () {
722 # needs to be called from pre_*
723 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
724 $invoked_in_git_tree = 0;
727 sub access_basedistro__noalias () {
728 if (defined $idistro) {
731 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
732 return $def if defined $def;
733 foreach my $src (@gitcfgsources, 'internal') {
734 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
736 foreach my $k (keys %$kl) {
737 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
739 next unless match_glob $dpat, $isuite;
743 return cfg("dgit.default.distro");
747 sub access_basedistro () {
748 my $noalias = access_basedistro__noalias();
749 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
750 return $canon // $noalias;
753 sub access_nomdistro () {
754 my $base = access_basedistro();
755 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
756 $r =~ m/^$distro_re$/ or badcfg
757 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
761 sub access_quirk () {
762 # returns (quirk name, distro to use instead or undef, quirk-specific info)
763 my $basedistro = access_basedistro();
764 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
766 if (defined $backports_quirk) {
767 my $re = $backports_quirk;
768 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
770 $re =~ s/\%/([-0-9a-z_]+)/
771 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
772 if ($isuite =~ m/^$re$/) {
773 return ('backports',"$basedistro-backports",$1);
776 return ('none',undef);
781 sub parse_cfg_bool ($$$) {
782 my ($what,$def,$v) = @_;
785 $v =~ m/^[ty1]/ ? 1 :
786 $v =~ m/^[fn0]/ ? 0 :
787 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
790 sub access_forpush_config () {
791 my $d = access_basedistro();
795 parse_cfg_bool('new-private-pushers', 0,
796 cfg("dgit-distro.$d.new-private-pushers",
799 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
802 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
803 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
804 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
805 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
808 sub access_forpush () {
809 $access_forpush //= access_forpush_config();
810 return $access_forpush;
814 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
815 badcfg "pushing but distro is configured readonly"
816 if access_forpush_config() eq '0';
818 $supplementary_message = <<'END' unless $we_are_responder;
819 Push failed, before we got started.
820 You can retry the push, after fixing the problem, if you like.
822 parseopts_late_defaults();
826 parseopts_late_defaults();
829 sub supplementary_message ($) {
831 if (!$we_are_responder) {
832 $supplementary_message = $msg;
834 } elsif ($protovsn >= 3) {
835 responder_send_command "supplementary-message ".length($msg)
837 print PO $msg or die $!;
841 sub access_distros () {
842 # Returns list of distros to try, in order
845 # 0. `instead of' distro name(s) we have been pointed to
846 # 1. the access_quirk distro, if any
847 # 2a. the user's specified distro, or failing that } basedistro
848 # 2b. the distro calculated from the suite }
849 my @l = access_basedistro();
851 my (undef,$quirkdistro) = access_quirk();
852 unshift @l, $quirkdistro;
853 unshift @l, $instead_distro;
854 @l = grep { defined } @l;
856 push @l, access_nomdistro();
858 if (access_forpush()) {
859 @l = map { ("$_/push", $_) } @l;
864 sub access_cfg_cfgs (@) {
867 # The nesting of these loops determines the search order. We put
868 # the key loop on the outside so that we search all the distros
869 # for each key, before going on to the next key. That means that
870 # if access_cfg is called with a more specific, and then a less
871 # specific, key, an earlier distro can override the less specific
872 # without necessarily overriding any more specific keys. (If the
873 # distro wants to override the more specific keys it can simply do
874 # so; whereas if we did the loop the other way around, it would be
875 # impossible to for an earlier distro to override a less specific
876 # key but not the more specific ones without restating the unknown
877 # values of the more specific keys.
880 # We have to deal with RETURN-UNDEF specially, so that we don't
881 # terminate the search prematurely.
883 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
886 foreach my $d (access_distros()) {
887 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
889 push @cfgs, map { "dgit.default.$_" } @realkeys;
896 my (@cfgs) = access_cfg_cfgs(@keys);
897 my $value = cfg(@cfgs);
901 sub access_cfg_bool ($$) {
902 my ($def, @keys) = @_;
903 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
906 sub string_to_ssh ($) {
908 if ($spec =~ m/\s/) {
909 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
915 sub access_cfg_ssh () {
916 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
917 if (!defined $gitssh) {
920 return string_to_ssh $gitssh;
924 sub access_runeinfo ($) {
926 return ": dgit ".access_basedistro()." $info ;";
929 sub access_someuserhost ($) {
931 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
932 defined($user) && length($user) or
933 $user = access_cfg("$some-user",'username');
934 my $host = access_cfg("$some-host");
935 return length($user) ? "$user\@$host" : $host;
938 sub access_gituserhost () {
939 return access_someuserhost('git');
942 sub access_giturl (;$) {
944 my $url = access_cfg('git-url','RETURN-UNDEF');
947 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
948 return undef unless defined $proto;
951 access_gituserhost().
952 access_cfg('git-path');
954 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
957 return "$url/$package$suffix";
960 sub commit_getclogp ($) {
961 # Returns the parsed changelog hashref for a particular commit
963 our %commit_getclogp_memo;
964 my $memo = $commit_getclogp_memo{$objid};
965 return $memo if $memo;
967 my $mclog = dgit_privdir()."clog";
968 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
969 "$objid:debian/changelog";
970 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
973 sub parse_dscdata () {
974 my $dscfh = new IO::File \$dscdata, '<' or die $!;
975 printdebug Dumper($dscdata) if $debuglevel>1;
976 $dsc = parsecontrolfh($dscfh,$dscurl,1);
977 printdebug Dumper($dsc) if $debuglevel>1;
982 sub archive_query ($;@) {
983 my ($method) = shift @_;
984 fail "this operation does not support multiple comma-separated suites"
986 my $query = access_cfg('archive-query','RETURN-UNDEF');
987 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
990 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
993 sub archive_query_prepend_mirror {
994 my $m = access_cfg('mirror');
995 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
998 sub pool_dsc_subpath ($$) {
999 my ($vsn,$component) = @_; # $package is implict arg
1000 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1001 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1004 sub cfg_apply_map ($$$) {
1005 my ($varref, $what, $mapspec) = @_;
1006 return unless $mapspec;
1008 printdebug "config $what EVAL{ $mapspec; }\n";
1010 eval "package Dgit::Config; $mapspec;";
1015 #---------- `ftpmasterapi' archive query method (nascent) ----------
1017 sub archive_api_query_cmd ($) {
1019 my @cmd = (@curl, qw(-sS));
1020 my $url = access_cfg('archive-query-url');
1021 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1023 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1024 foreach my $key (split /\:/, $keys) {
1025 $key =~ s/\%HOST\%/$host/g;
1027 fail "for $url: stat $key: $!" unless $!==ENOENT;
1030 fail "config requested specific TLS key but do not know".
1031 " how to get curl to use exactly that EE key ($key)";
1032 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1033 # # Sadly the above line does not work because of changes
1034 # # to gnutls. The real fix for #790093 may involve
1035 # # new curl options.
1038 # Fixing #790093 properly will involve providing a value
1039 # for this on clients.
1040 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1041 push @cmd, split / /, $kargs if defined $kargs;
1043 push @cmd, $url.$subpath;
1047 sub api_query ($$;$) {
1049 my ($data, $subpath, $ok404) = @_;
1050 badcfg "ftpmasterapi archive query method takes no data part"
1052 my @cmd = archive_api_query_cmd($subpath);
1053 my $url = $cmd[$#cmd];
1054 push @cmd, qw(-w %{http_code});
1055 my $json = cmdoutput @cmd;
1056 unless ($json =~ s/\d+\d+\d$//) {
1057 failedcmd_report_cmd undef, @cmd;
1058 fail "curl failed to print 3-digit HTTP code";
1061 return undef if $code eq '404' && $ok404;
1062 fail "fetch of $url gave HTTP code $code"
1063 unless $url =~ m#^file://# or $code =~ m/^2/;
1064 return decode_json($json);
1067 sub canonicalise_suite_ftpmasterapi {
1068 my ($proto,$data) = @_;
1069 my $suites = api_query($data, 'suites');
1071 foreach my $entry (@$suites) {
1073 my $v = $entry->{$_};
1074 defined $v && $v eq $isuite;
1075 } qw(codename name);
1076 push @matched, $entry;
1078 fail "unknown suite $isuite" unless @matched;
1081 @matched==1 or die "multiple matches for suite $isuite\n";
1082 $cn = "$matched[0]{codename}";
1083 defined $cn or die "suite $isuite info has no codename\n";
1084 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1086 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1091 sub archive_query_ftpmasterapi {
1092 my ($proto,$data) = @_;
1093 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1095 my $digester = Digest::SHA->new(256);
1096 foreach my $entry (@$info) {
1098 my $vsn = "$entry->{version}";
1099 my ($ok,$msg) = version_check $vsn;
1100 die "bad version: $msg\n" unless $ok;
1101 my $component = "$entry->{component}";
1102 $component =~ m/^$component_re$/ or die "bad component";
1103 my $filename = "$entry->{filename}";
1104 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1105 or die "bad filename";
1106 my $sha256sum = "$entry->{sha256sum}";
1107 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1108 push @rows, [ $vsn, "/pool/$component/$filename",
1109 $digester, $sha256sum ];
1111 die "bad ftpmaster api response: $@\n".Dumper($entry)
1114 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1115 return archive_query_prepend_mirror @rows;
1118 sub file_in_archive_ftpmasterapi {
1119 my ($proto,$data,$filename) = @_;
1120 my $pat = $filename;
1123 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1124 my $info = api_query($data, "file_in_archive/$pat", 1);
1127 sub package_not_wholly_new_ftpmasterapi {
1128 my ($proto,$data,$pkg) = @_;
1129 my $info = api_query($data,"madison?package=${pkg}&f=json");
1133 #---------- `aptget' archive query method ----------
1136 our $aptget_releasefile;
1137 our $aptget_configpath;
1139 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1140 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1142 sub aptget_cache_clean {
1143 runcmd_ordryrun_local qw(sh -ec),
1144 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1148 sub aptget_lock_acquire () {
1149 my $lockfile = "$aptget_base/lock";
1150 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1151 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1154 sub aptget_prep ($) {
1156 return if defined $aptget_base;
1158 badcfg "aptget archive query method takes no data part"
1161 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1164 ensuredir "$cache/dgit";
1166 access_cfg('aptget-cachekey','RETURN-UNDEF')
1167 // access_nomdistro();
1169 $aptget_base = "$cache/dgit/aptget";
1170 ensuredir $aptget_base;
1172 my $quoted_base = $aptget_base;
1173 die "$quoted_base contains bad chars, cannot continue"
1174 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1176 ensuredir $aptget_base;
1178 aptget_lock_acquire();
1180 aptget_cache_clean();
1182 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1183 my $sourceslist = "source.list#$cachekey";
1185 my $aptsuites = $isuite;
1186 cfg_apply_map(\$aptsuites, 'suite map',
1187 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1189 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1190 printf SRCS "deb-src %s %s %s\n",
1191 access_cfg('mirror'),
1193 access_cfg('aptget-components')
1196 ensuredir "$aptget_base/cache";
1197 ensuredir "$aptget_base/lists";
1199 open CONF, ">", $aptget_configpath or die $!;
1201 Debug::NoLocking "true";
1202 APT::Get::List-Cleanup "false";
1203 #clear APT::Update::Post-Invoke-Success;
1204 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1205 Dir::State::Lists "$quoted_base/lists";
1206 Dir::Etc::preferences "$quoted_base/preferences";
1207 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1208 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1211 foreach my $key (qw(
1214 Dir::Cache::Archives
1215 Dir::Etc::SourceParts
1216 Dir::Etc::preferencesparts
1218 ensuredir "$aptget_base/$key";
1219 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1222 my $oldatime = (time // die $!) - 1;
1223 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1224 next unless stat_exists $oldlist;
1225 my ($mtime) = (stat _)[9];
1226 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1229 runcmd_ordryrun_local aptget_aptget(), qw(update);
1232 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1233 next unless stat_exists $oldlist;
1234 my ($atime) = (stat _)[8];
1235 next if $atime == $oldatime;
1236 push @releasefiles, $oldlist;
1238 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1239 @releasefiles = @inreleasefiles if @inreleasefiles;
1240 die "apt updated wrong number of Release files (@releasefiles), erk"
1241 unless @releasefiles == 1;
1243 ($aptget_releasefile) = @releasefiles;
1246 sub canonicalise_suite_aptget {
1247 my ($proto,$data) = @_;
1250 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1252 foreach my $name (qw(Codename Suite)) {
1253 my $val = $release->{$name};
1255 printdebug "release file $name: $val\n";
1256 $val =~ m/^$suite_re$/o or fail
1257 "Release file ($aptget_releasefile) specifies intolerable $name";
1258 cfg_apply_map(\$val, 'suite rmap',
1259 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1266 sub archive_query_aptget {
1267 my ($proto,$data) = @_;
1270 ensuredir "$aptget_base/source";
1271 foreach my $old (<$aptget_base/source/*.dsc>) {
1272 unlink $old or die "$old: $!";
1275 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1276 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1277 # avoids apt-get source failing with ambiguous error code
1279 runcmd_ordryrun_local
1280 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1281 aptget_aptget(), qw(--download-only --only-source source), $package;
1283 my @dscs = <$aptget_base/source/*.dsc>;
1284 fail "apt-get source did not produce a .dsc" unless @dscs;
1285 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1287 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1290 my $uri = "file://". uri_escape $dscs[0];
1291 $uri =~ s{\%2f}{/}gi;
1292 return [ (getfield $pre_dsc, 'Version'), $uri ];
1295 sub file_in_archive_aptget () { return undef; }
1296 sub package_not_wholly_new_aptget () { return undef; }
1298 #---------- `dummyapicat' archive query method ----------
1300 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1301 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1303 sub dummycatapi_run_in_mirror ($@) {
1304 # runs $fn with FIA open onto rune
1305 my ($rune, $argl, $fn) = @_;
1307 my $mirror = access_cfg('mirror');
1308 $mirror =~ s#^file://#/# or die "$mirror ?";
1309 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1310 qw(x), $mirror, @$argl);
1311 debugcmd "-|", @cmd;
1312 open FIA, "-|", @cmd or die $!;
1314 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1318 sub file_in_archive_dummycatapi ($$$) {
1319 my ($proto,$data,$filename) = @_;
1321 dummycatapi_run_in_mirror '
1322 find -name "$1" -print0 |
1324 ', [$filename], sub {
1327 printdebug "| $_\n";
1328 m/^(\w+) (\S+)$/ or die "$_ ?";
1329 push @out, { sha256sum => $1, filename => $2 };
1335 sub package_not_wholly_new_dummycatapi {
1336 my ($proto,$data,$pkg) = @_;
1337 dummycatapi_run_in_mirror "
1338 find -name ${pkg}_*.dsc
1345 #---------- `madison' archive query method ----------
1347 sub archive_query_madison {
1348 return archive_query_prepend_mirror
1349 map { [ @$_[0..1] ] } madison_get_parse(@_);
1352 sub madison_get_parse {
1353 my ($proto,$data) = @_;
1354 die unless $proto eq 'madison';
1355 if (!length $data) {
1356 $data= access_cfg('madison-distro','RETURN-UNDEF');
1357 $data //= access_basedistro();
1359 $rmad{$proto,$data,$package} ||= cmdoutput
1360 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1361 my $rmad = $rmad{$proto,$data,$package};
1364 foreach my $l (split /\n/, $rmad) {
1365 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1366 \s*( [^ \t|]+ )\s* \|
1367 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1368 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1369 $1 eq $package or die "$rmad $package ?";
1376 $component = access_cfg('archive-query-default-component');
1378 $5 eq 'source' or die "$rmad ?";
1379 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1381 return sort { -version_compare($a->[0],$b->[0]); } @out;
1384 sub canonicalise_suite_madison {
1385 # madison canonicalises for us
1386 my @r = madison_get_parse(@_);
1388 "unable to canonicalise suite using package $package".
1389 " which does not appear to exist in suite $isuite;".
1390 " --existing-package may help";
1394 sub file_in_archive_madison { return undef; }
1395 sub package_not_wholly_new_madison { return undef; }
1397 #---------- `sshpsql' archive query method ----------
1400 my ($data,$runeinfo,$sql) = @_;
1401 if (!length $data) {
1402 $data= access_someuserhost('sshpsql').':'.
1403 access_cfg('sshpsql-dbname');
1405 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1406 my ($userhost,$dbname) = ($`,$'); #';
1408 my @cmd = (access_cfg_ssh, $userhost,
1409 access_runeinfo("ssh-psql $runeinfo").
1410 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1411 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1413 open P, "-|", @cmd or die $!;
1416 printdebug(">|$_|\n");
1419 $!=0; $?=0; close P or failedcmd @cmd;
1421 my $nrows = pop @rows;
1422 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1423 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1424 @rows = map { [ split /\|/, $_ ] } @rows;
1425 my $ncols = scalar @{ shift @rows };
1426 die if grep { scalar @$_ != $ncols } @rows;
1430 sub sql_injection_check {
1431 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1434 sub archive_query_sshpsql ($$) {
1435 my ($proto,$data) = @_;
1436 sql_injection_check $isuite, $package;
1437 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1438 SELECT source.version, component.name, files.filename, files.sha256sum
1440 JOIN src_associations ON source.id = src_associations.source
1441 JOIN suite ON suite.id = src_associations.suite
1442 JOIN dsc_files ON dsc_files.source = source.id
1443 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1444 JOIN component ON component.id = files_archive_map.component_id
1445 JOIN files ON files.id = dsc_files.file
1446 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1447 AND source.source='$package'
1448 AND files.filename LIKE '%.dsc';
1450 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1451 my $digester = Digest::SHA->new(256);
1453 my ($vsn,$component,$filename,$sha256sum) = @$_;
1454 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1456 return archive_query_prepend_mirror @rows;
1459 sub canonicalise_suite_sshpsql ($$) {
1460 my ($proto,$data) = @_;
1461 sql_injection_check $isuite;
1462 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1463 SELECT suite.codename
1464 FROM suite where suite_name='$isuite' or codename='$isuite';
1466 @rows = map { $_->[0] } @rows;
1467 fail "unknown suite $isuite" unless @rows;
1468 die "ambiguous $isuite: @rows ?" if @rows>1;
1472 sub file_in_archive_sshpsql ($$$) { return undef; }
1473 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1475 #---------- `dummycat' archive query method ----------
1477 sub canonicalise_suite_dummycat ($$) {
1478 my ($proto,$data) = @_;
1479 my $dpath = "$data/suite.$isuite";
1480 if (!open C, "<", $dpath) {
1481 $!==ENOENT or die "$dpath: $!";
1482 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1486 chomp or die "$dpath: $!";
1488 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1492 sub archive_query_dummycat ($$) {
1493 my ($proto,$data) = @_;
1494 canonicalise_suite();
1495 my $dpath = "$data/package.$csuite.$package";
1496 if (!open C, "<", $dpath) {
1497 $!==ENOENT or die "$dpath: $!";
1498 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1506 printdebug "dummycat query $csuite $package $dpath | $_\n";
1507 my @row = split /\s+/, $_;
1508 @row==2 or die "$dpath: $_ ?";
1511 C->error and die "$dpath: $!";
1513 return archive_query_prepend_mirror
1514 sort { -version_compare($a->[0],$b->[0]); } @rows;
1517 sub file_in_archive_dummycat () { return undef; }
1518 sub package_not_wholly_new_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);
1684 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1688 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1689 $playground = fresh_playground 'dgit/unpack';
1692 sub mktree_in_ud_here () {
1693 playtree_setup $gitcfgs{local};
1696 sub git_write_tree () {
1697 my $tree = cmdoutput @git, qw(write-tree);
1698 $tree =~ m/^\w+$/ or die "$tree ?";
1702 sub git_add_write_tree () {
1703 runcmd @git, qw(add -Af .);
1704 return git_write_tree();
1707 sub remove_stray_gits ($) {
1709 my @gitscmd = qw(find -name .git -prune -print0);
1710 debugcmd "|",@gitscmd;
1711 open GITS, "-|", @gitscmd or die $!;
1716 print STDERR "$us: warning: removing from $what: ",
1717 (messagequote $_), "\n";
1721 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1724 sub mktree_in_ud_from_only_subdir ($;$) {
1725 my ($what,$raw) = @_;
1726 # changes into the subdir
1729 die "expected one subdir but found @dirs ?" unless @dirs==1;
1730 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1734 remove_stray_gits($what);
1735 mktree_in_ud_here();
1737 my ($format, $fopts) = get_source_format();
1738 if (madformat($format)) {
1743 my $tree=git_add_write_tree();
1744 return ($tree,$dir);
1747 our @files_csum_info_fields =
1748 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1749 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1750 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1752 sub dsc_files_info () {
1753 foreach my $csumi (@files_csum_info_fields) {
1754 my ($fname, $module, $method) = @$csumi;
1755 my $field = $dsc->{$fname};
1756 next unless defined $field;
1757 eval "use $module; 1;" or die $@;
1759 foreach (split /\n/, $field) {
1761 m/^(\w+) (\d+) (\S+)$/ or
1762 fail "could not parse .dsc $fname line \`$_'";
1763 my $digester = eval "$module"."->$method;" or die $@;
1768 Digester => $digester,
1773 fail "missing any supported Checksums-* or Files field in ".
1774 $dsc->get_option('name');
1778 map { $_->{Filename} } dsc_files_info();
1781 sub files_compare_inputs (@) {
1786 my $showinputs = sub {
1787 return join "; ", map { $_->get_option('name') } @$inputs;
1790 foreach my $in (@$inputs) {
1792 my $in_name = $in->get_option('name');
1794 printdebug "files_compare_inputs $in_name\n";
1796 foreach my $csumi (@files_csum_info_fields) {
1797 my ($fname) = @$csumi;
1798 printdebug "files_compare_inputs $in_name $fname\n";
1800 my $field = $in->{$fname};
1801 next unless defined $field;
1804 foreach (split /\n/, $field) {
1807 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1808 fail "could not parse $in_name $fname line \`$_'";
1810 printdebug "files_compare_inputs $in_name $fname $f\n";
1814 my $re = \ $record{$f}{$fname};
1816 $fchecked{$f}{$in_name} = 1;
1818 fail "hash or size of $f varies in $fname fields".
1819 " (between: ".$showinputs->().")";
1824 @files = sort @files;
1825 $expected_files //= \@files;
1826 "@$expected_files" eq "@files" or
1827 fail "file list in $in_name varies between hash fields!";
1830 fail "$in_name has no files list field(s)";
1832 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1835 grep { keys %$_ == @$inputs-1 } values %fchecked
1836 or fail "no file appears in all file lists".
1837 " (looked in: ".$showinputs->().")";
1840 sub is_orig_file_in_dsc ($$) {
1841 my ($f, $dsc_files_info) = @_;
1842 return 0 if @$dsc_files_info <= 1;
1843 # One file means no origs, and the filename doesn't have a "what
1844 # part of dsc" component. (Consider versions ending `.orig'.)
1845 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1849 sub is_orig_file_of_vsn ($$) {
1850 my ($f, $upstreamvsn) = @_;
1851 my $base = srcfn $upstreamvsn, '';
1852 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1856 # This function determines whether a .changes file is source-only from
1857 # the point of view of dak. Thus, it permits *_source.buildinfo
1860 # It does not, however, permit any other buildinfo files. After a
1861 # source-only upload, the buildds will try to upload files like
1862 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1863 # named like this in their (otherwise) source-only upload, the uploads
1864 # of the buildd can be rejected by dak. Fixing the resultant
1865 # situation can require manual intervention. So we block such
1866 # .buildinfo files when the user tells us to perform a source-only
1867 # upload (such as when using the push-source subcommand with the -C
1868 # option, which calls this function).
1870 # Note, though, that when dgit is told to prepare a source-only
1871 # upload, such as when subcommands like build-source and push-source
1872 # without -C are used, dgit has a more restrictive notion of
1873 # source-only .changes than dak: such uploads will never include
1874 # *_source.buildinfo files. This is because there is no use for such
1875 # files when using a tool like dgit to produce the source package, as
1876 # dgit ensures the source is identical to git HEAD.
1877 sub test_source_only_changes ($) {
1879 foreach my $l (split /\n/, getfield $changes, 'Files') {
1880 $l =~ m/\S+$/ or next;
1881 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1882 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1883 print "purportedly source-only changes polluted by $&\n";
1890 sub changes_update_origs_from_dsc ($$$$) {
1891 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1893 printdebug "checking origs needed ($upstreamvsn)...\n";
1894 $_ = getfield $changes, 'Files';
1895 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1896 fail "cannot find section/priority from .changes Files field";
1897 my $placementinfo = $1;
1899 printdebug "checking origs needed placement '$placementinfo'...\n";
1900 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1901 $l =~ m/\S+$/ or next;
1903 printdebug "origs $file | $l\n";
1904 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1905 printdebug "origs $file is_orig\n";
1906 my $have = archive_query('file_in_archive', $file);
1907 if (!defined $have) {
1909 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1915 printdebug "origs $file \$#\$have=$#$have\n";
1916 foreach my $h (@$have) {
1919 foreach my $csumi (@files_csum_info_fields) {
1920 my ($fname, $module, $method, $archivefield) = @$csumi;
1921 next unless defined $h->{$archivefield};
1922 $_ = $dsc->{$fname};
1923 next unless defined;
1924 m/^(\w+) .* \Q$file\E$/m or
1925 fail ".dsc $fname missing entry for $file";
1926 if ($h->{$archivefield} eq $1) {
1930 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1933 die "$file ".Dumper($h)." ?!" if $same && @differ;
1936 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1939 printdebug "origs $file f.same=$found_same".
1940 " #f._differ=$#found_differ\n";
1941 if (@found_differ && !$found_same) {
1943 "archive contains $file with different checksum",
1946 # Now we edit the changes file to add or remove it
1947 foreach my $csumi (@files_csum_info_fields) {
1948 my ($fname, $module, $method, $archivefield) = @$csumi;
1949 next unless defined $changes->{$fname};
1951 # in archive, delete from .changes if it's there
1952 $changed{$file} = "removed" if
1953 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
1954 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
1955 # not in archive, but it's here in the .changes
1957 my $dsc_data = getfield $dsc, $fname;
1958 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
1960 $extra =~ s/ \d+ /$&$placementinfo /
1961 or die "$fname $extra >$dsc_data< ?"
1962 if $fname eq 'Files';
1963 $changes->{$fname} .= "\n". $extra;
1964 $changed{$file} = "added";
1969 foreach my $file (keys %changed) {
1971 "edited .changes for archive .orig contents: %s %s",
1972 $changed{$file}, $file;
1974 my $chtmp = "$changesfile.tmp";
1975 $changes->save($chtmp);
1977 rename $chtmp,$changesfile or die "$changesfile $!";
1979 progress "[new .changes left in $changesfile]";
1982 progress "$changesfile already has appropriate .orig(s) (if any)";
1986 sub make_commit ($) {
1988 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1991 sub make_commit_text ($) {
1994 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1996 print Dumper($text) if $debuglevel > 1;
1997 my $child = open2($out, $in, @cmd) or die $!;
2000 print $in $text or die $!;
2001 close $in or die $!;
2003 $h =~ m/^\w+$/ or die;
2005 printdebug "=> $h\n";
2008 waitpid $child, 0 == $child or die "$child $!";
2009 $? and failedcmd @cmd;
2013 sub clogp_authline ($) {
2015 my $author = getfield $clogp, 'Maintainer';
2016 if ($author =~ m/^[^"\@]+\,/) {
2017 # single entry Maintainer field with unquoted comma
2018 $author = ($& =~ y/,//rd).$'; # strip the comma
2020 # git wants a single author; any remaining commas in $author
2021 # are by now preceded by @ (or "). It seems safer to punt on
2022 # "..." for now rather than attempting to dequote or something.
2023 $author =~ s#,.*##ms unless $author =~ m/"/;
2024 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2025 my $authline = "$author $date";
2026 $authline =~ m/$git_authline_re/o or
2027 fail "unexpected commit author line format \`$authline'".
2028 " (was generated from changelog Maintainer field)";
2029 return ($1,$2,$3) if wantarray;
2033 sub vendor_patches_distro ($$) {
2034 my ($checkdistro, $what) = @_;
2035 return unless defined $checkdistro;
2037 my $series = "debian/patches/\L$checkdistro\E.series";
2038 printdebug "checking for vendor-specific $series ($what)\n";
2040 if (!open SERIES, "<", $series) {
2041 die "$series $!" unless $!==ENOENT;
2050 Unfortunately, this source package uses a feature of dpkg-source where
2051 the same source package unpacks to different source code on different
2052 distros. dgit cannot safely operate on such packages on affected
2053 distros, because the meaning of source packages is not stable.
2055 Please ask the distro/maintainer to remove the distro-specific series
2056 files and use a different technique (if necessary, uploading actually
2057 different packages, if different distros are supposed to have
2061 fail "Found active distro-specific series file for".
2062 " $checkdistro ($what): $series, cannot continue";
2064 die "$series $!" if SERIES->error;
2068 sub check_for_vendor_patches () {
2069 # This dpkg-source feature doesn't seem to be documented anywhere!
2070 # But it can be found in the changelog (reformatted):
2072 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2073 # Author: Raphael Hertzog <hertzog@debian.org>
2074 # Date: Sun Oct 3 09:36:48 2010 +0200
2076 # dpkg-source: correctly create .pc/.quilt_series with alternate
2079 # If you have debian/patches/ubuntu.series and you were
2080 # unpacking the source package on ubuntu, quilt was still
2081 # directed to debian/patches/series instead of
2082 # debian/patches/ubuntu.series.
2084 # debian/changelog | 3 +++
2085 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2086 # 2 files changed, 6 insertions(+), 1 deletion(-)
2089 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2090 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2091 "Dpkg::Vendor \`current vendor'");
2092 vendor_patches_distro(access_basedistro(),
2093 "(base) distro being accessed");
2094 vendor_patches_distro(access_nomdistro(),
2095 "(nominal) distro being accessed");
2098 sub generate_commits_from_dsc () {
2099 # See big comment in fetch_from_archive, below.
2100 # See also README.dsc-import.
2102 changedir $playground;
2104 my @dfi = dsc_files_info();
2105 foreach my $fi (@dfi) {
2106 my $f = $fi->{Filename};
2107 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2108 my $upper_f = "$maindir/../$f";
2110 printdebug "considering reusing $f: ";
2112 if (link_ltarget "$upper_f,fetch", $f) {
2113 printdebug "linked (using ...,fetch).\n";
2114 } elsif ((printdebug "($!) "),
2116 fail "accessing ../$f,fetch: $!";
2117 } elsif (link_ltarget $upper_f, $f) {
2118 printdebug "linked.\n";
2119 } elsif ((printdebug "($!) "),
2121 fail "accessing ../$f: $!";
2123 printdebug "absent.\n";
2127 complete_file_from_dsc('.', $fi, \$refetched)
2130 printdebug "considering saving $f: ";
2132 if (link $f, $upper_f) {
2133 printdebug "linked.\n";
2134 } elsif ((printdebug "($!) "),
2136 fail "saving ../$f: $!";
2137 } elsif (!$refetched) {
2138 printdebug "no need.\n";
2139 } elsif (link $f, "$upper_f,fetch") {
2140 printdebug "linked (using ...,fetch).\n";
2141 } elsif ((printdebug "($!) "),
2143 fail "saving ../$f,fetch: $!";
2145 printdebug "cannot.\n";
2149 # We unpack and record the orig tarballs first, so that we only
2150 # need disk space for one private copy of the unpacked source.
2151 # But we can't make them into commits until we have the metadata
2152 # from the debian/changelog, so we record the tree objects now and
2153 # make them into commits later.
2155 my $upstreamv = upstreamversion $dsc->{version};
2156 my $orig_f_base = srcfn $upstreamv, '';
2158 foreach my $fi (@dfi) {
2159 # We actually import, and record as a commit, every tarball
2160 # (unless there is only one file, in which case there seems
2163 my $f = $fi->{Filename};
2164 printdebug "import considering $f ";
2165 (printdebug "only one dfi\n"), next if @dfi == 1;
2166 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2167 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2171 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2173 printdebug "Y ", (join ' ', map { $_//"(none)" }
2174 $compr_ext, $orig_f_part
2177 my $input = new IO::File $f, '<' or die "$f $!";
2181 if (defined $compr_ext) {
2183 Dpkg::Compression::compression_guess_from_filename $f;
2184 fail "Dpkg::Compression cannot handle file $f in source package"
2185 if defined $compr_ext && !defined $cname;
2187 new Dpkg::Compression::Process compression => $cname;
2188 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2189 my $compr_fh = new IO::Handle;
2190 my $compr_pid = open $compr_fh, "-|" // die $!;
2192 open STDIN, "<&", $input or die $!;
2194 die "dgit (child): exec $compr_cmd[0]: $!\n";
2199 rmtree "_unpack-tar";
2200 mkdir "_unpack-tar" or die $!;
2201 my @tarcmd = qw(tar -x -f -
2202 --no-same-owner --no-same-permissions
2203 --no-acls --no-xattrs --no-selinux);
2204 my $tar_pid = fork // die $!;
2206 chdir "_unpack-tar" or die $!;
2207 open STDIN, "<&", $input or die $!;
2209 die "dgit (child): exec $tarcmd[0]: $!";
2211 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2212 !$? or failedcmd @tarcmd;
2215 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2217 # finally, we have the results in "tarball", but maybe
2218 # with the wrong permissions
2220 runcmd qw(chmod -R +rwX _unpack-tar);
2221 changedir "_unpack-tar";
2222 remove_stray_gits($f);
2223 mktree_in_ud_here();
2225 my ($tree) = git_add_write_tree();
2226 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2227 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2229 printdebug "one subtree $1\n";
2231 printdebug "multiple subtrees\n";
2234 rmtree "_unpack-tar";
2236 my $ent = [ $f, $tree ];
2238 Orig => !!$orig_f_part,
2239 Sort => (!$orig_f_part ? 2 :
2240 $orig_f_part =~ m/-/g ? 1 :
2248 # put any without "_" first (spec is not clear whether files
2249 # are always in the usual order). Tarballs without "_" are
2250 # the main orig or the debian tarball.
2251 $a->{Sort} <=> $b->{Sort} or
2255 my $any_orig = grep { $_->{Orig} } @tartrees;
2257 my $dscfn = "$package.dsc";
2259 my $treeimporthow = 'package';
2261 open D, ">", $dscfn or die "$dscfn: $!";
2262 print D $dscdata or die "$dscfn: $!";
2263 close D or die "$dscfn: $!";
2264 my @cmd = qw(dpkg-source);
2265 push @cmd, '--no-check' if $dsc_checked;
2266 if (madformat $dsc->{format}) {
2267 push @cmd, '--skip-patches';
2268 $treeimporthow = 'unpatched';
2270 push @cmd, qw(-x --), $dscfn;
2273 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2274 if (madformat $dsc->{format}) {
2275 check_for_vendor_patches();
2279 if (madformat $dsc->{format}) {
2280 my @pcmd = qw(dpkg-source --before-build .);
2281 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2283 $dappliedtree = git_add_write_tree();
2286 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2290 printdebug "import clog search...\n";
2291 parsechangelog_loop \@clogcmd, "package changelog", sub {
2292 my ($thisstanza, $desc) = @_;
2293 no warnings qw(exiting);
2295 $clogp //= $thisstanza;
2297 printdebug "import clog $thisstanza->{version} $desc...\n";
2299 last if !$any_orig; # we don't need $r1clogp
2301 # We look for the first (most recent) changelog entry whose
2302 # version number is lower than the upstream version of this
2303 # package. Then the last (least recent) previous changelog
2304 # entry is treated as the one which introduced this upstream
2305 # version and used for the synthetic commits for the upstream
2308 # One might think that a more sophisticated algorithm would be
2309 # necessary. But: we do not want to scan the whole changelog
2310 # file. Stopping when we see an earlier version, which
2311 # necessarily then is an earlier upstream version, is the only
2312 # realistic way to do that. Then, either the earliest
2313 # changelog entry we have seen so far is indeed the earliest
2314 # upload of this upstream version; or there are only changelog
2315 # entries relating to later upstream versions (which is not
2316 # possible unless the changelog and .dsc disagree about the
2317 # version). Then it remains to choose between the physically
2318 # last entry in the file, and the one with the lowest version
2319 # number. If these are not the same, we guess that the
2320 # versions were created in a non-monotonic order rather than
2321 # that the changelog entries have been misordered.
2323 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2325 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2326 $r1clogp = $thisstanza;
2328 printdebug "import clog $r1clogp->{version} becomes r1\n";
2331 $clogp or fail "package changelog has no entries!";
2333 my $authline = clogp_authline $clogp;
2334 my $changes = getfield $clogp, 'Changes';
2335 $changes =~ s/^\n//; # Changes: \n
2336 my $cversion = getfield $clogp, 'Version';
2339 $r1clogp //= $clogp; # maybe there's only one entry;
2340 my $r1authline = clogp_authline $r1clogp;
2341 # Strictly, r1authline might now be wrong if it's going to be
2342 # unused because !$any_orig. Whatever.
2344 printdebug "import tartrees authline $authline\n";
2345 printdebug "import tartrees r1authline $r1authline\n";
2347 foreach my $tt (@tartrees) {
2348 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2350 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2353 committer $r1authline
2357 [dgit import orig $tt->{F}]
2365 [dgit import tarball $package $cversion $tt->{F}]
2370 printdebug "import main commit\n";
2372 open C, ">../commit.tmp" or die $!;
2373 print C <<END or die $!;
2376 print C <<END or die $! foreach @tartrees;
2379 print C <<END or die $!;
2385 [dgit import $treeimporthow $package $cversion]
2389 my $rawimport_hash = make_commit qw(../commit.tmp);
2391 if (madformat $dsc->{format}) {
2392 printdebug "import apply patches...\n";
2394 # regularise the state of the working tree so that
2395 # the checkout of $rawimport_hash works nicely.
2396 my $dappliedcommit = make_commit_text(<<END);
2403 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2405 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2407 # We need the answers to be reproducible
2408 my @authline = clogp_authline($clogp);
2409 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2410 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2411 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2412 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2413 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2414 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2416 my $path = $ENV{PATH} or die;
2418 # we use ../../gbp-pq-output, which (given that we are in
2419 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2422 foreach my $use_absurd (qw(0 1)) {
2423 runcmd @git, qw(checkout -q unpa);
2424 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2425 local $ENV{PATH} = $path;
2428 progress "warning: $@";
2429 $path = "$absurdity:$path";
2430 progress "$us: trying slow absurd-git-apply...";
2431 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2436 die "forbid absurd git-apply\n" if $use_absurd
2437 && forceing [qw(import-gitapply-no-absurd)];
2438 die "only absurd git-apply!\n" if !$use_absurd
2439 && forceing [qw(import-gitapply-absurd)];
2441 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2442 local $ENV{PATH} = $path if $use_absurd;
2444 my @showcmd = (gbp_pq, qw(import));
2445 my @realcmd = shell_cmd
2446 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2447 debugcmd "+",@realcmd;
2448 if (system @realcmd) {
2449 die +(shellquote @showcmd).
2451 failedcmd_waitstatus()."\n";
2454 my $gapplied = git_rev_parse('HEAD');
2455 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2456 $gappliedtree eq $dappliedtree or
2458 gbp-pq import and dpkg-source disagree!
2459 gbp-pq import gave commit $gapplied
2460 gbp-pq import gave tree $gappliedtree
2461 dpkg-source --before-build gave tree $dappliedtree
2463 $rawimport_hash = $gapplied;
2468 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2473 progress "synthesised git commit from .dsc $cversion";
2475 my $rawimport_mergeinput = {
2476 Commit => $rawimport_hash,
2477 Info => "Import of source package",
2479 my @output = ($rawimport_mergeinput);
2481 if ($lastpush_mergeinput) {
2482 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2483 my $oversion = getfield $oldclogp, 'Version';
2485 version_compare($oversion, $cversion);
2487 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2488 { Message => <<END, ReverseParents => 1 });
2489 Record $package ($cversion) in archive suite $csuite
2491 } elsif ($vcmp > 0) {
2492 print STDERR <<END or die $!;
2494 Version actually in archive: $cversion (older)
2495 Last version pushed with dgit: $oversion (newer or same)
2498 @output = $lastpush_mergeinput;
2500 # Same version. Use what's in the server git branch,
2501 # discarding our own import. (This could happen if the
2502 # server automatically imports all packages into git.)
2503 @output = $lastpush_mergeinput;
2511 sub complete_file_from_dsc ($$;$) {
2512 our ($dstdir, $fi, $refetched) = @_;
2513 # Ensures that we have, in $dstdir, the file $fi, with the correct
2514 # contents. (Downloading it from alongside $dscurl if necessary.)
2515 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2516 # and will set $$refetched=1 if it did so (or tried to).
2518 my $f = $fi->{Filename};
2519 my $tf = "$dstdir/$f";
2523 my $checkhash = sub {
2524 open F, "<", "$tf" or die "$tf: $!";
2525 $fi->{Digester}->reset();
2526 $fi->{Digester}->addfile(*F);
2527 F->error and die $!;
2528 $got = $fi->{Digester}->hexdigest();
2529 return $got eq $fi->{Hash};
2532 if (stat_exists $tf) {
2533 if ($checkhash->()) {
2534 progress "using existing $f";
2538 fail "file $f has hash $got but .dsc".
2539 " demands hash $fi->{Hash} ".
2540 "(perhaps you should delete this file?)";
2542 progress "need to fetch correct version of $f";
2543 unlink $tf or die "$tf $!";
2546 printdebug "$tf does not exist, need to fetch\n";
2550 $furl =~ s{/[^/]+$}{};
2552 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2553 die "$f ?" if $f =~ m#/#;
2554 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2555 return 0 if !act_local();
2558 fail "file $f has hash $got but .dsc".
2559 " demands hash $fi->{Hash} ".
2560 "(got wrong file from archive!)";
2565 sub ensure_we_have_orig () {
2566 my @dfi = dsc_files_info();
2567 foreach my $fi (@dfi) {
2568 my $f = $fi->{Filename};
2569 next unless is_orig_file_in_dsc($f, \@dfi);
2570 complete_file_from_dsc('..', $fi)
2575 #---------- git fetch ----------
2577 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2578 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2580 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2581 # locally fetched refs because they have unhelpful names and clutter
2582 # up gitk etc. So we track whether we have "used up" head ref (ie,
2583 # whether we have made another local ref which refers to this object).
2585 # (If we deleted them unconditionally, then we might end up
2586 # re-fetching the same git objects each time dgit fetch was run.)
2588 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2589 # in git_fetch_us to fetch the refs in question, and possibly a call
2590 # to lrfetchref_used.
2592 our (%lrfetchrefs_f, %lrfetchrefs_d);
2593 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2595 sub lrfetchref_used ($) {
2596 my ($fullrefname) = @_;
2597 my $objid = $lrfetchrefs_f{$fullrefname};
2598 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2601 sub git_lrfetch_sane {
2602 my ($url, $supplementary, @specs) = @_;
2603 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2604 # at least as regards @specs. Also leave the results in
2605 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2606 # able to clean these up.
2608 # With $supplementary==1, @specs must not contain wildcards
2609 # and we add to our previous fetches (non-atomically).
2611 # This is rather miserable:
2612 # When git fetch --prune is passed a fetchspec ending with a *,
2613 # it does a plausible thing. If there is no * then:
2614 # - it matches subpaths too, even if the supplied refspec
2615 # starts refs, and behaves completely madly if the source
2616 # has refs/refs/something. (See, for example, Debian #NNNN.)
2617 # - if there is no matching remote ref, it bombs out the whole
2619 # We want to fetch a fixed ref, and we don't know in advance
2620 # if it exists, so this is not suitable.
2622 # Our workaround is to use git ls-remote. git ls-remote has its
2623 # own qairks. Notably, it has the absurd multi-tail-matching
2624 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2625 # refs/refs/foo etc.
2627 # Also, we want an idempotent snapshot, but we have to make two
2628 # calls to the remote: one to git ls-remote and to git fetch. The
2629 # solution is use git ls-remote to obtain a target state, and
2630 # git fetch to try to generate it. If we don't manage to generate
2631 # the target state, we try again.
2633 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2635 my $specre = join '|', map {
2638 my $wildcard = $x =~ s/\\\*$/.*/;
2639 die if $wildcard && $supplementary;
2642 printdebug "git_lrfetch_sane specre=$specre\n";
2643 my $wanted_rref = sub {
2645 return m/^(?:$specre)$/;
2648 my $fetch_iteration = 0;
2651 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2652 if (++$fetch_iteration > 10) {
2653 fail "too many iterations trying to get sane fetch!";
2656 my @look = map { "refs/$_" } @specs;
2657 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2661 open GITLS, "-|", @lcmd or die $!;
2663 printdebug "=> ", $_;
2664 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2665 my ($objid,$rrefname) = ($1,$2);
2666 if (!$wanted_rref->($rrefname)) {
2668 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2672 $wantr{$rrefname} = $objid;
2675 close GITLS or failedcmd @lcmd;
2677 # OK, now %want is exactly what we want for refs in @specs
2679 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2680 "+refs/$_:".lrfetchrefs."/$_";
2683 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2685 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2686 runcmd_ordryrun_local @fcmd if @fspecs;
2688 if (!$supplementary) {
2689 %lrfetchrefs_f = ();
2693 git_for_each_ref(lrfetchrefs, sub {
2694 my ($objid,$objtype,$lrefname,$reftail) = @_;
2695 $lrfetchrefs_f{$lrefname} = $objid;
2696 $objgot{$objid} = 1;
2699 if ($supplementary) {
2703 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2704 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2705 if (!exists $wantr{$rrefname}) {
2706 if ($wanted_rref->($rrefname)) {
2708 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2712 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2715 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2716 delete $lrfetchrefs_f{$lrefname};
2720 foreach my $rrefname (sort keys %wantr) {
2721 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2722 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2723 my $want = $wantr{$rrefname};
2724 next if $got eq $want;
2725 if (!defined $objgot{$want}) {
2726 fail <<END unless act_local();
2727 --dry-run specified but we actually wanted the results of git fetch,
2728 so this is not going to work. Try running dgit fetch first,
2729 or using --damp-run instead of --dry-run.
2732 warning: git ls-remote suggests we want $lrefname
2733 warning: and it should refer to $want
2734 warning: but git fetch didn't fetch that object to any relevant ref.
2735 warning: This may be due to a race with someone updating the server.
2736 warning: Will try again...
2738 next FETCH_ITERATION;
2741 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2743 runcmd_ordryrun_local @git, qw(update-ref -m),
2744 "dgit fetch git fetch fixup", $lrefname, $want;
2745 $lrfetchrefs_f{$lrefname} = $want;
2750 if (defined $csuite) {
2751 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2752 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2753 my ($objid,$objtype,$lrefname,$reftail) = @_;
2754 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2755 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2759 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2760 Dumper(\%lrfetchrefs_f);
2763 sub git_fetch_us () {
2764 # Want to fetch only what we are going to use, unless
2765 # deliberately-not-ff, in which case we must fetch everything.
2767 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2769 (quiltmode_splitbrain
2770 ? (map { $_->('*',access_nomdistro) }
2771 \&debiantag_new, \&debiantag_maintview)
2772 : debiantags('*',access_nomdistro));
2773 push @specs, server_branch($csuite);
2774 push @specs, $rewritemap;
2775 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2777 my $url = access_giturl();
2778 git_lrfetch_sane $url, 0, @specs;
2781 my @tagpats = debiantags('*',access_nomdistro);
2783 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2784 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2785 printdebug "currently $fullrefname=$objid\n";
2786 $here{$fullrefname} = $objid;
2788 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2789 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2790 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2791 printdebug "offered $lref=$objid\n";
2792 if (!defined $here{$lref}) {
2793 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2794 runcmd_ordryrun_local @upd;
2795 lrfetchref_used $fullrefname;
2796 } elsif ($here{$lref} eq $objid) {
2797 lrfetchref_used $fullrefname;
2800 "Not updating $lref from $here{$lref} to $objid.\n";
2805 #---------- dsc and archive handling ----------
2807 sub mergeinfo_getclogp ($) {
2808 # Ensures thit $mi->{Clogp} exists and returns it
2810 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2813 sub mergeinfo_version ($) {
2814 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2817 sub fetch_from_archive_record_1 ($) {
2819 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2820 cmdoutput @git, qw(log -n2), $hash;
2821 # ... gives git a chance to complain if our commit is malformed
2824 sub fetch_from_archive_record_2 ($) {
2826 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2830 dryrun_report @upd_cmd;
2834 sub parse_dsc_field_def_dsc_distro () {
2835 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2836 dgit.default.distro);
2839 sub parse_dsc_field ($$) {
2840 my ($dsc, $what) = @_;
2842 foreach my $field (@ourdscfield) {
2843 $f = $dsc->{$field};
2848 progress "$what: NO git hash";
2849 parse_dsc_field_def_dsc_distro();
2850 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2851 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2852 progress "$what: specified git info ($dsc_distro)";
2853 $dsc_hint_tag = [ $dsc_hint_tag ];
2854 } elsif ($f =~ m/^\w+\s*$/) {
2856 parse_dsc_field_def_dsc_distro();
2857 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2859 progress "$what: specified git hash";
2861 fail "$what: invalid Dgit info";
2865 sub resolve_dsc_field_commit ($$) {
2866 my ($already_distro, $already_mapref) = @_;
2868 return unless defined $dsc_hash;
2871 defined $already_mapref &&
2872 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2873 ? $already_mapref : undef;
2877 my ($what, @fetch) = @_;
2879 local $idistro = $dsc_distro;
2880 my $lrf = lrfetchrefs;
2882 if (!$chase_dsc_distro) {
2884 "not chasing .dsc distro $dsc_distro: not fetching $what";
2889 ".dsc names distro $dsc_distro: fetching $what";
2891 my $url = access_giturl();
2892 if (!defined $url) {
2893 defined $dsc_hint_url or fail <<END;
2894 .dsc Dgit metadata is in context of distro $dsc_distro
2895 for which we have no configured url and .dsc provides no hint
2898 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2899 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2900 parse_cfg_bool "dsc-url-proto-ok", 'false',
2901 cfg("dgit.dsc-url-proto-ok.$proto",
2902 "dgit.default.dsc-url-proto-ok")
2904 .dsc Dgit metadata is in context of distro $dsc_distro
2905 for which we have no configured url;
2906 .dsc provides hinted url with protocol $proto which is unsafe.
2907 (can be overridden by config - consult documentation)
2909 $url = $dsc_hint_url;
2912 git_lrfetch_sane $url, 1, @fetch;
2917 my $rewrite_enable = do {
2918 local $idistro = $dsc_distro;
2919 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2922 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2923 if (!defined $mapref) {
2924 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2925 $mapref = $lrf.'/'.$rewritemap;
2927 my $rewritemapdata = git_cat_file $mapref.':map';
2928 if (defined $rewritemapdata
2929 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2931 "server's git history rewrite map contains a relevant entry!";
2934 if (defined $dsc_hash) {
2935 progress "using rewritten git hash in place of .dsc value";
2937 progress "server data says .dsc hash is to be disregarded";
2942 if (!defined git_cat_file $dsc_hash) {
2943 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2944 my $lrf = $do_fetch->("additional commits", @tags) &&
2945 defined git_cat_file $dsc_hash
2947 .dsc Dgit metadata requires commit $dsc_hash
2948 but we could not obtain that object anywhere.
2950 foreach my $t (@tags) {
2951 my $fullrefname = $lrf.'/'.$t;
2952 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2953 next unless $lrfetchrefs_f{$fullrefname};
2954 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2955 lrfetchref_used $fullrefname;
2960 sub fetch_from_archive () {
2961 ensure_setup_existing_tree();
2963 # Ensures that lrref() is what is actually in the archive, one way
2964 # or another, according to us - ie this client's
2965 # appropritaely-updated archive view. Also returns the commit id.
2966 # If there is nothing in the archive, leaves lrref alone and
2967 # returns undef. git_fetch_us must have already been called.
2971 parse_dsc_field($dsc, 'last upload to archive');
2972 resolve_dsc_field_commit access_basedistro,
2973 lrfetchrefs."/".$rewritemap
2975 progress "no version available from the archive";
2978 # If the archive's .dsc has a Dgit field, there are three
2979 # relevant git commitids we need to choose between and/or merge
2981 # 1. $dsc_hash: the Dgit field from the archive
2982 # 2. $lastpush_hash: the suite branch on the dgit git server
2983 # 3. $lastfetch_hash: our local tracking brach for the suite
2985 # These may all be distinct and need not be in any fast forward
2988 # If the dsc was pushed to this suite, then the server suite
2989 # branch will have been updated; but it might have been pushed to
2990 # a different suite and copied by the archive. Conversely a more
2991 # recent version may have been pushed with dgit but not appeared
2992 # in the archive (yet).
2994 # $lastfetch_hash may be awkward because archive imports
2995 # (particularly, imports of Dgit-less .dscs) are performed only as
2996 # needed on individual clients, so different clients may perform a
2997 # different subset of them - and these imports are only made
2998 # public during push. So $lastfetch_hash may represent a set of
2999 # imports different to a subsequent upload by a different dgit
3002 # Our approach is as follows:
3004 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3005 # descendant of $dsc_hash, then it was pushed by a dgit user who
3006 # had based their work on $dsc_hash, so we should prefer it.
3007 # Otherwise, $dsc_hash was installed into this suite in the
3008 # archive other than by a dgit push, and (necessarily) after the
3009 # last dgit push into that suite (since a dgit push would have
3010 # been descended from the dgit server git branch); thus, in that
3011 # case, we prefer the archive's version (and produce a
3012 # pseudo-merge to overwrite the dgit server git branch).
3014 # (If there is no Dgit field in the archive's .dsc then
3015 # generate_commit_from_dsc uses the version numbers to decide
3016 # whether the suite branch or the archive is newer. If the suite
3017 # branch is newer it ignores the archive's .dsc; otherwise it
3018 # generates an import of the .dsc, and produces a pseudo-merge to
3019 # overwrite the suite branch with the archive contents.)
3021 # The outcome of that part of the algorithm is the `public view',
3022 # and is same for all dgit clients: it does not depend on any
3023 # unpublished history in the local tracking branch.
3025 # As between the public view and the local tracking branch: The
3026 # local tracking branch is only updated by dgit fetch, and
3027 # whenever dgit fetch runs it includes the public view in the
3028 # local tracking branch. Therefore if the public view is not
3029 # descended from the local tracking branch, the local tracking
3030 # branch must contain history which was imported from the archive
3031 # but never pushed; and, its tip is now out of date. So, we make
3032 # a pseudo-merge to overwrite the old imports and stitch the old
3035 # Finally: we do not necessarily reify the public view (as
3036 # described above). This is so that we do not end up stacking two
3037 # pseudo-merges. So what we actually do is figure out the inputs
3038 # to any public view pseudo-merge and put them in @mergeinputs.
3041 # $mergeinputs[]{Commit}
3042 # $mergeinputs[]{Info}
3043 # $mergeinputs[0] is the one whose tree we use
3044 # @mergeinputs is in the order we use in the actual commit)
3047 # $mergeinputs[]{Message} is a commit message to use
3048 # $mergeinputs[]{ReverseParents} if def specifies that parent
3049 # list should be in opposite order
3050 # Such an entry has no Commit or Info. It applies only when found
3051 # in the last entry. (This ugliness is to support making
3052 # identical imports to previous dgit versions.)
3054 my $lastpush_hash = git_get_ref(lrfetchref());
3055 printdebug "previous reference hash=$lastpush_hash\n";
3056 $lastpush_mergeinput = $lastpush_hash && {
3057 Commit => $lastpush_hash,
3058 Info => "dgit suite branch on dgit git server",
3061 my $lastfetch_hash = git_get_ref(lrref());
3062 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3063 my $lastfetch_mergeinput = $lastfetch_hash && {
3064 Commit => $lastfetch_hash,
3065 Info => "dgit client's archive history view",
3068 my $dsc_mergeinput = $dsc_hash && {
3069 Commit => $dsc_hash,
3070 Info => "Dgit field in .dsc from archive",
3074 my $del_lrfetchrefs = sub {
3077 printdebug "del_lrfetchrefs...\n";
3078 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3079 my $objid = $lrfetchrefs_d{$fullrefname};
3080 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3082 $gur ||= new IO::Handle;
3083 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3085 printf $gur "delete %s %s\n", $fullrefname, $objid;
3088 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3092 if (defined $dsc_hash) {
3093 ensure_we_have_orig();
3094 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3095 @mergeinputs = $dsc_mergeinput
3096 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3097 print STDERR <<END or die $!;
3099 Git commit in archive is behind the last version allegedly pushed/uploaded.
3100 Commit referred to by archive: $dsc_hash
3101 Last version pushed with dgit: $lastpush_hash
3104 @mergeinputs = ($lastpush_mergeinput);
3106 # Archive has .dsc which is not a descendant of the last dgit
3107 # push. This can happen if the archive moves .dscs about.
3108 # Just follow its lead.
3109 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3110 progress "archive .dsc names newer git commit";
3111 @mergeinputs = ($dsc_mergeinput);
3113 progress "archive .dsc names other git commit, fixing up";
3114 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3118 @mergeinputs = generate_commits_from_dsc();
3119 # We have just done an import. Now, our import algorithm might
3120 # have been improved. But even so we do not want to generate
3121 # a new different import of the same package. So if the
3122 # version numbers are the same, just use our existing version.
3123 # If the version numbers are different, the archive has changed
3124 # (perhaps, rewound).
3125 if ($lastfetch_mergeinput &&
3126 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3127 (mergeinfo_version $mergeinputs[0]) )) {
3128 @mergeinputs = ($lastfetch_mergeinput);
3130 } elsif ($lastpush_hash) {
3131 # only in git, not in the archive yet
3132 @mergeinputs = ($lastpush_mergeinput);
3133 print STDERR <<END or die $!;
3135 Package not found in the archive, but has allegedly been pushed using dgit.
3139 printdebug "nothing found!\n";
3140 if (defined $skew_warning_vsn) {
3141 print STDERR <<END or die $!;
3143 Warning: relevant archive skew detected.
3144 Archive allegedly contains $skew_warning_vsn
3145 But we were not able to obtain any version from the archive or git.
3149 unshift @end, $del_lrfetchrefs;
3153 if ($lastfetch_hash &&
3155 my $h = $_->{Commit};
3156 $h and is_fast_fwd($lastfetch_hash, $h);
3157 # If true, one of the existing parents of this commit
3158 # is a descendant of the $lastfetch_hash, so we'll
3159 # be ff from that automatically.
3163 push @mergeinputs, $lastfetch_mergeinput;
3166 printdebug "fetch mergeinfos:\n";
3167 foreach my $mi (@mergeinputs) {
3169 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3171 printdebug sprintf " ReverseParents=%d Message=%s",
3172 $mi->{ReverseParents}, $mi->{Message};
3176 my $compat_info= pop @mergeinputs
3177 if $mergeinputs[$#mergeinputs]{Message};
3179 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3182 if (@mergeinputs > 1) {
3184 my $tree_commit = $mergeinputs[0]{Commit};
3186 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3187 $tree =~ m/\n\n/; $tree = $`;
3188 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3191 # We use the changelog author of the package in question the
3192 # author of this pseudo-merge. This is (roughly) correct if
3193 # this commit is simply representing aa non-dgit upload.
3194 # (Roughly because it does not record sponsorship - but we
3195 # don't have sponsorship info because that's in the .changes,
3196 # which isn't in the archivw.)
3198 # But, it might be that we are representing archive history
3199 # updates (including in-archive copies). These are not really
3200 # the responsibility of the person who created the .dsc, but
3201 # there is no-one whose name we should better use. (The
3202 # author of the .dsc-named commit is clearly worse.)
3204 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3205 my $author = clogp_authline $useclogp;
3206 my $cversion = getfield $useclogp, 'Version';
3208 my $mcf = dgit_privdir()."/mergecommit";
3209 open MC, ">", $mcf or die "$mcf $!";
3210 print MC <<END or die $!;
3214 my @parents = grep { $_->{Commit} } @mergeinputs;
3215 @parents = reverse @parents if $compat_info->{ReverseParents};
3216 print MC <<END or die $! foreach @parents;
3220 print MC <<END or die $!;
3226 if (defined $compat_info->{Message}) {
3227 print MC $compat_info->{Message} or die $!;
3229 print MC <<END or die $!;
3230 Record $package ($cversion) in archive suite $csuite
3234 my $message_add_info = sub {
3236 my $mversion = mergeinfo_version $mi;
3237 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3241 $message_add_info->($mergeinputs[0]);
3242 print MC <<END or die $!;
3243 should be treated as descended from
3245 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3249 $hash = make_commit $mcf;
3251 $hash = $mergeinputs[0]{Commit};
3253 printdebug "fetch hash=$hash\n";
3256 my ($lasth, $what) = @_;
3257 return unless $lasth;
3258 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3261 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3263 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3265 fetch_from_archive_record_1($hash);
3267 if (defined $skew_warning_vsn) {
3268 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3269 my $gotclogp = commit_getclogp($hash);
3270 my $got_vsn = getfield $gotclogp, 'Version';
3271 printdebug "SKEW CHECK GOT $got_vsn\n";
3272 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3273 print STDERR <<END or die $!;
3275 Warning: archive skew detected. Using the available version:
3276 Archive allegedly contains $skew_warning_vsn
3277 We were able to obtain only $got_vsn
3283 if ($lastfetch_hash ne $hash) {
3284 fetch_from_archive_record_2($hash);
3287 lrfetchref_used lrfetchref();
3289 check_gitattrs($hash, "fetched source tree");
3291 unshift @end, $del_lrfetchrefs;
3295 sub set_local_git_config ($$) {
3297 runcmd @git, qw(config), $k, $v;
3300 sub setup_mergechangelogs (;$) {
3302 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3304 my $driver = 'dpkg-mergechangelogs';
3305 my $cb = "merge.$driver";
3306 confess unless defined $maindir;
3307 my $attrs = "$maindir_gitcommon/info/attributes";
3308 ensuredir "$maindir_gitcommon/info";
3310 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3311 if (!open ATTRS, "<", $attrs) {
3312 $!==ENOENT or die "$attrs: $!";
3316 next if m{^debian/changelog\s};
3317 print NATTRS $_, "\n" or die $!;
3319 ATTRS->error and die $!;
3322 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3325 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3326 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3328 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3331 sub setup_useremail (;$) {
3333 return unless $always || access_cfg_bool(1, 'setup-useremail');
3336 my ($k, $envvar) = @_;
3337 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3338 return unless defined $v;
3339 set_local_git_config "user.$k", $v;
3342 $setup->('email', 'DEBEMAIL');
3343 $setup->('name', 'DEBFULLNAME');
3346 sub ensure_setup_existing_tree () {
3347 my $k = "remote.$remotename.skipdefaultupdate";
3348 my $c = git_get_config $k;
3349 return if defined $c;
3350 set_local_git_config $k, 'true';
3353 sub open_main_gitattrs () {
3354 confess 'internal error no maindir' unless defined $maindir;
3355 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3357 or die "open $maindir_gitcommon/info/attributes: $!";
3361 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3363 sub is_gitattrs_setup () {
3366 # 1: gitattributes set up and should be left alone
3368 # 0: there is a dgit-defuse-attrs but it needs fixing
3369 # undef: there is none
3370 my $gai = open_main_gitattrs();
3371 return 0 unless $gai;
3373 next unless m{$gitattrs_ourmacro_re};
3374 return 1 if m{\s-working-tree-encoding\s};
3375 printdebug "is_gitattrs_setup: found old macro\n";
3378 $gai->error and die $!;
3379 printdebug "is_gitattrs_setup: found nothing\n";
3383 sub setup_gitattrs (;$) {
3385 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3387 my $already = is_gitattrs_setup();
3390 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3391 not doing further gitattributes setup
3395 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3396 my $af = "$maindir_gitcommon/info/attributes";
3397 ensuredir "$maindir_gitcommon/info";
3399 open GAO, "> $af.new" or die $!;
3400 print GAO <<END or die $! unless defined $already;
3403 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3405 my $gai = open_main_gitattrs();
3408 if (m{$gitattrs_ourmacro_re}) {
3409 die unless defined $already;
3413 print GAO $_, "\n" or die $!;
3415 $gai->error and die $!;
3417 close GAO or die $!;
3418 rename "$af.new", "$af" or die "install $af: $!";
3421 sub setup_new_tree () {
3422 setup_mergechangelogs();
3427 sub check_gitattrs ($$) {
3428 my ($treeish, $what) = @_;
3430 return if is_gitattrs_setup;
3433 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3435 my $gafl = new IO::File;
3436 open $gafl, "-|", @cmd or die $!;
3439 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3441 next unless m{(?:^|/)\.gitattributes$};
3443 # oh dear, found one
3445 dgit: warning: $what contains .gitattributes
3446 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3451 # tree contains no .gitattributes files
3452 $?=0; $!=0; close $gafl or failedcmd @cmd;
3456 sub multisuite_suite_child ($$$) {
3457 my ($tsuite, $merginputs, $fn) = @_;
3458 # in child, sets things up, calls $fn->(), and returns undef
3459 # in parent, returns canonical suite name for $tsuite
3460 my $canonsuitefh = IO::File::new_tmpfile;
3461 my $pid = fork // die $!;
3465 $us .= " [$isuite]";
3466 $debugprefix .= " ";
3467 progress "fetching $tsuite...";
3468 canonicalise_suite();
3469 print $canonsuitefh $csuite, "\n" or die $!;
3470 close $canonsuitefh or die $!;
3474 waitpid $pid,0 == $pid or die $!;
3475 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3476 seek $canonsuitefh,0,0 or die $!;
3477 local $csuite = <$canonsuitefh>;
3478 die $! unless defined $csuite && chomp $csuite;
3480 printdebug "multisuite $tsuite missing\n";
3483 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3484 push @$merginputs, {
3491 sub fork_for_multisuite ($) {
3492 my ($before_fetch_merge) = @_;
3493 # if nothing unusual, just returns ''
3496 # returns 0 to caller in child, to do first of the specified suites
3497 # in child, $csuite is not yet set
3499 # returns 1 to caller in parent, to finish up anything needed after
3500 # in parent, $csuite is set to canonicalised portmanteau
3502 my $org_isuite = $isuite;
3503 my @suites = split /\,/, $isuite;
3504 return '' unless @suites > 1;
3505 printdebug "fork_for_multisuite: @suites\n";
3509 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3511 return 0 unless defined $cbasesuite;
3513 fail "package $package missing in (base suite) $cbasesuite"
3514 unless @mergeinputs;
3516 my @csuites = ($cbasesuite);
3518 $before_fetch_merge->();
3520 foreach my $tsuite (@suites[1..$#suites]) {
3521 $tsuite =~ s/^-/$cbasesuite-/;
3522 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3528 # xxx collecte the ref here
3530 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3531 push @csuites, $csubsuite;
3534 foreach my $mi (@mergeinputs) {
3535 my $ref = git_get_ref $mi->{Ref};
3536 die "$mi->{Ref} ?" unless length $ref;
3537 $mi->{Commit} = $ref;
3540 $csuite = join ",", @csuites;
3542 my $previous = git_get_ref lrref;
3544 unshift @mergeinputs, {
3545 Commit => $previous,
3546 Info => "local combined tracking branch",
3548 "archive seems to have rewound: local tracking branch is ahead!",
3552 foreach my $ix (0..$#mergeinputs) {
3553 $mergeinputs[$ix]{Index} = $ix;
3556 @mergeinputs = sort {
3557 -version_compare(mergeinfo_version $a,
3558 mergeinfo_version $b) # highest version first
3560 $a->{Index} <=> $b->{Index}; # earliest in spec first
3566 foreach my $mi (@mergeinputs) {
3567 printdebug "multisuite merge check $mi->{Info}\n";
3568 foreach my $previous (@needed) {
3569 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3570 printdebug "multisuite merge un-needed $previous->{Info}\n";
3574 printdebug "multisuite merge this-needed\n";
3575 $mi->{Character} = '+';
3578 $needed[0]{Character} = '*';
3580 my $output = $needed[0]{Commit};
3583 printdebug "multisuite merge nontrivial\n";
3584 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3586 my $commit = "tree $tree\n";
3587 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3588 "Input branches:\n";
3590 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3591 printdebug "multisuite merge include $mi->{Info}\n";
3592 $mi->{Character} //= ' ';
3593 $commit .= "parent $mi->{Commit}\n";
3594 $msg .= sprintf " %s %-25s %s\n",
3596 (mergeinfo_version $mi),
3599 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3601 " * marks the highest version branch, which choose to use\n".
3602 " + marks each branch which was not already an ancestor\n\n".
3603 "[dgit multi-suite $csuite]\n";
3605 "author $authline\n".
3606 "committer $authline\n\n";
3607 $output = make_commit_text $commit.$msg;
3608 printdebug "multisuite merge generated $output\n";
3611 fetch_from_archive_record_1($output);
3612 fetch_from_archive_record_2($output);
3614 progress "calculated combined tracking suite $csuite";
3619 sub clone_set_head () {
3620 open H, "> .git/HEAD" or die $!;
3621 print H "ref: ".lref()."\n" or die $!;
3624 sub clone_finish ($) {
3626 runcmd @git, qw(reset --hard), lrref();
3627 runcmd qw(bash -ec), <<'END';
3629 git ls-tree -r --name-only -z HEAD | \
3630 xargs -0r touch -h -r . --
3632 printdone "ready for work in $dstdir";
3636 # in multisuite, returns twice!
3637 # once in parent after first suite fetched,
3638 # and then again in child after everything is finished
3640 badusage "dry run makes no sense with clone" unless act_local();
3642 my $multi_fetched = fork_for_multisuite(sub {
3643 printdebug "multi clone before fetch merge\n";
3647 if ($multi_fetched) {
3648 printdebug "multi clone after fetch merge\n";
3650 clone_finish($dstdir);
3653 printdebug "clone main body\n";
3655 canonicalise_suite();
3656 my $hasgit = check_for_git();
3657 mkdir $dstdir or fail "create \`$dstdir': $!";
3659 runcmd @git, qw(init -q);
3663 my $giturl = access_giturl(1);
3664 if (defined $giturl) {
3665 runcmd @git, qw(remote add), 'origin', $giturl;
3668 progress "fetching existing git history";
3670 runcmd_ordryrun_local @git, qw(fetch origin);
3672 progress "starting new git history";
3674 fetch_from_archive() or no_such_package;
3675 my $vcsgiturl = $dsc->{'Vcs-Git'};
3676 if (length $vcsgiturl) {
3677 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3678 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3680 clone_finish($dstdir);
3684 canonicalise_suite();
3685 if (check_for_git()) {
3688 fetch_from_archive() or no_such_package();
3690 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3691 if (length $vcsgiturl and
3692 (grep { $csuite eq $_ }
3694 cfg 'dgit.vcs-git.suites')) {
3695 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3696 if (defined $current && $current ne $vcsgiturl) {
3698 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3699 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3703 printdone "fetched into ".lrref();
3707 my $multi_fetched = fork_for_multisuite(sub { });
3708 fetch_one() unless $multi_fetched; # parent
3709 finish 0 if $multi_fetched eq '0'; # child
3714 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3716 printdone "fetched to ".lrref()." and merged into HEAD";
3719 sub check_not_dirty () {
3720 foreach my $f (qw(local-options local-patch-header)) {
3721 if (stat_exists "debian/source/$f") {
3722 fail "git tree contains debian/source/$f";
3726 return if $ignoredirty;
3728 git_check_unmodified();
3731 sub commit_admin ($) {
3734 runcmd_ordryrun_local @git, qw(commit -m), $m;
3737 sub quiltify_nofix_bail ($$) {
3738 my ($headinfo, $xinfo) = @_;
3739 if ($quilt_mode eq 'nofix') {
3740 fail "quilt fixup required but quilt mode is \`nofix'\n".
3741 "HEAD commit".$headinfo." differs from tree implied by ".
3742 " debian/patches".$xinfo;
3746 sub commit_quilty_patch () {
3747 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3749 foreach my $l (split /\n/, $output) {
3750 next unless $l =~ m/\S/;
3751 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3755 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3757 progress "nothing quilty to commit, ok.";
3760 quiltify_nofix_bail "", " (wanted to commit patch update)";
3761 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3762 runcmd_ordryrun_local @git, qw(add -f), @adds;
3764 Commit Debian 3.0 (quilt) metadata
3766 [dgit ($our_version) quilt-fixup]
3770 sub get_source_format () {
3772 if (open F, "debian/source/options") {
3776 s/\s+$//; # ignore missing final newline
3778 my ($k, $v) = ($`, $'); #');
3779 $v =~ s/^"(.*)"$/$1/;
3785 F->error and die $!;
3788 die $! unless $!==&ENOENT;
3791 if (!open F, "debian/source/format") {
3792 die $! unless $!==&ENOENT;
3796 F->error and die $!;
3798 return ($_, \%options);
3801 sub madformat_wantfixup ($) {
3803 return 0 unless $format eq '3.0 (quilt)';
3804 our $quilt_mode_warned;
3805 if ($quilt_mode eq 'nocheck') {
3806 progress "Not doing any fixup of \`$format' due to".
3807 " ----no-quilt-fixup or --quilt=nocheck"
3808 unless $quilt_mode_warned++;
3811 progress "Format \`$format', need to check/update patch stack"
3812 unless $quilt_mode_warned++;
3816 sub maybe_split_brain_save ($$$) {
3817 my ($headref, $dgitview, $msg) = @_;
3818 # => message fragment "$saved" describing disposition of $dgitview
3819 return "commit id $dgitview" unless defined $split_brain_save;
3820 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3822 "dgit --dgit-view-save $msg HEAD=$headref",
3823 $split_brain_save, $dgitview);
3825 return "and left in $split_brain_save";
3828 # An "infopair" is a tuple [ $thing, $what ]
3829 # (often $thing is a commit hash; $what is a description)
3831 sub infopair_cond_equal ($$) {
3833 $x->[0] eq $y->[0] or fail <<END;
3834 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3838 sub infopair_lrf_tag_lookup ($$) {
3839 my ($tagnames, $what) = @_;
3840 # $tagname may be an array ref
3841 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3842 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3843 foreach my $tagname (@tagnames) {
3844 my $lrefname = lrfetchrefs."/tags/$tagname";
3845 my $tagobj = $lrfetchrefs_f{$lrefname};
3846 next unless defined $tagobj;
3847 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3848 return [ git_rev_parse($tagobj), $what ];
3850 fail @tagnames==1 ? <<END : <<END;
3851 Wanted tag $what (@tagnames) on dgit server, but not found
3853 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3857 sub infopair_cond_ff ($$) {
3858 my ($anc,$desc) = @_;
3859 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3860 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3864 sub pseudomerge_version_check ($$) {
3865 my ($clogp, $archive_hash) = @_;
3867 my $arch_clogp = commit_getclogp $archive_hash;
3868 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3869 'version currently in archive' ];
3870 if (defined $overwrite_version) {
3871 if (length $overwrite_version) {
3872 infopair_cond_equal([ $overwrite_version,
3873 '--overwrite= version' ],
3876 my $v = $i_arch_v->[0];
3877 progress "Checking package changelog for archive version $v ...";
3880 my @xa = ("-f$v", "-t$v");
3881 my $vclogp = parsechangelog @xa;
3884 [ (getfield $vclogp, $fn),
3885 "$fn field from dpkg-parsechangelog @xa" ];
3887 my $cv = $gf->('Version');
3888 infopair_cond_equal($i_arch_v, $cv);
3889 $cd = $gf->('Distribution');
3892 $@ =~ s/^dgit: //gm;
3894 "Perhaps debian/changelog does not mention $v ?";
3896 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3897 $cd->[1] is $cd->[0]
3898 Your tree seems to based on earlier (not uploaded) $v.
3903 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3907 sub pseudomerge_make_commit ($$$$ $$) {
3908 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3909 $msg_cmd, $msg_msg) = @_;
3910 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3912 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3913 my $authline = clogp_authline $clogp;
3917 !defined $overwrite_version ? ""
3918 : !length $overwrite_version ? " --overwrite"
3919 : " --overwrite=".$overwrite_version;
3921 # Contributing parent is the first parent - that makes
3922 # git rev-list --first-parent DTRT.
3923 my $pmf = dgit_privdir()."/pseudomerge";
3924 open MC, ">", $pmf or die "$pmf $!";
3925 print MC <<END or die $!;
3928 parent $archive_hash
3938 return make_commit($pmf);
3941 sub splitbrain_pseudomerge ($$$$) {
3942 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3943 # => $merged_dgitview
3944 printdebug "splitbrain_pseudomerge...\n";
3946 # We: debian/PREVIOUS HEAD($maintview)
3947 # expect: o ----------------- o
3950 # a/d/PREVIOUS $dgitview
3953 # we do: `------------------ o
3957 return $dgitview unless defined $archive_hash;
3958 return $dgitview if deliberately_not_fast_forward();
3960 printdebug "splitbrain_pseudomerge...\n";
3962 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3964 if (!defined $overwrite_version) {
3965 progress "Checking that HEAD inciudes all changes in archive...";
3968 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3970 if (defined $overwrite_version) {
3972 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3973 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3974 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3975 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3976 my $i_archive = [ $archive_hash, "current archive contents" ];
3978 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3980 infopair_cond_equal($i_dgit, $i_archive);
3981 infopair_cond_ff($i_dep14, $i_dgit);
3982 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3985 $@ =~ s/^\n//; chomp $@;
3988 | Not fast forward; maybe --overwrite is needed, see dgit(1)
3993 my $r = pseudomerge_make_commit
3994 $clogp, $dgitview, $archive_hash, $i_arch_v,
3995 "dgit --quilt=$quilt_mode",
3996 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3997 Declare fast forward from $i_arch_v->[0]
3999 Make fast forward from $i_arch_v->[0]
4002 maybe_split_brain_save $maintview, $r, "pseudomerge";
4004 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4008 sub plain_overwrite_pseudomerge ($$$) {
4009 my ($clogp, $head, $archive_hash) = @_;
4011 printdebug "plain_overwrite_pseudomerge...";
4013 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4015 return $head if is_fast_fwd $archive_hash, $head;
4017 my $m = "Declare fast forward from $i_arch_v->[0]";
4019 my $r = pseudomerge_make_commit
4020 $clogp, $head, $archive_hash, $i_arch_v,
4023 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4025 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4029 sub push_parse_changelog ($) {
4032 my $clogp = Dpkg::Control::Hash->new();
4033 $clogp->load($clogpfn) or die;
4035 my $clogpackage = getfield $clogp, 'Source';
4036 $package //= $clogpackage;
4037 fail "-p specified $package but changelog specified $clogpackage"
4038 unless $package eq $clogpackage;
4039 my $cversion = getfield $clogp, 'Version';
4041 if (!$we_are_initiator) {
4042 # rpush initiator can't do this because it doesn't have $isuite yet
4043 my $tag = debiantag($cversion, access_nomdistro);
4044 runcmd @git, qw(check-ref-format), $tag;
4047 my $dscfn = dscfn($cversion);
4049 return ($clogp, $cversion, $dscfn);
4052 sub push_parse_dsc ($$$) {
4053 my ($dscfn,$dscfnwhat, $cversion) = @_;
4054 $dsc = parsecontrol($dscfn,$dscfnwhat);
4055 my $dversion = getfield $dsc, 'Version';
4056 my $dscpackage = getfield $dsc, 'Source';
4057 ($dscpackage eq $package && $dversion eq $cversion) or
4058 fail "$dscfn is for $dscpackage $dversion".
4059 " but debian/changelog is for $package $cversion";
4062 sub push_tagwants ($$$$) {
4063 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4066 TagFn => \&debiantag,
4071 if (defined $maintviewhead) {
4073 TagFn => \&debiantag_maintview,
4074 Objid => $maintviewhead,
4075 TfSuffix => '-maintview',
4078 } elsif ($dodep14tag eq 'no' ? 0
4079 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4080 : $dodep14tag eq 'always'
4081 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4082 --dep14tag-always (or equivalent in config) means server must support
4083 both "new" and "maint" tag formats, but config says it doesn't.
4085 : die "$dodep14tag ?") {
4087 TagFn => \&debiantag_maintview,
4089 TfSuffix => '-dgit',
4093 foreach my $tw (@tagwants) {
4094 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4095 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4097 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4101 sub push_mktags ($$ $$ $) {
4103 $changesfile,$changesfilewhat,
4106 die unless $tagwants->[0]{View} eq 'dgit';
4108 my $declaredistro = access_nomdistro();
4109 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4110 $dsc->{$ourdscfield[0]} = join " ",
4111 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4113 $dsc->save("$dscfn.tmp") or die $!;
4115 my $changes = parsecontrol($changesfile,$changesfilewhat);
4116 foreach my $field (qw(Source Distribution Version)) {
4117 $changes->{$field} eq $clogp->{$field} or
4118 fail "changes field $field \`$changes->{$field}'".
4119 " does not match changelog \`$clogp->{$field}'";
4122 my $cversion = getfield $clogp, 'Version';
4123 my $clogsuite = getfield $clogp, 'Distribution';
4125 # We make the git tag by hand because (a) that makes it easier
4126 # to control the "tagger" (b) we can do remote signing
4127 my $authline = clogp_authline $clogp;
4128 my $delibs = join(" ", "",@deliberatelies);
4132 my $tfn = $tw->{Tfn};
4133 my $head = $tw->{Objid};
4134 my $tag = $tw->{Tag};
4136 open TO, '>', $tfn->('.tmp') or die $!;
4137 print TO <<END or die $!;
4144 if ($tw->{View} eq 'dgit') {
4145 print TO <<END or die $!;
4146 $package release $cversion for $clogsuite ($csuite) [dgit]
4147 [dgit distro=$declaredistro$delibs]
4149 foreach my $ref (sort keys %previously) {
4150 print TO <<END or die $!;
4151 [dgit previously:$ref=$previously{$ref}]
4154 } elsif ($tw->{View} eq 'maint') {
4155 print TO <<END or die $!;
4156 $package release $cversion for $clogsuite ($csuite)
4157 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4160 die Dumper($tw)."?";
4165 my $tagobjfn = $tfn->('.tmp');
4167 if (!defined $keyid) {
4168 $keyid = access_cfg('keyid','RETURN-UNDEF');
4170 if (!defined $keyid) {
4171 $keyid = getfield $clogp, 'Maintainer';
4173 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4174 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4175 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4176 push @sign_cmd, $tfn->('.tmp');
4177 runcmd_ordryrun @sign_cmd;
4179 $tagobjfn = $tfn->('.signed.tmp');
4180 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4181 $tfn->('.tmp'), $tfn->('.tmp.asc');
4187 my @r = map { $mktag->($_); } @$tagwants;
4191 sub sign_changes ($) {
4192 my ($changesfile) = @_;
4194 my @debsign_cmd = @debsign;
4195 push @debsign_cmd, "-k$keyid" if defined $keyid;
4196 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4197 push @debsign_cmd, $changesfile;
4198 runcmd_ordryrun @debsign_cmd;
4203 printdebug "actually entering push\n";
4205 supplementary_message(<<'END');
4206 Push failed, while checking state of the archive.
4207 You can retry the push, after fixing the problem, if you like.
4209 if (check_for_git()) {
4212 my $archive_hash = fetch_from_archive();
4213 if (!$archive_hash) {
4215 fail "package appears to be new in this suite;".
4216 " if this is intentional, use --new";
4219 supplementary_message(<<'END');
4220 Push failed, while preparing your push.
4221 You can retry the push, after fixing the problem, if you like.
4224 need_tagformat 'new', "quilt mode $quilt_mode"
4225 if quiltmode_splitbrain;
4229 access_giturl(); # check that success is vaguely likely
4230 rpush_handle_protovsn_bothends() if $we_are_initiator;
4233 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4234 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4236 responder_send_file('parsed-changelog', $clogpfn);
4238 my ($clogp, $cversion, $dscfn) =
4239 push_parse_changelog("$clogpfn");
4241 my $dscpath = "$buildproductsdir/$dscfn";
4242 stat_exists $dscpath or
4243 fail "looked for .dsc $dscpath, but $!;".
4244 " maybe you forgot to build";
4246 responder_send_file('dsc', $dscpath);
4248 push_parse_dsc($dscpath, $dscfn, $cversion);
4250 my $format = getfield $dsc, 'Format';
4251 printdebug "format $format\n";
4253 my $symref = git_get_symref();
4254 my $actualhead = git_rev_parse('HEAD');
4256 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4257 runcmd_ordryrun_local @git_debrebase, 'stitch';
4258 $actualhead = git_rev_parse('HEAD');
4261 my $dgithead = $actualhead;
4262 my $maintviewhead = undef;
4264 my $upstreamversion = upstreamversion $clogp->{Version};
4266 if (madformat_wantfixup($format)) {
4267 # user might have not used dgit build, so maybe do this now:
4268 if (quiltmode_splitbrain()) {
4269 changedir $playground;
4270 quilt_make_fake_dsc($upstreamversion);
4272 ($dgithead, $cachekey) =
4273 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4275 "--quilt=$quilt_mode but no cached dgit view:
4276 perhaps HEAD changed since dgit build[-source] ?";
4278 $dgithead = splitbrain_pseudomerge($clogp,
4279 $actualhead, $dgithead,
4281 $maintviewhead = $actualhead;
4283 prep_ud(); # so _only_subdir() works, below
4285 commit_quilty_patch();
4289 if (defined $overwrite_version && !defined $maintviewhead
4291 $dgithead = plain_overwrite_pseudomerge($clogp,
4299 if ($archive_hash) {
4300 if (is_fast_fwd($archive_hash, $dgithead)) {
4302 } elsif (deliberately_not_fast_forward) {
4305 fail "dgit push: HEAD is not a descendant".
4306 " of the archive's version.\n".
4307 "To overwrite the archive's contents,".
4308 " pass --overwrite[=VERSION].\n".
4309 "To rewind history, if permitted by the archive,".
4310 " use --deliberately-not-fast-forward.";
4314 changedir $playground;
4315 progress "checking that $dscfn corresponds to HEAD";
4316 runcmd qw(dpkg-source -x --),
4317 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4318 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4319 check_for_vendor_patches() if madformat($dsc->{format});
4321 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4322 debugcmd "+",@diffcmd;
4324 my $r = system @diffcmd;
4327 my $referent = $split_brain ? $dgithead : 'HEAD';
4328 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4331 my $raw = cmdoutput @git,
4332 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4334 foreach (split /\0/, $raw) {
4335 if (defined $changed) {
4336 push @mode_changes, "$changed: $_\n" if $changed;
4339 } elsif (m/^:0+ 0+ /) {
4341 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4342 $changed = "Mode change from $1 to $2"
4347 if (@mode_changes) {
4348 fail <<END.(join '', @mode_changes).<<END;
4349 HEAD specifies a different tree to $dscfn:
4352 There is a problem with your source tree (see dgit(7) for some hints).
4353 To see a full diff, run git diff $tree $referent
4358 HEAD specifies a different tree to $dscfn:
4360 Perhaps you forgot to build. Or perhaps there is a problem with your
4361 source tree (see dgit(7) for some hints). To see a full diff, run
4362 git diff $tree $referent
4368 if (!$changesfile) {
4369 my $pat = changespat $cversion;
4370 my @cs = glob "$buildproductsdir/$pat";
4371 fail "failed to find unique changes file".
4372 " (looked for $pat in $buildproductsdir);".
4373 " perhaps you need to use dgit -C"
4375 ($changesfile) = @cs;
4377 $changesfile = "$buildproductsdir/$changesfile";
4380 # Check that changes and .dsc agree enough
4381 $changesfile =~ m{[^/]*$};
4382 my $changes = parsecontrol($changesfile,$&);
4383 files_compare_inputs($dsc, $changes)
4384 unless forceing [qw(dsc-changes-mismatch)];
4386 # Check whether this is a source only upload
4387 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4388 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4389 if ($sourceonlypolicy eq 'ok') {
4390 } elsif ($sourceonlypolicy eq 'always') {
4391 forceable_fail [qw(uploading-binaries)],
4392 "uploading binaries, although distroy policy is source only"
4394 } elsif ($sourceonlypolicy eq 'never') {
4395 forceable_fail [qw(uploading-source-only)],
4396 "source-only upload, although distroy policy requires .debs"
4398 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4399 forceable_fail [qw(uploading-source-only)],
4400 "source-only upload, even though package is entirely NEW\n".
4401 "(this is contrary to policy in ".(access_nomdistro()).")"
4404 && !(archive_query('package_not_wholly_new', $package) // 1);
4406 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4409 # Perhaps adjust .dsc to contain right set of origs
4410 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4412 unless forceing [qw(changes-origs-exactly)];
4414 # Checks complete, we're going to try and go ahead:
4416 responder_send_file('changes',$changesfile);
4417 responder_send_command("param head $dgithead");
4418 responder_send_command("param csuite $csuite");
4419 responder_send_command("param isuite $isuite");
4420 responder_send_command("param tagformat $tagformat");
4421 if (defined $maintviewhead) {
4422 die unless ($protovsn//4) >= 4;
4423 responder_send_command("param maint-view $maintviewhead");
4426 # Perhaps send buildinfo(s) for signing
4427 my $changes_files = getfield $changes, 'Files';
4428 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4429 foreach my $bi (@buildinfos) {
4430 responder_send_command("param buildinfo-filename $bi");
4431 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4434 if (deliberately_not_fast_forward) {
4435 git_for_each_ref(lrfetchrefs, sub {
4436 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4437 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4438 responder_send_command("previously $rrefname=$objid");
4439 $previously{$rrefname} = $objid;
4443 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4444 dgit_privdir()."/tag");
4447 supplementary_message(<<'END');
4448 Push failed, while signing the tag.
4449 You can retry the push, after fixing the problem, if you like.
4451 # If we manage to sign but fail to record it anywhere, it's fine.
4452 if ($we_are_responder) {
4453 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4454 responder_receive_files('signed-tag', @tagobjfns);
4456 @tagobjfns = push_mktags($clogp,$dscpath,
4457 $changesfile,$changesfile,
4460 supplementary_message(<<'END');
4461 Push failed, *after* signing the tag.
4462 If you want to try again, you should use a new version number.
4465 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4467 foreach my $tw (@tagwants) {
4468 my $tag = $tw->{Tag};
4469 my $tagobjfn = $tw->{TagObjFn};
4471 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4472 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4473 runcmd_ordryrun_local
4474 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4477 supplementary_message(<<'END');
4478 Push failed, while updating the remote git repository - see messages above.
4479 If you want to try again, you should use a new version number.
4481 if (!check_for_git()) {
4482 create_remote_git_repo();
4485 my @pushrefs = $forceflag.$dgithead.":".rrref();
4486 foreach my $tw (@tagwants) {
4487 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4490 runcmd_ordryrun @git,
4491 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4492 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4494 supplementary_message(<<'END');
4495 Push failed, while obtaining signatures on the .changes and .dsc.
4496 If it was just that the signature failed, you may try again by using
4497 debsign by hand to sign the changes
4499 and then dput to complete the upload.
4500 If you need to change the package, you must use a new version number.
4502 if ($we_are_responder) {
4503 my $dryrunsuffix = act_local() ? "" : ".tmp";
4504 my @rfiles = ($dscpath, $changesfile);
4505 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4506 responder_receive_files('signed-dsc-changes',
4507 map { "$_$dryrunsuffix" } @rfiles);
4510 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4512 progress "[new .dsc left in $dscpath.tmp]";
4514 sign_changes $changesfile;
4517 supplementary_message(<<END);
4518 Push failed, while uploading package(s) to the archive server.
4519 You can retry the upload of exactly these same files with dput of:
4521 If that .changes file is broken, you will need to use a new version
4522 number for your next attempt at the upload.
4524 my $host = access_cfg('upload-host','RETURN-UNDEF');
4525 my @hostarg = defined($host) ? ($host,) : ();
4526 runcmd_ordryrun @dput, @hostarg, $changesfile;
4527 printdone "pushed and uploaded $cversion";
4529 supplementary_message('');
4530 responder_send_command("complete");
4534 not_necessarily_a_tree();
4539 badusage "-p is not allowed with clone; specify as argument instead"
4540 if defined $package;
4543 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4544 ($package,$isuite) = @ARGV;
4545 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4546 ($package,$dstdir) = @ARGV;
4547 } elsif (@ARGV==3) {
4548 ($package,$isuite,$dstdir) = @ARGV;
4550 badusage "incorrect arguments to dgit clone";
4554 $dstdir ||= "$package";
4555 if (stat_exists $dstdir) {
4556 fail "$dstdir already exists";
4560 if ($rmonerror && !$dryrun_level) {
4561 $cwd_remove= getcwd();
4563 return unless defined $cwd_remove;
4564 if (!chdir "$cwd_remove") {
4565 return if $!==&ENOENT;
4566 die "chdir $cwd_remove: $!";
4568 printdebug "clone rmonerror removing $dstdir\n";
4570 rmtree($dstdir) or die "remove $dstdir: $!\n";
4571 } elsif (grep { $! == $_ }
4572 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4574 print STDERR "check whether to remove $dstdir: $!\n";
4580 $cwd_remove = undef;
4583 sub branchsuite () {
4584 my $branch = git_get_symref();
4585 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4592 sub package_from_d_control () {
4593 if (!defined $package) {
4594 my $sourcep = parsecontrol('debian/control','debian/control');
4595 $package = getfield $sourcep, 'Source';
4599 sub fetchpullargs () {
4600 package_from_d_control();
4602 $isuite = branchsuite();
4604 my $clogp = parsechangelog();
4605 my $clogsuite = getfield $clogp, 'Distribution';
4606 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4608 } elsif (@ARGV==1) {
4611 badusage "incorrect arguments to dgit fetch or dgit pull";
4625 if (quiltmode_splitbrain()) {
4626 my ($format, $fopts) = get_source_format();
4627 madformat($format) and fail <<END
4628 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4636 package_from_d_control();
4637 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4641 foreach my $canon (qw(0 1)) {
4646 canonicalise_suite();
4648 if (length git_get_ref lref()) {
4649 # local branch already exists, yay
4652 if (!length git_get_ref lrref()) {
4660 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4663 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4664 "dgit checkout $isuite";
4665 runcmd (@git, qw(checkout), lbranch());
4668 sub cmd_update_vcs_git () {
4670 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4671 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4673 ($specsuite) = (@ARGV);
4678 if ($ARGV[0] eq '-') {
4680 } elsif ($ARGV[0] eq '-') {
4685 package_from_d_control();
4687 if ($specsuite eq '.') {
4688 $ctrl = parsecontrol 'debian/control', 'debian/control';
4690 $isuite = $specsuite;
4694 my $url = getfield $ctrl, 'Vcs-Git';
4697 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4698 if (!defined $orgurl) {
4699 print STDERR "setting up vcs-git: $url\n";
4700 @cmd = (@git, qw(remote add vcs-git), $url);
4701 } elsif ($orgurl eq $url) {
4702 print STDERR "vcs git already configured: $url\n";
4704 print STDERR "changing vcs-git url to: $url\n";
4705 @cmd = (@git, qw(remote set-url vcs-git), $url);
4707 runcmd_ordryrun_local @cmd;
4709 print "fetching (@ARGV)\n";
4710 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4716 build_or_push_prep_early();
4721 } elsif (@ARGV==1) {
4722 ($specsuite) = (@ARGV);
4724 badusage "incorrect arguments to dgit $subcommand";
4727 local ($package) = $existing_package; # this is a hack
4728 canonicalise_suite();
4730 canonicalise_suite();
4732 if (defined $specsuite &&
4733 $specsuite ne $isuite &&
4734 $specsuite ne $csuite) {
4735 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4736 " but command line specifies $specsuite";
4745 sub cmd_push_source {
4748 my $changes = parsecontrol("$buildproductsdir/$changesfile",
4749 "source changes file");
4750 unless (test_source_only_changes($changes)) {
4751 fail "user-specified changes file is not source-only";
4754 # Building a source package is very fast, so just do it
4755 build_source_for_push();
4760 #---------- remote commands' implementation ----------
4762 sub pre_remote_push_build_host {
4763 my ($nrargs) = shift @ARGV;
4764 my (@rargs) = @ARGV[0..$nrargs-1];
4765 @ARGV = @ARGV[$nrargs..$#ARGV];
4767 my ($dir,$vsnwant) = @rargs;
4768 # vsnwant is a comma-separated list; we report which we have
4769 # chosen in our ready response (so other end can tell if they
4772 $we_are_responder = 1;
4773 $us .= " (build host)";
4775 open PI, "<&STDIN" or die $!;
4776 open STDIN, "/dev/null" or die $!;
4777 open PO, ">&STDOUT" or die $!;
4779 open STDOUT, ">&STDERR" or die $!;
4783 ($protovsn) = grep {
4784 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4785 } @rpushprotovsn_support;
4787 fail "build host has dgit rpush protocol versions ".
4788 (join ",", @rpushprotovsn_support).
4789 " but invocation host has $vsnwant"
4790 unless defined $protovsn;
4794 sub cmd_remote_push_build_host {
4795 responder_send_command("dgit-remote-push-ready $protovsn");
4799 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4800 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4801 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4802 # a good error message)
4804 sub rpush_handle_protovsn_bothends () {
4805 if ($protovsn < 4) {
4806 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4815 my $report = i_child_report();
4816 if (defined $report) {
4817 printdebug "($report)\n";
4818 } elsif ($i_child_pid) {
4819 printdebug "(killing build host child $i_child_pid)\n";
4820 kill 15, $i_child_pid;
4822 if (defined $i_tmp && !defined $initiator_tempdir) {
4824 eval { rmtree $i_tmp; };
4829 return unless forkcheck_mainprocess();
4834 my ($base,$selector,@args) = @_;
4835 $selector =~ s/\-/_/g;
4836 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4840 not_necessarily_a_tree();
4845 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4853 push @rargs, join ",", @rpushprotovsn_support;
4856 push @rdgit, @ropts;
4857 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4859 my @cmd = (@ssh, $host, shellquote @rdgit);
4862 $we_are_initiator=1;
4864 if (defined $initiator_tempdir) {
4865 rmtree $initiator_tempdir;
4866 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4867 $i_tmp = $initiator_tempdir;
4871 $i_child_pid = open2(\*RO, \*RI, @cmd);
4873 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4874 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4875 $supplementary_message = '' unless $protovsn >= 3;
4878 my ($icmd,$iargs) = initiator_expect {
4879 m/^(\S+)(?: (.*))?$/;
4882 i_method "i_resp", $icmd, $iargs;
4886 sub i_resp_progress ($) {
4888 my $msg = protocol_read_bytes \*RO, $rhs;
4892 sub i_resp_supplementary_message ($) {
4894 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4897 sub i_resp_complete {
4898 my $pid = $i_child_pid;
4899 $i_child_pid = undef; # prevents killing some other process with same pid
4900 printdebug "waiting for build host child $pid...\n";
4901 my $got = waitpid $pid, 0;
4902 die $! unless $got == $pid;
4903 die "build host child failed $?" if $?;
4906 printdebug "all done\n";
4910 sub i_resp_file ($) {
4912 my $localname = i_method "i_localname", $keyword;
4913 my $localpath = "$i_tmp/$localname";
4914 stat_exists $localpath and
4915 badproto \*RO, "file $keyword ($localpath) twice";
4916 protocol_receive_file \*RO, $localpath;
4917 i_method "i_file", $keyword;
4922 sub i_resp_param ($) {
4923 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4927 sub i_resp_previously ($) {
4928 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4929 or badproto \*RO, "bad previously spec";
4930 my $r = system qw(git check-ref-format), $1;
4931 die "bad previously ref spec ($r)" if $r;
4932 $previously{$1} = $2;
4937 sub i_resp_want ($) {
4939 die "$keyword ?" if $i_wanted{$keyword}++;
4941 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4942 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4943 die unless $isuite =~ m/^$suite_re$/;
4946 rpush_handle_protovsn_bothends();
4948 fail "rpush negotiated protocol version $protovsn".
4949 " which does not support quilt mode $quilt_mode"
4950 if quiltmode_splitbrain;
4952 my @localpaths = i_method "i_want", $keyword;
4953 printdebug "[[ $keyword @localpaths\n";
4954 foreach my $localpath (@localpaths) {
4955 protocol_send_file \*RI, $localpath;
4957 print RI "files-end\n" or die $!;
4960 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4962 sub i_localname_parsed_changelog {
4963 return "remote-changelog.822";
4965 sub i_file_parsed_changelog {
4966 ($i_clogp, $i_version, $i_dscfn) =
4967 push_parse_changelog "$i_tmp/remote-changelog.822";
4968 die if $i_dscfn =~ m#/|^\W#;
4971 sub i_localname_dsc {
4972 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4977 sub i_localname_buildinfo ($) {
4978 my $bi = $i_param{'buildinfo-filename'};
4979 defined $bi or badproto \*RO, "buildinfo before filename";
4980 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4981 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4982 or badproto \*RO, "improper buildinfo filename";
4985 sub i_file_buildinfo {
4986 my $bi = $i_param{'buildinfo-filename'};
4987 my $bd = parsecontrol "$i_tmp/$bi", $bi;
4988 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4989 if (!forceing [qw(buildinfo-changes-mismatch)]) {
4990 files_compare_inputs($bd, $ch);
4991 (getfield $bd, $_) eq (getfield $ch, $_) or
4992 fail "buildinfo mismatch $_"
4993 foreach qw(Source Version);
4994 !defined $bd->{$_} or
4995 fail "buildinfo contains $_"
4996 foreach qw(Changes Changed-by Distribution);
4998 push @i_buildinfos, $bi;
4999 delete $i_param{'buildinfo-filename'};
5002 sub i_localname_changes {
5003 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5004 $i_changesfn = $i_dscfn;
5005 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5006 return $i_changesfn;
5008 sub i_file_changes { }
5010 sub i_want_signed_tag {
5011 printdebug Dumper(\%i_param, $i_dscfn);
5012 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5013 && defined $i_param{'csuite'}
5014 or badproto \*RO, "premature desire for signed-tag";
5015 my $head = $i_param{'head'};
5016 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5018 my $maintview = $i_param{'maint-view'};
5019 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5022 if ($protovsn >= 4) {
5023 my $p = $i_param{'tagformat'} // '<undef>';
5025 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5028 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5030 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5032 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5035 push_mktags $i_clogp, $i_dscfn,
5036 $i_changesfn, 'remote changes',
5040 sub i_want_signed_dsc_changes {
5041 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5042 sign_changes $i_changesfn;
5043 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5046 #---------- building etc. ----------
5052 #----- `3.0 (quilt)' handling -----
5054 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5056 sub quiltify_dpkg_commit ($$$;$) {
5057 my ($patchname,$author,$msg, $xinfo) = @_;
5060 mkpath '.git/dgit'; # we are in playtree
5061 my $descfn = ".git/dgit/quilt-description.tmp";
5062 open O, '>', $descfn or die "$descfn: $!";
5063 $msg =~ s/\n+/\n\n/;
5064 print O <<END or die $!;
5066 ${xinfo}Subject: $msg
5073 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5074 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5075 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5076 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5080 sub quiltify_trees_differ ($$;$$$) {
5081 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5082 # returns true iff the two tree objects differ other than in debian/
5083 # with $finegrained,
5084 # returns bitmask 01 - differ in upstream files except .gitignore
5085 # 02 - differ in .gitignore
5086 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5087 # is set for each modified .gitignore filename $fn
5088 # if $unrepres is defined, array ref to which is appeneded
5089 # a list of unrepresentable changes (removals of upstream files
5092 my @cmd = (@git, qw(diff-tree -z --no-renames));
5093 push @cmd, qw(--name-only) unless $unrepres;
5094 push @cmd, qw(-r) if $finegrained || $unrepres;
5096 my $diffs= cmdoutput @cmd;
5099 foreach my $f (split /\0/, $diffs) {
5100 if ($unrepres && !@lmodes) {
5101 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5104 my ($oldmode,$newmode) = @lmodes;
5107 next if $f =~ m#^debian(?:/.*)?$#s;
5111 die "not a plain file or symlink\n"
5112 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5113 $oldmode =~ m/^(?:10|12)\d{4}$/;
5114 if ($oldmode =~ m/[^0]/ &&
5115 $newmode =~ m/[^0]/) {
5116 # both old and new files exist
5117 die "mode or type changed\n" if $oldmode ne $newmode;
5118 die "modified symlink\n" unless $newmode =~ m/^10/;
5119 } elsif ($oldmode =~ m/[^0]/) {
5121 die "deletion of symlink\n"
5122 unless $oldmode =~ m/^10/;
5125 die "creation with non-default mode\n"
5126 unless $newmode =~ m/^100644$/ or
5127 $newmode =~ m/^120000$/;
5131 local $/="\n"; chomp $@;
5132 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5136 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5137 $r |= $isignore ? 02 : 01;
5138 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5140 printdebug "quiltify_trees_differ $x $y => $r\n";
5144 sub quiltify_tree_sentinelfiles ($) {
5145 # lists the `sentinel' files present in the tree
5147 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5148 qw(-- debian/rules debian/control);
5153 sub quiltify_splitbrain_needed () {
5154 if (!$split_brain) {
5155 progress "dgit view: changes are required...";
5156 runcmd @git, qw(checkout -q -b dgit-view);
5161 sub quiltify_splitbrain ($$$$$$$) {
5162 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5163 $editedignores, $cachekey) = @_;
5164 my $gitignore_special = 1;
5165 if ($quilt_mode !~ m/gbp|dpm/) {
5166 # treat .gitignore just like any other upstream file
5167 $diffbits = { %$diffbits };
5168 $_ = !!$_ foreach values %$diffbits;
5169 $gitignore_special = 0;
5171 # We would like any commits we generate to be reproducible
5172 my @authline = clogp_authline($clogp);
5173 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5174 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5175 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5176 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5177 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5178 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5180 my $fulldiffhint = sub {
5182 my $cmd = "git diff $x $y -- :/ ':!debian'";
5183 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5184 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5187 if ($quilt_mode =~ m/gbp|unapplied/ &&
5188 ($diffbits->{O2H} & 01)) {
5190 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5191 " but git tree differs from orig in upstream files.";
5192 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5193 if (!stat_exists "debian/patches") {
5195 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5199 if ($quilt_mode =~ m/dpm/ &&
5200 ($diffbits->{H2A} & 01)) {
5201 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5202 --quilt=$quilt_mode specified, implying patches-applied git tree
5203 but git tree differs from result of applying debian/patches to upstream
5206 if ($quilt_mode =~ m/gbp|unapplied/ &&
5207 ($diffbits->{O2A} & 01)) { # some patches
5208 quiltify_splitbrain_needed();
5209 progress "dgit view: creating patches-applied version using gbp pq";
5210 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5211 # gbp pq import creates a fresh branch; push back to dgit-view
5212 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5213 runcmd @git, qw(checkout -q dgit-view);
5215 if ($quilt_mode =~ m/gbp|dpm/ &&
5216 ($diffbits->{O2A} & 02)) {
5218 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5219 tool which does not create patches for changes to upstream
5220 .gitignores: but, such patches exist in debian/patches.
5223 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5224 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5225 quiltify_splitbrain_needed();
5226 progress "dgit view: creating patch to represent .gitignore changes";
5227 ensuredir "debian/patches";
5228 my $gipatch = "debian/patches/auto-gitignore";
5229 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5230 stat GIPATCH or die "$gipatch: $!";
5231 fail "$gipatch already exists; but want to create it".
5232 " to record .gitignore changes" if (stat _)[7];
5233 print GIPATCH <<END or die "$gipatch: $!";
5234 Subject: Update .gitignore from Debian packaging branch
5236 The Debian packaging git branch contains these updates to the upstream
5237 .gitignore file(s). This patch is autogenerated, to provide these
5238 updates to users of the official Debian archive view of the package.
5240 [dgit ($our_version) update-gitignore]
5243 close GIPATCH or die "$gipatch: $!";
5244 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5245 $unapplied, $headref, "--", sort keys %$editedignores;
5246 open SERIES, "+>>", "debian/patches/series" or die $!;
5247 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5249 defined read SERIES, $newline, 1 or die $!;
5250 print SERIES "\n" or die $! unless $newline eq "\n";
5251 print SERIES "auto-gitignore\n" or die $!;
5252 close SERIES or die $!;
5253 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5255 Commit patch to update .gitignore
5257 [dgit ($our_version) update-gitignore-quilt-fixup]
5261 my $dgitview = git_rev_parse 'HEAD';
5264 # When we no longer need to support squeeze, use --create-reflog
5266 ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5267 my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5270 my $oldcache = git_get_ref "refs/$splitbraincache";
5271 if ($oldcache eq $dgitview) {
5272 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5273 # git update-ref doesn't always update, in this case. *sigh*
5274 my $dummy = make_commit_text <<END;
5277 author Dgit <dgit\@example.com> 1000000000 +0000
5278 committer Dgit <dgit\@example.com> 1000000000 +0000
5280 Dummy commit - do not use
5282 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5283 "refs/$splitbraincache", $dummy;
5285 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5288 changedir "$playground/work";
5290 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5291 progress "dgit view: created ($saved)";
5294 sub quiltify ($$$$) {
5295 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5297 # Quilt patchification algorithm
5299 # We search backwards through the history of the main tree's HEAD
5300 # (T) looking for a start commit S whose tree object is identical
5301 # to to the patch tip tree (ie the tree corresponding to the
5302 # current dpkg-committed patch series). For these purposes
5303 # `identical' disregards anything in debian/ - this wrinkle is
5304 # necessary because dpkg-source treates debian/ specially.
5306 # We can only traverse edges where at most one of the ancestors'
5307 # trees differs (in changes outside in debian/). And we cannot
5308 # handle edges which change .pc/ or debian/patches. To avoid
5309 # going down a rathole we avoid traversing edges which introduce
5310 # debian/rules or debian/control. And we set a limit on the
5311 # number of edges we are willing to look at.
5313 # If we succeed, we walk forwards again. For each traversed edge
5314 # PC (with P parent, C child) (starting with P=S and ending with
5315 # C=T) to we do this:
5317 # - dpkg-source --commit with a patch name and message derived from C
5318 # After traversing PT, we git commit the changes which
5319 # should be contained within debian/patches.
5321 # The search for the path S..T is breadth-first. We maintain a
5322 # todo list containing search nodes. A search node identifies a
5323 # commit, and looks something like this:
5325 # Commit => $git_commit_id,
5326 # Child => $c, # or undef if P=T
5327 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5328 # Nontrivial => true iff $p..$c has relevant changes
5335 my %considered; # saves being exponential on some weird graphs
5337 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5340 my ($search,$whynot) = @_;
5341 printdebug " search NOT $search->{Commit} $whynot\n";
5342 $search->{Whynot} = $whynot;
5343 push @nots, $search;
5344 no warnings qw(exiting);
5353 my $c = shift @todo;
5354 next if $considered{$c->{Commit}}++;
5356 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5358 printdebug "quiltify investigate $c->{Commit}\n";
5361 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5362 printdebug " search finished hooray!\n";
5367 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5368 if ($quilt_mode eq 'smash') {
5369 printdebug " search quitting smash\n";
5373 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5374 $not->($c, "has $c_sentinels not $t_sentinels")
5375 if $c_sentinels ne $t_sentinels;
5377 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5378 $commitdata =~ m/\n\n/;
5380 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5381 @parents = map { { Commit => $_, Child => $c } } @parents;
5383 $not->($c, "root commit") if !@parents;
5385 foreach my $p (@parents) {
5386 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5388 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5389 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5391 foreach my $p (@parents) {
5392 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5394 my @cmd= (@git, qw(diff-tree -r --name-only),
5395 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5396 my $patchstackchange = cmdoutput @cmd;
5397 if (length $patchstackchange) {
5398 $patchstackchange =~ s/\n/,/g;
5399 $not->($p, "changed $patchstackchange");
5402 printdebug " search queue P=$p->{Commit} ",
5403 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5409 printdebug "quiltify want to smash\n";
5412 my $x = $_[0]{Commit};
5413 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5416 my $reportnot = sub {
5418 my $s = $abbrev->($notp);
5419 my $c = $notp->{Child};
5420 $s .= "..".$abbrev->($c) if $c;
5421 $s .= ": ".$notp->{Whynot};
5424 if ($quilt_mode eq 'linear') {
5425 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5426 foreach my $notp (@nots) {
5427 print STDERR "$us: ", $reportnot->($notp), "\n";
5429 print STDERR "$us: $_\n" foreach @$failsuggestion;
5431 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n".
5432 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5433 } elsif ($quilt_mode eq 'smash') {
5434 } elsif ($quilt_mode eq 'auto') {
5435 progress "quilt fixup cannot be linear, smashing...";
5437 die "$quilt_mode ?";
5440 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5441 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5443 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5445 quiltify_dpkg_commit "auto-$version-$target-$time",
5446 (getfield $clogp, 'Maintainer'),
5447 "Automatically generated patch ($clogp->{Version})\n".
5448 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5452 progress "quiltify linearisation planning successful, executing...";
5454 for (my $p = $sref_S;
5455 my $c = $p->{Child};
5457 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5458 next unless $p->{Nontrivial};
5460 my $cc = $c->{Commit};
5462 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5463 $commitdata =~ m/\n\n/ or die "$c ?";
5466 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5469 my $commitdate = cmdoutput
5470 @git, qw(log -n1 --pretty=format:%aD), $cc;
5472 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5474 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5481 my $gbp_check_suitable = sub {
5486 die "contains unexpected slashes\n" if m{//} || m{/$};
5487 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5488 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5489 die "is series file\n" if m{$series_filename_re}o;
5490 die "too long" if length > 200;
5492 return $_ unless $@;
5493 print STDERR "quiltifying commit $cc:".
5494 " ignoring/dropping Gbp-Pq $what: $@";
5498 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5500 (\S+) \s* \n //ixm) {
5501 $patchname = $gbp_check_suitable->($1, 'Name');
5503 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5505 (\S+) \s* \n //ixm) {
5506 $patchdir = $gbp_check_suitable->($1, 'Topic');
5511 if (!defined $patchname) {
5512 $patchname = $title;
5513 $patchname =~ s/[.:]$//;
5516 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5517 my $translitname = $converter->convert($patchname);
5518 die unless defined $translitname;
5519 $patchname = $translitname;
5522 "dgit: patch title transliteration error: $@"
5524 $patchname =~ y/ A-Z/-a-z/;
5525 $patchname =~ y/-a-z0-9_.+=~//cd;
5526 $patchname =~ s/^\W/x-$&/;
5527 $patchname = substr($patchname,0,40);
5528 $patchname .= ".patch";
5530 if (!defined $patchdir) {
5533 if (length $patchdir) {
5534 $patchname = "$patchdir/$patchname";
5536 if ($patchname =~ m{^(.*)/}) {
5537 mkpath "debian/patches/$1";
5542 stat "debian/patches/$patchname$index";
5544 $!==ENOENT or die "$patchname$index $!";
5546 runcmd @git, qw(checkout -q), $cc;
5548 # We use the tip's changelog so that dpkg-source doesn't
5549 # produce complaining messages from dpkg-parsechangelog. None
5550 # of the information dpkg-source gets from the changelog is
5551 # actually relevant - it gets put into the original message
5552 # which dpkg-source provides our stunt editor, and then
5554 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5556 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5557 "Date: $commitdate\n".
5558 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5560 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5563 runcmd @git, qw(checkout -q master);
5566 sub build_maybe_quilt_fixup () {
5567 my ($format,$fopts) = get_source_format;
5568 return unless madformat_wantfixup $format;
5571 check_for_vendor_patches();
5573 if (quiltmode_splitbrain) {
5574 fail <<END unless access_cfg_tagformats_can_splitbrain;
5575 quilt mode $quilt_mode requires split view so server needs to support
5576 both "new" and "maint" tag formats, but config says it doesn't.
5580 my $clogp = parsechangelog();
5581 my $headref = git_rev_parse('HEAD');
5582 my $symref = git_get_symref();
5584 if ($quilt_mode eq 'linear'
5585 && !$fopts->{'single-debian-patch'}
5586 && branch_is_gdr($symref, $headref)) {
5587 # This is much faster. It also makes patches that gdr
5588 # likes better for future updates without laundering.
5590 # However, it can fail in some casses where we would
5591 # succeed: if there are existing patches, which correspond
5592 # to a prefix of the branch, but are not in gbp/gdr
5593 # format, gdr will fail (exiting status 7), but we might
5594 # be able to figure out where to start linearising. That
5595 # will be slower so hopefully there's not much to do.
5596 my @cmd = (@git_debrebase,
5597 qw(--noop-ok -funclean-mixed -funclean-ordering
5598 make-patches --quiet-would-amend));
5599 # We tolerate soe snags that gdr wouldn't, by default.
5603 failedcmd @cmd if system @cmd and $?!=7*256;
5607 $headref = git_rev_parse('HEAD');
5611 changedir $playground;
5613 my $upstreamversion = upstreamversion $version;
5615 if ($fopts->{'single-debian-patch'}) {
5616 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5618 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5621 die 'bug' if $split_brain && !$need_split_build_invocation;
5624 runcmd_ordryrun_local
5625 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5628 sub quilt_fixup_mkwork ($) {
5631 mkdir "work" or die $!;
5633 mktree_in_ud_here();
5634 runcmd @git, qw(reset -q --hard), $headref;
5637 sub quilt_fixup_linkorigs ($$) {
5638 my ($upstreamversion, $fn) = @_;
5639 # calls $fn->($leafname);
5641 foreach my $f (<$maindir/../*>) { #/){
5642 my $b=$f; $b =~ s{.*/}{};
5644 local ($debuglevel) = $debuglevel-1;
5645 printdebug "QF linkorigs $b, $f ?\n";
5647 next unless is_orig_file_of_vsn $b, $upstreamversion;
5648 printdebug "QF linkorigs $b, $f Y\n";
5649 link_ltarget $f, $b or die "$b $!";
5654 sub quilt_fixup_delete_pc () {
5655 runcmd @git, qw(rm -rqf .pc);
5657 Commit removal of .pc (quilt series tracking data)
5659 [dgit ($our_version) upgrade quilt-remove-pc]
5663 sub quilt_fixup_singlepatch ($$$) {
5664 my ($clogp, $headref, $upstreamversion) = @_;
5666 progress "starting quiltify (single-debian-patch)";
5668 # dpkg-source --commit generates new patches even if
5669 # single-debian-patch is in debian/source/options. In order to
5670 # get it to generate debian/patches/debian-changes, it is
5671 # necessary to build the source package.
5673 quilt_fixup_linkorigs($upstreamversion, sub { });
5674 quilt_fixup_mkwork($headref);
5676 rmtree("debian/patches");
5678 runcmd @dpkgsource, qw(-b .);
5680 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5681 rename srcfn("$upstreamversion", "/debian/patches"),
5682 "work/debian/patches";
5685 commit_quilty_patch();
5688 sub quilt_make_fake_dsc ($) {
5689 my ($upstreamversion) = @_;
5691 my $fakeversion="$upstreamversion-~~DGITFAKE";
5693 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5694 print $fakedsc <<END or die $!;
5697 Version: $fakeversion
5701 my $dscaddfile=sub {
5704 my $md = new Digest::MD5;
5706 my $fh = new IO::File $b, '<' or die "$b $!";
5711 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5714 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5716 my @files=qw(debian/source/format debian/rules
5717 debian/control debian/changelog);
5718 foreach my $maybe (qw(debian/patches debian/source/options
5719 debian/tests/control)) {
5720 next unless stat_exists "$maindir/$maybe";
5721 push @files, $maybe;
5724 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5725 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5727 $dscaddfile->($debtar);
5728 close $fakedsc or die $!;
5731 sub quilt_check_splitbrain_cache ($$) {
5732 my ($headref, $upstreamversion) = @_;
5733 # Called only if we are in (potentially) split brain mode.
5734 # Called in playground.
5735 # Computes the cache key and looks in the cache.
5736 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5738 my $splitbrain_cachekey;
5741 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5742 # we look in the reflog of dgit-intern/quilt-cache
5743 # we look for an entry whose message is the key for the cache lookup
5744 my @cachekey = (qw(dgit), $our_version);
5745 push @cachekey, $upstreamversion;
5746 push @cachekey, $quilt_mode;
5747 push @cachekey, $headref;
5749 push @cachekey, hashfile('fake.dsc');
5751 my $srcshash = Digest::SHA->new(256);
5752 my %sfs = ( %INC, '$0(dgit)' => $0 );
5753 foreach my $sfk (sort keys %sfs) {
5754 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5755 $srcshash->add($sfk," ");
5756 $srcshash->add(hashfile($sfs{$sfk}));
5757 $srcshash->add("\n");
5759 push @cachekey, $srcshash->hexdigest();
5760 $splitbrain_cachekey = "@cachekey";
5762 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5764 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5765 debugcmd "|(probably)",@cmd;
5766 my $child = open GC, "-|"; defined $child or die $!;
5768 chdir $maindir or die $!;
5769 if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5770 $! == ENOENT or die $!;
5771 printdebug ">(no reflog)\n";
5778 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5779 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5782 quilt_fixup_mkwork($headref);
5783 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5784 if ($cachehit ne $headref) {
5785 progress "dgit view: found cached ($saved)";
5786 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5788 return ($cachehit, $splitbrain_cachekey);
5790 progress "dgit view: found cached, no changes required";
5791 return ($headref, $splitbrain_cachekey);
5793 die $! if GC->error;
5794 failedcmd unless close GC;
5796 printdebug "splitbrain cache miss\n";
5797 return (undef, $splitbrain_cachekey);
5800 sub quilt_fixup_multipatch ($$$) {
5801 my ($clogp, $headref, $upstreamversion) = @_;
5803 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5806 # - honour any existing .pc in case it has any strangeness
5807 # - determine the git commit corresponding to the tip of
5808 # the patch stack (if there is one)
5809 # - if there is such a git commit, convert each subsequent
5810 # git commit into a quilt patch with dpkg-source --commit
5811 # - otherwise convert all the differences in the tree into
5812 # a single git commit
5816 # Our git tree doesn't necessarily contain .pc. (Some versions of
5817 # dgit would include the .pc in the git tree.) If there isn't
5818 # one, we need to generate one by unpacking the patches that we
5821 # We first look for a .pc in the git tree. If there is one, we
5822 # will use it. (This is not the normal case.)
5824 # Otherwise need to regenerate .pc so that dpkg-source --commit
5825 # can work. We do this as follows:
5826 # 1. Collect all relevant .orig from parent directory
5827 # 2. Generate a debian.tar.gz out of
5828 # debian/{patches,rules,source/format,source/options}
5829 # 3. Generate a fake .dsc containing just these fields:
5830 # Format Source Version Files
5831 # 4. Extract the fake .dsc
5832 # Now the fake .dsc has a .pc directory.
5833 # (In fact we do this in every case, because in future we will
5834 # want to search for a good base commit for generating patches.)
5836 # Then we can actually do the dpkg-source --commit
5837 # 1. Make a new working tree with the same object
5838 # store as our main tree and check out the main
5840 # 2. Copy .pc from the fake's extraction, if necessary
5841 # 3. Run dpkg-source --commit
5842 # 4. If the result has changes to debian/, then
5843 # - git add them them
5844 # - git add .pc if we had a .pc in-tree
5846 # 5. If we had a .pc in-tree, delete it, and git commit
5847 # 6. Back in the main tree, fast forward to the new HEAD
5849 # Another situation we may have to cope with is gbp-style
5850 # patches-unapplied trees.
5852 # We would want to detect these, so we know to escape into
5853 # quilt_fixup_gbp. However, this is in general not possible.
5854 # Consider a package with a one patch which the dgit user reverts
5855 # (with git revert or the moral equivalent).
5857 # That is indistinguishable in contents from a patches-unapplied
5858 # tree. And looking at the history to distinguish them is not
5859 # useful because the user might have made a confusing-looking git
5860 # history structure (which ought to produce an error if dgit can't
5861 # cope, not a silent reintroduction of an unwanted patch).
5863 # So gbp users will have to pass an option. But we can usually
5864 # detect their failure to do so: if the tree is not a clean
5865 # patches-applied tree, quilt linearisation fails, but the tree
5866 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5867 # they want --quilt=unapplied.
5869 # To help detect this, when we are extracting the fake dsc, we
5870 # first extract it with --skip-patches, and then apply the patches
5871 # afterwards with dpkg-source --before-build. That lets us save a
5872 # tree object corresponding to .origs.
5874 my $splitbrain_cachekey;
5876 quilt_make_fake_dsc($upstreamversion);
5878 if (quiltmode_splitbrain()) {
5880 ($cachehit, $splitbrain_cachekey) =
5881 quilt_check_splitbrain_cache($headref, $upstreamversion);
5882 return if $cachehit;
5886 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5888 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5889 rename $fakexdir, "fake" or die "$fakexdir $!";
5893 remove_stray_gits("source package");
5894 mktree_in_ud_here();
5898 rmtree 'debian'; # git checkout commitish paths does not delete!
5899 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5900 my $unapplied=git_add_write_tree();
5901 printdebug "fake orig tree object $unapplied\n";
5905 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5907 if (system @bbcmd) {
5908 failedcmd @bbcmd if $? < 0;
5910 failed to apply your git tree's patch stack (from debian/patches/) to
5911 the corresponding upstream tarball(s). Your source tree and .orig
5912 are probably too inconsistent. dgit can only fix up certain kinds of
5913 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5919 quilt_fixup_mkwork($headref);
5922 if (stat_exists ".pc") {
5924 progress "Tree already contains .pc - will use it then delete it.";
5927 rename '../fake/.pc','.pc' or die $!;
5930 changedir '../fake';
5932 my $oldtiptree=git_add_write_tree();
5933 printdebug "fake o+d/p tree object $unapplied\n";
5934 changedir '../work';
5937 # We calculate some guesswork now about what kind of tree this might
5938 # be. This is mostly for error reporting.
5944 # O = orig, without patches applied
5945 # A = "applied", ie orig with H's debian/patches applied
5946 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5947 \%editedignores, \@unrepres),
5948 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5949 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5953 foreach my $b (qw(01 02)) {
5954 foreach my $v (qw(O2H O2A H2A)) {
5955 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5958 printdebug "differences \@dl @dl.\n";
5961 "$us: base trees orig=%.20s o+d/p=%.20s",
5962 $unapplied, $oldtiptree;
5964 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5965 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5966 $dl[0], $dl[1], $dl[3], $dl[4],
5970 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5972 forceable_fail [qw(unrepresentable)], <<END;
5973 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5978 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5979 push @failsuggestion, "This might be a patches-unapplied branch.";
5980 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5981 push @failsuggestion, "This might be a patches-applied branch.";
5983 push @failsuggestion, "Maybe you need to specify one of".
5984 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5986 if (quiltmode_splitbrain()) {
5987 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
5988 $diffbits, \%editedignores,
5989 $splitbrain_cachekey);
5993 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5994 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5996 if (!open P, '>>', ".pc/applied-patches") {
5997 $!==&ENOENT or die $!;
6002 commit_quilty_patch();
6004 if ($mustdeletepc) {
6005 quilt_fixup_delete_pc();
6009 sub quilt_fixup_editor () {
6010 my $descfn = $ENV{$fakeeditorenv};
6011 my $editing = $ARGV[$#ARGV];
6012 open I1, '<', $descfn or die "$descfn: $!";
6013 open I2, '<', $editing or die "$editing: $!";
6014 unlink $editing or die "$editing: $!";
6015 open O, '>', $editing or die "$editing: $!";
6016 while (<I1>) { print O or die $!; } I1->error and die $!;
6019 $copying ||= m/^\-\-\- /;
6020 next unless $copying;
6023 I2->error and die $!;
6028 sub maybe_apply_patches_dirtily () {
6029 return unless $quilt_mode =~ m/gbp|unapplied/;
6030 print STDERR <<END or die $!;
6032 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6033 dgit: Have to apply the patches - making the tree dirty.
6034 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6037 $patches_applied_dirtily = 01;
6038 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6039 runcmd qw(dpkg-source --before-build .);
6042 sub maybe_unapply_patches_again () {
6043 progress "dgit: Unapplying patches again to tidy up the tree."
6044 if $patches_applied_dirtily;
6045 runcmd qw(dpkg-source --after-build .)
6046 if $patches_applied_dirtily & 01;
6048 if $patches_applied_dirtily & 02;
6049 $patches_applied_dirtily = 0;
6052 #----- other building -----
6054 our $clean_using_builder;
6055 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6056 # clean the tree before building (perhaps invoked indirectly by
6057 # whatever we are using to run the build), rather than separately
6058 # and explicitly by us.
6061 return if $clean_using_builder;
6062 if ($cleanmode eq 'dpkg-source') {
6063 maybe_apply_patches_dirtily();
6064 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6065 } elsif ($cleanmode eq 'dpkg-source-d') {
6066 maybe_apply_patches_dirtily();
6067 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6068 } elsif ($cleanmode eq 'git') {
6069 runcmd_ordryrun_local @git, qw(clean -xdf);
6070 } elsif ($cleanmode eq 'git-ff') {
6071 runcmd_ordryrun_local @git, qw(clean -xdff);
6072 } elsif ($cleanmode eq 'check') {
6073 my $leftovers = cmdoutput @git, qw(clean -xdn);
6074 if (length $leftovers) {
6075 print STDERR $leftovers, "\n" or die $!;
6076 fail "tree contains uncommitted files and --clean=check specified";
6078 } elsif ($cleanmode eq 'none') {
6085 badusage "clean takes no additional arguments" if @ARGV;
6088 maybe_unapply_patches_again();
6091 sub build_or_push_prep_early () {
6092 our $build_or_push_prep_early_done //= 0;
6093 return if $build_or_push_prep_early_done++;
6094 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6095 my $clogp = parsechangelog();
6096 $isuite = getfield $clogp, 'Distribution';
6097 $package = getfield $clogp, 'Source';
6098 $version = getfield $clogp, 'Version';
6101 sub build_prep_early () {
6102 build_or_push_prep_early();
6110 build_maybe_quilt_fixup();
6112 my $pat = changespat $version;
6113 foreach my $f (glob "$buildproductsdir/$pat") {
6115 unlink $f or fail "remove old changes file $f: $!";
6117 progress "would remove $f";
6123 sub changesopts_initial () {
6124 my @opts =@changesopts[1..$#changesopts];
6127 sub changesopts_version () {
6128 if (!defined $changes_since_version) {
6131 @vsns = archive_query('archive_query');
6132 my @quirk = access_quirk();
6133 if ($quirk[0] eq 'backports') {
6134 local $isuite = $quirk[2];
6136 canonicalise_suite();
6137 push @vsns, archive_query('archive_query');
6143 "archive query failed (queried because --since-version not specified)";
6146 @vsns = map { $_->[0] } @vsns;
6147 @vsns = sort { -version_compare($a, $b) } @vsns;
6148 $changes_since_version = $vsns[0];
6149 progress "changelog will contain changes since $vsns[0]";
6151 $changes_since_version = '_';
6152 progress "package seems new, not specifying -v<version>";
6155 if ($changes_since_version ne '_') {
6156 return ("-v$changes_since_version");
6162 sub changesopts () {
6163 return (changesopts_initial(), changesopts_version());
6166 sub massage_dbp_args ($;$) {
6167 my ($cmd,$xargs) = @_;
6170 # - if we're going to split the source build out so we can
6171 # do strange things to it, massage the arguments to dpkg-buildpackage
6172 # so that the main build doessn't build source (or add an argument
6173 # to stop it building source by default).
6175 # - add -nc to stop dpkg-source cleaning the source tree,
6176 # unless we're not doing a split build and want dpkg-source
6177 # as cleanmode, in which case we can do nothing
6180 # 0 - source will NOT need to be built separately by caller
6181 # +1 - source will need to be built separately by caller
6182 # +2 - source will need to be built separately by caller AND
6183 # dpkg-buildpackage should not in fact be run at all!
6184 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6185 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
6186 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
6187 $clean_using_builder = 1;
6190 # -nc has the side effect of specifying -b if nothing else specified
6191 # and some combinations of -S, -b, et al, are errors, rather than
6192 # later simply overriding earlie. So we need to:
6193 # - search the command line for these options
6194 # - pick the last one
6195 # - perhaps add our own as a default
6196 # - perhaps adjust it to the corresponding non-source-building version
6198 foreach my $l ($cmd, $xargs) {
6200 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6203 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6205 if ($need_split_build_invocation) {
6206 printdebug "massage split $dmode.\n";
6207 $r = $dmode =~ m/[S]/ ? +2 :
6208 $dmode =~ y/gGF/ABb/ ? +1 :
6209 $dmode =~ m/[ABb]/ ? 0 :
6212 printdebug "massage done $r $dmode.\n";
6214 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6220 my $wasdir = must_getcwd();
6226 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
6227 my ($msg_if_onlyone) = @_;
6228 # If there is only one .changes file, fail with $msg_if_onlyone,
6229 # or if that is undef, be a no-op.
6230 # Returns the changes file to report to the user.
6231 my $pat = changespat $version;
6232 my @changesfiles = glob $pat;
6233 @changesfiles = sort {
6234 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6238 if (@changesfiles==1) {
6239 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6240 only one changes file from build (@changesfiles)
6242 $result = $changesfiles[0];
6243 } elsif (@changesfiles==2) {
6244 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6245 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6246 fail "$l found in binaries changes file $binchanges"
6249 runcmd_ordryrun_local @mergechanges, @changesfiles;
6250 my $multichanges = changespat $version,'multi';
6252 stat_exists $multichanges or fail "$multichanges: $!";
6253 foreach my $cf (glob $pat) {
6254 next if $cf eq $multichanges;
6255 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6258 $result = $multichanges;
6260 fail "wrong number of different changes files (@changesfiles)";
6262 printdone "build successful, results in $result\n" or die $!;
6265 sub midbuild_checkchanges () {
6266 my $pat = changespat $version;
6267 return if $rmchanges;
6268 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
6269 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
6271 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6272 Suggest you delete @unwanted.
6277 sub midbuild_checkchanges_vanilla ($) {
6279 midbuild_checkchanges() if $wantsrc == 1;
6282 sub postbuild_mergechanges_vanilla ($) {
6284 if ($wantsrc == 1) {
6286 postbuild_mergechanges(undef);
6289 printdone "build successful\n";
6295 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6296 my $wantsrc = massage_dbp_args \@dbp;
6299 midbuild_checkchanges_vanilla $wantsrc;
6304 push @dbp, changesopts_version();
6305 maybe_apply_patches_dirtily();
6306 runcmd_ordryrun_local @dbp;
6308 maybe_unapply_patches_again();
6309 postbuild_mergechanges_vanilla $wantsrc;
6313 $quilt_mode //= 'gbp';
6319 # gbp can make .origs out of thin air. In my tests it does this
6320 # even for a 1.0 format package, with no origs present. So I
6321 # guess it keys off just the version number. We don't know
6322 # exactly what .origs ought to exist, but let's assume that we
6323 # should run gbp if: the version has an upstream part and the main
6325 my $upstreamversion = upstreamversion $version;
6326 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6327 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6329 if ($gbp_make_orig) {
6331 $cleanmode = 'none'; # don't do it again
6332 $need_split_build_invocation = 1;
6335 my @dbp = @dpkgbuildpackage;
6337 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6339 if (!length $gbp_build[0]) {
6340 if (length executable_on_path('git-buildpackage')) {
6341 $gbp_build[0] = qw(git-buildpackage);
6343 $gbp_build[0] = 'gbp buildpackage';
6346 my @cmd = opts_opt_multi_cmd @gbp_build;
6348 push @cmd, (qw(-us -uc --git-no-sign-tags),
6349 "--git-builder=".(shellquote @dbp));
6351 if ($gbp_make_orig) {
6352 my $priv = dgit_privdir();
6353 my $ok = "$priv/origs-gen-ok";
6354 unlink $ok or $!==&ENOENT or die $!;
6355 my @origs_cmd = @cmd;
6356 push @origs_cmd, qw(--git-cleaner=true);
6357 push @origs_cmd, "--git-prebuild=".
6358 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6359 push @origs_cmd, @ARGV;
6361 debugcmd @origs_cmd;
6363 do { local $!; stat_exists $ok; }
6364 or failedcmd @origs_cmd;
6366 dryrun_report @origs_cmd;
6372 midbuild_checkchanges_vanilla $wantsrc;
6374 if (!$clean_using_builder) {
6375 push @cmd, '--git-cleaner=true';
6379 maybe_unapply_patches_again();
6381 push @cmd, changesopts();
6382 runcmd_ordryrun_local @cmd, @ARGV;
6384 postbuild_mergechanges_vanilla $wantsrc;
6386 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6388 sub build_source_for_push {
6390 maybe_unapply_patches_again();
6391 $changesfile = $sourcechanges;
6397 $sourcechanges = changespat $version,'source';
6399 unlink "../$sourcechanges" or $!==ENOENT
6400 or fail "remove $sourcechanges: $!";
6402 $dscfn = dscfn($version);
6403 my @cmd = (@dpkgsource, qw(-b --));
6405 changedir $playground;
6406 runcmd_ordryrun_local @cmd, "work";
6407 my @udfiles = <${package}_*>;
6409 foreach my $f (@udfiles) {
6410 printdebug "source copy, found $f\n";
6413 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6414 $f eq srcfn($version, $&));
6415 printdebug "source copy, found $f - renaming\n";
6416 rename "$playground/$f", "../$f" or $!==ENOENT
6417 or fail "put in place new source file ($f): $!";
6420 my $pwd = must_getcwd();
6421 my $leafdir = basename $pwd;
6423 runcmd_ordryrun_local @cmd, $leafdir;
6426 runcmd_ordryrun_local qw(sh -ec),
6427 'exec >$1; shift; exec "$@"','x',
6428 "../$sourcechanges",
6429 @dpkggenchanges, qw(-S), changesopts();
6432 sub cmd_build_source {
6434 badusage "build-source takes no additional arguments" if @ARGV;
6436 maybe_unapply_patches_again();
6437 printdone "source built, results in $dscfn and $sourcechanges";
6442 midbuild_checkchanges();
6445 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6446 stat_exists $sourcechanges
6447 or fail "$sourcechanges (in parent directory): $!";
6449 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6451 maybe_unapply_patches_again();
6453 postbuild_mergechanges(<<END);
6454 perhaps you need to pass -A ? (sbuild's default is to build only
6455 arch-specific binaries; dgit 1.4 used to override that.)
6460 sub cmd_quilt_fixup {
6461 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6464 build_maybe_quilt_fixup();
6467 sub import_dsc_result {
6468 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6469 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6471 check_gitattrs($newhash, "source tree");
6473 progress "dgit: import-dsc: $what_msg";
6476 sub cmd_import_dsc {
6480 last unless $ARGV[0] =~ m/^-/;
6483 if (m/^--require-valid-signature$/) {
6486 badusage "unknown dgit import-dsc sub-option \`$_'";
6490 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6491 my ($dscfn, $dstbranch) = @ARGV;
6493 badusage "dry run makes no sense with import-dsc" unless act_local();
6495 my $force = $dstbranch =~ s/^\+// ? +1 :
6496 $dstbranch =~ s/^\.\.// ? -1 :
6498 my $info = $force ? " $&" : '';
6499 $info = "$dscfn$info";
6501 my $specbranch = $dstbranch;
6502 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6503 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6505 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6506 my $chead = cmdoutput_errok @symcmd;
6507 defined $chead or $?==256 or failedcmd @symcmd;
6509 fail "$dstbranch is checked out - will not update it"
6510 if defined $chead and $chead eq $dstbranch;
6512 my $oldhash = git_get_ref $dstbranch;
6514 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6515 $dscdata = do { local $/ = undef; <D>; };
6516 D->error and fail "read $dscfn: $!";
6519 # we don't normally need this so import it here
6520 use Dpkg::Source::Package;
6521 my $dp = new Dpkg::Source::Package filename => $dscfn,
6522 require_valid_signature => $needsig;
6524 local $SIG{__WARN__} = sub {
6526 return unless $needsig;
6527 fail "import-dsc signature check failed";
6529 if (!$dp->is_signed()) {
6530 warn "$us: warning: importing unsigned .dsc\n";
6532 my $r = $dp->check_signature();
6533 die "->check_signature => $r" if $needsig && $r;
6539 $package = getfield $dsc, 'Source';
6541 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6542 unless forceing [qw(import-dsc-with-dgit-field)];
6543 parse_dsc_field_def_dsc_distro();
6545 $isuite = 'DGIT-IMPORT-DSC';
6546 $idistro //= $dsc_distro;
6550 if (defined $dsc_hash) {
6551 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6552 resolve_dsc_field_commit undef, undef;
6554 if (defined $dsc_hash) {
6555 my @cmd = (qw(sh -ec),
6556 "echo $dsc_hash | git cat-file --batch-check");
6557 my $objgot = cmdoutput @cmd;
6558 if ($objgot =~ m#^\w+ missing\b#) {
6560 .dsc contains Dgit field referring to object $dsc_hash
6561 Your git tree does not have that object. Try `git fetch' from a
6562 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6565 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6567 progress "Not fast forward, forced update.";
6569 fail "Not fast forward to $dsc_hash";
6572 import_dsc_result $dstbranch, $dsc_hash,
6573 "dgit import-dsc (Dgit): $info",
6574 "updated git ref $dstbranch";
6579 Branch $dstbranch already exists
6580 Specify ..$specbranch for a pseudo-merge, binding in existing history
6581 Specify +$specbranch to overwrite, discarding existing history
6583 if $oldhash && !$force;
6585 my @dfi = dsc_files_info();
6586 foreach my $fi (@dfi) {
6587 my $f = $fi->{Filename};
6591 fail "lstat $here works but stat gives $! !";
6593 fail "stat $here: $!" unless $! == ENOENT;
6595 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6597 } elsif ($dscfn =~ m#^/#) {
6600 fail "cannot import $dscfn which seems to be inside working tree!";
6602 $there =~ s#/+[^/]+$## or
6603 fail "import $dscfn requires ../$f, but it does not exist";
6605 my $test = $there =~ m{^/} ? $there : "../$there";
6606 stat $test or fail "import $dscfn requires $test, but: $!";
6607 symlink $there, $here or fail "symlink $there to $here: $!";
6608 progress "made symlink $here -> $there";
6609 # print STDERR Dumper($fi);
6611 my @mergeinputs = generate_commits_from_dsc();
6612 die unless @mergeinputs == 1;
6614 my $newhash = $mergeinputs[0]{Commit};
6618 progress "Import, forced update - synthetic orphan git history.";
6619 } elsif ($force < 0) {
6620 progress "Import, merging.";
6621 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6622 my $version = getfield $dsc, 'Version';
6623 my $clogp = commit_getclogp $newhash;
6624 my $authline = clogp_authline $clogp;
6625 $newhash = make_commit_text <<END;
6632 Merge $package ($version) import into $dstbranch
6635 die; # caught earlier
6639 import_dsc_result $dstbranch, $newhash,
6640 "dgit import-dsc: $info",
6641 "results are in in git ref $dstbranch";
6644 sub pre_archive_api_query () {
6645 not_necessarily_a_tree();
6647 sub cmd_archive_api_query {
6648 badusage "need only 1 subpath argument" unless @ARGV==1;
6649 my ($subpath) = @ARGV;
6650 local $isuite = 'DGIT-API-QUERY-CMD';
6651 my @cmd = archive_api_query_cmd($subpath);
6654 exec @cmd or fail "exec curl: $!\n";
6657 sub repos_server_url () {
6658 $package = '_dgit-repos-server';
6659 local $access_forpush = 1;
6660 local $isuite = 'DGIT-REPOS-SERVER';
6661 my $url = access_giturl();
6664 sub pre_clone_dgit_repos_server () {
6665 not_necessarily_a_tree();
6667 sub cmd_clone_dgit_repos_server {
6668 badusage "need destination argument" unless @ARGV==1;
6669 my ($destdir) = @ARGV;
6670 my $url = repos_server_url();
6671 my @cmd = (@git, qw(clone), $url, $destdir);
6673 exec @cmd or fail "exec git clone: $!\n";
6676 sub pre_print_dgit_repos_server_source_url () {
6677 not_necessarily_a_tree();
6679 sub cmd_print_dgit_repos_server_source_url {
6680 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6682 my $url = repos_server_url();
6683 print $url, "\n" or die $!;
6686 sub pre_print_dpkg_source_ignores {
6687 not_necessarily_a_tree();
6689 sub cmd_print_dpkg_source_ignores {
6690 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6692 print "@dpkg_source_ignores\n" or die $!;
6695 sub cmd_setup_mergechangelogs {
6696 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6697 local $isuite = 'DGIT-SETUP-TREE';
6698 setup_mergechangelogs(1);
6701 sub cmd_setup_useremail {
6702 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6703 local $isuite = 'DGIT-SETUP-TREE';
6707 sub cmd_setup_gitattributes {
6708 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6709 local $isuite = 'DGIT-SETUP-TREE';
6713 sub cmd_setup_new_tree {
6714 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6715 local $isuite = 'DGIT-SETUP-TREE';
6719 #---------- argument parsing and main program ----------
6722 print "dgit version $our_version\n" or die $!;
6726 our (%valopts_long, %valopts_short);
6727 our (%funcopts_long);
6729 our (@modeopt_cfgs);
6731 sub defvalopt ($$$$) {
6732 my ($long,$short,$val_re,$how) = @_;
6733 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6734 $valopts_long{$long} = $oi;
6735 $valopts_short{$short} = $oi;
6736 # $how subref should:
6737 # do whatever assignemnt or thing it likes with $_[0]
6738 # if the option should not be passed on to remote, @rvalopts=()
6739 # or $how can be a scalar ref, meaning simply assign the value
6742 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6743 defvalopt '--distro', '-d', '.+', \$idistro;
6744 defvalopt '', '-k', '.+', \$keyid;
6745 defvalopt '--existing-package','', '.*', \$existing_package;
6746 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6747 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6748 defvalopt '--package', '-p', $package_re, \$package;
6749 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6751 defvalopt '', '-C', '.+', sub {
6752 ($changesfile) = (@_);
6753 if ($changesfile =~ s#^(.*)/##) {
6754 $buildproductsdir = $1;
6758 defvalopt '--initiator-tempdir','','.*', sub {
6759 ($initiator_tempdir) = (@_);
6760 $initiator_tempdir =~ m#^/# or
6761 badusage "--initiator-tempdir must be used specify an".
6762 " absolute, not relative, directory."
6765 sub defoptmodes ($@) {
6766 my ($varref, $cfgkey, $default, %optmap) = @_;
6768 while (my ($opt,$val) = each %optmap) {
6769 $funcopts_long{$opt} = sub { $$varref = $val; };
6770 $permit{$val} = $val;
6772 push @modeopt_cfgs, {
6775 Default => $default,
6780 defoptmodes \$dodep14tag, qw( dep14tag want
6783 --always-dep14tag always );
6788 if (defined $ENV{'DGIT_SSH'}) {
6789 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6790 } elsif (defined $ENV{'GIT_SSH'}) {
6791 @ssh = ($ENV{'GIT_SSH'});
6799 if (!defined $val) {
6800 badusage "$what needs a value" unless @ARGV;
6802 push @rvalopts, $val;
6804 badusage "bad value \`$val' for $what" unless
6805 $val =~ m/^$oi->{Re}$(?!\n)/s;
6806 my $how = $oi->{How};
6807 if (ref($how) eq 'SCALAR') {
6812 push @ropts, @rvalopts;
6816 last unless $ARGV[0] =~ m/^-/;
6820 if (m/^--dry-run$/) {
6823 } elsif (m/^--damp-run$/) {
6826 } elsif (m/^--no-sign$/) {
6829 } elsif (m/^--help$/) {
6831 } elsif (m/^--version$/) {
6833 } elsif (m/^--new$/) {
6836 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6837 ($om = $opts_opt_map{$1}) &&
6841 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6842 !$opts_opt_cmdonly{$1} &&
6843 ($om = $opts_opt_map{$1})) {
6846 } elsif (m/^--(gbp|dpm)$/s) {
6847 push @ropts, "--quilt=$1";
6849 } elsif (m/^--ignore-dirty$/s) {
6852 } elsif (m/^--no-quilt-fixup$/s) {
6854 $quilt_mode = 'nocheck';
6855 } elsif (m/^--no-rm-on-error$/s) {
6858 } elsif (m/^--no-chase-dsc-distro$/s) {
6860 $chase_dsc_distro = 0;
6861 } elsif (m/^--overwrite$/s) {
6863 $overwrite_version = '';
6864 } elsif (m/^--overwrite=(.+)$/s) {
6866 $overwrite_version = $1;
6867 } elsif (m/^--delayed=(\d+)$/s) {
6870 } elsif (m/^--dgit-view-save=(.+)$/s) {
6872 $split_brain_save = $1;
6873 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6874 } elsif (m/^--(no-)?rm-old-changes$/s) {
6877 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6879 push @deliberatelies, $&;
6880 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6884 } elsif (m/^--force-/) {
6886 "$us: warning: ignoring unknown force option $_\n";
6888 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6889 # undocumented, for testing
6891 $tagformat_want = [ $1, 'command line', 1 ];
6892 # 1 menas overrides distro configuration
6893 } elsif (m/^--always-split-source-build$/s) {
6894 # undocumented, for testing
6896 $need_split_build_invocation = 1;
6897 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6898 # undocumented, for testing
6900 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6901 # ^ it's supposed to be an array ref
6902 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6903 $val = $2 ? $' : undef; #';
6904 $valopt->($oi->{Long});
6905 } elsif ($funcopts_long{$_}) {
6907 $funcopts_long{$_}();
6909 badusage "unknown long option \`$_'";
6916 } elsif (s/^-L/-/) {
6919 } elsif (s/^-h/-/) {
6921 } elsif (s/^-D/-/) {
6925 } elsif (s/^-N/-/) {
6930 push @changesopts, $_;
6932 } elsif (s/^-wn$//s) {
6934 $cleanmode = 'none';
6935 } elsif (s/^-wg$//s) {
6938 } elsif (s/^-wgf$//s) {
6940 $cleanmode = 'git-ff';
6941 } elsif (s/^-wd$//s) {
6943 $cleanmode = 'dpkg-source';
6944 } elsif (s/^-wdd$//s) {
6946 $cleanmode = 'dpkg-source-d';
6947 } elsif (s/^-wc$//s) {
6949 $cleanmode = 'check';
6950 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6951 push @git, '-c', $&;
6952 $gitcfgs{cmdline}{$1} = [ $2 ];
6953 } elsif (s/^-c([^=]+)$//s) {
6954 push @git, '-c', $&;
6955 $gitcfgs{cmdline}{$1} = [ 'true' ];
6956 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6958 $val = undef unless length $val;
6959 $valopt->($oi->{Short});
6962 badusage "unknown short option \`$_'";
6969 sub check_env_sanity () {
6970 my $blocked = new POSIX::SigSet;
6971 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6974 foreach my $name (qw(PIPE CHLD)) {
6975 my $signame = "SIG$name";
6976 my $signum = eval "POSIX::$signame" // die;
6977 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6978 die "$signame is set to something other than SIG_DFL\n";
6979 $blocked->ismember($signum) and
6980 die "$signame is blocked\n";
6986 On entry to dgit, $@
6987 This is a bug produced by something in in your execution environment.
6993 sub parseopts_late_defaults () {
6994 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6995 if defined $idistro;
6996 $isuite //= cfg('dgit.default.default-suite');
6998 foreach my $k (keys %opts_opt_map) {
6999 my $om = $opts_opt_map{$k};
7001 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7003 badcfg "cannot set command for $k"
7004 unless length $om->[0];
7008 foreach my $c (access_cfg_cfgs("opts-$k")) {
7010 map { $_ ? @$_ : () }
7011 map { $gitcfgs{$_}{$c} }
7012 reverse @gitcfgsources;
7013 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7014 "\n" if $debuglevel >= 4;
7016 badcfg "cannot configure options for $k"
7017 if $opts_opt_cmdonly{$k};
7018 my $insertpos = $opts_cfg_insertpos{$k};
7019 @$om = ( @$om[0..$insertpos-1],
7021 @$om[$insertpos..$#$om] );
7025 if (!defined $rmchanges) {
7026 local $access_forpush;
7027 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7030 if (!defined $quilt_mode) {
7031 local $access_forpush;
7032 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7033 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7035 $quilt_mode =~ m/^($quilt_modes_re)$/
7036 or badcfg "unknown quilt-mode \`$quilt_mode'";
7040 foreach my $moc (@modeopt_cfgs) {
7041 local $access_forpush;
7042 my $vr = $moc->{Var};
7043 next if defined $$vr;
7044 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7045 my $v = $moc->{Vals}{$$vr};
7046 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7050 $need_split_build_invocation ||= quiltmode_splitbrain();
7052 if (!defined $cleanmode) {
7053 local $access_forpush;
7054 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7055 $cleanmode //= 'dpkg-source';
7057 badcfg "unknown clean-mode \`$cleanmode'" unless
7058 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7062 if ($ENV{$fakeeditorenv}) {
7064 quilt_fixup_editor();
7070 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7071 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7072 if $dryrun_level == 1;
7074 print STDERR $helpmsg or die $!;
7077 $cmd = $subcommand = shift @ARGV;
7080 my $pre_fn = ${*::}{"pre_$cmd"};
7081 $pre_fn->() if $pre_fn;
7083 record_maindir if $invoked_in_git_tree;
7086 my $fn = ${*::}{"cmd_$cmd"};
7087 $fn or badusage "unknown operation $cmd";