3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2017 Ian Jackson
6 # Copyright (C)2017 Sean Whitton
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
22 use Debian::Dgit::ExitStatus;
26 use Debian::Dgit qw(:DEFAULT :playground);
32 use Dpkg::Control::Hash;
34 use File::Temp qw(tempdir);
37 use Dpkg::Compression;
38 use Dpkg::Compression::Process;
43 use List::MoreUtils qw(pairwise);
44 use Text::Glob qw(match_glob);
45 use Fcntl qw(:DEFAULT :flock);
50 our $our_version = 'UNRELEASED'; ###substituted###
51 our $absurdity = undef; ###substituted###
53 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
64 our $dryrun_level = 0;
66 our $buildproductsdir = '..';
72 our $existing_package = 'dpkg';
74 our $changes_since_version;
76 our $overwrite_version; # undef: not specified; '': check changelog
78 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
80 our $split_brain_save;
81 our $we_are_responder;
82 our $we_are_initiator;
83 our $initiator_tempdir;
84 our $patches_applied_dirtily = 00;
88 our $chase_dsc_distro=1;
90 our %forceopts = map { $_=>0 }
91 qw(unrepresentable unsupported-source-format
92 dsc-changes-mismatch changes-origs-exactly
93 uploading-binaries uploading-source-only
94 import-gitapply-absurd
95 import-gitapply-no-absurd
96 import-dsc-with-dgit-field);
98 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
100 our $suite_re = '[-+.0-9a-z]+';
101 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
102 our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
103 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
104 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
106 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
107 our $splitbraincache = 'dgit-intern/quilt-cache';
108 our $rewritemap = 'dgit-rewrite/map';
110 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
112 our (@git) = qw(git);
113 our (@dget) = qw(dget);
114 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
115 our (@dput) = qw(dput);
116 our (@debsign) = qw(debsign);
117 our (@gpg) = qw(gpg);
118 our (@sbuild) = qw(sbuild);
120 our (@dgit) = qw(dgit);
121 our (@git_debrebase) = qw(git-debrebase);
122 our (@aptget) = qw(apt-get);
123 our (@aptcache) = qw(apt-cache);
124 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
125 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
126 our (@dpkggenchanges) = qw(dpkg-genchanges);
127 our (@mergechanges) = qw(mergechanges -f);
128 our (@gbp_build) = ('');
129 our (@gbp_pq) = ('gbp pq');
130 our (@changesopts) = ('');
132 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
135 'debsign' => \@debsign,
137 'sbuild' => \@sbuild,
141 'git-debrebase' => \@git_debrebase,
142 'apt-get' => \@aptget,
143 'apt-cache' => \@aptcache,
144 'dpkg-source' => \@dpkgsource,
145 'dpkg-buildpackage' => \@dpkgbuildpackage,
146 'dpkg-genchanges' => \@dpkggenchanges,
147 'gbp-build' => \@gbp_build,
148 'gbp-pq' => \@gbp_pq,
149 'ch' => \@changesopts,
150 'mergechanges' => \@mergechanges);
152 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
153 our %opts_cfg_insertpos = map {
155 scalar @{ $opts_opt_map{$_} }
156 } keys %opts_opt_map;
158 sub parseopts_late_defaults();
159 sub setup_gitattrs(;$);
160 sub check_gitattrs($$);
167 our $supplementary_message = '';
168 our $need_split_build_invocation = 0;
169 our $split_brain = 0;
173 return unless forkcheck_mainprocess();
174 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
177 our $remotename = 'dgit';
178 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
182 if (!defined $absurdity) {
184 $absurdity =~ s{/[^/]+$}{/absurd} or die;
188 my ($v,$distro) = @_;
189 return $tagformatfn->($v, $distro);
192 sub debiantag_maintview ($$) {
193 my ($v,$distro) = @_;
194 return "$distro/".dep14_version_mangle $v;
197 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
199 sub lbranch () { return "$branchprefix/$csuite"; }
200 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
201 sub lref () { return "refs/heads/".lbranch(); }
202 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
203 sub rrref () { return server_ref($csuite); }
213 return "${package}_".(stripepoch $vsn).$sfx
218 return srcfn($vsn,".dsc");
221 sub changespat ($;$) {
222 my ($vsn, $arch) = @_;
223 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
226 sub upstreamversion ($) {
238 return unless forkcheck_mainprocess();
239 foreach my $f (@end) {
241 print STDERR "$us: cleanup: $@" if length $@;
245 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
247 sub forceable_fail ($$) {
248 my ($forceoptsl, $msg) = @_;
249 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
250 print STDERR "warning: overriding problem due to --force:\n". $msg;
254 my ($forceoptsl) = @_;
255 my @got = grep { $forceopts{$_} } @$forceoptsl;
256 return 0 unless @got;
258 "warning: skipping checks or functionality due to --force-$got[0]\n";
261 sub no_such_package () {
262 print STDERR "$us: package $package does not exist in suite $isuite\n";
266 sub deliberately ($) {
268 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
271 sub deliberately_not_fast_forward () {
272 foreach (qw(not-fast-forward fresh-repo)) {
273 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
277 sub quiltmode_splitbrain () {
278 $quilt_mode =~ m/gbp|dpm|unapplied/;
281 sub opts_opt_multi_cmd {
283 push @cmd, split /\s+/, shift @_;
289 return opts_opt_multi_cmd @gbp_pq;
292 sub dgit_privdir () {
293 our $dgit_privdir_made //= ensure_a_playground 'dgit';
296 sub branch_gdr_info ($$) {
297 my ($symref, $head) = @_;
298 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
299 gdr_ffq_prev_branchinfo($symref);
300 return () unless $status eq 'branch';
301 $ffq_prev = git_get_ref $ffq_prev;
302 $gdrlast = git_get_ref $gdrlast;
303 $gdrlast &&= is_fast_fwd $gdrlast, $head;
304 return ($ffq_prev, $gdrlast);
307 sub branch_is_gdr ($$) {
308 my ($symref, $head) = @_;
309 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
310 return 0 unless $ffq_prev || $gdrlast;
314 sub branch_is_gdr_unstitched_ff ($$$) {
315 my ($symref, $head, $ancestor) = @_;
316 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
317 return 0 unless $ffq_prev;
318 return 0 unless is_fast_fwd $ancestor, $ffq_prev;
322 #---------- remote protocol support, common ----------
324 # remote push initiator/responder protocol:
325 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
326 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
327 # < dgit-remote-push-ready <actual-proto-vsn>
334 # > supplementary-message NBYTES # $protovsn >= 3
339 # > file parsed-changelog
340 # [indicates that output of dpkg-parsechangelog follows]
341 # > data-block NBYTES
342 # > [NBYTES bytes of data (no newline)]
343 # [maybe some more blocks]
352 # > param head DGIT-VIEW-HEAD
353 # > param csuite SUITE
354 # > param tagformat old|new
355 # > param maint-view MAINT-VIEW-HEAD
357 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
358 # > file buildinfo # for buildinfos to sign
360 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
361 # # goes into tag, for replay prevention
364 # [indicates that signed tag is wanted]
365 # < data-block NBYTES
366 # < [NBYTES bytes of data (no newline)]
367 # [maybe some more blocks]
371 # > want signed-dsc-changes
372 # < data-block NBYTES [transfer of signed dsc]
374 # < data-block NBYTES [transfer of signed changes]
376 # < data-block NBYTES [transfer of each signed buildinfo
377 # [etc] same number and order as "file buildinfo"]
385 sub i_child_report () {
386 # Sees if our child has died, and reap it if so. Returns a string
387 # describing how it died if it failed, or undef otherwise.
388 return undef unless $i_child_pid;
389 my $got = waitpid $i_child_pid, WNOHANG;
390 return undef if $got <= 0;
391 die unless $got == $i_child_pid;
392 $i_child_pid = undef;
393 return undef unless $?;
394 return "build host child ".waitstatusmsg();
399 fail "connection lost: $!" if $fh->error;
400 fail "protocol violation; $m not expected";
403 sub badproto_badread ($$) {
405 fail "connection lost: $!" if $!;
406 my $report = i_child_report();
407 fail $report if defined $report;
408 badproto $fh, "eof (reading $wh)";
411 sub protocol_expect (&$) {
412 my ($match, $fh) = @_;
415 defined && chomp or badproto_badread $fh, "protocol message";
423 badproto $fh, "\`$_'";
426 sub protocol_send_file ($$) {
427 my ($fh, $ourfn) = @_;
428 open PF, "<", $ourfn or die "$ourfn: $!";
431 my $got = read PF, $d, 65536;
432 die "$ourfn: $!" unless defined $got;
434 print $fh "data-block ".length($d)."\n" or die $!;
435 print $fh $d or die $!;
437 PF->error and die "$ourfn $!";
438 print $fh "data-end\n" or die $!;
442 sub protocol_read_bytes ($$) {
443 my ($fh, $nbytes) = @_;
444 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
446 my $got = read $fh, $d, $nbytes;
447 $got==$nbytes or badproto_badread $fh, "data block";
451 sub protocol_receive_file ($$) {
452 my ($fh, $ourfn) = @_;
453 printdebug "() $ourfn\n";
454 open PF, ">", $ourfn or die "$ourfn: $!";
456 my ($y,$l) = protocol_expect {
457 m/^data-block (.*)$/ ? (1,$1) :
458 m/^data-end$/ ? (0,) :
462 my $d = protocol_read_bytes $fh, $l;
463 print PF $d or die $!;
468 #---------- remote protocol support, responder ----------
470 sub responder_send_command ($) {
472 return unless $we_are_responder;
473 # called even without $we_are_responder
474 printdebug ">> $command\n";
475 print PO $command, "\n" or die $!;
478 sub responder_send_file ($$) {
479 my ($keyword, $ourfn) = @_;
480 return unless $we_are_responder;
481 printdebug "]] $keyword $ourfn\n";
482 responder_send_command "file $keyword";
483 protocol_send_file \*PO, $ourfn;
486 sub responder_receive_files ($@) {
487 my ($keyword, @ourfns) = @_;
488 die unless $we_are_responder;
489 printdebug "[[ $keyword @ourfns\n";
490 responder_send_command "want $keyword";
491 foreach my $fn (@ourfns) {
492 protocol_receive_file \*PI, $fn;
495 protocol_expect { m/^files-end$/ } \*PI;
498 #---------- remote protocol support, initiator ----------
500 sub initiator_expect (&) {
502 protocol_expect { &$match } \*RO;
505 #---------- end remote code ----------
508 if ($we_are_responder) {
510 responder_send_command "progress ".length($m) or die $!;
511 print PO $m or die $!;
521 $ua = LWP::UserAgent->new();
525 progress "downloading $what...";
526 my $r = $ua->get(@_) or die $!;
527 return undef if $r->code == 404;
528 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
529 return $r->decoded_content(charset => 'none');
532 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
534 sub act_local () { return $dryrun_level <= 1; }
535 sub act_scary () { return !$dryrun_level; }
538 if (!$dryrun_level) {
539 progress "$us ok: @_";
541 progress "would be ok: @_ (but dry run only)";
546 printcmd(\*STDERR,$debugprefix."#",@_);
549 sub runcmd_ordryrun {
557 sub runcmd_ordryrun_local {
565 our $helpmsg = <<END;
567 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
568 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
569 dgit [dgit-opts] build [dpkg-buildpackage-opts]
570 dgit [dgit-opts] sbuild [sbuild-opts]
571 dgit [dgit-opts] push [dgit-opts] [suite]
572 dgit [dgit-opts] push-source [dgit-opts] [suite]
573 dgit [dgit-opts] rpush build-host:build-dir ...
574 important dgit options:
575 -k<keyid> sign tag and package with <keyid> instead of default
576 --dry-run -n do not change anything, but go through the motions
577 --damp-run -L like --dry-run but make local changes, without signing
578 --new -N allow introducing a new package
579 --debug -D increase debug level
580 -c<name>=<value> set git config option (used directly by dgit too)
583 our $later_warning_msg = <<END;
584 Perhaps the upload is stuck in incoming. Using the version from git.
588 print STDERR "$us: @_\n", $helpmsg or die $!;
593 @ARGV or badusage "too few arguments";
594 return scalar shift @ARGV;
598 not_necessarily_a_tree();
601 print $helpmsg or die $!;
605 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
607 our %defcfg = ('dgit.default.distro' => 'debian',
608 'dgit.default.default-suite' => 'unstable',
609 'dgit.default.old-dsc-distro' => 'debian',
610 'dgit-suite.*-security.distro' => 'debian-security',
611 'dgit.default.username' => '',
612 'dgit.default.archive-query-default-component' => 'main',
613 'dgit.default.ssh' => 'ssh',
614 'dgit.default.archive-query' => 'madison:',
615 'dgit.default.sshpsql-dbname' => 'service=projectb',
616 'dgit.default.aptget-components' => 'main',
617 'dgit.default.dgit-tag-format' => 'new,old,maint',
618 'dgit.default.source-only-uploads' => 'ok',
619 'dgit.dsc-url-proto-ok.http' => 'true',
620 'dgit.dsc-url-proto-ok.https' => 'true',
621 'dgit.dsc-url-proto-ok.git' => 'true',
622 'dgit.vcs-git.suites', => 'sid', # ;-separated
623 'dgit.default.dsc-url-proto-ok' => 'false',
624 # old means "repo server accepts pushes with old dgit tags"
625 # new means "repo server accepts pushes with new dgit tags"
626 # maint means "repo server accepts split brain pushes"
627 # hist means "repo server may have old pushes without new tag"
628 # ("hist" is implied by "old")
629 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
630 'dgit-distro.debian.git-check' => 'url',
631 'dgit-distro.debian.git-check-suffix' => '/info/refs',
632 'dgit-distro.debian.new-private-pushers' => 't',
633 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
634 'dgit-distro.debian/push.git-url' => '',
635 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
636 'dgit-distro.debian/push.git-user-force' => 'dgit',
637 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
638 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
639 'dgit-distro.debian/push.git-create' => 'true',
640 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
641 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
642 # 'dgit-distro.debian.archive-query-tls-key',
643 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
644 # ^ this does not work because curl is broken nowadays
645 # Fixing #790093 properly will involve providing providing the key
646 # in some pacagke and maybe updating these paths.
648 # 'dgit-distro.debian.archive-query-tls-curl-args',
649 # '--ca-path=/etc/ssl/ca-debian',
650 # ^ this is a workaround but works (only) on DSA-administered machines
651 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
652 'dgit-distro.debian.git-url-suffix' => '',
653 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
654 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
655 'dgit-distro.debian-security.archive-query' => 'aptget:',
656 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
657 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
658 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
659 'dgit-distro.debian-security.nominal-distro' => 'debian',
660 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
661 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
662 'dgit-distro.ubuntu.git-check' => 'false',
663 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
664 'dgit-distro.test-dummy.ssh' => "$td/ssh",
665 'dgit-distro.test-dummy.username' => "alice",
666 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
667 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
668 'dgit-distro.test-dummy.git-url' => "$td/git",
669 'dgit-distro.test-dummy.git-host' => "git",
670 'dgit-distro.test-dummy.git-path' => "$td/git",
671 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
672 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
673 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
674 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
678 our @gitcfgsources = qw(cmdline local global system);
679 our $invoked_in_git_tree = 1;
681 sub git_slurp_config () {
682 # This algoritm is a bit subtle, but this is needed so that for
683 # options which we want to be single-valued, we allow the
684 # different config sources to override properly. See #835858.
685 foreach my $src (@gitcfgsources) {
686 next if $src eq 'cmdline';
687 # we do this ourselves since git doesn't handle it
689 $gitcfgs{$src} = git_slurp_config_src $src;
693 sub git_get_config ($) {
695 foreach my $src (@gitcfgsources) {
696 my $l = $gitcfgs{$src}{$c};
697 confess "internal error ($l $c)" if $l && !ref $l;
698 printdebug"C $c ".(defined $l ?
699 join " ", map { messagequote "'$_'" } @$l :
703 @$l==1 or badcfg "multiple values for $c".
704 " (in $src git config)" if @$l > 1;
712 return undef if $c =~ /RETURN-UNDEF/;
713 printdebug "C? $c\n" if $debuglevel >= 5;
714 my $v = git_get_config($c);
715 return $v if defined $v;
716 my $dv = $defcfg{$c};
718 printdebug "CD $c $dv\n" if $debuglevel >= 4;
722 badcfg "need value for one of: @_\n".
723 "$us: distro or suite appears not to be (properly) supported";
726 sub not_necessarily_a_tree () {
727 # needs to be called from pre_*
728 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
729 $invoked_in_git_tree = 0;
732 sub access_basedistro__noalias () {
733 if (defined $idistro) {
736 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
737 return $def if defined $def;
738 foreach my $src (@gitcfgsources, 'internal') {
739 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
741 foreach my $k (keys %$kl) {
742 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
744 next unless match_glob $dpat, $isuite;
748 return cfg("dgit.default.distro");
752 sub access_basedistro () {
753 my $noalias = access_basedistro__noalias();
754 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
755 return $canon // $noalias;
758 sub access_nomdistro () {
759 my $base = access_basedistro();
760 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
761 $r =~ m/^$distro_re$/ or badcfg
762 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
766 sub access_quirk () {
767 # returns (quirk name, distro to use instead or undef, quirk-specific info)
768 my $basedistro = access_basedistro();
769 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
771 if (defined $backports_quirk) {
772 my $re = $backports_quirk;
773 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
775 $re =~ s/\%/([-0-9a-z_]+)/
776 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
777 if ($isuite =~ m/^$re$/) {
778 return ('backports',"$basedistro-backports",$1);
781 return ('none',undef);
786 sub parse_cfg_bool ($$$) {
787 my ($what,$def,$v) = @_;
790 $v =~ m/^[ty1]/ ? 1 :
791 $v =~ m/^[fn0]/ ? 0 :
792 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
795 sub access_forpush_config () {
796 my $d = access_basedistro();
800 parse_cfg_bool('new-private-pushers', 0,
801 cfg("dgit-distro.$d.new-private-pushers",
804 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
807 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
808 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
809 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
810 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
813 sub access_forpush () {
814 $access_forpush //= access_forpush_config();
815 return $access_forpush;
819 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
820 badcfg "pushing but distro is configured readonly"
821 if access_forpush_config() eq '0';
823 $supplementary_message = <<'END' unless $we_are_responder;
824 Push failed, before we got started.
825 You can retry the push, after fixing the problem, if you like.
827 parseopts_late_defaults();
831 parseopts_late_defaults();
834 sub supplementary_message ($) {
836 if (!$we_are_responder) {
837 $supplementary_message = $msg;
839 } elsif ($protovsn >= 3) {
840 responder_send_command "supplementary-message ".length($msg)
842 print PO $msg or die $!;
846 sub access_distros () {
847 # Returns list of distros to try, in order
850 # 0. `instead of' distro name(s) we have been pointed to
851 # 1. the access_quirk distro, if any
852 # 2a. the user's specified distro, or failing that } basedistro
853 # 2b. the distro calculated from the suite }
854 my @l = access_basedistro();
856 my (undef,$quirkdistro) = access_quirk();
857 unshift @l, $quirkdistro;
858 unshift @l, $instead_distro;
859 @l = grep { defined } @l;
861 push @l, access_nomdistro();
863 if (access_forpush()) {
864 @l = map { ("$_/push", $_) } @l;
869 sub access_cfg_cfgs (@) {
872 # The nesting of these loops determines the search order. We put
873 # the key loop on the outside so that we search all the distros
874 # for each key, before going on to the next key. That means that
875 # if access_cfg is called with a more specific, and then a less
876 # specific, key, an earlier distro can override the less specific
877 # without necessarily overriding any more specific keys. (If the
878 # distro wants to override the more specific keys it can simply do
879 # so; whereas if we did the loop the other way around, it would be
880 # impossible to for an earlier distro to override a less specific
881 # key but not the more specific ones without restating the unknown
882 # values of the more specific keys.
885 # We have to deal with RETURN-UNDEF specially, so that we don't
886 # terminate the search prematurely.
888 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
891 foreach my $d (access_distros()) {
892 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
894 push @cfgs, map { "dgit.default.$_" } @realkeys;
901 my (@cfgs) = access_cfg_cfgs(@keys);
902 my $value = cfg(@cfgs);
906 sub access_cfg_bool ($$) {
907 my ($def, @keys) = @_;
908 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
911 sub string_to_ssh ($) {
913 if ($spec =~ m/\s/) {
914 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
920 sub access_cfg_ssh () {
921 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
922 if (!defined $gitssh) {
925 return string_to_ssh $gitssh;
929 sub access_runeinfo ($) {
931 return ": dgit ".access_basedistro()." $info ;";
934 sub access_someuserhost ($) {
936 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
937 defined($user) && length($user) or
938 $user = access_cfg("$some-user",'username');
939 my $host = access_cfg("$some-host");
940 return length($user) ? "$user\@$host" : $host;
943 sub access_gituserhost () {
944 return access_someuserhost('git');
947 sub access_giturl (;$) {
949 my $url = access_cfg('git-url','RETURN-UNDEF');
952 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
953 return undef unless defined $proto;
956 access_gituserhost().
957 access_cfg('git-path');
959 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
962 return "$url/$package$suffix";
965 sub parsecontrolfh ($$;$) {
966 my ($fh, $desc, $allowsigned) = @_;
967 our $dpkgcontrolhash_noissigned;
970 my %opts = ('name' => $desc);
971 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
972 $c = Dpkg::Control::Hash->new(%opts);
973 print STDERR "DCHn\n";
974 $c->parse($fh,$desc) or die "parsing of $desc failed";
975 print STDERR "parse\n";
976 last if $allowsigned;
977 last if $dpkgcontrolhash_noissigned;
978 my $issigned= $c->get_option('is_pgp_signed');
979 if (!defined $issigned) {
980 $dpkgcontrolhash_noissigned= 1;
981 seek $fh, 0,0 or die "seek $desc: $!";
982 } elsif ($issigned) {
983 fail "control file $desc is (already) PGP-signed. ".
984 " Note that dgit push needs to modify the .dsc and then".
985 " do the signature itself";
994 my ($file, $desc, $allowsigned) = @_;
995 my $fh = new IO::Handle;
996 open $fh, '<', $file or die "$file: $!";
997 my $c = parsecontrolfh($fh,$desc,$allowsigned);
998 $fh->error and die $!;
1004 my ($dctrl,$field) = @_;
1005 my $v = $dctrl->{$field};
1006 return $v if defined $v;
1007 fail "missing field $field in ".$dctrl->get_option('name');
1010 sub parsechangelog {
1011 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
1012 my $p = new IO::Handle;
1013 my @cmd = (qw(dpkg-parsechangelog), @_);
1014 open $p, '-|', @cmd or die $!;
1016 $?=0; $!=0; close $p or failedcmd @cmd;
1020 sub commit_getclogp ($) {
1021 # Returns the parsed changelog hashref for a particular commit
1023 our %commit_getclogp_memo;
1024 my $memo = $commit_getclogp_memo{$objid};
1025 return $memo if $memo;
1027 my $mclog = dgit_privdir()."clog";
1028 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1029 "$objid:debian/changelog";
1030 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1033 sub parse_dscdata () {
1034 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1035 printdebug Dumper($dscdata) if $debuglevel>1;
1036 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1037 printdebug Dumper($dsc) if $debuglevel>1;
1042 sub archive_query ($;@) {
1043 my ($method) = shift @_;
1044 fail "this operation does not support multiple comma-separated suites"
1046 my $query = access_cfg('archive-query','RETURN-UNDEF');
1047 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1050 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1053 sub archive_query_prepend_mirror {
1054 my $m = access_cfg('mirror');
1055 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1058 sub pool_dsc_subpath ($$) {
1059 my ($vsn,$component) = @_; # $package is implict arg
1060 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1061 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1064 sub cfg_apply_map ($$$) {
1065 my ($varref, $what, $mapspec) = @_;
1066 return unless $mapspec;
1068 printdebug "config $what EVAL{ $mapspec; }\n";
1070 eval "package Dgit::Config; $mapspec;";
1075 #---------- `ftpmasterapi' archive query method (nascent) ----------
1077 sub archive_api_query_cmd ($) {
1079 my @cmd = (@curl, qw(-sS));
1080 my $url = access_cfg('archive-query-url');
1081 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1083 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1084 foreach my $key (split /\:/, $keys) {
1085 $key =~ s/\%HOST\%/$host/g;
1087 fail "for $url: stat $key: $!" unless $!==ENOENT;
1090 fail "config requested specific TLS key but do not know".
1091 " how to get curl to use exactly that EE key ($key)";
1092 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1093 # # Sadly the above line does not work because of changes
1094 # # to gnutls. The real fix for #790093 may involve
1095 # # new curl options.
1098 # Fixing #790093 properly will involve providing a value
1099 # for this on clients.
1100 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1101 push @cmd, split / /, $kargs if defined $kargs;
1103 push @cmd, $url.$subpath;
1107 sub api_query ($$;$) {
1109 my ($data, $subpath, $ok404) = @_;
1110 badcfg "ftpmasterapi archive query method takes no data part"
1112 my @cmd = archive_api_query_cmd($subpath);
1113 my $url = $cmd[$#cmd];
1114 push @cmd, qw(-w %{http_code});
1115 my $json = cmdoutput @cmd;
1116 unless ($json =~ s/\d+\d+\d$//) {
1117 failedcmd_report_cmd undef, @cmd;
1118 fail "curl failed to print 3-digit HTTP code";
1121 return undef if $code eq '404' && $ok404;
1122 fail "fetch of $url gave HTTP code $code"
1123 unless $url =~ m#^file://# or $code =~ m/^2/;
1124 return decode_json($json);
1127 sub canonicalise_suite_ftpmasterapi {
1128 my ($proto,$data) = @_;
1129 my $suites = api_query($data, 'suites');
1131 foreach my $entry (@$suites) {
1133 my $v = $entry->{$_};
1134 defined $v && $v eq $isuite;
1135 } qw(codename name);
1136 push @matched, $entry;
1138 fail "unknown suite $isuite" unless @matched;
1141 @matched==1 or die "multiple matches for suite $isuite\n";
1142 $cn = "$matched[0]{codename}";
1143 defined $cn or die "suite $isuite info has no codename\n";
1144 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1146 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1151 sub archive_query_ftpmasterapi {
1152 my ($proto,$data) = @_;
1153 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1155 my $digester = Digest::SHA->new(256);
1156 foreach my $entry (@$info) {
1158 my $vsn = "$entry->{version}";
1159 my ($ok,$msg) = version_check $vsn;
1160 die "bad version: $msg\n" unless $ok;
1161 my $component = "$entry->{component}";
1162 $component =~ m/^$component_re$/ or die "bad component";
1163 my $filename = "$entry->{filename}";
1164 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1165 or die "bad filename";
1166 my $sha256sum = "$entry->{sha256sum}";
1167 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1168 push @rows, [ $vsn, "/pool/$component/$filename",
1169 $digester, $sha256sum ];
1171 die "bad ftpmaster api response: $@\n".Dumper($entry)
1174 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1175 return archive_query_prepend_mirror @rows;
1178 sub file_in_archive_ftpmasterapi {
1179 my ($proto,$data,$filename) = @_;
1180 my $pat = $filename;
1183 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1184 my $info = api_query($data, "file_in_archive/$pat", 1);
1187 sub package_not_wholly_new_ftpmasterapi {
1188 my ($proto,$data,$pkg) = @_;
1189 my $info = api_query($data,"madison?package=${pkg}&f=json");
1193 #---------- `aptget' archive query method ----------
1196 our $aptget_releasefile;
1197 our $aptget_configpath;
1199 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1200 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1202 sub aptget_cache_clean {
1203 runcmd_ordryrun_local qw(sh -ec),
1204 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1208 sub aptget_lock_acquire () {
1209 my $lockfile = "$aptget_base/lock";
1210 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1211 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1214 sub aptget_prep ($) {
1216 return if defined $aptget_base;
1218 badcfg "aptget archive query method takes no data part"
1221 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1224 ensuredir "$cache/dgit";
1226 access_cfg('aptget-cachekey','RETURN-UNDEF')
1227 // access_nomdistro();
1229 $aptget_base = "$cache/dgit/aptget";
1230 ensuredir $aptget_base;
1232 my $quoted_base = $aptget_base;
1233 die "$quoted_base contains bad chars, cannot continue"
1234 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1236 ensuredir $aptget_base;
1238 aptget_lock_acquire();
1240 aptget_cache_clean();
1242 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1243 my $sourceslist = "source.list#$cachekey";
1245 my $aptsuites = $isuite;
1246 cfg_apply_map(\$aptsuites, 'suite map',
1247 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1249 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1250 printf SRCS "deb-src %s %s %s\n",
1251 access_cfg('mirror'),
1253 access_cfg('aptget-components')
1256 ensuredir "$aptget_base/cache";
1257 ensuredir "$aptget_base/lists";
1259 open CONF, ">", $aptget_configpath or die $!;
1261 Debug::NoLocking "true";
1262 APT::Get::List-Cleanup "false";
1263 #clear APT::Update::Post-Invoke-Success;
1264 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1265 Dir::State::Lists "$quoted_base/lists";
1266 Dir::Etc::preferences "$quoted_base/preferences";
1267 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1268 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1271 foreach my $key (qw(
1274 Dir::Cache::Archives
1275 Dir::Etc::SourceParts
1276 Dir::Etc::preferencesparts
1278 ensuredir "$aptget_base/$key";
1279 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1282 my $oldatime = (time // die $!) - 1;
1283 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1284 next unless stat_exists $oldlist;
1285 my ($mtime) = (stat _)[9];
1286 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1289 runcmd_ordryrun_local aptget_aptget(), qw(update);
1292 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1293 next unless stat_exists $oldlist;
1294 my ($atime) = (stat _)[8];
1295 next if $atime == $oldatime;
1296 push @releasefiles, $oldlist;
1298 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1299 @releasefiles = @inreleasefiles if @inreleasefiles;
1300 die "apt updated wrong number of Release files (@releasefiles), erk"
1301 unless @releasefiles == 1;
1303 ($aptget_releasefile) = @releasefiles;
1306 sub canonicalise_suite_aptget {
1307 my ($proto,$data) = @_;
1310 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1312 foreach my $name (qw(Codename Suite)) {
1313 my $val = $release->{$name};
1315 printdebug "release file $name: $val\n";
1316 $val =~ m/^$suite_re$/o or fail
1317 "Release file ($aptget_releasefile) specifies intolerable $name";
1318 cfg_apply_map(\$val, 'suite rmap',
1319 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1326 sub archive_query_aptget {
1327 my ($proto,$data) = @_;
1330 ensuredir "$aptget_base/source";
1331 foreach my $old (<$aptget_base/source/*.dsc>) {
1332 unlink $old or die "$old: $!";
1335 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1336 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1337 # avoids apt-get source failing with ambiguous error code
1339 runcmd_ordryrun_local
1340 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1341 aptget_aptget(), qw(--download-only --only-source source), $package;
1343 my @dscs = <$aptget_base/source/*.dsc>;
1344 fail "apt-get source did not produce a .dsc" unless @dscs;
1345 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1347 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1350 my $uri = "file://". uri_escape $dscs[0];
1351 $uri =~ s{\%2f}{/}gi;
1352 return [ (getfield $pre_dsc, 'Version'), $uri ];
1355 sub file_in_archive_aptget () { return undef; }
1356 sub package_not_wholly_new_aptget () { return undef; }
1358 #---------- `dummyapicat' archive query method ----------
1360 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1361 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1363 sub dummycatapi_run_in_mirror ($@) {
1364 # runs $fn with FIA open onto rune
1365 my ($rune, $argl, $fn) = @_;
1367 my $mirror = access_cfg('mirror');
1368 $mirror =~ s#^file://#/# or die "$mirror ?";
1369 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1370 qw(x), $mirror, @$argl);
1371 debugcmd "-|", @cmd;
1372 open FIA, "-|", @cmd or die $!;
1374 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1378 sub file_in_archive_dummycatapi ($$$) {
1379 my ($proto,$data,$filename) = @_;
1381 dummycatapi_run_in_mirror '
1382 find -name "$1" -print0 |
1384 ', [$filename], sub {
1387 printdebug "| $_\n";
1388 m/^(\w+) (\S+)$/ or die "$_ ?";
1389 push @out, { sha256sum => $1, filename => $2 };
1395 sub package_not_wholly_new_dummycatapi {
1396 my ($proto,$data,$pkg) = @_;
1397 dummycatapi_run_in_mirror "
1398 find -name ${pkg}_*.dsc
1405 #---------- `madison' archive query method ----------
1407 sub archive_query_madison {
1408 return archive_query_prepend_mirror
1409 map { [ @$_[0..1] ] } madison_get_parse(@_);
1412 sub madison_get_parse {
1413 my ($proto,$data) = @_;
1414 die unless $proto eq 'madison';
1415 if (!length $data) {
1416 $data= access_cfg('madison-distro','RETURN-UNDEF');
1417 $data //= access_basedistro();
1419 $rmad{$proto,$data,$package} ||= cmdoutput
1420 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1421 my $rmad = $rmad{$proto,$data,$package};
1424 foreach my $l (split /\n/, $rmad) {
1425 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1426 \s*( [^ \t|]+ )\s* \|
1427 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1428 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1429 $1 eq $package or die "$rmad $package ?";
1436 $component = access_cfg('archive-query-default-component');
1438 $5 eq 'source' or die "$rmad ?";
1439 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1441 return sort { -version_compare($a->[0],$b->[0]); } @out;
1444 sub canonicalise_suite_madison {
1445 # madison canonicalises for us
1446 my @r = madison_get_parse(@_);
1448 "unable to canonicalise suite using package $package".
1449 " which does not appear to exist in suite $isuite;".
1450 " --existing-package may help";
1454 sub file_in_archive_madison { return undef; }
1455 sub package_not_wholly_new_madison { return undef; }
1457 #---------- `sshpsql' archive query method ----------
1460 my ($data,$runeinfo,$sql) = @_;
1461 if (!length $data) {
1462 $data= access_someuserhost('sshpsql').':'.
1463 access_cfg('sshpsql-dbname');
1465 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1466 my ($userhost,$dbname) = ($`,$'); #';
1468 my @cmd = (access_cfg_ssh, $userhost,
1469 access_runeinfo("ssh-psql $runeinfo").
1470 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1471 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1473 open P, "-|", @cmd or die $!;
1476 printdebug(">|$_|\n");
1479 $!=0; $?=0; close P or failedcmd @cmd;
1481 my $nrows = pop @rows;
1482 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1483 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1484 @rows = map { [ split /\|/, $_ ] } @rows;
1485 my $ncols = scalar @{ shift @rows };
1486 die if grep { scalar @$_ != $ncols } @rows;
1490 sub sql_injection_check {
1491 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1494 sub archive_query_sshpsql ($$) {
1495 my ($proto,$data) = @_;
1496 sql_injection_check $isuite, $package;
1497 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1498 SELECT source.version, component.name, files.filename, files.sha256sum
1500 JOIN src_associations ON source.id = src_associations.source
1501 JOIN suite ON suite.id = src_associations.suite
1502 JOIN dsc_files ON dsc_files.source = source.id
1503 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1504 JOIN component ON component.id = files_archive_map.component_id
1505 JOIN files ON files.id = dsc_files.file
1506 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1507 AND source.source='$package'
1508 AND files.filename LIKE '%.dsc';
1510 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1511 my $digester = Digest::SHA->new(256);
1513 my ($vsn,$component,$filename,$sha256sum) = @$_;
1514 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1516 return archive_query_prepend_mirror @rows;
1519 sub canonicalise_suite_sshpsql ($$) {
1520 my ($proto,$data) = @_;
1521 sql_injection_check $isuite;
1522 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1523 SELECT suite.codename
1524 FROM suite where suite_name='$isuite' or codename='$isuite';
1526 @rows = map { $_->[0] } @rows;
1527 fail "unknown suite $isuite" unless @rows;
1528 die "ambiguous $isuite: @rows ?" if @rows>1;
1532 sub file_in_archive_sshpsql ($$$) { return undef; }
1533 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1535 #---------- `dummycat' archive query method ----------
1537 sub canonicalise_suite_dummycat ($$) {
1538 my ($proto,$data) = @_;
1539 my $dpath = "$data/suite.$isuite";
1540 if (!open C, "<", $dpath) {
1541 $!==ENOENT or die "$dpath: $!";
1542 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1546 chomp or die "$dpath: $!";
1548 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1552 sub archive_query_dummycat ($$) {
1553 my ($proto,$data) = @_;
1554 canonicalise_suite();
1555 my $dpath = "$data/package.$csuite.$package";
1556 if (!open C, "<", $dpath) {
1557 $!==ENOENT or die "$dpath: $!";
1558 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1566 printdebug "dummycat query $csuite $package $dpath | $_\n";
1567 my @row = split /\s+/, $_;
1568 @row==2 or die "$dpath: $_ ?";
1571 C->error and die "$dpath: $!";
1573 return archive_query_prepend_mirror
1574 sort { -version_compare($a->[0],$b->[0]); } @rows;
1577 sub file_in_archive_dummycat () { return undef; }
1578 sub package_not_wholly_new_dummycat () { return undef; }
1580 #---------- tag format handling ----------
1582 sub access_cfg_tagformats () {
1583 split /\,/, access_cfg('dgit-tag-format');
1586 sub access_cfg_tagformats_can_splitbrain () {
1587 my %y = map { $_ => 1 } access_cfg_tagformats;
1588 foreach my $needtf (qw(new maint)) {
1589 next if $y{$needtf};
1595 sub need_tagformat ($$) {
1596 my ($fmt, $why) = @_;
1597 fail "need to use tag format $fmt ($why) but also need".
1598 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1599 " - no way to proceed"
1600 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1601 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1604 sub select_tagformat () {
1606 return if $tagformatfn && !$tagformat_want;
1607 die 'bug' if $tagformatfn && $tagformat_want;
1608 # ... $tagformat_want assigned after previous select_tagformat
1610 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1611 printdebug "select_tagformat supported @supported\n";
1613 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1614 printdebug "select_tagformat specified @$tagformat_want\n";
1616 my ($fmt,$why,$override) = @$tagformat_want;
1618 fail "target distro supports tag formats @supported".
1619 " but have to use $fmt ($why)"
1621 or grep { $_ eq $fmt } @supported;
1623 $tagformat_want = undef;
1625 $tagformatfn = ${*::}{"debiantag_$fmt"};
1627 fail "trying to use unknown tag format \`$fmt' ($why) !"
1628 unless $tagformatfn;
1631 #---------- archive query entrypoints and rest of program ----------
1633 sub canonicalise_suite () {
1634 return if defined $csuite;
1635 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1636 $csuite = archive_query('canonicalise_suite');
1637 if ($isuite ne $csuite) {
1638 progress "canonical suite name for $isuite is $csuite";
1640 progress "canonical suite name is $csuite";
1644 sub get_archive_dsc () {
1645 canonicalise_suite();
1646 my @vsns = archive_query('archive_query');
1647 foreach my $vinfo (@vsns) {
1648 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1649 $dscurl = $vsn_dscurl;
1650 $dscdata = url_get($dscurl);
1652 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1657 $digester->add($dscdata);
1658 my $got = $digester->hexdigest();
1660 fail "$dscurl has hash $got but".
1661 " archive told us to expect $digest";
1664 my $fmt = getfield $dsc, 'Format';
1665 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1666 "unsupported source format $fmt, sorry";
1668 $dsc_checked = !!$digester;
1669 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1673 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1676 sub check_for_git ();
1677 sub check_for_git () {
1679 my $how = access_cfg('git-check');
1680 if ($how eq 'ssh-cmd') {
1682 (access_cfg_ssh, access_gituserhost(),
1683 access_runeinfo("git-check $package").
1684 " set -e; cd ".access_cfg('git-path').";".
1685 " if test -d $package.git; then echo 1; else echo 0; fi");
1686 my $r= cmdoutput @cmd;
1687 if (defined $r and $r =~ m/^divert (\w+)$/) {
1689 my ($usedistro,) = access_distros();
1690 # NB that if we are pushing, $usedistro will be $distro/push
1691 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1692 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1693 progress "diverting to $divert (using config for $instead_distro)";
1694 return check_for_git();
1696 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1698 } elsif ($how eq 'url') {
1699 my $prefix = access_cfg('git-check-url','git-url');
1700 my $suffix = access_cfg('git-check-suffix','git-suffix',
1701 'RETURN-UNDEF') // '.git';
1702 my $url = "$prefix/$package$suffix";
1703 my @cmd = (@curl, qw(-sS -I), $url);
1704 my $result = cmdoutput @cmd;
1705 $result =~ s/^\S+ 200 .*\n\r?\n//;
1706 # curl -sS -I with https_proxy prints
1707 # HTTP/1.0 200 Connection established
1708 $result =~ m/^\S+ (404|200) /s or
1709 fail "unexpected results from git check query - ".
1710 Dumper($prefix, $result);
1712 if ($code eq '404') {
1714 } elsif ($code eq '200') {
1719 } elsif ($how eq 'true') {
1721 } elsif ($how eq 'false') {
1724 badcfg "unknown git-check \`$how'";
1728 sub create_remote_git_repo () {
1729 my $how = access_cfg('git-create');
1730 if ($how eq 'ssh-cmd') {
1732 (access_cfg_ssh, access_gituserhost(),
1733 access_runeinfo("git-create $package").
1734 "set -e; cd ".access_cfg('git-path').";".
1735 " cp -a _template $package.git");
1736 } elsif ($how eq 'true') {
1739 badcfg "unknown git-create \`$how'";
1743 our ($dsc_hash,$lastpush_mergeinput);
1744 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1748 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1749 $playground = fresh_playground 'dgit/unpack';
1752 sub mktree_in_ud_here () {
1753 playtree_setup $gitcfgs{local};
1756 sub git_write_tree () {
1757 my $tree = cmdoutput @git, qw(write-tree);
1758 $tree =~ m/^\w+$/ or die "$tree ?";
1762 sub git_add_write_tree () {
1763 runcmd @git, qw(add -Af .);
1764 return git_write_tree();
1767 sub remove_stray_gits ($) {
1769 my @gitscmd = qw(find -name .git -prune -print0);
1770 debugcmd "|",@gitscmd;
1771 open GITS, "-|", @gitscmd or die $!;
1776 print STDERR "$us: warning: removing from $what: ",
1777 (messagequote $_), "\n";
1781 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1784 sub mktree_in_ud_from_only_subdir ($;$) {
1785 my ($what,$raw) = @_;
1786 # changes into the subdir
1789 die "expected one subdir but found @dirs ?" unless @dirs==1;
1790 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1794 remove_stray_gits($what);
1795 mktree_in_ud_here();
1797 my ($format, $fopts) = get_source_format();
1798 if (madformat($format)) {
1803 my $tree=git_add_write_tree();
1804 return ($tree,$dir);
1807 our @files_csum_info_fields =
1808 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1809 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1810 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1812 sub dsc_files_info () {
1813 foreach my $csumi (@files_csum_info_fields) {
1814 my ($fname, $module, $method) = @$csumi;
1815 my $field = $dsc->{$fname};
1816 next unless defined $field;
1817 eval "use $module; 1;" or die $@;
1819 foreach (split /\n/, $field) {
1821 m/^(\w+) (\d+) (\S+)$/ or
1822 fail "could not parse .dsc $fname line \`$_'";
1823 my $digester = eval "$module"."->$method;" or die $@;
1828 Digester => $digester,
1833 fail "missing any supported Checksums-* or Files field in ".
1834 $dsc->get_option('name');
1838 map { $_->{Filename} } dsc_files_info();
1841 sub files_compare_inputs (@) {
1846 my $showinputs = sub {
1847 return join "; ", map { $_->get_option('name') } @$inputs;
1850 foreach my $in (@$inputs) {
1852 my $in_name = $in->get_option('name');
1854 printdebug "files_compare_inputs $in_name\n";
1856 foreach my $csumi (@files_csum_info_fields) {
1857 my ($fname) = @$csumi;
1858 printdebug "files_compare_inputs $in_name $fname\n";
1860 my $field = $in->{$fname};
1861 next unless defined $field;
1864 foreach (split /\n/, $field) {
1867 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1868 fail "could not parse $in_name $fname line \`$_'";
1870 printdebug "files_compare_inputs $in_name $fname $f\n";
1874 my $re = \ $record{$f}{$fname};
1876 $fchecked{$f}{$in_name} = 1;
1878 fail "hash or size of $f varies in $fname fields".
1879 " (between: ".$showinputs->().")";
1884 @files = sort @files;
1885 $expected_files //= \@files;
1886 "@$expected_files" eq "@files" or
1887 fail "file list in $in_name varies between hash fields!";
1890 fail "$in_name has no files list field(s)";
1892 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1895 grep { keys %$_ == @$inputs-1 } values %fchecked
1896 or fail "no file appears in all file lists".
1897 " (looked in: ".$showinputs->().")";
1900 sub is_orig_file_in_dsc ($$) {
1901 my ($f, $dsc_files_info) = @_;
1902 return 0 if @$dsc_files_info <= 1;
1903 # One file means no origs, and the filename doesn't have a "what
1904 # part of dsc" component. (Consider versions ending `.orig'.)
1905 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1909 sub is_orig_file_of_vsn ($$) {
1910 my ($f, $upstreamvsn) = @_;
1911 my $base = srcfn $upstreamvsn, '';
1912 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1916 # This function determines whether a .changes file is source-only from
1917 # the point of view of dak. Thus, it permits *_source.buildinfo
1920 # It does not, however, permit any other buildinfo files. After a
1921 # source-only upload, the buildds will try to upload files like
1922 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1923 # named like this in their (otherwise) source-only upload, the uploads
1924 # of the buildd can be rejected by dak. Fixing the resultant
1925 # situation can require manual intervention. So we block such
1926 # .buildinfo files when the user tells us to perform a source-only
1927 # upload (such as when using the push-source subcommand with the -C
1928 # option, which calls this function).
1930 # Note, though, that when dgit is told to prepare a source-only
1931 # upload, such as when subcommands like build-source and push-source
1932 # without -C are used, dgit has a more restrictive notion of
1933 # source-only .changes than dak: such uploads will never include
1934 # *_source.buildinfo files. This is because there is no use for such
1935 # files when using a tool like dgit to produce the source package, as
1936 # dgit ensures the source is identical to git HEAD.
1937 sub test_source_only_changes ($) {
1939 foreach my $l (split /\n/, getfield $changes, 'Files') {
1940 $l =~ m/\S+$/ or next;
1941 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1942 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1943 print "purportedly source-only changes polluted by $&\n";
1950 sub changes_update_origs_from_dsc ($$$$) {
1951 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1953 printdebug "checking origs needed ($upstreamvsn)...\n";
1954 $_ = getfield $changes, 'Files';
1955 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1956 fail "cannot find section/priority from .changes Files field";
1957 my $placementinfo = $1;
1959 printdebug "checking origs needed placement '$placementinfo'...\n";
1960 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1961 $l =~ m/\S+$/ or next;
1963 printdebug "origs $file | $l\n";
1964 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1965 printdebug "origs $file is_orig\n";
1966 my $have = archive_query('file_in_archive', $file);
1967 if (!defined $have) {
1969 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1975 printdebug "origs $file \$#\$have=$#$have\n";
1976 foreach my $h (@$have) {
1979 foreach my $csumi (@files_csum_info_fields) {
1980 my ($fname, $module, $method, $archivefield) = @$csumi;
1981 next unless defined $h->{$archivefield};
1982 $_ = $dsc->{$fname};
1983 next unless defined;
1984 m/^(\w+) .* \Q$file\E$/m or
1985 fail ".dsc $fname missing entry for $file";
1986 if ($h->{$archivefield} eq $1) {
1990 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1993 die "$file ".Dumper($h)." ?!" if $same && @differ;
1996 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1999 printdebug "origs $file f.same=$found_same".
2000 " #f._differ=$#found_differ\n";
2001 if (@found_differ && !$found_same) {
2003 "archive contains $file with different checksum",
2006 # Now we edit the changes file to add or remove it
2007 foreach my $csumi (@files_csum_info_fields) {
2008 my ($fname, $module, $method, $archivefield) = @$csumi;
2009 next unless defined $changes->{$fname};
2011 # in archive, delete from .changes if it's there
2012 $changed{$file} = "removed" if
2013 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2014 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2015 # not in archive, but it's here in the .changes
2017 my $dsc_data = getfield $dsc, $fname;
2018 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2020 $extra =~ s/ \d+ /$&$placementinfo /
2021 or die "$fname $extra >$dsc_data< ?"
2022 if $fname eq 'Files';
2023 $changes->{$fname} .= "\n". $extra;
2024 $changed{$file} = "added";
2029 foreach my $file (keys %changed) {
2031 "edited .changes for archive .orig contents: %s %s",
2032 $changed{$file}, $file;
2034 my $chtmp = "$changesfile.tmp";
2035 $changes->save($chtmp);
2037 rename $chtmp,$changesfile or die "$changesfile $!";
2039 progress "[new .changes left in $changesfile]";
2042 progress "$changesfile already has appropriate .orig(s) (if any)";
2046 sub make_commit ($) {
2048 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2051 sub make_commit_text ($) {
2054 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
2056 print Dumper($text) if $debuglevel > 1;
2057 my $child = open2($out, $in, @cmd) or die $!;
2060 print $in $text or die $!;
2061 close $in or die $!;
2063 $h =~ m/^\w+$/ or die;
2065 printdebug "=> $h\n";
2068 waitpid $child, 0 == $child or die "$child $!";
2069 $? and failedcmd @cmd;
2073 sub clogp_authline ($) {
2075 my $author = getfield $clogp, 'Maintainer';
2076 if ($author =~ m/^[^"\@]+\,/) {
2077 # single entry Maintainer field with unquoted comma
2078 $author = ($& =~ y/,//rd).$'; # strip the comma
2080 # git wants a single author; any remaining commas in $author
2081 # are by now preceded by @ (or "). It seems safer to punt on
2082 # "..." for now rather than attempting to dequote or something.
2083 $author =~ s#,.*##ms unless $author =~ m/"/;
2084 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2085 my $authline = "$author $date";
2086 $authline =~ m/$git_authline_re/o or
2087 fail "unexpected commit author line format \`$authline'".
2088 " (was generated from changelog Maintainer field)";
2089 return ($1,$2,$3) if wantarray;
2093 sub vendor_patches_distro ($$) {
2094 my ($checkdistro, $what) = @_;
2095 return unless defined $checkdistro;
2097 my $series = "debian/patches/\L$checkdistro\E.series";
2098 printdebug "checking for vendor-specific $series ($what)\n";
2100 if (!open SERIES, "<", $series) {
2101 die "$series $!" unless $!==ENOENT;
2110 Unfortunately, this source package uses a feature of dpkg-source where
2111 the same source package unpacks to different source code on different
2112 distros. dgit cannot safely operate on such packages on affected
2113 distros, because the meaning of source packages is not stable.
2115 Please ask the distro/maintainer to remove the distro-specific series
2116 files and use a different technique (if necessary, uploading actually
2117 different packages, if different distros are supposed to have
2121 fail "Found active distro-specific series file for".
2122 " $checkdistro ($what): $series, cannot continue";
2124 die "$series $!" if SERIES->error;
2128 sub check_for_vendor_patches () {
2129 # This dpkg-source feature doesn't seem to be documented anywhere!
2130 # But it can be found in the changelog (reformatted):
2132 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2133 # Author: Raphael Hertzog <hertzog@debian.org>
2134 # Date: Sun Oct 3 09:36:48 2010 +0200
2136 # dpkg-source: correctly create .pc/.quilt_series with alternate
2139 # If you have debian/patches/ubuntu.series and you were
2140 # unpacking the source package on ubuntu, quilt was still
2141 # directed to debian/patches/series instead of
2142 # debian/patches/ubuntu.series.
2144 # debian/changelog | 3 +++
2145 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2146 # 2 files changed, 6 insertions(+), 1 deletion(-)
2149 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2150 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2151 "Dpkg::Vendor \`current vendor'");
2152 vendor_patches_distro(access_basedistro(),
2153 "(base) distro being accessed");
2154 vendor_patches_distro(access_nomdistro(),
2155 "(nominal) distro being accessed");
2158 sub generate_commits_from_dsc () {
2159 # See big comment in fetch_from_archive, below.
2160 # See also README.dsc-import.
2162 changedir $playground;
2164 my @dfi = dsc_files_info();
2165 foreach my $fi (@dfi) {
2166 my $f = $fi->{Filename};
2167 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2168 my $upper_f = "$maindir/../$f";
2170 printdebug "considering reusing $f: ";
2172 if (link_ltarget "$upper_f,fetch", $f) {
2173 printdebug "linked (using ...,fetch).\n";
2174 } elsif ((printdebug "($!) "),
2176 fail "accessing ../$f,fetch: $!";
2177 } elsif (link_ltarget $upper_f, $f) {
2178 printdebug "linked.\n";
2179 } elsif ((printdebug "($!) "),
2181 fail "accessing ../$f: $!";
2183 printdebug "absent.\n";
2187 complete_file_from_dsc('.', $fi, \$refetched)
2190 printdebug "considering saving $f: ";
2192 if (link $f, $upper_f) {
2193 printdebug "linked.\n";
2194 } elsif ((printdebug "($!) "),
2196 fail "saving ../$f: $!";
2197 } elsif (!$refetched) {
2198 printdebug "no need.\n";
2199 } elsif (link $f, "$upper_f,fetch") {
2200 printdebug "linked (using ...,fetch).\n";
2201 } elsif ((printdebug "($!) "),
2203 fail "saving ../$f,fetch: $!";
2205 printdebug "cannot.\n";
2209 # We unpack and record the orig tarballs first, so that we only
2210 # need disk space for one private copy of the unpacked source.
2211 # But we can't make them into commits until we have the metadata
2212 # from the debian/changelog, so we record the tree objects now and
2213 # make them into commits later.
2215 my $upstreamv = upstreamversion $dsc->{version};
2216 my $orig_f_base = srcfn $upstreamv, '';
2218 foreach my $fi (@dfi) {
2219 # We actually import, and record as a commit, every tarball
2220 # (unless there is only one file, in which case there seems
2223 my $f = $fi->{Filename};
2224 printdebug "import considering $f ";
2225 (printdebug "only one dfi\n"), next if @dfi == 1;
2226 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2227 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2231 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2233 printdebug "Y ", (join ' ', map { $_//"(none)" }
2234 $compr_ext, $orig_f_part
2237 my $input = new IO::File $f, '<' or die "$f $!";
2241 if (defined $compr_ext) {
2243 Dpkg::Compression::compression_guess_from_filename $f;
2244 fail "Dpkg::Compression cannot handle file $f in source package"
2245 if defined $compr_ext && !defined $cname;
2247 new Dpkg::Compression::Process compression => $cname;
2248 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2249 my $compr_fh = new IO::Handle;
2250 my $compr_pid = open $compr_fh, "-|" // die $!;
2252 open STDIN, "<&", $input or die $!;
2254 die "dgit (child): exec $compr_cmd[0]: $!\n";
2259 rmtree "_unpack-tar";
2260 mkdir "_unpack-tar" or die $!;
2261 my @tarcmd = qw(tar -x -f -
2262 --no-same-owner --no-same-permissions
2263 --no-acls --no-xattrs --no-selinux);
2264 my $tar_pid = fork // die $!;
2266 chdir "_unpack-tar" or die $!;
2267 open STDIN, "<&", $input or die $!;
2269 die "dgit (child): exec $tarcmd[0]: $!";
2271 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2272 !$? or failedcmd @tarcmd;
2275 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2277 # finally, we have the results in "tarball", but maybe
2278 # with the wrong permissions
2280 runcmd qw(chmod -R +rwX _unpack-tar);
2281 changedir "_unpack-tar";
2282 remove_stray_gits($f);
2283 mktree_in_ud_here();
2285 my ($tree) = git_add_write_tree();
2286 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2287 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2289 printdebug "one subtree $1\n";
2291 printdebug "multiple subtrees\n";
2294 rmtree "_unpack-tar";
2296 my $ent = [ $f, $tree ];
2298 Orig => !!$orig_f_part,
2299 Sort => (!$orig_f_part ? 2 :
2300 $orig_f_part =~ m/-/g ? 1 :
2308 # put any without "_" first (spec is not clear whether files
2309 # are always in the usual order). Tarballs without "_" are
2310 # the main orig or the debian tarball.
2311 $a->{Sort} <=> $b->{Sort} or
2315 my $any_orig = grep { $_->{Orig} } @tartrees;
2317 my $dscfn = "$package.dsc";
2319 my $treeimporthow = 'package';
2321 open D, ">", $dscfn or die "$dscfn: $!";
2322 print D $dscdata or die "$dscfn: $!";
2323 close D or die "$dscfn: $!";
2324 my @cmd = qw(dpkg-source);
2325 push @cmd, '--no-check' if $dsc_checked;
2326 if (madformat $dsc->{format}) {
2327 push @cmd, '--skip-patches';
2328 $treeimporthow = 'unpatched';
2330 push @cmd, qw(-x --), $dscfn;
2333 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2334 if (madformat $dsc->{format}) {
2335 check_for_vendor_patches();
2339 if (madformat $dsc->{format}) {
2340 my @pcmd = qw(dpkg-source --before-build .);
2341 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2343 $dappliedtree = git_add_write_tree();
2346 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2347 debugcmd "|",@clogcmd;
2348 open CLOGS, "-|", @clogcmd or die $!;
2353 printdebug "import clog search...\n";
2356 my $stanzatext = do { local $/=""; <CLOGS>; };
2357 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2358 last if !defined $stanzatext;
2360 my $desc = "package changelog, entry no.$.";
2361 open my $stanzafh, "<", \$stanzatext or die;
2362 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2363 $clogp //= $thisstanza;
2365 printdebug "import clog $thisstanza->{version} $desc...\n";
2367 last if !$any_orig; # we don't need $r1clogp
2369 # We look for the first (most recent) changelog entry whose
2370 # version number is lower than the upstream version of this
2371 # package. Then the last (least recent) previous changelog
2372 # entry is treated as the one which introduced this upstream
2373 # version and used for the synthetic commits for the upstream
2376 # One might think that a more sophisticated algorithm would be
2377 # necessary. But: we do not want to scan the whole changelog
2378 # file. Stopping when we see an earlier version, which
2379 # necessarily then is an earlier upstream version, is the only
2380 # realistic way to do that. Then, either the earliest
2381 # changelog entry we have seen so far is indeed the earliest
2382 # upload of this upstream version; or there are only changelog
2383 # entries relating to later upstream versions (which is not
2384 # possible unless the changelog and .dsc disagree about the
2385 # version). Then it remains to choose between the physically
2386 # last entry in the file, and the one with the lowest version
2387 # number. If these are not the same, we guess that the
2388 # versions were created in a non-monotic order rather than
2389 # that the changelog entries have been misordered.
2391 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2393 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2394 $r1clogp = $thisstanza;
2396 printdebug "import clog $r1clogp->{version} becomes r1\n";
2398 die $! if CLOGS->error;
2399 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2401 $clogp or fail "package changelog has no entries!";
2403 my $authline = clogp_authline $clogp;
2404 my $changes = getfield $clogp, 'Changes';
2405 $changes =~ s/^\n//; # Changes: \n
2406 my $cversion = getfield $clogp, 'Version';
2409 $r1clogp //= $clogp; # maybe there's only one entry;
2410 my $r1authline = clogp_authline $r1clogp;
2411 # Strictly, r1authline might now be wrong if it's going to be
2412 # unused because !$any_orig. Whatever.
2414 printdebug "import tartrees authline $authline\n";
2415 printdebug "import tartrees r1authline $r1authline\n";
2417 foreach my $tt (@tartrees) {
2418 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2420 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2423 committer $r1authline
2427 [dgit import orig $tt->{F}]
2435 [dgit import tarball $package $cversion $tt->{F}]
2440 printdebug "import main commit\n";
2442 open C, ">../commit.tmp" or die $!;
2443 print C <<END or die $!;
2446 print C <<END or die $! foreach @tartrees;
2449 print C <<END or die $!;
2455 [dgit import $treeimporthow $package $cversion]
2459 my $rawimport_hash = make_commit qw(../commit.tmp);
2461 if (madformat $dsc->{format}) {
2462 printdebug "import apply patches...\n";
2464 # regularise the state of the working tree so that
2465 # the checkout of $rawimport_hash works nicely.
2466 my $dappliedcommit = make_commit_text(<<END);
2473 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2475 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2477 # We need the answers to be reproducible
2478 my @authline = clogp_authline($clogp);
2479 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2480 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2481 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2482 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2483 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2484 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2486 my $path = $ENV{PATH} or die;
2488 # we use ../../gbp-pq-output, which (given that we are in
2489 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2492 foreach my $use_absurd (qw(0 1)) {
2493 runcmd @git, qw(checkout -q unpa);
2494 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2495 local $ENV{PATH} = $path;
2498 progress "warning: $@";
2499 $path = "$absurdity:$path";
2500 progress "$us: trying slow absurd-git-apply...";
2501 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2506 die "forbid absurd git-apply\n" if $use_absurd
2507 && forceing [qw(import-gitapply-no-absurd)];
2508 die "only absurd git-apply!\n" if !$use_absurd
2509 && forceing [qw(import-gitapply-absurd)];
2511 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2512 local $ENV{PATH} = $path if $use_absurd;
2514 my @showcmd = (gbp_pq, qw(import));
2515 my @realcmd = shell_cmd
2516 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2517 debugcmd "+",@realcmd;
2518 if (system @realcmd) {
2519 die +(shellquote @showcmd).
2521 failedcmd_waitstatus()."\n";
2524 my $gapplied = git_rev_parse('HEAD');
2525 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2526 $gappliedtree eq $dappliedtree or
2528 gbp-pq import and dpkg-source disagree!
2529 gbp-pq import gave commit $gapplied
2530 gbp-pq import gave tree $gappliedtree
2531 dpkg-source --before-build gave tree $dappliedtree
2533 $rawimport_hash = $gapplied;
2538 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2543 progress "synthesised git commit from .dsc $cversion";
2545 my $rawimport_mergeinput = {
2546 Commit => $rawimport_hash,
2547 Info => "Import of source package",
2549 my @output = ($rawimport_mergeinput);
2551 if ($lastpush_mergeinput) {
2552 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2553 my $oversion = getfield $oldclogp, 'Version';
2555 version_compare($oversion, $cversion);
2557 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2558 { Message => <<END, ReverseParents => 1 });
2559 Record $package ($cversion) in archive suite $csuite
2561 } elsif ($vcmp > 0) {
2562 print STDERR <<END or die $!;
2564 Version actually in archive: $cversion (older)
2565 Last version pushed with dgit: $oversion (newer or same)
2568 @output = $lastpush_mergeinput;
2570 # Same version. Use what's in the server git branch,
2571 # discarding our own import. (This could happen if the
2572 # server automatically imports all packages into git.)
2573 @output = $lastpush_mergeinput;
2581 sub complete_file_from_dsc ($$;$) {
2582 our ($dstdir, $fi, $refetched) = @_;
2583 # Ensures that we have, in $dstdir, the file $fi, with the correct
2584 # contents. (Downloading it from alongside $dscurl if necessary.)
2585 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2586 # and will set $$refetched=1 if it did so (or tried to).
2588 my $f = $fi->{Filename};
2589 my $tf = "$dstdir/$f";
2593 my $checkhash = sub {
2594 open F, "<", "$tf" or die "$tf: $!";
2595 $fi->{Digester}->reset();
2596 $fi->{Digester}->addfile(*F);
2597 F->error and die $!;
2598 $got = $fi->{Digester}->hexdigest();
2599 return $got eq $fi->{Hash};
2602 if (stat_exists $tf) {
2603 if ($checkhash->()) {
2604 progress "using existing $f";
2608 fail "file $f has hash $got but .dsc".
2609 " demands hash $fi->{Hash} ".
2610 "(perhaps you should delete this file?)";
2612 progress "need to fetch correct version of $f";
2613 unlink $tf or die "$tf $!";
2616 printdebug "$tf does not exist, need to fetch\n";
2620 $furl =~ s{/[^/]+$}{};
2622 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2623 die "$f ?" if $f =~ m#/#;
2624 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2625 return 0 if !act_local();
2628 fail "file $f has hash $got but .dsc".
2629 " demands hash $fi->{Hash} ".
2630 "(got wrong file from archive!)";
2635 sub ensure_we_have_orig () {
2636 my @dfi = dsc_files_info();
2637 foreach my $fi (@dfi) {
2638 my $f = $fi->{Filename};
2639 next unless is_orig_file_in_dsc($f, \@dfi);
2640 complete_file_from_dsc('..', $fi)
2645 #---------- git fetch ----------
2647 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2648 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2650 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2651 # locally fetched refs because they have unhelpful names and clutter
2652 # up gitk etc. So we track whether we have "used up" head ref (ie,
2653 # whether we have made another local ref which refers to this object).
2655 # (If we deleted them unconditionally, then we might end up
2656 # re-fetching the same git objects each time dgit fetch was run.)
2658 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2659 # in git_fetch_us to fetch the refs in question, and possibly a call
2660 # to lrfetchref_used.
2662 our (%lrfetchrefs_f, %lrfetchrefs_d);
2663 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2665 sub lrfetchref_used ($) {
2666 my ($fullrefname) = @_;
2667 my $objid = $lrfetchrefs_f{$fullrefname};
2668 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2671 sub git_lrfetch_sane {
2672 my ($url, $supplementary, @specs) = @_;
2673 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2674 # at least as regards @specs. Also leave the results in
2675 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2676 # able to clean these up.
2678 # With $supplementary==1, @specs must not contain wildcards
2679 # and we add to our previous fetches (non-atomically).
2681 # This is rather miserable:
2682 # When git fetch --prune is passed a fetchspec ending with a *,
2683 # it does a plausible thing. If there is no * then:
2684 # - it matches subpaths too, even if the supplied refspec
2685 # starts refs, and behaves completely madly if the source
2686 # has refs/refs/something. (See, for example, Debian #NNNN.)
2687 # - if there is no matching remote ref, it bombs out the whole
2689 # We want to fetch a fixed ref, and we don't know in advance
2690 # if it exists, so this is not suitable.
2692 # Our workaround is to use git ls-remote. git ls-remote has its
2693 # own qairks. Notably, it has the absurd multi-tail-matching
2694 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2695 # refs/refs/foo etc.
2697 # Also, we want an idempotent snapshot, but we have to make two
2698 # calls to the remote: one to git ls-remote and to git fetch. The
2699 # solution is use git ls-remote to obtain a target state, and
2700 # git fetch to try to generate it. If we don't manage to generate
2701 # the target state, we try again.
2703 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2705 my $specre = join '|', map {
2708 my $wildcard = $x =~ s/\\\*$/.*/;
2709 die if $wildcard && $supplementary;
2712 printdebug "git_lrfetch_sane specre=$specre\n";
2713 my $wanted_rref = sub {
2715 return m/^(?:$specre)$/;
2718 my $fetch_iteration = 0;
2721 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2722 if (++$fetch_iteration > 10) {
2723 fail "too many iterations trying to get sane fetch!";
2726 my @look = map { "refs/$_" } @specs;
2727 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2731 open GITLS, "-|", @lcmd or die $!;
2733 printdebug "=> ", $_;
2734 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2735 my ($objid,$rrefname) = ($1,$2);
2736 if (!$wanted_rref->($rrefname)) {
2738 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2742 $wantr{$rrefname} = $objid;
2745 close GITLS or failedcmd @lcmd;
2747 # OK, now %want is exactly what we want for refs in @specs
2749 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2750 "+refs/$_:".lrfetchrefs."/$_";
2753 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2755 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2756 runcmd_ordryrun_local @fcmd if @fspecs;
2758 if (!$supplementary) {
2759 %lrfetchrefs_f = ();
2763 git_for_each_ref(lrfetchrefs, sub {
2764 my ($objid,$objtype,$lrefname,$reftail) = @_;
2765 $lrfetchrefs_f{$lrefname} = $objid;
2766 $objgot{$objid} = 1;
2769 if ($supplementary) {
2773 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2774 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2775 if (!exists $wantr{$rrefname}) {
2776 if ($wanted_rref->($rrefname)) {
2778 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2782 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2785 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2786 delete $lrfetchrefs_f{$lrefname};
2790 foreach my $rrefname (sort keys %wantr) {
2791 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2792 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2793 my $want = $wantr{$rrefname};
2794 next if $got eq $want;
2795 if (!defined $objgot{$want}) {
2796 fail <<END unless act_local();
2797 --dry-run specified but we actually wanted the results of git fetch,
2798 so this is not going to work. Try running dgit fetch first,
2799 or using --damp-run instead of --dry-run.
2802 warning: git ls-remote suggests we want $lrefname
2803 warning: and it should refer to $want
2804 warning: but git fetch didn't fetch that object to any relevant ref.
2805 warning: This may be due to a race with someone updating the server.
2806 warning: Will try again...
2808 next FETCH_ITERATION;
2811 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2813 runcmd_ordryrun_local @git, qw(update-ref -m),
2814 "dgit fetch git fetch fixup", $lrefname, $want;
2815 $lrfetchrefs_f{$lrefname} = $want;
2820 if (defined $csuite) {
2821 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2822 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2823 my ($objid,$objtype,$lrefname,$reftail) = @_;
2824 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2825 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2829 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2830 Dumper(\%lrfetchrefs_f);
2833 sub git_fetch_us () {
2834 # Want to fetch only what we are going to use, unless
2835 # deliberately-not-ff, in which case we must fetch everything.
2837 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2839 (quiltmode_splitbrain
2840 ? (map { $_->('*',access_nomdistro) }
2841 \&debiantag_new, \&debiantag_maintview)
2842 : debiantags('*',access_nomdistro));
2843 push @specs, server_branch($csuite);
2844 push @specs, $rewritemap;
2845 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2847 my $url = access_giturl();
2848 git_lrfetch_sane $url, 0, @specs;
2851 my @tagpats = debiantags('*',access_nomdistro);
2853 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2854 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2855 printdebug "currently $fullrefname=$objid\n";
2856 $here{$fullrefname} = $objid;
2858 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2859 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2860 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2861 printdebug "offered $lref=$objid\n";
2862 if (!defined $here{$lref}) {
2863 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2864 runcmd_ordryrun_local @upd;
2865 lrfetchref_used $fullrefname;
2866 } elsif ($here{$lref} eq $objid) {
2867 lrfetchref_used $fullrefname;
2870 "Not updating $lref from $here{$lref} to $objid.\n";
2875 #---------- dsc and archive handling ----------
2877 sub mergeinfo_getclogp ($) {
2878 # Ensures thit $mi->{Clogp} exists and returns it
2880 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2883 sub mergeinfo_version ($) {
2884 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2887 sub fetch_from_archive_record_1 ($) {
2889 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2890 cmdoutput @git, qw(log -n2), $hash;
2891 # ... gives git a chance to complain if our commit is malformed
2894 sub fetch_from_archive_record_2 ($) {
2896 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2900 dryrun_report @upd_cmd;
2904 sub parse_dsc_field_def_dsc_distro () {
2905 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2906 dgit.default.distro);
2909 sub parse_dsc_field ($$) {
2910 my ($dsc, $what) = @_;
2912 foreach my $field (@ourdscfield) {
2913 $f = $dsc->{$field};
2918 progress "$what: NO git hash";
2919 parse_dsc_field_def_dsc_distro();
2920 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2921 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2922 progress "$what: specified git info ($dsc_distro)";
2923 $dsc_hint_tag = [ $dsc_hint_tag ];
2924 } elsif ($f =~ m/^\w+\s*$/) {
2926 parse_dsc_field_def_dsc_distro();
2927 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2929 progress "$what: specified git hash";
2931 fail "$what: invalid Dgit info";
2935 sub resolve_dsc_field_commit ($$) {
2936 my ($already_distro, $already_mapref) = @_;
2938 return unless defined $dsc_hash;
2941 defined $already_mapref &&
2942 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2943 ? $already_mapref : undef;
2947 my ($what, @fetch) = @_;
2949 local $idistro = $dsc_distro;
2950 my $lrf = lrfetchrefs;
2952 if (!$chase_dsc_distro) {
2954 "not chasing .dsc distro $dsc_distro: not fetching $what";
2959 ".dsc names distro $dsc_distro: fetching $what";
2961 my $url = access_giturl();
2962 if (!defined $url) {
2963 defined $dsc_hint_url or fail <<END;
2964 .dsc Dgit metadata is in context of distro $dsc_distro
2965 for which we have no configured url and .dsc provides no hint
2968 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2969 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2970 parse_cfg_bool "dsc-url-proto-ok", 'false',
2971 cfg("dgit.dsc-url-proto-ok.$proto",
2972 "dgit.default.dsc-url-proto-ok")
2974 .dsc Dgit metadata is in context of distro $dsc_distro
2975 for which we have no configured url;
2976 .dsc provides hinted url with protocol $proto which is unsafe.
2977 (can be overridden by config - consult documentation)
2979 $url = $dsc_hint_url;
2982 git_lrfetch_sane $url, 1, @fetch;
2987 my $rewrite_enable = do {
2988 local $idistro = $dsc_distro;
2989 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2992 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2993 if (!defined $mapref) {
2994 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2995 $mapref = $lrf.'/'.$rewritemap;
2997 my $rewritemapdata = git_cat_file $mapref.':map';
2998 if (defined $rewritemapdata
2999 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3001 "server's git history rewrite map contains a relevant entry!";
3004 if (defined $dsc_hash) {
3005 progress "using rewritten git hash in place of .dsc value";
3007 progress "server data says .dsc hash is to be disregarded";
3012 if (!defined git_cat_file $dsc_hash) {
3013 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3014 my $lrf = $do_fetch->("additional commits", @tags) &&
3015 defined git_cat_file $dsc_hash
3017 .dsc Dgit metadata requires commit $dsc_hash
3018 but we could not obtain that object anywhere.
3020 foreach my $t (@tags) {
3021 my $fullrefname = $lrf.'/'.$t;
3022 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3023 next unless $lrfetchrefs_f{$fullrefname};
3024 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3025 lrfetchref_used $fullrefname;
3030 sub fetch_from_archive () {
3031 ensure_setup_existing_tree();
3033 # Ensures that lrref() is what is actually in the archive, one way
3034 # or another, according to us - ie this client's
3035 # appropritaely-updated archive view. Also returns the commit id.
3036 # If there is nothing in the archive, leaves lrref alone and
3037 # returns undef. git_fetch_us must have already been called.
3041 parse_dsc_field($dsc, 'last upload to archive');
3042 resolve_dsc_field_commit access_basedistro,
3043 lrfetchrefs."/".$rewritemap
3045 progress "no version available from the archive";
3048 # If the archive's .dsc has a Dgit field, there are three
3049 # relevant git commitids we need to choose between and/or merge
3051 # 1. $dsc_hash: the Dgit field from the archive
3052 # 2. $lastpush_hash: the suite branch on the dgit git server
3053 # 3. $lastfetch_hash: our local tracking brach for the suite
3055 # These may all be distinct and need not be in any fast forward
3058 # If the dsc was pushed to this suite, then the server suite
3059 # branch will have been updated; but it might have been pushed to
3060 # a different suite and copied by the archive. Conversely a more
3061 # recent version may have been pushed with dgit but not appeared
3062 # in the archive (yet).
3064 # $lastfetch_hash may be awkward because archive imports
3065 # (particularly, imports of Dgit-less .dscs) are performed only as
3066 # needed on individual clients, so different clients may perform a
3067 # different subset of them - and these imports are only made
3068 # public during push. So $lastfetch_hash may represent a set of
3069 # imports different to a subsequent upload by a different dgit
3072 # Our approach is as follows:
3074 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3075 # descendant of $dsc_hash, then it was pushed by a dgit user who
3076 # had based their work on $dsc_hash, so we should prefer it.
3077 # Otherwise, $dsc_hash was installed into this suite in the
3078 # archive other than by a dgit push, and (necessarily) after the
3079 # last dgit push into that suite (since a dgit push would have
3080 # been descended from the dgit server git branch); thus, in that
3081 # case, we prefer the archive's version (and produce a
3082 # pseudo-merge to overwrite the dgit server git branch).
3084 # (If there is no Dgit field in the archive's .dsc then
3085 # generate_commit_from_dsc uses the version numbers to decide
3086 # whether the suite branch or the archive is newer. If the suite
3087 # branch is newer it ignores the archive's .dsc; otherwise it
3088 # generates an import of the .dsc, and produces a pseudo-merge to
3089 # overwrite the suite branch with the archive contents.)
3091 # The outcome of that part of the algorithm is the `public view',
3092 # and is same for all dgit clients: it does not depend on any
3093 # unpublished history in the local tracking branch.
3095 # As between the public view and the local tracking branch: The
3096 # local tracking branch is only updated by dgit fetch, and
3097 # whenever dgit fetch runs it includes the public view in the
3098 # local tracking branch. Therefore if the public view is not
3099 # descended from the local tracking branch, the local tracking
3100 # branch must contain history which was imported from the archive
3101 # but never pushed; and, its tip is now out of date. So, we make
3102 # a pseudo-merge to overwrite the old imports and stitch the old
3105 # Finally: we do not necessarily reify the public view (as
3106 # described above). This is so that we do not end up stacking two
3107 # pseudo-merges. So what we actually do is figure out the inputs
3108 # to any public view pseudo-merge and put them in @mergeinputs.
3111 # $mergeinputs[]{Commit}
3112 # $mergeinputs[]{Info}
3113 # $mergeinputs[0] is the one whose tree we use
3114 # @mergeinputs is in the order we use in the actual commit)
3117 # $mergeinputs[]{Message} is a commit message to use
3118 # $mergeinputs[]{ReverseParents} if def specifies that parent
3119 # list should be in opposite order
3120 # Such an entry has no Commit or Info. It applies only when found
3121 # in the last entry. (This ugliness is to support making
3122 # identical imports to previous dgit versions.)
3124 my $lastpush_hash = git_get_ref(lrfetchref());
3125 printdebug "previous reference hash=$lastpush_hash\n";
3126 $lastpush_mergeinput = $lastpush_hash && {
3127 Commit => $lastpush_hash,
3128 Info => "dgit suite branch on dgit git server",
3131 my $lastfetch_hash = git_get_ref(lrref());
3132 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3133 my $lastfetch_mergeinput = $lastfetch_hash && {
3134 Commit => $lastfetch_hash,
3135 Info => "dgit client's archive history view",
3138 my $dsc_mergeinput = $dsc_hash && {
3139 Commit => $dsc_hash,
3140 Info => "Dgit field in .dsc from archive",
3144 my $del_lrfetchrefs = sub {
3147 printdebug "del_lrfetchrefs...\n";
3148 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3149 my $objid = $lrfetchrefs_d{$fullrefname};
3150 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3152 $gur ||= new IO::Handle;
3153 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3155 printf $gur "delete %s %s\n", $fullrefname, $objid;
3158 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3162 if (defined $dsc_hash) {
3163 ensure_we_have_orig();
3164 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3165 @mergeinputs = $dsc_mergeinput
3166 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3167 print STDERR <<END or die $!;
3169 Git commit in archive is behind the last version allegedly pushed/uploaded.
3170 Commit referred to by archive: $dsc_hash
3171 Last version pushed with dgit: $lastpush_hash
3174 @mergeinputs = ($lastpush_mergeinput);
3176 # Archive has .dsc which is not a descendant of the last dgit
3177 # push. This can happen if the archive moves .dscs about.
3178 # Just follow its lead.
3179 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3180 progress "archive .dsc names newer git commit";
3181 @mergeinputs = ($dsc_mergeinput);
3183 progress "archive .dsc names other git commit, fixing up";
3184 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3188 @mergeinputs = generate_commits_from_dsc();
3189 # We have just done an import. Now, our import algorithm might
3190 # have been improved. But even so we do not want to generate
3191 # a new different import of the same package. So if the
3192 # version numbers are the same, just use our existing version.
3193 # If the version numbers are different, the archive has changed
3194 # (perhaps, rewound).
3195 if ($lastfetch_mergeinput &&
3196 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3197 (mergeinfo_version $mergeinputs[0]) )) {
3198 @mergeinputs = ($lastfetch_mergeinput);
3200 } elsif ($lastpush_hash) {
3201 # only in git, not in the archive yet
3202 @mergeinputs = ($lastpush_mergeinput);
3203 print STDERR <<END or die $!;
3205 Package not found in the archive, but has allegedly been pushed using dgit.
3209 printdebug "nothing found!\n";
3210 if (defined $skew_warning_vsn) {
3211 print STDERR <<END or die $!;
3213 Warning: relevant archive skew detected.
3214 Archive allegedly contains $skew_warning_vsn
3215 But we were not able to obtain any version from the archive or git.
3219 unshift @end, $del_lrfetchrefs;
3223 if ($lastfetch_hash &&
3225 my $h = $_->{Commit};
3226 $h and is_fast_fwd($lastfetch_hash, $h);
3227 # If true, one of the existing parents of this commit
3228 # is a descendant of the $lastfetch_hash, so we'll
3229 # be ff from that automatically.
3233 push @mergeinputs, $lastfetch_mergeinput;
3236 printdebug "fetch mergeinfos:\n";
3237 foreach my $mi (@mergeinputs) {
3239 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3241 printdebug sprintf " ReverseParents=%d Message=%s",
3242 $mi->{ReverseParents}, $mi->{Message};
3246 my $compat_info= pop @mergeinputs
3247 if $mergeinputs[$#mergeinputs]{Message};
3249 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3252 if (@mergeinputs > 1) {
3254 my $tree_commit = $mergeinputs[0]{Commit};
3256 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3257 $tree =~ m/\n\n/; $tree = $`;
3258 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3261 # We use the changelog author of the package in question the
3262 # author of this pseudo-merge. This is (roughly) correct if
3263 # this commit is simply representing aa non-dgit upload.
3264 # (Roughly because it does not record sponsorship - but we
3265 # don't have sponsorship info because that's in the .changes,
3266 # which isn't in the archivw.)
3268 # But, it might be that we are representing archive history
3269 # updates (including in-archive copies). These are not really
3270 # the responsibility of the person who created the .dsc, but
3271 # there is no-one whose name we should better use. (The
3272 # author of the .dsc-named commit is clearly worse.)
3274 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3275 my $author = clogp_authline $useclogp;
3276 my $cversion = getfield $useclogp, 'Version';
3278 my $mcf = dgit_privdir()."/mergecommit";
3279 open MC, ">", $mcf or die "$mcf $!";
3280 print MC <<END or die $!;
3284 my @parents = grep { $_->{Commit} } @mergeinputs;
3285 @parents = reverse @parents if $compat_info->{ReverseParents};
3286 print MC <<END or die $! foreach @parents;
3290 print MC <<END or die $!;
3296 if (defined $compat_info->{Message}) {
3297 print MC $compat_info->{Message} or die $!;
3299 print MC <<END or die $!;
3300 Record $package ($cversion) in archive suite $csuite
3304 my $message_add_info = sub {
3306 my $mversion = mergeinfo_version $mi;
3307 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3311 $message_add_info->($mergeinputs[0]);
3312 print MC <<END or die $!;
3313 should be treated as descended from
3315 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3319 $hash = make_commit $mcf;
3321 $hash = $mergeinputs[0]{Commit};
3323 printdebug "fetch hash=$hash\n";
3326 my ($lasth, $what) = @_;
3327 return unless $lasth;
3328 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3331 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3333 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3335 fetch_from_archive_record_1($hash);
3337 if (defined $skew_warning_vsn) {
3338 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3339 my $gotclogp = commit_getclogp($hash);
3340 my $got_vsn = getfield $gotclogp, 'Version';
3341 printdebug "SKEW CHECK GOT $got_vsn\n";
3342 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3343 print STDERR <<END or die $!;
3345 Warning: archive skew detected. Using the available version:
3346 Archive allegedly contains $skew_warning_vsn
3347 We were able to obtain only $got_vsn
3353 if ($lastfetch_hash ne $hash) {
3354 fetch_from_archive_record_2($hash);
3357 lrfetchref_used lrfetchref();
3359 check_gitattrs($hash, "fetched source tree");
3361 unshift @end, $del_lrfetchrefs;
3365 sub set_local_git_config ($$) {
3367 runcmd @git, qw(config), $k, $v;
3370 sub setup_mergechangelogs (;$) {
3372 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3374 my $driver = 'dpkg-mergechangelogs';
3375 my $cb = "merge.$driver";
3376 confess unless defined $maindir;
3377 my $attrs = "$maindir_gitcommon/info/attributes";
3378 ensuredir "$maindir_gitcommon/info";
3380 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3381 if (!open ATTRS, "<", $attrs) {
3382 $!==ENOENT or die "$attrs: $!";
3386 next if m{^debian/changelog\s};
3387 print NATTRS $_, "\n" or die $!;
3389 ATTRS->error and die $!;
3392 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3395 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3396 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3398 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3401 sub setup_useremail (;$) {
3403 return unless $always || access_cfg_bool(1, 'setup-useremail');
3406 my ($k, $envvar) = @_;
3407 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3408 return unless defined $v;
3409 set_local_git_config "user.$k", $v;
3412 $setup->('email', 'DEBEMAIL');
3413 $setup->('name', 'DEBFULLNAME');
3416 sub ensure_setup_existing_tree () {
3417 my $k = "remote.$remotename.skipdefaultupdate";
3418 my $c = git_get_config $k;
3419 return if defined $c;
3420 set_local_git_config $k, 'true';
3423 sub open_main_gitattrs () {
3424 confess 'internal error no maindir' unless defined $maindir;
3425 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3427 or die "open $maindir_gitcommon/info/attributes: $!";
3431 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3433 sub is_gitattrs_setup () {
3436 # 1: gitattributes set up and should be left alone
3438 # 0: there is a dgit-defuse-attrs but it needs fixing
3439 # undef: there is none
3440 my $gai = open_main_gitattrs();
3441 return 0 unless $gai;
3443 next unless m{$gitattrs_ourmacro_re};
3444 return 1 if m{\s-working-tree-encoding\s};
3445 printdebug "is_gitattrs_setup: found old macro\n";
3448 $gai->error and die $!;
3449 printdebug "is_gitattrs_setup: found nothing\n";
3453 sub setup_gitattrs (;$) {
3455 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3457 my $already = is_gitattrs_setup();
3460 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3461 not doing further gitattributes setup
3465 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3466 my $af = "$maindir_gitcommon/info/attributes";
3467 ensuredir "$maindir_gitcommon/info";
3469 open GAO, "> $af.new" or die $!;
3470 print GAO <<END or die $! unless defined $already;
3473 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3475 my $gai = open_main_gitattrs();
3478 if (m{$gitattrs_ourmacro_re}) {
3479 die unless defined $already;
3483 print GAO $_, "\n" or die $!;
3485 $gai->error and die $!;
3487 close GAO or die $!;
3488 rename "$af.new", "$af" or die "install $af: $!";
3491 sub setup_new_tree () {
3492 setup_mergechangelogs();
3497 sub check_gitattrs ($$) {
3498 my ($treeish, $what) = @_;
3500 return if is_gitattrs_setup;
3503 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3505 my $gafl = new IO::File;
3506 open $gafl, "-|", @cmd or die $!;
3509 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3511 next unless m{(?:^|/)\.gitattributes$};
3513 # oh dear, found one
3515 dgit: warning: $what contains .gitattributes
3516 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3521 # tree contains no .gitattributes files
3522 $?=0; $!=0; close $gafl or failedcmd @cmd;
3526 sub multisuite_suite_child ($$$) {
3527 my ($tsuite, $merginputs, $fn) = @_;
3528 # in child, sets things up, calls $fn->(), and returns undef
3529 # in parent, returns canonical suite name for $tsuite
3530 my $canonsuitefh = IO::File::new_tmpfile;
3531 my $pid = fork // die $!;
3535 $us .= " [$isuite]";
3536 $debugprefix .= " ";
3537 progress "fetching $tsuite...";
3538 canonicalise_suite();
3539 print $canonsuitefh $csuite, "\n" or die $!;
3540 close $canonsuitefh or die $!;
3544 waitpid $pid,0 == $pid or die $!;
3545 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3546 seek $canonsuitefh,0,0 or die $!;
3547 local $csuite = <$canonsuitefh>;
3548 die $! unless defined $csuite && chomp $csuite;
3550 printdebug "multisuite $tsuite missing\n";
3553 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3554 push @$merginputs, {
3561 sub fork_for_multisuite ($) {
3562 my ($before_fetch_merge) = @_;
3563 # if nothing unusual, just returns ''
3566 # returns 0 to caller in child, to do first of the specified suites
3567 # in child, $csuite is not yet set
3569 # returns 1 to caller in parent, to finish up anything needed after
3570 # in parent, $csuite is set to canonicalised portmanteau
3572 my $org_isuite = $isuite;
3573 my @suites = split /\,/, $isuite;
3574 return '' unless @suites > 1;
3575 printdebug "fork_for_multisuite: @suites\n";
3579 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3581 return 0 unless defined $cbasesuite;
3583 fail "package $package missing in (base suite) $cbasesuite"
3584 unless @mergeinputs;
3586 my @csuites = ($cbasesuite);
3588 $before_fetch_merge->();
3590 foreach my $tsuite (@suites[1..$#suites]) {
3591 $tsuite =~ s/^-/$cbasesuite-/;
3592 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3598 # xxx collecte the ref here
3600 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3601 push @csuites, $csubsuite;
3604 foreach my $mi (@mergeinputs) {
3605 my $ref = git_get_ref $mi->{Ref};
3606 die "$mi->{Ref} ?" unless length $ref;
3607 $mi->{Commit} = $ref;
3610 $csuite = join ",", @csuites;
3612 my $previous = git_get_ref lrref;
3614 unshift @mergeinputs, {
3615 Commit => $previous,
3616 Info => "local combined tracking branch",
3618 "archive seems to have rewound: local tracking branch is ahead!",
3622 foreach my $ix (0..$#mergeinputs) {
3623 $mergeinputs[$ix]{Index} = $ix;
3626 @mergeinputs = sort {
3627 -version_compare(mergeinfo_version $a,
3628 mergeinfo_version $b) # highest version first
3630 $a->{Index} <=> $b->{Index}; # earliest in spec first
3636 foreach my $mi (@mergeinputs) {
3637 printdebug "multisuite merge check $mi->{Info}\n";
3638 foreach my $previous (@needed) {
3639 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3640 printdebug "multisuite merge un-needed $previous->{Info}\n";
3644 printdebug "multisuite merge this-needed\n";
3645 $mi->{Character} = '+';
3648 $needed[0]{Character} = '*';
3650 my $output = $needed[0]{Commit};
3653 printdebug "multisuite merge nontrivial\n";
3654 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3656 my $commit = "tree $tree\n";
3657 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3658 "Input branches:\n";
3660 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3661 printdebug "multisuite merge include $mi->{Info}\n";
3662 $mi->{Character} //= ' ';
3663 $commit .= "parent $mi->{Commit}\n";
3664 $msg .= sprintf " %s %-25s %s\n",
3666 (mergeinfo_version $mi),
3669 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3671 " * marks the highest version branch, which choose to use\n".
3672 " + marks each branch which was not already an ancestor\n\n".
3673 "[dgit multi-suite $csuite]\n";
3675 "author $authline\n".
3676 "committer $authline\n\n";
3677 $output = make_commit_text $commit.$msg;
3678 printdebug "multisuite merge generated $output\n";
3681 fetch_from_archive_record_1($output);
3682 fetch_from_archive_record_2($output);
3684 progress "calculated combined tracking suite $csuite";
3689 sub clone_set_head () {
3690 open H, "> .git/HEAD" or die $!;
3691 print H "ref: ".lref()."\n" or die $!;
3694 sub clone_finish ($) {
3696 runcmd @git, qw(reset --hard), lrref();
3697 runcmd qw(bash -ec), <<'END';
3699 git ls-tree -r --name-only -z HEAD | \
3700 xargs -0r touch -h -r . --
3702 printdone "ready for work in $dstdir";
3706 # in multisuite, returns twice!
3707 # once in parent after first suite fetched,
3708 # and then again in child after everything is finished
3710 badusage "dry run makes no sense with clone" unless act_local();
3712 my $multi_fetched = fork_for_multisuite(sub {
3713 printdebug "multi clone before fetch merge\n";
3717 if ($multi_fetched) {
3718 printdebug "multi clone after fetch merge\n";
3720 clone_finish($dstdir);
3723 printdebug "clone main body\n";
3725 canonicalise_suite();
3726 my $hasgit = check_for_git();
3727 mkdir $dstdir or fail "create \`$dstdir': $!";
3729 runcmd @git, qw(init -q);
3733 my $giturl = access_giturl(1);
3734 if (defined $giturl) {
3735 runcmd @git, qw(remote add), 'origin', $giturl;
3738 progress "fetching existing git history";
3740 runcmd_ordryrun_local @git, qw(fetch origin);
3742 progress "starting new git history";
3744 fetch_from_archive() or no_such_package;
3745 my $vcsgiturl = $dsc->{'Vcs-Git'};
3746 if (length $vcsgiturl) {
3747 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3748 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3750 clone_finish($dstdir);
3754 canonicalise_suite();
3755 if (check_for_git()) {
3758 fetch_from_archive() or no_such_package();
3760 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3761 if (length $vcsgiturl and
3762 (grep { $csuite eq $_ }
3764 cfg 'dgit.vcs-git.suites')) {
3765 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3766 if (defined $current && $current ne $vcsgiturl) {
3768 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3769 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3773 printdone "fetched into ".lrref();
3777 my $multi_fetched = fork_for_multisuite(sub { });
3778 fetch_one() unless $multi_fetched; # parent
3779 finish 0 if $multi_fetched eq '0'; # child
3784 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3786 printdone "fetched to ".lrref()." and merged into HEAD";
3789 sub check_not_dirty () {
3790 foreach my $f (qw(local-options local-patch-header)) {
3791 if (stat_exists "debian/source/$f") {
3792 fail "git tree contains debian/source/$f";
3796 return if $ignoredirty;
3798 git_check_unmodified();
3801 sub commit_admin ($) {
3804 runcmd_ordryrun_local @git, qw(commit -m), $m;
3807 sub quiltify_nofix_bail ($$) {
3808 my ($headinfo, $xinfo) = @_;
3809 if ($quilt_mode eq 'nofix') {
3810 fail "quilt fixup required but quilt mode is \`nofix'\n".
3811 "HEAD commit".$headinfo." differs from tree implied by ".
3812 " debian/patches".$xinfo;
3816 sub commit_quilty_patch () {
3817 my $output = cmdoutput @git, qw(status --porcelain);
3819 foreach my $l (split /\n/, $output) {
3820 next unless $l =~ m/\S/;
3821 if ($l =~ m{^(?:\?\?| [MADRC]) (.pc|debian/patches)}) {
3825 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3827 progress "nothing quilty to commit, ok.";
3830 quiltify_nofix_bail "", " (wanted to commit patch update)";
3831 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3832 runcmd_ordryrun_local @git, qw(add -f), @adds;
3834 Commit Debian 3.0 (quilt) metadata
3836 [dgit ($our_version) quilt-fixup]
3840 sub get_source_format () {
3842 if (open F, "debian/source/options") {
3846 s/\s+$//; # ignore missing final newline
3848 my ($k, $v) = ($`, $'); #');
3849 $v =~ s/^"(.*)"$/$1/;
3855 F->error and die $!;
3858 die $! unless $!==&ENOENT;
3861 if (!open F, "debian/source/format") {
3862 die $! unless $!==&ENOENT;
3866 F->error and die $!;
3868 return ($_, \%options);
3871 sub madformat_wantfixup ($) {
3873 return 0 unless $format eq '3.0 (quilt)';
3874 our $quilt_mode_warned;
3875 if ($quilt_mode eq 'nocheck') {
3876 progress "Not doing any fixup of \`$format' due to".
3877 " ----no-quilt-fixup or --quilt=nocheck"
3878 unless $quilt_mode_warned++;
3881 progress "Format \`$format', need to check/update patch stack"
3882 unless $quilt_mode_warned++;
3886 sub maybe_split_brain_save ($$$) {
3887 my ($headref, $dgitview, $msg) = @_;
3888 # => message fragment "$saved" describing disposition of $dgitview
3889 return "commit id $dgitview" unless defined $split_brain_save;
3890 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3892 "dgit --dgit-view-save $msg HEAD=$headref",
3893 $split_brain_save, $dgitview);
3895 return "and left in $split_brain_save";
3898 # An "infopair" is a tuple [ $thing, $what ]
3899 # (often $thing is a commit hash; $what is a description)
3901 sub infopair_cond_equal ($$) {
3903 $x->[0] eq $y->[0] or fail <<END;
3904 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3908 sub infopair_lrf_tag_lookup ($$) {
3909 my ($tagnames, $what) = @_;
3910 # $tagname may be an array ref
3911 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3912 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3913 foreach my $tagname (@tagnames) {
3914 my $lrefname = lrfetchrefs."/tags/$tagname";
3915 my $tagobj = $lrfetchrefs_f{$lrefname};
3916 next unless defined $tagobj;
3917 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3918 return [ git_rev_parse($tagobj), $what ];
3920 fail @tagnames==1 ? <<END : <<END;
3921 Wanted tag $what (@tagnames) on dgit server, but not found
3923 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3927 sub infopair_cond_ff ($$) {
3928 my ($anc,$desc) = @_;
3929 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3930 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3934 sub pseudomerge_version_check ($$) {
3935 my ($clogp, $archive_hash) = @_;
3937 my $arch_clogp = commit_getclogp $archive_hash;
3938 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3939 'version currently in archive' ];
3940 if (defined $overwrite_version) {
3941 if (length $overwrite_version) {
3942 infopair_cond_equal([ $overwrite_version,
3943 '--overwrite= version' ],
3946 my $v = $i_arch_v->[0];
3947 progress "Checking package changelog for archive version $v ...";
3950 my @xa = ("-f$v", "-t$v");
3951 my $vclogp = parsechangelog @xa;
3954 [ (getfield $vclogp, $fn),
3955 "$fn field from dpkg-parsechangelog @xa" ];
3957 my $cv = $gf->('Version');
3958 infopair_cond_equal($i_arch_v, $cv);
3959 $cd = $gf->('Distribution');
3962 $@ =~ s/^dgit: //gm;
3964 "Perhaps debian/changelog does not mention $v ?";
3966 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3967 $cd->[1] is $cd->[0]
3968 Your tree seems to based on earlier (not uploaded) $v.
3973 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3977 sub pseudomerge_make_commit ($$$$ $$) {
3978 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3979 $msg_cmd, $msg_msg) = @_;
3980 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3982 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3983 my $authline = clogp_authline $clogp;
3987 !defined $overwrite_version ? ""
3988 : !length $overwrite_version ? " --overwrite"
3989 : " --overwrite=".$overwrite_version;
3991 # Contributing parent is the first parent - that makes
3992 # git rev-list --first-parent DTRT.
3993 my $pmf = dgit_privdir()."/pseudomerge";
3994 open MC, ">", $pmf or die "$pmf $!";
3995 print MC <<END or die $!;
3998 parent $archive_hash
4008 return make_commit($pmf);
4011 sub splitbrain_pseudomerge ($$$$) {
4012 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4013 # => $merged_dgitview
4014 printdebug "splitbrain_pseudomerge...\n";
4016 # We: debian/PREVIOUS HEAD($maintview)
4017 # expect: o ----------------- o
4020 # a/d/PREVIOUS $dgitview
4023 # we do: `------------------ o
4027 return $dgitview unless defined $archive_hash;
4028 return $dgitview if deliberately_not_fast_forward();
4030 printdebug "splitbrain_pseudomerge...\n";
4032 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4034 if (!defined $overwrite_version) {
4035 progress "Checking that HEAD inciudes all changes in archive...";
4038 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4040 if (defined $overwrite_version) {
4042 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4043 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
4044 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4045 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
4046 my $i_archive = [ $archive_hash, "current archive contents" ];
4048 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4050 infopair_cond_equal($i_dgit, $i_archive);
4051 infopair_cond_ff($i_dep14, $i_dgit);
4052 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4055 $@ =~ s/^\n//; chomp $@;
4058 | Not fast forward; maybe --overwrite is needed, see dgit(1)
4063 my $r = pseudomerge_make_commit
4064 $clogp, $dgitview, $archive_hash, $i_arch_v,
4065 "dgit --quilt=$quilt_mode",
4066 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4067 Declare fast forward from $i_arch_v->[0]
4069 Make fast forward from $i_arch_v->[0]
4072 maybe_split_brain_save $maintview, $r, "pseudomerge";
4074 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4078 sub plain_overwrite_pseudomerge ($$$) {
4079 my ($clogp, $head, $archive_hash) = @_;
4081 printdebug "plain_overwrite_pseudomerge...";
4083 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4085 return $head if is_fast_fwd $archive_hash, $head;
4087 my $m = "Declare fast forward from $i_arch_v->[0]";
4089 my $r = pseudomerge_make_commit
4090 $clogp, $head, $archive_hash, $i_arch_v,
4093 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4095 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4099 sub push_parse_changelog ($) {
4102 my $clogp = Dpkg::Control::Hash->new();
4103 $clogp->load($clogpfn) or die;
4105 my $clogpackage = getfield $clogp, 'Source';
4106 $package //= $clogpackage;
4107 fail "-p specified $package but changelog specified $clogpackage"
4108 unless $package eq $clogpackage;
4109 my $cversion = getfield $clogp, 'Version';
4111 if (!$we_are_initiator) {
4112 # rpush initiator can't do this because it doesn't have $isuite yet
4113 my $tag = debiantag($cversion, access_nomdistro);
4114 runcmd @git, qw(check-ref-format), $tag;
4117 my $dscfn = dscfn($cversion);
4119 return ($clogp, $cversion, $dscfn);
4122 sub push_parse_dsc ($$$) {
4123 my ($dscfn,$dscfnwhat, $cversion) = @_;
4124 $dsc = parsecontrol($dscfn,$dscfnwhat);
4125 my $dversion = getfield $dsc, 'Version';
4126 my $dscpackage = getfield $dsc, 'Source';
4127 ($dscpackage eq $package && $dversion eq $cversion) or
4128 fail "$dscfn is for $dscpackage $dversion".
4129 " but debian/changelog is for $package $cversion";
4132 sub push_tagwants ($$$$) {
4133 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4136 TagFn => \&debiantag,
4141 if (defined $maintviewhead) {
4143 TagFn => \&debiantag_maintview,
4144 Objid => $maintviewhead,
4145 TfSuffix => '-maintview',
4148 } elsif ($dodep14tag eq 'no' ? 0
4149 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4150 : $dodep14tag eq 'always'
4151 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4152 --dep14tag-always (or equivalent in config) means server must support
4153 both "new" and "maint" tag formats, but config says it doesn't.
4155 : die "$dodep14tag ?") {
4157 TagFn => \&debiantag_maintview,
4159 TfSuffix => '-dgit',
4163 foreach my $tw (@tagwants) {
4164 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4165 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4167 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4171 sub push_mktags ($$ $$ $) {
4173 $changesfile,$changesfilewhat,
4176 die unless $tagwants->[0]{View} eq 'dgit';
4178 my $declaredistro = access_nomdistro();
4179 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4180 $dsc->{$ourdscfield[0]} = join " ",
4181 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4183 $dsc->save("$dscfn.tmp") or die $!;
4185 my $changes = parsecontrol($changesfile,$changesfilewhat);
4186 foreach my $field (qw(Source Distribution Version)) {
4187 $changes->{$field} eq $clogp->{$field} or
4188 fail "changes field $field \`$changes->{$field}'".
4189 " does not match changelog \`$clogp->{$field}'";
4192 my $cversion = getfield $clogp, 'Version';
4193 my $clogsuite = getfield $clogp, 'Distribution';
4195 # We make the git tag by hand because (a) that makes it easier
4196 # to control the "tagger" (b) we can do remote signing
4197 my $authline = clogp_authline $clogp;
4198 my $delibs = join(" ", "",@deliberatelies);
4202 my $tfn = $tw->{Tfn};
4203 my $head = $tw->{Objid};
4204 my $tag = $tw->{Tag};
4206 open TO, '>', $tfn->('.tmp') or die $!;
4207 print TO <<END or die $!;
4214 if ($tw->{View} eq 'dgit') {
4215 print TO <<END or die $!;
4216 $package release $cversion for $clogsuite ($csuite) [dgit]
4217 [dgit distro=$declaredistro$delibs]
4219 foreach my $ref (sort keys %previously) {
4220 print TO <<END or die $!;
4221 [dgit previously:$ref=$previously{$ref}]
4224 } elsif ($tw->{View} eq 'maint') {
4225 print TO <<END or die $!;
4226 $package release $cversion for $clogsuite ($csuite)
4227 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4230 die Dumper($tw)."?";
4235 my $tagobjfn = $tfn->('.tmp');
4237 if (!defined $keyid) {
4238 $keyid = access_cfg('keyid','RETURN-UNDEF');
4240 if (!defined $keyid) {
4241 $keyid = getfield $clogp, 'Maintainer';
4243 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4244 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4245 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4246 push @sign_cmd, $tfn->('.tmp');
4247 runcmd_ordryrun @sign_cmd;
4249 $tagobjfn = $tfn->('.signed.tmp');
4250 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4251 $tfn->('.tmp'), $tfn->('.tmp.asc');
4257 my @r = map { $mktag->($_); } @$tagwants;
4261 sub sign_changes ($) {
4262 my ($changesfile) = @_;
4264 my @debsign_cmd = @debsign;
4265 push @debsign_cmd, "-k$keyid" if defined $keyid;
4266 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4267 push @debsign_cmd, $changesfile;
4268 runcmd_ordryrun @debsign_cmd;
4273 printdebug "actually entering push\n";
4275 supplementary_message(<<'END');
4276 Push failed, while checking state of the archive.
4277 You can retry the push, after fixing the problem, if you like.
4279 if (check_for_git()) {
4282 my $archive_hash = fetch_from_archive();
4283 if (!$archive_hash) {
4285 fail "package appears to be new in this suite;".
4286 " if this is intentional, use --new";
4289 supplementary_message(<<'END');
4290 Push failed, while preparing your push.
4291 You can retry the push, after fixing the problem, if you like.
4294 need_tagformat 'new', "quilt mode $quilt_mode"
4295 if quiltmode_splitbrain;
4299 access_giturl(); # check that success is vaguely likely
4300 rpush_handle_protovsn_bothends() if $we_are_initiator;
4303 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4304 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4306 responder_send_file('parsed-changelog', $clogpfn);
4308 my ($clogp, $cversion, $dscfn) =
4309 push_parse_changelog("$clogpfn");
4311 my $dscpath = "$buildproductsdir/$dscfn";
4312 stat_exists $dscpath or
4313 fail "looked for .dsc $dscpath, but $!;".
4314 " maybe you forgot to build";
4316 responder_send_file('dsc', $dscpath);
4318 push_parse_dsc($dscpath, $dscfn, $cversion);
4320 my $format = getfield $dsc, 'Format';
4321 printdebug "format $format\n";
4323 my $symref = git_get_symref();
4324 my $actualhead = git_rev_parse('HEAD');
4326 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4327 runcmd_ordryrun_local @git_debrebase, 'stitch';
4328 $actualhead = git_rev_parse('HEAD');
4331 my $dgithead = $actualhead;
4332 my $maintviewhead = undef;
4334 my $upstreamversion = upstreamversion $clogp->{Version};
4336 if (madformat_wantfixup($format)) {
4337 # user might have not used dgit build, so maybe do this now:
4338 if (quiltmode_splitbrain()) {
4339 changedir $playground;
4340 quilt_make_fake_dsc($upstreamversion);
4342 ($dgithead, $cachekey) =
4343 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4345 "--quilt=$quilt_mode but no cached dgit view:
4346 perhaps HEAD changed since dgit build[-source] ?";
4348 $dgithead = splitbrain_pseudomerge($clogp,
4349 $actualhead, $dgithead,
4351 $maintviewhead = $actualhead;
4353 prep_ud(); # so _only_subdir() works, below
4355 commit_quilty_patch();
4359 if (defined $overwrite_version && !defined $maintviewhead
4361 $dgithead = plain_overwrite_pseudomerge($clogp,
4369 if ($archive_hash) {
4370 if (is_fast_fwd($archive_hash, $dgithead)) {
4372 } elsif (deliberately_not_fast_forward) {
4375 fail "dgit push: HEAD is not a descendant".
4376 " of the archive's version.\n".
4377 "To overwrite the archive's contents,".
4378 " pass --overwrite[=VERSION].\n".
4379 "To rewind history, if permitted by the archive,".
4380 " use --deliberately-not-fast-forward.";
4384 changedir $playground;
4385 progress "checking that $dscfn corresponds to HEAD";
4386 runcmd qw(dpkg-source -x --),
4387 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4388 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4389 check_for_vendor_patches() if madformat($dsc->{format});
4391 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4392 debugcmd "+",@diffcmd;
4394 my $r = system @diffcmd;
4397 my $referent = $split_brain ? $dgithead : 'HEAD';
4398 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4401 my $raw = cmdoutput @git,
4402 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4404 foreach (split /\0/, $raw) {
4405 if (defined $changed) {
4406 push @mode_changes, "$changed: $_\n" if $changed;
4409 } elsif (m/^:0+ 0+ /) {
4411 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4412 $changed = "Mode change from $1 to $2"
4417 if (@mode_changes) {
4418 fail <<END.(join '', @mode_changes).<<END;
4419 HEAD specifies a different tree to $dscfn:
4422 There is a problem with your source tree (see dgit(7) for some hints).
4423 To see a full diff, run git diff $tree $referent
4428 HEAD specifies a different tree to $dscfn:
4430 Perhaps you forgot to build. Or perhaps there is a problem with your
4431 source tree (see dgit(7) for some hints). To see a full diff, run
4432 git diff $tree $referent
4438 if (!$changesfile) {
4439 my $pat = changespat $cversion;
4440 my @cs = glob "$buildproductsdir/$pat";
4441 fail "failed to find unique changes file".
4442 " (looked for $pat in $buildproductsdir);".
4443 " perhaps you need to use dgit -C"
4445 ($changesfile) = @cs;
4447 $changesfile = "$buildproductsdir/$changesfile";
4450 # Check that changes and .dsc agree enough
4451 $changesfile =~ m{[^/]*$};
4452 my $changes = parsecontrol($changesfile,$&);
4453 files_compare_inputs($dsc, $changes)
4454 unless forceing [qw(dsc-changes-mismatch)];
4456 # Check whether this is a source only upload
4457 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4458 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4459 if ($sourceonlypolicy eq 'ok') {
4460 } elsif ($sourceonlypolicy eq 'always') {
4461 forceable_fail [qw(uploading-binaries)],
4462 "uploading binaries, although distroy policy is source only"
4464 } elsif ($sourceonlypolicy eq 'never') {
4465 forceable_fail [qw(uploading-source-only)],
4466 "source-only upload, although distroy policy requires .debs"
4468 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4469 forceable_fail [qw(uploading-source-only)],
4470 "source-only upload, even though package is entirely NEW\n".
4471 "(this is contrary to policy in ".(access_nomdistro()).")"
4474 && !archive_query('package_not_wholly_new', $package);
4476 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4479 # Perhaps adjust .dsc to contain right set of origs
4480 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4482 unless forceing [qw(changes-origs-exactly)];
4484 # Checks complete, we're going to try and go ahead:
4486 responder_send_file('changes',$changesfile);
4487 responder_send_command("param head $dgithead");
4488 responder_send_command("param csuite $csuite");
4489 responder_send_command("param isuite $isuite");
4490 responder_send_command("param tagformat $tagformat");
4491 if (defined $maintviewhead) {
4492 die unless ($protovsn//4) >= 4;
4493 responder_send_command("param maint-view $maintviewhead");
4496 # Perhaps send buildinfo(s) for signing
4497 my $changes_files = getfield $changes, 'Files';
4498 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4499 foreach my $bi (@buildinfos) {
4500 responder_send_command("param buildinfo-filename $bi");
4501 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4504 if (deliberately_not_fast_forward) {
4505 git_for_each_ref(lrfetchrefs, sub {
4506 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4507 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4508 responder_send_command("previously $rrefname=$objid");
4509 $previously{$rrefname} = $objid;
4513 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4514 dgit_privdir()."/tag");
4517 supplementary_message(<<'END');
4518 Push failed, while signing the tag.
4519 You can retry the push, after fixing the problem, if you like.
4521 # If we manage to sign but fail to record it anywhere, it's fine.
4522 if ($we_are_responder) {
4523 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4524 responder_receive_files('signed-tag', @tagobjfns);
4526 @tagobjfns = push_mktags($clogp,$dscpath,
4527 $changesfile,$changesfile,
4530 supplementary_message(<<'END');
4531 Push failed, *after* signing the tag.
4532 If you want to try again, you should use a new version number.
4535 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4537 foreach my $tw (@tagwants) {
4538 my $tag = $tw->{Tag};
4539 my $tagobjfn = $tw->{TagObjFn};
4541 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4542 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4543 runcmd_ordryrun_local
4544 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4547 supplementary_message(<<'END');
4548 Push failed, while updating the remote git repository - see messages above.
4549 If you want to try again, you should use a new version number.
4551 if (!check_for_git()) {
4552 create_remote_git_repo();
4555 my @pushrefs = $forceflag.$dgithead.":".rrref();
4556 foreach my $tw (@tagwants) {
4557 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4560 runcmd_ordryrun @git,
4561 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4562 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4564 supplementary_message(<<'END');
4565 Push failed, while obtaining signatures on the .changes and .dsc.
4566 If it was just that the signature failed, you may try again by using
4567 debsign by hand to sign the changes
4569 and then dput to complete the upload.
4570 If you need to change the package, you must use a new version number.
4572 if ($we_are_responder) {
4573 my $dryrunsuffix = act_local() ? "" : ".tmp";
4574 my @rfiles = ($dscpath, $changesfile);
4575 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4576 responder_receive_files('signed-dsc-changes',
4577 map { "$_$dryrunsuffix" } @rfiles);
4580 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4582 progress "[new .dsc left in $dscpath.tmp]";
4584 sign_changes $changesfile;
4587 supplementary_message(<<END);
4588 Push failed, while uploading package(s) to the archive server.
4589 You can retry the upload of exactly these same files with dput of:
4591 If that .changes file is broken, you will need to use a new version
4592 number for your next attempt at the upload.
4594 my $host = access_cfg('upload-host','RETURN-UNDEF');
4595 my @hostarg = defined($host) ? ($host,) : ();
4596 runcmd_ordryrun @dput, @hostarg, $changesfile;
4597 printdone "pushed and uploaded $cversion";
4599 supplementary_message('');
4600 responder_send_command("complete");
4604 not_necessarily_a_tree();
4609 badusage "-p is not allowed with clone; specify as argument instead"
4610 if defined $package;
4613 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4614 ($package,$isuite) = @ARGV;
4615 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4616 ($package,$dstdir) = @ARGV;
4617 } elsif (@ARGV==3) {
4618 ($package,$isuite,$dstdir) = @ARGV;
4620 badusage "incorrect arguments to dgit clone";
4624 $dstdir ||= "$package";
4625 if (stat_exists $dstdir) {
4626 fail "$dstdir already exists";
4630 if ($rmonerror && !$dryrun_level) {
4631 $cwd_remove= getcwd();
4633 return unless defined $cwd_remove;
4634 if (!chdir "$cwd_remove") {
4635 return if $!==&ENOENT;
4636 die "chdir $cwd_remove: $!";
4638 printdebug "clone rmonerror removing $dstdir\n";
4640 rmtree($dstdir) or die "remove $dstdir: $!\n";
4641 } elsif (grep { $! == $_ }
4642 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4644 print STDERR "check whether to remove $dstdir: $!\n";
4650 $cwd_remove = undef;
4653 sub branchsuite () {
4654 my $branch = git_get_symref();
4655 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4662 sub package_from_d_control () {
4663 if (!defined $package) {
4664 my $sourcep = parsecontrol('debian/control','debian/control');
4665 $package = getfield $sourcep, 'Source';
4669 sub fetchpullargs () {
4670 package_from_d_control();
4672 $isuite = branchsuite();
4674 my $clogp = parsechangelog();
4675 my $clogsuite = getfield $clogp, 'Distribution';
4676 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4678 } elsif (@ARGV==1) {
4681 badusage "incorrect arguments to dgit fetch or dgit pull";
4695 if (quiltmode_splitbrain()) {
4696 my ($format, $fopts) = get_source_format();
4697 madformat($format) and fail <<END
4698 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4706 package_from_d_control();
4707 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4711 foreach my $canon (qw(0 1)) {
4716 canonicalise_suite();
4718 if (length git_get_ref lref()) {
4719 # local branch already exists, yay
4722 if (!length git_get_ref lrref()) {
4730 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4733 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4734 "dgit checkout $isuite";
4735 runcmd (@git, qw(checkout), lref());
4738 sub cmd_update_vcs_git () {
4740 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4741 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4743 ($specsuite) = (@ARGV);
4748 if ($ARGV[0] eq '-') {
4750 } elsif ($ARGV[0] eq '-') {
4755 package_from_d_control();
4757 if ($specsuite eq '.') {
4758 $ctrl = parsecontrol 'debian/control', 'debian/control';
4760 $isuite = $specsuite;
4764 my $url = getfield $ctrl, 'Vcs-Git';
4767 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4768 if (!defined $orgurl) {
4769 print STDERR "setting up vcs-git: $url\n";
4770 @cmd = (@git, qw(remote add vcs-git), $url);
4771 } elsif ($orgurl eq $url) {
4772 print STDERR "vcs git already configured: $url\n";
4774 print STDERR "changing vcs-git url to: $url\n";
4775 @cmd = (@git, qw(remote set-url vcs-git), $url);
4777 runcmd_ordryrun_local @cmd;
4779 print "fetching (@ARGV)\n";
4780 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4786 build_or_push_prep_early();
4791 } elsif (@ARGV==1) {
4792 ($specsuite) = (@ARGV);
4794 badusage "incorrect arguments to dgit $subcommand";
4797 local ($package) = $existing_package; # this is a hack
4798 canonicalise_suite();
4800 canonicalise_suite();
4802 if (defined $specsuite &&
4803 $specsuite ne $isuite &&
4804 $specsuite ne $csuite) {
4805 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4806 " but command line specifies $specsuite";
4815 sub cmd_push_source {
4818 my $changes = parsecontrol("$buildproductsdir/$changesfile",
4819 "source changes file");
4820 unless (test_source_only_changes($changes)) {
4821 fail "user-specified changes file is not source-only";
4824 # Building a source package is very fast, so just do it
4825 build_source_for_push();
4830 #---------- remote commands' implementation ----------
4832 sub pre_remote_push_build_host {
4833 my ($nrargs) = shift @ARGV;
4834 my (@rargs) = @ARGV[0..$nrargs-1];
4835 @ARGV = @ARGV[$nrargs..$#ARGV];
4837 my ($dir,$vsnwant) = @rargs;
4838 # vsnwant is a comma-separated list; we report which we have
4839 # chosen in our ready response (so other end can tell if they
4842 $we_are_responder = 1;
4843 $us .= " (build host)";
4845 open PI, "<&STDIN" or die $!;
4846 open STDIN, "/dev/null" or die $!;
4847 open PO, ">&STDOUT" or die $!;
4849 open STDOUT, ">&STDERR" or die $!;
4853 ($protovsn) = grep {
4854 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4855 } @rpushprotovsn_support;
4857 fail "build host has dgit rpush protocol versions ".
4858 (join ",", @rpushprotovsn_support).
4859 " but invocation host has $vsnwant"
4860 unless defined $protovsn;
4864 sub cmd_remote_push_build_host {
4865 responder_send_command("dgit-remote-push-ready $protovsn");
4869 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4870 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4871 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4872 # a good error message)
4874 sub rpush_handle_protovsn_bothends () {
4875 if ($protovsn < 4) {
4876 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4885 my $report = i_child_report();
4886 if (defined $report) {
4887 printdebug "($report)\n";
4888 } elsif ($i_child_pid) {
4889 printdebug "(killing build host child $i_child_pid)\n";
4890 kill 15, $i_child_pid;
4892 if (defined $i_tmp && !defined $initiator_tempdir) {
4894 eval { rmtree $i_tmp; };
4899 return unless forkcheck_mainprocess();
4904 my ($base,$selector,@args) = @_;
4905 $selector =~ s/\-/_/g;
4906 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4910 not_necessarily_a_tree();
4915 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4923 push @rargs, join ",", @rpushprotovsn_support;
4926 push @rdgit, @ropts;
4927 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4929 my @cmd = (@ssh, $host, shellquote @rdgit);
4932 $we_are_initiator=1;
4934 if (defined $initiator_tempdir) {
4935 rmtree $initiator_tempdir;
4936 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4937 $i_tmp = $initiator_tempdir;
4941 $i_child_pid = open2(\*RO, \*RI, @cmd);
4943 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4944 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4945 $supplementary_message = '' unless $protovsn >= 3;
4948 my ($icmd,$iargs) = initiator_expect {
4949 m/^(\S+)(?: (.*))?$/;
4952 i_method "i_resp", $icmd, $iargs;
4956 sub i_resp_progress ($) {
4958 my $msg = protocol_read_bytes \*RO, $rhs;
4962 sub i_resp_supplementary_message ($) {
4964 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4967 sub i_resp_complete {
4968 my $pid = $i_child_pid;
4969 $i_child_pid = undef; # prevents killing some other process with same pid
4970 printdebug "waiting for build host child $pid...\n";
4971 my $got = waitpid $pid, 0;
4972 die $! unless $got == $pid;
4973 die "build host child failed $?" if $?;
4976 printdebug "all done\n";
4980 sub i_resp_file ($) {
4982 my $localname = i_method "i_localname", $keyword;
4983 my $localpath = "$i_tmp/$localname";
4984 stat_exists $localpath and
4985 badproto \*RO, "file $keyword ($localpath) twice";
4986 protocol_receive_file \*RO, $localpath;
4987 i_method "i_file", $keyword;
4992 sub i_resp_param ($) {
4993 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4997 sub i_resp_previously ($) {
4998 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4999 or badproto \*RO, "bad previously spec";
5000 my $r = system qw(git check-ref-format), $1;
5001 die "bad previously ref spec ($r)" if $r;
5002 $previously{$1} = $2;
5007 sub i_resp_want ($) {
5009 die "$keyword ?" if $i_wanted{$keyword}++;
5011 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5012 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5013 die unless $isuite =~ m/^$suite_re$/;
5016 rpush_handle_protovsn_bothends();
5018 fail "rpush negotiated protocol version $protovsn".
5019 " which does not support quilt mode $quilt_mode"
5020 if quiltmode_splitbrain;
5022 my @localpaths = i_method "i_want", $keyword;
5023 printdebug "[[ $keyword @localpaths\n";
5024 foreach my $localpath (@localpaths) {
5025 protocol_send_file \*RI, $localpath;
5027 print RI "files-end\n" or die $!;
5030 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5032 sub i_localname_parsed_changelog {
5033 return "remote-changelog.822";
5035 sub i_file_parsed_changelog {
5036 ($i_clogp, $i_version, $i_dscfn) =
5037 push_parse_changelog "$i_tmp/remote-changelog.822";
5038 die if $i_dscfn =~ m#/|^\W#;
5041 sub i_localname_dsc {
5042 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5047 sub i_localname_buildinfo ($) {
5048 my $bi = $i_param{'buildinfo-filename'};
5049 defined $bi or badproto \*RO, "buildinfo before filename";
5050 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5051 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5052 or badproto \*RO, "improper buildinfo filename";
5055 sub i_file_buildinfo {
5056 my $bi = $i_param{'buildinfo-filename'};
5057 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5058 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5059 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5060 files_compare_inputs($bd, $ch);
5061 (getfield $bd, $_) eq (getfield $ch, $_) or
5062 fail "buildinfo mismatch $_"
5063 foreach qw(Source Version);
5064 !defined $bd->{$_} or
5065 fail "buildinfo contains $_"
5066 foreach qw(Changes Changed-by Distribution);
5068 push @i_buildinfos, $bi;
5069 delete $i_param{'buildinfo-filename'};
5072 sub i_localname_changes {
5073 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5074 $i_changesfn = $i_dscfn;
5075 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5076 return $i_changesfn;
5078 sub i_file_changes { }
5080 sub i_want_signed_tag {
5081 printdebug Dumper(\%i_param, $i_dscfn);
5082 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5083 && defined $i_param{'csuite'}
5084 or badproto \*RO, "premature desire for signed-tag";
5085 my $head = $i_param{'head'};
5086 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5088 my $maintview = $i_param{'maint-view'};
5089 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5092 if ($protovsn >= 4) {
5093 my $p = $i_param{'tagformat'} // '<undef>';
5095 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5098 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5100 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5102 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5105 push_mktags $i_clogp, $i_dscfn,
5106 $i_changesfn, 'remote changes',
5110 sub i_want_signed_dsc_changes {
5111 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5112 sign_changes $i_changesfn;
5113 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5116 #---------- building etc. ----------
5122 #----- `3.0 (quilt)' handling -----
5124 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5126 sub quiltify_dpkg_commit ($$$;$) {
5127 my ($patchname,$author,$msg, $xinfo) = @_;
5130 mkpath '.git/dgit'; # we are in playtree
5131 my $descfn = ".git/dgit/quilt-description.tmp";
5132 open O, '>', $descfn or die "$descfn: $!";
5133 $msg =~ s/\n+/\n\n/;
5134 print O <<END or die $!;
5136 ${xinfo}Subject: $msg
5143 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5144 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5145 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5146 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5150 sub quiltify_trees_differ ($$;$$$) {
5151 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5152 # returns true iff the two tree objects differ other than in debian/
5153 # with $finegrained,
5154 # returns bitmask 01 - differ in upstream files except .gitignore
5155 # 02 - differ in .gitignore
5156 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5157 # is set for each modified .gitignore filename $fn
5158 # if $unrepres is defined, array ref to which is appeneded
5159 # a list of unrepresentable changes (removals of upstream files
5162 my @cmd = (@git, qw(diff-tree -z --no-renames));
5163 push @cmd, qw(--name-only) unless $unrepres;
5164 push @cmd, qw(-r) if $finegrained || $unrepres;
5166 my $diffs= cmdoutput @cmd;
5169 foreach my $f (split /\0/, $diffs) {
5170 if ($unrepres && !@lmodes) {
5171 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5174 my ($oldmode,$newmode) = @lmodes;
5177 next if $f =~ m#^debian(?:/.*)?$#s;
5181 die "not a plain file or symlink\n"
5182 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5183 $oldmode =~ m/^(?:10|12)\d{4}$/;
5184 if ($oldmode =~ m/[^0]/ &&
5185 $newmode =~ m/[^0]/) {
5186 # both old and new files exist
5187 die "mode or type changed\n" if $oldmode ne $newmode;
5188 die "modified symlink\n" unless $newmode =~ m/^10/;
5189 } elsif ($oldmode =~ m/[^0]/) {
5191 die "deletion of symlink\n"
5192 unless $oldmode =~ m/^10/;
5195 die "creation with non-default mode\n"
5196 unless $newmode =~ m/^100644$/ or
5197 $newmode =~ m/^120000$/;
5201 local $/="\n"; chomp $@;
5202 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5206 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5207 $r |= $isignore ? 02 : 01;
5208 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5210 printdebug "quiltify_trees_differ $x $y => $r\n";
5214 sub quiltify_tree_sentinelfiles ($) {
5215 # lists the `sentinel' files present in the tree
5217 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5218 qw(-- debian/rules debian/control);
5223 sub quiltify_splitbrain_needed () {
5224 if (!$split_brain) {
5225 progress "dgit view: changes are required...";
5226 runcmd @git, qw(checkout -q -b dgit-view);
5231 sub quiltify_splitbrain ($$$$$$$) {
5232 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5233 $editedignores, $cachekey) = @_;
5234 my $gitignore_special = 1;
5235 if ($quilt_mode !~ m/gbp|dpm/) {
5236 # treat .gitignore just like any other upstream file
5237 $diffbits = { %$diffbits };
5238 $_ = !!$_ foreach values %$diffbits;
5239 $gitignore_special = 0;
5241 # We would like any commits we generate to be reproducible
5242 my @authline = clogp_authline($clogp);
5243 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5244 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5245 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5246 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5247 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5248 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5250 my $fulldiffhint = sub {
5252 my $cmd = "git diff $x $y -- :/ ':!debian'";
5253 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5254 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5257 if ($quilt_mode =~ m/gbp|unapplied/ &&
5258 ($diffbits->{O2H} & 01)) {
5260 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5261 " but git tree differs from orig in upstream files.";
5262 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5263 if (!stat_exists "debian/patches") {
5265 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5269 if ($quilt_mode =~ m/dpm/ &&
5270 ($diffbits->{H2A} & 01)) {
5271 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5272 --quilt=$quilt_mode specified, implying patches-applied git tree
5273 but git tree differs from result of applying debian/patches to upstream
5276 if ($quilt_mode =~ m/gbp|unapplied/ &&
5277 ($diffbits->{O2A} & 01)) { # some patches
5278 quiltify_splitbrain_needed();
5279 progress "dgit view: creating patches-applied version using gbp pq";
5280 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5281 # gbp pq import creates a fresh branch; push back to dgit-view
5282 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5283 runcmd @git, qw(checkout -q dgit-view);
5285 if ($quilt_mode =~ m/gbp|dpm/ &&
5286 ($diffbits->{O2A} & 02)) {
5288 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5289 tool which does not create patches for changes to upstream
5290 .gitignores: but, such patches exist in debian/patches.
5293 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5294 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5295 quiltify_splitbrain_needed();
5296 progress "dgit view: creating patch to represent .gitignore changes";
5297 ensuredir "debian/patches";
5298 my $gipatch = "debian/patches/auto-gitignore";
5299 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5300 stat GIPATCH or die "$gipatch: $!";
5301 fail "$gipatch already exists; but want to create it".
5302 " to record .gitignore changes" if (stat _)[7];
5303 print GIPATCH <<END or die "$gipatch: $!";
5304 Subject: Update .gitignore from Debian packaging branch
5306 The Debian packaging git branch contains these updates to the upstream
5307 .gitignore file(s). This patch is autogenerated, to provide these
5308 updates to users of the official Debian archive view of the package.
5310 [dgit ($our_version) update-gitignore]
5313 close GIPATCH or die "$gipatch: $!";
5314 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5315 $unapplied, $headref, "--", sort keys %$editedignores;
5316 open SERIES, "+>>", "debian/patches/series" or die $!;
5317 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5319 defined read SERIES, $newline, 1 or die $!;
5320 print SERIES "\n" or die $! unless $newline eq "\n";
5321 print SERIES "auto-gitignore\n" or die $!;
5322 close SERIES or die $!;
5323 runcmd @git, qw(add -- debian/patches/series), $gipatch;
5325 Commit patch to update .gitignore
5327 [dgit ($our_version) update-gitignore-quilt-fixup]
5331 my $dgitview = git_rev_parse 'HEAD';
5334 # When we no longer need to support squeeze, use --create-reflog
5336 ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5337 my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5340 my $oldcache = git_get_ref "refs/$splitbraincache";
5341 if ($oldcache eq $dgitview) {
5342 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5343 # git update-ref doesn't always update, in this case. *sigh*
5344 my $dummy = make_commit_text <<END;
5347 author Dgit <dgit\@example.com> 1000000000 +0000
5348 committer Dgit <dgit\@example.com> 1000000000 +0000
5350 Dummy commit - do not use
5352 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5353 "refs/$splitbraincache", $dummy;
5355 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5358 changedir "$playground/work";
5360 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5361 progress "dgit view: created ($saved)";
5364 sub quiltify ($$$$) {
5365 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5367 # Quilt patchification algorithm
5369 # We search backwards through the history of the main tree's HEAD
5370 # (T) looking for a start commit S whose tree object is identical
5371 # to to the patch tip tree (ie the tree corresponding to the
5372 # current dpkg-committed patch series). For these purposes
5373 # `identical' disregards anything in debian/ - this wrinkle is
5374 # necessary because dpkg-source treates debian/ specially.
5376 # We can only traverse edges where at most one of the ancestors'
5377 # trees differs (in changes outside in debian/). And we cannot
5378 # handle edges which change .pc/ or debian/patches. To avoid
5379 # going down a rathole we avoid traversing edges which introduce
5380 # debian/rules or debian/control. And we set a limit on the
5381 # number of edges we are willing to look at.
5383 # If we succeed, we walk forwards again. For each traversed edge
5384 # PC (with P parent, C child) (starting with P=S and ending with
5385 # C=T) to we do this:
5387 # - dpkg-source --commit with a patch name and message derived from C
5388 # After traversing PT, we git commit the changes which
5389 # should be contained within debian/patches.
5391 # The search for the path S..T is breadth-first. We maintain a
5392 # todo list containing search nodes. A search node identifies a
5393 # commit, and looks something like this:
5395 # Commit => $git_commit_id,
5396 # Child => $c, # or undef if P=T
5397 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5398 # Nontrivial => true iff $p..$c has relevant changes
5405 my %considered; # saves being exponential on some weird graphs
5407 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5410 my ($search,$whynot) = @_;
5411 printdebug " search NOT $search->{Commit} $whynot\n";
5412 $search->{Whynot} = $whynot;
5413 push @nots, $search;
5414 no warnings qw(exiting);
5423 my $c = shift @todo;
5424 next if $considered{$c->{Commit}}++;
5426 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5428 printdebug "quiltify investigate $c->{Commit}\n";
5431 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5432 printdebug " search finished hooray!\n";
5437 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5438 if ($quilt_mode eq 'smash') {
5439 printdebug " search quitting smash\n";
5443 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5444 $not->($c, "has $c_sentinels not $t_sentinels")
5445 if $c_sentinels ne $t_sentinels;
5447 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5448 $commitdata =~ m/\n\n/;
5450 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5451 @parents = map { { Commit => $_, Child => $c } } @parents;
5453 $not->($c, "root commit") if !@parents;
5455 foreach my $p (@parents) {
5456 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5458 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5459 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5461 foreach my $p (@parents) {
5462 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5464 my @cmd= (@git, qw(diff-tree -r --name-only),
5465 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5466 my $patchstackchange = cmdoutput @cmd;
5467 if (length $patchstackchange) {
5468 $patchstackchange =~ s/\n/,/g;
5469 $not->($p, "changed $patchstackchange");
5472 printdebug " search queue P=$p->{Commit} ",
5473 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5479 printdebug "quiltify want to smash\n";
5482 my $x = $_[0]{Commit};
5483 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5486 my $reportnot = sub {
5488 my $s = $abbrev->($notp);
5489 my $c = $notp->{Child};
5490 $s .= "..".$abbrev->($c) if $c;
5491 $s .= ": ".$notp->{Whynot};
5494 if ($quilt_mode eq 'linear') {
5495 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5496 foreach my $notp (@nots) {
5497 print STDERR "$us: ", $reportnot->($notp), "\n";
5499 print STDERR "$us: $_\n" foreach @$failsuggestion;
5501 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n".
5502 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5503 } elsif ($quilt_mode eq 'smash') {
5504 } elsif ($quilt_mode eq 'auto') {
5505 progress "quilt fixup cannot be linear, smashing...";
5507 die "$quilt_mode ?";
5510 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5511 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5513 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5515 quiltify_dpkg_commit "auto-$version-$target-$time",
5516 (getfield $clogp, 'Maintainer'),
5517 "Automatically generated patch ($clogp->{Version})\n".
5518 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5522 progress "quiltify linearisation planning successful, executing...";
5524 for (my $p = $sref_S;
5525 my $c = $p->{Child};
5527 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5528 next unless $p->{Nontrivial};
5530 my $cc = $c->{Commit};
5532 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5533 $commitdata =~ m/\n\n/ or die "$c ?";
5536 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5539 my $commitdate = cmdoutput
5540 @git, qw(log -n1 --pretty=format:%aD), $cc;
5542 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5544 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5551 my $gbp_check_suitable = sub {
5556 die "contains unexpected slashes\n" if m{//} || m{/$};
5557 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5558 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5559 die "is series file\n" if m{$series_filename_re}o;
5560 die "too long" if length > 200;
5562 return $_ unless $@;
5563 print STDERR "quiltifying commit $cc:".
5564 " ignoring/dropping Gbp-Pq $what: $@";
5568 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5570 (\S+) \s* \n //ixm) {
5571 $patchname = $gbp_check_suitable->($1, 'Name');
5573 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5575 (\S+) \s* \n //ixm) {
5576 $patchdir = $gbp_check_suitable->($1, 'Topic');
5581 if (!defined $patchname) {
5582 $patchname = $title;
5583 $patchname =~ s/[.:]$//;
5586 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5587 my $translitname = $converter->convert($patchname);
5588 die unless defined $translitname;
5589 $patchname = $translitname;
5592 "dgit: patch title transliteration error: $@"
5594 $patchname =~ y/ A-Z/-a-z/;
5595 $patchname =~ y/-a-z0-9_.+=~//cd;
5596 $patchname =~ s/^\W/x-$&/;
5597 $patchname = substr($patchname,0,40);
5598 $patchname .= ".patch";
5600 if (!defined $patchdir) {
5603 if (length $patchdir) {
5604 $patchname = "$patchdir/$patchname";
5606 if ($patchname =~ m{^(.*)/}) {
5607 mkpath "debian/patches/$1";
5612 stat "debian/patches/$patchname$index";
5614 $!==ENOENT or die "$patchname$index $!";
5616 runcmd @git, qw(checkout -q), $cc;
5618 # We use the tip's changelog so that dpkg-source doesn't
5619 # produce complaining messages from dpkg-parsechangelog. None
5620 # of the information dpkg-source gets from the changelog is
5621 # actually relevant - it gets put into the original message
5622 # which dpkg-source provides our stunt editor, and then
5624 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5626 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5627 "Date: $commitdate\n".
5628 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5630 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5633 runcmd @git, qw(checkout -q master);
5636 sub build_maybe_quilt_fixup () {
5637 my ($format,$fopts) = get_source_format;
5638 return unless madformat_wantfixup $format;
5641 check_for_vendor_patches();
5643 if (quiltmode_splitbrain) {
5644 fail <<END unless access_cfg_tagformats_can_splitbrain;
5645 quilt mode $quilt_mode requires split view so server needs to support
5646 both "new" and "maint" tag formats, but config says it doesn't.
5650 my $clogp = parsechangelog();
5651 my $headref = git_rev_parse('HEAD');
5652 my $symref = git_get_symref();
5654 if ($quilt_mode eq 'linear'
5655 && !$fopts->{'single-debian-patch'}
5656 && branch_is_gdr($symref, $headref)) {
5657 # This is much faster. It also makes patches that gdr
5658 # likes better for future updates without laundering.
5660 # However, it can fail in some casses where we would
5661 # succeed: if there are existing patches, which correspond
5662 # to a prefix of the branch, but are not in gbp/gdr
5663 # format, gdr will fail (exiting status 7), but we might
5664 # be able to figure out where to start linearising. That
5665 # will be slower so hopefully there's not much to do.
5666 my @cmd = (@git_debrebase,
5667 qw(--noop-ok -funclean-mixed -funclean-ordering
5668 make-patches --quiet-would-amend));
5669 # We tolerate soe snags that gdr wouldn't, by default.
5673 failedcmd @cmd if system @cmd and $?!=7*256;
5677 $headref = git_rev_parse('HEAD');
5681 changedir $playground;
5683 my $upstreamversion = upstreamversion $version;
5685 if ($fopts->{'single-debian-patch'}) {
5686 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5688 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5691 die 'bug' if $split_brain && !$need_split_build_invocation;
5694 runcmd_ordryrun_local
5695 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5698 sub quilt_fixup_mkwork ($) {
5701 mkdir "work" or die $!;
5703 mktree_in_ud_here();
5704 runcmd @git, qw(reset -q --hard), $headref;
5707 sub quilt_fixup_linkorigs ($$) {
5708 my ($upstreamversion, $fn) = @_;
5709 # calls $fn->($leafname);
5711 foreach my $f (<$maindir/../*>) { #/){
5712 my $b=$f; $b =~ s{.*/}{};
5714 local ($debuglevel) = $debuglevel-1;
5715 printdebug "QF linkorigs $b, $f ?\n";
5717 next unless is_orig_file_of_vsn $b, $upstreamversion;
5718 printdebug "QF linkorigs $b, $f Y\n";
5719 link_ltarget $f, $b or die "$b $!";
5724 sub quilt_fixup_delete_pc () {
5725 runcmd @git, qw(rm -rqf .pc);
5727 Commit removal of .pc (quilt series tracking data)
5729 [dgit ($our_version) upgrade quilt-remove-pc]
5733 sub quilt_fixup_singlepatch ($$$) {
5734 my ($clogp, $headref, $upstreamversion) = @_;
5736 progress "starting quiltify (single-debian-patch)";
5738 # dpkg-source --commit generates new patches even if
5739 # single-debian-patch is in debian/source/options. In order to
5740 # get it to generate debian/patches/debian-changes, it is
5741 # necessary to build the source package.
5743 quilt_fixup_linkorigs($upstreamversion, sub { });
5744 quilt_fixup_mkwork($headref);
5746 rmtree("debian/patches");
5748 runcmd @dpkgsource, qw(-b .);
5750 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5751 rename srcfn("$upstreamversion", "/debian/patches"),
5752 "work/debian/patches";
5755 commit_quilty_patch();
5758 sub quilt_make_fake_dsc ($) {
5759 my ($upstreamversion) = @_;
5761 my $fakeversion="$upstreamversion-~~DGITFAKE";
5763 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5764 print $fakedsc <<END or die $!;
5767 Version: $fakeversion
5771 my $dscaddfile=sub {
5774 my $md = new Digest::MD5;
5776 my $fh = new IO::File $b, '<' or die "$b $!";
5781 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5784 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5786 my @files=qw(debian/source/format debian/rules
5787 debian/control debian/changelog);
5788 foreach my $maybe (qw(debian/patches debian/source/options
5789 debian/tests/control)) {
5790 next unless stat_exists "$maindir/$maybe";
5791 push @files, $maybe;
5794 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5795 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5797 $dscaddfile->($debtar);
5798 close $fakedsc or die $!;
5801 sub quilt_check_splitbrain_cache ($$) {
5802 my ($headref, $upstreamversion) = @_;
5803 # Called only if we are in (potentially) split brain mode.
5804 # Called in playground.
5805 # Computes the cache key and looks in the cache.
5806 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5808 my $splitbrain_cachekey;
5811 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5812 # we look in the reflog of dgit-intern/quilt-cache
5813 # we look for an entry whose message is the key for the cache lookup
5814 my @cachekey = (qw(dgit), $our_version);
5815 push @cachekey, $upstreamversion;
5816 push @cachekey, $quilt_mode;
5817 push @cachekey, $headref;
5819 push @cachekey, hashfile('fake.dsc');
5821 my $srcshash = Digest::SHA->new(256);
5822 my %sfs = ( %INC, '$0(dgit)' => $0 );
5823 foreach my $sfk (sort keys %sfs) {
5824 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5825 $srcshash->add($sfk," ");
5826 $srcshash->add(hashfile($sfs{$sfk}));
5827 $srcshash->add("\n");
5829 push @cachekey, $srcshash->hexdigest();
5830 $splitbrain_cachekey = "@cachekey";
5832 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5834 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5835 debugcmd "|(probably)",@cmd;
5836 my $child = open GC, "-|"; defined $child or die $!;
5838 chdir $maindir or die $!;
5839 if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5840 $! == ENOENT or die $!;
5841 printdebug ">(no reflog)\n";
5848 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5849 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5852 quilt_fixup_mkwork($headref);
5853 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5854 if ($cachehit ne $headref) {
5855 progress "dgit view: found cached ($saved)";
5856 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5858 return ($cachehit, $splitbrain_cachekey);
5860 progress "dgit view: found cached, no changes required";
5861 return ($headref, $splitbrain_cachekey);
5863 die $! if GC->error;
5864 failedcmd unless close GC;
5866 printdebug "splitbrain cache miss\n";
5867 return (undef, $splitbrain_cachekey);
5870 sub quilt_fixup_multipatch ($$$) {
5871 my ($clogp, $headref, $upstreamversion) = @_;
5873 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5876 # - honour any existing .pc in case it has any strangeness
5877 # - determine the git commit corresponding to the tip of
5878 # the patch stack (if there is one)
5879 # - if there is such a git commit, convert each subsequent
5880 # git commit into a quilt patch with dpkg-source --commit
5881 # - otherwise convert all the differences in the tree into
5882 # a single git commit
5886 # Our git tree doesn't necessarily contain .pc. (Some versions of
5887 # dgit would include the .pc in the git tree.) If there isn't
5888 # one, we need to generate one by unpacking the patches that we
5891 # We first look for a .pc in the git tree. If there is one, we
5892 # will use it. (This is not the normal case.)
5894 # Otherwise need to regenerate .pc so that dpkg-source --commit
5895 # can work. We do this as follows:
5896 # 1. Collect all relevant .orig from parent directory
5897 # 2. Generate a debian.tar.gz out of
5898 # debian/{patches,rules,source/format,source/options}
5899 # 3. Generate a fake .dsc containing just these fields:
5900 # Format Source Version Files
5901 # 4. Extract the fake .dsc
5902 # Now the fake .dsc has a .pc directory.
5903 # (In fact we do this in every case, because in future we will
5904 # want to search for a good base commit for generating patches.)
5906 # Then we can actually do the dpkg-source --commit
5907 # 1. Make a new working tree with the same object
5908 # store as our main tree and check out the main
5910 # 2. Copy .pc from the fake's extraction, if necessary
5911 # 3. Run dpkg-source --commit
5912 # 4. If the result has changes to debian/, then
5913 # - git add them them
5914 # - git add .pc if we had a .pc in-tree
5916 # 5. If we had a .pc in-tree, delete it, and git commit
5917 # 6. Back in the main tree, fast forward to the new HEAD
5919 # Another situation we may have to cope with is gbp-style
5920 # patches-unapplied trees.
5922 # We would want to detect these, so we know to escape into
5923 # quilt_fixup_gbp. However, this is in general not possible.
5924 # Consider a package with a one patch which the dgit user reverts
5925 # (with git revert or the moral equivalent).
5927 # That is indistinguishable in contents from a patches-unapplied
5928 # tree. And looking at the history to distinguish them is not
5929 # useful because the user might have made a confusing-looking git
5930 # history structure (which ought to produce an error if dgit can't
5931 # cope, not a silent reintroduction of an unwanted patch).
5933 # So gbp users will have to pass an option. But we can usually
5934 # detect their failure to do so: if the tree is not a clean
5935 # patches-applied tree, quilt linearisation fails, but the tree
5936 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5937 # they want --quilt=unapplied.
5939 # To help detect this, when we are extracting the fake dsc, we
5940 # first extract it with --skip-patches, and then apply the patches
5941 # afterwards with dpkg-source --before-build. That lets us save a
5942 # tree object corresponding to .origs.
5944 my $splitbrain_cachekey;
5946 quilt_make_fake_dsc($upstreamversion);
5948 if (quiltmode_splitbrain()) {
5950 ($cachehit, $splitbrain_cachekey) =
5951 quilt_check_splitbrain_cache($headref, $upstreamversion);
5952 return if $cachehit;
5956 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5958 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5959 rename $fakexdir, "fake" or die "$fakexdir $!";
5963 remove_stray_gits("source package");
5964 mktree_in_ud_here();
5968 rmtree 'debian'; # git checkout commitish paths does not delete!
5969 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5970 my $unapplied=git_add_write_tree();
5971 printdebug "fake orig tree object $unapplied\n";
5975 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5977 if (system @bbcmd) {
5978 failedcmd @bbcmd if $? < 0;
5980 failed to apply your git tree's patch stack (from debian/patches/) to
5981 the corresponding upstream tarball(s). Your source tree and .orig
5982 are probably too inconsistent. dgit can only fix up certain kinds of
5983 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5989 quilt_fixup_mkwork($headref);
5992 if (stat_exists ".pc") {
5994 progress "Tree already contains .pc - will use it then delete it.";
5997 rename '../fake/.pc','.pc' or die $!;
6000 changedir '../fake';
6002 my $oldtiptree=git_add_write_tree();
6003 printdebug "fake o+d/p tree object $unapplied\n";
6004 changedir '../work';
6007 # We calculate some guesswork now about what kind of tree this might
6008 # be. This is mostly for error reporting.
6014 # O = orig, without patches applied
6015 # A = "applied", ie orig with H's debian/patches applied
6016 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6017 \%editedignores, \@unrepres),
6018 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6019 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6023 foreach my $b (qw(01 02)) {
6024 foreach my $v (qw(O2H O2A H2A)) {
6025 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
6028 printdebug "differences \@dl @dl.\n";
6031 "$us: base trees orig=%.20s o+d/p=%.20s",
6032 $unapplied, $oldtiptree;
6034 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6035 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6036 $dl[0], $dl[1], $dl[3], $dl[4],
6040 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
6042 forceable_fail [qw(unrepresentable)], <<END;
6043 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6048 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6049 push @failsuggestion, "This might be a patches-unapplied branch.";
6050 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6051 push @failsuggestion, "This might be a patches-applied branch.";
6053 push @failsuggestion, "Maybe you need to specify one of".
6054 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
6056 if (quiltmode_splitbrain()) {
6057 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6058 $diffbits, \%editedignores,
6059 $splitbrain_cachekey);
6063 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6064 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6066 if (!open P, '>>', ".pc/applied-patches") {
6067 $!==&ENOENT or die $!;
6072 commit_quilty_patch();
6074 if ($mustdeletepc) {
6075 quilt_fixup_delete_pc();
6079 sub quilt_fixup_editor () {
6080 my $descfn = $ENV{$fakeeditorenv};
6081 my $editing = $ARGV[$#ARGV];
6082 open I1, '<', $descfn or die "$descfn: $!";
6083 open I2, '<', $editing or die "$editing: $!";
6084 unlink $editing or die "$editing: $!";
6085 open O, '>', $editing or die "$editing: $!";
6086 while (<I1>) { print O or die $!; } I1->error and die $!;
6089 $copying ||= m/^\-\-\- /;
6090 next unless $copying;
6093 I2->error and die $!;
6098 sub maybe_apply_patches_dirtily () {
6099 return unless $quilt_mode =~ m/gbp|unapplied/;
6100 print STDERR <<END or die $!;
6102 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6103 dgit: Have to apply the patches - making the tree dirty.
6104 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6107 $patches_applied_dirtily = 01;
6108 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6109 runcmd qw(dpkg-source --before-build .);
6112 sub maybe_unapply_patches_again () {
6113 progress "dgit: Unapplying patches again to tidy up the tree."
6114 if $patches_applied_dirtily;
6115 runcmd qw(dpkg-source --after-build .)
6116 if $patches_applied_dirtily & 01;
6118 if $patches_applied_dirtily & 02;
6119 $patches_applied_dirtily = 0;
6122 #----- other building -----
6124 our $clean_using_builder;
6125 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6126 # clean the tree before building (perhaps invoked indirectly by
6127 # whatever we are using to run the build), rather than separately
6128 # and explicitly by us.
6131 return if $clean_using_builder;
6132 if ($cleanmode eq 'dpkg-source') {
6133 maybe_apply_patches_dirtily();
6134 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6135 } elsif ($cleanmode eq 'dpkg-source-d') {
6136 maybe_apply_patches_dirtily();
6137 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6138 } elsif ($cleanmode eq 'git') {
6139 runcmd_ordryrun_local @git, qw(clean -xdf);
6140 } elsif ($cleanmode eq 'git-ff') {
6141 runcmd_ordryrun_local @git, qw(clean -xdff);
6142 } elsif ($cleanmode eq 'check') {
6143 my $leftovers = cmdoutput @git, qw(clean -xdn);
6144 if (length $leftovers) {
6145 print STDERR $leftovers, "\n" or die $!;
6146 fail "tree contains uncommitted files and --clean=check specified";
6148 } elsif ($cleanmode eq 'none') {
6155 badusage "clean takes no additional arguments" if @ARGV;
6158 maybe_unapply_patches_again();
6161 sub build_or_push_prep_early () {
6162 our $build_or_push_prep_early_done //= 0;
6163 return if $build_or_push_prep_early_done++;
6164 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6165 my $clogp = parsechangelog();
6166 $isuite = getfield $clogp, 'Distribution';
6167 $package = getfield $clogp, 'Source';
6168 $version = getfield $clogp, 'Version';
6171 sub build_prep_early () {
6172 build_or_push_prep_early();
6180 build_maybe_quilt_fixup();
6182 my $pat = changespat $version;
6183 foreach my $f (glob "$buildproductsdir/$pat") {
6185 unlink $f or fail "remove old changes file $f: $!";
6187 progress "would remove $f";
6193 sub changesopts_initial () {
6194 my @opts =@changesopts[1..$#changesopts];
6197 sub changesopts_version () {
6198 if (!defined $changes_since_version) {
6201 @vsns = archive_query('archive_query');
6202 my @quirk = access_quirk();
6203 if ($quirk[0] eq 'backports') {
6204 local $isuite = $quirk[2];
6206 canonicalise_suite();
6207 push @vsns, archive_query('archive_query');
6213 "archive query failed (queried because --since-version not specified)";
6216 @vsns = map { $_->[0] } @vsns;
6217 @vsns = sort { -version_compare($a, $b) } @vsns;
6218 $changes_since_version = $vsns[0];
6219 progress "changelog will contain changes since $vsns[0]";
6221 $changes_since_version = '_';
6222 progress "package seems new, not specifying -v<version>";
6225 if ($changes_since_version ne '_') {
6226 return ("-v$changes_since_version");
6232 sub changesopts () {
6233 return (changesopts_initial(), changesopts_version());
6236 sub massage_dbp_args ($;$) {
6237 my ($cmd,$xargs) = @_;
6240 # - if we're going to split the source build out so we can
6241 # do strange things to it, massage the arguments to dpkg-buildpackage
6242 # so that the main build doessn't build source (or add an argument
6243 # to stop it building source by default).
6245 # - add -nc to stop dpkg-source cleaning the source tree,
6246 # unless we're not doing a split build and want dpkg-source
6247 # as cleanmode, in which case we can do nothing
6250 # 0 - source will NOT need to be built separately by caller
6251 # +1 - source will need to be built separately by caller
6252 # +2 - source will need to be built separately by caller AND
6253 # dpkg-buildpackage should not in fact be run at all!
6254 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6255 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
6256 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
6257 $clean_using_builder = 1;
6260 # -nc has the side effect of specifying -b if nothing else specified
6261 # and some combinations of -S, -b, et al, are errors, rather than
6262 # later simply overriding earlie. So we need to:
6263 # - search the command line for these options
6264 # - pick the last one
6265 # - perhaps add our own as a default
6266 # - perhaps adjust it to the corresponding non-source-building version
6268 foreach my $l ($cmd, $xargs) {
6270 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6273 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6275 if ($need_split_build_invocation) {
6276 printdebug "massage split $dmode.\n";
6277 $r = $dmode =~ m/[S]/ ? +2 :
6278 $dmode =~ y/gGF/ABb/ ? +1 :
6279 $dmode =~ m/[ABb]/ ? 0 :
6282 printdebug "massage done $r $dmode.\n";
6284 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6290 my $wasdir = must_getcwd();
6296 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
6297 my ($msg_if_onlyone) = @_;
6298 # If there is only one .changes file, fail with $msg_if_onlyone,
6299 # or if that is undef, be a no-op.
6300 # Returns the changes file to report to the user.
6301 my $pat = changespat $version;
6302 my @changesfiles = glob $pat;
6303 @changesfiles = sort {
6304 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6308 if (@changesfiles==1) {
6309 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6310 only one changes file from build (@changesfiles)
6312 $result = $changesfiles[0];
6313 } elsif (@changesfiles==2) {
6314 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6315 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6316 fail "$l found in binaries changes file $binchanges"
6319 runcmd_ordryrun_local @mergechanges, @changesfiles;
6320 my $multichanges = changespat $version,'multi';
6322 stat_exists $multichanges or fail "$multichanges: $!";
6323 foreach my $cf (glob $pat) {
6324 next if $cf eq $multichanges;
6325 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6328 $result = $multichanges;
6330 fail "wrong number of different changes files (@changesfiles)";
6332 printdone "build successful, results in $result\n" or die $!;
6335 sub midbuild_checkchanges () {
6336 my $pat = changespat $version;
6337 return if $rmchanges;
6338 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
6339 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
6341 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6342 Suggest you delete @unwanted.
6347 sub midbuild_checkchanges_vanilla ($) {
6349 midbuild_checkchanges() if $wantsrc == 1;
6352 sub postbuild_mergechanges_vanilla ($) {
6354 if ($wantsrc == 1) {
6356 postbuild_mergechanges(undef);
6359 printdone "build successful\n";
6365 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6366 my $wantsrc = massage_dbp_args \@dbp;
6369 midbuild_checkchanges_vanilla $wantsrc;
6374 push @dbp, changesopts_version();
6375 maybe_apply_patches_dirtily();
6376 runcmd_ordryrun_local @dbp;
6378 maybe_unapply_patches_again();
6379 postbuild_mergechanges_vanilla $wantsrc;
6383 $quilt_mode //= 'gbp';
6389 # gbp can make .origs out of thin air. In my tests it does this
6390 # even for a 1.0 format package, with no origs present. So I
6391 # guess it keys off just the version number. We don't know
6392 # exactly what .origs ought to exist, but let's assume that we
6393 # should run gbp if: the version has an upstream part and the main
6395 my $upstreamversion = upstreamversion $version;
6396 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6397 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6399 if ($gbp_make_orig) {
6401 $cleanmode = 'none'; # don't do it again
6402 $need_split_build_invocation = 1;
6405 my @dbp = @dpkgbuildpackage;
6407 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6409 if (!length $gbp_build[0]) {
6410 if (length executable_on_path('git-buildpackage')) {
6411 $gbp_build[0] = qw(git-buildpackage);
6413 $gbp_build[0] = 'gbp buildpackage';
6416 my @cmd = opts_opt_multi_cmd @gbp_build;
6418 push @cmd, (qw(-us -uc --git-no-sign-tags),
6419 "--git-builder=".(shellquote @dbp));
6421 if ($gbp_make_orig) {
6422 my $priv = dgit_privdir();
6423 my $ok = "$priv/origs-gen-ok";
6424 unlink $ok or $!==&ENOENT or die $!;
6425 my @origs_cmd = @cmd;
6426 push @origs_cmd, qw(--git-cleaner=true);
6427 push @origs_cmd, "--git-prebuild=".
6428 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6429 push @origs_cmd, @ARGV;
6431 debugcmd @origs_cmd;
6433 do { local $!; stat_exists $ok; }
6434 or failedcmd @origs_cmd;
6436 dryrun_report @origs_cmd;
6442 midbuild_checkchanges_vanilla $wantsrc;
6444 if (!$clean_using_builder) {
6445 push @cmd, '--git-cleaner=true';
6449 maybe_unapply_patches_again();
6451 push @cmd, changesopts();
6452 runcmd_ordryrun_local @cmd, @ARGV;
6454 postbuild_mergechanges_vanilla $wantsrc;
6456 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6458 sub build_source_for_push {
6460 maybe_unapply_patches_again();
6461 $changesfile = $sourcechanges;
6467 $sourcechanges = changespat $version,'source';
6469 unlink "../$sourcechanges" or $!==ENOENT
6470 or fail "remove $sourcechanges: $!";
6472 $dscfn = dscfn($version);
6473 my @cmd = (@dpkgsource, qw(-b --));
6475 changedir $playground;
6476 runcmd_ordryrun_local @cmd, "work";
6477 my @udfiles = <${package}_*>;
6479 foreach my $f (@udfiles) {
6480 printdebug "source copy, found $f\n";
6483 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6484 $f eq srcfn($version, $&));
6485 printdebug "source copy, found $f - renaming\n";
6486 rename "$playground/$f", "../$f" or $!==ENOENT
6487 or fail "put in place new source file ($f): $!";
6490 my $pwd = must_getcwd();
6491 my $leafdir = basename $pwd;
6493 runcmd_ordryrun_local @cmd, $leafdir;
6496 runcmd_ordryrun_local qw(sh -ec),
6497 'exec >$1; shift; exec "$@"','x',
6498 "../$sourcechanges",
6499 @dpkggenchanges, qw(-S), changesopts();
6502 sub cmd_build_source {
6504 badusage "build-source takes no additional arguments" if @ARGV;
6506 maybe_unapply_patches_again();
6507 printdone "source built, results in $dscfn and $sourcechanges";
6512 midbuild_checkchanges();
6515 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6516 stat_exists $sourcechanges
6517 or fail "$sourcechanges (in parent directory): $!";
6519 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6521 maybe_unapply_patches_again();
6523 postbuild_mergechanges(<<END);
6524 perhaps you need to pass -A ? (sbuild's default is to build only
6525 arch-specific binaries; dgit 1.4 used to override that.)
6530 sub cmd_quilt_fixup {
6531 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6534 build_maybe_quilt_fixup();
6537 sub import_dsc_result {
6538 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6539 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6541 check_gitattrs($newhash, "source tree");
6543 progress "dgit: import-dsc: $what_msg";
6546 sub cmd_import_dsc {
6550 last unless $ARGV[0] =~ m/^-/;
6553 if (m/^--require-valid-signature$/) {
6556 badusage "unknown dgit import-dsc sub-option \`$_'";
6560 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6561 my ($dscfn, $dstbranch) = @ARGV;
6563 badusage "dry run makes no sense with import-dsc" unless act_local();
6565 my $force = $dstbranch =~ s/^\+// ? +1 :
6566 $dstbranch =~ s/^\.\.// ? -1 :
6568 my $info = $force ? " $&" : '';
6569 $info = "$dscfn$info";
6571 my $specbranch = $dstbranch;
6572 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6573 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6575 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6576 my $chead = cmdoutput_errok @symcmd;
6577 defined $chead or $?==256 or failedcmd @symcmd;
6579 fail "$dstbranch is checked out - will not update it"
6580 if defined $chead and $chead eq $dstbranch;
6582 my $oldhash = git_get_ref $dstbranch;
6584 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6585 $dscdata = do { local $/ = undef; <D>; };
6586 D->error and fail "read $dscfn: $!";
6589 # we don't normally need this so import it here
6590 use Dpkg::Source::Package;
6591 my $dp = new Dpkg::Source::Package filename => $dscfn,
6592 require_valid_signature => $needsig;
6594 local $SIG{__WARN__} = sub {
6596 return unless $needsig;
6597 fail "import-dsc signature check failed";
6599 if (!$dp->is_signed()) {
6600 warn "$us: warning: importing unsigned .dsc\n";
6602 my $r = $dp->check_signature();
6603 die "->check_signature => $r" if $needsig && $r;
6609 $package = getfield $dsc, 'Source';
6611 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6612 unless forceing [qw(import-dsc-with-dgit-field)];
6613 parse_dsc_field_def_dsc_distro();
6615 $isuite = 'DGIT-IMPORT-DSC';
6616 $idistro //= $dsc_distro;
6620 if (defined $dsc_hash) {
6621 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6622 resolve_dsc_field_commit undef, undef;
6624 if (defined $dsc_hash) {
6625 my @cmd = (qw(sh -ec),
6626 "echo $dsc_hash | git cat-file --batch-check");
6627 my $objgot = cmdoutput @cmd;
6628 if ($objgot =~ m#^\w+ missing\b#) {
6630 .dsc contains Dgit field referring to object $dsc_hash
6631 Your git tree does not have that object. Try `git fetch' from a
6632 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6635 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6637 progress "Not fast forward, forced update.";
6639 fail "Not fast forward to $dsc_hash";
6642 import_dsc_result $dstbranch, $dsc_hash,
6643 "dgit import-dsc (Dgit): $info",
6644 "updated git ref $dstbranch";
6649 Branch $dstbranch already exists
6650 Specify ..$specbranch for a pseudo-merge, binding in existing history
6651 Specify +$specbranch to overwrite, discarding existing history
6653 if $oldhash && !$force;
6655 my @dfi = dsc_files_info();
6656 foreach my $fi (@dfi) {
6657 my $f = $fi->{Filename};
6661 fail "lstat $here works but stat gives $! !";
6663 fail "stat $here: $!" unless $! == ENOENT;
6665 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6667 } elsif ($dscfn =~ m#^/#) {
6670 fail "cannot import $dscfn which seems to be inside working tree!";
6672 $there =~ s#/+[^/]+$## or
6673 fail "import $dscfn requires ../$f, but it does not exist";
6675 my $test = $there =~ m{^/} ? $there : "../$there";
6676 stat $test or fail "import $dscfn requires $test, but: $!";
6677 symlink $there, $here or fail "symlink $there to $here: $!";
6678 progress "made symlink $here -> $there";
6679 # print STDERR Dumper($fi);
6681 my @mergeinputs = generate_commits_from_dsc();
6682 die unless @mergeinputs == 1;
6684 my $newhash = $mergeinputs[0]{Commit};
6688 progress "Import, forced update - synthetic orphan git history.";
6689 } elsif ($force < 0) {
6690 progress "Import, merging.";
6691 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6692 my $version = getfield $dsc, 'Version';
6693 my $clogp = commit_getclogp $newhash;
6694 my $authline = clogp_authline $clogp;
6695 $newhash = make_commit_text <<END;
6702 Merge $package ($version) import into $dstbranch
6705 die; # caught earlier
6709 import_dsc_result $dstbranch, $newhash,
6710 "dgit import-dsc: $info",
6711 "results are in in git ref $dstbranch";
6714 sub pre_archive_api_query () {
6715 not_necessarily_a_tree();
6717 sub cmd_archive_api_query {
6718 badusage "need only 1 subpath argument" unless @ARGV==1;
6719 my ($subpath) = @ARGV;
6720 local $isuite = 'DGIT-API-QUERY-CMD';
6721 my @cmd = archive_api_query_cmd($subpath);
6724 exec @cmd or fail "exec curl: $!\n";
6727 sub repos_server_url () {
6728 $package = '_dgit-repos-server';
6729 local $access_forpush = 1;
6730 local $isuite = 'DGIT-REPOS-SERVER';
6731 my $url = access_giturl();
6734 sub pre_clone_dgit_repos_server () {
6735 not_necessarily_a_tree();
6737 sub cmd_clone_dgit_repos_server {
6738 badusage "need destination argument" unless @ARGV==1;
6739 my ($destdir) = @ARGV;
6740 my $url = repos_server_url();
6741 my @cmd = (@git, qw(clone), $url, $destdir);
6743 exec @cmd or fail "exec git clone: $!\n";
6746 sub pre_print_dgit_repos_server_source_url () {
6747 not_necessarily_a_tree();
6749 sub cmd_print_dgit_repos_server_source_url {
6750 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6752 my $url = repos_server_url();
6753 print $url, "\n" or die $!;
6756 sub pre_print_dpkg_source_ignores {
6757 not_necessarily_a_tree();
6759 sub cmd_print_dpkg_source_ignores {
6760 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6762 print "@dpkg_source_ignores\n" or die $!;
6765 sub cmd_setup_mergechangelogs {
6766 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6767 local $isuite = 'DGIT-SETUP-TREE';
6768 setup_mergechangelogs(1);
6771 sub cmd_setup_useremail {
6772 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6773 local $isuite = 'DGIT-SETUP-TREE';
6777 sub cmd_setup_gitattributes {
6778 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6779 local $isuite = 'DGIT-SETUP-TREE';
6783 sub cmd_setup_new_tree {
6784 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6785 local $isuite = 'DGIT-SETUP-TREE';
6789 #---------- argument parsing and main program ----------
6792 print "dgit version $our_version\n" or die $!;
6796 our (%valopts_long, %valopts_short);
6797 our (%funcopts_long);
6799 our (@modeopt_cfgs);
6801 sub defvalopt ($$$$) {
6802 my ($long,$short,$val_re,$how) = @_;
6803 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6804 $valopts_long{$long} = $oi;
6805 $valopts_short{$short} = $oi;
6806 # $how subref should:
6807 # do whatever assignemnt or thing it likes with $_[0]
6808 # if the option should not be passed on to remote, @rvalopts=()
6809 # or $how can be a scalar ref, meaning simply assign the value
6812 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6813 defvalopt '--distro', '-d', '.+', \$idistro;
6814 defvalopt '', '-k', '.+', \$keyid;
6815 defvalopt '--existing-package','', '.*', \$existing_package;
6816 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6817 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6818 defvalopt '--package', '-p', $package_re, \$package;
6819 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6821 defvalopt '', '-C', '.+', sub {
6822 ($changesfile) = (@_);
6823 if ($changesfile =~ s#^(.*)/##) {
6824 $buildproductsdir = $1;
6828 defvalopt '--initiator-tempdir','','.*', sub {
6829 ($initiator_tempdir) = (@_);
6830 $initiator_tempdir =~ m#^/# or
6831 badusage "--initiator-tempdir must be used specify an".
6832 " absolute, not relative, directory."
6835 sub defoptmodes ($@) {
6836 my ($varref, $cfgkey, $default, %optmap) = @_;
6838 while (my ($opt,$val) = each %optmap) {
6839 $funcopts_long{$opt} = sub { $$varref = $val; };
6840 $permit{$val} = $val;
6842 push @modeopt_cfgs, {
6845 Default => $default,
6850 defoptmodes \$dodep14tag, qw( dep14tag want
6853 --always-dep14tag always );
6858 if (defined $ENV{'DGIT_SSH'}) {
6859 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6860 } elsif (defined $ENV{'GIT_SSH'}) {
6861 @ssh = ($ENV{'GIT_SSH'});
6869 if (!defined $val) {
6870 badusage "$what needs a value" unless @ARGV;
6872 push @rvalopts, $val;
6874 badusage "bad value \`$val' for $what" unless
6875 $val =~ m/^$oi->{Re}$(?!\n)/s;
6876 my $how = $oi->{How};
6877 if (ref($how) eq 'SCALAR') {
6882 push @ropts, @rvalopts;
6886 last unless $ARGV[0] =~ m/^-/;
6890 if (m/^--dry-run$/) {
6893 } elsif (m/^--damp-run$/) {
6896 } elsif (m/^--no-sign$/) {
6899 } elsif (m/^--help$/) {
6901 } elsif (m/^--version$/) {
6903 } elsif (m/^--new$/) {
6906 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6907 ($om = $opts_opt_map{$1}) &&
6911 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6912 !$opts_opt_cmdonly{$1} &&
6913 ($om = $opts_opt_map{$1})) {
6916 } elsif (m/^--(gbp|dpm)$/s) {
6917 push @ropts, "--quilt=$1";
6919 } elsif (m/^--ignore-dirty$/s) {
6922 } elsif (m/^--no-quilt-fixup$/s) {
6924 $quilt_mode = 'nocheck';
6925 } elsif (m/^--no-rm-on-error$/s) {
6928 } elsif (m/^--no-chase-dsc-distro$/s) {
6930 $chase_dsc_distro = 0;
6931 } elsif (m/^--overwrite$/s) {
6933 $overwrite_version = '';
6934 } elsif (m/^--overwrite=(.+)$/s) {
6936 $overwrite_version = $1;
6937 } elsif (m/^--delayed=(\d+)$/s) {
6940 } elsif (m/^--dgit-view-save=(.+)$/s) {
6942 $split_brain_save = $1;
6943 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6944 } elsif (m/^--(no-)?rm-old-changes$/s) {
6947 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6949 push @deliberatelies, $&;
6950 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6954 } elsif (m/^--force-/) {
6956 "$us: warning: ignoring unknown force option $_\n";
6958 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6959 # undocumented, for testing
6961 $tagformat_want = [ $1, 'command line', 1 ];
6962 # 1 menas overrides distro configuration
6963 } elsif (m/^--always-split-source-build$/s) {
6964 # undocumented, for testing
6966 $need_split_build_invocation = 1;
6967 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6968 # undocumented, for testing
6970 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6971 # ^ it's supposed to be an array ref
6972 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6973 $val = $2 ? $' : undef; #';
6974 $valopt->($oi->{Long});
6975 } elsif ($funcopts_long{$_}) {
6977 $funcopts_long{$_}();
6979 badusage "unknown long option \`$_'";
6986 } elsif (s/^-L/-/) {
6989 } elsif (s/^-h/-/) {
6991 } elsif (s/^-D/-/) {
6995 } elsif (s/^-N/-/) {
7000 push @changesopts, $_;
7002 } elsif (s/^-wn$//s) {
7004 $cleanmode = 'none';
7005 } elsif (s/^-wg$//s) {
7008 } elsif (s/^-wgf$//s) {
7010 $cleanmode = 'git-ff';
7011 } elsif (s/^-wd$//s) {
7013 $cleanmode = 'dpkg-source';
7014 } elsif (s/^-wdd$//s) {
7016 $cleanmode = 'dpkg-source-d';
7017 } elsif (s/^-wc$//s) {
7019 $cleanmode = 'check';
7020 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7021 push @git, '-c', $&;
7022 $gitcfgs{cmdline}{$1} = [ $2 ];
7023 } elsif (s/^-c([^=]+)$//s) {
7024 push @git, '-c', $&;
7025 $gitcfgs{cmdline}{$1} = [ 'true' ];
7026 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7028 $val = undef unless length $val;
7029 $valopt->($oi->{Short});
7032 badusage "unknown short option \`$_'";
7039 sub check_env_sanity () {
7040 my $blocked = new POSIX::SigSet;
7041 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7044 foreach my $name (qw(PIPE CHLD)) {
7045 my $signame = "SIG$name";
7046 my $signum = eval "POSIX::$signame" // die;
7047 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
7048 die "$signame is set to something other than SIG_DFL\n";
7049 $blocked->ismember($signum) and
7050 die "$signame is blocked\n";
7056 On entry to dgit, $@
7057 This is a bug produced by something in in your execution environment.
7063 sub parseopts_late_defaults () {
7064 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7065 if defined $idistro;
7066 $isuite //= cfg('dgit.default.default-suite');
7068 foreach my $k (keys %opts_opt_map) {
7069 my $om = $opts_opt_map{$k};
7071 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7073 badcfg "cannot set command for $k"
7074 unless length $om->[0];
7078 foreach my $c (access_cfg_cfgs("opts-$k")) {
7080 map { $_ ? @$_ : () }
7081 map { $gitcfgs{$_}{$c} }
7082 reverse @gitcfgsources;
7083 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7084 "\n" if $debuglevel >= 4;
7086 badcfg "cannot configure options for $k"
7087 if $opts_opt_cmdonly{$k};
7088 my $insertpos = $opts_cfg_insertpos{$k};
7089 @$om = ( @$om[0..$insertpos-1],
7091 @$om[$insertpos..$#$om] );
7095 if (!defined $rmchanges) {
7096 local $access_forpush;
7097 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7100 if (!defined $quilt_mode) {
7101 local $access_forpush;
7102 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7103 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7105 $quilt_mode =~ m/^($quilt_modes_re)$/
7106 or badcfg "unknown quilt-mode \`$quilt_mode'";
7110 foreach my $moc (@modeopt_cfgs) {
7111 local $access_forpush;
7112 my $vr = $moc->{Var};
7113 next if defined $$vr;
7114 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7115 my $v = $moc->{Vals}{$$vr};
7116 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7120 $need_split_build_invocation ||= quiltmode_splitbrain();
7122 if (!defined $cleanmode) {
7123 local $access_forpush;
7124 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7125 $cleanmode //= 'dpkg-source';
7127 badcfg "unknown clean-mode \`$cleanmode'" unless
7128 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7132 if ($ENV{$fakeeditorenv}) {
7134 quilt_fixup_editor();
7140 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7141 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7142 if $dryrun_level == 1;
7144 print STDERR $helpmsg or die $!;
7147 $cmd = $subcommand = shift @ARGV;
7150 my $pre_fn = ${*::}{"pre_$cmd"};
7151 $pre_fn->() if $pre_fn;
7153 record_maindir if $invoked_in_git_tree;
7156 my $fn = ${*::}{"cmd_$cmd"};
7157 $fn or badusage "unknown operation $cmd";