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 = 0;
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";
4759 sub cmd_push_source {
4762 my $changes = parsecontrol("$buildproductsdir/$changesfile",
4763 "source changes file");
4764 unless (test_source_only_changes($changes)) {
4765 fail "user-specified changes file is not source-only";
4768 # Building a source package is very fast, so just do it
4769 build_source_for_push();
4774 #---------- remote commands' implementation ----------
4776 sub pre_remote_push_build_host {
4777 my ($nrargs) = shift @ARGV;
4778 my (@rargs) = @ARGV[0..$nrargs-1];
4779 @ARGV = @ARGV[$nrargs..$#ARGV];
4781 my ($dir,$vsnwant) = @rargs;
4782 # vsnwant is a comma-separated list; we report which we have
4783 # chosen in our ready response (so other end can tell if they
4786 $we_are_responder = 1;
4787 $us .= " (build host)";
4789 open PI, "<&STDIN" or die $!;
4790 open STDIN, "/dev/null" or die $!;
4791 open PO, ">&STDOUT" or die $!;
4793 open STDOUT, ">&STDERR" or die $!;
4797 ($protovsn) = grep {
4798 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4799 } @rpushprotovsn_support;
4801 fail "build host has dgit rpush protocol versions ".
4802 (join ",", @rpushprotovsn_support).
4803 " but invocation host has $vsnwant"
4804 unless defined $protovsn;
4808 sub cmd_remote_push_build_host {
4809 responder_send_command("dgit-remote-push-ready $protovsn");
4813 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4814 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4815 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4816 # a good error message)
4818 sub rpush_handle_protovsn_bothends () {
4819 if ($protovsn < 4) {
4820 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4829 my $report = i_child_report();
4830 if (defined $report) {
4831 printdebug "($report)\n";
4832 } elsif ($i_child_pid) {
4833 printdebug "(killing build host child $i_child_pid)\n";
4834 kill 15, $i_child_pid;
4836 if (defined $i_tmp && !defined $initiator_tempdir) {
4838 eval { rmtree $i_tmp; };
4843 return unless forkcheck_mainprocess();
4848 my ($base,$selector,@args) = @_;
4849 $selector =~ s/\-/_/g;
4850 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4854 not_necessarily_a_tree();
4859 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4867 push @rargs, join ",", @rpushprotovsn_support;
4870 push @rdgit, @ropts;
4871 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4873 my @cmd = (@ssh, $host, shellquote @rdgit);
4876 $we_are_initiator=1;
4878 if (defined $initiator_tempdir) {
4879 rmtree $initiator_tempdir;
4880 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4881 $i_tmp = $initiator_tempdir;
4885 $i_child_pid = open2(\*RO, \*RI, @cmd);
4887 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4888 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4889 $supplementary_message = '' unless $protovsn >= 3;
4892 my ($icmd,$iargs) = initiator_expect {
4893 m/^(\S+)(?: (.*))?$/;
4896 i_method "i_resp", $icmd, $iargs;
4900 sub i_resp_progress ($) {
4902 my $msg = protocol_read_bytes \*RO, $rhs;
4906 sub i_resp_supplementary_message ($) {
4908 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4911 sub i_resp_complete {
4912 my $pid = $i_child_pid;
4913 $i_child_pid = undef; # prevents killing some other process with same pid
4914 printdebug "waiting for build host child $pid...\n";
4915 my $got = waitpid $pid, 0;
4916 die $! unless $got == $pid;
4917 die "build host child failed $?" if $?;
4920 printdebug "all done\n";
4924 sub i_resp_file ($) {
4926 my $localname = i_method "i_localname", $keyword;
4927 my $localpath = "$i_tmp/$localname";
4928 stat_exists $localpath and
4929 badproto \*RO, "file $keyword ($localpath) twice";
4930 protocol_receive_file \*RO, $localpath;
4931 i_method "i_file", $keyword;
4936 sub i_resp_param ($) {
4937 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4941 sub i_resp_previously ($) {
4942 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4943 or badproto \*RO, "bad previously spec";
4944 my $r = system qw(git check-ref-format), $1;
4945 die "bad previously ref spec ($r)" if $r;
4946 $previously{$1} = $2;
4951 sub i_resp_want ($) {
4953 die "$keyword ?" if $i_wanted{$keyword}++;
4955 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4956 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4957 die unless $isuite =~ m/^$suite_re$/;
4960 rpush_handle_protovsn_bothends();
4962 fail "rpush negotiated protocol version $protovsn".
4963 " which does not support quilt mode $quilt_mode"
4964 if quiltmode_splitbrain;
4966 my @localpaths = i_method "i_want", $keyword;
4967 printdebug "[[ $keyword @localpaths\n";
4968 foreach my $localpath (@localpaths) {
4969 protocol_send_file \*RI, $localpath;
4971 print RI "files-end\n" or die $!;
4974 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4976 sub i_localname_parsed_changelog {
4977 return "remote-changelog.822";
4979 sub i_file_parsed_changelog {
4980 ($i_clogp, $i_version, $i_dscfn) =
4981 push_parse_changelog "$i_tmp/remote-changelog.822";
4982 die if $i_dscfn =~ m#/|^\W#;
4985 sub i_localname_dsc {
4986 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4991 sub i_localname_buildinfo ($) {
4992 my $bi = $i_param{'buildinfo-filename'};
4993 defined $bi or badproto \*RO, "buildinfo before filename";
4994 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4995 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4996 or badproto \*RO, "improper buildinfo filename";
4999 sub i_file_buildinfo {
5000 my $bi = $i_param{'buildinfo-filename'};
5001 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5002 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5003 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5004 files_compare_inputs($bd, $ch);
5005 (getfield $bd, $_) eq (getfield $ch, $_) or
5006 fail "buildinfo mismatch $_"
5007 foreach qw(Source Version);
5008 !defined $bd->{$_} or
5009 fail "buildinfo contains $_"
5010 foreach qw(Changes Changed-by Distribution);
5012 push @i_buildinfos, $bi;
5013 delete $i_param{'buildinfo-filename'};
5016 sub i_localname_changes {
5017 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5018 $i_changesfn = $i_dscfn;
5019 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5020 return $i_changesfn;
5022 sub i_file_changes { }
5024 sub i_want_signed_tag {
5025 printdebug Dumper(\%i_param, $i_dscfn);
5026 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5027 && defined $i_param{'csuite'}
5028 or badproto \*RO, "premature desire for signed-tag";
5029 my $head = $i_param{'head'};
5030 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5032 my $maintview = $i_param{'maint-view'};
5033 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5036 if ($protovsn >= 4) {
5037 my $p = $i_param{'tagformat'} // '<undef>';
5039 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5042 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5044 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5046 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5049 push_mktags $i_clogp, $i_dscfn,
5050 $i_changesfn, 'remote changes',
5054 sub i_want_signed_dsc_changes {
5055 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5056 sign_changes $i_changesfn;
5057 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5060 #---------- building etc. ----------
5066 #----- `3.0 (quilt)' handling -----
5068 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5070 sub quiltify_dpkg_commit ($$$;$) {
5071 my ($patchname,$author,$msg, $xinfo) = @_;
5074 mkpath '.git/dgit'; # we are in playtree
5075 my $descfn = ".git/dgit/quilt-description.tmp";
5076 open O, '>', $descfn or die "$descfn: $!";
5077 $msg =~ s/\n+/\n\n/;
5078 print O <<END or die $!;
5080 ${xinfo}Subject: $msg
5087 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5088 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5089 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5090 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5094 sub quiltify_trees_differ ($$;$$$) {
5095 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5096 # returns true iff the two tree objects differ other than in debian/
5097 # with $finegrained,
5098 # returns bitmask 01 - differ in upstream files except .gitignore
5099 # 02 - differ in .gitignore
5100 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5101 # is set for each modified .gitignore filename $fn
5102 # if $unrepres is defined, array ref to which is appeneded
5103 # a list of unrepresentable changes (removals of upstream files
5106 my @cmd = (@git, qw(diff-tree -z --no-renames));
5107 push @cmd, qw(--name-only) unless $unrepres;
5108 push @cmd, qw(-r) if $finegrained || $unrepres;
5110 my $diffs= cmdoutput @cmd;
5113 foreach my $f (split /\0/, $diffs) {
5114 if ($unrepres && !@lmodes) {
5115 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5118 my ($oldmode,$newmode) = @lmodes;
5121 next if $f =~ m#^debian(?:/.*)?$#s;
5125 die "not a plain file or symlink\n"
5126 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5127 $oldmode =~ m/^(?:10|12)\d{4}$/;
5128 if ($oldmode =~ m/[^0]/ &&
5129 $newmode =~ m/[^0]/) {
5130 # both old and new files exist
5131 die "mode or type changed\n" if $oldmode ne $newmode;
5132 die "modified symlink\n" unless $newmode =~ m/^10/;
5133 } elsif ($oldmode =~ m/[^0]/) {
5135 die "deletion of symlink\n"
5136 unless $oldmode =~ m/^10/;
5139 die "creation with non-default mode\n"
5140 unless $newmode =~ m/^100644$/ or
5141 $newmode =~ m/^120000$/;
5145 local $/="\n"; chomp $@;
5146 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5150 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5151 $r |= $isignore ? 02 : 01;
5152 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5154 printdebug "quiltify_trees_differ $x $y => $r\n";
5158 sub quiltify_tree_sentinelfiles ($) {
5159 # lists the `sentinel' files present in the tree
5161 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5162 qw(-- debian/rules debian/control);
5167 sub quiltify_splitbrain_needed () {
5168 if (!$split_brain) {
5169 progress "dgit view: changes are required...";
5170 runcmd @git, qw(checkout -q -b dgit-view);
5175 sub quiltify_splitbrain ($$$$$$$) {
5176 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5177 $editedignores, $cachekey) = @_;
5178 my $gitignore_special = 1;
5179 if ($quilt_mode !~ m/gbp|dpm/) {
5180 # treat .gitignore just like any other upstream file
5181 $diffbits = { %$diffbits };
5182 $_ = !!$_ foreach values %$diffbits;
5183 $gitignore_special = 0;
5185 # We would like any commits we generate to be reproducible
5186 my @authline = clogp_authline($clogp);
5187 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5188 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5189 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5190 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5191 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5192 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5194 my $fulldiffhint = sub {
5196 my $cmd = "git diff $x $y -- :/ ':!debian'";
5197 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5198 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5201 if ($quilt_mode =~ m/gbp|unapplied/ &&
5202 ($diffbits->{O2H} & 01)) {
5204 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5205 " but git tree differs from orig in upstream files.";
5206 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5207 if (!stat_exists "debian/patches") {
5209 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5213 if ($quilt_mode =~ m/dpm/ &&
5214 ($diffbits->{H2A} & 01)) {
5215 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5216 --quilt=$quilt_mode specified, implying patches-applied git tree
5217 but git tree differs from result of applying debian/patches to upstream
5220 if ($quilt_mode =~ m/gbp|unapplied/ &&
5221 ($diffbits->{O2A} & 01)) { # some patches
5222 quiltify_splitbrain_needed();
5223 progress "dgit view: creating patches-applied version using gbp pq";
5224 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5225 # gbp pq import creates a fresh branch; push back to dgit-view
5226 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5227 runcmd @git, qw(checkout -q dgit-view);
5229 if ($quilt_mode =~ m/gbp|dpm/ &&
5230 ($diffbits->{O2A} & 02)) {
5232 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5233 tool which does not create patches for changes to upstream
5234 .gitignores: but, such patches exist in debian/patches.
5237 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5238 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5239 quiltify_splitbrain_needed();
5240 progress "dgit view: creating patch to represent .gitignore changes";
5241 ensuredir "debian/patches";
5242 my $gipatch = "debian/patches/auto-gitignore";
5243 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5244 stat GIPATCH or die "$gipatch: $!";
5245 fail "$gipatch already exists; but want to create it".
5246 " to record .gitignore changes" if (stat _)[7];
5247 print GIPATCH <<END or die "$gipatch: $!";
5248 Subject: Update .gitignore from Debian packaging branch
5250 The Debian packaging git branch contains these updates to the upstream
5251 .gitignore file(s). This patch is autogenerated, to provide these
5252 updates to users of the official Debian archive view of the package.
5254 [dgit ($our_version) update-gitignore]
5257 close GIPATCH or die "$gipatch: $!";
5258 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5259 $unapplied, $headref, "--", sort keys %$editedignores;
5260 open SERIES, "+>>", "debian/patches/series" or die $!;
5261 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5263 defined read SERIES, $newline, 1 or die $!;
5264 print SERIES "\n" or die $! unless $newline eq "\n";
5265 print SERIES "auto-gitignore\n" or die $!;
5266 close SERIES or die $!;
5267 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5269 Commit patch to update .gitignore
5271 [dgit ($our_version) update-gitignore-quilt-fixup]
5275 my $dgitview = git_rev_parse 'HEAD';
5278 # When we no longer need to support squeeze, use --create-reflog
5280 ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5281 my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5284 my $oldcache = git_get_ref "refs/$splitbraincache";
5285 if ($oldcache eq $dgitview) {
5286 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5287 # git update-ref doesn't always update, in this case. *sigh*
5288 my $dummy = make_commit_text <<END;
5291 author Dgit <dgit\@example.com> 1000000000 +0000
5292 committer Dgit <dgit\@example.com> 1000000000 +0000
5294 Dummy commit - do not use
5296 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5297 "refs/$splitbraincache", $dummy;
5299 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5302 changedir "$playground/work";
5304 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5305 progress "dgit view: created ($saved)";
5308 sub quiltify ($$$$) {
5309 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5311 # Quilt patchification algorithm
5313 # We search backwards through the history of the main tree's HEAD
5314 # (T) looking for a start commit S whose tree object is identical
5315 # to to the patch tip tree (ie the tree corresponding to the
5316 # current dpkg-committed patch series). For these purposes
5317 # `identical' disregards anything in debian/ - this wrinkle is
5318 # necessary because dpkg-source treates debian/ specially.
5320 # We can only traverse edges where at most one of the ancestors'
5321 # trees differs (in changes outside in debian/). And we cannot
5322 # handle edges which change .pc/ or debian/patches. To avoid
5323 # going down a rathole we avoid traversing edges which introduce
5324 # debian/rules or debian/control. And we set a limit on the
5325 # number of edges we are willing to look at.
5327 # If we succeed, we walk forwards again. For each traversed edge
5328 # PC (with P parent, C child) (starting with P=S and ending with
5329 # C=T) to we do this:
5331 # - dpkg-source --commit with a patch name and message derived from C
5332 # After traversing PT, we git commit the changes which
5333 # should be contained within debian/patches.
5335 # The search for the path S..T is breadth-first. We maintain a
5336 # todo list containing search nodes. A search node identifies a
5337 # commit, and looks something like this:
5339 # Commit => $git_commit_id,
5340 # Child => $c, # or undef if P=T
5341 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5342 # Nontrivial => true iff $p..$c has relevant changes
5349 my %considered; # saves being exponential on some weird graphs
5351 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5354 my ($search,$whynot) = @_;
5355 printdebug " search NOT $search->{Commit} $whynot\n";
5356 $search->{Whynot} = $whynot;
5357 push @nots, $search;
5358 no warnings qw(exiting);
5367 my $c = shift @todo;
5368 next if $considered{$c->{Commit}}++;
5370 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5372 printdebug "quiltify investigate $c->{Commit}\n";
5375 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5376 printdebug " search finished hooray!\n";
5381 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5382 if ($quilt_mode eq 'smash') {
5383 printdebug " search quitting smash\n";
5387 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5388 $not->($c, "has $c_sentinels not $t_sentinels")
5389 if $c_sentinels ne $t_sentinels;
5391 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5392 $commitdata =~ m/\n\n/;
5394 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5395 @parents = map { { Commit => $_, Child => $c } } @parents;
5397 $not->($c, "root commit") if !@parents;
5399 foreach my $p (@parents) {
5400 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5402 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5403 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5405 foreach my $p (@parents) {
5406 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5408 my @cmd= (@git, qw(diff-tree -r --name-only),
5409 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5410 my $patchstackchange = cmdoutput @cmd;
5411 if (length $patchstackchange) {
5412 $patchstackchange =~ s/\n/,/g;
5413 $not->($p, "changed $patchstackchange");
5416 printdebug " search queue P=$p->{Commit} ",
5417 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5423 printdebug "quiltify want to smash\n";
5426 my $x = $_[0]{Commit};
5427 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5430 my $reportnot = sub {
5432 my $s = $abbrev->($notp);
5433 my $c = $notp->{Child};
5434 $s .= "..".$abbrev->($c) if $c;
5435 $s .= ": ".$notp->{Whynot};
5438 if ($quilt_mode eq 'linear') {
5439 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5440 foreach my $notp (@nots) {
5441 print STDERR "$us: ", $reportnot->($notp), "\n";
5443 print STDERR "$us: $_\n" foreach @$failsuggestion;
5445 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n".
5446 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5447 } elsif ($quilt_mode eq 'smash') {
5448 } elsif ($quilt_mode eq 'auto') {
5449 progress "quilt fixup cannot be linear, smashing...";
5451 die "$quilt_mode ?";
5454 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5455 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5457 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5459 quiltify_dpkg_commit "auto-$version-$target-$time",
5460 (getfield $clogp, 'Maintainer'),
5461 "Automatically generated patch ($clogp->{Version})\n".
5462 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5466 progress "quiltify linearisation planning successful, executing...";
5468 for (my $p = $sref_S;
5469 my $c = $p->{Child};
5471 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5472 next unless $p->{Nontrivial};
5474 my $cc = $c->{Commit};
5476 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5477 $commitdata =~ m/\n\n/ or die "$c ?";
5480 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5483 my $commitdate = cmdoutput
5484 @git, qw(log -n1 --pretty=format:%aD), $cc;
5486 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5488 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5495 my $gbp_check_suitable = sub {
5500 die "contains unexpected slashes\n" if m{//} || m{/$};
5501 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5502 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5503 die "is series file\n" if m{$series_filename_re}o;
5504 die "too long" if length > 200;
5506 return $_ unless $@;
5507 print STDERR "quiltifying commit $cc:".
5508 " ignoring/dropping Gbp-Pq $what: $@";
5512 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5514 (\S+) \s* \n //ixm) {
5515 $patchname = $gbp_check_suitable->($1, 'Name');
5517 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5519 (\S+) \s* \n //ixm) {
5520 $patchdir = $gbp_check_suitable->($1, 'Topic');
5525 if (!defined $patchname) {
5526 $patchname = $title;
5527 $patchname =~ s/[.:]$//;
5530 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5531 my $translitname = $converter->convert($patchname);
5532 die unless defined $translitname;
5533 $patchname = $translitname;
5536 "dgit: patch title transliteration error: $@"
5538 $patchname =~ y/ A-Z/-a-z/;
5539 $patchname =~ y/-a-z0-9_.+=~//cd;
5540 $patchname =~ s/^\W/x-$&/;
5541 $patchname = substr($patchname,0,40);
5542 $patchname .= ".patch";
5544 if (!defined $patchdir) {
5547 if (length $patchdir) {
5548 $patchname = "$patchdir/$patchname";
5550 if ($patchname =~ m{^(.*)/}) {
5551 mkpath "debian/patches/$1";
5556 stat "debian/patches/$patchname$index";
5558 $!==ENOENT or die "$patchname$index $!";
5560 runcmd @git, qw(checkout -q), $cc;
5562 # We use the tip's changelog so that dpkg-source doesn't
5563 # produce complaining messages from dpkg-parsechangelog. None
5564 # of the information dpkg-source gets from the changelog is
5565 # actually relevant - it gets put into the original message
5566 # which dpkg-source provides our stunt editor, and then
5568 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5570 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5571 "Date: $commitdate\n".
5572 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5574 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5577 runcmd @git, qw(checkout -q master);
5580 sub build_maybe_quilt_fixup () {
5581 my ($format,$fopts) = get_source_format;
5582 return unless madformat_wantfixup $format;
5585 check_for_vendor_patches();
5587 if (quiltmode_splitbrain) {
5588 fail <<END unless access_cfg_tagformats_can_splitbrain;
5589 quilt mode $quilt_mode requires split view so server needs to support
5590 both "new" and "maint" tag formats, but config says it doesn't.
5594 my $clogp = parsechangelog();
5595 my $headref = git_rev_parse('HEAD');
5596 my $symref = git_get_symref();
5598 if ($quilt_mode eq 'linear'
5599 && !$fopts->{'single-debian-patch'}
5600 && branch_is_gdr($symref, $headref)) {
5601 # This is much faster. It also makes patches that gdr
5602 # likes better for future updates without laundering.
5604 # However, it can fail in some casses where we would
5605 # succeed: if there are existing patches, which correspond
5606 # to a prefix of the branch, but are not in gbp/gdr
5607 # format, gdr will fail (exiting status 7), but we might
5608 # be able to figure out where to start linearising. That
5609 # will be slower so hopefully there's not much to do.
5610 my @cmd = (@git_debrebase,
5611 qw(--noop-ok -funclean-mixed -funclean-ordering
5612 make-patches --quiet-would-amend));
5613 # We tolerate soe snags that gdr wouldn't, by default.
5617 failedcmd @cmd if system @cmd and $?!=7*256;
5621 $headref = git_rev_parse('HEAD');
5625 changedir $playground;
5627 my $upstreamversion = upstreamversion $version;
5629 if ($fopts->{'single-debian-patch'}) {
5630 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5632 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5635 die 'bug' if $split_brain && !$need_split_build_invocation;
5638 runcmd_ordryrun_local
5639 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5642 sub unpack_playtree_mkwork ($) {
5645 mkdir "work" or die $!;
5647 mktree_in_ud_here();
5648 runcmd @git, qw(reset -q --hard), $headref;
5651 sub unpack_playtree_linkorigs ($$) {
5652 my ($upstreamversion, $fn) = @_;
5653 # calls $fn->($leafname);
5655 my $bpd_abs = bpd_abs();
5656 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5657 while ($!=0, defined(my $b = readdir QFD)) {
5658 my $f = bpd_abs()."/".$b;
5660 local ($debuglevel) = $debuglevel-1;
5661 printdebug "QF linkorigs $b, $f ?\n";
5663 next unless is_orig_file_of_vsn $b, $upstreamversion;
5664 printdebug "QF linkorigs $b, $f Y\n";
5665 link_ltarget $f, $b or die "$b $!";
5668 die "$buildproductsdir: $!" if $!;
5672 sub quilt_fixup_delete_pc () {
5673 runcmd @git, qw(rm -rqf .pc);
5675 Commit removal of .pc (quilt series tracking data)
5677 [dgit ($our_version) upgrade quilt-remove-pc]
5681 sub quilt_fixup_singlepatch ($$$) {
5682 my ($clogp, $headref, $upstreamversion) = @_;
5684 progress "starting quiltify (single-debian-patch)";
5686 # dpkg-source --commit generates new patches even if
5687 # single-debian-patch is in debian/source/options. In order to
5688 # get it to generate debian/patches/debian-changes, it is
5689 # necessary to build the source package.
5691 unpack_playtree_linkorigs($upstreamversion, sub { });
5692 unpack_playtree_mkwork($headref);
5694 rmtree("debian/patches");
5696 runcmd @dpkgsource, qw(-b .);
5698 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5699 rename srcfn("$upstreamversion", "/debian/patches"),
5700 "work/debian/patches";
5703 commit_quilty_patch();
5706 sub quilt_make_fake_dsc ($) {
5707 my ($upstreamversion) = @_;
5709 my $fakeversion="$upstreamversion-~~DGITFAKE";
5711 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5712 print $fakedsc <<END or die $!;
5715 Version: $fakeversion
5719 my $dscaddfile=sub {
5722 my $md = new Digest::MD5;
5724 my $fh = new IO::File $b, '<' or die "$b $!";
5729 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5732 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5734 my @files=qw(debian/source/format debian/rules
5735 debian/control debian/changelog);
5736 foreach my $maybe (qw(debian/patches debian/source/options
5737 debian/tests/control)) {
5738 next unless stat_exists "$maindir/$maybe";
5739 push @files, $maybe;
5742 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5743 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5745 $dscaddfile->($debtar);
5746 close $fakedsc or die $!;
5749 sub quilt_check_splitbrain_cache ($$) {
5750 my ($headref, $upstreamversion) = @_;
5751 # Called only if we are in (potentially) split brain mode.
5752 # Called in playground.
5753 # Computes the cache key and looks in the cache.
5754 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5756 my $splitbrain_cachekey;
5759 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5760 # we look in the reflog of dgit-intern/quilt-cache
5761 # we look for an entry whose message is the key for the cache lookup
5762 my @cachekey = (qw(dgit), $our_version);
5763 push @cachekey, $upstreamversion;
5764 push @cachekey, $quilt_mode;
5765 push @cachekey, $headref;
5767 push @cachekey, hashfile('fake.dsc');
5769 my $srcshash = Digest::SHA->new(256);
5770 my %sfs = ( %INC, '$0(dgit)' => $0 );
5771 foreach my $sfk (sort keys %sfs) {
5772 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5773 $srcshash->add($sfk," ");
5774 $srcshash->add(hashfile($sfs{$sfk}));
5775 $srcshash->add("\n");
5777 push @cachekey, $srcshash->hexdigest();
5778 $splitbrain_cachekey = "@cachekey";
5780 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5782 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5783 debugcmd "|(probably)",@cmd;
5784 my $child = open GC, "-|"; defined $child or die $!;
5786 chdir $maindir or die $!;
5787 if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5788 $! == ENOENT or die $!;
5789 printdebug ">(no reflog)\n";
5796 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5797 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5800 unpack_playtree_mkwork($headref);
5801 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5802 if ($cachehit ne $headref) {
5803 progress "dgit view: found cached ($saved)";
5804 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5806 return ($cachehit, $splitbrain_cachekey);
5808 progress "dgit view: found cached, no changes required";
5809 return ($headref, $splitbrain_cachekey);
5811 die $! if GC->error;
5812 failedcmd unless close GC;
5814 printdebug "splitbrain cache miss\n";
5815 return (undef, $splitbrain_cachekey);
5818 sub quilt_fixup_multipatch ($$$) {
5819 my ($clogp, $headref, $upstreamversion) = @_;
5821 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5824 # - honour any existing .pc in case it has any strangeness
5825 # - determine the git commit corresponding to the tip of
5826 # the patch stack (if there is one)
5827 # - if there is such a git commit, convert each subsequent
5828 # git commit into a quilt patch with dpkg-source --commit
5829 # - otherwise convert all the differences in the tree into
5830 # a single git commit
5834 # Our git tree doesn't necessarily contain .pc. (Some versions of
5835 # dgit would include the .pc in the git tree.) If there isn't
5836 # one, we need to generate one by unpacking the patches that we
5839 # We first look for a .pc in the git tree. If there is one, we
5840 # will use it. (This is not the normal case.)
5842 # Otherwise need to regenerate .pc so that dpkg-source --commit
5843 # can work. We do this as follows:
5844 # 1. Collect all relevant .orig from parent directory
5845 # 2. Generate a debian.tar.gz out of
5846 # debian/{patches,rules,source/format,source/options}
5847 # 3. Generate a fake .dsc containing just these fields:
5848 # Format Source Version Files
5849 # 4. Extract the fake .dsc
5850 # Now the fake .dsc has a .pc directory.
5851 # (In fact we do this in every case, because in future we will
5852 # want to search for a good base commit for generating patches.)
5854 # Then we can actually do the dpkg-source --commit
5855 # 1. Make a new working tree with the same object
5856 # store as our main tree and check out the main
5858 # 2. Copy .pc from the fake's extraction, if necessary
5859 # 3. Run dpkg-source --commit
5860 # 4. If the result has changes to debian/, then
5861 # - git add them them
5862 # - git add .pc if we had a .pc in-tree
5864 # 5. If we had a .pc in-tree, delete it, and git commit
5865 # 6. Back in the main tree, fast forward to the new HEAD
5867 # Another situation we may have to cope with is gbp-style
5868 # patches-unapplied trees.
5870 # We would want to detect these, so we know to escape into
5871 # quilt_fixup_gbp. However, this is in general not possible.
5872 # Consider a package with a one patch which the dgit user reverts
5873 # (with git revert or the moral equivalent).
5875 # That is indistinguishable in contents from a patches-unapplied
5876 # tree. And looking at the history to distinguish them is not
5877 # useful because the user might have made a confusing-looking git
5878 # history structure (which ought to produce an error if dgit can't
5879 # cope, not a silent reintroduction of an unwanted patch).
5881 # So gbp users will have to pass an option. But we can usually
5882 # detect their failure to do so: if the tree is not a clean
5883 # patches-applied tree, quilt linearisation fails, but the tree
5884 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5885 # they want --quilt=unapplied.
5887 # To help detect this, when we are extracting the fake dsc, we
5888 # first extract it with --skip-patches, and then apply the patches
5889 # afterwards with dpkg-source --before-build. That lets us save a
5890 # tree object corresponding to .origs.
5892 my $splitbrain_cachekey;
5894 quilt_make_fake_dsc($upstreamversion);
5896 if (quiltmode_splitbrain()) {
5898 ($cachehit, $splitbrain_cachekey) =
5899 quilt_check_splitbrain_cache($headref, $upstreamversion);
5900 return if $cachehit;
5904 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5906 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5907 rename $fakexdir, "fake" or die "$fakexdir $!";
5911 remove_stray_gits("source package");
5912 mktree_in_ud_here();
5916 rmtree 'debian'; # git checkout commitish paths does not delete!
5917 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5918 my $unapplied=git_add_write_tree();
5919 printdebug "fake orig tree object $unapplied\n";
5923 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5925 if (system @bbcmd) {
5926 failedcmd @bbcmd if $? < 0;
5928 failed to apply your git tree's patch stack (from debian/patches/) to
5929 the corresponding upstream tarball(s). Your source tree and .orig
5930 are probably too inconsistent. dgit can only fix up certain kinds of
5931 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5937 unpack_playtree_mkwork($headref);
5940 if (stat_exists ".pc") {
5942 progress "Tree already contains .pc - will use it then delete it.";
5945 rename '../fake/.pc','.pc' or die $!;
5948 changedir '../fake';
5950 my $oldtiptree=git_add_write_tree();
5951 printdebug "fake o+d/p tree object $unapplied\n";
5952 changedir '../work';
5955 # We calculate some guesswork now about what kind of tree this might
5956 # be. This is mostly for error reporting.
5962 # O = orig, without patches applied
5963 # A = "applied", ie orig with H's debian/patches applied
5964 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5965 \%editedignores, \@unrepres),
5966 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5967 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5971 foreach my $b (qw(01 02)) {
5972 foreach my $v (qw(O2H O2A H2A)) {
5973 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5976 printdebug "differences \@dl @dl.\n";
5979 "$us: base trees orig=%.20s o+d/p=%.20s",
5980 $unapplied, $oldtiptree;
5982 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5983 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5984 $dl[0], $dl[1], $dl[3], $dl[4],
5988 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5990 forceable_fail [qw(unrepresentable)], <<END;
5991 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5996 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5997 push @failsuggestion, "This might be a patches-unapplied branch.";
5998 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5999 push @failsuggestion, "This might be a patches-applied branch.";
6001 push @failsuggestion, "Maybe you need to specify one of".
6002 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
6004 if (quiltmode_splitbrain()) {
6005 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6006 $diffbits, \%editedignores,
6007 $splitbrain_cachekey);
6011 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6012 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6014 if (!open P, '>>', ".pc/applied-patches") {
6015 $!==&ENOENT or die $!;
6020 commit_quilty_patch();
6022 if ($mustdeletepc) {
6023 quilt_fixup_delete_pc();
6027 sub quilt_fixup_editor () {
6028 my $descfn = $ENV{$fakeeditorenv};
6029 my $editing = $ARGV[$#ARGV];
6030 open I1, '<', $descfn or die "$descfn: $!";
6031 open I2, '<', $editing or die "$editing: $!";
6032 unlink $editing or die "$editing: $!";
6033 open O, '>', $editing or die "$editing: $!";
6034 while (<I1>) { print O or die $!; } I1->error and die $!;
6037 $copying ||= m/^\-\-\- /;
6038 next unless $copying;
6041 I2->error and die $!;
6046 sub maybe_apply_patches_dirtily () {
6047 return unless $quilt_mode =~ m/gbp|unapplied/;
6048 print STDERR <<END or die $!;
6050 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6051 dgit: Have to apply the patches - making the tree dirty.
6052 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6055 $patches_applied_dirtily = 01;
6056 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6057 runcmd qw(dpkg-source --before-build .);
6060 sub maybe_unapply_patches_again () {
6061 progress "dgit: Unapplying patches again to tidy up the tree."
6062 if $patches_applied_dirtily;
6063 runcmd qw(dpkg-source --after-build .)
6064 if $patches_applied_dirtily & 01;
6066 if $patches_applied_dirtily & 02;
6067 $patches_applied_dirtily = 0;
6070 #----- other building -----
6072 our $clean_using_builder;
6073 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6074 # clean the tree before building (perhaps invoked indirectly by
6075 # whatever we are using to run the build), rather than separately
6076 # and explicitly by us.
6079 return if $clean_using_builder;
6080 if ($cleanmode eq 'dpkg-source') {
6081 maybe_apply_patches_dirtily();
6082 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6083 } elsif ($cleanmode eq 'dpkg-source-d') {
6084 maybe_apply_patches_dirtily();
6085 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6086 } elsif ($cleanmode eq 'git') {
6087 runcmd_ordryrun_local @git, qw(clean -xdf);
6088 } elsif ($cleanmode eq 'git-ff') {
6089 runcmd_ordryrun_local @git, qw(clean -xdff);
6090 } elsif ($cleanmode eq 'check') {
6091 my $leftovers = cmdoutput @git, qw(clean -xdn);
6092 if (length $leftovers) {
6093 print STDERR $leftovers, "\n" or die $!;
6094 fail "tree contains uncommitted files and --clean=check specified";
6096 } elsif ($cleanmode eq 'none') {
6103 badusage "clean takes no additional arguments" if @ARGV;
6106 maybe_unapply_patches_again();
6109 sub build_or_push_prep_early () {
6110 our $build_or_push_prep_early_done //= 0;
6111 return if $build_or_push_prep_early_done++;
6112 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6113 my $clogp = parsechangelog();
6114 $isuite = getfield $clogp, 'Distribution';
6115 $package = getfield $clogp, 'Source';
6116 $version = getfield $clogp, 'Version';
6119 sub build_prep_early () {
6120 build_or_push_prep_early();
6128 build_maybe_quilt_fixup();
6130 my $pat = changespat $version;
6131 foreach my $f (glob "$buildproductsdir/$pat") {
6133 unlink $f or fail "remove old changes file $f: $!";
6135 progress "would remove $f";
6141 sub changesopts_initial () {
6142 my @opts =@changesopts[1..$#changesopts];
6145 sub changesopts_version () {
6146 if (!defined $changes_since_version) {
6149 @vsns = archive_query('archive_query');
6150 my @quirk = access_quirk();
6151 if ($quirk[0] eq 'backports') {
6152 local $isuite = $quirk[2];
6154 canonicalise_suite();
6155 push @vsns, archive_query('archive_query');
6161 "archive query failed (queried because --since-version not specified)";
6164 @vsns = map { $_->[0] } @vsns;
6165 @vsns = sort { -version_compare($a, $b) } @vsns;
6166 $changes_since_version = $vsns[0];
6167 progress "changelog will contain changes since $vsns[0]";
6169 $changes_since_version = '_';
6170 progress "package seems new, not specifying -v<version>";
6173 if ($changes_since_version ne '_') {
6174 return ("-v$changes_since_version");
6180 sub changesopts () {
6181 return (changesopts_initial(), changesopts_version());
6184 # return values from massage_dbp_args are one or both of these flags
6185 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6186 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6188 sub massage_dbp_args ($;$) {
6189 my ($cmd,$xargs) = @_;
6192 # - if we're going to split the source build out so we can
6193 # do strange things to it, massage the arguments to dpkg-buildpackage
6194 # so that the main build doessn't build source (or add an argument
6195 # to stop it building source by default).
6197 # - add -nc to stop dpkg-source cleaning the source tree,
6198 # unless we're not doing a split build and want dpkg-source
6199 # as cleanmode, in which case we can do nothing
6201 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6202 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
6203 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
6204 $clean_using_builder = 1;
6205 return WANTSRC_BUILDER;
6207 # -nc has the side effect of specifying -b if nothing else specified
6208 # and some combinations of -S, -b, et al, are errors, rather than
6209 # later simply overriding earlie. So we need to:
6210 # - search the command line for these options
6211 # - pick the last one
6212 # - perhaps add our own as a default
6213 # - perhaps adjust it to the corresponding non-source-building version
6215 foreach my $l ($cmd, $xargs) {
6217 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6220 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6221 my $r = WANTSRC_BUILDER;
6222 if ($need_split_build_invocation) {
6223 printdebug "massage split $dmode.\n";
6224 $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6225 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6226 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6229 printdebug "massage done $r $dmode.\n";
6231 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6237 my $wasdir = must_getcwd();
6238 changedir $buildproductsdir;
6243 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6244 sub postbuild_mergechanges ($) {
6245 my ($msg_if_onlyone) = @_;
6246 # If there is only one .changes file, fail with $msg_if_onlyone,
6247 # or if that is undef, be a no-op.
6248 # Returns the changes file to report to the user.
6249 my $pat = changespat $version;
6250 my @changesfiles = glob $pat;
6251 @changesfiles = sort {
6252 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6256 if (@changesfiles==1) {
6257 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6258 only one changes file from build (@changesfiles)
6260 $result = $changesfiles[0];
6261 } elsif (@changesfiles==2) {
6262 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6263 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6264 fail "$l found in binaries changes file $binchanges"
6267 runcmd_ordryrun_local @mergechanges, @changesfiles;
6268 my $multichanges = changespat $version,'multi';
6270 stat_exists $multichanges or fail "$multichanges: $!";
6271 foreach my $cf (glob $pat) {
6272 next if $cf eq $multichanges;
6273 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6276 $result = $multichanges;
6278 fail "wrong number of different changes files (@changesfiles)";
6280 printdone "build successful, results in $result\n" or die $!;
6283 sub midbuild_checkchanges () {
6284 my $pat = changespat $version;
6285 return if $rmchanges;
6286 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6287 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
6289 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6290 Suggest you delete @unwanted.
6295 sub midbuild_checkchanges_vanilla ($) {
6297 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6300 sub postbuild_mergechanges_vanilla ($) {
6302 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6304 postbuild_mergechanges(undef);
6307 printdone "build successful\n";
6313 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6314 my $wantsrc = massage_dbp_args \@dbp;
6315 if ($wantsrc & WANTSRC_SOURCE) {
6317 midbuild_checkchanges_vanilla $wantsrc;
6321 if ($wantsrc & WANTSRC_BUILDER) {
6322 push @dbp, changesopts_version();
6323 maybe_apply_patches_dirtily();
6324 runcmd_ordryrun_local @dbp;
6326 maybe_unapply_patches_again();
6327 postbuild_mergechanges_vanilla $wantsrc;
6331 $quilt_mode //= 'gbp';
6337 # gbp can make .origs out of thin air. In my tests it does this
6338 # even for a 1.0 format package, with no origs present. So I
6339 # guess it keys off just the version number. We don't know
6340 # exactly what .origs ought to exist, but let's assume that we
6341 # should run gbp if: the version has an upstream part and the main
6343 my $upstreamversion = upstreamversion $version;
6344 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6345 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6347 if ($gbp_make_orig) {
6349 $cleanmode = 'none'; # don't do it again
6350 $need_split_build_invocation = 1;
6353 my @dbp = @dpkgbuildpackage;
6355 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6357 if (!length $gbp_build[0]) {
6358 if (length executable_on_path('git-buildpackage')) {
6359 $gbp_build[0] = qw(git-buildpackage);
6361 $gbp_build[0] = 'gbp buildpackage';
6364 my @cmd = opts_opt_multi_cmd @gbp_build;
6366 push @cmd, (qw(-us -uc --git-no-sign-tags),
6367 "--git-builder=".(shellquote @dbp));
6369 if ($gbp_make_orig) {
6370 my $priv = dgit_privdir();
6371 my $ok = "$priv/origs-gen-ok";
6372 unlink $ok or $!==&ENOENT or die $!;
6373 my @origs_cmd = @cmd;
6374 push @origs_cmd, qw(--git-cleaner=true);
6375 push @origs_cmd, "--git-prebuild=".
6376 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6377 push @origs_cmd, @ARGV;
6379 debugcmd @origs_cmd;
6381 do { local $!; stat_exists $ok; }
6382 or failedcmd @origs_cmd;
6384 dryrun_report @origs_cmd;
6388 if ($wantsrc & WANTSRC_SOURCE) {
6390 midbuild_checkchanges_vanilla $wantsrc;
6392 if (!$clean_using_builder) {
6393 push @cmd, '--git-cleaner=true';
6397 maybe_unapply_patches_again();
6398 if ($wantsrc & WANTSRC_BUILDER) {
6399 push @cmd, changesopts();
6400 runcmd_ordryrun_local @cmd, @ARGV;
6402 postbuild_mergechanges_vanilla $wantsrc;
6404 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6406 sub build_source_for_push {
6408 maybe_unapply_patches_again();
6409 $changesfile = $sourcechanges;
6415 $sourcechanges = changespat $version,'source';
6417 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6418 or fail "remove $sourcechanges: $!";
6420 $dscfn = dscfn($version);
6421 my @cmd = (@dpkgsource, qw(-b --));
6423 changedir $playground;
6424 runcmd_ordryrun_local @cmd, "work";
6425 my @udfiles = <${package}_*>;
6427 foreach my $f (@udfiles) {
6428 printdebug "source copy, found $f\n";
6431 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6432 $f eq srcfn($version, $&));
6433 printdebug "source copy, found $f - renaming\n";
6434 rename "$playground/$f", "$buildproductsdir/$f" or $!==ENOENT
6435 or fail "put in place new source file ($f): $!";
6438 my $pwd = must_getcwd();
6439 my $leafdir = basename $pwd;
6441 runcmd_ordryrun_local @cmd, $leafdir;
6444 runcmd_ordryrun_local qw(sh -ec),
6445 'exec >$1; shift; exec "$@"','x',
6446 "$buildproductsdir/$sourcechanges",
6447 @dpkggenchanges, qw(-S), changesopts();
6450 sub cmd_build_source {
6452 badusage "build-source takes no additional arguments" if @ARGV;
6454 maybe_unapply_patches_again();
6455 printdone "source built, results in $dscfn and $sourcechanges";
6460 midbuild_checkchanges();
6463 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6464 stat_exists $sourcechanges
6465 or fail "$sourcechanges (in parent directory): $!";
6467 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6469 maybe_unapply_patches_again();
6471 postbuild_mergechanges(<<END);
6472 perhaps you need to pass -A ? (sbuild's default is to build only
6473 arch-specific binaries; dgit 1.4 used to override that.)
6478 sub cmd_quilt_fixup {
6479 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6482 build_maybe_quilt_fixup();
6485 sub import_dsc_result {
6486 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6487 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6489 check_gitattrs($newhash, "source tree");
6491 progress "dgit: import-dsc: $what_msg";
6494 sub cmd_import_dsc {
6498 last unless $ARGV[0] =~ m/^-/;
6501 if (m/^--require-valid-signature$/) {
6504 badusage "unknown dgit import-dsc sub-option \`$_'";
6508 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6509 my ($dscfn, $dstbranch) = @ARGV;
6511 badusage "dry run makes no sense with import-dsc" unless act_local();
6513 my $force = $dstbranch =~ s/^\+// ? +1 :
6514 $dstbranch =~ s/^\.\.// ? -1 :
6516 my $info = $force ? " $&" : '';
6517 $info = "$dscfn$info";
6519 my $specbranch = $dstbranch;
6520 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6521 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6523 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6524 my $chead = cmdoutput_errok @symcmd;
6525 defined $chead or $?==256 or failedcmd @symcmd;
6527 fail "$dstbranch is checked out - will not update it"
6528 if defined $chead and $chead eq $dstbranch;
6530 my $oldhash = git_get_ref $dstbranch;
6532 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6533 $dscdata = do { local $/ = undef; <D>; };
6534 D->error and fail "read $dscfn: $!";
6537 # we don't normally need this so import it here
6538 use Dpkg::Source::Package;
6539 my $dp = new Dpkg::Source::Package filename => $dscfn,
6540 require_valid_signature => $needsig;
6542 local $SIG{__WARN__} = sub {
6544 return unless $needsig;
6545 fail "import-dsc signature check failed";
6547 if (!$dp->is_signed()) {
6548 warn "$us: warning: importing unsigned .dsc\n";
6550 my $r = $dp->check_signature();
6551 die "->check_signature => $r" if $needsig && $r;
6557 $package = getfield $dsc, 'Source';
6559 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6560 unless forceing [qw(import-dsc-with-dgit-field)];
6561 parse_dsc_field_def_dsc_distro();
6563 $isuite = 'DGIT-IMPORT-DSC';
6564 $idistro //= $dsc_distro;
6568 if (defined $dsc_hash) {
6569 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6570 resolve_dsc_field_commit undef, undef;
6572 if (defined $dsc_hash) {
6573 my @cmd = (qw(sh -ec),
6574 "echo $dsc_hash | git cat-file --batch-check");
6575 my $objgot = cmdoutput @cmd;
6576 if ($objgot =~ m#^\w+ missing\b#) {
6578 .dsc contains Dgit field referring to object $dsc_hash
6579 Your git tree does not have that object. Try `git fetch' from a
6580 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6583 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6585 progress "Not fast forward, forced update.";
6587 fail "Not fast forward to $dsc_hash";
6590 import_dsc_result $dstbranch, $dsc_hash,
6591 "dgit import-dsc (Dgit): $info",
6592 "updated git ref $dstbranch";
6597 Branch $dstbranch already exists
6598 Specify ..$specbranch for a pseudo-merge, binding in existing history
6599 Specify +$specbranch to overwrite, discarding existing history
6601 if $oldhash && !$force;
6603 my @dfi = dsc_files_info();
6604 foreach my $fi (@dfi) {
6605 my $f = $fi->{Filename};
6606 my $here = "$buildproductsdir/$f";
6609 fail "lstat $here works but stat gives $! !";
6611 fail "stat $here: $!" unless $! == ENOENT;
6613 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6615 } elsif ($dscfn =~ m#^/#) {
6618 fail "cannot import $dscfn which seems to be inside working tree!";
6620 $there =~ s#/+[^/]+$## or
6621 fail "import $dscfn requires ../$f, but it does not exist";
6623 my $test = $there =~ m{^/} ? $there : "../$there";
6624 stat $test or fail "import $dscfn requires $test, but: $!";
6625 symlink $there, $here or fail "symlink $there to $here: $!";
6626 progress "made symlink $here -> $there";
6627 # print STDERR Dumper($fi);
6629 my @mergeinputs = generate_commits_from_dsc();
6630 die unless @mergeinputs == 1;
6632 my $newhash = $mergeinputs[0]{Commit};
6636 progress "Import, forced update - synthetic orphan git history.";
6637 } elsif ($force < 0) {
6638 progress "Import, merging.";
6639 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6640 my $version = getfield $dsc, 'Version';
6641 my $clogp = commit_getclogp $newhash;
6642 my $authline = clogp_authline $clogp;
6643 $newhash = make_commit_text <<END;
6650 Merge $package ($version) import into $dstbranch
6653 die; # caught earlier
6657 import_dsc_result $dstbranch, $newhash,
6658 "dgit import-dsc: $info",
6659 "results are in in git ref $dstbranch";
6662 sub pre_archive_api_query () {
6663 not_necessarily_a_tree();
6665 sub cmd_archive_api_query {
6666 badusage "need only 1 subpath argument" unless @ARGV==1;
6667 my ($subpath) = @ARGV;
6668 local $isuite = 'DGIT-API-QUERY-CMD';
6669 my @cmd = archive_api_query_cmd($subpath);
6672 exec @cmd or fail "exec curl: $!\n";
6675 sub repos_server_url () {
6676 $package = '_dgit-repos-server';
6677 local $access_forpush = 1;
6678 local $isuite = 'DGIT-REPOS-SERVER';
6679 my $url = access_giturl();
6682 sub pre_clone_dgit_repos_server () {
6683 not_necessarily_a_tree();
6685 sub cmd_clone_dgit_repos_server {
6686 badusage "need destination argument" unless @ARGV==1;
6687 my ($destdir) = @ARGV;
6688 my $url = repos_server_url();
6689 my @cmd = (@git, qw(clone), $url, $destdir);
6691 exec @cmd or fail "exec git clone: $!\n";
6694 sub pre_print_dgit_repos_server_source_url () {
6695 not_necessarily_a_tree();
6697 sub cmd_print_dgit_repos_server_source_url {
6698 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6700 my $url = repos_server_url();
6701 print $url, "\n" or die $!;
6704 sub pre_print_dpkg_source_ignores {
6705 not_necessarily_a_tree();
6707 sub cmd_print_dpkg_source_ignores {
6708 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6710 print "@dpkg_source_ignores\n" or die $!;
6713 sub cmd_setup_mergechangelogs {
6714 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6715 local $isuite = 'DGIT-SETUP-TREE';
6716 setup_mergechangelogs(1);
6719 sub cmd_setup_useremail {
6720 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6721 local $isuite = 'DGIT-SETUP-TREE';
6725 sub cmd_setup_gitattributes {
6726 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6727 local $isuite = 'DGIT-SETUP-TREE';
6731 sub cmd_setup_new_tree {
6732 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6733 local $isuite = 'DGIT-SETUP-TREE';
6737 #---------- argument parsing and main program ----------
6740 print "dgit version $our_version\n" or die $!;
6744 our (%valopts_long, %valopts_short);
6745 our (%funcopts_long);
6747 our (@modeopt_cfgs);
6749 sub defvalopt ($$$$) {
6750 my ($long,$short,$val_re,$how) = @_;
6751 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6752 $valopts_long{$long} = $oi;
6753 $valopts_short{$short} = $oi;
6754 # $how subref should:
6755 # do whatever assignemnt or thing it likes with $_[0]
6756 # if the option should not be passed on to remote, @rvalopts=()
6757 # or $how can be a scalar ref, meaning simply assign the value
6760 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6761 defvalopt '--distro', '-d', '.+', \$idistro;
6762 defvalopt '', '-k', '.+', \$keyid;
6763 defvalopt '--existing-package','', '.*', \$existing_package;
6764 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6765 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6766 defvalopt '--package', '-p', $package_re, \$package;
6767 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6769 defvalopt '', '-C', '.+', sub {
6770 ($changesfile) = (@_);
6771 if ($changesfile =~ s#^(.*)/##) {
6772 $buildproductsdir = $1;
6776 defvalopt '--initiator-tempdir','','.*', sub {
6777 ($initiator_tempdir) = (@_);
6778 $initiator_tempdir =~ m#^/# or
6779 badusage "--initiator-tempdir must be used specify an".
6780 " absolute, not relative, directory."
6783 sub defoptmodes ($@) {
6784 my ($varref, $cfgkey, $default, %optmap) = @_;
6786 while (my ($opt,$val) = each %optmap) {
6787 $funcopts_long{$opt} = sub { $$varref = $val; };
6788 $permit{$val} = $val;
6790 push @modeopt_cfgs, {
6793 Default => $default,
6798 defoptmodes \$dodep14tag, qw( dep14tag want
6801 --always-dep14tag always );
6806 if (defined $ENV{'DGIT_SSH'}) {
6807 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6808 } elsif (defined $ENV{'GIT_SSH'}) {
6809 @ssh = ($ENV{'GIT_SSH'});
6817 if (!defined $val) {
6818 badusage "$what needs a value" unless @ARGV;
6820 push @rvalopts, $val;
6822 badusage "bad value \`$val' for $what" unless
6823 $val =~ m/^$oi->{Re}$(?!\n)/s;
6824 my $how = $oi->{How};
6825 if (ref($how) eq 'SCALAR') {
6830 push @ropts, @rvalopts;
6834 last unless $ARGV[0] =~ m/^-/;
6838 if (m/^--dry-run$/) {
6841 } elsif (m/^--damp-run$/) {
6844 } elsif (m/^--no-sign$/) {
6847 } elsif (m/^--help$/) {
6849 } elsif (m/^--version$/) {
6851 } elsif (m/^--new$/) {
6854 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6855 ($om = $opts_opt_map{$1}) &&
6859 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6860 !$opts_opt_cmdonly{$1} &&
6861 ($om = $opts_opt_map{$1})) {
6864 } elsif (m/^--(gbp|dpm)$/s) {
6865 push @ropts, "--quilt=$1";
6867 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6870 } elsif (m/^--no-quilt-fixup$/s) {
6872 $quilt_mode = 'nocheck';
6873 } elsif (m/^--no-rm-on-error$/s) {
6876 } elsif (m/^--no-chase-dsc-distro$/s) {
6878 $chase_dsc_distro = 0;
6879 } elsif (m/^--overwrite$/s) {
6881 $overwrite_version = '';
6882 } elsif (m/^--overwrite=(.+)$/s) {
6884 $overwrite_version = $1;
6885 } elsif (m/^--delayed=(\d+)$/s) {
6888 } elsif (m/^--dgit-view-save=(.+)$/s) {
6890 $split_brain_save = $1;
6891 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6892 } elsif (m/^--(no-)?rm-old-changes$/s) {
6895 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6897 push @deliberatelies, $&;
6898 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6902 } elsif (m/^--force-/) {
6904 "$us: warning: ignoring unknown force option $_\n";
6906 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6907 # undocumented, for testing
6909 $tagformat_want = [ $1, 'command line', 1 ];
6910 # 1 menas overrides distro configuration
6911 } elsif (m/^--always-split-source-build$/s) {
6912 # undocumented, for testing
6914 $need_split_build_invocation = 1;
6915 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6916 # undocumented, for testing
6918 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6919 # ^ it's supposed to be an array ref
6920 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6921 $val = $2 ? $' : undef; #';
6922 $valopt->($oi->{Long});
6923 } elsif ($funcopts_long{$_}) {
6925 $funcopts_long{$_}();
6927 badusage "unknown long option \`$_'";
6934 } elsif (s/^-L/-/) {
6937 } elsif (s/^-h/-/) {
6939 } elsif (s/^-D/-/) {
6943 } elsif (s/^-N/-/) {
6948 push @changesopts, $_;
6950 } elsif (s/^-wn$//s) {
6952 $cleanmode = 'none';
6953 } elsif (s/^-wg$//s) {
6956 } elsif (s/^-wgf$//s) {
6958 $cleanmode = 'git-ff';
6959 } elsif (s/^-wd$//s) {
6961 $cleanmode = 'dpkg-source';
6962 } elsif (s/^-wdd$//s) {
6964 $cleanmode = 'dpkg-source-d';
6965 } elsif (s/^-wc$//s) {
6967 $cleanmode = 'check';
6968 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6969 push @git, '-c', $&;
6970 $gitcfgs{cmdline}{$1} = [ $2 ];
6971 } elsif (s/^-c([^=]+)$//s) {
6972 push @git, '-c', $&;
6973 $gitcfgs{cmdline}{$1} = [ 'true' ];
6974 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6976 $val = undef unless length $val;
6977 $valopt->($oi->{Short});
6980 badusage "unknown short option \`$_'";
6987 sub check_env_sanity () {
6988 my $blocked = new POSIX::SigSet;
6989 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6992 foreach my $name (qw(PIPE CHLD)) {
6993 my $signame = "SIG$name";
6994 my $signum = eval "POSIX::$signame" // die;
6995 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6996 die "$signame is set to something other than SIG_DFL\n";
6997 $blocked->ismember($signum) and
6998 die "$signame is blocked\n";
7004 On entry to dgit, $@
7005 This is a bug produced by something in in your execution environment.
7011 sub parseopts_late_defaults () {
7012 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7013 if defined $idistro;
7014 $isuite //= cfg('dgit.default.default-suite');
7016 foreach my $k (keys %opts_opt_map) {
7017 my $om = $opts_opt_map{$k};
7019 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7021 badcfg "cannot set command for $k"
7022 unless length $om->[0];
7026 foreach my $c (access_cfg_cfgs("opts-$k")) {
7028 map { $_ ? @$_ : () }
7029 map { $gitcfgs{$_}{$c} }
7030 reverse @gitcfgsources;
7031 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7032 "\n" if $debuglevel >= 4;
7034 badcfg "cannot configure options for $k"
7035 if $opts_opt_cmdonly{$k};
7036 my $insertpos = $opts_cfg_insertpos{$k};
7037 @$om = ( @$om[0..$insertpos-1],
7039 @$om[$insertpos..$#$om] );
7043 if (!defined $rmchanges) {
7044 local $access_forpush;
7045 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7048 if (!defined $quilt_mode) {
7049 local $access_forpush;
7050 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7051 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7053 $quilt_mode =~ m/^($quilt_modes_re)$/
7054 or badcfg "unknown quilt-mode \`$quilt_mode'";
7058 foreach my $moc (@modeopt_cfgs) {
7059 local $access_forpush;
7060 my $vr = $moc->{Var};
7061 next if defined $$vr;
7062 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7063 my $v = $moc->{Vals}{$$vr};
7064 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7068 $need_split_build_invocation ||= quiltmode_splitbrain();
7070 fail "dgit: --include-dirty is not supported in split view quilt mode"
7071 if $split_brain && $includedirty;
7073 if (!defined $cleanmode) {
7074 local $access_forpush;
7075 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7076 $cleanmode //= 'dpkg-source';
7078 badcfg "unknown clean-mode \`$cleanmode'" unless
7079 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7082 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7083 $buildproductsdir //= '..';
7084 $bpd_glob = $buildproductsdir;
7085 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7088 if ($ENV{$fakeeditorenv}) {
7090 quilt_fixup_editor();
7096 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7097 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7098 if $dryrun_level == 1;
7100 print STDERR $helpmsg or die $!;
7103 $cmd = $subcommand = shift @ARGV;
7106 my $pre_fn = ${*::}{"pre_$cmd"};
7107 $pre_fn->() if $pre_fn;
7109 record_maindir if $invoked_in_git_tree;
7112 my $fn = ${*::}{"cmd_$cmd"};
7113 $fn or badusage "unknown operation $cmd";