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;
69 our $includedirty = 0;
73 our $existing_package = 'dpkg';
75 our $changes_since_version;
77 our $overwrite_version; # undef: not specified; '': check changelog
79 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
81 our $split_brain_save;
82 our $we_are_responder;
83 our $we_are_initiator;
84 our $initiator_tempdir;
85 our $patches_applied_dirtily = 00;
89 our $chase_dsc_distro=1;
91 our %forceopts = map { $_=>0 }
92 qw(unrepresentable unsupported-source-format
93 dsc-changes-mismatch changes-origs-exactly
94 uploading-binaries uploading-source-only
95 import-gitapply-absurd
96 import-gitapply-no-absurd
97 import-dsc-with-dgit-field);
99 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
101 our $suite_re = '[-+.0-9a-z]+';
102 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
103 our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
104 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
105 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
107 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
108 our $splitbraincache = 'dgit-intern/quilt-cache';
109 our $rewritemap = 'dgit-rewrite/map';
111 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
113 our (@git) = qw(git);
114 our (@dget) = qw(dget);
115 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
116 our (@dput) = qw(dput);
117 our (@debsign) = qw(debsign);
118 our (@gpg) = qw(gpg);
119 our (@sbuild) = qw(sbuild);
121 our (@dgit) = qw(dgit);
122 our (@git_debrebase) = qw(git-debrebase);
123 our (@aptget) = qw(apt-get);
124 our (@aptcache) = qw(apt-cache);
125 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
126 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
127 our (@dpkggenchanges) = qw(dpkg-genchanges);
128 our (@mergechanges) = qw(mergechanges -f);
129 our (@gbp_build) = ('');
130 our (@gbp_pq) = ('gbp pq');
131 our (@changesopts) = ('');
133 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
136 'debsign' => \@debsign,
138 'sbuild' => \@sbuild,
142 'git-debrebase' => \@git_debrebase,
143 'apt-get' => \@aptget,
144 'apt-cache' => \@aptcache,
145 'dpkg-source' => \@dpkgsource,
146 'dpkg-buildpackage' => \@dpkgbuildpackage,
147 'dpkg-genchanges' => \@dpkggenchanges,
148 'gbp-build' => \@gbp_build,
149 'gbp-pq' => \@gbp_pq,
150 'ch' => \@changesopts,
151 'mergechanges' => \@mergechanges);
153 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
154 our %opts_cfg_insertpos = map {
156 scalar @{ $opts_opt_map{$_} }
157 } keys %opts_opt_map;
159 sub parseopts_late_defaults();
160 sub setup_gitattrs(;$);
161 sub check_gitattrs($$);
168 our $supplementary_message = '';
169 our $need_split_build_invocation = 1;
170 our $split_brain = 0;
174 return unless forkcheck_mainprocess();
175 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
178 our $remotename = 'dgit';
179 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
183 if (!defined $absurdity) {
185 $absurdity =~ s{/[^/]+$}{/absurd} or die;
189 my ($v,$distro) = @_;
190 return $tagformatfn->($v, $distro);
193 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
195 sub lbranch () { return "$branchprefix/$csuite"; }
196 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
197 sub lref () { return "refs/heads/".lbranch(); }
198 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
199 sub rrref () { return server_ref($csuite); }
209 return "${package}_".(stripepoch $vsn).$sfx
214 return srcfn($vsn,".dsc");
217 sub changespat ($;$) {
218 my ($vsn, $arch) = @_;
219 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
222 sub upstreamversion ($) {
234 return unless forkcheck_mainprocess();
235 foreach my $f (@end) {
237 print STDERR "$us: cleanup: $@" if length $@;
241 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
243 sub forceable_fail ($$) {
244 my ($forceoptsl, $msg) = @_;
245 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
246 print STDERR "warning: overriding problem due to --force:\n". $msg;
250 my ($forceoptsl) = @_;
251 my @got = grep { $forceopts{$_} } @$forceoptsl;
252 return 0 unless @got;
254 "warning: skipping checks or functionality due to --force-$got[0]\n";
257 sub no_such_package () {
258 print STDERR "$us: package $package does not exist in suite $isuite\n";
262 sub deliberately ($) {
264 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
267 sub deliberately_not_fast_forward () {
268 foreach (qw(not-fast-forward fresh-repo)) {
269 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
273 sub quiltmode_splitbrain () {
274 $quilt_mode =~ m/gbp|dpm|unapplied/;
277 sub opts_opt_multi_cmd {
279 push @cmd, split /\s+/, shift @_;
285 return opts_opt_multi_cmd @gbp_pq;
288 sub dgit_privdir () {
289 our $dgit_privdir_made //= ensure_a_playground 'dgit';
293 my $r = $buildproductsdir;
294 $r = "$maindir/$r" unless $r =~ m{^/};
298 sub branch_gdr_info ($$) {
299 my ($symref, $head) = @_;
300 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
301 gdr_ffq_prev_branchinfo($symref);
302 return () unless $status eq 'branch';
303 $ffq_prev = git_get_ref $ffq_prev;
304 $gdrlast = git_get_ref $gdrlast;
305 $gdrlast &&= is_fast_fwd $gdrlast, $head;
306 return ($ffq_prev, $gdrlast);
309 sub branch_is_gdr ($$) {
310 my ($symref, $head) = @_;
311 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
312 return 0 unless $ffq_prev || $gdrlast;
316 sub branch_is_gdr_unstitched_ff ($$$) {
317 my ($symref, $head, $ancestor) = @_;
318 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
319 return 0 unless $ffq_prev;
320 return 0 unless is_fast_fwd $ancestor, $ffq_prev;
324 #---------- remote protocol support, common ----------
326 # remote push initiator/responder protocol:
327 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
328 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
329 # < dgit-remote-push-ready <actual-proto-vsn>
336 # > supplementary-message NBYTES # $protovsn >= 3
341 # > file parsed-changelog
342 # [indicates that output of dpkg-parsechangelog follows]
343 # > data-block NBYTES
344 # > [NBYTES bytes of data (no newline)]
345 # [maybe some more blocks]
354 # > param head DGIT-VIEW-HEAD
355 # > param csuite SUITE
356 # > param tagformat old|new
357 # > param maint-view MAINT-VIEW-HEAD
359 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
360 # > file buildinfo # for buildinfos to sign
362 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
363 # # goes into tag, for replay prevention
366 # [indicates that signed tag is wanted]
367 # < data-block NBYTES
368 # < [NBYTES bytes of data (no newline)]
369 # [maybe some more blocks]
373 # > want signed-dsc-changes
374 # < data-block NBYTES [transfer of signed dsc]
376 # < data-block NBYTES [transfer of signed changes]
378 # < data-block NBYTES [transfer of each signed buildinfo
379 # [etc] same number and order as "file buildinfo"]
387 sub i_child_report () {
388 # Sees if our child has died, and reap it if so. Returns a string
389 # describing how it died if it failed, or undef otherwise.
390 return undef unless $i_child_pid;
391 my $got = waitpid $i_child_pid, WNOHANG;
392 return undef if $got <= 0;
393 die unless $got == $i_child_pid;
394 $i_child_pid = undef;
395 return undef unless $?;
396 return "build host child ".waitstatusmsg();
401 fail "connection lost: $!" if $fh->error;
402 fail "protocol violation; $m not expected";
405 sub badproto_badread ($$) {
407 fail "connection lost: $!" if $!;
408 my $report = i_child_report();
409 fail $report if defined $report;
410 badproto $fh, "eof (reading $wh)";
413 sub protocol_expect (&$) {
414 my ($match, $fh) = @_;
417 defined && chomp or badproto_badread $fh, "protocol message";
425 badproto $fh, "\`$_'";
428 sub protocol_send_file ($$) {
429 my ($fh, $ourfn) = @_;
430 open PF, "<", $ourfn or die "$ourfn: $!";
433 my $got = read PF, $d, 65536;
434 die "$ourfn: $!" unless defined $got;
436 print $fh "data-block ".length($d)."\n" or die $!;
437 print $fh $d or die $!;
439 PF->error and die "$ourfn $!";
440 print $fh "data-end\n" or die $!;
444 sub protocol_read_bytes ($$) {
445 my ($fh, $nbytes) = @_;
446 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
448 my $got = read $fh, $d, $nbytes;
449 $got==$nbytes or badproto_badread $fh, "data block";
453 sub protocol_receive_file ($$) {
454 my ($fh, $ourfn) = @_;
455 printdebug "() $ourfn\n";
456 open PF, ">", $ourfn or die "$ourfn: $!";
458 my ($y,$l) = protocol_expect {
459 m/^data-block (.*)$/ ? (1,$1) :
460 m/^data-end$/ ? (0,) :
464 my $d = protocol_read_bytes $fh, $l;
465 print PF $d or die $!;
470 #---------- remote protocol support, responder ----------
472 sub responder_send_command ($) {
474 return unless $we_are_responder;
475 # called even without $we_are_responder
476 printdebug ">> $command\n";
477 print PO $command, "\n" or die $!;
480 sub responder_send_file ($$) {
481 my ($keyword, $ourfn) = @_;
482 return unless $we_are_responder;
483 printdebug "]] $keyword $ourfn\n";
484 responder_send_command "file $keyword";
485 protocol_send_file \*PO, $ourfn;
488 sub responder_receive_files ($@) {
489 my ($keyword, @ourfns) = @_;
490 die unless $we_are_responder;
491 printdebug "[[ $keyword @ourfns\n";
492 responder_send_command "want $keyword";
493 foreach my $fn (@ourfns) {
494 protocol_receive_file \*PI, $fn;
497 protocol_expect { m/^files-end$/ } \*PI;
500 #---------- remote protocol support, initiator ----------
502 sub initiator_expect (&) {
504 protocol_expect { &$match } \*RO;
507 #---------- end remote code ----------
510 if ($we_are_responder) {
512 responder_send_command "progress ".length($m) or die $!;
513 print PO $m or die $!;
523 $ua = LWP::UserAgent->new();
527 progress "downloading $what...";
528 my $r = $ua->get(@_) or die $!;
529 return undef if $r->code == 404;
530 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
531 return $r->decoded_content(charset => 'none');
534 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
536 sub act_local () { return $dryrun_level <= 1; }
537 sub act_scary () { return !$dryrun_level; }
540 if (!$dryrun_level) {
541 progress "$us ok: @_";
543 progress "would be ok: @_ (but dry run only)";
548 printcmd(\*STDERR,$debugprefix."#",@_);
551 sub runcmd_ordryrun {
559 sub runcmd_ordryrun_local {
567 our $helpmsg = <<END;
569 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
570 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
571 dgit [dgit-opts] build [dpkg-buildpackage-opts]
572 dgit [dgit-opts] sbuild [sbuild-opts]
573 dgit [dgit-opts] push [dgit-opts] [suite]
574 dgit [dgit-opts] push-source [dgit-opts] [suite]
575 dgit [dgit-opts] rpush build-host:build-dir ...
576 important dgit options:
577 -k<keyid> sign tag and package with <keyid> instead of default
578 --dry-run -n do not change anything, but go through the motions
579 --damp-run -L like --dry-run but make local changes, without signing
580 --new -N allow introducing a new package
581 --debug -D increase debug level
582 -c<name>=<value> set git config option (used directly by dgit too)
585 our $later_warning_msg = <<END;
586 Perhaps the upload is stuck in incoming. Using the version from git.
590 print STDERR "$us: @_\n", $helpmsg or die $!;
595 @ARGV or badusage "too few arguments";
596 return scalar shift @ARGV;
600 not_necessarily_a_tree();
603 print $helpmsg or die $!;
607 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
609 our %defcfg = ('dgit.default.distro' => 'debian',
610 'dgit.default.default-suite' => 'unstable',
611 'dgit.default.old-dsc-distro' => 'debian',
612 'dgit-suite.*-security.distro' => 'debian-security',
613 'dgit.default.username' => '',
614 'dgit.default.archive-query-default-component' => 'main',
615 'dgit.default.ssh' => 'ssh',
616 'dgit.default.archive-query' => 'madison:',
617 'dgit.default.sshpsql-dbname' => 'service=projectb',
618 'dgit.default.aptget-components' => 'main',
619 'dgit.default.dgit-tag-format' => 'new,old,maint',
620 'dgit.default.source-only-uploads' => 'ok',
621 'dgit.dsc-url-proto-ok.http' => 'true',
622 'dgit.dsc-url-proto-ok.https' => 'true',
623 'dgit.dsc-url-proto-ok.git' => 'true',
624 'dgit.vcs-git.suites', => 'sid', # ;-separated
625 'dgit.default.dsc-url-proto-ok' => 'false',
626 # old means "repo server accepts pushes with old dgit tags"
627 # new means "repo server accepts pushes with new dgit tags"
628 # maint means "repo server accepts split brain pushes"
629 # hist means "repo server may have old pushes without new tag"
630 # ("hist" is implied by "old")
631 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
632 'dgit-distro.debian.git-check' => 'url',
633 'dgit-distro.debian.git-check-suffix' => '/info/refs',
634 'dgit-distro.debian.new-private-pushers' => 't',
635 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
636 'dgit-distro.debian/push.git-url' => '',
637 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
638 'dgit-distro.debian/push.git-user-force' => 'dgit',
639 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
640 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
641 'dgit-distro.debian/push.git-create' => 'true',
642 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
643 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
644 # 'dgit-distro.debian.archive-query-tls-key',
645 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
646 # ^ this does not work because curl is broken nowadays
647 # Fixing #790093 properly will involve providing providing the key
648 # in some pacagke and maybe updating these paths.
650 # 'dgit-distro.debian.archive-query-tls-curl-args',
651 # '--ca-path=/etc/ssl/ca-debian',
652 # ^ this is a workaround but works (only) on DSA-administered machines
653 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
654 'dgit-distro.debian.git-url-suffix' => '',
655 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
656 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
657 'dgit-distro.debian-security.archive-query' => 'aptget:',
658 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
659 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
660 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
661 'dgit-distro.debian-security.nominal-distro' => 'debian',
662 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
663 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
664 'dgit-distro.ubuntu.git-check' => 'false',
665 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
666 'dgit-distro.test-dummy.ssh' => "$td/ssh",
667 'dgit-distro.test-dummy.username' => "alice",
668 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
669 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
670 'dgit-distro.test-dummy.git-url' => "$td/git",
671 'dgit-distro.test-dummy.git-host' => "git",
672 'dgit-distro.test-dummy.git-path' => "$td/git",
673 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
674 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
675 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
676 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
680 our @gitcfgsources = qw(cmdline local global system);
681 our $invoked_in_git_tree = 1;
683 sub git_slurp_config () {
684 # This algoritm is a bit subtle, but this is needed so that for
685 # options which we want to be single-valued, we allow the
686 # different config sources to override properly. See #835858.
687 foreach my $src (@gitcfgsources) {
688 next if $src eq 'cmdline';
689 # we do this ourselves since git doesn't handle it
691 $gitcfgs{$src} = git_slurp_config_src $src;
695 sub git_get_config ($) {
697 foreach my $src (@gitcfgsources) {
698 my $l = $gitcfgs{$src}{$c};
699 confess "internal error ($l $c)" if $l && !ref $l;
700 printdebug"C $c ".(defined $l ?
701 join " ", map { messagequote "'$_'" } @$l :
705 @$l==1 or badcfg "multiple values for $c".
706 " (in $src git config)" if @$l > 1;
714 return undef if $c =~ /RETURN-UNDEF/;
715 printdebug "C? $c\n" if $debuglevel >= 5;
716 my $v = git_get_config($c);
717 return $v if defined $v;
718 my $dv = $defcfg{$c};
720 printdebug "CD $c $dv\n" if $debuglevel >= 4;
724 badcfg "need value for one of: @_\n".
725 "$us: distro or suite appears not to be (properly) supported";
728 sub not_necessarily_a_tree () {
729 # needs to be called from pre_*
730 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
731 $invoked_in_git_tree = 0;
734 sub access_basedistro__noalias () {
735 if (defined $idistro) {
738 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
739 return $def if defined $def;
740 foreach my $src (@gitcfgsources, 'internal') {
741 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
743 foreach my $k (keys %$kl) {
744 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
746 next unless match_glob $dpat, $isuite;
750 return cfg("dgit.default.distro");
754 sub access_basedistro () {
755 my $noalias = access_basedistro__noalias();
756 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
757 return $canon // $noalias;
760 sub access_nomdistro () {
761 my $base = access_basedistro();
762 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
763 $r =~ m/^$distro_re$/ or badcfg
764 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
768 sub access_quirk () {
769 # returns (quirk name, distro to use instead or undef, quirk-specific info)
770 my $basedistro = access_basedistro();
771 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
773 if (defined $backports_quirk) {
774 my $re = $backports_quirk;
775 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
777 $re =~ s/\%/([-0-9a-z_]+)/
778 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
779 if ($isuite =~ m/^$re$/) {
780 return ('backports',"$basedistro-backports",$1);
783 return ('none',undef);
788 sub parse_cfg_bool ($$$) {
789 my ($what,$def,$v) = @_;
792 $v =~ m/^[ty1]/ ? 1 :
793 $v =~ m/^[fn0]/ ? 0 :
794 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
797 sub access_forpush_config () {
798 my $d = access_basedistro();
802 parse_cfg_bool('new-private-pushers', 0,
803 cfg("dgit-distro.$d.new-private-pushers",
806 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
809 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
810 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
811 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
812 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
815 sub access_forpush () {
816 $access_forpush //= access_forpush_config();
817 return $access_forpush;
821 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
822 badcfg "pushing but distro is configured readonly"
823 if access_forpush_config() eq '0';
825 $supplementary_message = <<'END' unless $we_are_responder;
826 Push failed, before we got started.
827 You can retry the push, after fixing the problem, if you like.
829 parseopts_late_defaults();
833 parseopts_late_defaults();
836 sub supplementary_message ($) {
838 if (!$we_are_responder) {
839 $supplementary_message = $msg;
841 } elsif ($protovsn >= 3) {
842 responder_send_command "supplementary-message ".length($msg)
844 print PO $msg or die $!;
848 sub access_distros () {
849 # Returns list of distros to try, in order
852 # 0. `instead of' distro name(s) we have been pointed to
853 # 1. the access_quirk distro, if any
854 # 2a. the user's specified distro, or failing that } basedistro
855 # 2b. the distro calculated from the suite }
856 my @l = access_basedistro();
858 my (undef,$quirkdistro) = access_quirk();
859 unshift @l, $quirkdistro;
860 unshift @l, $instead_distro;
861 @l = grep { defined } @l;
863 push @l, access_nomdistro();
865 if (access_forpush()) {
866 @l = map { ("$_/push", $_) } @l;
871 sub access_cfg_cfgs (@) {
874 # The nesting of these loops determines the search order. We put
875 # the key loop on the outside so that we search all the distros
876 # for each key, before going on to the next key. That means that
877 # if access_cfg is called with a more specific, and then a less
878 # specific, key, an earlier distro can override the less specific
879 # without necessarily overriding any more specific keys. (If the
880 # distro wants to override the more specific keys it can simply do
881 # so; whereas if we did the loop the other way around, it would be
882 # impossible to for an earlier distro to override a less specific
883 # key but not the more specific ones without restating the unknown
884 # values of the more specific keys.
887 # We have to deal with RETURN-UNDEF specially, so that we don't
888 # terminate the search prematurely.
890 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
893 foreach my $d (access_distros()) {
894 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
896 push @cfgs, map { "dgit.default.$_" } @realkeys;
903 my (@cfgs) = access_cfg_cfgs(@keys);
904 my $value = cfg(@cfgs);
908 sub access_cfg_bool ($$) {
909 my ($def, @keys) = @_;
910 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
913 sub string_to_ssh ($) {
915 if ($spec =~ m/\s/) {
916 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
922 sub access_cfg_ssh () {
923 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
924 if (!defined $gitssh) {
927 return string_to_ssh $gitssh;
931 sub access_runeinfo ($) {
933 return ": dgit ".access_basedistro()." $info ;";
936 sub access_someuserhost ($) {
938 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
939 defined($user) && length($user) or
940 $user = access_cfg("$some-user",'username');
941 my $host = access_cfg("$some-host");
942 return length($user) ? "$user\@$host" : $host;
945 sub access_gituserhost () {
946 return access_someuserhost('git');
949 sub access_giturl (;$) {
951 my $url = access_cfg('git-url','RETURN-UNDEF');
954 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
955 return undef unless defined $proto;
958 access_gituserhost().
959 access_cfg('git-path');
961 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
964 return "$url/$package$suffix";
967 sub commit_getclogp ($) {
968 # Returns the parsed changelog hashref for a particular commit
970 our %commit_getclogp_memo;
971 my $memo = $commit_getclogp_memo{$objid};
972 return $memo if $memo;
974 my $mclog = dgit_privdir()."clog";
975 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
976 "$objid:debian/changelog";
977 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
980 sub parse_dscdata () {
981 my $dscfh = new IO::File \$dscdata, '<' or die $!;
982 printdebug Dumper($dscdata) if $debuglevel>1;
983 $dsc = parsecontrolfh($dscfh,$dscurl,1);
984 printdebug Dumper($dsc) if $debuglevel>1;
989 sub archive_query ($;@) {
990 my ($method) = shift @_;
991 fail "this operation does not support multiple comma-separated suites"
993 my $query = access_cfg('archive-query','RETURN-UNDEF');
994 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
997 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1000 sub archive_query_prepend_mirror {
1001 my $m = access_cfg('mirror');
1002 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1005 sub pool_dsc_subpath ($$) {
1006 my ($vsn,$component) = @_; # $package is implict arg
1007 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1008 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1011 sub cfg_apply_map ($$$) {
1012 my ($varref, $what, $mapspec) = @_;
1013 return unless $mapspec;
1015 printdebug "config $what EVAL{ $mapspec; }\n";
1017 eval "package Dgit::Config; $mapspec;";
1022 #---------- `ftpmasterapi' archive query method (nascent) ----------
1024 sub archive_api_query_cmd ($) {
1026 my @cmd = (@curl, qw(-sS));
1027 my $url = access_cfg('archive-query-url');
1028 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1030 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1031 foreach my $key (split /\:/, $keys) {
1032 $key =~ s/\%HOST\%/$host/g;
1034 fail "for $url: stat $key: $!" unless $!==ENOENT;
1037 fail "config requested specific TLS key but do not know".
1038 " how to get curl to use exactly that EE key ($key)";
1039 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1040 # # Sadly the above line does not work because of changes
1041 # # to gnutls. The real fix for #790093 may involve
1042 # # new curl options.
1045 # Fixing #790093 properly will involve providing a value
1046 # for this on clients.
1047 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1048 push @cmd, split / /, $kargs if defined $kargs;
1050 push @cmd, $url.$subpath;
1054 sub api_query ($$;$) {
1056 my ($data, $subpath, $ok404) = @_;
1057 badcfg "ftpmasterapi archive query method takes no data part"
1059 my @cmd = archive_api_query_cmd($subpath);
1060 my $url = $cmd[$#cmd];
1061 push @cmd, qw(-w %{http_code});
1062 my $json = cmdoutput @cmd;
1063 unless ($json =~ s/\d+\d+\d$//) {
1064 failedcmd_report_cmd undef, @cmd;
1065 fail "curl failed to print 3-digit HTTP code";
1068 return undef if $code eq '404' && $ok404;
1069 fail "fetch of $url gave HTTP code $code"
1070 unless $url =~ m#^file://# or $code =~ m/^2/;
1071 return decode_json($json);
1074 sub canonicalise_suite_ftpmasterapi {
1075 my ($proto,$data) = @_;
1076 my $suites = api_query($data, 'suites');
1078 foreach my $entry (@$suites) {
1080 my $v = $entry->{$_};
1081 defined $v && $v eq $isuite;
1082 } qw(codename name);
1083 push @matched, $entry;
1085 fail "unknown suite $isuite" unless @matched;
1088 @matched==1 or die "multiple matches for suite $isuite\n";
1089 $cn = "$matched[0]{codename}";
1090 defined $cn or die "suite $isuite info has no codename\n";
1091 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1093 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1098 sub archive_query_ftpmasterapi {
1099 my ($proto,$data) = @_;
1100 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1102 my $digester = Digest::SHA->new(256);
1103 foreach my $entry (@$info) {
1105 my $vsn = "$entry->{version}";
1106 my ($ok,$msg) = version_check $vsn;
1107 die "bad version: $msg\n" unless $ok;
1108 my $component = "$entry->{component}";
1109 $component =~ m/^$component_re$/ or die "bad component";
1110 my $filename = "$entry->{filename}";
1111 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1112 or die "bad filename";
1113 my $sha256sum = "$entry->{sha256sum}";
1114 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1115 push @rows, [ $vsn, "/pool/$component/$filename",
1116 $digester, $sha256sum ];
1118 die "bad ftpmaster api response: $@\n".Dumper($entry)
1121 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1122 return archive_query_prepend_mirror @rows;
1125 sub file_in_archive_ftpmasterapi {
1126 my ($proto,$data,$filename) = @_;
1127 my $pat = $filename;
1130 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1131 my $info = api_query($data, "file_in_archive/$pat", 1);
1134 sub package_not_wholly_new_ftpmasterapi {
1135 my ($proto,$data,$pkg) = @_;
1136 my $info = api_query($data,"madison?package=${pkg}&f=json");
1140 #---------- `aptget' archive query method ----------
1143 our $aptget_releasefile;
1144 our $aptget_configpath;
1146 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1147 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1149 sub aptget_cache_clean {
1150 runcmd_ordryrun_local qw(sh -ec),
1151 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1155 sub aptget_lock_acquire () {
1156 my $lockfile = "$aptget_base/lock";
1157 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1158 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1161 sub aptget_prep ($) {
1163 return if defined $aptget_base;
1165 badcfg "aptget archive query method takes no data part"
1168 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1171 ensuredir "$cache/dgit";
1173 access_cfg('aptget-cachekey','RETURN-UNDEF')
1174 // access_nomdistro();
1176 $aptget_base = "$cache/dgit/aptget";
1177 ensuredir $aptget_base;
1179 my $quoted_base = $aptget_base;
1180 die "$quoted_base contains bad chars, cannot continue"
1181 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1183 ensuredir $aptget_base;
1185 aptget_lock_acquire();
1187 aptget_cache_clean();
1189 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1190 my $sourceslist = "source.list#$cachekey";
1192 my $aptsuites = $isuite;
1193 cfg_apply_map(\$aptsuites, 'suite map',
1194 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1196 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1197 printf SRCS "deb-src %s %s %s\n",
1198 access_cfg('mirror'),
1200 access_cfg('aptget-components')
1203 ensuredir "$aptget_base/cache";
1204 ensuredir "$aptget_base/lists";
1206 open CONF, ">", $aptget_configpath or die $!;
1208 Debug::NoLocking "true";
1209 APT::Get::List-Cleanup "false";
1210 #clear APT::Update::Post-Invoke-Success;
1211 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1212 Dir::State::Lists "$quoted_base/lists";
1213 Dir::Etc::preferences "$quoted_base/preferences";
1214 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1215 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1218 foreach my $key (qw(
1221 Dir::Cache::Archives
1222 Dir::Etc::SourceParts
1223 Dir::Etc::preferencesparts
1225 ensuredir "$aptget_base/$key";
1226 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1229 my $oldatime = (time // die $!) - 1;
1230 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1231 next unless stat_exists $oldlist;
1232 my ($mtime) = (stat _)[9];
1233 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1236 runcmd_ordryrun_local aptget_aptget(), qw(update);
1239 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1240 next unless stat_exists $oldlist;
1241 my ($atime) = (stat _)[8];
1242 next if $atime == $oldatime;
1243 push @releasefiles, $oldlist;
1245 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1246 @releasefiles = @inreleasefiles if @inreleasefiles;
1247 if (!@releasefiles) {
1249 apt seemed to not to update dgit's cached Release files for $isuite.
1251 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1254 die "apt updated too many Release files (@releasefiles), erk"
1255 unless @releasefiles == 1;
1257 ($aptget_releasefile) = @releasefiles;
1260 sub canonicalise_suite_aptget {
1261 my ($proto,$data) = @_;
1264 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1266 foreach my $name (qw(Codename Suite)) {
1267 my $val = $release->{$name};
1269 printdebug "release file $name: $val\n";
1270 $val =~ m/^$suite_re$/o or fail
1271 "Release file ($aptget_releasefile) specifies intolerable $name";
1272 cfg_apply_map(\$val, 'suite rmap',
1273 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1280 sub archive_query_aptget {
1281 my ($proto,$data) = @_;
1284 ensuredir "$aptget_base/source";
1285 foreach my $old (<$aptget_base/source/*.dsc>) {
1286 unlink $old or die "$old: $!";
1289 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1290 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1291 # avoids apt-get source failing with ambiguous error code
1293 runcmd_ordryrun_local
1294 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1295 aptget_aptget(), qw(--download-only --only-source source), $package;
1297 my @dscs = <$aptget_base/source/*.dsc>;
1298 fail "apt-get source did not produce a .dsc" unless @dscs;
1299 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1301 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1304 my $uri = "file://". uri_escape $dscs[0];
1305 $uri =~ s{\%2f}{/}gi;
1306 return [ (getfield $pre_dsc, 'Version'), $uri ];
1309 sub file_in_archive_aptget () { return undef; }
1310 sub package_not_wholly_new_aptget () { return undef; }
1312 #---------- `dummyapicat' archive query method ----------
1314 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1315 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1317 sub dummycatapi_run_in_mirror ($@) {
1318 # runs $fn with FIA open onto rune
1319 my ($rune, $argl, $fn) = @_;
1321 my $mirror = access_cfg('mirror');
1322 $mirror =~ s#^file://#/# or die "$mirror ?";
1323 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1324 qw(x), $mirror, @$argl);
1325 debugcmd "-|", @cmd;
1326 open FIA, "-|", @cmd or die $!;
1328 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1332 sub file_in_archive_dummycatapi ($$$) {
1333 my ($proto,$data,$filename) = @_;
1335 dummycatapi_run_in_mirror '
1336 find -name "$1" -print0 |
1338 ', [$filename], sub {
1341 printdebug "| $_\n";
1342 m/^(\w+) (\S+)$/ or die "$_ ?";
1343 push @out, { sha256sum => $1, filename => $2 };
1349 sub package_not_wholly_new_dummycatapi {
1350 my ($proto,$data,$pkg) = @_;
1351 dummycatapi_run_in_mirror "
1352 find -name ${pkg}_*.dsc
1359 #---------- `madison' archive query method ----------
1361 sub archive_query_madison {
1362 return archive_query_prepend_mirror
1363 map { [ @$_[0..1] ] } madison_get_parse(@_);
1366 sub madison_get_parse {
1367 my ($proto,$data) = @_;
1368 die unless $proto eq 'madison';
1369 if (!length $data) {
1370 $data= access_cfg('madison-distro','RETURN-UNDEF');
1371 $data //= access_basedistro();
1373 $rmad{$proto,$data,$package} ||= cmdoutput
1374 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1375 my $rmad = $rmad{$proto,$data,$package};
1378 foreach my $l (split /\n/, $rmad) {
1379 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1380 \s*( [^ \t|]+ )\s* \|
1381 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1382 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1383 $1 eq $package or die "$rmad $package ?";
1390 $component = access_cfg('archive-query-default-component');
1392 $5 eq 'source' or die "$rmad ?";
1393 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1395 return sort { -version_compare($a->[0],$b->[0]); } @out;
1398 sub canonicalise_suite_madison {
1399 # madison canonicalises for us
1400 my @r = madison_get_parse(@_);
1402 "unable to canonicalise suite using package $package".
1403 " which does not appear to exist in suite $isuite;".
1404 " --existing-package may help";
1408 sub file_in_archive_madison { return undef; }
1409 sub package_not_wholly_new_madison { return undef; }
1411 #---------- `sshpsql' archive query method ----------
1414 my ($data,$runeinfo,$sql) = @_;
1415 if (!length $data) {
1416 $data= access_someuserhost('sshpsql').':'.
1417 access_cfg('sshpsql-dbname');
1419 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1420 my ($userhost,$dbname) = ($`,$'); #';
1422 my @cmd = (access_cfg_ssh, $userhost,
1423 access_runeinfo("ssh-psql $runeinfo").
1424 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1425 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1427 open P, "-|", @cmd or die $!;
1430 printdebug(">|$_|\n");
1433 $!=0; $?=0; close P or failedcmd @cmd;
1435 my $nrows = pop @rows;
1436 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1437 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1438 @rows = map { [ split /\|/, $_ ] } @rows;
1439 my $ncols = scalar @{ shift @rows };
1440 die if grep { scalar @$_ != $ncols } @rows;
1444 sub sql_injection_check {
1445 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1448 sub archive_query_sshpsql ($$) {
1449 my ($proto,$data) = @_;
1450 sql_injection_check $isuite, $package;
1451 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1452 SELECT source.version, component.name, files.filename, files.sha256sum
1454 JOIN src_associations ON source.id = src_associations.source
1455 JOIN suite ON suite.id = src_associations.suite
1456 JOIN dsc_files ON dsc_files.source = source.id
1457 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1458 JOIN component ON component.id = files_archive_map.component_id
1459 JOIN files ON files.id = dsc_files.file
1460 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1461 AND source.source='$package'
1462 AND files.filename LIKE '%.dsc';
1464 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1465 my $digester = Digest::SHA->new(256);
1467 my ($vsn,$component,$filename,$sha256sum) = @$_;
1468 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1470 return archive_query_prepend_mirror @rows;
1473 sub canonicalise_suite_sshpsql ($$) {
1474 my ($proto,$data) = @_;
1475 sql_injection_check $isuite;
1476 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1477 SELECT suite.codename
1478 FROM suite where suite_name='$isuite' or codename='$isuite';
1480 @rows = map { $_->[0] } @rows;
1481 fail "unknown suite $isuite" unless @rows;
1482 die "ambiguous $isuite: @rows ?" if @rows>1;
1486 sub file_in_archive_sshpsql ($$$) { return undef; }
1487 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1489 #---------- `dummycat' archive query method ----------
1491 sub canonicalise_suite_dummycat ($$) {
1492 my ($proto,$data) = @_;
1493 my $dpath = "$data/suite.$isuite";
1494 if (!open C, "<", $dpath) {
1495 $!==ENOENT or die "$dpath: $!";
1496 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1500 chomp or die "$dpath: $!";
1502 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1506 sub archive_query_dummycat ($$) {
1507 my ($proto,$data) = @_;
1508 canonicalise_suite();
1509 my $dpath = "$data/package.$csuite.$package";
1510 if (!open C, "<", $dpath) {
1511 $!==ENOENT or die "$dpath: $!";
1512 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1520 printdebug "dummycat query $csuite $package $dpath | $_\n";
1521 my @row = split /\s+/, $_;
1522 @row==2 or die "$dpath: $_ ?";
1525 C->error and die "$dpath: $!";
1527 return archive_query_prepend_mirror
1528 sort { -version_compare($a->[0],$b->[0]); } @rows;
1531 sub file_in_archive_dummycat () { return undef; }
1532 sub package_not_wholly_new_dummycat () { return undef; }
1534 #---------- tag format handling ----------
1536 sub access_cfg_tagformats () {
1537 split /\,/, access_cfg('dgit-tag-format');
1540 sub access_cfg_tagformats_can_splitbrain () {
1541 my %y = map { $_ => 1 } access_cfg_tagformats;
1542 foreach my $needtf (qw(new maint)) {
1543 next if $y{$needtf};
1549 sub need_tagformat ($$) {
1550 my ($fmt, $why) = @_;
1551 fail "need to use tag format $fmt ($why) but also need".
1552 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1553 " - no way to proceed"
1554 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1555 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1558 sub select_tagformat () {
1560 return if $tagformatfn && !$tagformat_want;
1561 die 'bug' if $tagformatfn && $tagformat_want;
1562 # ... $tagformat_want assigned after previous select_tagformat
1564 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1565 printdebug "select_tagformat supported @supported\n";
1567 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1568 printdebug "select_tagformat specified @$tagformat_want\n";
1570 my ($fmt,$why,$override) = @$tagformat_want;
1572 fail "target distro supports tag formats @supported".
1573 " but have to use $fmt ($why)"
1575 or grep { $_ eq $fmt } @supported;
1577 $tagformat_want = undef;
1579 $tagformatfn = ${*::}{"debiantag_$fmt"};
1581 fail "trying to use unknown tag format \`$fmt' ($why) !"
1582 unless $tagformatfn;
1585 #---------- archive query entrypoints and rest of program ----------
1587 sub canonicalise_suite () {
1588 return if defined $csuite;
1589 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1590 $csuite = archive_query('canonicalise_suite');
1591 if ($isuite ne $csuite) {
1592 progress "canonical suite name for $isuite is $csuite";
1594 progress "canonical suite name is $csuite";
1598 sub get_archive_dsc () {
1599 canonicalise_suite();
1600 my @vsns = archive_query('archive_query');
1601 foreach my $vinfo (@vsns) {
1602 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1603 $dscurl = $vsn_dscurl;
1604 $dscdata = url_get($dscurl);
1606 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1611 $digester->add($dscdata);
1612 my $got = $digester->hexdigest();
1614 fail "$dscurl has hash $got but".
1615 " archive told us to expect $digest";
1618 my $fmt = getfield $dsc, 'Format';
1619 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1620 "unsupported source format $fmt, sorry";
1622 $dsc_checked = !!$digester;
1623 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1627 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1630 sub check_for_git ();
1631 sub check_for_git () {
1633 my $how = access_cfg('git-check');
1634 if ($how eq 'ssh-cmd') {
1636 (access_cfg_ssh, access_gituserhost(),
1637 access_runeinfo("git-check $package").
1638 " set -e; cd ".access_cfg('git-path').";".
1639 " if test -d $package.git; then echo 1; else echo 0; fi");
1640 my $r= cmdoutput @cmd;
1641 if (defined $r and $r =~ m/^divert (\w+)$/) {
1643 my ($usedistro,) = access_distros();
1644 # NB that if we are pushing, $usedistro will be $distro/push
1645 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1646 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1647 progress "diverting to $divert (using config for $instead_distro)";
1648 return check_for_git();
1650 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1652 } elsif ($how eq 'url') {
1653 my $prefix = access_cfg('git-check-url','git-url');
1654 my $suffix = access_cfg('git-check-suffix','git-suffix',
1655 'RETURN-UNDEF') // '.git';
1656 my $url = "$prefix/$package$suffix";
1657 my @cmd = (@curl, qw(-sS -I), $url);
1658 my $result = cmdoutput @cmd;
1659 $result =~ s/^\S+ 200 .*\n\r?\n//;
1660 # curl -sS -I with https_proxy prints
1661 # HTTP/1.0 200 Connection established
1662 $result =~ m/^\S+ (404|200) /s or
1663 fail "unexpected results from git check query - ".
1664 Dumper($prefix, $result);
1666 if ($code eq '404') {
1668 } elsif ($code eq '200') {
1673 } elsif ($how eq 'true') {
1675 } elsif ($how eq 'false') {
1678 badcfg "unknown git-check \`$how'";
1682 sub create_remote_git_repo () {
1683 my $how = access_cfg('git-create');
1684 if ($how eq 'ssh-cmd') {
1686 (access_cfg_ssh, access_gituserhost(),
1687 access_runeinfo("git-create $package").
1688 "set -e; cd ".access_cfg('git-path').";".
1689 " cp -a _template $package.git");
1690 } elsif ($how eq 'true') {
1693 badcfg "unknown git-create \`$how'";
1697 our ($dsc_hash,$lastpush_mergeinput);
1698 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1702 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1703 $playground = fresh_playground 'dgit/unpack';
1706 sub mktree_in_ud_here () {
1707 playtree_setup $gitcfgs{local};
1710 sub git_write_tree () {
1711 my $tree = cmdoutput @git, qw(write-tree);
1712 $tree =~ m/^\w+$/ or die "$tree ?";
1716 sub git_add_write_tree () {
1717 runcmd @git, qw(add -Af .);
1718 return git_write_tree();
1721 sub remove_stray_gits ($) {
1723 my @gitscmd = qw(find -name .git -prune -print0);
1724 debugcmd "|",@gitscmd;
1725 open GITS, "-|", @gitscmd or die $!;
1730 print STDERR "$us: warning: removing from $what: ",
1731 (messagequote $_), "\n";
1735 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1738 sub mktree_in_ud_from_only_subdir ($;$) {
1739 my ($what,$raw) = @_;
1740 # changes into the subdir
1743 die "expected one subdir but found @dirs ?" unless @dirs==1;
1744 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1748 remove_stray_gits($what);
1749 mktree_in_ud_here();
1751 my ($format, $fopts) = get_source_format();
1752 if (madformat($format)) {
1757 my $tree=git_add_write_tree();
1758 return ($tree,$dir);
1761 our @files_csum_info_fields =
1762 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1763 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1764 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1766 sub dsc_files_info () {
1767 foreach my $csumi (@files_csum_info_fields) {
1768 my ($fname, $module, $method) = @$csumi;
1769 my $field = $dsc->{$fname};
1770 next unless defined $field;
1771 eval "use $module; 1;" or die $@;
1773 foreach (split /\n/, $field) {
1775 m/^(\w+) (\d+) (\S+)$/ or
1776 fail "could not parse .dsc $fname line \`$_'";
1777 my $digester = eval "$module"."->$method;" or die $@;
1782 Digester => $digester,
1787 fail "missing any supported Checksums-* or Files field in ".
1788 $dsc->get_option('name');
1792 map { $_->{Filename} } dsc_files_info();
1795 sub files_compare_inputs (@) {
1800 my $showinputs = sub {
1801 return join "; ", map { $_->get_option('name') } @$inputs;
1804 foreach my $in (@$inputs) {
1806 my $in_name = $in->get_option('name');
1808 printdebug "files_compare_inputs $in_name\n";
1810 foreach my $csumi (@files_csum_info_fields) {
1811 my ($fname) = @$csumi;
1812 printdebug "files_compare_inputs $in_name $fname\n";
1814 my $field = $in->{$fname};
1815 next unless defined $field;
1818 foreach (split /\n/, $field) {
1821 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1822 fail "could not parse $in_name $fname line \`$_'";
1824 printdebug "files_compare_inputs $in_name $fname $f\n";
1828 my $re = \ $record{$f}{$fname};
1830 $fchecked{$f}{$in_name} = 1;
1832 fail "hash or size of $f varies in $fname fields".
1833 " (between: ".$showinputs->().")";
1838 @files = sort @files;
1839 $expected_files //= \@files;
1840 "@$expected_files" eq "@files" or
1841 fail "file list in $in_name varies between hash fields!";
1844 fail "$in_name has no files list field(s)";
1846 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1849 grep { keys %$_ == @$inputs-1 } values %fchecked
1850 or fail "no file appears in all file lists".
1851 " (looked in: ".$showinputs->().")";
1854 sub is_orig_file_in_dsc ($$) {
1855 my ($f, $dsc_files_info) = @_;
1856 return 0 if @$dsc_files_info <= 1;
1857 # One file means no origs, and the filename doesn't have a "what
1858 # part of dsc" component. (Consider versions ending `.orig'.)
1859 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1863 sub is_orig_file_of_vsn ($$) {
1864 my ($f, $upstreamvsn) = @_;
1865 my $base = srcfn $upstreamvsn, '';
1866 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1870 # This function determines whether a .changes file is source-only from
1871 # the point of view of dak. Thus, it permits *_source.buildinfo
1874 # It does not, however, permit any other buildinfo files. After a
1875 # source-only upload, the buildds will try to upload files like
1876 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1877 # named like this in their (otherwise) source-only upload, the uploads
1878 # of the buildd can be rejected by dak. Fixing the resultant
1879 # situation can require manual intervention. So we block such
1880 # .buildinfo files when the user tells us to perform a source-only
1881 # upload (such as when using the push-source subcommand with the -C
1882 # option, which calls this function).
1884 # Note, though, that when dgit is told to prepare a source-only
1885 # upload, such as when subcommands like build-source and push-source
1886 # without -C are used, dgit has a more restrictive notion of
1887 # source-only .changes than dak: such uploads will never include
1888 # *_source.buildinfo files. This is because there is no use for such
1889 # files when using a tool like dgit to produce the source package, as
1890 # dgit ensures the source is identical to git HEAD.
1891 sub test_source_only_changes ($) {
1893 foreach my $l (split /\n/, getfield $changes, 'Files') {
1894 $l =~ m/\S+$/ or next;
1895 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1896 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1897 print "purportedly source-only changes polluted by $&\n";
1904 sub changes_update_origs_from_dsc ($$$$) {
1905 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1907 printdebug "checking origs needed ($upstreamvsn)...\n";
1908 $_ = getfield $changes, 'Files';
1909 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1910 fail "cannot find section/priority from .changes Files field";
1911 my $placementinfo = $1;
1913 printdebug "checking origs needed placement '$placementinfo'...\n";
1914 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1915 $l =~ m/\S+$/ or next;
1917 printdebug "origs $file | $l\n";
1918 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1919 printdebug "origs $file is_orig\n";
1920 my $have = archive_query('file_in_archive', $file);
1921 if (!defined $have) {
1923 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1929 printdebug "origs $file \$#\$have=$#$have\n";
1930 foreach my $h (@$have) {
1933 foreach my $csumi (@files_csum_info_fields) {
1934 my ($fname, $module, $method, $archivefield) = @$csumi;
1935 next unless defined $h->{$archivefield};
1936 $_ = $dsc->{$fname};
1937 next unless defined;
1938 m/^(\w+) .* \Q$file\E$/m or
1939 fail ".dsc $fname missing entry for $file";
1940 if ($h->{$archivefield} eq $1) {
1944 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1947 die "$file ".Dumper($h)." ?!" if $same && @differ;
1950 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1953 printdebug "origs $file f.same=$found_same".
1954 " #f._differ=$#found_differ\n";
1955 if (@found_differ && !$found_same) {
1957 "archive contains $file with different checksum",
1960 # Now we edit the changes file to add or remove it
1961 foreach my $csumi (@files_csum_info_fields) {
1962 my ($fname, $module, $method, $archivefield) = @$csumi;
1963 next unless defined $changes->{$fname};
1965 # in archive, delete from .changes if it's there
1966 $changed{$file} = "removed" if
1967 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
1968 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
1969 # not in archive, but it's here in the .changes
1971 my $dsc_data = getfield $dsc, $fname;
1972 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
1974 $extra =~ s/ \d+ /$&$placementinfo /
1975 or die "$fname $extra >$dsc_data< ?"
1976 if $fname eq 'Files';
1977 $changes->{$fname} .= "\n". $extra;
1978 $changed{$file} = "added";
1983 foreach my $file (keys %changed) {
1985 "edited .changes for archive .orig contents: %s %s",
1986 $changed{$file}, $file;
1988 my $chtmp = "$changesfile.tmp";
1989 $changes->save($chtmp);
1991 rename $chtmp,$changesfile or die "$changesfile $!";
1993 progress "[new .changes left in $changesfile]";
1996 progress "$changesfile already has appropriate .orig(s) (if any)";
2000 sub make_commit ($) {
2002 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2005 sub make_commit_text ($) {
2008 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
2010 print Dumper($text) if $debuglevel > 1;
2011 my $child = open2($out, $in, @cmd) or die $!;
2014 print $in $text or die $!;
2015 close $in or die $!;
2017 $h =~ m/^\w+$/ or die;
2019 printdebug "=> $h\n";
2022 waitpid $child, 0 == $child or die "$child $!";
2023 $? and failedcmd @cmd;
2027 sub clogp_authline ($) {
2029 my $author = getfield $clogp, 'Maintainer';
2030 if ($author =~ m/^[^"\@]+\,/) {
2031 # single entry Maintainer field with unquoted comma
2032 $author = ($& =~ y/,//rd).$'; # strip the comma
2034 # git wants a single author; any remaining commas in $author
2035 # are by now preceded by @ (or "). It seems safer to punt on
2036 # "..." for now rather than attempting to dequote or something.
2037 $author =~ s#,.*##ms unless $author =~ m/"/;
2038 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2039 my $authline = "$author $date";
2040 $authline =~ m/$git_authline_re/o or
2041 fail "unexpected commit author line format \`$authline'".
2042 " (was generated from changelog Maintainer field)";
2043 return ($1,$2,$3) if wantarray;
2047 sub vendor_patches_distro ($$) {
2048 my ($checkdistro, $what) = @_;
2049 return unless defined $checkdistro;
2051 my $series = "debian/patches/\L$checkdistro\E.series";
2052 printdebug "checking for vendor-specific $series ($what)\n";
2054 if (!open SERIES, "<", $series) {
2055 die "$series $!" unless $!==ENOENT;
2064 Unfortunately, this source package uses a feature of dpkg-source where
2065 the same source package unpacks to different source code on different
2066 distros. dgit cannot safely operate on such packages on affected
2067 distros, because the meaning of source packages is not stable.
2069 Please ask the distro/maintainer to remove the distro-specific series
2070 files and use a different technique (if necessary, uploading actually
2071 different packages, if different distros are supposed to have
2075 fail "Found active distro-specific series file for".
2076 " $checkdistro ($what): $series, cannot continue";
2078 die "$series $!" if SERIES->error;
2082 sub check_for_vendor_patches () {
2083 # This dpkg-source feature doesn't seem to be documented anywhere!
2084 # But it can be found in the changelog (reformatted):
2086 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2087 # Author: Raphael Hertzog <hertzog@debian.org>
2088 # Date: Sun Oct 3 09:36:48 2010 +0200
2090 # dpkg-source: correctly create .pc/.quilt_series with alternate
2093 # If you have debian/patches/ubuntu.series and you were
2094 # unpacking the source package on ubuntu, quilt was still
2095 # directed to debian/patches/series instead of
2096 # debian/patches/ubuntu.series.
2098 # debian/changelog | 3 +++
2099 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2100 # 2 files changed, 6 insertions(+), 1 deletion(-)
2103 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2104 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2105 "Dpkg::Vendor \`current vendor'");
2106 vendor_patches_distro(access_basedistro(),
2107 "(base) distro being accessed");
2108 vendor_patches_distro(access_nomdistro(),
2109 "(nominal) distro being accessed");
2112 sub generate_commits_from_dsc () {
2113 # See big comment in fetch_from_archive, below.
2114 # See also README.dsc-import.
2116 changedir $playground;
2118 my @dfi = dsc_files_info();
2119 foreach my $fi (@dfi) {
2120 my $f = $fi->{Filename};
2121 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2122 my $upper_f = (bpd_abs()."/$f");
2124 printdebug "considering reusing $f: ";
2126 if (link_ltarget "$upper_f,fetch", $f) {
2127 printdebug "linked (using ...,fetch).\n";
2128 } elsif ((printdebug "($!) "),
2130 fail "accessing $buildproductsdir/$f,fetch: $!";
2131 } elsif (link_ltarget $upper_f, $f) {
2132 printdebug "linked.\n";
2133 } elsif ((printdebug "($!) "),
2135 fail "accessing $buildproductsdir/$f: $!";
2137 printdebug "absent.\n";
2141 complete_file_from_dsc('.', $fi, \$refetched)
2144 printdebug "considering saving $f: ";
2146 if (link $f, $upper_f) {
2147 printdebug "linked.\n";
2148 } elsif ((printdebug "($!) "),
2150 fail "saving $buildproductsdir/$f: $!";
2151 } elsif (!$refetched) {
2152 printdebug "no need.\n";
2153 } elsif (link $f, "$upper_f,fetch") {
2154 printdebug "linked (using ...,fetch).\n";
2155 } elsif ((printdebug "($!) "),
2157 fail "saving $buildproductsdir/$f,fetch: $!";
2159 printdebug "cannot.\n";
2163 # We unpack and record the orig tarballs first, so that we only
2164 # need disk space for one private copy of the unpacked source.
2165 # But we can't make them into commits until we have the metadata
2166 # from the debian/changelog, so we record the tree objects now and
2167 # make them into commits later.
2169 my $upstreamv = upstreamversion $dsc->{version};
2170 my $orig_f_base = srcfn $upstreamv, '';
2172 foreach my $fi (@dfi) {
2173 # We actually import, and record as a commit, every tarball
2174 # (unless there is only one file, in which case there seems
2177 my $f = $fi->{Filename};
2178 printdebug "import considering $f ";
2179 (printdebug "only one dfi\n"), next if @dfi == 1;
2180 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2181 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2185 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2187 printdebug "Y ", (join ' ', map { $_//"(none)" }
2188 $compr_ext, $orig_f_part
2191 my $input = new IO::File $f, '<' or die "$f $!";
2195 if (defined $compr_ext) {
2197 Dpkg::Compression::compression_guess_from_filename $f;
2198 fail "Dpkg::Compression cannot handle file $f in source package"
2199 if defined $compr_ext && !defined $cname;
2201 new Dpkg::Compression::Process compression => $cname;
2202 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2203 my $compr_fh = new IO::Handle;
2204 my $compr_pid = open $compr_fh, "-|" // die $!;
2206 open STDIN, "<&", $input or die $!;
2208 die "dgit (child): exec $compr_cmd[0]: $!\n";
2213 rmtree "_unpack-tar";
2214 mkdir "_unpack-tar" or die $!;
2215 my @tarcmd = qw(tar -x -f -
2216 --no-same-owner --no-same-permissions
2217 --no-acls --no-xattrs --no-selinux);
2218 my $tar_pid = fork // die $!;
2220 chdir "_unpack-tar" or die $!;
2221 open STDIN, "<&", $input or die $!;
2223 die "dgit (child): exec $tarcmd[0]: $!";
2225 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2226 !$? or failedcmd @tarcmd;
2229 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2231 # finally, we have the results in "tarball", but maybe
2232 # with the wrong permissions
2234 runcmd qw(chmod -R +rwX _unpack-tar);
2235 changedir "_unpack-tar";
2236 remove_stray_gits($f);
2237 mktree_in_ud_here();
2239 my ($tree) = git_add_write_tree();
2240 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2241 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2243 printdebug "one subtree $1\n";
2245 printdebug "multiple subtrees\n";
2248 rmtree "_unpack-tar";
2250 my $ent = [ $f, $tree ];
2252 Orig => !!$orig_f_part,
2253 Sort => (!$orig_f_part ? 2 :
2254 $orig_f_part =~ m/-/g ? 1 :
2262 # put any without "_" first (spec is not clear whether files
2263 # are always in the usual order). Tarballs without "_" are
2264 # the main orig or the debian tarball.
2265 $a->{Sort} <=> $b->{Sort} or
2269 my $any_orig = grep { $_->{Orig} } @tartrees;
2271 my $dscfn = "$package.dsc";
2273 my $treeimporthow = 'package';
2275 open D, ">", $dscfn or die "$dscfn: $!";
2276 print D $dscdata or die "$dscfn: $!";
2277 close D or die "$dscfn: $!";
2278 my @cmd = qw(dpkg-source);
2279 push @cmd, '--no-check' if $dsc_checked;
2280 if (madformat $dsc->{format}) {
2281 push @cmd, '--skip-patches';
2282 $treeimporthow = 'unpatched';
2284 push @cmd, qw(-x --), $dscfn;
2287 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2288 if (madformat $dsc->{format}) {
2289 check_for_vendor_patches();
2293 if (madformat $dsc->{format}) {
2294 my @pcmd = qw(dpkg-source --before-build .);
2295 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2297 $dappliedtree = git_add_write_tree();
2300 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2304 printdebug "import clog search...\n";
2305 parsechangelog_loop \@clogcmd, "package changelog", sub {
2306 my ($thisstanza, $desc) = @_;
2307 no warnings qw(exiting);
2309 $clogp //= $thisstanza;
2311 printdebug "import clog $thisstanza->{version} $desc...\n";
2313 last if !$any_orig; # we don't need $r1clogp
2315 # We look for the first (most recent) changelog entry whose
2316 # version number is lower than the upstream version of this
2317 # package. Then the last (least recent) previous changelog
2318 # entry is treated as the one which introduced this upstream
2319 # version and used for the synthetic commits for the upstream
2322 # One might think that a more sophisticated algorithm would be
2323 # necessary. But: we do not want to scan the whole changelog
2324 # file. Stopping when we see an earlier version, which
2325 # necessarily then is an earlier upstream version, is the only
2326 # realistic way to do that. Then, either the earliest
2327 # changelog entry we have seen so far is indeed the earliest
2328 # upload of this upstream version; or there are only changelog
2329 # entries relating to later upstream versions (which is not
2330 # possible unless the changelog and .dsc disagree about the
2331 # version). Then it remains to choose between the physically
2332 # last entry in the file, and the one with the lowest version
2333 # number. If these are not the same, we guess that the
2334 # versions were created in a non-monotonic order rather than
2335 # that the changelog entries have been misordered.
2337 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2339 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2340 $r1clogp = $thisstanza;
2342 printdebug "import clog $r1clogp->{version} becomes r1\n";
2345 $clogp or fail "package changelog has no entries!";
2347 my $authline = clogp_authline $clogp;
2348 my $changes = getfield $clogp, 'Changes';
2349 $changes =~ s/^\n//; # Changes: \n
2350 my $cversion = getfield $clogp, 'Version';
2353 $r1clogp //= $clogp; # maybe there's only one entry;
2354 my $r1authline = clogp_authline $r1clogp;
2355 # Strictly, r1authline might now be wrong if it's going to be
2356 # unused because !$any_orig. Whatever.
2358 printdebug "import tartrees authline $authline\n";
2359 printdebug "import tartrees r1authline $r1authline\n";
2361 foreach my $tt (@tartrees) {
2362 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2364 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2367 committer $r1authline
2371 [dgit import orig $tt->{F}]
2379 [dgit import tarball $package $cversion $tt->{F}]
2384 printdebug "import main commit\n";
2386 open C, ">../commit.tmp" or die $!;
2387 print C <<END or die $!;
2390 print C <<END or die $! foreach @tartrees;
2393 print C <<END or die $!;
2399 [dgit import $treeimporthow $package $cversion]
2403 my $rawimport_hash = make_commit qw(../commit.tmp);
2405 if (madformat $dsc->{format}) {
2406 printdebug "import apply patches...\n";
2408 # regularise the state of the working tree so that
2409 # the checkout of $rawimport_hash works nicely.
2410 my $dappliedcommit = make_commit_text(<<END);
2417 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2419 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2421 # We need the answers to be reproducible
2422 my @authline = clogp_authline($clogp);
2423 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2424 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2425 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2426 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2427 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2428 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2430 my $path = $ENV{PATH} or die;
2432 # we use ../../gbp-pq-output, which (given that we are in
2433 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2436 foreach my $use_absurd (qw(0 1)) {
2437 runcmd @git, qw(checkout -q unpa);
2438 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2439 local $ENV{PATH} = $path;
2442 progress "warning: $@";
2443 $path = "$absurdity:$path";
2444 progress "$us: trying slow absurd-git-apply...";
2445 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2450 die "forbid absurd git-apply\n" if $use_absurd
2451 && forceing [qw(import-gitapply-no-absurd)];
2452 die "only absurd git-apply!\n" if !$use_absurd
2453 && forceing [qw(import-gitapply-absurd)];
2455 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2456 local $ENV{PATH} = $path if $use_absurd;
2458 my @showcmd = (gbp_pq, qw(import));
2459 my @realcmd = shell_cmd
2460 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2461 debugcmd "+",@realcmd;
2462 if (system @realcmd) {
2463 die +(shellquote @showcmd).
2465 failedcmd_waitstatus()."\n";
2468 my $gapplied = git_rev_parse('HEAD');
2469 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2470 $gappliedtree eq $dappliedtree or
2472 gbp-pq import and dpkg-source disagree!
2473 gbp-pq import gave commit $gapplied
2474 gbp-pq import gave tree $gappliedtree
2475 dpkg-source --before-build gave tree $dappliedtree
2477 $rawimport_hash = $gapplied;
2482 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2487 progress "synthesised git commit from .dsc $cversion";
2489 my $rawimport_mergeinput = {
2490 Commit => $rawimport_hash,
2491 Info => "Import of source package",
2493 my @output = ($rawimport_mergeinput);
2495 if ($lastpush_mergeinput) {
2496 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2497 my $oversion = getfield $oldclogp, 'Version';
2499 version_compare($oversion, $cversion);
2501 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2502 { Message => <<END, ReverseParents => 1 });
2503 Record $package ($cversion) in archive suite $csuite
2505 } elsif ($vcmp > 0) {
2506 print STDERR <<END or die $!;
2508 Version actually in archive: $cversion (older)
2509 Last version pushed with dgit: $oversion (newer or same)
2512 @output = $lastpush_mergeinput;
2514 # Same version. Use what's in the server git branch,
2515 # discarding our own import. (This could happen if the
2516 # server automatically imports all packages into git.)
2517 @output = $lastpush_mergeinput;
2525 sub complete_file_from_dsc ($$;$) {
2526 our ($dstdir, $fi, $refetched) = @_;
2527 # Ensures that we have, in $dstdir, the file $fi, with the correct
2528 # contents. (Downloading it from alongside $dscurl if necessary.)
2529 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2530 # and will set $$refetched=1 if it did so (or tried to).
2532 my $f = $fi->{Filename};
2533 my $tf = "$dstdir/$f";
2537 my $checkhash = sub {
2538 open F, "<", "$tf" or die "$tf: $!";
2539 $fi->{Digester}->reset();
2540 $fi->{Digester}->addfile(*F);
2541 F->error and die $!;
2542 $got = $fi->{Digester}->hexdigest();
2543 return $got eq $fi->{Hash};
2546 if (stat_exists $tf) {
2547 if ($checkhash->()) {
2548 progress "using existing $f";
2552 fail "file $f has hash $got but .dsc".
2553 " demands hash $fi->{Hash} ".
2554 "(perhaps you should delete this file?)";
2556 progress "need to fetch correct version of $f";
2557 unlink $tf or die "$tf $!";
2560 printdebug "$tf does not exist, need to fetch\n";
2564 $furl =~ s{/[^/]+$}{};
2566 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2567 die "$f ?" if $f =~ m#/#;
2568 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2569 return 0 if !act_local();
2572 fail "file $f has hash $got but .dsc".
2573 " demands hash $fi->{Hash} ".
2574 "(got wrong file from archive!)";
2579 sub ensure_we_have_orig () {
2580 my @dfi = dsc_files_info();
2581 foreach my $fi (@dfi) {
2582 my $f = $fi->{Filename};
2583 next unless is_orig_file_in_dsc($f, \@dfi);
2584 complete_file_from_dsc($buildproductsdir, $fi)
2589 #---------- git fetch ----------
2591 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2592 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2594 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2595 # locally fetched refs because they have unhelpful names and clutter
2596 # up gitk etc. So we track whether we have "used up" head ref (ie,
2597 # whether we have made another local ref which refers to this object).
2599 # (If we deleted them unconditionally, then we might end up
2600 # re-fetching the same git objects each time dgit fetch was run.)
2602 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2603 # in git_fetch_us to fetch the refs in question, and possibly a call
2604 # to lrfetchref_used.
2606 our (%lrfetchrefs_f, %lrfetchrefs_d);
2607 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2609 sub lrfetchref_used ($) {
2610 my ($fullrefname) = @_;
2611 my $objid = $lrfetchrefs_f{$fullrefname};
2612 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2615 sub git_lrfetch_sane {
2616 my ($url, $supplementary, @specs) = @_;
2617 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2618 # at least as regards @specs. Also leave the results in
2619 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2620 # able to clean these up.
2622 # With $supplementary==1, @specs must not contain wildcards
2623 # and we add to our previous fetches (non-atomically).
2625 # This is rather miserable:
2626 # When git fetch --prune is passed a fetchspec ending with a *,
2627 # it does a plausible thing. If there is no * then:
2628 # - it matches subpaths too, even if the supplied refspec
2629 # starts refs, and behaves completely madly if the source
2630 # has refs/refs/something. (See, for example, Debian #NNNN.)
2631 # - if there is no matching remote ref, it bombs out the whole
2633 # We want to fetch a fixed ref, and we don't know in advance
2634 # if it exists, so this is not suitable.
2636 # Our workaround is to use git ls-remote. git ls-remote has its
2637 # own qairks. Notably, it has the absurd multi-tail-matching
2638 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2639 # refs/refs/foo etc.
2641 # Also, we want an idempotent snapshot, but we have to make two
2642 # calls to the remote: one to git ls-remote and to git fetch. The
2643 # solution is use git ls-remote to obtain a target state, and
2644 # git fetch to try to generate it. If we don't manage to generate
2645 # the target state, we try again.
2647 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2649 my $specre = join '|', map {
2652 my $wildcard = $x =~ s/\\\*$/.*/;
2653 die if $wildcard && $supplementary;
2656 printdebug "git_lrfetch_sane specre=$specre\n";
2657 my $wanted_rref = sub {
2659 return m/^(?:$specre)$/;
2662 my $fetch_iteration = 0;
2665 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2666 if (++$fetch_iteration > 10) {
2667 fail "too many iterations trying to get sane fetch!";
2670 my @look = map { "refs/$_" } @specs;
2671 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2675 open GITLS, "-|", @lcmd or die $!;
2677 printdebug "=> ", $_;
2678 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2679 my ($objid,$rrefname) = ($1,$2);
2680 if (!$wanted_rref->($rrefname)) {
2682 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2686 $wantr{$rrefname} = $objid;
2689 close GITLS or failedcmd @lcmd;
2691 # OK, now %want is exactly what we want for refs in @specs
2693 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2694 "+refs/$_:".lrfetchrefs."/$_";
2697 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2699 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2700 runcmd_ordryrun_local @fcmd if @fspecs;
2702 if (!$supplementary) {
2703 %lrfetchrefs_f = ();
2707 git_for_each_ref(lrfetchrefs, sub {
2708 my ($objid,$objtype,$lrefname,$reftail) = @_;
2709 $lrfetchrefs_f{$lrefname} = $objid;
2710 $objgot{$objid} = 1;
2713 if ($supplementary) {
2717 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2718 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2719 if (!exists $wantr{$rrefname}) {
2720 if ($wanted_rref->($rrefname)) {
2722 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2726 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2729 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2730 delete $lrfetchrefs_f{$lrefname};
2734 foreach my $rrefname (sort keys %wantr) {
2735 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2736 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2737 my $want = $wantr{$rrefname};
2738 next if $got eq $want;
2739 if (!defined $objgot{$want}) {
2740 fail <<END unless act_local();
2741 --dry-run specified but we actually wanted the results of git fetch,
2742 so this is not going to work. Try running dgit fetch first,
2743 or using --damp-run instead of --dry-run.
2746 warning: git ls-remote suggests we want $lrefname
2747 warning: and it should refer to $want
2748 warning: but git fetch didn't fetch that object to any relevant ref.
2749 warning: This may be due to a race with someone updating the server.
2750 warning: Will try again...
2752 next FETCH_ITERATION;
2755 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2757 runcmd_ordryrun_local @git, qw(update-ref -m),
2758 "dgit fetch git fetch fixup", $lrefname, $want;
2759 $lrfetchrefs_f{$lrefname} = $want;
2764 if (defined $csuite) {
2765 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2766 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2767 my ($objid,$objtype,$lrefname,$reftail) = @_;
2768 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2769 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2773 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2774 Dumper(\%lrfetchrefs_f);
2777 sub git_fetch_us () {
2778 # Want to fetch only what we are going to use, unless
2779 # deliberately-not-ff, in which case we must fetch everything.
2781 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2783 (quiltmode_splitbrain
2784 ? (map { $_->('*',access_nomdistro) }
2785 \&debiantag_new, \&debiantag_maintview)
2786 : debiantags('*',access_nomdistro));
2787 push @specs, server_branch($csuite);
2788 push @specs, $rewritemap;
2789 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2791 my $url = access_giturl();
2792 git_lrfetch_sane $url, 0, @specs;
2795 my @tagpats = debiantags('*',access_nomdistro);
2797 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2798 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2799 printdebug "currently $fullrefname=$objid\n";
2800 $here{$fullrefname} = $objid;
2802 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2803 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2804 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2805 printdebug "offered $lref=$objid\n";
2806 if (!defined $here{$lref}) {
2807 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2808 runcmd_ordryrun_local @upd;
2809 lrfetchref_used $fullrefname;
2810 } elsif ($here{$lref} eq $objid) {
2811 lrfetchref_used $fullrefname;
2814 "Not updating $lref from $here{$lref} to $objid.\n";
2819 #---------- dsc and archive handling ----------
2821 sub mergeinfo_getclogp ($) {
2822 # Ensures thit $mi->{Clogp} exists and returns it
2824 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2827 sub mergeinfo_version ($) {
2828 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2831 sub fetch_from_archive_record_1 ($) {
2833 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2834 cmdoutput @git, qw(log -n2), $hash;
2835 # ... gives git a chance to complain if our commit is malformed
2838 sub fetch_from_archive_record_2 ($) {
2840 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2844 dryrun_report @upd_cmd;
2848 sub parse_dsc_field_def_dsc_distro () {
2849 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2850 dgit.default.distro);
2853 sub parse_dsc_field ($$) {
2854 my ($dsc, $what) = @_;
2856 foreach my $field (@ourdscfield) {
2857 $f = $dsc->{$field};
2862 progress "$what: NO git hash";
2863 parse_dsc_field_def_dsc_distro();
2864 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2865 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2866 progress "$what: specified git info ($dsc_distro)";
2867 $dsc_hint_tag = [ $dsc_hint_tag ];
2868 } elsif ($f =~ m/^\w+\s*$/) {
2870 parse_dsc_field_def_dsc_distro();
2871 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2873 progress "$what: specified git hash";
2875 fail "$what: invalid Dgit info";
2879 sub resolve_dsc_field_commit ($$) {
2880 my ($already_distro, $already_mapref) = @_;
2882 return unless defined $dsc_hash;
2885 defined $already_mapref &&
2886 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2887 ? $already_mapref : undef;
2891 my ($what, @fetch) = @_;
2893 local $idistro = $dsc_distro;
2894 my $lrf = lrfetchrefs;
2896 if (!$chase_dsc_distro) {
2898 "not chasing .dsc distro $dsc_distro: not fetching $what";
2903 ".dsc names distro $dsc_distro: fetching $what";
2905 my $url = access_giturl();
2906 if (!defined $url) {
2907 defined $dsc_hint_url or fail <<END;
2908 .dsc Dgit metadata is in context of distro $dsc_distro
2909 for which we have no configured url and .dsc provides no hint
2912 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2913 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2914 parse_cfg_bool "dsc-url-proto-ok", 'false',
2915 cfg("dgit.dsc-url-proto-ok.$proto",
2916 "dgit.default.dsc-url-proto-ok")
2918 .dsc Dgit metadata is in context of distro $dsc_distro
2919 for which we have no configured url;
2920 .dsc provides hinted url with protocol $proto which is unsafe.
2921 (can be overridden by config - consult documentation)
2923 $url = $dsc_hint_url;
2926 git_lrfetch_sane $url, 1, @fetch;
2931 my $rewrite_enable = do {
2932 local $idistro = $dsc_distro;
2933 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2936 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2937 if (!defined $mapref) {
2938 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2939 $mapref = $lrf.'/'.$rewritemap;
2941 my $rewritemapdata = git_cat_file $mapref.':map';
2942 if (defined $rewritemapdata
2943 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2945 "server's git history rewrite map contains a relevant entry!";
2948 if (defined $dsc_hash) {
2949 progress "using rewritten git hash in place of .dsc value";
2951 progress "server data says .dsc hash is to be disregarded";
2956 if (!defined git_cat_file $dsc_hash) {
2957 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2958 my $lrf = $do_fetch->("additional commits", @tags) &&
2959 defined git_cat_file $dsc_hash
2961 .dsc Dgit metadata requires commit $dsc_hash
2962 but we could not obtain that object anywhere.
2964 foreach my $t (@tags) {
2965 my $fullrefname = $lrf.'/'.$t;
2966 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2967 next unless $lrfetchrefs_f{$fullrefname};
2968 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2969 lrfetchref_used $fullrefname;
2974 sub fetch_from_archive () {
2975 ensure_setup_existing_tree();
2977 # Ensures that lrref() is what is actually in the archive, one way
2978 # or another, according to us - ie this client's
2979 # appropritaely-updated archive view. Also returns the commit id.
2980 # If there is nothing in the archive, leaves lrref alone and
2981 # returns undef. git_fetch_us must have already been called.
2985 parse_dsc_field($dsc, 'last upload to archive');
2986 resolve_dsc_field_commit access_basedistro,
2987 lrfetchrefs."/".$rewritemap
2989 progress "no version available from the archive";
2992 # If the archive's .dsc has a Dgit field, there are three
2993 # relevant git commitids we need to choose between and/or merge
2995 # 1. $dsc_hash: the Dgit field from the archive
2996 # 2. $lastpush_hash: the suite branch on the dgit git server
2997 # 3. $lastfetch_hash: our local tracking brach for the suite
2999 # These may all be distinct and need not be in any fast forward
3002 # If the dsc was pushed to this suite, then the server suite
3003 # branch will have been updated; but it might have been pushed to
3004 # a different suite and copied by the archive. Conversely a more
3005 # recent version may have been pushed with dgit but not appeared
3006 # in the archive (yet).
3008 # $lastfetch_hash may be awkward because archive imports
3009 # (particularly, imports of Dgit-less .dscs) are performed only as
3010 # needed on individual clients, so different clients may perform a
3011 # different subset of them - and these imports are only made
3012 # public during push. So $lastfetch_hash may represent a set of
3013 # imports different to a subsequent upload by a different dgit
3016 # Our approach is as follows:
3018 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3019 # descendant of $dsc_hash, then it was pushed by a dgit user who
3020 # had based their work on $dsc_hash, so we should prefer it.
3021 # Otherwise, $dsc_hash was installed into this suite in the
3022 # archive other than by a dgit push, and (necessarily) after the
3023 # last dgit push into that suite (since a dgit push would have
3024 # been descended from the dgit server git branch); thus, in that
3025 # case, we prefer the archive's version (and produce a
3026 # pseudo-merge to overwrite the dgit server git branch).
3028 # (If there is no Dgit field in the archive's .dsc then
3029 # generate_commit_from_dsc uses the version numbers to decide
3030 # whether the suite branch or the archive is newer. If the suite
3031 # branch is newer it ignores the archive's .dsc; otherwise it
3032 # generates an import of the .dsc, and produces a pseudo-merge to
3033 # overwrite the suite branch with the archive contents.)
3035 # The outcome of that part of the algorithm is the `public view',
3036 # and is same for all dgit clients: it does not depend on any
3037 # unpublished history in the local tracking branch.
3039 # As between the public view and the local tracking branch: The
3040 # local tracking branch is only updated by dgit fetch, and
3041 # whenever dgit fetch runs it includes the public view in the
3042 # local tracking branch. Therefore if the public view is not
3043 # descended from the local tracking branch, the local tracking
3044 # branch must contain history which was imported from the archive
3045 # but never pushed; and, its tip is now out of date. So, we make
3046 # a pseudo-merge to overwrite the old imports and stitch the old
3049 # Finally: we do not necessarily reify the public view (as
3050 # described above). This is so that we do not end up stacking two
3051 # pseudo-merges. So what we actually do is figure out the inputs
3052 # to any public view pseudo-merge and put them in @mergeinputs.
3055 # $mergeinputs[]{Commit}
3056 # $mergeinputs[]{Info}
3057 # $mergeinputs[0] is the one whose tree we use
3058 # @mergeinputs is in the order we use in the actual commit)
3061 # $mergeinputs[]{Message} is a commit message to use
3062 # $mergeinputs[]{ReverseParents} if def specifies that parent
3063 # list should be in opposite order
3064 # Such an entry has no Commit or Info. It applies only when found
3065 # in the last entry. (This ugliness is to support making
3066 # identical imports to previous dgit versions.)
3068 my $lastpush_hash = git_get_ref(lrfetchref());
3069 printdebug "previous reference hash=$lastpush_hash\n";
3070 $lastpush_mergeinput = $lastpush_hash && {
3071 Commit => $lastpush_hash,
3072 Info => "dgit suite branch on dgit git server",
3075 my $lastfetch_hash = git_get_ref(lrref());
3076 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3077 my $lastfetch_mergeinput = $lastfetch_hash && {
3078 Commit => $lastfetch_hash,
3079 Info => "dgit client's archive history view",
3082 my $dsc_mergeinput = $dsc_hash && {
3083 Commit => $dsc_hash,
3084 Info => "Dgit field in .dsc from archive",
3088 my $del_lrfetchrefs = sub {
3091 printdebug "del_lrfetchrefs...\n";
3092 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3093 my $objid = $lrfetchrefs_d{$fullrefname};
3094 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3096 $gur ||= new IO::Handle;
3097 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3099 printf $gur "delete %s %s\n", $fullrefname, $objid;
3102 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3106 if (defined $dsc_hash) {
3107 ensure_we_have_orig();
3108 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3109 @mergeinputs = $dsc_mergeinput
3110 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3111 print STDERR <<END or die $!;
3113 Git commit in archive is behind the last version allegedly pushed/uploaded.
3114 Commit referred to by archive: $dsc_hash
3115 Last version pushed with dgit: $lastpush_hash
3118 @mergeinputs = ($lastpush_mergeinput);
3120 # Archive has .dsc which is not a descendant of the last dgit
3121 # push. This can happen if the archive moves .dscs about.
3122 # Just follow its lead.
3123 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3124 progress "archive .dsc names newer git commit";
3125 @mergeinputs = ($dsc_mergeinput);
3127 progress "archive .dsc names other git commit, fixing up";
3128 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3132 @mergeinputs = generate_commits_from_dsc();
3133 # We have just done an import. Now, our import algorithm might
3134 # have been improved. But even so we do not want to generate
3135 # a new different import of the same package. So if the
3136 # version numbers are the same, just use our existing version.
3137 # If the version numbers are different, the archive has changed
3138 # (perhaps, rewound).
3139 if ($lastfetch_mergeinput &&
3140 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3141 (mergeinfo_version $mergeinputs[0]) )) {
3142 @mergeinputs = ($lastfetch_mergeinput);
3144 } elsif ($lastpush_hash) {
3145 # only in git, not in the archive yet
3146 @mergeinputs = ($lastpush_mergeinput);
3147 print STDERR <<END or die $!;
3149 Package not found in the archive, but has allegedly been pushed using dgit.
3153 printdebug "nothing found!\n";
3154 if (defined $skew_warning_vsn) {
3155 print STDERR <<END or die $!;
3157 Warning: relevant archive skew detected.
3158 Archive allegedly contains $skew_warning_vsn
3159 But we were not able to obtain any version from the archive or git.
3163 unshift @end, $del_lrfetchrefs;
3167 if ($lastfetch_hash &&
3169 my $h = $_->{Commit};
3170 $h and is_fast_fwd($lastfetch_hash, $h);
3171 # If true, one of the existing parents of this commit
3172 # is a descendant of the $lastfetch_hash, so we'll
3173 # be ff from that automatically.
3177 push @mergeinputs, $lastfetch_mergeinput;
3180 printdebug "fetch mergeinfos:\n";
3181 foreach my $mi (@mergeinputs) {
3183 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3185 printdebug sprintf " ReverseParents=%d Message=%s",
3186 $mi->{ReverseParents}, $mi->{Message};
3190 my $compat_info= pop @mergeinputs
3191 if $mergeinputs[$#mergeinputs]{Message};
3193 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3196 if (@mergeinputs > 1) {
3198 my $tree_commit = $mergeinputs[0]{Commit};
3200 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3201 $tree =~ m/\n\n/; $tree = $`;
3202 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3205 # We use the changelog author of the package in question the
3206 # author of this pseudo-merge. This is (roughly) correct if
3207 # this commit is simply representing aa non-dgit upload.
3208 # (Roughly because it does not record sponsorship - but we
3209 # don't have sponsorship info because that's in the .changes,
3210 # which isn't in the archivw.)
3212 # But, it might be that we are representing archive history
3213 # updates (including in-archive copies). These are not really
3214 # the responsibility of the person who created the .dsc, but
3215 # there is no-one whose name we should better use. (The
3216 # author of the .dsc-named commit is clearly worse.)
3218 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3219 my $author = clogp_authline $useclogp;
3220 my $cversion = getfield $useclogp, 'Version';
3222 my $mcf = dgit_privdir()."/mergecommit";
3223 open MC, ">", $mcf or die "$mcf $!";
3224 print MC <<END or die $!;
3228 my @parents = grep { $_->{Commit} } @mergeinputs;
3229 @parents = reverse @parents if $compat_info->{ReverseParents};
3230 print MC <<END or die $! foreach @parents;
3234 print MC <<END or die $!;
3240 if (defined $compat_info->{Message}) {
3241 print MC $compat_info->{Message} or die $!;
3243 print MC <<END or die $!;
3244 Record $package ($cversion) in archive suite $csuite
3248 my $message_add_info = sub {
3250 my $mversion = mergeinfo_version $mi;
3251 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3255 $message_add_info->($mergeinputs[0]);
3256 print MC <<END or die $!;
3257 should be treated as descended from
3259 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3263 $hash = make_commit $mcf;
3265 $hash = $mergeinputs[0]{Commit};
3267 printdebug "fetch hash=$hash\n";
3270 my ($lasth, $what) = @_;
3271 return unless $lasth;
3272 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3275 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3277 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3279 fetch_from_archive_record_1($hash);
3281 if (defined $skew_warning_vsn) {
3282 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3283 my $gotclogp = commit_getclogp($hash);
3284 my $got_vsn = getfield $gotclogp, 'Version';
3285 printdebug "SKEW CHECK GOT $got_vsn\n";
3286 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3287 print STDERR <<END or die $!;
3289 Warning: archive skew detected. Using the available version:
3290 Archive allegedly contains $skew_warning_vsn
3291 We were able to obtain only $got_vsn
3297 if ($lastfetch_hash ne $hash) {
3298 fetch_from_archive_record_2($hash);
3301 lrfetchref_used lrfetchref();
3303 check_gitattrs($hash, "fetched source tree");
3305 unshift @end, $del_lrfetchrefs;
3309 sub set_local_git_config ($$) {
3311 runcmd @git, qw(config), $k, $v;
3314 sub setup_mergechangelogs (;$) {
3316 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3318 my $driver = 'dpkg-mergechangelogs';
3319 my $cb = "merge.$driver";
3320 confess unless defined $maindir;
3321 my $attrs = "$maindir_gitcommon/info/attributes";
3322 ensuredir "$maindir_gitcommon/info";
3324 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3325 if (!open ATTRS, "<", $attrs) {
3326 $!==ENOENT or die "$attrs: $!";
3330 next if m{^debian/changelog\s};
3331 print NATTRS $_, "\n" or die $!;
3333 ATTRS->error and die $!;
3336 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3339 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3340 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3342 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3345 sub setup_useremail (;$) {
3347 return unless $always || access_cfg_bool(1, 'setup-useremail');
3350 my ($k, $envvar) = @_;
3351 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3352 return unless defined $v;
3353 set_local_git_config "user.$k", $v;
3356 $setup->('email', 'DEBEMAIL');
3357 $setup->('name', 'DEBFULLNAME');
3360 sub ensure_setup_existing_tree () {
3361 my $k = "remote.$remotename.skipdefaultupdate";
3362 my $c = git_get_config $k;
3363 return if defined $c;
3364 set_local_git_config $k, 'true';
3367 sub open_main_gitattrs () {
3368 confess 'internal error no maindir' unless defined $maindir;
3369 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3371 or die "open $maindir_gitcommon/info/attributes: $!";
3375 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3377 sub is_gitattrs_setup () {
3380 # 1: gitattributes set up and should be left alone
3382 # 0: there is a dgit-defuse-attrs but it needs fixing
3383 # undef: there is none
3384 my $gai = open_main_gitattrs();
3385 return 0 unless $gai;
3387 next unless m{$gitattrs_ourmacro_re};
3388 return 1 if m{\s-working-tree-encoding\s};
3389 printdebug "is_gitattrs_setup: found old macro\n";
3392 $gai->error and die $!;
3393 printdebug "is_gitattrs_setup: found nothing\n";
3397 sub setup_gitattrs (;$) {
3399 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3401 my $already = is_gitattrs_setup();
3404 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3405 not doing further gitattributes setup
3409 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3410 my $af = "$maindir_gitcommon/info/attributes";
3411 ensuredir "$maindir_gitcommon/info";
3413 open GAO, "> $af.new" or die $!;
3414 print GAO <<END or die $! unless defined $already;
3417 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3419 my $gai = open_main_gitattrs();
3422 if (m{$gitattrs_ourmacro_re}) {
3423 die unless defined $already;
3427 print GAO $_, "\n" or die $!;
3429 $gai->error and die $!;
3431 close GAO or die $!;
3432 rename "$af.new", "$af" or die "install $af: $!";
3435 sub setup_new_tree () {
3436 setup_mergechangelogs();
3441 sub check_gitattrs ($$) {
3442 my ($treeish, $what) = @_;
3444 return if is_gitattrs_setup;
3447 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3449 my $gafl = new IO::File;
3450 open $gafl, "-|", @cmd or die $!;
3453 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3455 next unless m{(?:^|/)\.gitattributes$};
3457 # oh dear, found one
3459 dgit: warning: $what contains .gitattributes
3460 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3465 # tree contains no .gitattributes files
3466 $?=0; $!=0; close $gafl or failedcmd @cmd;
3470 sub multisuite_suite_child ($$$) {
3471 my ($tsuite, $merginputs, $fn) = @_;
3472 # in child, sets things up, calls $fn->(), and returns undef
3473 # in parent, returns canonical suite name for $tsuite
3474 my $canonsuitefh = IO::File::new_tmpfile;
3475 my $pid = fork // die $!;
3479 $us .= " [$isuite]";
3480 $debugprefix .= " ";
3481 progress "fetching $tsuite...";
3482 canonicalise_suite();
3483 print $canonsuitefh $csuite, "\n" or die $!;
3484 close $canonsuitefh or die $!;
3488 waitpid $pid,0 == $pid or die $!;
3489 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3490 seek $canonsuitefh,0,0 or die $!;
3491 local $csuite = <$canonsuitefh>;
3492 die $! unless defined $csuite && chomp $csuite;
3494 printdebug "multisuite $tsuite missing\n";
3497 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3498 push @$merginputs, {
3505 sub fork_for_multisuite ($) {
3506 my ($before_fetch_merge) = @_;
3507 # if nothing unusual, just returns ''
3510 # returns 0 to caller in child, to do first of the specified suites
3511 # in child, $csuite is not yet set
3513 # returns 1 to caller in parent, to finish up anything needed after
3514 # in parent, $csuite is set to canonicalised portmanteau
3516 my $org_isuite = $isuite;
3517 my @suites = split /\,/, $isuite;
3518 return '' unless @suites > 1;
3519 printdebug "fork_for_multisuite: @suites\n";
3523 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3525 return 0 unless defined $cbasesuite;
3527 fail "package $package missing in (base suite) $cbasesuite"
3528 unless @mergeinputs;
3530 my @csuites = ($cbasesuite);
3532 $before_fetch_merge->();
3534 foreach my $tsuite (@suites[1..$#suites]) {
3535 $tsuite =~ s/^-/$cbasesuite-/;
3536 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3542 # xxx collecte the ref here
3544 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3545 push @csuites, $csubsuite;
3548 foreach my $mi (@mergeinputs) {
3549 my $ref = git_get_ref $mi->{Ref};
3550 die "$mi->{Ref} ?" unless length $ref;
3551 $mi->{Commit} = $ref;
3554 $csuite = join ",", @csuites;
3556 my $previous = git_get_ref lrref;
3558 unshift @mergeinputs, {
3559 Commit => $previous,
3560 Info => "local combined tracking branch",
3562 "archive seems to have rewound: local tracking branch is ahead!",
3566 foreach my $ix (0..$#mergeinputs) {
3567 $mergeinputs[$ix]{Index} = $ix;
3570 @mergeinputs = sort {
3571 -version_compare(mergeinfo_version $a,
3572 mergeinfo_version $b) # highest version first
3574 $a->{Index} <=> $b->{Index}; # earliest in spec first
3580 foreach my $mi (@mergeinputs) {
3581 printdebug "multisuite merge check $mi->{Info}\n";
3582 foreach my $previous (@needed) {
3583 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3584 printdebug "multisuite merge un-needed $previous->{Info}\n";
3588 printdebug "multisuite merge this-needed\n";
3589 $mi->{Character} = '+';
3592 $needed[0]{Character} = '*';
3594 my $output = $needed[0]{Commit};
3597 printdebug "multisuite merge nontrivial\n";
3598 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3600 my $commit = "tree $tree\n";
3601 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3602 "Input branches:\n";
3604 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3605 printdebug "multisuite merge include $mi->{Info}\n";
3606 $mi->{Character} //= ' ';
3607 $commit .= "parent $mi->{Commit}\n";
3608 $msg .= sprintf " %s %-25s %s\n",
3610 (mergeinfo_version $mi),
3613 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3615 " * marks the highest version branch, which choose to use\n".
3616 " + marks each branch which was not already an ancestor\n\n".
3617 "[dgit multi-suite $csuite]\n";
3619 "author $authline\n".
3620 "committer $authline\n\n";
3621 $output = make_commit_text $commit.$msg;
3622 printdebug "multisuite merge generated $output\n";
3625 fetch_from_archive_record_1($output);
3626 fetch_from_archive_record_2($output);
3628 progress "calculated combined tracking suite $csuite";
3633 sub clone_set_head () {
3634 open H, "> .git/HEAD" or die $!;
3635 print H "ref: ".lref()."\n" or die $!;
3638 sub clone_finish ($) {
3640 runcmd @git, qw(reset --hard), lrref();
3641 runcmd qw(bash -ec), <<'END';
3643 git ls-tree -r --name-only -z HEAD | \
3644 xargs -0r touch -h -r . --
3646 printdone "ready for work in $dstdir";
3650 # in multisuite, returns twice!
3651 # once in parent after first suite fetched,
3652 # and then again in child after everything is finished
3654 badusage "dry run makes no sense with clone" unless act_local();
3656 my $multi_fetched = fork_for_multisuite(sub {
3657 printdebug "multi clone before fetch merge\n";
3661 if ($multi_fetched) {
3662 printdebug "multi clone after fetch merge\n";
3664 clone_finish($dstdir);
3667 printdebug "clone main body\n";
3669 canonicalise_suite();
3670 my $hasgit = check_for_git();
3671 mkdir $dstdir or fail "create \`$dstdir': $!";
3673 runcmd @git, qw(init -q);
3677 my $giturl = access_giturl(1);
3678 if (defined $giturl) {
3679 runcmd @git, qw(remote add), 'origin', $giturl;
3682 progress "fetching existing git history";
3684 runcmd_ordryrun_local @git, qw(fetch origin);
3686 progress "starting new git history";
3688 fetch_from_archive() or no_such_package;
3689 my $vcsgiturl = $dsc->{'Vcs-Git'};
3690 if (length $vcsgiturl) {
3691 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3692 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3694 clone_finish($dstdir);
3698 canonicalise_suite();
3699 if (check_for_git()) {
3702 fetch_from_archive() or no_such_package();
3704 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3705 if (length $vcsgiturl and
3706 (grep { $csuite eq $_ }
3708 cfg 'dgit.vcs-git.suites')) {
3709 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3710 if (defined $current && $current ne $vcsgiturl) {
3712 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3713 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3717 printdone "fetched into ".lrref();
3721 my $multi_fetched = fork_for_multisuite(sub { });
3722 fetch_one() unless $multi_fetched; # parent
3723 finish 0 if $multi_fetched eq '0'; # child
3728 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3730 printdone "fetched to ".lrref()." and merged into HEAD";
3733 sub check_not_dirty () {
3734 foreach my $f (qw(local-options local-patch-header)) {
3735 if (stat_exists "debian/source/$f") {
3736 fail "git tree contains debian/source/$f";
3740 return if $includedirty;
3742 git_check_unmodified();
3745 sub commit_admin ($) {
3748 runcmd_ordryrun_local @git, qw(commit -m), $m;
3751 sub quiltify_nofix_bail ($$) {
3752 my ($headinfo, $xinfo) = @_;
3753 if ($quilt_mode eq 'nofix') {
3754 fail "quilt fixup required but quilt mode is \`nofix'\n".
3755 "HEAD commit".$headinfo." differs from tree implied by ".
3756 " debian/patches".$xinfo;
3760 sub commit_quilty_patch () {
3761 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3763 foreach my $l (split /\n/, $output) {
3764 next unless $l =~ m/\S/;
3765 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3769 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3771 progress "nothing quilty to commit, ok.";
3774 quiltify_nofix_bail "", " (wanted to commit patch update)";
3775 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3776 runcmd_ordryrun_local @git, qw(add -f), @adds;
3778 Commit Debian 3.0 (quilt) metadata
3780 [dgit ($our_version) quilt-fixup]
3784 sub get_source_format () {
3786 if (open F, "debian/source/options") {
3790 s/\s+$//; # ignore missing final newline
3792 my ($k, $v) = ($`, $'); #');
3793 $v =~ s/^"(.*)"$/$1/;
3799 F->error and die $!;
3802 die $! unless $!==&ENOENT;
3805 if (!open F, "debian/source/format") {
3806 die $! unless $!==&ENOENT;
3810 F->error and die $!;
3812 return ($_, \%options);
3815 sub madformat_wantfixup ($) {
3817 return 0 unless $format eq '3.0 (quilt)';
3818 our $quilt_mode_warned;
3819 if ($quilt_mode eq 'nocheck') {
3820 progress "Not doing any fixup of \`$format' due to".
3821 " ----no-quilt-fixup or --quilt=nocheck"
3822 unless $quilt_mode_warned++;
3825 progress "Format \`$format', need to check/update patch stack"
3826 unless $quilt_mode_warned++;
3830 sub maybe_split_brain_save ($$$) {
3831 my ($headref, $dgitview, $msg) = @_;
3832 # => message fragment "$saved" describing disposition of $dgitview
3833 return "commit id $dgitview" unless defined $split_brain_save;
3834 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3836 "dgit --dgit-view-save $msg HEAD=$headref",
3837 $split_brain_save, $dgitview);
3839 return "and left in $split_brain_save";
3842 # An "infopair" is a tuple [ $thing, $what ]
3843 # (often $thing is a commit hash; $what is a description)
3845 sub infopair_cond_equal ($$) {
3847 $x->[0] eq $y->[0] or fail <<END;
3848 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3852 sub infopair_lrf_tag_lookup ($$) {
3853 my ($tagnames, $what) = @_;
3854 # $tagname may be an array ref
3855 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3856 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3857 foreach my $tagname (@tagnames) {
3858 my $lrefname = lrfetchrefs."/tags/$tagname";
3859 my $tagobj = $lrfetchrefs_f{$lrefname};
3860 next unless defined $tagobj;
3861 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3862 return [ git_rev_parse($tagobj), $what ];
3864 fail @tagnames==1 ? <<END : <<END;
3865 Wanted tag $what (@tagnames) on dgit server, but not found
3867 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3871 sub infopair_cond_ff ($$) {
3872 my ($anc,$desc) = @_;
3873 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3874 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3878 sub pseudomerge_version_check ($$) {
3879 my ($clogp, $archive_hash) = @_;
3881 my $arch_clogp = commit_getclogp $archive_hash;
3882 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3883 'version currently in archive' ];
3884 if (defined $overwrite_version) {
3885 if (length $overwrite_version) {
3886 infopair_cond_equal([ $overwrite_version,
3887 '--overwrite= version' ],
3890 my $v = $i_arch_v->[0];
3891 progress "Checking package changelog for archive version $v ...";
3894 my @xa = ("-f$v", "-t$v");
3895 my $vclogp = parsechangelog @xa;
3898 [ (getfield $vclogp, $fn),
3899 "$fn field from dpkg-parsechangelog @xa" ];
3901 my $cv = $gf->('Version');
3902 infopair_cond_equal($i_arch_v, $cv);
3903 $cd = $gf->('Distribution');
3906 $@ =~ s/^dgit: //gm;
3908 "Perhaps debian/changelog does not mention $v ?";
3910 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3911 $cd->[1] is $cd->[0]
3912 Your tree seems to based on earlier (not uploaded) $v.
3917 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3921 sub pseudomerge_make_commit ($$$$ $$) {
3922 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3923 $msg_cmd, $msg_msg) = @_;
3924 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3926 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3927 my $authline = clogp_authline $clogp;
3931 !defined $overwrite_version ? ""
3932 : !length $overwrite_version ? " --overwrite"
3933 : " --overwrite=".$overwrite_version;
3935 # Contributing parent is the first parent - that makes
3936 # git rev-list --first-parent DTRT.
3937 my $pmf = dgit_privdir()."/pseudomerge";
3938 open MC, ">", $pmf or die "$pmf $!";
3939 print MC <<END or die $!;
3942 parent $archive_hash
3952 return make_commit($pmf);
3955 sub splitbrain_pseudomerge ($$$$) {
3956 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3957 # => $merged_dgitview
3958 printdebug "splitbrain_pseudomerge...\n";
3960 # We: debian/PREVIOUS HEAD($maintview)
3961 # expect: o ----------------- o
3964 # a/d/PREVIOUS $dgitview
3967 # we do: `------------------ o
3971 return $dgitview unless defined $archive_hash;
3972 return $dgitview if deliberately_not_fast_forward();
3974 printdebug "splitbrain_pseudomerge...\n";
3976 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3978 if (!defined $overwrite_version) {
3979 progress "Checking that HEAD inciudes all changes in archive...";
3982 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3984 if (defined $overwrite_version) {
3986 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3987 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3988 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3989 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3990 my $i_archive = [ $archive_hash, "current archive contents" ];
3992 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3994 infopair_cond_equal($i_dgit, $i_archive);
3995 infopair_cond_ff($i_dep14, $i_dgit);
3996 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3999 $@ =~ s/^\n//; chomp $@;
4002 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4007 my $r = pseudomerge_make_commit
4008 $clogp, $dgitview, $archive_hash, $i_arch_v,
4009 "dgit --quilt=$quilt_mode",
4010 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4011 Declare fast forward from $i_arch_v->[0]
4013 Make fast forward from $i_arch_v->[0]
4016 maybe_split_brain_save $maintview, $r, "pseudomerge";
4018 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4022 sub plain_overwrite_pseudomerge ($$$) {
4023 my ($clogp, $head, $archive_hash) = @_;
4025 printdebug "plain_overwrite_pseudomerge...";
4027 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4029 return $head if is_fast_fwd $archive_hash, $head;
4031 my $m = "Declare fast forward from $i_arch_v->[0]";
4033 my $r = pseudomerge_make_commit
4034 $clogp, $head, $archive_hash, $i_arch_v,
4037 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4039 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4043 sub push_parse_changelog ($) {
4046 my $clogp = Dpkg::Control::Hash->new();
4047 $clogp->load($clogpfn) or die;
4049 my $clogpackage = getfield $clogp, 'Source';
4050 $package //= $clogpackage;
4051 fail "-p specified $package but changelog specified $clogpackage"
4052 unless $package eq $clogpackage;
4053 my $cversion = getfield $clogp, 'Version';
4055 if (!$we_are_initiator) {
4056 # rpush initiator can't do this because it doesn't have $isuite yet
4057 my $tag = debiantag($cversion, access_nomdistro);
4058 runcmd @git, qw(check-ref-format), $tag;
4061 my $dscfn = dscfn($cversion);
4063 return ($clogp, $cversion, $dscfn);
4066 sub push_parse_dsc ($$$) {
4067 my ($dscfn,$dscfnwhat, $cversion) = @_;
4068 $dsc = parsecontrol($dscfn,$dscfnwhat);
4069 my $dversion = getfield $dsc, 'Version';
4070 my $dscpackage = getfield $dsc, 'Source';
4071 ($dscpackage eq $package && $dversion eq $cversion) or
4072 fail "$dscfn is for $dscpackage $dversion".
4073 " but debian/changelog is for $package $cversion";
4076 sub push_tagwants ($$$$) {
4077 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4080 TagFn => \&debiantag,
4085 if (defined $maintviewhead) {
4087 TagFn => \&debiantag_maintview,
4088 Objid => $maintviewhead,
4089 TfSuffix => '-maintview',
4092 } elsif ($dodep14tag eq 'no' ? 0
4093 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4094 : $dodep14tag eq 'always'
4095 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4096 --dep14tag-always (or equivalent in config) means server must support
4097 both "new" and "maint" tag formats, but config says it doesn't.
4099 : die "$dodep14tag ?") {
4101 TagFn => \&debiantag_maintview,
4103 TfSuffix => '-dgit',
4107 foreach my $tw (@tagwants) {
4108 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4109 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4111 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4115 sub push_mktags ($$ $$ $) {
4117 $changesfile,$changesfilewhat,
4120 die unless $tagwants->[0]{View} eq 'dgit';
4122 my $declaredistro = access_nomdistro();
4123 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4124 $dsc->{$ourdscfield[0]} = join " ",
4125 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4127 $dsc->save("$dscfn.tmp") or die $!;
4129 my $changes = parsecontrol($changesfile,$changesfilewhat);
4130 foreach my $field (qw(Source Distribution Version)) {
4131 $changes->{$field} eq $clogp->{$field} or
4132 fail "changes field $field \`$changes->{$field}'".
4133 " does not match changelog \`$clogp->{$field}'";
4136 my $cversion = getfield $clogp, 'Version';
4137 my $clogsuite = getfield $clogp, 'Distribution';
4139 # We make the git tag by hand because (a) that makes it easier
4140 # to control the "tagger" (b) we can do remote signing
4141 my $authline = clogp_authline $clogp;
4142 my $delibs = join(" ", "",@deliberatelies);
4146 my $tfn = $tw->{Tfn};
4147 my $head = $tw->{Objid};
4148 my $tag = $tw->{Tag};
4150 open TO, '>', $tfn->('.tmp') or die $!;
4151 print TO <<END or die $!;
4158 if ($tw->{View} eq 'dgit') {
4159 print TO <<END or die $!;
4160 $package release $cversion for $clogsuite ($csuite) [dgit]
4161 [dgit distro=$declaredistro$delibs]
4163 foreach my $ref (sort keys %previously) {
4164 print TO <<END or die $!;
4165 [dgit previously:$ref=$previously{$ref}]
4168 } elsif ($tw->{View} eq 'maint') {
4169 print TO <<END or die $!;
4170 $package release $cversion for $clogsuite ($csuite)
4171 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4174 die Dumper($tw)."?";
4179 my $tagobjfn = $tfn->('.tmp');
4181 if (!defined $keyid) {
4182 $keyid = access_cfg('keyid','RETURN-UNDEF');
4184 if (!defined $keyid) {
4185 $keyid = getfield $clogp, 'Maintainer';
4187 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4188 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4189 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4190 push @sign_cmd, $tfn->('.tmp');
4191 runcmd_ordryrun @sign_cmd;
4193 $tagobjfn = $tfn->('.signed.tmp');
4194 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4195 $tfn->('.tmp'), $tfn->('.tmp.asc');
4201 my @r = map { $mktag->($_); } @$tagwants;
4205 sub sign_changes ($) {
4206 my ($changesfile) = @_;
4208 my @debsign_cmd = @debsign;
4209 push @debsign_cmd, "-k$keyid" if defined $keyid;
4210 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4211 push @debsign_cmd, $changesfile;
4212 runcmd_ordryrun @debsign_cmd;
4217 printdebug "actually entering push\n";
4219 supplementary_message(<<'END');
4220 Push failed, while checking state of the archive.
4221 You can retry the push, after fixing the problem, if you like.
4223 if (check_for_git()) {
4226 my $archive_hash = fetch_from_archive();
4227 if (!$archive_hash) {
4229 fail "package appears to be new in this suite;".
4230 " if this is intentional, use --new";
4233 supplementary_message(<<'END');
4234 Push failed, while preparing your push.
4235 You can retry the push, after fixing the problem, if you like.
4238 need_tagformat 'new', "quilt mode $quilt_mode"
4239 if quiltmode_splitbrain;
4243 access_giturl(); # check that success is vaguely likely
4244 rpush_handle_protovsn_bothends() if $we_are_initiator;
4247 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4248 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4250 responder_send_file('parsed-changelog', $clogpfn);
4252 my ($clogp, $cversion, $dscfn) =
4253 push_parse_changelog("$clogpfn");
4255 my $dscpath = "$buildproductsdir/$dscfn";
4256 stat_exists $dscpath or
4257 fail "looked for .dsc $dscpath, but $!;".
4258 " maybe you forgot to build";
4260 responder_send_file('dsc', $dscpath);
4262 push_parse_dsc($dscpath, $dscfn, $cversion);
4264 my $format = getfield $dsc, 'Format';
4265 printdebug "format $format\n";
4267 my $symref = git_get_symref();
4268 my $actualhead = git_rev_parse('HEAD');
4270 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4271 runcmd_ordryrun_local @git_debrebase, 'stitch';
4272 $actualhead = git_rev_parse('HEAD');
4275 my $dgithead = $actualhead;
4276 my $maintviewhead = undef;
4278 my $upstreamversion = upstreamversion $clogp->{Version};
4280 if (madformat_wantfixup($format)) {
4281 # user might have not used dgit build, so maybe do this now:
4282 if (quiltmode_splitbrain()) {
4283 changedir $playground;
4284 quilt_make_fake_dsc($upstreamversion);
4286 ($dgithead, $cachekey) =
4287 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4289 "--quilt=$quilt_mode but no cached dgit view:
4290 perhaps HEAD changed since dgit build[-source] ?";
4292 $dgithead = splitbrain_pseudomerge($clogp,
4293 $actualhead, $dgithead,
4295 $maintviewhead = $actualhead;
4297 prep_ud(); # so _only_subdir() works, below
4299 commit_quilty_patch();
4303 if (defined $overwrite_version && !defined $maintviewhead
4305 $dgithead = plain_overwrite_pseudomerge($clogp,
4313 if ($archive_hash) {
4314 if (is_fast_fwd($archive_hash, $dgithead)) {
4316 } elsif (deliberately_not_fast_forward) {
4319 fail "dgit push: HEAD is not a descendant".
4320 " of the archive's version.\n".
4321 "To overwrite the archive's contents,".
4322 " pass --overwrite[=VERSION].\n".
4323 "To rewind history, if permitted by the archive,".
4324 " use --deliberately-not-fast-forward.";
4328 changedir $playground;
4329 progress "checking that $dscfn corresponds to HEAD";
4330 runcmd qw(dpkg-source -x --),
4331 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4332 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4333 check_for_vendor_patches() if madformat($dsc->{format});
4335 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4336 debugcmd "+",@diffcmd;
4338 my $r = system @diffcmd;
4341 my $referent = $split_brain ? $dgithead : 'HEAD';
4342 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4345 my $raw = cmdoutput @git,
4346 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4348 foreach (split /\0/, $raw) {
4349 if (defined $changed) {
4350 push @mode_changes, "$changed: $_\n" if $changed;
4353 } elsif (m/^:0+ 0+ /) {
4355 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4356 $changed = "Mode change from $1 to $2"
4361 if (@mode_changes) {
4362 fail <<END.(join '', @mode_changes).<<END;
4363 HEAD specifies a different tree to $dscfn:
4366 There is a problem with your source tree (see dgit(7) for some hints).
4367 To see a full diff, run git diff $tree $referent
4372 HEAD specifies a different tree to $dscfn:
4374 Perhaps you forgot to build. Or perhaps there is a problem with your
4375 source tree (see dgit(7) for some hints). To see a full diff, run
4376 git diff $tree $referent
4382 if (!$changesfile) {
4383 my $pat = changespat $cversion;
4384 my @cs = glob "$buildproductsdir/$pat";
4385 fail "failed to find unique changes file".
4386 " (looked for $pat in $buildproductsdir);".
4387 " perhaps you need to use dgit -C"
4389 ($changesfile) = @cs;
4391 $changesfile = "$buildproductsdir/$changesfile";
4394 # Check that changes and .dsc agree enough
4395 $changesfile =~ m{[^/]*$};
4396 my $changes = parsecontrol($changesfile,$&);
4397 files_compare_inputs($dsc, $changes)
4398 unless forceing [qw(dsc-changes-mismatch)];
4400 # Check whether this is a source only upload
4401 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4402 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4403 if ($sourceonlypolicy eq 'ok') {
4404 } elsif ($sourceonlypolicy eq 'always') {
4405 forceable_fail [qw(uploading-binaries)],
4406 "uploading binaries, although distroy policy is source only"
4408 } elsif ($sourceonlypolicy eq 'never') {
4409 forceable_fail [qw(uploading-source-only)],
4410 "source-only upload, although distroy policy requires .debs"
4412 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4413 forceable_fail [qw(uploading-source-only)],
4414 "source-only upload, even though package is entirely NEW\n".
4415 "(this is contrary to policy in ".(access_nomdistro()).")"
4418 && !(archive_query('package_not_wholly_new', $package) // 1);
4420 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4423 # Perhaps adjust .dsc to contain right set of origs
4424 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4426 unless forceing [qw(changes-origs-exactly)];
4428 # Checks complete, we're going to try and go ahead:
4430 responder_send_file('changes',$changesfile);
4431 responder_send_command("param head $dgithead");
4432 responder_send_command("param csuite $csuite");
4433 responder_send_command("param isuite $isuite");
4434 responder_send_command("param tagformat $tagformat");
4435 if (defined $maintviewhead) {
4436 die unless ($protovsn//4) >= 4;
4437 responder_send_command("param maint-view $maintviewhead");
4440 # Perhaps send buildinfo(s) for signing
4441 my $changes_files = getfield $changes, 'Files';
4442 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4443 foreach my $bi (@buildinfos) {
4444 responder_send_command("param buildinfo-filename $bi");
4445 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4448 if (deliberately_not_fast_forward) {
4449 git_for_each_ref(lrfetchrefs, sub {
4450 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4451 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4452 responder_send_command("previously $rrefname=$objid");
4453 $previously{$rrefname} = $objid;
4457 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4458 dgit_privdir()."/tag");
4461 supplementary_message(<<'END');
4462 Push failed, while signing the tag.
4463 You can retry the push, after fixing the problem, if you like.
4465 # If we manage to sign but fail to record it anywhere, it's fine.
4466 if ($we_are_responder) {
4467 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4468 responder_receive_files('signed-tag', @tagobjfns);
4470 @tagobjfns = push_mktags($clogp,$dscpath,
4471 $changesfile,$changesfile,
4474 supplementary_message(<<'END');
4475 Push failed, *after* signing the tag.
4476 If you want to try again, you should use a new version number.
4479 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4481 foreach my $tw (@tagwants) {
4482 my $tag = $tw->{Tag};
4483 my $tagobjfn = $tw->{TagObjFn};
4485 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4486 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4487 runcmd_ordryrun_local
4488 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4491 supplementary_message(<<'END');
4492 Push failed, while updating the remote git repository - see messages above.
4493 If you want to try again, you should use a new version number.
4495 if (!check_for_git()) {
4496 create_remote_git_repo();
4499 my @pushrefs = $forceflag.$dgithead.":".rrref();
4500 foreach my $tw (@tagwants) {
4501 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4504 runcmd_ordryrun @git,
4505 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4506 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4508 supplementary_message(<<'END');
4509 Push failed, while obtaining signatures on the .changes and .dsc.
4510 If it was just that the signature failed, you may try again by using
4511 debsign by hand to sign the changes
4513 and then dput to complete the upload.
4514 If you need to change the package, you must use a new version number.
4516 if ($we_are_responder) {
4517 my $dryrunsuffix = act_local() ? "" : ".tmp";
4518 my @rfiles = ($dscpath, $changesfile);
4519 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4520 responder_receive_files('signed-dsc-changes',
4521 map { "$_$dryrunsuffix" } @rfiles);
4524 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4526 progress "[new .dsc left in $dscpath.tmp]";
4528 sign_changes $changesfile;
4531 supplementary_message(<<END);
4532 Push failed, while uploading package(s) to the archive server.
4533 You can retry the upload of exactly these same files with dput of:
4535 If that .changes file is broken, you will need to use a new version
4536 number for your next attempt at the upload.
4538 my $host = access_cfg('upload-host','RETURN-UNDEF');
4539 my @hostarg = defined($host) ? ($host,) : ();
4540 runcmd_ordryrun @dput, @hostarg, $changesfile;
4541 printdone "pushed and uploaded $cversion";
4543 supplementary_message('');
4544 responder_send_command("complete");
4548 not_necessarily_a_tree();
4553 badusage "-p is not allowed with clone; specify as argument instead"
4554 if defined $package;
4557 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4558 ($package,$isuite) = @ARGV;
4559 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4560 ($package,$dstdir) = @ARGV;
4561 } elsif (@ARGV==3) {
4562 ($package,$isuite,$dstdir) = @ARGV;
4564 badusage "incorrect arguments to dgit clone";
4568 $dstdir ||= "$package";
4569 if (stat_exists $dstdir) {
4570 fail "$dstdir already exists";
4574 if ($rmonerror && !$dryrun_level) {
4575 $cwd_remove= getcwd();
4577 return unless defined $cwd_remove;
4578 if (!chdir "$cwd_remove") {
4579 return if $!==&ENOENT;
4580 die "chdir $cwd_remove: $!";
4582 printdebug "clone rmonerror removing $dstdir\n";
4584 rmtree($dstdir) or die "remove $dstdir: $!\n";
4585 } elsif (grep { $! == $_ }
4586 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4588 print STDERR "check whether to remove $dstdir: $!\n";
4594 $cwd_remove = undef;
4597 sub branchsuite () {
4598 my $branch = git_get_symref();
4599 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4606 sub package_from_d_control () {
4607 if (!defined $package) {
4608 my $sourcep = parsecontrol('debian/control','debian/control');
4609 $package = getfield $sourcep, 'Source';
4613 sub fetchpullargs () {
4614 package_from_d_control();
4616 $isuite = branchsuite();
4618 my $clogp = parsechangelog();
4619 my $clogsuite = getfield $clogp, 'Distribution';
4620 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4622 } elsif (@ARGV==1) {
4625 badusage "incorrect arguments to dgit fetch or dgit pull";
4639 if (quiltmode_splitbrain()) {
4640 my ($format, $fopts) = get_source_format();
4641 madformat($format) and fail <<END
4642 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4650 package_from_d_control();
4651 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4655 foreach my $canon (qw(0 1)) {
4660 canonicalise_suite();
4662 if (length git_get_ref lref()) {
4663 # local branch already exists, yay
4666 if (!length git_get_ref lrref()) {
4674 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4677 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4678 "dgit checkout $isuite";
4679 runcmd (@git, qw(checkout), lbranch());
4682 sub cmd_update_vcs_git () {
4684 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4685 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4687 ($specsuite) = (@ARGV);
4692 if ($ARGV[0] eq '-') {
4694 } elsif ($ARGV[0] eq '-') {
4699 package_from_d_control();
4701 if ($specsuite eq '.') {
4702 $ctrl = parsecontrol 'debian/control', 'debian/control';
4704 $isuite = $specsuite;
4708 my $url = getfield $ctrl, 'Vcs-Git';
4711 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4712 if (!defined $orgurl) {
4713 print STDERR "setting up vcs-git: $url\n";
4714 @cmd = (@git, qw(remote add vcs-git), $url);
4715 } elsif ($orgurl eq $url) {
4716 print STDERR "vcs git already configured: $url\n";
4718 print STDERR "changing vcs-git url to: $url\n";
4719 @cmd = (@git, qw(remote set-url vcs-git), $url);
4721 runcmd_ordryrun_local @cmd;
4723 print "fetching (@ARGV)\n";
4724 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4730 build_or_push_prep_early();
4735 } elsif (@ARGV==1) {
4736 ($specsuite) = (@ARGV);
4738 badusage "incorrect arguments to dgit $subcommand";
4741 local ($package) = $existing_package; # this is a hack
4742 canonicalise_suite();
4744 canonicalise_suite();
4746 if (defined $specsuite &&
4747 $specsuite ne $isuite &&
4748 $specsuite ne $csuite) {
4749 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4750 " but command line specifies $specsuite";
4761 sub cmd_push_source {
4763 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
4764 "sense with push-source!" if $includedirty;
4765 build_maybe_quilt_fixup();
4767 my $changes = parsecontrol("$buildproductsdir/$changesfile",
4768 "source changes file");
4769 unless (test_source_only_changes($changes)) {
4770 fail "user-specified changes file is not source-only";
4773 # Building a source package is very fast, so just do it
4775 die "er, patches are applied dirtily but shouldn't be.."
4776 if $patches_applied_dirtily;
4777 $changesfile = $sourcechanges;
4782 #---------- remote commands' implementation ----------
4784 sub pre_remote_push_build_host {
4785 my ($nrargs) = shift @ARGV;
4786 my (@rargs) = @ARGV[0..$nrargs-1];
4787 @ARGV = @ARGV[$nrargs..$#ARGV];
4789 my ($dir,$vsnwant) = @rargs;
4790 # vsnwant is a comma-separated list; we report which we have
4791 # chosen in our ready response (so other end can tell if they
4794 $we_are_responder = 1;
4795 $us .= " (build host)";
4797 open PI, "<&STDIN" or die $!;
4798 open STDIN, "/dev/null" or die $!;
4799 open PO, ">&STDOUT" or die $!;
4801 open STDOUT, ">&STDERR" or die $!;
4805 ($protovsn) = grep {
4806 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4807 } @rpushprotovsn_support;
4809 fail "build host has dgit rpush protocol versions ".
4810 (join ",", @rpushprotovsn_support).
4811 " but invocation host has $vsnwant"
4812 unless defined $protovsn;
4816 sub cmd_remote_push_build_host {
4817 responder_send_command("dgit-remote-push-ready $protovsn");
4821 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4822 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4823 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4824 # a good error message)
4826 sub rpush_handle_protovsn_bothends () {
4827 if ($protovsn < 4) {
4828 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4837 my $report = i_child_report();
4838 if (defined $report) {
4839 printdebug "($report)\n";
4840 } elsif ($i_child_pid) {
4841 printdebug "(killing build host child $i_child_pid)\n";
4842 kill 15, $i_child_pid;
4844 if (defined $i_tmp && !defined $initiator_tempdir) {
4846 eval { rmtree $i_tmp; };
4851 return unless forkcheck_mainprocess();
4856 my ($base,$selector,@args) = @_;
4857 $selector =~ s/\-/_/g;
4858 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4862 not_necessarily_a_tree();
4867 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4875 push @rargs, join ",", @rpushprotovsn_support;
4878 push @rdgit, @ropts;
4879 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4881 my @cmd = (@ssh, $host, shellquote @rdgit);
4884 $we_are_initiator=1;
4886 if (defined $initiator_tempdir) {
4887 rmtree $initiator_tempdir;
4888 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4889 $i_tmp = $initiator_tempdir;
4893 $i_child_pid = open2(\*RO, \*RI, @cmd);
4895 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4896 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4897 $supplementary_message = '' unless $protovsn >= 3;
4900 my ($icmd,$iargs) = initiator_expect {
4901 m/^(\S+)(?: (.*))?$/;
4904 i_method "i_resp", $icmd, $iargs;
4908 sub i_resp_progress ($) {
4910 my $msg = protocol_read_bytes \*RO, $rhs;
4914 sub i_resp_supplementary_message ($) {
4916 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4919 sub i_resp_complete {
4920 my $pid = $i_child_pid;
4921 $i_child_pid = undef; # prevents killing some other process with same pid
4922 printdebug "waiting for build host child $pid...\n";
4923 my $got = waitpid $pid, 0;
4924 die $! unless $got == $pid;
4925 die "build host child failed $?" if $?;
4928 printdebug "all done\n";
4932 sub i_resp_file ($) {
4934 my $localname = i_method "i_localname", $keyword;
4935 my $localpath = "$i_tmp/$localname";
4936 stat_exists $localpath and
4937 badproto \*RO, "file $keyword ($localpath) twice";
4938 protocol_receive_file \*RO, $localpath;
4939 i_method "i_file", $keyword;
4944 sub i_resp_param ($) {
4945 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4949 sub i_resp_previously ($) {
4950 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4951 or badproto \*RO, "bad previously spec";
4952 my $r = system qw(git check-ref-format), $1;
4953 die "bad previously ref spec ($r)" if $r;
4954 $previously{$1} = $2;
4959 sub i_resp_want ($) {
4961 die "$keyword ?" if $i_wanted{$keyword}++;
4963 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4964 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4965 die unless $isuite =~ m/^$suite_re$/;
4968 rpush_handle_protovsn_bothends();
4970 fail "rpush negotiated protocol version $protovsn".
4971 " which does not support quilt mode $quilt_mode"
4972 if quiltmode_splitbrain;
4974 my @localpaths = i_method "i_want", $keyword;
4975 printdebug "[[ $keyword @localpaths\n";
4976 foreach my $localpath (@localpaths) {
4977 protocol_send_file \*RI, $localpath;
4979 print RI "files-end\n" or die $!;
4982 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4984 sub i_localname_parsed_changelog {
4985 return "remote-changelog.822";
4987 sub i_file_parsed_changelog {
4988 ($i_clogp, $i_version, $i_dscfn) =
4989 push_parse_changelog "$i_tmp/remote-changelog.822";
4990 die if $i_dscfn =~ m#/|^\W#;
4993 sub i_localname_dsc {
4994 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4999 sub i_localname_buildinfo ($) {
5000 my $bi = $i_param{'buildinfo-filename'};
5001 defined $bi or badproto \*RO, "buildinfo before filename";
5002 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5003 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5004 or badproto \*RO, "improper buildinfo filename";
5007 sub i_file_buildinfo {
5008 my $bi = $i_param{'buildinfo-filename'};
5009 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5010 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5011 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5012 files_compare_inputs($bd, $ch);
5013 (getfield $bd, $_) eq (getfield $ch, $_) or
5014 fail "buildinfo mismatch $_"
5015 foreach qw(Source Version);
5016 !defined $bd->{$_} or
5017 fail "buildinfo contains $_"
5018 foreach qw(Changes Changed-by Distribution);
5020 push @i_buildinfos, $bi;
5021 delete $i_param{'buildinfo-filename'};
5024 sub i_localname_changes {
5025 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5026 $i_changesfn = $i_dscfn;
5027 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5028 return $i_changesfn;
5030 sub i_file_changes { }
5032 sub i_want_signed_tag {
5033 printdebug Dumper(\%i_param, $i_dscfn);
5034 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5035 && defined $i_param{'csuite'}
5036 or badproto \*RO, "premature desire for signed-tag";
5037 my $head = $i_param{'head'};
5038 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5040 my $maintview = $i_param{'maint-view'};
5041 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5044 if ($protovsn >= 4) {
5045 my $p = $i_param{'tagformat'} // '<undef>';
5047 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5050 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5052 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5054 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5057 push_mktags $i_clogp, $i_dscfn,
5058 $i_changesfn, 'remote changes',
5062 sub i_want_signed_dsc_changes {
5063 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5064 sign_changes $i_changesfn;
5065 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5068 #---------- building etc. ----------
5073 #----- `3.0 (quilt)' handling -----
5075 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5077 sub quiltify_dpkg_commit ($$$;$) {
5078 my ($patchname,$author,$msg, $xinfo) = @_;
5081 mkpath '.git/dgit'; # we are in playtree
5082 my $descfn = ".git/dgit/quilt-description.tmp";
5083 open O, '>', $descfn or die "$descfn: $!";
5084 $msg =~ s/\n+/\n\n/;
5085 print O <<END or die $!;
5087 ${xinfo}Subject: $msg
5094 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5095 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5096 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5097 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5101 sub quiltify_trees_differ ($$;$$$) {
5102 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5103 # returns true iff the two tree objects differ other than in debian/
5104 # with $finegrained,
5105 # returns bitmask 01 - differ in upstream files except .gitignore
5106 # 02 - differ in .gitignore
5107 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5108 # is set for each modified .gitignore filename $fn
5109 # if $unrepres is defined, array ref to which is appeneded
5110 # a list of unrepresentable changes (removals of upstream files
5113 my @cmd = (@git, qw(diff-tree -z --no-renames));
5114 push @cmd, qw(--name-only) unless $unrepres;
5115 push @cmd, qw(-r) if $finegrained || $unrepres;
5117 my $diffs= cmdoutput @cmd;
5120 foreach my $f (split /\0/, $diffs) {
5121 if ($unrepres && !@lmodes) {
5122 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5125 my ($oldmode,$newmode) = @lmodes;
5128 next if $f =~ m#^debian(?:/.*)?$#s;
5132 die "not a plain file or symlink\n"
5133 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5134 $oldmode =~ m/^(?:10|12)\d{4}$/;
5135 if ($oldmode =~ m/[^0]/ &&
5136 $newmode =~ m/[^0]/) {
5137 # both old and new files exist
5138 die "mode or type changed\n" if $oldmode ne $newmode;
5139 die "modified symlink\n" unless $newmode =~ m/^10/;
5140 } elsif ($oldmode =~ m/[^0]/) {
5142 die "deletion of symlink\n"
5143 unless $oldmode =~ m/^10/;
5146 die "creation with non-default mode\n"
5147 unless $newmode =~ m/^100644$/ or
5148 $newmode =~ m/^120000$/;
5152 local $/="\n"; chomp $@;
5153 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5157 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5158 $r |= $isignore ? 02 : 01;
5159 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5161 printdebug "quiltify_trees_differ $x $y => $r\n";
5165 sub quiltify_tree_sentinelfiles ($) {
5166 # lists the `sentinel' files present in the tree
5168 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5169 qw(-- debian/rules debian/control);
5174 sub quiltify_splitbrain_needed () {
5175 if (!$split_brain) {
5176 progress "dgit view: changes are required...";
5177 runcmd @git, qw(checkout -q -b dgit-view);
5182 sub quiltify_splitbrain ($$$$$$$) {
5183 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5184 $editedignores, $cachekey) = @_;
5185 my $gitignore_special = 1;
5186 if ($quilt_mode !~ m/gbp|dpm/) {
5187 # treat .gitignore just like any other upstream file
5188 $diffbits = { %$diffbits };
5189 $_ = !!$_ foreach values %$diffbits;
5190 $gitignore_special = 0;
5192 # We would like any commits we generate to be reproducible
5193 my @authline = clogp_authline($clogp);
5194 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5195 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5196 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5197 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5198 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5199 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5201 my $fulldiffhint = sub {
5203 my $cmd = "git diff $x $y -- :/ ':!debian'";
5204 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5205 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5208 if ($quilt_mode =~ m/gbp|unapplied/ &&
5209 ($diffbits->{O2H} & 01)) {
5211 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5212 " but git tree differs from orig in upstream files.";
5213 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5214 if (!stat_exists "debian/patches") {
5216 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5220 if ($quilt_mode =~ m/dpm/ &&
5221 ($diffbits->{H2A} & 01)) {
5222 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5223 --quilt=$quilt_mode specified, implying patches-applied git tree
5224 but git tree differs from result of applying debian/patches to upstream
5227 if ($quilt_mode =~ m/gbp|unapplied/ &&
5228 ($diffbits->{O2A} & 01)) { # some patches
5229 quiltify_splitbrain_needed();
5230 progress "dgit view: creating patches-applied version using gbp pq";
5231 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5232 # gbp pq import creates a fresh branch; push back to dgit-view
5233 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5234 runcmd @git, qw(checkout -q dgit-view);
5236 if ($quilt_mode =~ m/gbp|dpm/ &&
5237 ($diffbits->{O2A} & 02)) {
5239 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5240 tool which does not create patches for changes to upstream
5241 .gitignores: but, such patches exist in debian/patches.
5244 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5245 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5246 quiltify_splitbrain_needed();
5247 progress "dgit view: creating patch to represent .gitignore changes";
5248 ensuredir "debian/patches";
5249 my $gipatch = "debian/patches/auto-gitignore";
5250 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5251 stat GIPATCH or die "$gipatch: $!";
5252 fail "$gipatch already exists; but want to create it".
5253 " to record .gitignore changes" if (stat _)[7];
5254 print GIPATCH <<END or die "$gipatch: $!";
5255 Subject: Update .gitignore from Debian packaging branch
5257 The Debian packaging git branch contains these updates to the upstream
5258 .gitignore file(s). This patch is autogenerated, to provide these
5259 updates to users of the official Debian archive view of the package.
5261 [dgit ($our_version) update-gitignore]
5264 close GIPATCH or die "$gipatch: $!";
5265 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5266 $unapplied, $headref, "--", sort keys %$editedignores;
5267 open SERIES, "+>>", "debian/patches/series" or die $!;
5268 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5270 defined read SERIES, $newline, 1 or die $!;
5271 print SERIES "\n" or die $! unless $newline eq "\n";
5272 print SERIES "auto-gitignore\n" or die $!;
5273 close SERIES or die $!;
5274 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5276 Commit patch to update .gitignore
5278 [dgit ($our_version) update-gitignore-quilt-fixup]
5282 my $dgitview = git_rev_parse 'HEAD';
5285 # When we no longer need to support squeeze, use --create-reflog
5287 ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5288 my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5291 my $oldcache = git_get_ref "refs/$splitbraincache";
5292 if ($oldcache eq $dgitview) {
5293 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5294 # git update-ref doesn't always update, in this case. *sigh*
5295 my $dummy = make_commit_text <<END;
5298 author Dgit <dgit\@example.com> 1000000000 +0000
5299 committer Dgit <dgit\@example.com> 1000000000 +0000
5301 Dummy commit - do not use
5303 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5304 "refs/$splitbraincache", $dummy;
5306 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5309 changedir "$playground/work";
5311 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5312 progress "dgit view: created ($saved)";
5315 sub quiltify ($$$$) {
5316 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5318 # Quilt patchification algorithm
5320 # We search backwards through the history of the main tree's HEAD
5321 # (T) looking for a start commit S whose tree object is identical
5322 # to to the patch tip tree (ie the tree corresponding to the
5323 # current dpkg-committed patch series). For these purposes
5324 # `identical' disregards anything in debian/ - this wrinkle is
5325 # necessary because dpkg-source treates debian/ specially.
5327 # We can only traverse edges where at most one of the ancestors'
5328 # trees differs (in changes outside in debian/). And we cannot
5329 # handle edges which change .pc/ or debian/patches. To avoid
5330 # going down a rathole we avoid traversing edges which introduce
5331 # debian/rules or debian/control. And we set a limit on the
5332 # number of edges we are willing to look at.
5334 # If we succeed, we walk forwards again. For each traversed edge
5335 # PC (with P parent, C child) (starting with P=S and ending with
5336 # C=T) to we do this:
5338 # - dpkg-source --commit with a patch name and message derived from C
5339 # After traversing PT, we git commit the changes which
5340 # should be contained within debian/patches.
5342 # The search for the path S..T is breadth-first. We maintain a
5343 # todo list containing search nodes. A search node identifies a
5344 # commit, and looks something like this:
5346 # Commit => $git_commit_id,
5347 # Child => $c, # or undef if P=T
5348 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5349 # Nontrivial => true iff $p..$c has relevant changes
5356 my %considered; # saves being exponential on some weird graphs
5358 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5361 my ($search,$whynot) = @_;
5362 printdebug " search NOT $search->{Commit} $whynot\n";
5363 $search->{Whynot} = $whynot;
5364 push @nots, $search;
5365 no warnings qw(exiting);
5374 my $c = shift @todo;
5375 next if $considered{$c->{Commit}}++;
5377 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5379 printdebug "quiltify investigate $c->{Commit}\n";
5382 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5383 printdebug " search finished hooray!\n";
5388 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5389 if ($quilt_mode eq 'smash') {
5390 printdebug " search quitting smash\n";
5394 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5395 $not->($c, "has $c_sentinels not $t_sentinels")
5396 if $c_sentinels ne $t_sentinels;
5398 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5399 $commitdata =~ m/\n\n/;
5401 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5402 @parents = map { { Commit => $_, Child => $c } } @parents;
5404 $not->($c, "root commit") if !@parents;
5406 foreach my $p (@parents) {
5407 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5409 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5410 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5412 foreach my $p (@parents) {
5413 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5415 my @cmd= (@git, qw(diff-tree -r --name-only),
5416 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5417 my $patchstackchange = cmdoutput @cmd;
5418 if (length $patchstackchange) {
5419 $patchstackchange =~ s/\n/,/g;
5420 $not->($p, "changed $patchstackchange");
5423 printdebug " search queue P=$p->{Commit} ",
5424 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5430 printdebug "quiltify want to smash\n";
5433 my $x = $_[0]{Commit};
5434 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5437 my $reportnot = sub {
5439 my $s = $abbrev->($notp);
5440 my $c = $notp->{Child};
5441 $s .= "..".$abbrev->($c) if $c;
5442 $s .= ": ".$notp->{Whynot};
5445 if ($quilt_mode eq 'linear') {
5446 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5447 foreach my $notp (@nots) {
5448 print STDERR "$us: ", $reportnot->($notp), "\n";
5450 print STDERR "$us: $_\n" foreach @$failsuggestion;
5452 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n".
5453 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5454 } elsif ($quilt_mode eq 'smash') {
5455 } elsif ($quilt_mode eq 'auto') {
5456 progress "quilt fixup cannot be linear, smashing...";
5458 die "$quilt_mode ?";
5461 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5462 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5464 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5466 quiltify_dpkg_commit "auto-$version-$target-$time",
5467 (getfield $clogp, 'Maintainer'),
5468 "Automatically generated patch ($clogp->{Version})\n".
5469 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5473 progress "quiltify linearisation planning successful, executing...";
5475 for (my $p = $sref_S;
5476 my $c = $p->{Child};
5478 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5479 next unless $p->{Nontrivial};
5481 my $cc = $c->{Commit};
5483 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5484 $commitdata =~ m/\n\n/ or die "$c ?";
5487 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5490 my $commitdate = cmdoutput
5491 @git, qw(log -n1 --pretty=format:%aD), $cc;
5493 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5495 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5502 my $gbp_check_suitable = sub {
5507 die "contains unexpected slashes\n" if m{//} || m{/$};
5508 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5509 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5510 die "is series file\n" if m{$series_filename_re}o;
5511 die "too long" if length > 200;
5513 return $_ unless $@;
5514 print STDERR "quiltifying commit $cc:".
5515 " ignoring/dropping Gbp-Pq $what: $@";
5519 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5521 (\S+) \s* \n //ixm) {
5522 $patchname = $gbp_check_suitable->($1, 'Name');
5524 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5526 (\S+) \s* \n //ixm) {
5527 $patchdir = $gbp_check_suitable->($1, 'Topic');
5532 if (!defined $patchname) {
5533 $patchname = $title;
5534 $patchname =~ s/[.:]$//;
5537 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5538 my $translitname = $converter->convert($patchname);
5539 die unless defined $translitname;
5540 $patchname = $translitname;
5543 "dgit: patch title transliteration error: $@"
5545 $patchname =~ y/ A-Z/-a-z/;
5546 $patchname =~ y/-a-z0-9_.+=~//cd;
5547 $patchname =~ s/^\W/x-$&/;
5548 $patchname = substr($patchname,0,40);
5549 $patchname .= ".patch";
5551 if (!defined $patchdir) {
5554 if (length $patchdir) {
5555 $patchname = "$patchdir/$patchname";
5557 if ($patchname =~ m{^(.*)/}) {
5558 mkpath "debian/patches/$1";
5563 stat "debian/patches/$patchname$index";
5565 $!==ENOENT or die "$patchname$index $!";
5567 runcmd @git, qw(checkout -q), $cc;
5569 # We use the tip's changelog so that dpkg-source doesn't
5570 # produce complaining messages from dpkg-parsechangelog. None
5571 # of the information dpkg-source gets from the changelog is
5572 # actually relevant - it gets put into the original message
5573 # which dpkg-source provides our stunt editor, and then
5575 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5577 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5578 "Date: $commitdate\n".
5579 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5581 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5584 runcmd @git, qw(checkout -q master);
5587 sub build_maybe_quilt_fixup () {
5588 my ($format,$fopts) = get_source_format;
5589 return unless madformat_wantfixup $format;
5592 check_for_vendor_patches();
5594 if (quiltmode_splitbrain) {
5595 fail <<END unless access_cfg_tagformats_can_splitbrain;
5596 quilt mode $quilt_mode requires split view so server needs to support
5597 both "new" and "maint" tag formats, but config says it doesn't.
5601 my $clogp = parsechangelog();
5602 my $headref = git_rev_parse('HEAD');
5603 my $symref = git_get_symref();
5605 if ($quilt_mode eq 'linear'
5606 && !$fopts->{'single-debian-patch'}
5607 && branch_is_gdr($symref, $headref)) {
5608 # This is much faster. It also makes patches that gdr
5609 # likes better for future updates without laundering.
5611 # However, it can fail in some casses where we would
5612 # succeed: if there are existing patches, which correspond
5613 # to a prefix of the branch, but are not in gbp/gdr
5614 # format, gdr will fail (exiting status 7), but we might
5615 # be able to figure out where to start linearising. That
5616 # will be slower so hopefully there's not much to do.
5617 my @cmd = (@git_debrebase,
5618 qw(--noop-ok -funclean-mixed -funclean-ordering
5619 make-patches --quiet-would-amend));
5620 # We tolerate soe snags that gdr wouldn't, by default.
5624 failedcmd @cmd if system @cmd and $?!=7*256;
5628 $headref = git_rev_parse('HEAD');
5632 changedir $playground;
5634 my $upstreamversion = upstreamversion $version;
5636 if ($fopts->{'single-debian-patch'}) {
5637 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5639 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5642 die 'bug' if $split_brain && !$need_split_build_invocation;
5645 runcmd_ordryrun_local
5646 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5649 sub unpack_playtree_mkwork ($) {
5652 mkdir "work" or die $!;
5654 mktree_in_ud_here();
5655 runcmd @git, qw(reset -q --hard), $headref;
5658 sub unpack_playtree_linkorigs ($$) {
5659 my ($upstreamversion, $fn) = @_;
5660 # calls $fn->($leafname);
5662 my $bpd_abs = bpd_abs();
5663 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5664 while ($!=0, defined(my $b = readdir QFD)) {
5665 my $f = bpd_abs()."/".$b;
5667 local ($debuglevel) = $debuglevel-1;
5668 printdebug "QF linkorigs $b, $f ?\n";
5670 next unless is_orig_file_of_vsn $b, $upstreamversion;
5671 printdebug "QF linkorigs $b, $f Y\n";
5672 link_ltarget $f, $b or die "$b $!";
5675 die "$buildproductsdir: $!" if $!;
5679 sub quilt_fixup_delete_pc () {
5680 runcmd @git, qw(rm -rqf .pc);
5682 Commit removal of .pc (quilt series tracking data)
5684 [dgit ($our_version) upgrade quilt-remove-pc]
5688 sub quilt_fixup_singlepatch ($$$) {
5689 my ($clogp, $headref, $upstreamversion) = @_;
5691 progress "starting quiltify (single-debian-patch)";
5693 # dpkg-source --commit generates new patches even if
5694 # single-debian-patch is in debian/source/options. In order to
5695 # get it to generate debian/patches/debian-changes, it is
5696 # necessary to build the source package.
5698 unpack_playtree_linkorigs($upstreamversion, sub { });
5699 unpack_playtree_mkwork($headref);
5701 rmtree("debian/patches");
5703 runcmd @dpkgsource, qw(-b .);
5705 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5706 rename srcfn("$upstreamversion", "/debian/patches"),
5707 "work/debian/patches";
5710 commit_quilty_patch();
5713 sub quilt_make_fake_dsc ($) {
5714 my ($upstreamversion) = @_;
5716 my $fakeversion="$upstreamversion-~~DGITFAKE";
5718 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5719 print $fakedsc <<END or die $!;
5722 Version: $fakeversion
5726 my $dscaddfile=sub {
5729 my $md = new Digest::MD5;
5731 my $fh = new IO::File $b, '<' or die "$b $!";
5736 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5739 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5741 my @files=qw(debian/source/format debian/rules
5742 debian/control debian/changelog);
5743 foreach my $maybe (qw(debian/patches debian/source/options
5744 debian/tests/control)) {
5745 next unless stat_exists "$maindir/$maybe";
5746 push @files, $maybe;
5749 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5750 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5752 $dscaddfile->($debtar);
5753 close $fakedsc or die $!;
5756 sub quilt_check_splitbrain_cache ($$) {
5757 my ($headref, $upstreamversion) = @_;
5758 # Called only if we are in (potentially) split brain mode.
5759 # Called in playground.
5760 # Computes the cache key and looks in the cache.
5761 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5763 my $splitbrain_cachekey;
5766 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5767 # we look in the reflog of dgit-intern/quilt-cache
5768 # we look for an entry whose message is the key for the cache lookup
5769 my @cachekey = (qw(dgit), $our_version);
5770 push @cachekey, $upstreamversion;
5771 push @cachekey, $quilt_mode;
5772 push @cachekey, $headref;
5774 push @cachekey, hashfile('fake.dsc');
5776 my $srcshash = Digest::SHA->new(256);
5777 my %sfs = ( %INC, '$0(dgit)' => $0 );
5778 foreach my $sfk (sort keys %sfs) {
5779 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5780 $srcshash->add($sfk," ");
5781 $srcshash->add(hashfile($sfs{$sfk}));
5782 $srcshash->add("\n");
5784 push @cachekey, $srcshash->hexdigest();
5785 $splitbrain_cachekey = "@cachekey";
5787 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5789 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5790 debugcmd "|(probably)",@cmd;
5791 my $child = open GC, "-|"; defined $child or die $!;
5793 chdir $maindir or die $!;
5794 if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5795 $! == ENOENT or die $!;
5796 printdebug ">(no reflog)\n";
5803 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5804 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5807 unpack_playtree_mkwork($headref);
5808 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5809 if ($cachehit ne $headref) {
5810 progress "dgit view: found cached ($saved)";
5811 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5813 return ($cachehit, $splitbrain_cachekey);
5815 progress "dgit view: found cached, no changes required";
5816 return ($headref, $splitbrain_cachekey);
5818 die $! if GC->error;
5819 failedcmd unless close GC;
5821 printdebug "splitbrain cache miss\n";
5822 return (undef, $splitbrain_cachekey);
5825 sub quilt_fixup_multipatch ($$$) {
5826 my ($clogp, $headref, $upstreamversion) = @_;
5828 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5831 # - honour any existing .pc in case it has any strangeness
5832 # - determine the git commit corresponding to the tip of
5833 # the patch stack (if there is one)
5834 # - if there is such a git commit, convert each subsequent
5835 # git commit into a quilt patch with dpkg-source --commit
5836 # - otherwise convert all the differences in the tree into
5837 # a single git commit
5841 # Our git tree doesn't necessarily contain .pc. (Some versions of
5842 # dgit would include the .pc in the git tree.) If there isn't
5843 # one, we need to generate one by unpacking the patches that we
5846 # We first look for a .pc in the git tree. If there is one, we
5847 # will use it. (This is not the normal case.)
5849 # Otherwise need to regenerate .pc so that dpkg-source --commit
5850 # can work. We do this as follows:
5851 # 1. Collect all relevant .orig from parent directory
5852 # 2. Generate a debian.tar.gz out of
5853 # debian/{patches,rules,source/format,source/options}
5854 # 3. Generate a fake .dsc containing just these fields:
5855 # Format Source Version Files
5856 # 4. Extract the fake .dsc
5857 # Now the fake .dsc has a .pc directory.
5858 # (In fact we do this in every case, because in future we will
5859 # want to search for a good base commit for generating patches.)
5861 # Then we can actually do the dpkg-source --commit
5862 # 1. Make a new working tree with the same object
5863 # store as our main tree and check out the main
5865 # 2. Copy .pc from the fake's extraction, if necessary
5866 # 3. Run dpkg-source --commit
5867 # 4. If the result has changes to debian/, then
5868 # - git add them them
5869 # - git add .pc if we had a .pc in-tree
5871 # 5. If we had a .pc in-tree, delete it, and git commit
5872 # 6. Back in the main tree, fast forward to the new HEAD
5874 # Another situation we may have to cope with is gbp-style
5875 # patches-unapplied trees.
5877 # We would want to detect these, so we know to escape into
5878 # quilt_fixup_gbp. However, this is in general not possible.
5879 # Consider a package with a one patch which the dgit user reverts
5880 # (with git revert or the moral equivalent).
5882 # That is indistinguishable in contents from a patches-unapplied
5883 # tree. And looking at the history to distinguish them is not
5884 # useful because the user might have made a confusing-looking git
5885 # history structure (which ought to produce an error if dgit can't
5886 # cope, not a silent reintroduction of an unwanted patch).
5888 # So gbp users will have to pass an option. But we can usually
5889 # detect their failure to do so: if the tree is not a clean
5890 # patches-applied tree, quilt linearisation fails, but the tree
5891 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5892 # they want --quilt=unapplied.
5894 # To help detect this, when we are extracting the fake dsc, we
5895 # first extract it with --skip-patches, and then apply the patches
5896 # afterwards with dpkg-source --before-build. That lets us save a
5897 # tree object corresponding to .origs.
5899 my $splitbrain_cachekey;
5901 quilt_make_fake_dsc($upstreamversion);
5903 if (quiltmode_splitbrain()) {
5905 ($cachehit, $splitbrain_cachekey) =
5906 quilt_check_splitbrain_cache($headref, $upstreamversion);
5907 return if $cachehit;
5911 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5913 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5914 rename $fakexdir, "fake" or die "$fakexdir $!";
5918 remove_stray_gits("source package");
5919 mktree_in_ud_here();
5923 rmtree 'debian'; # git checkout commitish paths does not delete!
5924 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5925 my $unapplied=git_add_write_tree();
5926 printdebug "fake orig tree object $unapplied\n";
5930 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5932 if (system @bbcmd) {
5933 failedcmd @bbcmd if $? < 0;
5935 failed to apply your git tree's patch stack (from debian/patches/) to
5936 the corresponding upstream tarball(s). Your source tree and .orig
5937 are probably too inconsistent. dgit can only fix up certain kinds of
5938 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5944 unpack_playtree_mkwork($headref);
5947 if (stat_exists ".pc") {
5949 progress "Tree already contains .pc - will use it then delete it.";
5952 rename '../fake/.pc','.pc' or die $!;
5955 changedir '../fake';
5957 my $oldtiptree=git_add_write_tree();
5958 printdebug "fake o+d/p tree object $unapplied\n";
5959 changedir '../work';
5962 # We calculate some guesswork now about what kind of tree this might
5963 # be. This is mostly for error reporting.
5969 # O = orig, without patches applied
5970 # A = "applied", ie orig with H's debian/patches applied
5971 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5972 \%editedignores, \@unrepres),
5973 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5974 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5978 foreach my $b (qw(01 02)) {
5979 foreach my $v (qw(O2H O2A H2A)) {
5980 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5983 printdebug "differences \@dl @dl.\n";
5986 "$us: base trees orig=%.20s o+d/p=%.20s",
5987 $unapplied, $oldtiptree;
5989 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5990 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5991 $dl[0], $dl[1], $dl[3], $dl[4],
5995 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5997 forceable_fail [qw(unrepresentable)], <<END;
5998 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6003 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6004 push @failsuggestion, "This might be a patches-unapplied branch.";
6005 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6006 push @failsuggestion, "This might be a patches-applied branch.";
6008 push @failsuggestion, "Maybe you need to specify one of".
6009 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
6011 if (quiltmode_splitbrain()) {
6012 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6013 $diffbits, \%editedignores,
6014 $splitbrain_cachekey);
6018 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6019 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6021 if (!open P, '>>', ".pc/applied-patches") {
6022 $!==&ENOENT or die $!;
6027 commit_quilty_patch();
6029 if ($mustdeletepc) {
6030 quilt_fixup_delete_pc();
6034 sub quilt_fixup_editor () {
6035 my $descfn = $ENV{$fakeeditorenv};
6036 my $editing = $ARGV[$#ARGV];
6037 open I1, '<', $descfn or die "$descfn: $!";
6038 open I2, '<', $editing or die "$editing: $!";
6039 unlink $editing or die "$editing: $!";
6040 open O, '>', $editing or die "$editing: $!";
6041 while (<I1>) { print O or die $!; } I1->error and die $!;
6044 $copying ||= m/^\-\-\- /;
6045 next unless $copying;
6048 I2->error and die $!;
6053 sub maybe_apply_patches_dirtily () {
6054 return unless $quilt_mode =~ m/gbp|unapplied/;
6055 print STDERR <<END or die $!;
6057 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6058 dgit: Have to apply the patches - making the tree dirty.
6059 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6062 $patches_applied_dirtily = 01;
6063 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6064 runcmd qw(dpkg-source --before-build .);
6067 sub maybe_unapply_patches_again () {
6068 progress "dgit: Unapplying patches again to tidy up the tree."
6069 if $patches_applied_dirtily;
6070 runcmd qw(dpkg-source --after-build .)
6071 if $patches_applied_dirtily & 01;
6073 if $patches_applied_dirtily & 02;
6074 $patches_applied_dirtily = 0;
6077 #----- other building -----
6079 our $clean_using_builder;
6080 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6081 # clean the tree before building (perhaps invoked indirectly by
6082 # whatever we are using to run the build), rather than separately
6083 # and explicitly by us.
6086 return if $clean_using_builder;
6087 if ($cleanmode eq 'dpkg-source') {
6088 maybe_apply_patches_dirtily();
6089 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6090 } elsif ($cleanmode eq 'dpkg-source-d') {
6091 maybe_apply_patches_dirtily();
6092 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6093 } elsif ($cleanmode eq 'git') {
6094 runcmd_ordryrun_local @git, qw(clean -xdf);
6095 } elsif ($cleanmode eq 'git-ff') {
6096 runcmd_ordryrun_local @git, qw(clean -xdff);
6097 } elsif ($cleanmode eq 'check') {
6098 my $leftovers = cmdoutput @git, qw(clean -xdn);
6099 if (length $leftovers) {
6100 print STDERR $leftovers, "\n" or die $!;
6101 fail "tree contains uncommitted files and --clean=check specified";
6103 } elsif ($cleanmode eq 'none') {
6110 badusage "clean takes no additional arguments" if @ARGV;
6113 maybe_unapply_patches_again();
6116 # return values from massage_dbp_args are one or both of these flags
6117 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6118 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6120 sub build_or_push_prep_early () {
6121 our $build_or_push_prep_early_done //= 0;
6122 return if $build_or_push_prep_early_done++;
6123 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6124 my $clogp = parsechangelog();
6125 $isuite = getfield $clogp, 'Distribution';
6126 $package = getfield $clogp, 'Source';
6127 $version = getfield $clogp, 'Version';
6130 sub build_prep_early () {
6131 build_or_push_prep_early();
6136 sub build_prep ($) {
6139 # clean the tree if we're trying to include dirty changes in the
6140 # source package, or we are running the builder in $maindir
6141 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6142 build_maybe_quilt_fixup();
6144 my $pat = changespat $version;
6145 foreach my $f (glob "$buildproductsdir/$pat") {
6147 unlink $f or fail "remove old changes file $f: $!";
6149 progress "would remove $f";
6155 sub changesopts_initial () {
6156 my @opts =@changesopts[1..$#changesopts];
6159 sub changesopts_version () {
6160 if (!defined $changes_since_version) {
6163 @vsns = archive_query('archive_query');
6164 my @quirk = access_quirk();
6165 if ($quirk[0] eq 'backports') {
6166 local $isuite = $quirk[2];
6168 canonicalise_suite();
6169 push @vsns, archive_query('archive_query');
6175 "archive query failed (queried because --since-version not specified)";
6178 @vsns = map { $_->[0] } @vsns;
6179 @vsns = sort { -version_compare($a, $b) } @vsns;
6180 $changes_since_version = $vsns[0];
6181 progress "changelog will contain changes since $vsns[0]";
6183 $changes_since_version = '_';
6184 progress "package seems new, not specifying -v<version>";
6187 if ($changes_since_version ne '_') {
6188 return ("-v$changes_since_version");
6194 sub changesopts () {
6195 return (changesopts_initial(), changesopts_version());
6198 sub massage_dbp_args ($;$) {
6199 my ($cmd,$xargs) = @_;
6202 # - if we're going to split the source build out so we can
6203 # do strange things to it, massage the arguments to dpkg-buildpackage
6204 # so that the main build doessn't build source (or add an argument
6205 # to stop it building source by default).
6207 # - add -nc to stop dpkg-source cleaning the source tree,
6208 # unless we're not doing a split build and want dpkg-source
6209 # as cleanmode, in which case we can do nothing
6211 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6212 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
6213 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
6214 $clean_using_builder = 1;
6215 return WANTSRC_BUILDER;
6217 # -nc has the side effect of specifying -b if nothing else specified
6218 # and some combinations of -S, -b, et al, are errors, rather than
6219 # later simply overriding earlie. So we need to:
6220 # - search the command line for these options
6221 # - pick the last one
6222 # - perhaps add our own as a default
6223 # - perhaps adjust it to the corresponding non-source-building version
6225 foreach my $l ($cmd, $xargs) {
6227 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6230 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6231 my $r = WANTSRC_BUILDER;
6232 if ($need_split_build_invocation) {
6233 printdebug "massage split $dmode.\n";
6234 $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6235 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6236 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6239 printdebug "massage done $r $dmode.\n";
6241 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6247 my $wasdir = must_getcwd();
6248 changedir $buildproductsdir;
6253 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6254 sub postbuild_mergechanges ($) {
6255 my ($msg_if_onlyone) = @_;
6256 # If there is only one .changes file, fail with $msg_if_onlyone,
6257 # or if that is undef, be a no-op.
6258 # Returns the changes file to report to the user.
6259 my $pat = changespat $version;
6260 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6261 @changesfiles = sort {
6262 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6266 if (@changesfiles==1) {
6267 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6268 only one changes file from build (@changesfiles)
6270 $result = $changesfiles[0];
6271 } elsif (@changesfiles==2) {
6272 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6273 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6274 fail "$l found in binaries changes file $binchanges"
6277 runcmd_ordryrun_local @mergechanges, @changesfiles;
6278 my $multichanges = changespat $version,'multi';
6280 stat_exists $multichanges or fail "$multichanges: $!";
6281 foreach my $cf (glob $pat) {
6282 next if $cf eq $multichanges;
6283 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6286 $result = $multichanges;
6288 fail "wrong number of different changes files (@changesfiles)";
6290 printdone "build successful, results in $result\n" or die $!;
6293 sub midbuild_checkchanges () {
6294 my $pat = changespat $version;
6295 return if $rmchanges;
6296 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6298 $_ ne changespat $version,'source' and
6299 $_ ne changespat $version,'multi'
6302 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6303 Suggest you delete @unwanted.
6308 sub midbuild_checkchanges_vanilla ($) {
6310 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6313 sub postbuild_mergechanges_vanilla ($) {
6315 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6317 postbuild_mergechanges(undef);
6320 printdone "build successful\n";
6326 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6327 my $wantsrc = massage_dbp_args \@dbp;
6328 build_prep($wantsrc);
6329 if ($wantsrc & WANTSRC_SOURCE) {
6331 midbuild_checkchanges_vanilla $wantsrc;
6333 if ($wantsrc & WANTSRC_BUILDER) {
6334 push @dbp, changesopts_version();
6335 maybe_apply_patches_dirtily();
6336 runcmd_ordryrun_local @dbp;
6338 maybe_unapply_patches_again();
6339 postbuild_mergechanges_vanilla $wantsrc;
6343 $quilt_mode //= 'gbp';
6349 # gbp can make .origs out of thin air. In my tests it does this
6350 # even for a 1.0 format package, with no origs present. So I
6351 # guess it keys off just the version number. We don't know
6352 # exactly what .origs ought to exist, but let's assume that we
6353 # should run gbp if: the version has an upstream part and the main
6355 my $upstreamversion = upstreamversion $version;
6356 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6357 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6359 if ($gbp_make_orig) {
6361 $cleanmode = 'none'; # don't do it again
6362 $need_split_build_invocation = 1;
6365 my @dbp = @dpkgbuildpackage;
6367 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6369 if (!length $gbp_build[0]) {
6370 if (length executable_on_path('git-buildpackage')) {
6371 $gbp_build[0] = qw(git-buildpackage);
6373 $gbp_build[0] = 'gbp buildpackage';
6376 my @cmd = opts_opt_multi_cmd @gbp_build;
6378 push @cmd, (qw(-us -uc --git-no-sign-tags),
6379 "--git-builder=".(shellquote @dbp));
6381 if ($gbp_make_orig) {
6382 my $priv = dgit_privdir();
6383 my $ok = "$priv/origs-gen-ok";
6384 unlink $ok or $!==&ENOENT or die $!;
6385 my @origs_cmd = @cmd;
6386 push @origs_cmd, qw(--git-cleaner=true);
6387 push @origs_cmd, "--git-prebuild=".
6388 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6389 push @origs_cmd, @ARGV;
6391 debugcmd @origs_cmd;
6393 do { local $!; stat_exists $ok; }
6394 or failedcmd @origs_cmd;
6396 dryrun_report @origs_cmd;
6400 build_prep($wantsrc);
6401 if ($wantsrc & WANTSRC_SOURCE) {
6403 midbuild_checkchanges_vanilla $wantsrc;
6405 if (!$clean_using_builder) {
6406 push @cmd, '--git-cleaner=true';
6409 maybe_unapply_patches_again();
6410 if ($wantsrc & WANTSRC_BUILDER) {
6411 push @cmd, changesopts();
6412 runcmd_ordryrun_local @cmd, @ARGV;
6414 postbuild_mergechanges_vanilla $wantsrc;
6416 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6418 sub move_dsc_to_bpd ($) {
6420 printdebug "moving $dscfn and all referenced files to ".bpd_abs()."\n";
6421 $dsc = parsecontrol($dscfn, "source package");
6422 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6423 $l =~ m/\S+$/ or next;
6425 printdebug "found $l - renaming\n";
6426 rename "$l", bpd_abs()."/$l"
6427 or fail "put in place new source file ($l): $!";
6429 printdebug "moving $dscfn to ".bpd_abs()."/$dscfn\n";
6430 rename "$dscfn", bpd_abs()."/$dscfn"
6431 or fail "put in place new source file ($dscfn): $!";
6434 sub building_source_in_playtree {
6435 # If $includedirty, we have to build the source package from the
6436 # working tree, not a playtree, so that uncommitted changes are
6437 # included (copying or hardlinking them into the playtree could
6440 # Note that if we are building a source package in split brain
6441 # mode we do not support including uncommitted changes, because
6442 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6443 # building a source package)) => !$includedirty
6444 return !$includedirty;
6448 $sourcechanges = changespat $version,'source';
6450 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6451 or fail "remove $sourcechanges: $!";
6453 $dscfn = dscfn($version);
6454 my @cmd = (@dpkgsource, qw(-b --));
6456 if (building_source_in_playtree()) {
6458 my $headref = git_rev_parse('HEAD');
6459 # If we are in split brain, there is already a playtree with
6460 # the thing we should package into a .dsc (thanks to quilt
6461 # fixup). If not, make a playtree
6462 prep_ud() unless $split_brain;
6463 changedir $playground;
6464 unless ($split_brain) {
6465 my $upstreamversion = upstreamversion $version;
6466 unpack_playtree_linkorigs($upstreamversion, sub { });
6467 unpack_playtree_mkwork($headref);
6471 $leafdir = basename $maindir;
6474 runcmd_ordryrun_local @cmd, $leafdir;
6477 runcmd_ordryrun_local qw(sh -ec),
6478 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6479 @dpkggenchanges, qw(-S), changesopts();
6481 move_dsc_to_bpd($dscfn);
6482 rename "$sourcechanges", bpd_abs()."/$sourcechanges"
6483 or fail "put in place source changes file ($sourcechanges): $!";
6487 sub cmd_build_source {
6488 badusage "build-source takes no additional arguments" if @ARGV;
6489 build_prep(WANTSRC_SOURCE);
6491 maybe_unapply_patches_again();
6492 printdone "source built, results in $dscfn and $sourcechanges";
6496 build_prep(WANTSRC_SOURCE); # not BUILDER because sbuild uses the .dsc
6498 midbuild_checkchanges();
6501 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6502 stat_exists $sourcechanges
6503 or fail "$sourcechanges (in parent directory): $!";
6505 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6507 maybe_unapply_patches_again();
6509 postbuild_mergechanges(<<END);
6510 perhaps you need to pass -A ? (sbuild's default is to build only
6511 arch-specific binaries; dgit 1.4 used to override that.)
6516 sub cmd_quilt_fixup {
6517 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6520 build_maybe_quilt_fixup();
6523 sub import_dsc_result {
6524 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6525 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6527 check_gitattrs($newhash, "source tree");
6529 progress "dgit: import-dsc: $what_msg";
6532 sub cmd_import_dsc {
6536 last unless $ARGV[0] =~ m/^-/;
6539 if (m/^--require-valid-signature$/) {
6542 badusage "unknown dgit import-dsc sub-option \`$_'";
6546 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6547 my ($dscfn, $dstbranch) = @ARGV;
6549 badusage "dry run makes no sense with import-dsc" unless act_local();
6551 my $force = $dstbranch =~ s/^\+// ? +1 :
6552 $dstbranch =~ s/^\.\.// ? -1 :
6554 my $info = $force ? " $&" : '';
6555 $info = "$dscfn$info";
6557 my $specbranch = $dstbranch;
6558 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6559 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6561 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6562 my $chead = cmdoutput_errok @symcmd;
6563 defined $chead or $?==256 or failedcmd @symcmd;
6565 fail "$dstbranch is checked out - will not update it"
6566 if defined $chead and $chead eq $dstbranch;
6568 my $oldhash = git_get_ref $dstbranch;
6570 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6571 $dscdata = do { local $/ = undef; <D>; };
6572 D->error and fail "read $dscfn: $!";
6575 # we don't normally need this so import it here
6576 use Dpkg::Source::Package;
6577 my $dp = new Dpkg::Source::Package filename => $dscfn,
6578 require_valid_signature => $needsig;
6580 local $SIG{__WARN__} = sub {
6582 return unless $needsig;
6583 fail "import-dsc signature check failed";
6585 if (!$dp->is_signed()) {
6586 warn "$us: warning: importing unsigned .dsc\n";
6588 my $r = $dp->check_signature();
6589 die "->check_signature => $r" if $needsig && $r;
6595 $package = getfield $dsc, 'Source';
6597 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6598 unless forceing [qw(import-dsc-with-dgit-field)];
6599 parse_dsc_field_def_dsc_distro();
6601 $isuite = 'DGIT-IMPORT-DSC';
6602 $idistro //= $dsc_distro;
6606 if (defined $dsc_hash) {
6607 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6608 resolve_dsc_field_commit undef, undef;
6610 if (defined $dsc_hash) {
6611 my @cmd = (qw(sh -ec),
6612 "echo $dsc_hash | git cat-file --batch-check");
6613 my $objgot = cmdoutput @cmd;
6614 if ($objgot =~ m#^\w+ missing\b#) {
6616 .dsc contains Dgit field referring to object $dsc_hash
6617 Your git tree does not have that object. Try `git fetch' from a
6618 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6621 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6623 progress "Not fast forward, forced update.";
6625 fail "Not fast forward to $dsc_hash";
6628 import_dsc_result $dstbranch, $dsc_hash,
6629 "dgit import-dsc (Dgit): $info",
6630 "updated git ref $dstbranch";
6635 Branch $dstbranch already exists
6636 Specify ..$specbranch for a pseudo-merge, binding in existing history
6637 Specify +$specbranch to overwrite, discarding existing history
6639 if $oldhash && !$force;
6641 my @dfi = dsc_files_info();
6642 foreach my $fi (@dfi) {
6643 my $f = $fi->{Filename};
6644 my $here = "$buildproductsdir/$f";
6647 fail "lstat $here works but stat gives $! !";
6649 fail "stat $here: $!" unless $! == ENOENT;
6651 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6653 } elsif ($dscfn =~ m#^/#) {
6656 fail "cannot import $dscfn which seems to be inside working tree!";
6658 $there =~ s#/+[^/]+$## or
6659 fail "import $dscfn requires ../$f, but it does not exist";
6661 my $test = $there =~ m{^/} ? $there : "../$there";
6662 stat $test or fail "import $dscfn requires $test, but: $!";
6663 symlink $there, $here or fail "symlink $there to $here: $!";
6664 progress "made symlink $here -> $there";
6665 # print STDERR Dumper($fi);
6667 my @mergeinputs = generate_commits_from_dsc();
6668 die unless @mergeinputs == 1;
6670 my $newhash = $mergeinputs[0]{Commit};
6674 progress "Import, forced update - synthetic orphan git history.";
6675 } elsif ($force < 0) {
6676 progress "Import, merging.";
6677 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6678 my $version = getfield $dsc, 'Version';
6679 my $clogp = commit_getclogp $newhash;
6680 my $authline = clogp_authline $clogp;
6681 $newhash = make_commit_text <<END;
6688 Merge $package ($version) import into $dstbranch
6691 die; # caught earlier
6695 import_dsc_result $dstbranch, $newhash,
6696 "dgit import-dsc: $info",
6697 "results are in in git ref $dstbranch";
6700 sub pre_archive_api_query () {
6701 not_necessarily_a_tree();
6703 sub cmd_archive_api_query {
6704 badusage "need only 1 subpath argument" unless @ARGV==1;
6705 my ($subpath) = @ARGV;
6706 local $isuite = 'DGIT-API-QUERY-CMD';
6707 my @cmd = archive_api_query_cmd($subpath);
6710 exec @cmd or fail "exec curl: $!\n";
6713 sub repos_server_url () {
6714 $package = '_dgit-repos-server';
6715 local $access_forpush = 1;
6716 local $isuite = 'DGIT-REPOS-SERVER';
6717 my $url = access_giturl();
6720 sub pre_clone_dgit_repos_server () {
6721 not_necessarily_a_tree();
6723 sub cmd_clone_dgit_repos_server {
6724 badusage "need destination argument" unless @ARGV==1;
6725 my ($destdir) = @ARGV;
6726 my $url = repos_server_url();
6727 my @cmd = (@git, qw(clone), $url, $destdir);
6729 exec @cmd or fail "exec git clone: $!\n";
6732 sub pre_print_dgit_repos_server_source_url () {
6733 not_necessarily_a_tree();
6735 sub cmd_print_dgit_repos_server_source_url {
6736 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6738 my $url = repos_server_url();
6739 print $url, "\n" or die $!;
6742 sub pre_print_dpkg_source_ignores {
6743 not_necessarily_a_tree();
6745 sub cmd_print_dpkg_source_ignores {
6746 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6748 print "@dpkg_source_ignores\n" or die $!;
6751 sub cmd_setup_mergechangelogs {
6752 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6753 local $isuite = 'DGIT-SETUP-TREE';
6754 setup_mergechangelogs(1);
6757 sub cmd_setup_useremail {
6758 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6759 local $isuite = 'DGIT-SETUP-TREE';
6763 sub cmd_setup_gitattributes {
6764 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6765 local $isuite = 'DGIT-SETUP-TREE';
6769 sub cmd_setup_new_tree {
6770 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6771 local $isuite = 'DGIT-SETUP-TREE';
6775 #---------- argument parsing and main program ----------
6778 print "dgit version $our_version\n" or die $!;
6782 our (%valopts_long, %valopts_short);
6783 our (%funcopts_long);
6785 our (@modeopt_cfgs);
6787 sub defvalopt ($$$$) {
6788 my ($long,$short,$val_re,$how) = @_;
6789 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6790 $valopts_long{$long} = $oi;
6791 $valopts_short{$short} = $oi;
6792 # $how subref should:
6793 # do whatever assignemnt or thing it likes with $_[0]
6794 # if the option should not be passed on to remote, @rvalopts=()
6795 # or $how can be a scalar ref, meaning simply assign the value
6798 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6799 defvalopt '--distro', '-d', '.+', \$idistro;
6800 defvalopt '', '-k', '.+', \$keyid;
6801 defvalopt '--existing-package','', '.*', \$existing_package;
6802 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6803 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6804 defvalopt '--package', '-p', $package_re, \$package;
6805 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6807 defvalopt '', '-C', '.+', sub {
6808 ($changesfile) = (@_);
6809 if ($changesfile =~ s#^(.*)/##) {
6810 $buildproductsdir = $1;
6814 defvalopt '--initiator-tempdir','','.*', sub {
6815 ($initiator_tempdir) = (@_);
6816 $initiator_tempdir =~ m#^/# or
6817 badusage "--initiator-tempdir must be used specify an".
6818 " absolute, not relative, directory."
6821 sub defoptmodes ($@) {
6822 my ($varref, $cfgkey, $default, %optmap) = @_;
6824 while (my ($opt,$val) = each %optmap) {
6825 $funcopts_long{$opt} = sub { $$varref = $val; };
6826 $permit{$val} = $val;
6828 push @modeopt_cfgs, {
6831 Default => $default,
6836 defoptmodes \$dodep14tag, qw( dep14tag want
6839 --always-dep14tag always );
6844 if (defined $ENV{'DGIT_SSH'}) {
6845 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6846 } elsif (defined $ENV{'GIT_SSH'}) {
6847 @ssh = ($ENV{'GIT_SSH'});
6855 if (!defined $val) {
6856 badusage "$what needs a value" unless @ARGV;
6858 push @rvalopts, $val;
6860 badusage "bad value \`$val' for $what" unless
6861 $val =~ m/^$oi->{Re}$(?!\n)/s;
6862 my $how = $oi->{How};
6863 if (ref($how) eq 'SCALAR') {
6868 push @ropts, @rvalopts;
6872 last unless $ARGV[0] =~ m/^-/;
6876 if (m/^--dry-run$/) {
6879 } elsif (m/^--damp-run$/) {
6882 } elsif (m/^--no-sign$/) {
6885 } elsif (m/^--help$/) {
6887 } elsif (m/^--version$/) {
6889 } elsif (m/^--new$/) {
6892 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6893 ($om = $opts_opt_map{$1}) &&
6897 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6898 !$opts_opt_cmdonly{$1} &&
6899 ($om = $opts_opt_map{$1})) {
6902 } elsif (m/^--(gbp|dpm)$/s) {
6903 push @ropts, "--quilt=$1";
6905 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6908 } elsif (m/^--no-quilt-fixup$/s) {
6910 $quilt_mode = 'nocheck';
6911 } elsif (m/^--no-rm-on-error$/s) {
6914 } elsif (m/^--no-chase-dsc-distro$/s) {
6916 $chase_dsc_distro = 0;
6917 } elsif (m/^--overwrite$/s) {
6919 $overwrite_version = '';
6920 } elsif (m/^--overwrite=(.+)$/s) {
6922 $overwrite_version = $1;
6923 } elsif (m/^--delayed=(\d+)$/s) {
6926 } elsif (m/^--dgit-view-save=(.+)$/s) {
6928 $split_brain_save = $1;
6929 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6930 } elsif (m/^--(no-)?rm-old-changes$/s) {
6933 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6935 push @deliberatelies, $&;
6936 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6940 } elsif (m/^--force-/) {
6942 "$us: warning: ignoring unknown force option $_\n";
6944 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6945 # undocumented, for testing
6947 $tagformat_want = [ $1, 'command line', 1 ];
6948 # 1 menas overrides distro configuration
6949 } elsif (m/^--always-split-source-build$/s) {
6950 # undocumented, was once for testing, now a no-op
6952 $need_split_build_invocation = 1;
6953 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6954 # undocumented, for testing
6956 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6957 # ^ it's supposed to be an array ref
6958 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6959 $val = $2 ? $' : undef; #';
6960 $valopt->($oi->{Long});
6961 } elsif ($funcopts_long{$_}) {
6963 $funcopts_long{$_}();
6965 badusage "unknown long option \`$_'";
6972 } elsif (s/^-L/-/) {
6975 } elsif (s/^-h/-/) {
6977 } elsif (s/^-D/-/) {
6981 } elsif (s/^-N/-/) {
6986 push @changesopts, $_;
6988 } elsif (s/^-wn$//s) {
6990 $cleanmode = 'none';
6991 } elsif (s/^-wg$//s) {
6994 } elsif (s/^-wgf$//s) {
6996 $cleanmode = 'git-ff';
6997 } elsif (s/^-wd$//s) {
6999 $cleanmode = 'dpkg-source';
7000 } elsif (s/^-wdd$//s) {
7002 $cleanmode = 'dpkg-source-d';
7003 } elsif (s/^-wc$//s) {
7005 $cleanmode = 'check';
7006 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7007 push @git, '-c', $&;
7008 $gitcfgs{cmdline}{$1} = [ $2 ];
7009 } elsif (s/^-c([^=]+)$//s) {
7010 push @git, '-c', $&;
7011 $gitcfgs{cmdline}{$1} = [ 'true' ];
7012 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7014 $val = undef unless length $val;
7015 $valopt->($oi->{Short});
7018 badusage "unknown short option \`$_'";
7025 sub check_env_sanity () {
7026 my $blocked = new POSIX::SigSet;
7027 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7030 foreach my $name (qw(PIPE CHLD)) {
7031 my $signame = "SIG$name";
7032 my $signum = eval "POSIX::$signame" // die;
7033 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
7034 die "$signame is set to something other than SIG_DFL\n";
7035 $blocked->ismember($signum) and
7036 die "$signame is blocked\n";
7042 On entry to dgit, $@
7043 This is a bug produced by something in in your execution environment.
7049 sub parseopts_late_defaults () {
7050 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7051 if defined $idistro;
7052 $isuite //= cfg('dgit.default.default-suite');
7054 foreach my $k (keys %opts_opt_map) {
7055 my $om = $opts_opt_map{$k};
7057 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7059 badcfg "cannot set command for $k"
7060 unless length $om->[0];
7064 foreach my $c (access_cfg_cfgs("opts-$k")) {
7066 map { $_ ? @$_ : () }
7067 map { $gitcfgs{$_}{$c} }
7068 reverse @gitcfgsources;
7069 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7070 "\n" if $debuglevel >= 4;
7072 badcfg "cannot configure options for $k"
7073 if $opts_opt_cmdonly{$k};
7074 my $insertpos = $opts_cfg_insertpos{$k};
7075 @$om = ( @$om[0..$insertpos-1],
7077 @$om[$insertpos..$#$om] );
7081 if (!defined $rmchanges) {
7082 local $access_forpush;
7083 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7086 if (!defined $quilt_mode) {
7087 local $access_forpush;
7088 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7089 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7091 $quilt_mode =~ m/^($quilt_modes_re)$/
7092 or badcfg "unknown quilt-mode \`$quilt_mode'";
7096 foreach my $moc (@modeopt_cfgs) {
7097 local $access_forpush;
7098 my $vr = $moc->{Var};
7099 next if defined $$vr;
7100 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7101 my $v = $moc->{Vals}{$$vr};
7102 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7106 $need_split_build_invocation ||= quiltmode_splitbrain();
7108 fail "dgit: --include-dirty is not supported in split view quilt mode"
7109 if $split_brain && $includedirty;
7111 if (!defined $cleanmode) {
7112 local $access_forpush;
7113 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7114 $cleanmode //= 'dpkg-source';
7116 badcfg "unknown clean-mode \`$cleanmode'" unless
7117 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7120 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7121 $buildproductsdir //= '..';
7122 $bpd_glob = $buildproductsdir;
7123 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7126 if ($ENV{$fakeeditorenv}) {
7128 quilt_fixup_editor();
7134 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7135 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7136 if $dryrun_level == 1;
7138 print STDERR $helpmsg or die $!;
7141 $cmd = $subcommand = shift @ARGV;
7144 my $pre_fn = ${*::}{"pre_$cmd"};
7145 $pre_fn->() if $pre_fn;
7147 record_maindir if $invoked_in_git_tree;
7150 my $fn = ${*::}{"cmd_$cmd"};
7151 $fn or badusage "unknown operation $cmd";