3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2018 Ian Jackson
6 # Copyright (C)2017-2018 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;
23 use Debian::Dgit::I18n;
27 use Debian::Dgit qw(:DEFAULT :playground);
33 use Dpkg::Control::Hash;
36 use File::Temp qw(tempdir);
39 use Dpkg::Compression;
40 use Dpkg::Compression::Process;
46 use List::MoreUtils qw(pairwise);
47 use Text::Glob qw(match_glob);
48 use Fcntl qw(:DEFAULT :flock);
53 our $our_version = 'UNRELEASED'; ###substituted###
54 our $absurdity = undef; ###substituted###
56 our @rpushprotovsn_support = qw(4 5); # 5 drops tag format specification
67 our $dryrun_level = 0;
69 our $buildproductsdir;
72 our $includedirty = 0;
76 our $existing_package = 'dpkg';
78 our $changes_since_version;
80 our $overwrite_version; # undef: not specified; '': check changelog
82 our $quilt_upstream_commitish;
83 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied|baredebian';
85 our $splitview_modes_re = qr{auto|always|never};
87 our %internal_object_save;
88 our $we_are_responder;
89 our $we_are_initiator;
90 our $initiator_tempdir;
91 our $patches_applied_dirtily = 00;
92 our $chase_dsc_distro=1;
94 our %forceopts = map { $_=>0 }
95 qw(unrepresentable unsupported-source-format
96 dsc-changes-mismatch changes-origs-exactly
97 uploading-binaries uploading-source-only
98 import-gitapply-absurd
99 import-gitapply-no-absurd
100 import-dsc-with-dgit-field);
102 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
104 our $suite_re = '[-+.0-9a-z]+';
105 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
106 | (?: git | git-ff ) (?: ,always )?
107 | check (?: ,ignores )?
111 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
112 our $splitbraincache = 'dgit-intern/quilt-cache';
113 our $rewritemap = 'dgit-rewrite/map';
115 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
117 our (@git) = qw(git);
118 our (@dget) = qw(dget);
119 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
120 our (@dput) = qw(dput);
121 our (@debsign) = qw(debsign);
122 our (@gpg) = qw(gpg);
123 our (@sbuild) = (qw(sbuild --no-source));
125 our (@dgit) = qw(dgit);
126 our (@git_debrebase) = qw(git-debrebase);
127 our (@aptget) = qw(apt-get);
128 our (@aptcache) = qw(apt-cache);
129 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
130 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
131 our (@dpkggenchanges) = qw(dpkg-genchanges);
132 our (@mergechanges) = qw(mergechanges -f);
133 our (@gbp_build) = ('');
134 our (@gbp_pq) = ('gbp pq');
135 our (@changesopts) = ('');
136 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
137 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
139 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
142 'debsign' => \@debsign,
144 'sbuild' => \@sbuild,
148 'git-debrebase' => \@git_debrebase,
149 'apt-get' => \@aptget,
150 'apt-cache' => \@aptcache,
151 'dpkg-source' => \@dpkgsource,
152 'dpkg-buildpackage' => \@dpkgbuildpackage,
153 'dpkg-genchanges' => \@dpkggenchanges,
154 'gbp-build' => \@gbp_build,
155 'gbp-pq' => \@gbp_pq,
156 'ch' => \@changesopts,
157 'mergechanges' => \@mergechanges,
158 'pbuilder' => \@pbuilder,
159 'cowbuilder' => \@cowbuilder);
161 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
162 our %opts_cfg_insertpos = map {
164 scalar @{ $opts_opt_map{$_} }
165 } keys %opts_opt_map;
167 sub parseopts_late_defaults();
168 sub quiltify_trees_differ ($$;$$$);
169 sub setup_gitattrs(;$);
170 sub check_gitattrs($$);
177 our $supplementary_message = '';
178 our $made_split_brain = 0;
181 # Interactions between quilt mode and split brain
182 # (currently, split brain only implemented iff
183 # madformat_wantfixup && quiltmode_splitting)
185 # source format sane `3.0 (quilt)'
186 # madformat_wantfixup()
188 # quilt mode normal quiltmode
189 # (eg linear) _splitbrain
191 # ------------ ------------------------------------------------
193 # no split no q cache no q cache forbidden,
194 # brain PM on master q fixup on master prevented
195 # !do_split_brain() PM on master
197 # split brain no q cache q fixup cached, to dgit view
198 # PM in dgit view PM in dgit view
200 # PM = pseudomerge to make ff, due to overwrite (or split view)
201 # "no q cache" = do not record in cache on build, do not check cache
202 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
206 return unless forkcheck_mainprocess();
207 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
210 our $remotename = 'dgit';
211 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
215 if (!defined $absurdity) {
217 $absurdity =~ s{/[^/]+$}{/absurd} or die;
220 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
222 sub lbranch () { return "$branchprefix/$csuite"; }
223 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
224 sub lref () { return "refs/heads/".lbranch(); }
225 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
226 sub rrref () { return server_ref($csuite); }
229 my ($vsn, $sfx) = @_;
230 return &source_file_leafname($package, $vsn, $sfx);
232 sub is_orig_file_of_vsn ($$) {
233 my ($f, $upstreamvsn) = @_;
234 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
239 return srcfn($vsn,".dsc");
242 sub changespat ($;$) {
243 my ($vsn, $arch) = @_;
244 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
253 return unless forkcheck_mainprocess();
254 foreach my $f (@end) {
256 print STDERR "$us: cleanup: $@" if length $@;
261 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
265 sub forceable_fail ($$) {
266 my ($forceoptsl, $msg) = @_;
267 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
268 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
272 my ($forceoptsl) = @_;
273 my @got = grep { $forceopts{$_} } @$forceoptsl;
274 return 0 unless @got;
276 "warning: skipping checks or functionality due to --force-%s\n",
280 sub no_such_package () {
281 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
282 $us, $package, $isuite;
286 sub deliberately ($) {
288 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
291 sub deliberately_not_fast_forward () {
292 foreach (qw(not-fast-forward fresh-repo)) {
293 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
297 sub quiltmode_splitting () {
298 $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/;
301 sub do_split_brain () { !!($do_split_brain // confess) }
303 sub opts_opt_multi_cmd {
306 push @cmd, split /\s+/, shift @_;
313 return opts_opt_multi_cmd [], @gbp_pq;
316 sub dgit_privdir () {
317 our $dgit_privdir_made //= ensure_a_playground 'dgit';
321 my $r = $buildproductsdir;
322 $r = "$maindir/$r" unless $r =~ m{^/};
326 sub get_tree_of_commit ($) {
327 my ($commitish) = @_;
328 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
329 $cdata =~ m/\n\n/; $cdata = $`;
330 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
334 sub branch_gdr_info ($$) {
335 my ($symref, $head) = @_;
336 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
337 gdr_ffq_prev_branchinfo($symref);
338 return () unless $status eq 'branch';
339 $ffq_prev = git_get_ref $ffq_prev;
340 $gdrlast = git_get_ref $gdrlast;
341 $gdrlast &&= is_fast_fwd $gdrlast, $head;
342 return ($ffq_prev, $gdrlast);
345 sub branch_is_gdr_unstitched_ff ($$$) {
346 my ($symref, $head, $ancestor) = @_;
347 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
348 return 0 unless $ffq_prev;
349 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
353 sub branch_is_gdr ($) {
355 # This is quite like git-debrebase's keycommits.
356 # We have our own implementation because:
357 # - our algorighm can do fewer tests so is faster
358 # - it saves testing to see if gdr is installed
360 # NB we use this jsut for deciding whether to run gdr make-patches
361 # Before reusing this algorithm for somthing else, its
362 # suitability should be reconsidered.
365 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
366 printdebug "branch_is_gdr $head...\n";
367 my $get_patches = sub {
368 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
371 my $tip_patches = $get_patches->($head);
374 my $cdata = git_cat_file $walk, 'commit';
375 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
376 if ($msg =~ m{^\[git-debrebase\ (
377 anchor | changelog | make-patches |
378 merged-breakwater | pseudomerge
380 # no need to analyse this - it's sufficient
381 # (gdr classifications: Anchor, MergedBreakwaters)
382 # (made by gdr: Pseudomerge, Changelog)
383 printdebug "branch_is_gdr $walk gdr $1 YES\n";
386 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
388 my $walk_tree = get_tree_of_commit $walk;
389 foreach my $p (@parents) {
390 my $p_tree = get_tree_of_commit $p;
391 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
392 # (gdr classification: Pseudomerge; not made by gdr)
393 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
399 # some other non-gdr merge
400 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
401 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
405 # (gdr classification: ?)
406 printdebug "branch_is_gdr $walk ?-octopus NO\n";
410 printdebug "branch_is_gdr $walk origin\n";
413 if ($get_patches->($walk) ne $tip_patches) {
414 # Our parent added, removed, or edited patches, and wasn't
415 # a gdr make-patches commit. gdr make-patches probably
416 # won't do that well, then.
417 # (gdr classification of parent: AddPatches or ?)
418 printdebug "branch_is_gdr $walk ?-patches NO\n";
421 if ($tip_patches eq '' and
422 !defined git_cat_file "$walk~:debian" and
423 !quiltify_trees_differ "$walk~", $walk
425 # (gdr classification of parent: BreakwaterStart
426 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
429 # (gdr classification: Upstream Packaging Mixed Changelog)
430 printdebug "branch_is_gdr $walk plain\n"
436 #---------- remote protocol support, common ----------
438 # remote push initiator/responder protocol:
439 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
440 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
441 # < dgit-remote-push-ready <actual-proto-vsn>
448 # > supplementary-message NBYTES
453 # > file parsed-changelog
454 # [indicates that output of dpkg-parsechangelog follows]
455 # > data-block NBYTES
456 # > [NBYTES bytes of data (no newline)]
457 # [maybe some more blocks]
466 # > param head DGIT-VIEW-HEAD
467 # > param csuite SUITE
468 # > param tagformat new # $protovsn == 4
469 # > param maint-view MAINT-VIEW-HEAD
471 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
472 # > file buildinfo # for buildinfos to sign
474 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
475 # # goes into tag, for replay prevention
478 # [indicates that signed tag is wanted]
479 # < data-block NBYTES
480 # < [NBYTES bytes of data (no newline)]
481 # [maybe some more blocks]
485 # > want signed-dsc-changes
486 # < data-block NBYTES [transfer of signed dsc]
488 # < data-block NBYTES [transfer of signed changes]
490 # < data-block NBYTES [transfer of each signed buildinfo
491 # [etc] same number and order as "file buildinfo"]
499 sub i_child_report () {
500 # Sees if our child has died, and reap it if so. Returns a string
501 # describing how it died if it failed, or undef otherwise.
502 return undef unless $i_child_pid;
503 my $got = waitpid $i_child_pid, WNOHANG;
504 return undef if $got <= 0;
505 die unless $got == $i_child_pid;
506 $i_child_pid = undef;
507 return undef unless $?;
508 return f_ "build host child %s", waitstatusmsg();
513 fail f_ "connection lost: %s", $! if $fh->error;
514 fail f_ "protocol violation; %s not expected", $m;
517 sub badproto_badread ($$) {
519 fail f_ "connection lost: %s", $! if $!;
520 my $report = i_child_report();
521 fail $report if defined $report;
522 badproto $fh, f_ "eof (reading %s)", $wh;
525 sub protocol_expect (&$) {
526 my ($match, $fh) = @_;
529 defined && chomp or badproto_badread $fh, __ "protocol message";
537 badproto $fh, f_ "\`%s'", $_;
540 sub protocol_send_file ($$) {
541 my ($fh, $ourfn) = @_;
542 open PF, "<", $ourfn or die "$ourfn: $!";
545 my $got = read PF, $d, 65536;
546 die "$ourfn: $!" unless defined $got;
548 print $fh "data-block ".length($d)."\n" or confess "$!";
549 print $fh $d or confess "$!";
551 PF->error and die "$ourfn $!";
552 print $fh "data-end\n" or confess "$!";
556 sub protocol_read_bytes ($$) {
557 my ($fh, $nbytes) = @_;
558 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
560 my $got = read $fh, $d, $nbytes;
561 $got==$nbytes or badproto_badread $fh, __ "data block";
565 sub protocol_receive_file ($$) {
566 my ($fh, $ourfn) = @_;
567 printdebug "() $ourfn\n";
568 open PF, ">", $ourfn or die "$ourfn: $!";
570 my ($y,$l) = protocol_expect {
571 m/^data-block (.*)$/ ? (1,$1) :
572 m/^data-end$/ ? (0,) :
576 my $d = protocol_read_bytes $fh, $l;
577 print PF $d or confess "$!";
579 close PF or confess "$!";
582 #---------- remote protocol support, responder ----------
584 sub responder_send_command ($) {
586 return unless $we_are_responder;
587 # called even without $we_are_responder
588 printdebug ">> $command\n";
589 print PO $command, "\n" or confess "$!";
592 sub responder_send_file ($$) {
593 my ($keyword, $ourfn) = @_;
594 return unless $we_are_responder;
595 printdebug "]] $keyword $ourfn\n";
596 responder_send_command "file $keyword";
597 protocol_send_file \*PO, $ourfn;
600 sub responder_receive_files ($@) {
601 my ($keyword, @ourfns) = @_;
602 die unless $we_are_responder;
603 printdebug "[[ $keyword @ourfns\n";
604 responder_send_command "want $keyword";
605 foreach my $fn (@ourfns) {
606 protocol_receive_file \*PI, $fn;
609 protocol_expect { m/^files-end$/ } \*PI;
612 #---------- remote protocol support, initiator ----------
614 sub initiator_expect (&) {
616 protocol_expect { &$match } \*RO;
619 #---------- end remote code ----------
622 if ($we_are_responder) {
624 responder_send_command "progress ".length($m) or confess "$!";
625 print PO $m or confess "$!";
635 $ua = LWP::UserAgent->new();
639 progress "downloading $what...";
640 my $r = $ua->get(@_) or confess "$!";
641 return undef if $r->code == 404;
642 $r->is_success or fail f_ "failed to fetch %s: %s",
643 $what, $r->status_line;
644 return $r->decoded_content(charset => 'none');
647 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
649 sub act_local () { return $dryrun_level <= 1; }
650 sub act_scary () { return !$dryrun_level; }
653 if (!$dryrun_level) {
654 progress f_ "%s ok: %s", $us, "@_";
656 progress f_ "would be ok: %s (but dry run only)", "@_";
661 printcmd(\*STDERR,$debugprefix."#",@_);
664 sub runcmd_ordryrun {
672 sub runcmd_ordryrun_local {
680 our $helpmsg = i_ <<END;
682 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
683 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
684 dgit [dgit-opts] build [dpkg-buildpackage-opts]
685 dgit [dgit-opts] sbuild [sbuild-opts]
686 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
687 dgit [dgit-opts] push [dgit-opts] [suite]
688 dgit [dgit-opts] push-source [dgit-opts] [suite]
689 dgit [dgit-opts] rpush build-host:build-dir ...
690 important dgit options:
691 -k<keyid> sign tag and package with <keyid> instead of default
692 --dry-run -n do not change anything, but go through the motions
693 --damp-run -L like --dry-run but make local changes, without signing
694 --new -N allow introducing a new package
695 --debug -D increase debug level
696 -c<name>=<value> set git config option (used directly by dgit too)
699 our $later_warning_msg = i_ <<END;
700 Perhaps the upload is stuck in incoming. Using the version from git.
704 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
709 @ARGV or badusage __ "too few arguments";
710 return scalar shift @ARGV;
714 not_necessarily_a_tree();
717 print __ $helpmsg or confess "$!";
721 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
723 our %defcfg = ('dgit.default.distro' => 'debian',
724 'dgit.default.default-suite' => 'unstable',
725 'dgit.default.old-dsc-distro' => 'debian',
726 'dgit-suite.*-security.distro' => 'debian-security',
727 'dgit.default.username' => '',
728 'dgit.default.archive-query-default-component' => 'main',
729 'dgit.default.ssh' => 'ssh',
730 'dgit.default.archive-query' => 'madison:',
731 'dgit.default.sshpsql-dbname' => 'service=projectb',
732 'dgit.default.aptget-components' => 'main',
733 'dgit.default.source-only-uploads' => 'ok',
734 'dgit.dsc-url-proto-ok.http' => 'true',
735 'dgit.dsc-url-proto-ok.https' => 'true',
736 'dgit.dsc-url-proto-ok.git' => 'true',
737 'dgit.vcs-git.suites', => 'sid', # ;-separated
738 'dgit.default.dsc-url-proto-ok' => 'false',
739 # old means "repo server accepts pushes with old dgit tags"
740 # new means "repo server accepts pushes with new dgit tags"
741 # maint means "repo server accepts split brain pushes"
742 # hist means "repo server may have old pushes without new tag"
743 # ("hist" is implied by "old")
744 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
745 'dgit-distro.debian.git-check' => 'url',
746 'dgit-distro.debian.git-check-suffix' => '/info/refs',
747 'dgit-distro.debian.new-private-pushers' => 't',
748 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
749 'dgit-distro.debian/push.git-url' => '',
750 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
751 'dgit-distro.debian/push.git-user-force' => 'dgit',
752 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
753 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
754 'dgit-distro.debian/push.git-create' => 'true',
755 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
756 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
757 # 'dgit-distro.debian.archive-query-tls-key',
758 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
759 # ^ this does not work because curl is broken nowadays
760 # Fixing #790093 properly will involve providing providing the key
761 # in some pacagke and maybe updating these paths.
763 # 'dgit-distro.debian.archive-query-tls-curl-args',
764 # '--ca-path=/etc/ssl/ca-debian',
765 # ^ this is a workaround but works (only) on DSA-administered machines
766 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
767 'dgit-distro.debian.git-url-suffix' => '',
768 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
769 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
770 'dgit-distro.debian-security.archive-query' => 'aptget:',
771 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
772 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
773 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
774 'dgit-distro.debian-security.nominal-distro' => 'debian',
775 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
776 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
777 'dgit-distro.ubuntu.git-check' => 'false',
778 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
779 'dgit-distro.test-dummy.ssh' => "$td/ssh",
780 'dgit-distro.test-dummy.username' => "alice",
781 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
782 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
783 'dgit-distro.test-dummy.git-url' => "$td/git",
784 'dgit-distro.test-dummy.git-host' => "git",
785 'dgit-distro.test-dummy.git-path' => "$td/git",
786 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
787 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
788 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
789 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
793 our @gitcfgsources = qw(cmdline local global system);
794 our $invoked_in_git_tree = 1;
796 sub git_slurp_config () {
797 # This algoritm is a bit subtle, but this is needed so that for
798 # options which we want to be single-valued, we allow the
799 # different config sources to override properly. See #835858.
800 foreach my $src (@gitcfgsources) {
801 next if $src eq 'cmdline';
802 # we do this ourselves since git doesn't handle it
804 $gitcfgs{$src} = git_slurp_config_src $src;
808 sub git_get_config ($) {
810 foreach my $src (@gitcfgsources) {
811 my $l = $gitcfgs{$src}{$c};
812 confess "internal error ($l $c)" if $l && !ref $l;
813 printdebug"C $c ".(defined $l ?
814 join " ", map { messagequote "'$_'" } @$l :
819 f_ "multiple values for %s (in %s git config)", $c, $src
821 $l->[0] =~ m/\n/ and badcfg f_
822 "value for config option %s (in %s git config) contains newline(s)!",
831 return undef if $c =~ /RETURN-UNDEF/;
832 printdebug "C? $c\n" if $debuglevel >= 5;
833 my $v = git_get_config($c);
834 return $v if defined $v;
835 my $dv = $defcfg{$c};
837 printdebug "CD $c $dv\n" if $debuglevel >= 4;
842 "need value for one of: %s\n".
843 "%s: distro or suite appears not to be (properly) supported",
847 sub not_necessarily_a_tree () {
848 # needs to be called from pre_*
849 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
850 $invoked_in_git_tree = 0;
853 sub access_basedistro__noalias () {
854 if (defined $idistro) {
857 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
858 return $def if defined $def;
859 foreach my $src (@gitcfgsources, 'internal') {
860 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
862 foreach my $k (keys %$kl) {
863 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
865 next unless match_glob $dpat, $isuite;
869 return cfg("dgit.default.distro");
873 sub access_basedistro () {
874 my $noalias = access_basedistro__noalias();
875 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
876 return $canon // $noalias;
879 sub access_nomdistro () {
880 my $base = access_basedistro();
881 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
882 $r =~ m/^$distro_re$/ or badcfg
883 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
884 $r, "/^$distro_re$/";
888 sub access_quirk () {
889 # returns (quirk name, distro to use instead or undef, quirk-specific info)
890 my $basedistro = access_basedistro();
891 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
893 if (defined $backports_quirk) {
894 my $re = $backports_quirk;
895 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
897 $re =~ s/\%/([-0-9a-z_]+)/
898 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
899 if ($isuite =~ m/^$re$/) {
900 return ('backports',"$basedistro-backports",$1);
903 return ('none',undef);
908 sub parse_cfg_bool ($$$) {
909 my ($what,$def,$v) = @_;
912 $v =~ m/^[ty1]/ ? 1 :
913 $v =~ m/^[fn0]/ ? 0 :
914 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
918 sub access_forpush_config () {
919 my $d = access_basedistro();
923 parse_cfg_bool('new-private-pushers', 0,
924 cfg("dgit-distro.$d.new-private-pushers",
927 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
930 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
931 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
932 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
934 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
937 sub access_forpush () {
938 $access_forpush //= access_forpush_config();
939 return $access_forpush;
942 sub default_from_access_cfg ($$$;$) {
943 my ($var, $keybase, $defval, $permit_re) = @_;
944 return if defined $$var;
946 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
947 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
949 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
952 badcfg f_ "unknown %s \`%s'", $keybase, $$var
953 if defined $permit_re and $$var !~ m/$permit_re/;
957 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
958 defined $access_forpush and !$access_forpush;
959 badcfg __ "pushing but distro is configured readonly"
960 if access_forpush_config() eq '0';
962 $supplementary_message = __ <<'END' unless $we_are_responder;
963 Push failed, before we got started.
964 You can retry the push, after fixing the problem, if you like.
966 parseopts_late_defaults();
970 parseopts_late_defaults();
973 sub determine_whether_split_brain () {
974 my ($format,) = get_source_format();
977 local $access_forpush;
978 default_from_access_cfg(\$splitview_mode, 'split-view', 'auto',
979 $splitview_modes_re);
980 $do_split_brain = 1 if $splitview_mode eq 'always';
983 printdebug "format $format, quilt mode $quilt_mode\n";
985 if (madformat_wantfixup($format) && quiltmode_splitting()) {
986 $splitview_mode ne 'never' or
987 fail f_ "dgit: quilt mode \`%s' (for format \`%s')".
988 " implies split view, but split-view set to \`%s'",
989 $quilt_mode, $format, $splitview_mode;
992 $do_split_brain //= 0;
997 sub supplementary_message ($) {
999 if (!$we_are_responder) {
1000 $supplementary_message = $msg;
1003 responder_send_command "supplementary-message ".length($msg)
1005 print PO $msg or confess "$!";
1009 sub access_distros () {
1010 # Returns list of distros to try, in order
1013 # 0. `instead of' distro name(s) we have been pointed to
1014 # 1. the access_quirk distro, if any
1015 # 2a. the user's specified distro, or failing that } basedistro
1016 # 2b. the distro calculated from the suite }
1017 my @l = access_basedistro();
1019 my (undef,$quirkdistro) = access_quirk();
1020 unshift @l, $quirkdistro;
1021 unshift @l, $instead_distro;
1022 @l = grep { defined } @l;
1024 push @l, access_nomdistro();
1026 if (access_forpush()) {
1027 @l = map { ("$_/push", $_) } @l;
1032 sub access_cfg_cfgs (@) {
1035 # The nesting of these loops determines the search order. We put
1036 # the key loop on the outside so that we search all the distros
1037 # for each key, before going on to the next key. That means that
1038 # if access_cfg is called with a more specific, and then a less
1039 # specific, key, an earlier distro can override the less specific
1040 # without necessarily overriding any more specific keys. (If the
1041 # distro wants to override the more specific keys it can simply do
1042 # so; whereas if we did the loop the other way around, it would be
1043 # impossible to for an earlier distro to override a less specific
1044 # key but not the more specific ones without restating the unknown
1045 # values of the more specific keys.
1048 # We have to deal with RETURN-UNDEF specially, so that we don't
1049 # terminate the search prematurely.
1051 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1054 foreach my $d (access_distros()) {
1055 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1057 push @cfgs, map { "dgit.default.$_" } @realkeys;
1058 push @cfgs, @rundef;
1062 sub access_cfg (@) {
1064 my (@cfgs) = access_cfg_cfgs(@keys);
1065 my $value = cfg(@cfgs);
1069 sub access_cfg_bool ($$) {
1070 my ($def, @keys) = @_;
1071 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1074 sub string_to_ssh ($) {
1076 if ($spec =~ m/\s/) {
1077 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1083 sub access_cfg_ssh () {
1084 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1085 if (!defined $gitssh) {
1088 return string_to_ssh $gitssh;
1092 sub access_runeinfo ($) {
1094 return ": dgit ".access_basedistro()." $info ;";
1097 sub access_someuserhost ($) {
1099 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1100 defined($user) && length($user) or
1101 $user = access_cfg("$some-user",'username');
1102 my $host = access_cfg("$some-host");
1103 return length($user) ? "$user\@$host" : $host;
1106 sub access_gituserhost () {
1107 return access_someuserhost('git');
1110 sub access_giturl (;$) {
1111 my ($optional) = @_;
1112 my $url = access_cfg('git-url','RETURN-UNDEF');
1115 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1116 return undef unless defined $proto;
1119 access_gituserhost().
1120 access_cfg('git-path');
1122 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1125 return "$url/$package$suffix";
1128 sub commit_getclogp ($) {
1129 # Returns the parsed changelog hashref for a particular commit
1131 our %commit_getclogp_memo;
1132 my $memo = $commit_getclogp_memo{$objid};
1133 return $memo if $memo;
1135 my $mclog = dgit_privdir()."clog";
1136 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1137 "$objid:debian/changelog";
1138 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1141 sub parse_dscdata () {
1142 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1143 printdebug Dumper($dscdata) if $debuglevel>1;
1144 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1145 printdebug Dumper($dsc) if $debuglevel>1;
1150 sub archive_query ($;@) {
1151 my ($method) = shift @_;
1152 fail __ "this operation does not support multiple comma-separated suites"
1154 my $query = access_cfg('archive-query','RETURN-UNDEF');
1155 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1158 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1161 sub archive_query_prepend_mirror {
1162 my $m = access_cfg('mirror');
1163 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1166 sub pool_dsc_subpath ($$) {
1167 my ($vsn,$component) = @_; # $package is implict arg
1168 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1169 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1172 sub cfg_apply_map ($$$) {
1173 my ($varref, $what, $mapspec) = @_;
1174 return unless $mapspec;
1176 printdebug "config $what EVAL{ $mapspec; }\n";
1178 eval "package Dgit::Config; $mapspec;";
1183 #---------- `ftpmasterapi' archive query method (nascent) ----------
1185 sub archive_api_query_cmd ($) {
1187 my @cmd = (@curl, qw(-sS));
1188 my $url = access_cfg('archive-query-url');
1189 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1191 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1192 foreach my $key (split /\:/, $keys) {
1193 $key =~ s/\%HOST\%/$host/g;
1195 fail "for $url: stat $key: $!" unless $!==ENOENT;
1198 fail f_ "config requested specific TLS key but do not know".
1199 " how to get curl to use exactly that EE key (%s)",
1201 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1202 # # Sadly the above line does not work because of changes
1203 # # to gnutls. The real fix for #790093 may involve
1204 # # new curl options.
1207 # Fixing #790093 properly will involve providing a value
1208 # for this on clients.
1209 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1210 push @cmd, split / /, $kargs if defined $kargs;
1212 push @cmd, $url.$subpath;
1216 sub api_query ($$;$) {
1218 my ($data, $subpath, $ok404) = @_;
1219 badcfg __ "ftpmasterapi archive query method takes no data part"
1221 my @cmd = archive_api_query_cmd($subpath);
1222 my $url = $cmd[$#cmd];
1223 push @cmd, qw(-w %{http_code});
1224 my $json = cmdoutput @cmd;
1225 unless ($json =~ s/\d+\d+\d$//) {
1226 failedcmd_report_cmd undef, @cmd;
1227 fail __ "curl failed to print 3-digit HTTP code";
1230 return undef if $code eq '404' && $ok404;
1231 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1232 unless $url =~ m#^file://# or $code =~ m/^2/;
1233 return decode_json($json);
1236 sub canonicalise_suite_ftpmasterapi {
1237 my ($proto,$data) = @_;
1238 my $suites = api_query($data, 'suites');
1240 foreach my $entry (@$suites) {
1242 my $v = $entry->{$_};
1243 defined $v && $v eq $isuite;
1244 } qw(codename name);
1245 push @matched, $entry;
1247 fail f_ "unknown suite %s, maybe -d would help", $isuite
1251 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1252 $cn = "$matched[0]{codename}";
1253 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1254 $cn =~ m/^$suite_re$/
1255 or die f_ "suite %s maps to bad codename\n", $isuite;
1257 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1262 sub archive_query_ftpmasterapi {
1263 my ($proto,$data) = @_;
1264 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1266 my $digester = Digest::SHA->new(256);
1267 foreach my $entry (@$info) {
1269 my $vsn = "$entry->{version}";
1270 my ($ok,$msg) = version_check $vsn;
1271 die f_ "bad version: %s\n", $msg unless $ok;
1272 my $component = "$entry->{component}";
1273 $component =~ m/^$component_re$/ or die __ "bad component";
1274 my $filename = "$entry->{filename}";
1275 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1276 or die __ "bad filename";
1277 my $sha256sum = "$entry->{sha256sum}";
1278 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1279 push @rows, [ $vsn, "/pool/$component/$filename",
1280 $digester, $sha256sum ];
1282 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1285 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1286 return archive_query_prepend_mirror @rows;
1289 sub file_in_archive_ftpmasterapi {
1290 my ($proto,$data,$filename) = @_;
1291 my $pat = $filename;
1294 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1295 my $info = api_query($data, "file_in_archive/$pat", 1);
1298 sub package_not_wholly_new_ftpmasterapi {
1299 my ($proto,$data,$pkg) = @_;
1300 my $info = api_query($data,"madison?package=${pkg}&f=json");
1304 #---------- `aptget' archive query method ----------
1307 our $aptget_releasefile;
1308 our $aptget_configpath;
1310 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1311 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1313 sub aptget_cache_clean {
1314 runcmd_ordryrun_local qw(sh -ec),
1315 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1319 sub aptget_lock_acquire () {
1320 my $lockfile = "$aptget_base/lock";
1321 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1322 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1325 sub aptget_prep ($) {
1327 return if defined $aptget_base;
1329 badcfg __ "aptget archive query method takes no data part"
1332 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1335 ensuredir "$cache/dgit";
1337 access_cfg('aptget-cachekey','RETURN-UNDEF')
1338 // access_nomdistro();
1340 $aptget_base = "$cache/dgit/aptget";
1341 ensuredir $aptget_base;
1343 my $quoted_base = $aptget_base;
1344 confess "$quoted_base contains bad chars, cannot continue"
1345 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1347 ensuredir $aptget_base;
1349 aptget_lock_acquire();
1351 aptget_cache_clean();
1353 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1354 my $sourceslist = "source.list#$cachekey";
1356 my $aptsuites = $isuite;
1357 cfg_apply_map(\$aptsuites, 'suite map',
1358 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1360 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1361 printf SRCS "deb-src %s %s %s\n",
1362 access_cfg('mirror'),
1364 access_cfg('aptget-components')
1367 ensuredir "$aptget_base/cache";
1368 ensuredir "$aptget_base/lists";
1370 open CONF, ">", $aptget_configpath or confess "$!";
1372 Debug::NoLocking "true";
1373 APT::Get::List-Cleanup "false";
1374 #clear APT::Update::Post-Invoke-Success;
1375 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1376 Dir::State::Lists "$quoted_base/lists";
1377 Dir::Etc::preferences "$quoted_base/preferences";
1378 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1379 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1382 foreach my $key (qw(
1385 Dir::Cache::Archives
1386 Dir::Etc::SourceParts
1387 Dir::Etc::preferencesparts
1389 ensuredir "$aptget_base/$key";
1390 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1393 my $oldatime = (time // confess "$!") - 1;
1394 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1395 next unless stat_exists $oldlist;
1396 my ($mtime) = (stat _)[9];
1397 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1400 runcmd_ordryrun_local aptget_aptget(), qw(update);
1403 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1404 next unless stat_exists $oldlist;
1405 my ($atime) = (stat _)[8];
1406 next if $atime == $oldatime;
1407 push @releasefiles, $oldlist;
1409 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1410 @releasefiles = @inreleasefiles if @inreleasefiles;
1411 if (!@releasefiles) {
1412 fail f_ <<END, $isuite, $cache;
1413 apt seemed to not to update dgit's cached Release files for %s.
1415 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1418 confess "apt updated too many Release files (@releasefiles), erk"
1419 unless @releasefiles == 1;
1421 ($aptget_releasefile) = @releasefiles;
1424 sub canonicalise_suite_aptget {
1425 my ($proto,$data) = @_;
1428 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1430 foreach my $name (qw(Codename Suite)) {
1431 my $val = $release->{$name};
1433 printdebug "release file $name: $val\n";
1434 $val =~ m/^$suite_re$/o or fail f_
1435 "Release file (%s) specifies intolerable %s",
1436 $aptget_releasefile, $name;
1437 cfg_apply_map(\$val, 'suite rmap',
1438 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1445 sub archive_query_aptget {
1446 my ($proto,$data) = @_;
1449 ensuredir "$aptget_base/source";
1450 foreach my $old (<$aptget_base/source/*.dsc>) {
1451 unlink $old or die "$old: $!";
1454 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1455 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1456 # avoids apt-get source failing with ambiguous error code
1458 runcmd_ordryrun_local
1459 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1460 aptget_aptget(), qw(--download-only --only-source source), $package;
1462 my @dscs = <$aptget_base/source/*.dsc>;
1463 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1464 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1467 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1470 my $uri = "file://". uri_escape $dscs[0];
1471 $uri =~ s{\%2f}{/}gi;
1472 return [ (getfield $pre_dsc, 'Version'), $uri ];
1475 sub file_in_archive_aptget () { return undef; }
1476 sub package_not_wholly_new_aptget () { return undef; }
1478 #---------- `dummyapicat' archive query method ----------
1479 # (untranslated, because this is for testing purposes etc.)
1481 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1482 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1484 sub dummycatapi_run_in_mirror ($@) {
1485 # runs $fn with FIA open onto rune
1486 my ($rune, $argl, $fn) = @_;
1488 my $mirror = access_cfg('mirror');
1489 $mirror =~ s#^file://#/# or die "$mirror ?";
1490 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1491 qw(x), $mirror, @$argl);
1492 debugcmd "-|", @cmd;
1493 open FIA, "-|", @cmd or confess "$!";
1495 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1499 sub file_in_archive_dummycatapi ($$$) {
1500 my ($proto,$data,$filename) = @_;
1502 dummycatapi_run_in_mirror '
1503 find -name "$1" -print0 |
1505 ', [$filename], sub {
1508 printdebug "| $_\n";
1509 m/^(\w+) (\S+)$/ or die "$_ ?";
1510 push @out, { sha256sum => $1, filename => $2 };
1516 sub package_not_wholly_new_dummycatapi {
1517 my ($proto,$data,$pkg) = @_;
1518 dummycatapi_run_in_mirror "
1519 find -name ${pkg}_*.dsc
1526 #---------- `madison' archive query method ----------
1528 sub archive_query_madison {
1529 return archive_query_prepend_mirror
1530 map { [ @$_[0..1] ] } madison_get_parse(@_);
1533 sub madison_get_parse {
1534 my ($proto,$data) = @_;
1535 die unless $proto eq 'madison';
1536 if (!length $data) {
1537 $data= access_cfg('madison-distro','RETURN-UNDEF');
1538 $data //= access_basedistro();
1540 $rmad{$proto,$data,$package} ||= cmdoutput
1541 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1542 my $rmad = $rmad{$proto,$data,$package};
1545 foreach my $l (split /\n/, $rmad) {
1546 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1547 \s*( [^ \t|]+ )\s* \|
1548 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1549 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1550 $1 eq $package or die "$rmad $package ?";
1557 $component = access_cfg('archive-query-default-component');
1559 $5 eq 'source' or die "$rmad ?";
1560 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1562 return sort { -version_compare($a->[0],$b->[0]); } @out;
1565 sub canonicalise_suite_madison {
1566 # madison canonicalises for us
1567 my @r = madison_get_parse(@_);
1569 "unable to canonicalise suite using package %s".
1570 " which does not appear to exist in suite %s;".
1571 " --existing-package may help",
1576 sub file_in_archive_madison { return undef; }
1577 sub package_not_wholly_new_madison { return undef; }
1579 #---------- `sshpsql' archive query method ----------
1580 # (untranslated, because this is obsolete)
1583 my ($data,$runeinfo,$sql) = @_;
1584 if (!length $data) {
1585 $data= access_someuserhost('sshpsql').':'.
1586 access_cfg('sshpsql-dbname');
1588 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1589 my ($userhost,$dbname) = ($`,$'); #';
1591 my @cmd = (access_cfg_ssh, $userhost,
1592 access_runeinfo("ssh-psql $runeinfo").
1593 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1594 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1596 open P, "-|", @cmd or confess "$!";
1599 printdebug(">|$_|\n");
1602 $!=0; $?=0; close P or failedcmd @cmd;
1604 my $nrows = pop @rows;
1605 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1606 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1607 @rows = map { [ split /\|/, $_ ] } @rows;
1608 my $ncols = scalar @{ shift @rows };
1609 die if grep { scalar @$_ != $ncols } @rows;
1613 sub sql_injection_check {
1614 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1617 sub archive_query_sshpsql ($$) {
1618 my ($proto,$data) = @_;
1619 sql_injection_check $isuite, $package;
1620 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1621 SELECT source.version, component.name, files.filename, files.sha256sum
1623 JOIN src_associations ON source.id = src_associations.source
1624 JOIN suite ON suite.id = src_associations.suite
1625 JOIN dsc_files ON dsc_files.source = source.id
1626 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1627 JOIN component ON component.id = files_archive_map.component_id
1628 JOIN files ON files.id = dsc_files.file
1629 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1630 AND source.source='$package'
1631 AND files.filename LIKE '%.dsc';
1633 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1634 my $digester = Digest::SHA->new(256);
1636 my ($vsn,$component,$filename,$sha256sum) = @$_;
1637 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1639 return archive_query_prepend_mirror @rows;
1642 sub canonicalise_suite_sshpsql ($$) {
1643 my ($proto,$data) = @_;
1644 sql_injection_check $isuite;
1645 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1646 SELECT suite.codename
1647 FROM suite where suite_name='$isuite' or codename='$isuite';
1649 @rows = map { $_->[0] } @rows;
1650 fail "unknown suite $isuite" unless @rows;
1651 die "ambiguous $isuite: @rows ?" if @rows>1;
1655 sub file_in_archive_sshpsql ($$$) { return undef; }
1656 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1658 #---------- `dummycat' archive query method ----------
1659 # (untranslated, because this is for testing purposes etc.)
1661 sub canonicalise_suite_dummycat ($$) {
1662 my ($proto,$data) = @_;
1663 my $dpath = "$data/suite.$isuite";
1664 if (!open C, "<", $dpath) {
1665 $!==ENOENT or die "$dpath: $!";
1666 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1670 chomp or die "$dpath: $!";
1672 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1676 sub archive_query_dummycat ($$) {
1677 my ($proto,$data) = @_;
1678 canonicalise_suite();
1679 my $dpath = "$data/package.$csuite.$package";
1680 if (!open C, "<", $dpath) {
1681 $!==ENOENT or die "$dpath: $!";
1682 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1690 printdebug "dummycat query $csuite $package $dpath | $_\n";
1691 my @row = split /\s+/, $_;
1692 @row==2 or die "$dpath: $_ ?";
1695 C->error and die "$dpath: $!";
1697 return archive_query_prepend_mirror
1698 sort { -version_compare($a->[0],$b->[0]); } @rows;
1701 sub file_in_archive_dummycat () { return undef; }
1702 sub package_not_wholly_new_dummycat () { return undef; }
1704 #---------- archive query entrypoints and rest of program ----------
1706 sub canonicalise_suite () {
1707 return if defined $csuite;
1708 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1709 $csuite = archive_query('canonicalise_suite');
1710 if ($isuite ne $csuite) {
1711 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1713 progress f_ "canonical suite name is %s", $csuite;
1717 sub get_archive_dsc () {
1718 canonicalise_suite();
1719 my @vsns = archive_query('archive_query');
1720 foreach my $vinfo (@vsns) {
1721 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1722 $dscurl = $vsn_dscurl;
1723 $dscdata = url_get($dscurl);
1725 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1730 $digester->add($dscdata);
1731 my $got = $digester->hexdigest();
1733 fail f_ "%s has hash %s but archive told us to expect %s",
1734 $dscurl, $got, $digest;
1737 my $fmt = getfield $dsc, 'Format';
1738 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1739 f_ "unsupported source format %s, sorry", $fmt;
1741 $dsc_checked = !!$digester;
1742 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1746 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1749 sub check_for_git ();
1750 sub check_for_git () {
1752 my $how = access_cfg('git-check');
1753 if ($how eq 'ssh-cmd') {
1755 (access_cfg_ssh, access_gituserhost(),
1756 access_runeinfo("git-check $package").
1757 " set -e; cd ".access_cfg('git-path').";".
1758 " if test -d $package.git; then echo 1; else echo 0; fi");
1759 my $r= cmdoutput @cmd;
1760 if (defined $r and $r =~ m/^divert (\w+)$/) {
1762 my ($usedistro,) = access_distros();
1763 # NB that if we are pushing, $usedistro will be $distro/push
1764 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1765 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1766 progress f_ "diverting to %s (using config for %s)",
1767 $divert, $instead_distro;
1768 return check_for_git();
1770 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1772 } elsif ($how eq 'url') {
1773 my $prefix = access_cfg('git-check-url','git-url');
1774 my $suffix = access_cfg('git-check-suffix','git-suffix',
1775 'RETURN-UNDEF') // '.git';
1776 my $url = "$prefix/$package$suffix";
1777 my @cmd = (@curl, qw(-sS -I), $url);
1778 my $result = cmdoutput @cmd;
1779 $result =~ s/^\S+ 200 .*\n\r?\n//;
1780 # curl -sS -I with https_proxy prints
1781 # HTTP/1.0 200 Connection established
1782 $result =~ m/^\S+ (404|200) /s or
1783 fail +(__ "unexpected results from git check query - ").
1784 Dumper($prefix, $result);
1786 if ($code eq '404') {
1788 } elsif ($code eq '200') {
1793 } elsif ($how eq 'true') {
1795 } elsif ($how eq 'false') {
1798 badcfg f_ "unknown git-check \`%s'", $how;
1802 sub create_remote_git_repo () {
1803 my $how = access_cfg('git-create');
1804 if ($how eq 'ssh-cmd') {
1806 (access_cfg_ssh, access_gituserhost(),
1807 access_runeinfo("git-create $package").
1808 "set -e; cd ".access_cfg('git-path').";".
1809 " cp -a _template $package.git");
1810 } elsif ($how eq 'true') {
1813 badcfg f_ "unknown git-create \`%s'", $how;
1817 our ($dsc_hash,$lastpush_mergeinput);
1818 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1822 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1823 $playground = fresh_playground 'dgit/unpack';
1826 sub mktree_in_ud_here () {
1827 playtree_setup $gitcfgs{local};
1830 sub git_write_tree () {
1831 my $tree = cmdoutput @git, qw(write-tree);
1832 $tree =~ m/^\w+$/ or die "$tree ?";
1836 sub git_add_write_tree () {
1837 runcmd @git, qw(add -Af .);
1838 return git_write_tree();
1841 sub remove_stray_gits ($) {
1843 my @gitscmd = qw(find -name .git -prune -print0);
1844 debugcmd "|",@gitscmd;
1845 open GITS, "-|", @gitscmd or confess "$!";
1850 print STDERR f_ "%s: warning: removing from %s: %s\n",
1851 $us, $what, (messagequote $_);
1855 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1858 sub mktree_in_ud_from_only_subdir ($;$) {
1859 my ($what,$raw) = @_;
1860 # changes into the subdir
1863 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1864 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1868 remove_stray_gits($what);
1869 mktree_in_ud_here();
1871 my ($format, $fopts) = get_source_format();
1872 if (madformat($format)) {
1877 my $tree=git_add_write_tree();
1878 return ($tree,$dir);
1881 our @files_csum_info_fields =
1882 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1883 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1884 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1886 sub dsc_files_info () {
1887 foreach my $csumi (@files_csum_info_fields) {
1888 my ($fname, $module, $method) = @$csumi;
1889 my $field = $dsc->{$fname};
1890 next unless defined $field;
1891 eval "use $module; 1;" or die $@;
1893 foreach (split /\n/, $field) {
1895 m/^(\w+) (\d+) (\S+)$/ or
1896 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1897 my $digester = eval "$module"."->$method;" or die $@;
1902 Digester => $digester,
1907 fail f_ "missing any supported Checksums-* or Files field in %s",
1908 $dsc->get_option('name');
1912 map { $_->{Filename} } dsc_files_info();
1915 sub files_compare_inputs (@) {
1920 my $showinputs = sub {
1921 return join "; ", map { $_->get_option('name') } @$inputs;
1924 foreach my $in (@$inputs) {
1926 my $in_name = $in->get_option('name');
1928 printdebug "files_compare_inputs $in_name\n";
1930 foreach my $csumi (@files_csum_info_fields) {
1931 my ($fname) = @$csumi;
1932 printdebug "files_compare_inputs $in_name $fname\n";
1934 my $field = $in->{$fname};
1935 next unless defined $field;
1938 foreach (split /\n/, $field) {
1941 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1942 fail "could not parse $in_name $fname line \`$_'";
1944 printdebug "files_compare_inputs $in_name $fname $f\n";
1948 my $re = \ $record{$f}{$fname};
1950 $fchecked{$f}{$in_name} = 1;
1953 "hash or size of %s varies in %s fields (between: %s)",
1954 $f, $fname, $showinputs->();
1959 @files = sort @files;
1960 $expected_files //= \@files;
1961 "@$expected_files" eq "@files" or
1962 fail f_ "file list in %s varies between hash fields!",
1966 fail f_ "%s has no files list field(s)", $in_name;
1968 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1971 grep { keys %$_ == @$inputs-1 } values %fchecked
1972 or fail f_ "no file appears in all file lists (looked in: %s)",
1976 sub is_orig_file_in_dsc ($$) {
1977 my ($f, $dsc_files_info) = @_;
1978 return 0 if @$dsc_files_info <= 1;
1979 # One file means no origs, and the filename doesn't have a "what
1980 # part of dsc" component. (Consider versions ending `.orig'.)
1981 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1985 # This function determines whether a .changes file is source-only from
1986 # the point of view of dak. Thus, it permits *_source.buildinfo
1989 # It does not, however, permit any other buildinfo files. After a
1990 # source-only upload, the buildds will try to upload files like
1991 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1992 # named like this in their (otherwise) source-only upload, the uploads
1993 # of the buildd can be rejected by dak. Fixing the resultant
1994 # situation can require manual intervention. So we block such
1995 # .buildinfo files when the user tells us to perform a source-only
1996 # upload (such as when using the push-source subcommand with the -C
1997 # option, which calls this function).
1999 # Note, though, that when dgit is told to prepare a source-only
2000 # upload, such as when subcommands like build-source and push-source
2001 # without -C are used, dgit has a more restrictive notion of
2002 # source-only .changes than dak: such uploads will never include
2003 # *_source.buildinfo files. This is because there is no use for such
2004 # files when using a tool like dgit to produce the source package, as
2005 # dgit ensures the source is identical to git HEAD.
2006 sub test_source_only_changes ($) {
2008 foreach my $l (split /\n/, getfield $changes, 'Files') {
2009 $l =~ m/\S+$/ or next;
2010 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2011 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
2012 print f_ "purportedly source-only changes polluted by %s\n", $&;
2019 sub changes_update_origs_from_dsc ($$$$) {
2020 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2022 printdebug "checking origs needed ($upstreamvsn)...\n";
2023 $_ = getfield $changes, 'Files';
2024 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2025 fail __ "cannot find section/priority from .changes Files field";
2026 my $placementinfo = $1;
2028 printdebug "checking origs needed placement '$placementinfo'...\n";
2029 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2030 $l =~ m/\S+$/ or next;
2032 printdebug "origs $file | $l\n";
2033 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2034 printdebug "origs $file is_orig\n";
2035 my $have = archive_query('file_in_archive', $file);
2036 if (!defined $have) {
2037 print STDERR __ <<END;
2038 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2044 printdebug "origs $file \$#\$have=$#$have\n";
2045 foreach my $h (@$have) {
2048 foreach my $csumi (@files_csum_info_fields) {
2049 my ($fname, $module, $method, $archivefield) = @$csumi;
2050 next unless defined $h->{$archivefield};
2051 $_ = $dsc->{$fname};
2052 next unless defined;
2053 m/^(\w+) .* \Q$file\E$/m or
2054 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2055 if ($h->{$archivefield} eq $1) {
2059 "%s: %s (archive) != %s (local .dsc)",
2060 $archivefield, $h->{$archivefield}, $1;
2063 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2067 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2070 printdebug "origs $file f.same=$found_same".
2071 " #f._differ=$#found_differ\n";
2072 if (@found_differ && !$found_same) {
2074 (f_ "archive contains %s with different checksum", $file),
2077 # Now we edit the changes file to add or remove it
2078 foreach my $csumi (@files_csum_info_fields) {
2079 my ($fname, $module, $method, $archivefield) = @$csumi;
2080 next unless defined $changes->{$fname};
2082 # in archive, delete from .changes if it's there
2083 $changed{$file} = "removed" if
2084 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2085 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2086 # not in archive, but it's here in the .changes
2088 my $dsc_data = getfield $dsc, $fname;
2089 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2091 $extra =~ s/ \d+ /$&$placementinfo /
2092 or confess "$fname $extra >$dsc_data< ?"
2093 if $fname eq 'Files';
2094 $changes->{$fname} .= "\n". $extra;
2095 $changed{$file} = "added";
2100 foreach my $file (keys %changed) {
2102 "edited .changes for archive .orig contents: %s %s",
2103 $changed{$file}, $file;
2105 my $chtmp = "$changesfile.tmp";
2106 $changes->save($chtmp);
2108 rename $chtmp,$changesfile or die "$changesfile $!";
2110 progress f_ "[new .changes left in %s]", $changesfile;
2113 progress f_ "%s already has appropriate .orig(s) (if any)",
2118 sub clogp_authline ($) {
2120 my $author = getfield $clogp, 'Maintainer';
2121 if ($author =~ m/^[^"\@]+\,/) {
2122 # single entry Maintainer field with unquoted comma
2123 $author = ($& =~ y/,//rd).$'; # strip the comma
2125 # git wants a single author; any remaining commas in $author
2126 # are by now preceded by @ (or "). It seems safer to punt on
2127 # "..." for now rather than attempting to dequote or something.
2128 $author =~ s#,.*##ms unless $author =~ m/"/;
2129 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2130 my $authline = "$author $date";
2131 $authline =~ m/$git_authline_re/o or
2132 fail f_ "unexpected commit author line format \`%s'".
2133 " (was generated from changelog Maintainer field)",
2135 return ($1,$2,$3) if wantarray;
2139 sub vendor_patches_distro ($$) {
2140 my ($checkdistro, $what) = @_;
2141 return unless defined $checkdistro;
2143 my $series = "debian/patches/\L$checkdistro\E.series";
2144 printdebug "checking for vendor-specific $series ($what)\n";
2146 if (!open SERIES, "<", $series) {
2147 confess "$series $!" unless $!==ENOENT;
2154 print STDERR __ <<END;
2156 Unfortunately, this source package uses a feature of dpkg-source where
2157 the same source package unpacks to different source code on different
2158 distros. dgit cannot safely operate on such packages on affected
2159 distros, because the meaning of source packages is not stable.
2161 Please ask the distro/maintainer to remove the distro-specific series
2162 files and use a different technique (if necessary, uploading actually
2163 different packages, if different distros are supposed to have
2167 fail f_ "Found active distro-specific series file for".
2168 " %s (%s): %s, cannot continue",
2169 $checkdistro, $what, $series;
2171 die "$series $!" if SERIES->error;
2175 sub check_for_vendor_patches () {
2176 # This dpkg-source feature doesn't seem to be documented anywhere!
2177 # But it can be found in the changelog (reformatted):
2179 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2180 # Author: Raphael Hertzog <hertzog@debian.org>
2181 # Date: Sun Oct 3 09:36:48 2010 +0200
2183 # dpkg-source: correctly create .pc/.quilt_series with alternate
2186 # If you have debian/patches/ubuntu.series and you were
2187 # unpacking the source package on ubuntu, quilt was still
2188 # directed to debian/patches/series instead of
2189 # debian/patches/ubuntu.series.
2191 # debian/changelog | 3 +++
2192 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2193 # 2 files changed, 6 insertions(+), 1 deletion(-)
2196 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2197 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2198 __ "Dpkg::Vendor \`current vendor'");
2199 vendor_patches_distro(access_basedistro(),
2200 __ "(base) distro being accessed");
2201 vendor_patches_distro(access_nomdistro(),
2202 __ "(nominal) distro being accessed");
2205 sub check_bpd_exists () {
2206 stat $buildproductsdir
2207 or fail f_ "build-products-dir %s is not accessible: %s\n",
2208 $buildproductsdir, $!;
2211 sub dotdot_bpd_transfer_origs ($$$) {
2212 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2213 # checks is_orig_file_of_vsn and if
2214 # calls $wanted->{$leaf} and expects boolish
2216 return if $buildproductsdir eq '..';
2219 my $dotdot = $maindir;
2220 $dotdot =~ s{/[^/]+$}{};
2221 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2222 while ($!=0, defined(my $leaf = readdir DD)) {
2224 local ($debuglevel) = $debuglevel-1;
2225 printdebug "DD_BPD $leaf ?\n";
2227 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2228 next unless $wanted->($leaf);
2229 next if lstat "$bpd_abs/$leaf";
2232 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2235 $! == &ENOENT or fail f_
2236 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2237 lstat "$dotdot/$leaf" or fail f_
2238 "check orig file %s in ..: %s", $leaf, $!;
2240 stat "$dotdot/$leaf" or fail f_
2241 "check target of orig symlink %s in ..: %s", $leaf, $!;
2242 my $ltarget = readlink "$dotdot/$leaf" or
2243 die "readlink $dotdot/$leaf: $!";
2244 if ($ltarget !~ m{^/}) {
2245 $ltarget = "$dotdot/$ltarget";
2247 symlink $ltarget, "$bpd_abs/$leaf"
2248 or die "$ltarget $bpd_abs $leaf: $!";
2250 "%s: cloned orig symlink from ..: %s\n",
2252 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2254 "%s: hardlinked orig from ..: %s\n",
2256 } elsif ($! != EXDEV) {
2257 fail f_ "failed to make %s a hardlink to %s: %s",
2258 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2260 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2261 or die "$bpd_abs $dotdot $leaf $!";
2263 "%s: symmlinked orig from .. on other filesystem: %s\n",
2267 die "$dotdot; $!" if $!;
2271 sub generate_commits_from_dsc () {
2272 # See big comment in fetch_from_archive, below.
2273 # See also README.dsc-import.
2275 changedir $playground;
2277 my $bpd_abs = bpd_abs();
2278 my $upstreamv = upstreamversion $dsc->{version};
2279 my @dfi = dsc_files_info();
2281 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2282 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2284 foreach my $fi (@dfi) {
2285 my $f = $fi->{Filename};
2286 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2287 my $upper_f = "$bpd_abs/$f";
2289 printdebug "considering reusing $f: ";
2291 if (link_ltarget "$upper_f,fetch", $f) {
2292 printdebug "linked (using ...,fetch).\n";
2293 } elsif ((printdebug "($!) "),
2295 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2296 } elsif (link_ltarget $upper_f, $f) {
2297 printdebug "linked.\n";
2298 } elsif ((printdebug "($!) "),
2300 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2302 printdebug "absent.\n";
2306 complete_file_from_dsc('.', $fi, \$refetched)
2309 printdebug "considering saving $f: ";
2311 if (rename_link_xf 1, $f, $upper_f) {
2312 printdebug "linked.\n";
2313 } elsif ((printdebug "($@) "),
2315 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2316 } elsif (!$refetched) {
2317 printdebug "no need.\n";
2318 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2319 printdebug "linked (using ...,fetch).\n";
2320 } elsif ((printdebug "($@) "),
2322 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2324 printdebug "cannot.\n";
2328 # We unpack and record the orig tarballs first, so that we only
2329 # need disk space for one private copy of the unpacked source.
2330 # But we can't make them into commits until we have the metadata
2331 # from the debian/changelog, so we record the tree objects now and
2332 # make them into commits later.
2334 my $orig_f_base = srcfn $upstreamv, '';
2336 foreach my $fi (@dfi) {
2337 # We actually import, and record as a commit, every tarball
2338 # (unless there is only one file, in which case there seems
2341 my $f = $fi->{Filename};
2342 printdebug "import considering $f ";
2343 (printdebug "only one dfi\n"), next if @dfi == 1;
2344 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2345 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2349 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2351 printdebug "Y ", (join ' ', map { $_//"(none)" }
2352 $compr_ext, $orig_f_part
2355 my $input = new IO::File $f, '<' or die "$f $!";
2359 if (defined $compr_ext) {
2361 Dpkg::Compression::compression_guess_from_filename $f;
2362 fail "Dpkg::Compression cannot handle file $f in source package"
2363 if defined $compr_ext && !defined $cname;
2365 new Dpkg::Compression::Process compression => $cname;
2366 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2367 my $compr_fh = new IO::Handle;
2368 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2370 open STDIN, "<&", $input or confess "$!";
2372 die "dgit (child): exec $compr_cmd[0]: $!\n";
2377 rmtree "_unpack-tar";
2378 mkdir "_unpack-tar" or confess "$!";
2379 my @tarcmd = qw(tar -x -f -
2380 --no-same-owner --no-same-permissions
2381 --no-acls --no-xattrs --no-selinux);
2382 my $tar_pid = fork // confess "$!";
2384 chdir "_unpack-tar" or confess "$!";
2385 open STDIN, "<&", $input or confess "$!";
2387 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2389 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2390 !$? or failedcmd @tarcmd;
2393 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2395 # finally, we have the results in "tarball", but maybe
2396 # with the wrong permissions
2398 runcmd qw(chmod -R +rwX _unpack-tar);
2399 changedir "_unpack-tar";
2400 remove_stray_gits($f);
2401 mktree_in_ud_here();
2403 my ($tree) = git_add_write_tree();
2404 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2405 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2407 printdebug "one subtree $1\n";
2409 printdebug "multiple subtrees\n";
2412 rmtree "_unpack-tar";
2414 my $ent = [ $f, $tree ];
2416 Orig => !!$orig_f_part,
2417 Sort => (!$orig_f_part ? 2 :
2418 $orig_f_part =~ m/-/g ? 1 :
2426 # put any without "_" first (spec is not clear whether files
2427 # are always in the usual order). Tarballs without "_" are
2428 # the main orig or the debian tarball.
2429 $a->{Sort} <=> $b->{Sort} or
2433 my $any_orig = grep { $_->{Orig} } @tartrees;
2435 my $dscfn = "$package.dsc";
2437 my $treeimporthow = 'package';
2439 open D, ">", $dscfn or die "$dscfn: $!";
2440 print D $dscdata or die "$dscfn: $!";
2441 close D or die "$dscfn: $!";
2442 my @cmd = qw(dpkg-source);
2443 push @cmd, '--no-check' if $dsc_checked;
2444 if (madformat $dsc->{format}) {
2445 push @cmd, '--skip-patches';
2446 $treeimporthow = 'unpatched';
2448 push @cmd, qw(-x --), $dscfn;
2451 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2452 if (madformat $dsc->{format}) {
2453 check_for_vendor_patches();
2457 if (madformat $dsc->{format}) {
2458 my @pcmd = qw(dpkg-source --before-build .);
2459 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2461 $dappliedtree = git_add_write_tree();
2464 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2468 printdebug "import clog search...\n";
2469 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2470 my ($thisstanza, $desc) = @_;
2471 no warnings qw(exiting);
2473 $clogp //= $thisstanza;
2475 printdebug "import clog $thisstanza->{version} $desc...\n";
2477 last if !$any_orig; # we don't need $r1clogp
2479 # We look for the first (most recent) changelog entry whose
2480 # version number is lower than the upstream version of this
2481 # package. Then the last (least recent) previous changelog
2482 # entry is treated as the one which introduced this upstream
2483 # version and used for the synthetic commits for the upstream
2486 # One might think that a more sophisticated algorithm would be
2487 # necessary. But: we do not want to scan the whole changelog
2488 # file. Stopping when we see an earlier version, which
2489 # necessarily then is an earlier upstream version, is the only
2490 # realistic way to do that. Then, either the earliest
2491 # changelog entry we have seen so far is indeed the earliest
2492 # upload of this upstream version; or there are only changelog
2493 # entries relating to later upstream versions (which is not
2494 # possible unless the changelog and .dsc disagree about the
2495 # version). Then it remains to choose between the physically
2496 # last entry in the file, and the one with the lowest version
2497 # number. If these are not the same, we guess that the
2498 # versions were created in a non-monotonic order rather than
2499 # that the changelog entries have been misordered.
2501 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2503 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2504 $r1clogp = $thisstanza;
2506 printdebug "import clog $r1clogp->{version} becomes r1\n";
2509 $clogp or fail __ "package changelog has no entries!";
2511 my $authline = clogp_authline $clogp;
2512 my $changes = getfield $clogp, 'Changes';
2513 $changes =~ s/^\n//; # Changes: \n
2514 my $cversion = getfield $clogp, 'Version';
2517 $r1clogp //= $clogp; # maybe there's only one entry;
2518 my $r1authline = clogp_authline $r1clogp;
2519 # Strictly, r1authline might now be wrong if it's going to be
2520 # unused because !$any_orig. Whatever.
2522 printdebug "import tartrees authline $authline\n";
2523 printdebug "import tartrees r1authline $r1authline\n";
2525 foreach my $tt (@tartrees) {
2526 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2528 my $mbody = f_ "Import %s", $tt->{F};
2529 $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2532 committer $r1authline
2536 [dgit import orig $tt->{F}]
2544 [dgit import tarball $package $cversion $tt->{F}]
2549 printdebug "import main commit\n";
2551 open C, ">../commit.tmp" or confess "$!";
2552 print C <<END or confess "$!";
2555 print C <<END or confess "$!" foreach @tartrees;
2558 print C <<END or confess "$!";
2564 [dgit import $treeimporthow $package $cversion]
2567 close C or confess "$!";
2568 my $rawimport_hash = hash_commit qw(../commit.tmp);
2570 if (madformat $dsc->{format}) {
2571 printdebug "import apply patches...\n";
2573 # regularise the state of the working tree so that
2574 # the checkout of $rawimport_hash works nicely.
2575 my $dappliedcommit = hash_commit_text(<<END);
2582 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2584 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2586 # We need the answers to be reproducible
2587 my @authline = clogp_authline($clogp);
2588 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2589 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2590 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2591 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2592 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2593 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2595 my $path = $ENV{PATH} or die;
2597 # we use ../../gbp-pq-output, which (given that we are in
2598 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2601 foreach my $use_absurd (qw(0 1)) {
2602 runcmd @git, qw(checkout -q unpa);
2603 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2604 local $ENV{PATH} = $path;
2607 progress "warning: $@";
2608 $path = "$absurdity:$path";
2609 progress f_ "%s: trying slow absurd-git-apply...", $us;
2610 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2615 die "forbid absurd git-apply\n" if $use_absurd
2616 && forceing [qw(import-gitapply-no-absurd)];
2617 die "only absurd git-apply!\n" if !$use_absurd
2618 && forceing [qw(import-gitapply-absurd)];
2620 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2621 local $ENV{PATH} = $path if $use_absurd;
2623 my @showcmd = (gbp_pq, qw(import));
2624 my @realcmd = shell_cmd
2625 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2626 debugcmd "+",@realcmd;
2627 if (system @realcmd) {
2628 die f_ "%s failed: %s\n",
2629 +(shellquote @showcmd),
2630 failedcmd_waitstatus();
2633 my $gapplied = git_rev_parse('HEAD');
2634 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2635 $gappliedtree eq $dappliedtree or
2636 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2637 gbp-pq import and dpkg-source disagree!
2638 gbp-pq import gave commit %s
2639 gbp-pq import gave tree %s
2640 dpkg-source --before-build gave tree %s
2642 $rawimport_hash = $gapplied;
2647 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2652 progress f_ "synthesised git commit from .dsc %s", $cversion;
2654 my $rawimport_mergeinput = {
2655 Commit => $rawimport_hash,
2656 Info => __ "Import of source package",
2658 my @output = ($rawimport_mergeinput);
2660 if ($lastpush_mergeinput) {
2661 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2662 my $oversion = getfield $oldclogp, 'Version';
2664 version_compare($oversion, $cversion);
2666 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2667 { ReverseParents => 1,
2668 Message => (f_ <<END, $package, $cversion, $csuite) });
2669 Record %s (%s) in archive suite %s
2671 } elsif ($vcmp > 0) {
2672 print STDERR f_ <<END, $cversion, $oversion,
2674 Version actually in archive: %s (older)
2675 Last version pushed with dgit: %s (newer or same)
2678 __ $later_warning_msg or confess "$!";
2679 @output = $lastpush_mergeinput;
2681 # Same version. Use what's in the server git branch,
2682 # discarding our own import. (This could happen if the
2683 # server automatically imports all packages into git.)
2684 @output = $lastpush_mergeinput;
2692 sub complete_file_from_dsc ($$;$) {
2693 our ($dstdir, $fi, $refetched) = @_;
2694 # Ensures that we have, in $dstdir, the file $fi, with the correct
2695 # contents. (Downloading it from alongside $dscurl if necessary.)
2696 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2697 # and will set $$refetched=1 if it did so (or tried to).
2699 my $f = $fi->{Filename};
2700 my $tf = "$dstdir/$f";
2704 my $checkhash = sub {
2705 open F, "<", "$tf" or die "$tf: $!";
2706 $fi->{Digester}->reset();
2707 $fi->{Digester}->addfile(*F);
2708 F->error and confess "$!";
2709 $got = $fi->{Digester}->hexdigest();
2710 return $got eq $fi->{Hash};
2713 if (stat_exists $tf) {
2714 if ($checkhash->()) {
2715 progress f_ "using existing %s", $f;
2719 fail f_ "file %s has hash %s but .dsc demands hash %s".
2720 " (perhaps you should delete this file?)",
2721 $f, $got, $fi->{Hash};
2723 progress f_ "need to fetch correct version of %s", $f;
2724 unlink $tf or die "$tf $!";
2727 printdebug "$tf does not exist, need to fetch\n";
2731 $furl =~ s{/[^/]+$}{};
2733 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2734 die "$f ?" if $f =~ m#/#;
2735 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2736 return 0 if !act_local();
2739 fail f_ "file %s has hash %s but .dsc demands hash %s".
2740 " (got wrong file from archive!)",
2741 $f, $got, $fi->{Hash};
2746 sub ensure_we_have_orig () {
2747 my @dfi = dsc_files_info();
2748 foreach my $fi (@dfi) {
2749 my $f = $fi->{Filename};
2750 next unless is_orig_file_in_dsc($f, \@dfi);
2751 complete_file_from_dsc($buildproductsdir, $fi)
2756 #---------- git fetch ----------
2758 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2759 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2761 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2762 # locally fetched refs because they have unhelpful names and clutter
2763 # up gitk etc. So we track whether we have "used up" head ref (ie,
2764 # whether we have made another local ref which refers to this object).
2766 # (If we deleted them unconditionally, then we might end up
2767 # re-fetching the same git objects each time dgit fetch was run.)
2769 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2770 # in git_fetch_us to fetch the refs in question, and possibly a call
2771 # to lrfetchref_used.
2773 our (%lrfetchrefs_f, %lrfetchrefs_d);
2774 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2776 sub lrfetchref_used ($) {
2777 my ($fullrefname) = @_;
2778 my $objid = $lrfetchrefs_f{$fullrefname};
2779 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2782 sub git_lrfetch_sane {
2783 my ($url, $supplementary, @specs) = @_;
2784 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2785 # at least as regards @specs. Also leave the results in
2786 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2787 # able to clean these up.
2789 # With $supplementary==1, @specs must not contain wildcards
2790 # and we add to our previous fetches (non-atomically).
2792 # This is rather miserable:
2793 # When git fetch --prune is passed a fetchspec ending with a *,
2794 # it does a plausible thing. If there is no * then:
2795 # - it matches subpaths too, even if the supplied refspec
2796 # starts refs, and behaves completely madly if the source
2797 # has refs/refs/something. (See, for example, Debian #NNNN.)
2798 # - if there is no matching remote ref, it bombs out the whole
2800 # We want to fetch a fixed ref, and we don't know in advance
2801 # if it exists, so this is not suitable.
2803 # Our workaround is to use git ls-remote. git ls-remote has its
2804 # own qairks. Notably, it has the absurd multi-tail-matching
2805 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2806 # refs/refs/foo etc.
2808 # Also, we want an idempotent snapshot, but we have to make two
2809 # calls to the remote: one to git ls-remote and to git fetch. The
2810 # solution is use git ls-remote to obtain a target state, and
2811 # git fetch to try to generate it. If we don't manage to generate
2812 # the target state, we try again.
2814 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2816 my $specre = join '|', map {
2819 my $wildcard = $x =~ s/\\\*$/.*/;
2820 die if $wildcard && $supplementary;
2823 printdebug "git_lrfetch_sane specre=$specre\n";
2824 my $wanted_rref = sub {
2826 return m/^(?:$specre)$/;
2829 my $fetch_iteration = 0;
2832 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2833 if (++$fetch_iteration > 10) {
2834 fail __ "too many iterations trying to get sane fetch!";
2837 my @look = map { "refs/$_" } @specs;
2838 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2842 open GITLS, "-|", @lcmd or confess "$!";
2844 printdebug "=> ", $_;
2845 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2846 my ($objid,$rrefname) = ($1,$2);
2847 if (!$wanted_rref->($rrefname)) {
2848 print STDERR f_ <<END, "@look", $rrefname;
2849 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2853 $wantr{$rrefname} = $objid;
2856 close GITLS or failedcmd @lcmd;
2858 # OK, now %want is exactly what we want for refs in @specs
2860 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2861 "+refs/$_:".lrfetchrefs."/$_";
2864 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2866 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2867 runcmd_ordryrun_local @fcmd if @fspecs;
2869 if (!$supplementary) {
2870 %lrfetchrefs_f = ();
2874 git_for_each_ref(lrfetchrefs, sub {
2875 my ($objid,$objtype,$lrefname,$reftail) = @_;
2876 $lrfetchrefs_f{$lrefname} = $objid;
2877 $objgot{$objid} = 1;
2880 if ($supplementary) {
2884 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2885 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2886 if (!exists $wantr{$rrefname}) {
2887 if ($wanted_rref->($rrefname)) {
2889 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2892 print STDERR f_ <<END, "@fspecs", $lrefname
2893 warning: git fetch %s created %s; this is silly, deleting it.
2896 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2897 delete $lrfetchrefs_f{$lrefname};
2901 foreach my $rrefname (sort keys %wantr) {
2902 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2903 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2904 my $want = $wantr{$rrefname};
2905 next if $got eq $want;
2906 if (!defined $objgot{$want}) {
2907 fail __ <<END unless act_local();
2908 --dry-run specified but we actually wanted the results of git fetch,
2909 so this is not going to work. Try running dgit fetch first,
2910 or using --damp-run instead of --dry-run.
2912 print STDERR f_ <<END, $lrefname, $want;
2913 warning: git ls-remote suggests we want %s
2914 warning: and it should refer to %s
2915 warning: but git fetch didn't fetch that object to any relevant ref.
2916 warning: This may be due to a race with someone updating the server.
2917 warning: Will try again...
2919 next FETCH_ITERATION;
2922 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2924 runcmd_ordryrun_local @git, qw(update-ref -m),
2925 "dgit fetch git fetch fixup", $lrefname, $want;
2926 $lrfetchrefs_f{$lrefname} = $want;
2931 if (defined $csuite) {
2932 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2933 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2934 my ($objid,$objtype,$lrefname,$reftail) = @_;
2935 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2936 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2940 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2941 Dumper(\%lrfetchrefs_f);
2944 sub git_fetch_us () {
2945 # Want to fetch only what we are going to use, unless
2946 # deliberately-not-ff, in which case we must fetch everything.
2948 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2949 map { "tags/$_" } debiantags('*',access_nomdistro);
2950 push @specs, server_branch($csuite);
2951 push @specs, $rewritemap;
2952 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2954 my $url = access_giturl();
2955 git_lrfetch_sane $url, 0, @specs;
2958 my @tagpats = debiantags('*',access_nomdistro);
2960 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2961 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2962 printdebug "currently $fullrefname=$objid\n";
2963 $here{$fullrefname} = $objid;
2965 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2966 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2967 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2968 printdebug "offered $lref=$objid\n";
2969 if (!defined $here{$lref}) {
2970 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2971 runcmd_ordryrun_local @upd;
2972 lrfetchref_used $fullrefname;
2973 } elsif ($here{$lref} eq $objid) {
2974 lrfetchref_used $fullrefname;
2976 print STDERR f_ "Not updating %s from %s to %s.\n",
2977 $lref, $here{$lref}, $objid;
2982 #---------- dsc and archive handling ----------
2984 sub mergeinfo_getclogp ($) {
2985 # Ensures thit $mi->{Clogp} exists and returns it
2987 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2990 sub mergeinfo_version ($) {
2991 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2994 sub fetch_from_archive_record_1 ($) {
2996 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2997 cmdoutput @git, qw(log -n2), $hash;
2998 # ... gives git a chance to complain if our commit is malformed
3001 sub fetch_from_archive_record_2 ($) {
3003 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3007 dryrun_report @upd_cmd;
3011 sub parse_dsc_field_def_dsc_distro () {
3012 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3013 dgit.default.distro);
3016 sub parse_dsc_field ($$) {
3017 my ($dsc, $what) = @_;
3019 foreach my $field (@ourdscfield) {
3020 $f = $dsc->{$field};
3025 progress f_ "%s: NO git hash", $what;
3026 parse_dsc_field_def_dsc_distro();
3027 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3028 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3029 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3030 $dsc_hint_tag = [ $dsc_hint_tag ];
3031 } elsif ($f =~ m/^\w+\s*$/) {
3033 parse_dsc_field_def_dsc_distro();
3034 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3036 progress f_ "%s: specified git hash", $what;
3038 fail f_ "%s: invalid Dgit info", $what;
3042 sub resolve_dsc_field_commit ($$) {
3043 my ($already_distro, $already_mapref) = @_;
3045 return unless defined $dsc_hash;
3048 defined $already_mapref &&
3049 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3050 ? $already_mapref : undef;
3054 my ($what, @fetch) = @_;
3056 local $idistro = $dsc_distro;
3057 my $lrf = lrfetchrefs;
3059 if (!$chase_dsc_distro) {
3060 progress f_ "not chasing .dsc distro %s: not fetching %s",
3065 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3067 my $url = access_giturl();
3068 if (!defined $url) {
3069 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3070 .dsc Dgit metadata is in context of distro %s
3071 for which we have no configured url and .dsc provides no hint
3074 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3075 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3076 parse_cfg_bool "dsc-url-proto-ok", 'false',
3077 cfg("dgit.dsc-url-proto-ok.$proto",
3078 "dgit.default.dsc-url-proto-ok")
3079 or fail f_ <<END, $dsc_distro, $proto;
3080 .dsc Dgit metadata is in context of distro %s
3081 for which we have no configured url;
3082 .dsc provides hinted url with protocol %s which is unsafe.
3083 (can be overridden by config - consult documentation)
3085 $url = $dsc_hint_url;
3088 git_lrfetch_sane $url, 1, @fetch;
3093 my $rewrite_enable = do {
3094 local $idistro = $dsc_distro;
3095 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3098 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3099 if (!defined $mapref) {
3100 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3101 $mapref = $lrf.'/'.$rewritemap;
3103 my $rewritemapdata = git_cat_file $mapref.':map';
3104 if (defined $rewritemapdata
3105 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3107 "server's git history rewrite map contains a relevant entry!";
3110 if (defined $dsc_hash) {
3111 progress __ "using rewritten git hash in place of .dsc value";
3113 progress __ "server data says .dsc hash is to be disregarded";
3118 if (!defined git_cat_file $dsc_hash) {
3119 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3120 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3121 defined git_cat_file $dsc_hash
3122 or fail f_ <<END, $dsc_hash;
3123 .dsc Dgit metadata requires commit %s
3124 but we could not obtain that object anywhere.
3126 foreach my $t (@tags) {
3127 my $fullrefname = $lrf.'/'.$t;
3128 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3129 next unless $lrfetchrefs_f{$fullrefname};
3130 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3131 lrfetchref_used $fullrefname;
3136 sub fetch_from_archive () {
3138 ensure_setup_existing_tree();
3140 # Ensures that lrref() is what is actually in the archive, one way
3141 # or another, according to us - ie this client's
3142 # appropritaely-updated archive view. Also returns the commit id.
3143 # If there is nothing in the archive, leaves lrref alone and
3144 # returns undef. git_fetch_us must have already been called.
3148 parse_dsc_field($dsc, __ 'last upload to archive');
3149 resolve_dsc_field_commit access_basedistro,
3150 lrfetchrefs."/".$rewritemap
3152 progress __ "no version available from the archive";
3155 # If the archive's .dsc has a Dgit field, there are three
3156 # relevant git commitids we need to choose between and/or merge
3158 # 1. $dsc_hash: the Dgit field from the archive
3159 # 2. $lastpush_hash: the suite branch on the dgit git server
3160 # 3. $lastfetch_hash: our local tracking brach for the suite
3162 # These may all be distinct and need not be in any fast forward
3165 # If the dsc was pushed to this suite, then the server suite
3166 # branch will have been updated; but it might have been pushed to
3167 # a different suite and copied by the archive. Conversely a more
3168 # recent version may have been pushed with dgit but not appeared
3169 # in the archive (yet).
3171 # $lastfetch_hash may be awkward because archive imports
3172 # (particularly, imports of Dgit-less .dscs) are performed only as
3173 # needed on individual clients, so different clients may perform a
3174 # different subset of them - and these imports are only made
3175 # public during push. So $lastfetch_hash may represent a set of
3176 # imports different to a subsequent upload by a different dgit
3179 # Our approach is as follows:
3181 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3182 # descendant of $dsc_hash, then it was pushed by a dgit user who
3183 # had based their work on $dsc_hash, so we should prefer it.
3184 # Otherwise, $dsc_hash was installed into this suite in the
3185 # archive other than by a dgit push, and (necessarily) after the
3186 # last dgit push into that suite (since a dgit push would have
3187 # been descended from the dgit server git branch); thus, in that
3188 # case, we prefer the archive's version (and produce a
3189 # pseudo-merge to overwrite the dgit server git branch).
3191 # (If there is no Dgit field in the archive's .dsc then
3192 # generate_commit_from_dsc uses the version numbers to decide
3193 # whether the suite branch or the archive is newer. If the suite
3194 # branch is newer it ignores the archive's .dsc; otherwise it
3195 # generates an import of the .dsc, and produces a pseudo-merge to
3196 # overwrite the suite branch with the archive contents.)
3198 # The outcome of that part of the algorithm is the `public view',
3199 # and is same for all dgit clients: it does not depend on any
3200 # unpublished history in the local tracking branch.
3202 # As between the public view and the local tracking branch: The
3203 # local tracking branch is only updated by dgit fetch, and
3204 # whenever dgit fetch runs it includes the public view in the
3205 # local tracking branch. Therefore if the public view is not
3206 # descended from the local tracking branch, the local tracking
3207 # branch must contain history which was imported from the archive
3208 # but never pushed; and, its tip is now out of date. So, we make
3209 # a pseudo-merge to overwrite the old imports and stitch the old
3212 # Finally: we do not necessarily reify the public view (as
3213 # described above). This is so that we do not end up stacking two
3214 # pseudo-merges. So what we actually do is figure out the inputs
3215 # to any public view pseudo-merge and put them in @mergeinputs.
3218 # $mergeinputs[]{Commit}
3219 # $mergeinputs[]{Info}
3220 # $mergeinputs[0] is the one whose tree we use
3221 # @mergeinputs is in the order we use in the actual commit)
3224 # $mergeinputs[]{Message} is a commit message to use
3225 # $mergeinputs[]{ReverseParents} if def specifies that parent
3226 # list should be in opposite order
3227 # Such an entry has no Commit or Info. It applies only when found
3228 # in the last entry. (This ugliness is to support making
3229 # identical imports to previous dgit versions.)
3231 my $lastpush_hash = git_get_ref(lrfetchref());
3232 printdebug "previous reference hash=$lastpush_hash\n";
3233 $lastpush_mergeinput = $lastpush_hash && {
3234 Commit => $lastpush_hash,
3235 Info => (__ "dgit suite branch on dgit git server"),
3238 my $lastfetch_hash = git_get_ref(lrref());
3239 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3240 my $lastfetch_mergeinput = $lastfetch_hash && {
3241 Commit => $lastfetch_hash,
3242 Info => (__ "dgit client's archive history view"),
3245 my $dsc_mergeinput = $dsc_hash && {
3246 Commit => $dsc_hash,
3247 Info => (__ "Dgit field in .dsc from archive"),
3251 my $del_lrfetchrefs = sub {
3254 printdebug "del_lrfetchrefs...\n";
3255 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3256 my $objid = $lrfetchrefs_d{$fullrefname};
3257 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3259 $gur ||= new IO::Handle;
3260 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3262 printf $gur "delete %s %s\n", $fullrefname, $objid;
3265 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3269 if (defined $dsc_hash) {
3270 ensure_we_have_orig();
3271 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3272 @mergeinputs = $dsc_mergeinput
3273 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3274 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3276 Git commit in archive is behind the last version allegedly pushed/uploaded.
3277 Commit referred to by archive: %s
3278 Last version pushed with dgit: %s
3281 __ $later_warning_msg or confess "$!";
3282 @mergeinputs = ($lastpush_mergeinput);
3284 # Archive has .dsc which is not a descendant of the last dgit
3285 # push. This can happen if the archive moves .dscs about.
3286 # Just follow its lead.
3287 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3288 progress __ "archive .dsc names newer git commit";
3289 @mergeinputs = ($dsc_mergeinput);
3291 progress __ "archive .dsc names other git commit, fixing up";
3292 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3296 @mergeinputs = generate_commits_from_dsc();
3297 # We have just done an import. Now, our import algorithm might
3298 # have been improved. But even so we do not want to generate
3299 # a new different import of the same package. So if the
3300 # version numbers are the same, just use our existing version.
3301 # If the version numbers are different, the archive has changed
3302 # (perhaps, rewound).
3303 if ($lastfetch_mergeinput &&
3304 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3305 (mergeinfo_version $mergeinputs[0]) )) {
3306 @mergeinputs = ($lastfetch_mergeinput);
3308 } elsif ($lastpush_hash) {
3309 # only in git, not in the archive yet
3310 @mergeinputs = ($lastpush_mergeinput);
3311 print STDERR f_ <<END,
3313 Package not found in the archive, but has allegedly been pushed using dgit.
3316 __ $later_warning_msg or confess "$!";
3318 printdebug "nothing found!\n";
3319 if (defined $skew_warning_vsn) {
3320 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3322 Warning: relevant archive skew detected.
3323 Archive allegedly contains %s
3324 But we were not able to obtain any version from the archive or git.
3328 unshift @end, $del_lrfetchrefs;
3332 if ($lastfetch_hash &&
3334 my $h = $_->{Commit};
3335 $h and is_fast_fwd($lastfetch_hash, $h);
3336 # If true, one of the existing parents of this commit
3337 # is a descendant of the $lastfetch_hash, so we'll
3338 # be ff from that automatically.
3342 push @mergeinputs, $lastfetch_mergeinput;
3345 printdebug "fetch mergeinfos:\n";
3346 foreach my $mi (@mergeinputs) {
3348 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3350 printdebug sprintf " ReverseParents=%d Message=%s",
3351 $mi->{ReverseParents}, $mi->{Message};
3355 my $compat_info= pop @mergeinputs
3356 if $mergeinputs[$#mergeinputs]{Message};
3358 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3361 if (@mergeinputs > 1) {
3363 my $tree_commit = $mergeinputs[0]{Commit};
3365 my $tree = get_tree_of_commit $tree_commit;;
3367 # We use the changelog author of the package in question the
3368 # author of this pseudo-merge. This is (roughly) correct if
3369 # this commit is simply representing aa non-dgit upload.
3370 # (Roughly because it does not record sponsorship - but we
3371 # don't have sponsorship info because that's in the .changes,
3372 # which isn't in the archivw.)
3374 # But, it might be that we are representing archive history
3375 # updates (including in-archive copies). These are not really
3376 # the responsibility of the person who created the .dsc, but
3377 # there is no-one whose name we should better use. (The
3378 # author of the .dsc-named commit is clearly worse.)
3380 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3381 my $author = clogp_authline $useclogp;
3382 my $cversion = getfield $useclogp, 'Version';
3384 my $mcf = dgit_privdir()."/mergecommit";
3385 open MC, ">", $mcf or die "$mcf $!";
3386 print MC <<END or confess "$!";
3390 my @parents = grep { $_->{Commit} } @mergeinputs;
3391 @parents = reverse @parents if $compat_info->{ReverseParents};
3392 print MC <<END or confess "$!" foreach @parents;
3396 print MC <<END or confess "$!";
3402 if (defined $compat_info->{Message}) {
3403 print MC $compat_info->{Message} or confess "$!";
3405 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3406 Record %s (%s) in archive suite %s
3410 my $message_add_info = sub {
3412 my $mversion = mergeinfo_version $mi;
3413 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3417 $message_add_info->($mergeinputs[0]);
3418 print MC __ <<END or confess "$!";
3419 should be treated as descended from
3421 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3424 close MC or confess "$!";
3425 $hash = hash_commit $mcf;
3427 $hash = $mergeinputs[0]{Commit};
3429 printdebug "fetch hash=$hash\n";
3432 my ($lasth, $what) = @_;
3433 return unless $lasth;
3434 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3437 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3439 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3441 fetch_from_archive_record_1($hash);
3443 if (defined $skew_warning_vsn) {
3444 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3445 my $gotclogp = commit_getclogp($hash);
3446 my $got_vsn = getfield $gotclogp, 'Version';
3447 printdebug "SKEW CHECK GOT $got_vsn\n";
3448 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3449 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3451 Warning: archive skew detected. Using the available version:
3452 Archive allegedly contains %s
3453 We were able to obtain only %s
3459 if ($lastfetch_hash ne $hash) {
3460 fetch_from_archive_record_2($hash);
3463 lrfetchref_used lrfetchref();
3465 check_gitattrs($hash, __ "fetched source tree");
3467 unshift @end, $del_lrfetchrefs;
3471 sub set_local_git_config ($$) {
3473 runcmd @git, qw(config), $k, $v;
3476 sub setup_mergechangelogs (;$) {
3478 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3480 my $driver = 'dpkg-mergechangelogs';
3481 my $cb = "merge.$driver";
3482 confess unless defined $maindir;
3483 my $attrs = "$maindir_gitcommon/info/attributes";
3484 ensuredir "$maindir_gitcommon/info";
3486 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3487 if (!open ATTRS, "<", $attrs) {
3488 $!==ENOENT or die "$attrs: $!";
3492 next if m{^debian/changelog\s};
3493 print NATTRS $_, "\n" or confess "$!";
3495 ATTRS->error and confess "$!";
3498 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3501 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3502 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3504 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3507 sub setup_useremail (;$) {
3509 return unless $always || access_cfg_bool(1, 'setup-useremail');
3512 my ($k, $envvar) = @_;
3513 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3514 return unless defined $v;
3515 set_local_git_config "user.$k", $v;
3518 $setup->('email', 'DEBEMAIL');
3519 $setup->('name', 'DEBFULLNAME');
3522 sub ensure_setup_existing_tree () {
3523 my $k = "remote.$remotename.skipdefaultupdate";
3524 my $c = git_get_config $k;
3525 return if defined $c;
3526 set_local_git_config $k, 'true';
3529 sub open_main_gitattrs () {
3530 confess 'internal error no maindir' unless defined $maindir;
3531 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3533 or die "open $maindir_gitcommon/info/attributes: $!";
3537 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3539 sub is_gitattrs_setup () {
3542 # 1: gitattributes set up and should be left alone
3544 # 0: there is a dgit-defuse-attrs but it needs fixing
3545 # undef: there is none
3546 my $gai = open_main_gitattrs();
3547 return 0 unless $gai;
3549 next unless m{$gitattrs_ourmacro_re};
3550 return 1 if m{\s-working-tree-encoding\s};
3551 printdebug "is_gitattrs_setup: found old macro\n";
3554 $gai->error and confess "$!";
3555 printdebug "is_gitattrs_setup: found nothing\n";
3559 sub setup_gitattrs (;$) {
3561 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3563 my $already = is_gitattrs_setup();
3566 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3567 not doing further gitattributes setup
3571 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3572 my $af = "$maindir_gitcommon/info/attributes";
3573 ensuredir "$maindir_gitcommon/info";
3575 open GAO, "> $af.new" or confess "$!";
3576 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3580 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3582 my $gai = open_main_gitattrs();
3585 if (m{$gitattrs_ourmacro_re}) {
3586 die unless defined $already;
3590 print GAO $_, "\n" or confess "$!";
3592 $gai->error and confess "$!";
3594 close GAO or confess "$!";
3595 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3598 sub setup_new_tree () {
3599 setup_mergechangelogs();
3604 sub check_gitattrs ($$) {
3605 my ($treeish, $what) = @_;
3607 return if is_gitattrs_setup;
3610 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3612 my $gafl = new IO::File;
3613 open $gafl, "-|", @cmd or confess "$!";
3616 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3618 next unless m{(?:^|/)\.gitattributes$};
3620 # oh dear, found one
3621 print STDERR f_ <<END, $what;
3622 dgit: warning: %s contains .gitattributes
3623 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3628 # tree contains no .gitattributes files
3629 $?=0; $!=0; close $gafl or failedcmd @cmd;
3633 sub multisuite_suite_child ($$$) {
3634 my ($tsuite, $mergeinputs, $fn) = @_;
3635 # in child, sets things up, calls $fn->(), and returns undef
3636 # in parent, returns canonical suite name for $tsuite
3637 my $canonsuitefh = IO::File::new_tmpfile;
3638 my $pid = fork // confess "$!";
3642 $us .= " [$isuite]";
3643 $debugprefix .= " ";
3644 progress f_ "fetching %s...", $tsuite;
3645 canonicalise_suite();
3646 print $canonsuitefh $csuite, "\n" or confess "$!";
3647 close $canonsuitefh or confess "$!";
3651 waitpid $pid,0 == $pid or confess "$!";
3652 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3654 seek $canonsuitefh,0,0 or confess "$!";
3655 local $csuite = <$canonsuitefh>;
3656 confess "$!" unless defined $csuite && chomp $csuite;
3658 printdebug "multisuite $tsuite missing\n";
3661 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3662 push @$mergeinputs, {
3669 sub fork_for_multisuite ($) {
3670 my ($before_fetch_merge) = @_;
3671 # if nothing unusual, just returns ''
3674 # returns 0 to caller in child, to do first of the specified suites
3675 # in child, $csuite is not yet set
3677 # returns 1 to caller in parent, to finish up anything needed after
3678 # in parent, $csuite is set to canonicalised portmanteau
3680 my $org_isuite = $isuite;
3681 my @suites = split /\,/, $isuite;
3682 return '' unless @suites > 1;
3683 printdebug "fork_for_multisuite: @suites\n";
3687 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3689 return 0 unless defined $cbasesuite;
3691 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3692 unless @mergeinputs;
3694 my @csuites = ($cbasesuite);
3696 $before_fetch_merge->();
3698 foreach my $tsuite (@suites[1..$#suites]) {
3699 $tsuite =~ s/^-/$cbasesuite-/;
3700 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3707 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3708 push @csuites, $csubsuite;
3711 foreach my $mi (@mergeinputs) {
3712 my $ref = git_get_ref $mi->{Ref};
3713 die "$mi->{Ref} ?" unless length $ref;
3714 $mi->{Commit} = $ref;
3717 $csuite = join ",", @csuites;
3719 my $previous = git_get_ref lrref;
3721 unshift @mergeinputs, {
3722 Commit => $previous,
3723 Info => (__ "local combined tracking branch"),
3725 "archive seems to have rewound: local tracking branch is ahead!"),
3729 foreach my $ix (0..$#mergeinputs) {
3730 $mergeinputs[$ix]{Index} = $ix;
3733 @mergeinputs = sort {
3734 -version_compare(mergeinfo_version $a,
3735 mergeinfo_version $b) # highest version first
3737 $a->{Index} <=> $b->{Index}; # earliest in spec first
3743 foreach my $mi (@mergeinputs) {
3744 printdebug "multisuite merge check $mi->{Info}\n";
3745 foreach my $previous (@needed) {
3746 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3747 printdebug "multisuite merge un-needed $previous->{Info}\n";
3751 printdebug "multisuite merge this-needed\n";
3752 $mi->{Character} = '+';
3755 $needed[0]{Character} = '*';
3757 my $output = $needed[0]{Commit};
3760 printdebug "multisuite merge nontrivial\n";
3761 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3763 my $commit = "tree $tree\n";
3764 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3765 "Input branches:\n",
3768 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3769 printdebug "multisuite merge include $mi->{Info}\n";
3770 $mi->{Character} //= ' ';
3771 $commit .= "parent $mi->{Commit}\n";
3772 $msg .= sprintf " %s %-25s %s\n",
3774 (mergeinfo_version $mi),
3777 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3778 $msg .= __ "\nKey\n".
3779 " * marks the highest version branch, which choose to use\n".
3780 " + marks each branch which was not already an ancestor\n\n";
3782 "[dgit multi-suite $csuite]\n";
3784 "author $authline\n".
3785 "committer $authline\n\n";
3786 $output = hash_commit_text $commit.$msg;
3787 printdebug "multisuite merge generated $output\n";
3790 fetch_from_archive_record_1($output);
3791 fetch_from_archive_record_2($output);
3793 progress f_ "calculated combined tracking suite %s", $csuite;
3798 sub clone_set_head () {
3799 open H, "> .git/HEAD" or confess "$!";
3800 print H "ref: ".lref()."\n" or confess "$!";
3801 close H or confess "$!";
3803 sub clone_finish ($) {
3805 runcmd @git, qw(reset --hard), lrref();
3806 runcmd qw(bash -ec), <<'END';
3808 git ls-tree -r --name-only -z HEAD | \
3809 xargs -0r touch -h -r . --
3811 printdone f_ "ready for work in %s", $dstdir;
3815 # in multisuite, returns twice!
3816 # once in parent after first suite fetched,
3817 # and then again in child after everything is finished
3819 badusage __ "dry run makes no sense with clone" unless act_local();
3821 my $multi_fetched = fork_for_multisuite(sub {
3822 printdebug "multi clone before fetch merge\n";
3826 if ($multi_fetched) {
3827 printdebug "multi clone after fetch merge\n";
3829 clone_finish($dstdir);
3832 printdebug "clone main body\n";
3834 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3838 canonicalise_suite();
3839 my $hasgit = check_for_git();
3841 runcmd @git, qw(init -q);
3845 my $giturl = access_giturl(1);
3846 if (defined $giturl) {
3847 runcmd @git, qw(remote add), 'origin', $giturl;
3850 progress __ "fetching existing git history";
3852 runcmd_ordryrun_local @git, qw(fetch origin);
3854 progress __ "starting new git history";
3856 fetch_from_archive() or no_such_package;
3857 my $vcsgiturl = $dsc->{'Vcs-Git'};
3858 if (length $vcsgiturl) {
3859 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3860 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3862 clone_finish($dstdir);
3866 canonicalise_suite();
3867 if (check_for_git()) {
3870 fetch_from_archive() or no_such_package();
3872 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3873 if (length $vcsgiturl and
3874 (grep { $csuite eq $_ }
3876 cfg 'dgit.vcs-git.suites')) {
3877 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3878 if (defined $current && $current ne $vcsgiturl) {
3879 print STDERR f_ <<END, $csuite;
3880 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3881 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3885 printdone f_ "fetched into %s", lrref();
3889 my $multi_fetched = fork_for_multisuite(sub { });
3890 fetch_one() unless $multi_fetched; # parent
3891 finish 0 if $multi_fetched eq '0'; # child
3896 runcmd_ordryrun_local @git, qw(merge -m),
3897 (f_ "Merge from %s [dgit]", $csuite),
3899 printdone f_ "fetched to %s and merged into HEAD", lrref();
3902 sub check_not_dirty () {
3903 my @forbid = qw(local-options local-patch-header);
3904 @forbid = map { "debian/source/$_" } @forbid;
3905 foreach my $f (@forbid) {
3906 if (stat_exists $f) {
3907 fail f_ "git tree contains %s", $f;
3911 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3912 push @cmd, qw(debian/source/format debian/source/options);
3915 my $bad = cmdoutput @cmd;
3918 "you have uncommitted changes to critical files, cannot continue:\n").
3922 return if $includedirty;
3924 git_check_unmodified();
3927 sub commit_admin ($) {
3930 runcmd_ordryrun_local @git, qw(commit -m), $m;
3933 sub quiltify_nofix_bail ($$) {
3934 my ($headinfo, $xinfo) = @_;
3935 if ($quilt_mode eq 'nofix') {
3937 "quilt fixup required but quilt mode is \`nofix'\n".
3938 "HEAD commit%s differs from tree implied by debian/patches%s",
3943 sub commit_quilty_patch () {
3944 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3946 foreach my $l (split /\n/, $output) {
3947 next unless $l =~ m/\S/;
3948 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3952 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3954 progress __ "nothing quilty to commit, ok.";
3957 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3958 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3959 runcmd_ordryrun_local @git, qw(add -f), @adds;
3960 commit_admin +(__ <<ENDT).<<END
3961 Commit Debian 3.0 (quilt) metadata
3964 [dgit ($our_version) quilt-fixup]
3968 sub get_source_format () {
3970 if (open F, "debian/source/options") {
3974 s/\s+$//; # ignore missing final newline
3976 my ($k, $v) = ($`, $'); #');
3977 $v =~ s/^"(.*)"$/$1/;
3983 F->error and confess "$!";
3986 confess "$!" unless $!==&ENOENT;
3989 if (!open F, "debian/source/format") {
3990 confess "$!" unless $!==&ENOENT;
3994 F->error and confess "$!";
3996 return ($_, \%options);
3999 sub madformat_wantfixup ($) {
4001 return 0 unless $format eq '3.0 (quilt)';
4002 our $quilt_mode_warned;
4003 if ($quilt_mode eq 'nocheck') {
4004 progress f_ "Not doing any fixup of \`%s'".
4005 " due to ----no-quilt-fixup or --quilt=nocheck", $format
4006 unless $quilt_mode_warned++;
4009 progress f_ "Format \`%s', need to check/update patch stack", $format
4010 unless $quilt_mode_warned++;
4014 sub maybe_split_brain_save ($$$) {
4015 my ($headref, $dgitview, $msg) = @_;
4016 # => message fragment "$saved" describing disposition of $dgitview
4017 # (used inside parens, in the English texts)
4018 my $save = $internal_object_save{'dgit-view'};
4019 return f_ "commit id %s", $dgitview unless defined $save;
4020 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4022 "dgit --dgit-view-save $msg HEAD=$headref",
4025 return f_ "and left in %s", $save;
4028 # An "infopair" is a tuple [ $thing, $what ]
4029 # (often $thing is a commit hash; $what is a description)
4031 sub infopair_cond_equal ($$) {
4033 $x->[0] eq $y->[0] or fail <<END;
4034 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4038 sub infopair_lrf_tag_lookup ($$) {
4039 my ($tagnames, $what) = @_;
4040 # $tagname may be an array ref
4041 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4042 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4043 foreach my $tagname (@tagnames) {
4044 my $lrefname = lrfetchrefs."/tags/$tagname";
4045 my $tagobj = $lrfetchrefs_f{$lrefname};
4046 next unless defined $tagobj;
4047 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4048 return [ git_rev_parse($tagobj), $what ];
4050 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4051 Wanted tag %s (%s) on dgit server, but not found
4053 : (f_ <<END, $what, "@tagnames");
4054 Wanted tag %s (one of: %s) on dgit server, but not found
4058 sub infopair_cond_ff ($$) {
4059 my ($anc,$desc) = @_;
4060 is_fast_fwd($anc->[0], $desc->[0]) or
4061 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4062 %s (%s) .. %s (%s) is not fast forward
4066 sub pseudomerge_version_check ($$) {
4067 my ($clogp, $archive_hash) = @_;
4069 my $arch_clogp = commit_getclogp $archive_hash;
4070 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4071 __ 'version currently in archive' ];
4072 if (defined $overwrite_version) {
4073 if (length $overwrite_version) {
4074 infopair_cond_equal([ $overwrite_version,
4075 '--overwrite= version' ],
4078 my $v = $i_arch_v->[0];
4080 "Checking package changelog for archive version %s ...", $v;
4083 my @xa = ("-f$v", "-t$v");
4084 my $vclogp = parsechangelog @xa;
4087 [ (getfield $vclogp, $fn),
4088 (f_ "%s field from dpkg-parsechangelog %s",
4091 my $cv = $gf->('Version');
4092 infopair_cond_equal($i_arch_v, $cv);
4093 $cd = $gf->('Distribution');
4097 $@ =~ s/^dgit: //gm;
4099 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4101 fail f_ <<END, $cd->[1], $cd->[0], $v
4103 Your tree seems to based on earlier (not uploaded) %s.
4105 if $cd->[0] =~ m/UNRELEASED/;
4109 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4113 sub pseudomerge_hash_commit ($$$$ $$) {
4114 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4115 $msg_cmd, $msg_msg) = @_;
4116 progress f_ "Declaring that HEAD includes all changes in %s...",
4119 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4120 my $authline = clogp_authline $clogp;
4124 !defined $overwrite_version ? ""
4125 : !length $overwrite_version ? " --overwrite"
4126 : " --overwrite=".$overwrite_version;
4128 # Contributing parent is the first parent - that makes
4129 # git rev-list --first-parent DTRT.
4130 my $pmf = dgit_privdir()."/pseudomerge";
4131 open MC, ">", $pmf or die "$pmf $!";
4132 print MC <<END or confess "$!";
4135 parent $archive_hash
4143 close MC or confess "$!";
4145 return hash_commit($pmf);
4148 sub splitbrain_pseudomerge ($$$$) {
4149 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4150 # => $merged_dgitview
4151 printdebug "splitbrain_pseudomerge...\n";
4153 # We: debian/PREVIOUS HEAD($maintview)
4154 # expect: o ----------------- o
4157 # a/d/PREVIOUS $dgitview
4160 # we do: `------------------ o
4164 return $dgitview unless defined $archive_hash;
4165 return $dgitview if deliberately_not_fast_forward();
4167 printdebug "splitbrain_pseudomerge...\n";
4169 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4171 if (!defined $overwrite_version) {
4172 progress __ "Checking that HEAD includes all changes in archive...";
4175 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4177 if (defined $overwrite_version) {
4179 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4180 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4181 __ "maintainer view tag");
4182 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4183 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4184 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4186 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4188 infopair_cond_equal($i_dgit, $i_archive);
4189 infopair_cond_ff($i_dep14, $i_dgit);
4190 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4193 $@ =~ s/^\n//; chomp $@;
4194 print STDERR <<END.(__ <<ENDT);
4197 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4202 my $arch_v = $i_arch_v->[0];
4203 my $r = pseudomerge_hash_commit
4204 $clogp, $dgitview, $archive_hash, $i_arch_v,
4205 "dgit --quilt=$quilt_mode",
4206 (defined $overwrite_version
4207 ? f_ "Declare fast forward from %s\n", $arch_v
4208 : f_ "Make fast forward from %s\n", $arch_v);
4210 maybe_split_brain_save $maintview, $r, "pseudomerge";
4212 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4216 sub plain_overwrite_pseudomerge ($$$) {
4217 my ($clogp, $head, $archive_hash) = @_;
4219 printdebug "plain_overwrite_pseudomerge...";
4221 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4223 return $head if is_fast_fwd $archive_hash, $head;
4225 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4227 my $r = pseudomerge_hash_commit
4228 $clogp, $head, $archive_hash, $i_arch_v,
4231 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4233 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4237 sub push_parse_changelog ($) {
4240 my $clogp = Dpkg::Control::Hash->new();
4241 $clogp->load($clogpfn) or die;
4243 my $clogpackage = getfield $clogp, 'Source';
4244 $package //= $clogpackage;
4245 fail f_ "-p specified %s but changelog specified %s",
4246 $package, $clogpackage
4247 unless $package eq $clogpackage;
4248 my $cversion = getfield $clogp, 'Version';
4250 if (!$we_are_initiator) {
4251 # rpush initiator can't do this because it doesn't have $isuite yet
4252 my $tag = debiantag_new($cversion, access_nomdistro);
4253 runcmd @git, qw(check-ref-format), $tag;
4256 my $dscfn = dscfn($cversion);
4258 return ($clogp, $cversion, $dscfn);
4261 sub push_parse_dsc ($$$) {
4262 my ($dscfn,$dscfnwhat, $cversion) = @_;
4263 $dsc = parsecontrol($dscfn,$dscfnwhat);
4264 my $dversion = getfield $dsc, 'Version';
4265 my $dscpackage = getfield $dsc, 'Source';
4266 ($dscpackage eq $package && $dversion eq $cversion) or
4267 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4268 $dscfn, $dscpackage, $dversion,
4269 $package, $cversion;
4272 sub push_tagwants ($$$$) {
4273 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4276 TagFn => \&debiantag_new,
4281 if (defined $maintviewhead) {
4283 TagFn => \&debiantag_maintview,
4284 Objid => $maintviewhead,
4285 TfSuffix => '-maintview',
4288 } elsif ($dodep14tag ne 'no') {
4290 TagFn => \&debiantag_maintview,
4292 TfSuffix => '-dgit',
4296 foreach my $tw (@tagwants) {
4297 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4298 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4300 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4304 sub push_mktags ($$ $$ $) {
4306 $changesfile,$changesfilewhat,
4309 die unless $tagwants->[0]{View} eq 'dgit';
4311 my $declaredistro = access_nomdistro();
4312 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4313 $dsc->{$ourdscfield[0]} = join " ",
4314 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4316 $dsc->save("$dscfn.tmp") or confess "$!";
4318 my $changes = parsecontrol($changesfile,$changesfilewhat);
4319 foreach my $field (qw(Source Distribution Version)) {
4320 $changes->{$field} eq $clogp->{$field} or
4321 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4322 $field, $changes->{$field}, $clogp->{$field};
4325 my $cversion = getfield $clogp, 'Version';
4326 my $clogsuite = getfield $clogp, 'Distribution';
4328 # We make the git tag by hand because (a) that makes it easier
4329 # to control the "tagger" (b) we can do remote signing
4330 my $authline = clogp_authline $clogp;
4331 my $delibs = join(" ", "",@deliberatelies);
4335 my $tfn = $tw->{Tfn};
4336 my $head = $tw->{Objid};
4337 my $tag = $tw->{Tag};
4339 open TO, '>', $tfn->('.tmp') or confess "$!";
4340 print TO <<END or confess "$!";
4347 if ($tw->{View} eq 'dgit') {
4348 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4349 %s release %s for %s (%s) [dgit]
4352 print TO <<END or confess "$!";
4353 [dgit distro=$declaredistro$delibs]
4355 foreach my $ref (sort keys %previously) {
4356 print TO <<END or confess "$!";
4357 [dgit previously:$ref=$previously{$ref}]
4360 } elsif ($tw->{View} eq 'maint') {
4361 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4362 %s release %s for %s (%s)
4363 (maintainer view tag generated by dgit --quilt=%s)
4368 confess Dumper($tw)."?";
4371 close TO or confess "$!";
4373 my $tagobjfn = $tfn->('.tmp');
4375 if (!defined $keyid) {
4376 $keyid = access_cfg('keyid','RETURN-UNDEF');
4378 if (!defined $keyid) {
4379 $keyid = getfield $clogp, 'Maintainer';
4381 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4382 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4383 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4384 push @sign_cmd, $tfn->('.tmp');
4385 runcmd_ordryrun @sign_cmd;
4387 $tagobjfn = $tfn->('.signed.tmp');
4388 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4389 $tfn->('.tmp'), $tfn->('.tmp.asc');
4395 my @r = map { $mktag->($_); } @$tagwants;
4399 sub sign_changes ($) {
4400 my ($changesfile) = @_;
4402 my @debsign_cmd = @debsign;
4403 push @debsign_cmd, "-k$keyid" if defined $keyid;
4404 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4405 push @debsign_cmd, $changesfile;
4406 runcmd_ordryrun @debsign_cmd;
4411 printdebug "actually entering push\n";
4413 supplementary_message(__ <<'END');
4414 Push failed, while checking state of the archive.
4415 You can retry the push, after fixing the problem, if you like.
4417 if (check_for_git()) {
4420 my $archive_hash = fetch_from_archive();
4421 if (!$archive_hash) {
4423 fail __ "package appears to be new in this suite;".
4424 " if this is intentional, use --new";
4427 supplementary_message(__ <<'END');
4428 Push failed, while preparing your push.
4429 You can retry the push, after fixing the problem, if you like.
4434 access_giturl(); # check that success is vaguely likely
4435 rpush_handle_protovsn_bothends() if $we_are_initiator;
4437 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4438 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4440 responder_send_file('parsed-changelog', $clogpfn);
4442 my ($clogp, $cversion, $dscfn) =
4443 push_parse_changelog("$clogpfn");
4445 my $dscpath = "$buildproductsdir/$dscfn";
4446 stat_exists $dscpath or
4447 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4450 responder_send_file('dsc', $dscpath);
4452 push_parse_dsc($dscpath, $dscfn, $cversion);
4454 my $format = getfield $dsc, 'Format';
4456 my $symref = git_get_symref();
4457 my $actualhead = git_rev_parse('HEAD');
4459 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4460 if (quiltmode_splitting()) {
4461 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4462 fail f_ <<END, $ffq_prev, $quilt_mode;
4463 Branch is managed by git-debrebase (%s
4464 exists), but quilt mode (%s) implies a split view.
4465 Pass the right --quilt option or adjust your git config.
4466 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4469 runcmd_ordryrun_local @git_debrebase, 'stitch';
4470 $actualhead = git_rev_parse('HEAD');
4473 my $dgithead = $actualhead;
4474 my $maintviewhead = undef;
4476 my $upstreamversion = upstreamversion $clogp->{Version};
4478 if (madformat_wantfixup($format)) {
4479 # user might have not used dgit build, so maybe do this now:
4480 if (do_split_brain()) {
4481 changedir $playground;
4483 ($dgithead, $cachekey) =
4484 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4485 $dgithead or fail f_
4486 "--quilt=%s but no cached dgit view:
4487 perhaps HEAD changed since dgit build[-source] ?",
4490 if (!do_split_brain()) {
4491 # In split brain mode, do not attempt to incorporate dirty
4492 # stuff from the user's working tree. That would be mad.
4493 commit_quilty_patch();
4496 if (do_split_brain()) {
4497 $made_split_brain = 1;
4498 $dgithead = splitbrain_pseudomerge($clogp,
4499 $actualhead, $dgithead,
4501 $maintviewhead = $actualhead;
4503 prep_ud(); # so _only_subdir() works, below
4506 if (defined $overwrite_version && !defined $maintviewhead
4508 $dgithead = plain_overwrite_pseudomerge($clogp,
4516 if ($archive_hash) {
4517 if (is_fast_fwd($archive_hash, $dgithead)) {
4519 } elsif (deliberately_not_fast_forward) {
4522 fail __ "dgit push: HEAD is not a descendant".
4523 " of the archive's version.\n".
4524 "To overwrite the archive's contents,".
4525 " pass --overwrite[=VERSION].\n".
4526 "To rewind history, if permitted by the archive,".
4527 " use --deliberately-not-fast-forward.";
4531 confess unless !!$made_split_brain == do_split_brain();
4533 changedir $playground;
4534 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4535 runcmd qw(dpkg-source -x --),
4536 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4537 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4538 check_for_vendor_patches() if madformat($dsc->{format});
4540 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4541 debugcmd "+",@diffcmd;
4543 my $r = system @diffcmd;
4546 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4547 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4550 my $raw = cmdoutput @git,
4551 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4553 foreach (split /\0/, $raw) {
4554 if (defined $changed) {
4555 push @mode_changes, "$changed: $_\n" if $changed;
4558 } elsif (m/^:0+ 0+ /) {
4560 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4561 $changed = "Mode change from $1 to $2"
4566 if (@mode_changes) {
4567 fail +(f_ <<ENDT, $dscfn).<<END
4568 HEAD specifies a different tree to %s:
4572 .(join '', @mode_changes)
4573 .(f_ <<ENDT, $tree, $referent);
4574 There is a problem with your source tree (see dgit(7) for some hints).
4575 To see a full diff, run git diff %s %s
4579 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4580 HEAD specifies a different tree to %s:
4584 Perhaps you forgot to build. Or perhaps there is a problem with your
4585 source tree (see dgit(7) for some hints). To see a full diff, run
4592 if (!$changesfile) {
4593 my $pat = changespat $cversion;
4594 my @cs = glob "$buildproductsdir/$pat";
4595 fail f_ "failed to find unique changes file".
4596 " (looked for %s in %s);".
4597 " perhaps you need to use dgit -C",
4598 $pat, $buildproductsdir
4600 ($changesfile) = @cs;
4602 $changesfile = "$buildproductsdir/$changesfile";
4605 # Check that changes and .dsc agree enough
4606 $changesfile =~ m{[^/]*$};
4607 my $changes = parsecontrol($changesfile,$&);
4608 files_compare_inputs($dsc, $changes)
4609 unless forceing [qw(dsc-changes-mismatch)];
4611 # Check whether this is a source only upload
4612 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4613 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4614 if ($sourceonlypolicy eq 'ok') {
4615 } elsif ($sourceonlypolicy eq 'always') {
4616 forceable_fail [qw(uploading-binaries)],
4617 __ "uploading binaries, although distro policy is source only"
4619 } elsif ($sourceonlypolicy eq 'never') {
4620 forceable_fail [qw(uploading-source-only)],
4621 __ "source-only upload, although distro policy requires .debs"
4623 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4624 forceable_fail [qw(uploading-source-only)],
4625 f_ "source-only upload, even though package is entirely NEW\n".
4626 "(this is contrary to policy in %s)",
4630 && !(archive_query('package_not_wholly_new', $package) // 1);
4632 badcfg f_ "unknown source-only-uploads policy \`%s'",
4636 # Perhaps adjust .dsc to contain right set of origs
4637 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4639 unless forceing [qw(changes-origs-exactly)];
4641 # Checks complete, we're going to try and go ahead:
4643 responder_send_file('changes',$changesfile);
4644 responder_send_command("param head $dgithead");
4645 responder_send_command("param csuite $csuite");
4646 responder_send_command("param isuite $isuite");
4647 responder_send_command("param tagformat new"); # needed in $protovsn==4
4648 if (defined $maintviewhead) {
4649 responder_send_command("param maint-view $maintviewhead");
4652 # Perhaps send buildinfo(s) for signing
4653 my $changes_files = getfield $changes, 'Files';
4654 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4655 foreach my $bi (@buildinfos) {
4656 responder_send_command("param buildinfo-filename $bi");
4657 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4660 if (deliberately_not_fast_forward) {
4661 git_for_each_ref(lrfetchrefs, sub {
4662 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4663 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4664 responder_send_command("previously $rrefname=$objid");
4665 $previously{$rrefname} = $objid;
4669 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4670 dgit_privdir()."/tag");
4673 supplementary_message(__ <<'END');
4674 Push failed, while signing the tag.
4675 You can retry the push, after fixing the problem, if you like.
4677 # If we manage to sign but fail to record it anywhere, it's fine.
4678 if ($we_are_responder) {
4679 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4680 responder_receive_files('signed-tag', @tagobjfns);
4682 @tagobjfns = push_mktags($clogp,$dscpath,
4683 $changesfile,$changesfile,
4686 supplementary_message(__ <<'END');
4687 Push failed, *after* signing the tag.
4688 If you want to try again, you should use a new version number.
4691 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4693 foreach my $tw (@tagwants) {
4694 my $tag = $tw->{Tag};
4695 my $tagobjfn = $tw->{TagObjFn};
4697 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4698 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4699 runcmd_ordryrun_local
4700 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4703 supplementary_message(__ <<'END');
4704 Push failed, while updating the remote git repository - see messages above.
4705 If you want to try again, you should use a new version number.
4707 if (!check_for_git()) {
4708 create_remote_git_repo();
4711 my @pushrefs = $forceflag.$dgithead.":".rrref();
4712 foreach my $tw (@tagwants) {
4713 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4716 runcmd_ordryrun @git,
4717 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4718 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4720 supplementary_message(__ <<'END');
4721 Push failed, while obtaining signatures on the .changes and .dsc.
4722 If it was just that the signature failed, you may try again by using
4723 debsign by hand to sign the changes file (see the command dgit tried,
4724 above), and then dput that changes file to complete the upload.
4725 If you need to change the package, you must use a new version number.
4727 if ($we_are_responder) {
4728 my $dryrunsuffix = act_local() ? "" : ".tmp";
4729 my @rfiles = ($dscpath, $changesfile);
4730 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4731 responder_receive_files('signed-dsc-changes',
4732 map { "$_$dryrunsuffix" } @rfiles);
4735 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4737 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4739 sign_changes $changesfile;
4742 supplementary_message(f_ <<END, $changesfile);
4743 Push failed, while uploading package(s) to the archive server.
4744 You can retry the upload of exactly these same files with dput of:
4746 If that .changes file is broken, you will need to use a new version
4747 number for your next attempt at the upload.
4749 my $host = access_cfg('upload-host','RETURN-UNDEF');
4750 my @hostarg = defined($host) ? ($host,) : ();
4751 runcmd_ordryrun @dput, @hostarg, $changesfile;
4752 printdone f_ "pushed and uploaded %s", $cversion;
4754 supplementary_message('');
4755 responder_send_command("complete");
4759 not_necessarily_a_tree();
4764 badusage __ "-p is not allowed with clone; specify as argument instead"
4765 if defined $package;
4768 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4769 ($package,$isuite) = @ARGV;
4770 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4771 ($package,$dstdir) = @ARGV;
4772 } elsif (@ARGV==3) {
4773 ($package,$isuite,$dstdir) = @ARGV;
4775 badusage __ "incorrect arguments to dgit clone";
4779 $dstdir ||= "$package";
4780 if (stat_exists $dstdir) {
4781 fail f_ "%s already exists", $dstdir;
4785 if ($rmonerror && !$dryrun_level) {
4786 $cwd_remove= getcwd();
4788 return unless defined $cwd_remove;
4789 if (!chdir "$cwd_remove") {
4790 return if $!==&ENOENT;
4791 confess "chdir $cwd_remove: $!";
4793 printdebug "clone rmonerror removing $dstdir\n";
4795 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4796 } elsif (grep { $! == $_ }
4797 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4799 print STDERR f_ "check whether to remove %s: %s\n",
4806 $cwd_remove = undef;
4809 sub branchsuite () {
4810 my $branch = git_get_symref();
4811 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4818 sub package_from_d_control () {
4819 if (!defined $package) {
4820 my $sourcep = parsecontrol('debian/control','debian/control');
4821 $package = getfield $sourcep, 'Source';
4825 sub fetchpullargs () {
4826 package_from_d_control();
4828 $isuite = branchsuite();
4830 my $clogp = parsechangelog();
4831 my $clogsuite = getfield $clogp, 'Distribution';
4832 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4834 } elsif (@ARGV==1) {
4837 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4851 determine_whether_split_brain();
4852 if (do_split_brain()) {
4853 my ($format, $fopts) = get_source_format();
4854 madformat($format) and fail f_ <<END, $quilt_mode
4855 dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
4863 package_from_d_control();
4864 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4868 foreach my $canon (qw(0 1)) {
4873 canonicalise_suite();
4875 if (length git_get_ref lref()) {
4876 # local branch already exists, yay
4879 if (!length git_get_ref lrref()) {
4887 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4890 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4891 "dgit checkout $isuite";
4892 runcmd (@git, qw(checkout), lbranch());
4895 sub cmd_update_vcs_git () {
4897 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4898 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4900 ($specsuite) = (@ARGV);
4905 if ($ARGV[0] eq '-') {
4907 } elsif ($ARGV[0] eq '-') {
4912 package_from_d_control();
4914 if ($specsuite eq '.') {
4915 $ctrl = parsecontrol 'debian/control', 'debian/control';
4917 $isuite = $specsuite;
4921 my $url = getfield $ctrl, 'Vcs-Git';
4924 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4925 if (!defined $orgurl) {
4926 print STDERR f_ "setting up vcs-git: %s\n", $url;
4927 @cmd = (@git, qw(remote add vcs-git), $url);
4928 } elsif ($orgurl eq $url) {
4929 print STDERR f_ "vcs git already configured: %s\n", $url;
4931 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4932 @cmd = (@git, qw(remote set-url vcs-git), $url);
4934 runcmd_ordryrun_local @cmd;
4936 print f_ "fetching (%s)\n", "@ARGV";
4937 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4943 build_or_push_prep_early();
4945 build_or_push_prep_modes();
4949 } elsif (@ARGV==1) {
4950 ($specsuite) = (@ARGV);
4952 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4955 local ($package) = $existing_package; # this is a hack
4956 canonicalise_suite();
4958 canonicalise_suite();
4960 if (defined $specsuite &&
4961 $specsuite ne $isuite &&
4962 $specsuite ne $csuite) {
4963 fail f_ "dgit %s: changelog specifies %s (%s)".
4964 " but command line specifies %s",
4965 $subcommand, $isuite, $csuite, $specsuite;
4974 #---------- remote commands' implementation ----------
4976 sub pre_remote_push_build_host {
4977 my ($nrargs) = shift @ARGV;
4978 my (@rargs) = @ARGV[0..$nrargs-1];
4979 @ARGV = @ARGV[$nrargs..$#ARGV];
4981 my ($dir,$vsnwant) = @rargs;
4982 # vsnwant is a comma-separated list; we report which we have
4983 # chosen in our ready response (so other end can tell if they
4986 $we_are_responder = 1;
4987 $us .= " (build host)";
4989 open PI, "<&STDIN" or confess "$!";
4990 open STDIN, "/dev/null" or confess "$!";
4991 open PO, ">&STDOUT" or confess "$!";
4993 open STDOUT, ">&STDERR" or confess "$!";
4997 ($protovsn) = grep {
4998 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4999 } @rpushprotovsn_support;
5001 fail f_ "build host has dgit rpush protocol versions %s".
5002 " but invocation host has %s",
5003 (join ",", @rpushprotovsn_support), $vsnwant
5004 unless defined $protovsn;
5008 sub cmd_remote_push_build_host {
5009 responder_send_command("dgit-remote-push-ready $protovsn");
5013 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5014 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5015 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5016 # a good error message)
5018 sub rpush_handle_protovsn_bothends () {
5025 my $report = i_child_report();
5026 if (defined $report) {
5027 printdebug "($report)\n";
5028 } elsif ($i_child_pid) {
5029 printdebug "(killing build host child $i_child_pid)\n";
5030 kill 15, $i_child_pid;
5032 if (defined $i_tmp && !defined $initiator_tempdir) {
5034 eval { rmtree $i_tmp; };
5039 return unless forkcheck_mainprocess();
5044 my ($base,$selector,@args) = @_;
5045 $selector =~ s/\-/_/g;
5046 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5050 not_necessarily_a_tree();
5055 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5063 push @rargs, join ",", @rpushprotovsn_support;
5066 push @rdgit, @ropts;
5067 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5069 my @cmd = (@ssh, $host, shellquote @rdgit);
5072 $we_are_initiator=1;
5074 if (defined $initiator_tempdir) {
5075 rmtree $initiator_tempdir;
5076 mkdir $initiator_tempdir, 0700
5077 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5078 $i_tmp = $initiator_tempdir;
5082 $i_child_pid = open2(\*RO, \*RI, @cmd);
5084 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5085 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5088 my ($icmd,$iargs) = initiator_expect {
5089 m/^(\S+)(?: (.*))?$/;
5092 i_method "i_resp", $icmd, $iargs;
5096 sub i_resp_progress ($) {
5098 my $msg = protocol_read_bytes \*RO, $rhs;
5102 sub i_resp_supplementary_message ($) {
5104 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5107 sub i_resp_complete {
5108 my $pid = $i_child_pid;
5109 $i_child_pid = undef; # prevents killing some other process with same pid
5110 printdebug "waiting for build host child $pid...\n";
5111 my $got = waitpid $pid, 0;
5112 confess "$!" unless $got == $pid;
5113 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5116 printdebug __ "all done\n";
5120 sub i_resp_file ($) {
5122 my $localname = i_method "i_localname", $keyword;
5123 my $localpath = "$i_tmp/$localname";
5124 stat_exists $localpath and
5125 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5126 protocol_receive_file \*RO, $localpath;
5127 i_method "i_file", $keyword;
5132 sub i_resp_param ($) {
5133 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5137 sub i_resp_previously ($) {
5138 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5139 or badproto \*RO, __ "bad previously spec";
5140 my $r = system qw(git check-ref-format), $1;
5141 confess "bad previously ref spec ($r)" if $r;
5142 $previously{$1} = $2;
5147 sub i_resp_want ($) {
5149 die "$keyword ?" if $i_wanted{$keyword}++;
5151 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5152 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5153 die unless $isuite =~ m/^$suite_re$/;
5156 rpush_handle_protovsn_bothends();
5158 my @localpaths = i_method "i_want", $keyword;
5159 printdebug "[[ $keyword @localpaths\n";
5160 foreach my $localpath (@localpaths) {
5161 protocol_send_file \*RI, $localpath;
5163 print RI "files-end\n" or confess "$!";
5166 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5168 sub i_localname_parsed_changelog {
5169 return "remote-changelog.822";
5171 sub i_file_parsed_changelog {
5172 ($i_clogp, $i_version, $i_dscfn) =
5173 push_parse_changelog "$i_tmp/remote-changelog.822";
5174 die if $i_dscfn =~ m#/|^\W#;
5177 sub i_localname_dsc {
5178 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5183 sub i_localname_buildinfo ($) {
5184 my $bi = $i_param{'buildinfo-filename'};
5185 defined $bi or badproto \*RO, "buildinfo before filename";
5186 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5187 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5188 or badproto \*RO, "improper buildinfo filename";
5191 sub i_file_buildinfo {
5192 my $bi = $i_param{'buildinfo-filename'};
5193 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5194 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5195 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5196 files_compare_inputs($bd, $ch);
5197 (getfield $bd, $_) eq (getfield $ch, $_) or
5198 fail f_ "buildinfo mismatch in field %s", $_
5199 foreach qw(Source Version);
5200 !defined $bd->{$_} or
5201 fail f_ "buildinfo contains forbidden field %s", $_
5202 foreach qw(Changes Changed-by Distribution);
5204 push @i_buildinfos, $bi;
5205 delete $i_param{'buildinfo-filename'};
5208 sub i_localname_changes {
5209 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5210 $i_changesfn = $i_dscfn;
5211 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5212 return $i_changesfn;
5214 sub i_file_changes { }
5216 sub i_want_signed_tag {
5217 printdebug Dumper(\%i_param, $i_dscfn);
5218 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5219 && defined $i_param{'csuite'}
5220 or badproto \*RO, "premature desire for signed-tag";
5221 my $head = $i_param{'head'};
5222 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5224 my $maintview = $i_param{'maint-view'};
5225 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5227 if ($protovsn == 4) {
5228 my $p = $i_param{'tagformat'} // '<undef>';
5230 or badproto \*RO, "tag format mismatch: $p vs. new";
5233 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5235 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5237 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5240 push_mktags $i_clogp, $i_dscfn,
5241 $i_changesfn, (__ 'remote changes file'),
5245 sub i_want_signed_dsc_changes {
5246 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5247 sign_changes $i_changesfn;
5248 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5251 #---------- building etc. ----------
5257 #----- `3.0 (quilt)' handling -----
5259 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5261 sub quiltify_dpkg_commit ($$$;$) {
5262 my ($patchname,$author,$msg, $xinfo) = @_;
5265 mkpath '.git/dgit'; # we are in playtree
5266 my $descfn = ".git/dgit/quilt-description.tmp";
5267 open O, '>', $descfn or confess "$descfn: $!";
5268 $msg =~ s/\n+/\n\n/;
5269 print O <<END or confess "$!";
5271 ${xinfo}Subject: $msg
5275 close O or confess "$!";
5278 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5279 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5280 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5281 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5285 sub quiltify_trees_differ ($$;$$$) {
5286 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5287 # returns true iff the two tree objects differ other than in debian/
5288 # with $finegrained,
5289 # returns bitmask 01 - differ in upstream files except .gitignore
5290 # 02 - differ in .gitignore
5291 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5292 # is set for each modified .gitignore filename $fn
5293 # if $unrepres is defined, array ref to which is appeneded
5294 # a list of unrepresentable changes (removals of upstream files
5297 my @cmd = (@git, qw(diff-tree -z --no-renames));
5298 push @cmd, qw(--name-only) unless $unrepres;
5299 push @cmd, qw(-r) if $finegrained || $unrepres;
5301 my $diffs= cmdoutput @cmd;
5304 foreach my $f (split /\0/, $diffs) {
5305 if ($unrepres && !@lmodes) {
5306 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5309 my ($oldmode,$newmode) = @lmodes;
5312 next if $f =~ m#^debian(?:/.*)?$#s;
5316 die __ "not a plain file or symlink\n"
5317 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5318 $oldmode =~ m/^(?:10|12)\d{4}$/;
5319 if ($oldmode =~ m/[^0]/ &&
5320 $newmode =~ m/[^0]/) {
5321 # both old and new files exist
5322 die __ "mode or type changed\n" if $oldmode ne $newmode;
5323 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5324 } elsif ($oldmode =~ m/[^0]/) {
5326 die __ "deletion of symlink\n"
5327 unless $oldmode =~ m/^10/;
5330 die __ "creation with non-default mode\n"
5331 unless $newmode =~ m/^100644$/ or
5332 $newmode =~ m/^120000$/;
5336 local $/="\n"; chomp $@;
5337 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5341 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5342 $r |= $isignore ? 02 : 01;
5343 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5345 printdebug "quiltify_trees_differ $x $y => $r\n";
5349 sub quiltify_tree_sentinelfiles ($) {
5350 # lists the `sentinel' files present in the tree
5352 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5353 qw(-- debian/rules debian/control);
5358 sub quiltify_splitting ($$$$$$$) {
5359 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5360 $editedignores, $cachekey) = @_;
5361 my $gitignore_special = 1;
5362 if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
5363 # treat .gitignore just like any other upstream file
5364 $diffbits = { %$diffbits };
5365 $_ = !!$_ foreach values %$diffbits;
5366 $gitignore_special = 0;
5368 # We would like any commits we generate to be reproducible
5369 my @authline = clogp_authline($clogp);
5370 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5371 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5372 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5373 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5374 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5375 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5377 confess unless do_split_brain();
5379 my $fulldiffhint = sub {
5381 my $cmd = "git diff $x $y -- :/ ':!debian'";
5382 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5383 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5387 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5388 ($diffbits->{O2H} & 01)) {
5390 "--quilt=%s specified, implying patches-unapplied git tree\n".
5391 " but git tree differs from orig in upstream files.",
5393 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5394 if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
5396 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5400 if ($quilt_mode =~ m/dpm/ &&
5401 ($diffbits->{H2A} & 01)) {
5402 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5403 --quilt=%s specified, implying patches-applied git tree
5404 but git tree differs from result of applying debian/patches to upstream
5407 if ($quilt_mode =~ m/baredebian/) {
5408 # We need to construct a merge which has upstream files from
5409 # upstream and debian/ files from HEAD.
5411 read_tree_upstream $quilt_upstream_commitish, 1, $headref;
5412 my $upsversion = upstreamversion getfield $clogp, 'Version';
5413 my $merge = make_commit
5414 [ $headref, $quilt_upstream_commitish ],
5415 [ +(f_ <<ENDT, $upsversion), <<ENDU ];
5416 Combine debian/ with upstream source for %s
5418 [dgit ($our_version) baredebian-merge]
5420 runcmd @git, qw(reset -q --hard), $merge;
5422 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5423 ($diffbits->{O2A} & 01)) { # some patches
5424 progress __ "dgit view: creating patches-applied version using gbp pq";
5425 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5426 # gbp pq import creates a fresh branch; push back to dgit-view
5427 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5428 runcmd @git, qw(checkout -q dgit-view);
5430 if ($quilt_mode =~ m/gbp|dpm/ &&
5431 ($diffbits->{O2A} & 02)) {
5432 fail f_ <<END, $quilt_mode;
5433 --quilt=%s specified, implying that HEAD is for use with a
5434 tool which does not create patches for changes to upstream
5435 .gitignores: but, such patches exist in debian/patches.
5438 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5439 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5441 "dgit view: creating patch to represent .gitignore changes";
5442 ensuredir "debian/patches";
5443 my $gipatch = "debian/patches/auto-gitignore";
5444 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5445 stat GIPATCH or confess "$gipatch: $!";
5446 fail f_ "%s already exists; but want to create it".
5447 " to record .gitignore changes",
5450 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5451 Subject: Update .gitignore from Debian packaging branch
5453 The Debian packaging git branch contains these updates to the upstream
5454 .gitignore file(s). This patch is autogenerated, to provide these
5455 updates to users of the official Debian archive view of the package.
5458 [dgit ($our_version) update-gitignore]
5461 close GIPATCH or die "$gipatch: $!";
5462 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5463 $unapplied, $headref, "--", sort keys %$editedignores;
5464 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5465 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5467 defined read SERIES, $newline, 1 or confess "$!";
5468 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5469 print SERIES "auto-gitignore\n" or confess "$!";
5470 close SERIES or die $!;
5471 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5472 commit_admin +(__ <<END).<<ENDU
5473 Commit patch to update .gitignore
5476 [dgit ($our_version) update-gitignore-quilt-fixup]
5481 sub quiltify ($$$$) {
5482 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5484 # Quilt patchification algorithm
5486 # We search backwards through the history of the main tree's HEAD
5487 # (T) looking for a start commit S whose tree object is identical
5488 # to to the patch tip tree (ie the tree corresponding to the
5489 # current dpkg-committed patch series). For these purposes
5490 # `identical' disregards anything in debian/ - this wrinkle is
5491 # necessary because dpkg-source treates debian/ specially.
5493 # We can only traverse edges where at most one of the ancestors'
5494 # trees differs (in changes outside in debian/). And we cannot
5495 # handle edges which change .pc/ or debian/patches. To avoid
5496 # going down a rathole we avoid traversing edges which introduce
5497 # debian/rules or debian/control. And we set a limit on the
5498 # number of edges we are willing to look at.
5500 # If we succeed, we walk forwards again. For each traversed edge
5501 # PC (with P parent, C child) (starting with P=S and ending with
5502 # C=T) to we do this:
5504 # - dpkg-source --commit with a patch name and message derived from C
5505 # After traversing PT, we git commit the changes which
5506 # should be contained within debian/patches.
5508 # The search for the path S..T is breadth-first. We maintain a
5509 # todo list containing search nodes. A search node identifies a
5510 # commit, and looks something like this:
5512 # Commit => $git_commit_id,
5513 # Child => $c, # or undef if P=T
5514 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5515 # Nontrivial => true iff $p..$c has relevant changes
5522 my %considered; # saves being exponential on some weird graphs
5524 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5527 my ($search,$whynot) = @_;
5528 printdebug " search NOT $search->{Commit} $whynot\n";
5529 $search->{Whynot} = $whynot;
5530 push @nots, $search;
5531 no warnings qw(exiting);
5540 my $c = shift @todo;
5541 next if $considered{$c->{Commit}}++;
5543 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5545 printdebug "quiltify investigate $c->{Commit}\n";
5548 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5549 printdebug " search finished hooray!\n";
5554 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5555 if ($quilt_mode eq 'smash') {
5556 printdebug " search quitting smash\n";
5560 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5561 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5562 if $c_sentinels ne $t_sentinels;
5564 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5565 $commitdata =~ m/\n\n/;
5567 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5568 @parents = map { { Commit => $_, Child => $c } } @parents;
5570 $not->($c, __ "root commit") if !@parents;
5572 foreach my $p (@parents) {
5573 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5575 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5576 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5579 foreach my $p (@parents) {
5580 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5582 my @cmd= (@git, qw(diff-tree -r --name-only),
5583 $p->{Commit},$c->{Commit},
5584 qw(-- debian/patches .pc debian/source/format));
5585 my $patchstackchange = cmdoutput @cmd;
5586 if (length $patchstackchange) {
5587 $patchstackchange =~ s/\n/,/g;
5588 $not->($p, f_ "changed %s", $patchstackchange);
5591 printdebug " search queue P=$p->{Commit} ",
5592 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5598 printdebug "quiltify want to smash\n";
5601 my $x = $_[0]{Commit};
5602 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5605 if ($quilt_mode eq 'linear') {
5607 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5609 my $all_gdr = !!@nots;
5610 foreach my $notp (@nots) {
5611 my $c = $notp->{Child};
5612 my $cprange = $abbrev->($notp);
5613 $cprange .= "..".$abbrev->($c) if $c;
5614 print STDERR f_ "%s: %s: %s\n",
5615 $us, $cprange, $notp->{Whynot};
5616 $all_gdr &&= $notp->{Child} &&
5617 (git_cat_file $notp->{Child}{Commit}, 'commit')
5618 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5622 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5624 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5626 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5627 } elsif ($quilt_mode eq 'smash') {
5628 } elsif ($quilt_mode eq 'auto') {
5629 progress __ "quilt fixup cannot be linear, smashing...";
5631 confess "$quilt_mode ?";
5634 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5635 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5637 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5639 quiltify_dpkg_commit "auto-$version-$target-$time",
5640 (getfield $clogp, 'Maintainer'),
5641 (f_ "Automatically generated patch (%s)\n".
5642 "Last (up to) %s git changes, FYI:\n\n",
5643 $clogp->{Version}, $ncommits).
5648 progress __ "quiltify linearisation planning successful, executing...";
5650 for (my $p = $sref_S;
5651 my $c = $p->{Child};
5653 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5654 next unless $p->{Nontrivial};
5656 my $cc = $c->{Commit};
5658 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5659 $commitdata =~ m/\n\n/ or die "$c ?";
5662 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5665 my $commitdate = cmdoutput
5666 @git, qw(log -n1 --pretty=format:%aD), $cc;
5668 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5670 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5677 my $gbp_check_suitable = sub {
5682 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5683 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5684 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5685 die __ "is series file\n" if m{$series_filename_re}o;
5686 die __ "too long\n" if length > 200;
5688 return $_ unless $@;
5690 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5695 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5697 (\S+) \s* \n //ixm) {
5698 $patchname = $gbp_check_suitable->($1, 'Name');
5700 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5702 (\S+) \s* \n //ixm) {
5703 $patchdir = $gbp_check_suitable->($1, 'Topic');
5708 if (!defined $patchname) {
5709 $patchname = $title;
5710 $patchname =~ s/[.:]$//;
5713 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5714 my $translitname = $converter->convert($patchname);
5715 die unless defined $translitname;
5716 $patchname = $translitname;
5719 +(f_ "dgit: patch title transliteration error: %s", $@)
5721 $patchname =~ y/ A-Z/-a-z/;
5722 $patchname =~ y/-a-z0-9_.+=~//cd;
5723 $patchname =~ s/^\W/x-$&/;
5724 $patchname = substr($patchname,0,40);
5725 $patchname .= ".patch";
5727 if (!defined $patchdir) {
5730 if (length $patchdir) {
5731 $patchname = "$patchdir/$patchname";
5733 if ($patchname =~ m{^(.*)/}) {
5734 mkpath "debian/patches/$1";
5739 stat "debian/patches/$patchname$index";
5741 $!==ENOENT or confess "$patchname$index $!";
5743 runcmd @git, qw(checkout -q), $cc;
5745 # We use the tip's changelog so that dpkg-source doesn't
5746 # produce complaining messages from dpkg-parsechangelog. None
5747 # of the information dpkg-source gets from the changelog is
5748 # actually relevant - it gets put into the original message
5749 # which dpkg-source provides our stunt editor, and then
5751 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5753 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5754 "Date: $commitdate\n".
5755 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5757 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5761 sub build_maybe_quilt_fixup () {
5762 my ($format,$fopts) = get_source_format;
5763 return unless madformat_wantfixup $format;
5766 check_for_vendor_patches();
5768 my $clogp = parsechangelog();
5769 my $headref = git_rev_parse('HEAD');
5770 my $symref = git_get_symref();
5771 my $upstreamversion = upstreamversion $version;
5774 changedir $playground;
5776 my $splitbrain_cachekey;
5778 if (do_split_brain()) {
5780 ($cachehit, $splitbrain_cachekey) =
5781 quilt_check_splitbrain_cache($headref, $upstreamversion);
5788 unpack_playtree_need_cd_work($headref);
5789 if (do_split_brain()) {
5790 runcmd @git, qw(checkout -q -b dgit-view);
5791 # so long as work is not deleted, its current branch will
5792 # remain dgit-view, rather than master, so subsequent calls to
5793 # unpack_playtree_need_cd_work
5794 # will DTRT, resetting dgit-view.
5795 confess if $made_split_brain;
5796 $made_split_brain = 1;
5800 if ($fopts->{'single-debian-patch'}) {
5802 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5804 if quiltmode_splitting();
5805 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5807 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5808 $splitbrain_cachekey);
5811 if (do_split_brain()) {
5812 my $dgitview = git_rev_parse 'HEAD';
5815 reflog_cache_insert "refs/$splitbraincache",
5816 $splitbrain_cachekey, $dgitview;
5818 changedir "$playground/work";
5820 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5821 progress f_ "dgit view: created (%s)", $saved;
5825 runcmd_ordryrun_local
5826 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5829 sub build_check_quilt_splitbrain () {
5830 build_maybe_quilt_fixup();
5833 sub unpack_playtree_need_cd_work ($) {
5836 # prep_ud() must have been called already.
5837 if (!chdir "work") {
5838 # Check in the filesystem because sometimes we run prep_ud
5839 # in between multiple calls to unpack_playtree_need_cd_work.
5840 confess "$!" unless $!==ENOENT;
5841 mkdir "work" or confess "$!";
5843 mktree_in_ud_here();
5845 runcmd @git, qw(reset -q --hard), $headref;
5848 sub unpack_playtree_linkorigs ($$) {
5849 my ($upstreamversion, $fn) = @_;
5850 # calls $fn->($leafname);
5852 my $bpd_abs = bpd_abs();
5854 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5856 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5857 while ($!=0, defined(my $leaf = readdir QFD)) {
5858 my $f = bpd_abs()."/".$leaf;
5860 local ($debuglevel) = $debuglevel-1;
5861 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5863 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5864 printdebug "QF linkorigs $leaf, $f Y\n";
5865 link_ltarget $f, $leaf or die "$leaf $!";
5868 die "$buildproductsdir: $!" if $!;
5872 sub quilt_fixup_delete_pc () {
5873 runcmd @git, qw(rm -rqf .pc);
5874 commit_admin +(__ <<END).<<ENDU
5875 Commit removal of .pc (quilt series tracking data)
5878 [dgit ($our_version) upgrade quilt-remove-pc]
5882 sub quilt_fixup_singlepatch ($$$) {
5883 my ($clogp, $headref, $upstreamversion) = @_;
5885 progress __ "starting quiltify (single-debian-patch)";
5887 # dpkg-source --commit generates new patches even if
5888 # single-debian-patch is in debian/source/options. In order to
5889 # get it to generate debian/patches/debian-changes, it is
5890 # necessary to build the source package.
5892 unpack_playtree_linkorigs($upstreamversion, sub { });
5893 unpack_playtree_need_cd_work($headref);
5895 rmtree("debian/patches");
5897 runcmd @dpkgsource, qw(-b .);
5899 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5900 rename srcfn("$upstreamversion", "/debian/patches"),
5901 "work/debian/patches"
5903 or confess "install d/patches: $!";
5906 commit_quilty_patch();
5909 sub quilt_need_fake_dsc ($) {
5910 # cwd should be playground
5911 my ($upstreamversion) = @_;
5913 return if stat_exists "fake.dsc";
5914 # ^ OK to test this as a sentinel because if we created it
5915 # we must either have done the rest too, or crashed.
5917 my $fakeversion="$upstreamversion-~~DGITFAKE";
5919 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5920 print $fakedsc <<END or confess "$!";
5923 Version: $fakeversion
5927 my $dscaddfile=sub {
5930 my $md = new Digest::MD5;
5932 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5933 stat $fh or confess "$!";
5937 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5940 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5942 my @files=qw(debian/source/format debian/rules
5943 debian/control debian/changelog);
5944 foreach my $maybe (qw(debian/patches debian/source/options
5945 debian/tests/control)) {
5946 next unless stat_exists "$maindir/$maybe";
5947 push @files, $maybe;
5950 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5951 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5953 $dscaddfile->($debtar);
5954 close $fakedsc or confess "$!";
5957 sub quilt_fakedsc2unapplied ($$) {
5958 my ($headref, $upstreamversion) = @_;
5959 # must be run in the playground
5960 # quilt_need_fake_dsc must have been called
5962 quilt_need_fake_dsc($upstreamversion);
5964 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5966 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5967 rename $fakexdir, "fake" or die "$fakexdir $!";
5971 remove_stray_gits(__ "source package");
5972 mktree_in_ud_here();
5976 rmtree 'debian'; # git checkout commitish paths does not delete!
5977 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5978 my $unapplied=git_add_write_tree();
5979 printdebug "fake orig tree object $unapplied\n";
5983 sub quilt_check_splitbrain_cache ($$) {
5984 my ($headref, $upstreamversion) = @_;
5985 # Called only if we are in (potentially) split brain mode.
5986 # Called in playground.
5987 # Computes the cache key and looks in the cache.
5988 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5990 quilt_need_fake_dsc($upstreamversion);
5992 my $splitbrain_cachekey;
5995 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5997 # we look in the reflog of dgit-intern/quilt-cache
5998 # we look for an entry whose message is the key for the cache lookup
5999 my @cachekey = (qw(dgit), $our_version);
6000 push @cachekey, $upstreamversion;
6001 push @cachekey, $quilt_mode;
6002 push @cachekey, $headref;
6003 push @cachekey, $quilt_upstream_commitish // '-';
6005 push @cachekey, hashfile('fake.dsc');
6007 my $srcshash = Digest::SHA->new(256);
6008 my %sfs = ( %INC, '$0(dgit)' => $0 );
6009 foreach my $sfk (sort keys %sfs) {
6010 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6011 $srcshash->add($sfk," ");
6012 $srcshash->add(hashfile($sfs{$sfk}));
6013 $srcshash->add("\n");
6015 push @cachekey, $srcshash->hexdigest();
6016 $splitbrain_cachekey = "@cachekey";
6018 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6020 my $cachehit = reflog_cache_lookup
6021 "refs/$splitbraincache", $splitbrain_cachekey;
6024 unpack_playtree_need_cd_work($headref);
6025 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6026 if ($cachehit ne $headref) {
6027 progress f_ "dgit view: found cached (%s)", $saved;
6028 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6029 $made_split_brain = 1;
6030 return ($cachehit, $splitbrain_cachekey);
6032 progress __ "dgit view: found cached, no changes required";
6033 return ($headref, $splitbrain_cachekey);
6036 printdebug "splitbrain cache miss\n";
6037 return (undef, $splitbrain_cachekey);
6040 sub quilt_fixup_multipatch ($$$) {
6041 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6043 progress f_ "examining quilt state (multiple patches, %s mode)",
6047 # - honour any existing .pc in case it has any strangeness
6048 # - determine the git commit corresponding to the tip of
6049 # the patch stack (if there is one)
6050 # - if there is such a git commit, convert each subsequent
6051 # git commit into a quilt patch with dpkg-source --commit
6052 # - otherwise convert all the differences in the tree into
6053 # a single git commit
6057 # Our git tree doesn't necessarily contain .pc. (Some versions of
6058 # dgit would include the .pc in the git tree.) If there isn't
6059 # one, we need to generate one by unpacking the patches that we
6062 # We first look for a .pc in the git tree. If there is one, we
6063 # will use it. (This is not the normal case.)
6065 # Otherwise need to regenerate .pc so that dpkg-source --commit
6066 # can work. We do this as follows:
6067 # 1. Collect all relevant .orig from parent directory
6068 # 2. Generate a debian.tar.gz out of
6069 # debian/{patches,rules,source/format,source/options}
6070 # 3. Generate a fake .dsc containing just these fields:
6071 # Format Source Version Files
6072 # 4. Extract the fake .dsc
6073 # Now the fake .dsc has a .pc directory.
6074 # (In fact we do this in every case, because in future we will
6075 # want to search for a good base commit for generating patches.)
6077 # Then we can actually do the dpkg-source --commit
6078 # 1. Make a new working tree with the same object
6079 # store as our main tree and check out the main
6081 # 2. Copy .pc from the fake's extraction, if necessary
6082 # 3. Run dpkg-source --commit
6083 # 4. If the result has changes to debian/, then
6084 # - git add them them
6085 # - git add .pc if we had a .pc in-tree
6087 # 5. If we had a .pc in-tree, delete it, and git commit
6088 # 6. Back in the main tree, fast forward to the new HEAD
6090 # Another situation we may have to cope with is gbp-style
6091 # patches-unapplied trees.
6093 # We would want to detect these, so we know to escape into
6094 # quilt_fixup_gbp. However, this is in general not possible.
6095 # Consider a package with a one patch which the dgit user reverts
6096 # (with git revert or the moral equivalent).
6098 # That is indistinguishable in contents from a patches-unapplied
6099 # tree. And looking at the history to distinguish them is not
6100 # useful because the user might have made a confusing-looking git
6101 # history structure (which ought to produce an error if dgit can't
6102 # cope, not a silent reintroduction of an unwanted patch).
6104 # So gbp users will have to pass an option. But we can usually
6105 # detect their failure to do so: if the tree is not a clean
6106 # patches-applied tree, quilt linearisation fails, but the tree
6107 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6108 # they want --quilt=unapplied.
6110 # To help detect this, when we are extracting the fake dsc, we
6111 # first extract it with --skip-patches, and then apply the patches
6112 # afterwards with dpkg-source --before-build. That lets us save a
6113 # tree object corresponding to .origs.
6115 if ($quilt_mode eq 'linear'
6116 && branch_is_gdr($headref)) {
6117 # This is much faster. It also makes patches that gdr
6118 # likes better for future updates without laundering.
6120 # However, it can fail in some casses where we would
6121 # succeed: if there are existing patches, which correspond
6122 # to a prefix of the branch, but are not in gbp/gdr
6123 # format, gdr will fail (exiting status 7), but we might
6124 # be able to figure out where to start linearising. That
6125 # will be slower so hopefully there's not much to do.
6127 unpack_playtree_need_cd_work $headref;
6129 my @cmd = (@git_debrebase,
6130 qw(--noop-ok -funclean-mixed -funclean-ordering
6131 make-patches --quiet-would-amend));
6132 # We tolerate soe snags that gdr wouldn't, by default.
6138 and not ($? == 7*256 or
6139 $? == -1 && $!==ENOENT);
6143 $headref = git_rev_parse('HEAD');
6148 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6152 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6154 if (system @bbcmd) {
6155 failedcmd @bbcmd if $? < 0;
6157 failed to apply your git tree's patch stack (from debian/patches/) to
6158 the corresponding upstream tarball(s). Your source tree and .orig
6159 are probably too inconsistent. dgit can only fix up certain kinds of
6160 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6166 unpack_playtree_need_cd_work($headref);
6169 if (stat_exists ".pc") {
6171 progress __ "Tree already contains .pc - will use it then delete it.";
6174 rename '../fake/.pc','.pc' or confess "$!";
6177 changedir '../fake';
6179 my $oldtiptree=git_add_write_tree();
6180 printdebug "fake o+d/p tree object $unapplied\n";
6181 changedir '../work';
6184 # We calculate some guesswork now about what kind of tree this might
6185 # be. This is mostly for error reporting.
6187 my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
6188 my $onlydebian = $tentries eq "debian\0";
6190 my $uheadref = $headref;
6191 my $uhead_whatshort = 'HEAD';
6193 if ($quilt_mode =~ m/baredebian/) {
6194 $uheadref = $quilt_upstream_commitish;
6195 # TRANSLATORS: this translation must fit in the ASCII art
6196 # quilt differences display. The untranslated display
6197 # says %9.9s, so with that display it must be at most 9
6199 $uhead_whatshort = __ 'upstream';
6206 # O = orig, without patches applied
6207 # A = "applied", ie orig with H's debian/patches applied
6208 O2H => quiltify_trees_differ($unapplied,$uheadref, 1,
6209 \%editedignores, \@unrepres),
6210 H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
6211 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6215 foreach my $bits (qw(01 02)) {
6216 foreach my $v (qw(O2H O2A H2A)) {
6217 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6220 printdebug "differences \@dl @dl.\n";
6223 "%s: base trees orig=%.20s o+d/p=%.20s",
6224 $us, $unapplied, $oldtiptree;
6225 # TRANSLATORS: Try to keep this ascii-art layout right. The 0s in
6226 # %9.00009s will be ignored and are there to make the format the
6227 # same length (9 characters) as the output it generates. If you
6228 # change the value 9, your translation of "upstream" must fit into
6229 # the new length, and you should change the number of 0s. Do
6230 # not reduce it below 4 as HEAD has to fit too.
6232 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6233 "%s: quilt differences: %9.00009s %s o+d/p %9.00009s %s o+d/p",
6234 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6235 $us, $uhead_whatshort, $dl[2], $uhead_whatshort, $dl[5];
6237 if (@unrepres && $quilt_mode !~ m/baredebian/) {
6238 # With baredebian, even if the upstream commitish has this
6239 # problem, we don't want to print this message, as nothing
6240 # is going to try to make a patch out of it anyway.
6241 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6244 forceable_fail [qw(unrepresentable)], __ <<END;
6245 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6251 push @failsuggestion, [ 'onlydebian', __
6252 "This has only a debian/ directory; you probably want --quilt=bare debian." ]
6253 unless $quilt_mode =~ m/baredebian/;
6254 } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
6255 push @failsuggestion, [ 'unapplied', __
6256 "This might be a patches-unapplied branch." ];
6257 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6258 push @failsuggestion, [ 'applied', __
6259 "This might be a patches-applied branch." ];
6261 push @failsuggestion, [ 'quilt-mode', __
6262 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6264 push @failsuggestion, [ 'gitattrs', __
6265 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6266 if stat_exists '.gitattributes';
6268 push @failsuggestion, [ 'origs', __
6269 "Maybe orig tarball(s) are not identical to git representation?" ]
6270 unless $onlydebian && $quilt_mode !~ m/baredebian/;
6271 # ^ in that case, we didn't really look properly
6273 if (quiltmode_splitting()) {
6274 quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6275 $diffbits, \%editedignores,
6276 $splitbrain_cachekey);
6280 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6281 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6282 runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6284 if (!open P, '>>', ".pc/applied-patches") {
6285 $!==&ENOENT or confess "$!";
6290 commit_quilty_patch();
6292 if ($mustdeletepc) {
6293 quilt_fixup_delete_pc();
6297 sub quilt_fixup_editor () {
6298 my $descfn = $ENV{$fakeeditorenv};
6299 my $editing = $ARGV[$#ARGV];
6300 open I1, '<', $descfn or confess "$descfn: $!";
6301 open I2, '<', $editing or confess "$editing: $!";
6302 unlink $editing or confess "$editing: $!";
6303 open O, '>', $editing or confess "$editing: $!";
6304 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6307 $copying ||= m/^\-\-\- /;
6308 next unless $copying;
6309 print O or confess "$!";
6311 I2->error and confess "$!";
6316 sub maybe_apply_patches_dirtily () {
6317 return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
6318 print STDERR __ <<END or confess "$!";
6320 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6321 dgit: Have to apply the patches - making the tree dirty.
6322 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6325 $patches_applied_dirtily = 01;
6326 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6327 runcmd qw(dpkg-source --before-build .);
6330 sub maybe_unapply_patches_again () {
6331 progress __ "dgit: Unapplying patches again to tidy up the tree."
6332 if $patches_applied_dirtily;
6333 runcmd qw(dpkg-source --after-build .)
6334 if $patches_applied_dirtily & 01;
6336 if $patches_applied_dirtily & 02;
6337 $patches_applied_dirtily = 0;
6340 #----- other building -----
6342 sub clean_tree_check_git ($$$) {
6343 my ($honour_ignores, $message, $ignmessage) = @_;
6344 my @cmd = (@git, qw(clean -dn));
6345 push @cmd, qw(-x) unless $honour_ignores;
6346 my $leftovers = cmdoutput @cmd;
6347 if (length $leftovers) {
6348 print STDERR $leftovers, "\n" or confess "$!";
6349 $message .= $ignmessage if $honour_ignores;
6354 sub clean_tree_check_git_wd ($) {
6356 return if $cleanmode =~ m{no-check};
6357 return if $patches_applied_dirtily; # yuk
6358 clean_tree_check_git +($cleanmode !~ m{all-check}),
6359 $message, "\n".__ <<END;
6360 If this is just missing .gitignore entries, use a different clean
6361 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6362 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6366 sub clean_tree_check () {
6367 # This function needs to not care about modified but tracked files.
6368 # That was done by check_not_dirty, and by now we may have run
6369 # the rules clean target which might modify tracked files (!)
6370 if ($cleanmode =~ m{^check}) {
6371 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6372 "tree contains uncommitted files and --clean=check specified", '';
6373 } elsif ($cleanmode =~ m{^dpkg-source}) {
6374 clean_tree_check_git_wd __
6375 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6376 } elsif ($cleanmode =~ m{^git}) {
6377 clean_tree_check_git 1, __
6378 "tree contains uncommited, untracked, unignored files\n".
6379 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6380 } elsif ($cleanmode eq 'none') {
6382 confess "$cleanmode ?";
6387 # We always clean the tree ourselves, rather than leave it to the
6388 # builder (dpkg-source, or soemthing which calls dpkg-source).
6389 if ($cleanmode =~ m{^dpkg-source}) {
6390 my @cmd = @dpkgbuildpackage;
6391 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6392 push @cmd, qw(-T clean);
6393 maybe_apply_patches_dirtily();
6394 runcmd_ordryrun_local @cmd;
6395 clean_tree_check_git_wd __
6396 "tree contains uncommitted files (after running rules clean)";
6397 } elsif ($cleanmode =~ m{^git(?!-)}) {
6398 runcmd_ordryrun_local @git, qw(clean -xdf);
6399 } elsif ($cleanmode =~ m{^git-ff}) {
6400 runcmd_ordryrun_local @git, qw(clean -xdff);
6401 } elsif ($cleanmode =~ m{^check}) {
6403 } elsif ($cleanmode eq 'none') {
6405 confess "$cleanmode ?";
6410 badusage __ "clean takes no additional arguments" if @ARGV;
6413 maybe_unapply_patches_again();
6416 # return values from massage_dbp_args are one or both of these flags
6417 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6418 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6420 sub build_or_push_prep_early () {
6421 our $build_or_push_prep_early_done //= 0;
6422 return if $build_or_push_prep_early_done++;
6423 badusage f_ "-p is not allowed with dgit %s", $subcommand
6424 if defined $package;
6425 my $clogp = parsechangelog();
6426 $isuite = getfield $clogp, 'Distribution';
6427 $package = getfield $clogp, 'Source';
6428 $version = getfield $clogp, 'Version';
6429 $dscfn = dscfn($version);
6432 sub build_or_push_prep_modes () {
6433 my ($format,) = determine_whether_split_brain();
6435 fail __ "dgit: --include-dirty is not supported with split view".
6436 " (including with view-splitting quilt modes)"
6437 if do_split_brain() && $includedirty;
6439 if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
6440 my ($dummy, $umessage);
6441 ($quilt_upstream_commitish, $dummy, $umessage) =
6442 resolve_upstream_version
6443 $quilt_upstream_commitish, upstreamversion $version;
6444 progress f_ "dgit: --quilt=%s, %s", $quilt_mode, $umessage;
6445 } elsif (defined $quilt_upstream_commitish) {
6447 "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
6451 sub build_prep_early () {
6452 build_or_push_prep_early();
6454 build_or_push_prep_modes();
6458 sub build_prep ($) {
6462 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6463 # Clean the tree because we're going to use the contents of
6464 # $maindir. (We trying to include dirty changes in the source
6465 # package, or we are running the builder in $maindir.)
6466 || $cleanmode =~ m{always}) {
6467 # Or because the user asked us to.
6470 # We don't actually need to do anything in $maindir, but we
6471 # should do some kind of cleanliness check because (i) the
6472 # user may have forgotten a `git add', and (ii) if the user
6473 # said -wc we should still do the check.
6476 build_check_quilt_splitbrain();
6478 my $pat = changespat $version;
6479 foreach my $f (glob "$buildproductsdir/$pat") {
6482 fail f_ "remove old changes file %s: %s", $f, $!;
6484 progress f_ "would remove %s", $f;
6490 sub changesopts_initial () {
6491 my @opts =@changesopts[1..$#changesopts];
6494 sub changesopts_version () {
6495 if (!defined $changes_since_version) {
6498 @vsns = archive_query('archive_query');
6499 my @quirk = access_quirk();
6500 if ($quirk[0] eq 'backports') {
6501 local $isuite = $quirk[2];
6503 canonicalise_suite();
6504 push @vsns, archive_query('archive_query');
6510 "archive query failed (queried because --since-version not specified)";
6513 @vsns = map { $_->[0] } @vsns;
6514 @vsns = sort { -version_compare($a, $b) } @vsns;
6515 $changes_since_version = $vsns[0];
6516 progress f_ "changelog will contain changes since %s", $vsns[0];
6518 $changes_since_version = '_';
6519 progress __ "package seems new, not specifying -v<version>";
6522 if ($changes_since_version ne '_') {
6523 return ("-v$changes_since_version");
6529 sub changesopts () {
6530 return (changesopts_initial(), changesopts_version());
6533 sub massage_dbp_args ($;$) {
6534 my ($cmd,$xargs) = @_;
6535 # Since we split the source build out so we can do strange things
6536 # to it, massage the arguments to dpkg-buildpackage so that the
6537 # main build doessn't build source (or add an argument to stop it
6538 # building source by default).
6539 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6540 # -nc has the side effect of specifying -b if nothing else specified
6541 # and some combinations of -S, -b, et al, are errors, rather than
6542 # later simply overriding earlie. So we need to:
6543 # - search the command line for these options
6544 # - pick the last one
6545 # - perhaps add our own as a default
6546 # - perhaps adjust it to the corresponding non-source-building version
6548 foreach my $l ($cmd, $xargs) {
6550 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6553 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6554 my $r = WANTSRC_BUILDER;
6555 printdebug "massage split $dmode.\n";
6556 if ($dmode =~ s/^--build=//) {
6558 my @d = split /,/, $dmode;
6559 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6560 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6561 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6562 fail __ "Wanted to build nothing!" unless $r;
6563 $dmode = '--build='. join ',', grep m/./, @d;
6566 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6567 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6568 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6571 printdebug "massage done $r $dmode.\n";
6573 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6579 my $wasdir = must_getcwd();
6580 changedir $buildproductsdir;
6585 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6586 sub postbuild_mergechanges ($) {
6587 my ($msg_if_onlyone) = @_;
6588 # If there is only one .changes file, fail with $msg_if_onlyone,
6589 # or if that is undef, be a no-op.
6590 # Returns the changes file to report to the user.
6591 my $pat = changespat $version;
6592 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6593 @changesfiles = sort {
6594 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6598 if (@changesfiles==1) {
6599 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6600 only one changes file from build (%s)
6602 if defined $msg_if_onlyone;
6603 $result = $changesfiles[0];
6604 } elsif (@changesfiles==2) {
6605 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6606 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6607 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6610 runcmd_ordryrun_local @mergechanges, @changesfiles;
6611 my $multichanges = changespat $version,'multi';
6613 stat_exists $multichanges or fail f_
6614 "%s unexpectedly not created by build", $multichanges;
6615 foreach my $cf (glob $pat) {
6616 next if $cf eq $multichanges;
6617 rename "$cf", "$cf.inmulti" or fail f_
6618 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6621 $result = $multichanges;
6623 fail f_ "wrong number of different changes files (%s)",
6626 printdone f_ "build successful, results in %s\n", $result
6630 sub midbuild_checkchanges () {
6631 my $pat = changespat $version;
6632 return if $rmchanges;
6633 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6635 $_ ne changespat $version,'source' and
6636 $_ ne changespat $version,'multi'
6638 fail +(f_ <<END, $pat, "@unwanted")
6639 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6640 Suggest you delete %s.
6645 sub midbuild_checkchanges_vanilla ($) {
6647 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6650 sub postbuild_mergechanges_vanilla ($) {
6652 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6654 postbuild_mergechanges(undef);
6657 printdone __ "build successful\n";
6663 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6664 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6665 %s: warning: build-products-dir will be ignored; files will go to ..
6667 $buildproductsdir = '..';
6668 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6669 my $wantsrc = massage_dbp_args \@dbp;
6670 build_prep($wantsrc);
6671 if ($wantsrc & WANTSRC_SOURCE) {
6673 midbuild_checkchanges_vanilla $wantsrc;
6675 if ($wantsrc & WANTSRC_BUILDER) {
6676 push @dbp, changesopts_version();
6677 maybe_apply_patches_dirtily();
6678 runcmd_ordryrun_local @dbp;
6680 maybe_unapply_patches_again();
6681 postbuild_mergechanges_vanilla $wantsrc;
6685 $quilt_mode //= 'gbp';
6691 # gbp can make .origs out of thin air. In my tests it does this
6692 # even for a 1.0 format package, with no origs present. So I
6693 # guess it keys off just the version number. We don't know
6694 # exactly what .origs ought to exist, but let's assume that we
6695 # should run gbp if: the version has an upstream part and the main
6697 my $upstreamversion = upstreamversion $version;
6698 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6699 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6701 if ($gbp_make_orig) {
6703 $cleanmode = 'none'; # don't do it again
6706 my @dbp = @dpkgbuildpackage;
6708 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6710 if (!length $gbp_build[0]) {
6711 if (length executable_on_path('git-buildpackage')) {
6712 $gbp_build[0] = qw(git-buildpackage);
6714 $gbp_build[0] = 'gbp buildpackage';
6717 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6719 push @cmd, (qw(-us -uc --git-no-sign-tags),
6720 "--git-builder=".(shellquote @dbp));
6722 if ($gbp_make_orig) {
6723 my $priv = dgit_privdir();
6724 my $ok = "$priv/origs-gen-ok";
6725 unlink $ok or $!==&ENOENT or confess "$!";
6726 my @origs_cmd = @cmd;
6727 push @origs_cmd, qw(--git-cleaner=true);
6728 push @origs_cmd, "--git-prebuild=".
6729 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6730 push @origs_cmd, @ARGV;
6732 debugcmd @origs_cmd;
6734 do { local $!; stat_exists $ok; }
6735 or failedcmd @origs_cmd;
6737 dryrun_report @origs_cmd;
6741 build_prep($wantsrc);
6742 if ($wantsrc & WANTSRC_SOURCE) {
6744 midbuild_checkchanges_vanilla $wantsrc;
6746 push @cmd, '--git-cleaner=true';
6748 maybe_unapply_patches_again();
6749 if ($wantsrc & WANTSRC_BUILDER) {
6750 push @cmd, changesopts();
6751 runcmd_ordryrun_local @cmd, @ARGV;
6753 postbuild_mergechanges_vanilla $wantsrc;
6755 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6757 sub building_source_in_playtree {
6758 # If $includedirty, we have to build the source package from the
6759 # working tree, not a playtree, so that uncommitted changes are
6760 # included (copying or hardlinking them into the playtree could
6763 # Note that if we are building a source package in split brain
6764 # mode we do not support including uncommitted changes, because
6765 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6766 # building a source package)) => !$includedirty
6767 return !$includedirty;
6771 $sourcechanges = changespat $version,'source';
6773 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6774 or fail f_ "remove %s: %s", $sourcechanges, $!;
6776 # confess unless !!$made_split_brain == do_split_brain();
6778 my @cmd = (@dpkgsource, qw(-b --));
6780 if (building_source_in_playtree()) {
6782 my $headref = git_rev_parse('HEAD');
6783 # If we are in split brain, there is already a playtree with
6784 # the thing we should package into a .dsc (thanks to quilt
6785 # fixup). If not, make a playtree
6786 prep_ud() unless $made_split_brain;
6787 changedir $playground;
6788 unless ($made_split_brain) {
6789 my $upstreamversion = upstreamversion $version;
6790 unpack_playtree_linkorigs($upstreamversion, sub { });
6791 unpack_playtree_need_cd_work($headref);
6795 $leafdir = basename $maindir;
6797 if ($buildproductsdir ne '..') {
6798 # Well, we are going to run dpkg-source -b which consumes
6799 # origs from .. and generates output there. To make this
6800 # work when the bpd is not .. , we would have to (i) link
6801 # origs from bpd to .. , (ii) check for files that
6802 # dpkg-source -b would/might overwrite, and afterwards
6803 # (iii) move all the outputs back to the bpd (iv) except
6804 # for the origs which should be deleted from .. if they
6805 # weren't there beforehand. And if there is an error and
6806 # we don't run to completion we would necessarily leave a
6807 # mess. This is too much. The real way to fix this
6808 # is for dpkg-source to have bpd support.
6809 confess unless $includedirty;
6811 "--include-dirty not supported with --build-products-dir, sorry";
6816 runcmd_ordryrun_local @cmd, $leafdir;
6819 runcmd_ordryrun_local qw(sh -ec),
6820 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6821 @dpkggenchanges, qw(-S), changesopts();
6824 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6825 $dsc = parsecontrol($dscfn, "source package");
6829 printdebug " renaming ($why) $l\n";
6830 rename_link_xf 0, "$l", bpd_abs()."/$l"
6831 or fail f_ "put in place new built file (%s): %s", $l, $@;
6833 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6834 $l =~ m/\S+$/ or next;
6837 $mv->('dsc', $dscfn);
6838 $mv->('changes', $sourcechanges);
6843 sub cmd_build_source {
6844 badusage __ "build-source takes no additional arguments" if @ARGV;
6845 build_prep(WANTSRC_SOURCE);
6847 maybe_unapply_patches_again();
6848 printdone f_ "source built, results in %s and %s",
6849 $dscfn, $sourcechanges;
6852 sub cmd_push_source {
6855 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6856 "sense with push-source!"
6858 build_check_quilt_splitbrain();
6860 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6861 __ "source changes file");
6862 unless (test_source_only_changes($changes)) {
6863 fail __ "user-specified changes file is not source-only";
6866 # Building a source package is very fast, so just do it
6868 confess "er, patches are applied dirtily but shouldn't be.."
6869 if $patches_applied_dirtily;
6870 $changesfile = $sourcechanges;
6875 sub binary_builder {
6876 my ($bbuilder, $pbmc_msg, @args) = @_;
6877 build_prep(WANTSRC_SOURCE);
6879 midbuild_checkchanges();
6882 stat_exists $dscfn or fail f_
6883 "%s (in build products dir): %s", $dscfn, $!;
6884 stat_exists $sourcechanges or fail f_
6885 "%s (in build products dir): %s", $sourcechanges, $!;
6887 runcmd_ordryrun_local @$bbuilder, @args;
6889 maybe_unapply_patches_again();
6891 postbuild_mergechanges($pbmc_msg);
6897 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6898 perhaps you need to pass -A ? (sbuild's default is to build only
6899 arch-specific binaries; dgit 1.4 used to override that.)
6904 my ($pbuilder) = @_;
6906 # @ARGV is allowed to contain only things that should be passed to
6907 # pbuilder under debbuildopts; just massage those
6908 my $wantsrc = massage_dbp_args \@ARGV;
6910 "you asked for a builder but your debbuildopts didn't ask for".
6911 " any binaries -- is this really what you meant?"
6912 unless $wantsrc & WANTSRC_BUILDER;
6914 "we must build a .dsc to pass to the builder but your debbuiltopts".
6915 " forbids the building of a source package; cannot continue"
6916 unless $wantsrc & WANTSRC_SOURCE;
6917 # We do not want to include the verb "build" in @pbuilder because
6918 # the user can customise @pbuilder and they shouldn't be required
6919 # to include "build" in their customised value. However, if the
6920 # user passes any additional args to pbuilder using the dgit
6921 # option --pbuilder:foo, such args need to come after the "build"
6922 # verb. opts_opt_multi_cmd does all of that.
6923 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6924 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6929 pbuilder(\@pbuilder);
6932 sub cmd_cowbuilder {
6933 pbuilder(\@cowbuilder);
6936 sub cmd_quilt_fixup {
6937 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6940 build_maybe_quilt_fixup();
6943 sub cmd_print_unapplied_treeish {
6944 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6946 my $headref = git_rev_parse('HEAD');
6947 my $clogp = commit_getclogp $headref;
6948 $package = getfield $clogp, 'Source';
6949 $version = getfield $clogp, 'Version';
6950 $isuite = getfield $clogp, 'Distribution';
6951 $csuite = $isuite; # we want this to be offline!
6955 changedir $playground;
6956 my $uv = upstreamversion $version;
6957 my $u = quilt_fakedsc2unapplied($headref, $uv);
6958 print $u, "\n" or confess "$!";
6961 sub import_dsc_result {
6962 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6963 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6965 check_gitattrs($newhash, __ "source tree");
6967 progress f_ "dgit: import-dsc: %s", $what_msg;
6970 sub cmd_import_dsc {
6974 last unless $ARGV[0] =~ m/^-/;
6977 if (m/^--require-valid-signature$/) {
6980 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6984 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6986 my ($dscfn, $dstbranch) = @ARGV;
6988 badusage __ "dry run makes no sense with import-dsc"
6991 my $force = $dstbranch =~ s/^\+// ? +1 :
6992 $dstbranch =~ s/^\.\.// ? -1 :
6994 my $info = $force ? " $&" : '';
6995 $info = "$dscfn$info";
6997 my $specbranch = $dstbranch;
6998 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6999 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
7001 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
7002 my $chead = cmdoutput_errok @symcmd;
7003 defined $chead or $?==256 or failedcmd @symcmd;
7005 fail f_ "%s is checked out - will not update it", $dstbranch
7006 if defined $chead and $chead eq $dstbranch;
7008 my $oldhash = git_get_ref $dstbranch;
7010 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
7011 $dscdata = do { local $/ = undef; <D>; };
7012 D->error and fail f_ "read %s: %s", $dscfn, $!;
7015 # we don't normally need this so import it here
7016 use Dpkg::Source::Package;
7017 my $dp = new Dpkg::Source::Package filename => $dscfn,
7018 require_valid_signature => $needsig;
7020 local $SIG{__WARN__} = sub {
7022 return unless $needsig;
7023 fail __ "import-dsc signature check failed";
7025 if (!$dp->is_signed()) {
7026 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
7028 my $r = $dp->check_signature();
7029 confess "->check_signature => $r" if $needsig && $r;
7035 $package = getfield $dsc, 'Source';
7037 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
7038 unless forceing [qw(import-dsc-with-dgit-field)];
7039 parse_dsc_field_def_dsc_distro();
7041 $isuite = 'DGIT-IMPORT-DSC';
7042 $idistro //= $dsc_distro;
7046 if (defined $dsc_hash) {
7048 "dgit: import-dsc of .dsc with Dgit field, using git hash";
7049 resolve_dsc_field_commit undef, undef;
7051 if (defined $dsc_hash) {
7052 my @cmd = (qw(sh -ec),
7053 "echo $dsc_hash | git cat-file --batch-check");
7054 my $objgot = cmdoutput @cmd;
7055 if ($objgot =~ m#^\w+ missing\b#) {
7056 fail f_ <<END, $dsc_hash
7057 .dsc contains Dgit field referring to object %s
7058 Your git tree does not have that object. Try `git fetch' from a
7059 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7062 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7064 progress __ "Not fast forward, forced update.";
7066 fail f_ "Not fast forward to %s", $dsc_hash;
7069 import_dsc_result $dstbranch, $dsc_hash,
7070 "dgit import-dsc (Dgit): $info",
7071 f_ "updated git ref %s", $dstbranch;
7075 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7076 Branch %s already exists
7077 Specify ..%s for a pseudo-merge, binding in existing history
7078 Specify +%s to overwrite, discarding existing history
7080 if $oldhash && !$force;
7082 my @dfi = dsc_files_info();
7083 foreach my $fi (@dfi) {
7084 my $f = $fi->{Filename};
7085 # We transfer all the pieces of the dsc to the bpd, not just
7086 # origs. This is by analogy with dgit fetch, which wants to
7087 # keep them somewhere to avoid downloading them again.
7088 # We make symlinks, though. If the user wants copies, then
7089 # they can copy the parts of the dsc to the bpd using dcmd,
7091 my $here = "$buildproductsdir/$f";
7096 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7098 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7099 printdebug "not in bpd, $f ...\n";
7100 # $f does not exist in bpd, we need to transfer it
7102 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7103 # $there is file we want, relative to user's cwd, or abs
7104 printdebug "not in bpd, $f, test $there ...\n";
7105 stat $there or fail f_
7106 "import %s requires %s, but: %s", $dscfn, $there, $!;
7107 if ($there =~ m#^(?:\./+)?\.\./+#) {
7108 # $there is relative to user's cwd
7109 my $there_from_parent = $';
7110 if ($buildproductsdir !~ m{^/}) {
7111 # abs2rel, despite its name, can take two relative paths
7112 $there = File::Spec->abs2rel($there,$buildproductsdir);
7113 # now $there is relative to bpd, great
7114 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7116 $there = (dirname $maindir)."/$there_from_parent";
7117 # now $there is absoute
7118 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7120 } elsif ($there =~ m#^/#) {
7121 # $there is absolute already
7122 printdebug "not in bpd, $f, abs, $there ...\n";
7125 "cannot import %s which seems to be inside working tree!",
7128 symlink $there, $here or fail f_
7129 "symlink %s to %s: %s", $there, $here, $!;
7130 progress f_ "made symlink %s -> %s", $here, $there;
7131 # print STDERR Dumper($fi);
7133 my @mergeinputs = generate_commits_from_dsc();
7134 die unless @mergeinputs == 1;
7136 my $newhash = $mergeinputs[0]{Commit};
7141 "Import, forced update - synthetic orphan git history.";
7142 } elsif ($force < 0) {
7143 progress __ "Import, merging.";
7144 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7145 my $version = getfield $dsc, 'Version';
7146 my $clogp = commit_getclogp $newhash;
7147 my $authline = clogp_authline $clogp;
7148 $newhash = hash_commit_text <<ENDU
7156 .(f_ <<END, $package, $version, $dstbranch);
7157 Merge %s (%s) import into %s
7160 die; # caught earlier
7164 import_dsc_result $dstbranch, $newhash,
7165 "dgit import-dsc: $info",
7166 f_ "results are in git ref %s", $dstbranch;
7169 sub pre_archive_api_query () {
7170 not_necessarily_a_tree();
7172 sub cmd_archive_api_query {
7173 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7174 my ($subpath) = @ARGV;
7175 local $isuite = 'DGIT-API-QUERY-CMD';
7176 my @cmd = archive_api_query_cmd($subpath);
7179 exec @cmd or fail f_ "exec curl: %s\n", $!;
7182 sub repos_server_url () {
7183 $package = '_dgit-repos-server';
7184 local $access_forpush = 1;
7185 local $isuite = 'DGIT-REPOS-SERVER';
7186 my $url = access_giturl();
7189 sub pre_clone_dgit_repos_server () {
7190 not_necessarily_a_tree();
7192 sub cmd_clone_dgit_repos_server {
7193 badusage __ "need destination argument" unless @ARGV==1;
7194 my ($destdir) = @ARGV;
7195 my $url = repos_server_url();
7196 my @cmd = (@git, qw(clone), $url, $destdir);
7198 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7201 sub pre_print_dgit_repos_server_source_url () {
7202 not_necessarily_a_tree();
7204 sub cmd_print_dgit_repos_server_source_url {
7206 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7208 my $url = repos_server_url();
7209 print $url, "\n" or confess "$!";
7212 sub pre_print_dpkg_source_ignores {
7213 not_necessarily_a_tree();
7215 sub cmd_print_dpkg_source_ignores {
7217 "no arguments allowed to dgit print-dpkg-source-ignores"
7219 print "@dpkg_source_ignores\n" or confess "$!";
7222 sub cmd_setup_mergechangelogs {
7223 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7225 local $isuite = 'DGIT-SETUP-TREE';
7226 setup_mergechangelogs(1);
7229 sub cmd_setup_useremail {
7230 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7231 local $isuite = 'DGIT-SETUP-TREE';
7235 sub cmd_setup_gitattributes {
7236 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7237 local $isuite = 'DGIT-SETUP-TREE';
7241 sub cmd_setup_new_tree {
7242 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7243 local $isuite = 'DGIT-SETUP-TREE';
7247 #---------- argument parsing and main program ----------
7250 print "dgit version $our_version\n" or confess "$!";
7254 our (%valopts_long, %valopts_short);
7255 our (%funcopts_long);
7257 our (@modeopt_cfgs);
7259 sub defvalopt ($$$$) {
7260 my ($long,$short,$val_re,$how) = @_;
7261 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7262 $valopts_long{$long} = $oi;
7263 $valopts_short{$short} = $oi;
7264 # $how subref should:
7265 # do whatever assignemnt or thing it likes with $_[0]
7266 # if the option should not be passed on to remote, @rvalopts=()
7267 # or $how can be a scalar ref, meaning simply assign the value
7270 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7271 defvalopt '--distro', '-d', '.+', \$idistro;
7272 defvalopt '', '-k', '.+', \$keyid;
7273 defvalopt '--existing-package','', '.*', \$existing_package;
7274 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7275 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7276 defvalopt '--package', '-p', $package_re, \$package;
7277 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7279 defvalopt '', '-C', '.+', sub {
7280 ($changesfile) = (@_);
7281 if ($changesfile =~ s#^(.*)/##) {
7282 $buildproductsdir = $1;
7286 defvalopt '--initiator-tempdir','','.*', sub {
7287 ($initiator_tempdir) = (@_);
7288 $initiator_tempdir =~ m#^/# or
7289 badusage __ "--initiator-tempdir must be used specify an".
7290 " absolute, not relative, directory."
7293 sub defoptmodes ($@) {
7294 my ($varref, $cfgkey, $default, %optmap) = @_;
7296 while (my ($opt,$val) = each %optmap) {
7297 $funcopts_long{$opt} = sub { $$varref = $val; };
7298 $permit{$val} = $val;
7300 push @modeopt_cfgs, {
7303 Default => $default,
7308 defoptmodes \$dodep14tag, qw( dep14tag want
7311 --always-dep14tag always );
7316 if (defined $ENV{'DGIT_SSH'}) {
7317 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7318 } elsif (defined $ENV{'GIT_SSH'}) {
7319 @ssh = ($ENV{'GIT_SSH'});
7327 if (!defined $val) {
7328 badusage f_ "%s needs a value", $what unless @ARGV;
7330 push @rvalopts, $val;
7332 badusage f_ "bad value \`%s' for %s", $val, $what unless
7333 $val =~ m/^$oi->{Re}$(?!\n)/s;
7334 my $how = $oi->{How};
7335 if (ref($how) eq 'SCALAR') {
7340 push @ropts, @rvalopts;
7344 last unless $ARGV[0] =~ m/^-/;
7348 if (m/^--dry-run$/) {
7351 } elsif (m/^--damp-run$/) {
7354 } elsif (m/^--no-sign$/) {
7357 } elsif (m/^--help$/) {
7359 } elsif (m/^--version$/) {
7361 } elsif (m/^--new$/) {
7364 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7365 ($om = $opts_opt_map{$1}) &&
7369 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7370 !$opts_opt_cmdonly{$1} &&
7371 ($om = $opts_opt_map{$1})) {
7374 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7375 !$opts_opt_cmdonly{$1} &&
7376 ($om = $opts_opt_map{$1})) {
7378 my $cmd = shift @$om;
7379 @$om = ($cmd, grep { $_ ne $2 } @$om);
7380 } elsif (m/^--(gbp|dpm|baredebian)$/s) {
7381 push @ropts, "--quilt=$1";
7383 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7386 } elsif (m/^--no-quilt-fixup$/s) {
7388 $quilt_mode = 'nocheck';
7389 } elsif (m/^--no-rm-on-error$/s) {
7392 } elsif (m/^--no-chase-dsc-distro$/s) {
7394 $chase_dsc_distro = 0;
7395 } elsif (m/^--overwrite$/s) {
7397 $overwrite_version = '';
7398 } elsif (m/^--split-(?:view|brain)$/s) {
7400 $splitview_mode = 'always';
7401 } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7403 $splitview_mode = $1;
7404 } elsif (m/^--overwrite=(.+)$/s) {
7406 $overwrite_version = $1;
7407 } elsif (m/^--delayed=(\d+)$/s) {
7410 } elsif (m/^--upstream-commitish=(.+)$/s) {
7412 $quilt_upstream_commitish = $1;
7413 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7414 m/^--(dgit-view)-save=(.+)$/s
7416 my ($k,$v) = ($1,$2);
7418 $v =~ s#^(?!refs/)#refs/heads/#;
7419 $internal_object_save{$k} = $v;
7420 } elsif (m/^--(no-)?rm-old-changes$/s) {
7423 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7425 push @deliberatelies, $&;
7426 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7430 } elsif (m/^--force-/) {
7432 f_ "%s: warning: ignoring unknown force option %s\n",
7435 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7436 # undocumented, for testing
7438 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7439 # ^ it's supposed to be an array ref
7440 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7441 $val = $2 ? $' : undef; #';
7442 $valopt->($oi->{Long});
7443 } elsif ($funcopts_long{$_}) {
7445 $funcopts_long{$_}();
7447 badusage f_ "unknown long option \`%s'", $_;
7454 } elsif (s/^-L/-/) {
7457 } elsif (s/^-h/-/) {
7459 } elsif (s/^-D/-/) {
7463 } elsif (s/^-N/-/) {
7468 push @changesopts, $_;
7470 } elsif (s/^-wn$//s) {
7472 $cleanmode = 'none';
7473 } elsif (s/^-wg(f?)(a?)$//s) {
7476 $cleanmode .= '-ff' if $1;
7477 $cleanmode .= ',always' if $2;
7478 } elsif (s/^-wd(d?)([na]?)$//s) {
7480 $cleanmode = 'dpkg-source';
7481 $cleanmode .= '-d' if $1;
7482 $cleanmode .= ',no-check' if $2 eq 'n';
7483 $cleanmode .= ',all-check' if $2 eq 'a';
7484 } elsif (s/^-wc$//s) {
7486 $cleanmode = 'check';
7487 } elsif (s/^-wci$//s) {
7489 $cleanmode = 'check,ignores';
7490 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7491 push @git, '-c', $&;
7492 $gitcfgs{cmdline}{$1} = [ $2 ];
7493 } elsif (s/^-c([^=]+)$//s) {
7494 push @git, '-c', $&;
7495 $gitcfgs{cmdline}{$1} = [ 'true' ];
7496 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7498 $val = undef unless length $val;
7499 $valopt->($oi->{Short});
7502 badusage f_ "unknown short option \`%s'", $_;
7509 sub check_env_sanity () {
7510 my $blocked = new POSIX::SigSet;
7511 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7514 foreach my $name (qw(PIPE CHLD)) {
7515 my $signame = "SIG$name";
7516 my $signum = eval "POSIX::$signame" // die;
7517 die f_ "%s is set to something other than SIG_DFL\n",
7519 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7520 $blocked->ismember($signum) and
7521 die f_ "%s is blocked\n", $signame;
7527 On entry to dgit, %s
7528 This is a bug produced by something in your execution environment.
7534 sub parseopts_late_defaults () {
7535 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7536 if defined $idistro;
7537 $isuite //= cfg('dgit.default.default-suite');
7539 foreach my $k (keys %opts_opt_map) {
7540 my $om = $opts_opt_map{$k};
7542 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7544 badcfg f_ "cannot set command for %s", $k
7545 unless length $om->[0];
7549 foreach my $c (access_cfg_cfgs("opts-$k")) {
7551 map { $_ ? @$_ : () }
7552 map { $gitcfgs{$_}{$c} }
7553 reverse @gitcfgsources;
7554 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7555 "\n" if $debuglevel >= 4;
7557 badcfg f_ "cannot configure options for %s", $k
7558 if $opts_opt_cmdonly{$k};
7559 my $insertpos = $opts_cfg_insertpos{$k};
7560 @$om = ( @$om[0..$insertpos-1],
7562 @$om[$insertpos..$#$om] );
7566 if (!defined $rmchanges) {
7567 local $access_forpush;
7568 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7571 if (!defined $quilt_mode) {
7572 local $access_forpush;
7573 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7574 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7576 $quilt_mode =~ m/^($quilt_modes_re)$/
7577 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7581 foreach my $moc (@modeopt_cfgs) {
7582 local $access_forpush;
7583 my $vr = $moc->{Var};
7584 next if defined $$vr;
7585 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7586 my $v = $moc->{Vals}{$$vr};
7587 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7593 local $access_forpush;
7594 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7598 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7599 $buildproductsdir //= '..';
7600 $bpd_glob = $buildproductsdir;
7601 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7604 setlocale(LC_MESSAGES, "");
7607 if ($ENV{$fakeeditorenv}) {
7609 quilt_fixup_editor();
7615 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7616 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7617 if $dryrun_level == 1;
7619 print STDERR __ $helpmsg or confess "$!";
7622 $cmd = $subcommand = shift @ARGV;
7625 my $pre_fn = ${*::}{"pre_$cmd"};
7626 $pre_fn->() if $pre_fn;
7628 if ($invoked_in_git_tree) {
7629 changedir_git_toplevel();
7634 my $fn = ${*::}{"cmd_$cmd"};
7635 $fn or badusage f_ "unknown operation %s", $cmd;