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_upstream_commitish_used;
84 our $quilt_upstream_commitish_message;
85 our $quilt_options_re = 'gbp|dpm|baredebian';
86 our $quilt_modes_re = "linear|smash|auto|nofix|nocheck|unapplied|$quilt_options_re";
88 our $splitview_modes_re = qr{auto|always|never};
90 our %internal_object_save;
91 our $we_are_responder;
92 our $we_are_initiator;
93 our $initiator_tempdir;
94 our $patches_applied_dirtily = 00;
95 our $chase_dsc_distro=1;
97 our %forceopts = map { $_=>0 }
98 qw(unrepresentable unsupported-source-format
99 dsc-changes-mismatch changes-origs-exactly
100 uploading-binaries uploading-source-only
101 import-gitapply-absurd
102 import-gitapply-no-absurd
103 import-dsc-with-dgit-field);
105 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
107 our $suite_re = '[-+.0-9a-z]+';
108 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
109 | (?: git | git-ff ) (?: ,always )?
110 | check (?: ,ignores )?
114 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
115 our $splitbraincache = 'dgit-intern/quilt-cache';
116 our $rewritemap = 'dgit-rewrite/map';
118 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
120 our (@git) = qw(git);
121 our (@dget) = qw(dget);
122 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
123 our (@dput) = qw(dput);
124 our (@debsign) = qw(debsign);
125 our (@gpg) = qw(gpg);
126 our (@sbuild) = (qw(sbuild --no-source));
128 our (@dgit) = qw(dgit);
129 our (@git_debrebase) = qw(git-debrebase);
130 our (@aptget) = qw(apt-get);
131 our (@aptcache) = qw(apt-cache);
132 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
133 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
134 our (@dpkggenchanges) = qw(dpkg-genchanges);
135 our (@mergechanges) = qw(mergechanges -f);
136 our (@gbp_build) = ('');
137 our (@gbp_pq) = ('gbp pq');
138 our (@changesopts) = ('');
139 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
140 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
142 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
145 'debsign' => \@debsign,
147 'sbuild' => \@sbuild,
151 'git-debrebase' => \@git_debrebase,
152 'apt-get' => \@aptget,
153 'apt-cache' => \@aptcache,
154 'dpkg-source' => \@dpkgsource,
155 'dpkg-buildpackage' => \@dpkgbuildpackage,
156 'dpkg-genchanges' => \@dpkggenchanges,
157 'gbp-build' => \@gbp_build,
158 'gbp-pq' => \@gbp_pq,
159 'ch' => \@changesopts,
160 'mergechanges' => \@mergechanges,
161 'pbuilder' => \@pbuilder,
162 'cowbuilder' => \@cowbuilder);
164 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
165 our %opts_cfg_insertpos = map {
167 scalar @{ $opts_opt_map{$_} }
168 } keys %opts_opt_map;
170 sub parseopts_late_defaults();
171 sub quiltify_trees_differ ($$;$$$);
172 sub setup_gitattrs(;$);
173 sub check_gitattrs($$);
180 our $supplementary_message = '';
181 our $made_split_brain = 0;
184 # Interactions between quilt mode and split brain
185 # (currently, split brain only implemented iff
186 # madformat_wantfixup && quiltmode_splitting)
188 # source format sane `3.0 (quilt)'
189 # madformat_wantfixup()
191 # quilt mode normal quiltmode
192 # (eg linear) _splitbrain
194 # ------------ ------------------------------------------------
196 # no split no q cache no q cache forbidden,
197 # brain PM on master q fixup on master prevented
198 # !do_split_brain() PM on master
200 # split brain no q cache q fixup cached, to dgit view
201 # PM in dgit view PM in dgit view
203 # PM = pseudomerge to make ff, due to overwrite (or split view)
204 # "no q cache" = do not record in cache on build, do not check cache
205 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
209 return unless forkcheck_mainprocess();
210 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
213 our $remotename = 'dgit';
214 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
218 if (!defined $absurdity) {
220 $absurdity =~ s{/[^/]+$}{/absurd} or die;
223 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
225 sub lbranch () { return "$branchprefix/$csuite"; }
226 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
227 sub lref () { return "refs/heads/".lbranch(); }
228 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
229 sub rrref () { return server_ref($csuite); }
232 my ($vsn, $sfx) = @_;
233 return &source_file_leafname($package, $vsn, $sfx);
235 sub is_orig_file_of_vsn ($$) {
236 my ($f, $upstreamvsn) = @_;
237 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
242 return srcfn($vsn,".dsc");
245 sub changespat ($;$) {
246 my ($vsn, $arch) = @_;
247 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
256 return unless forkcheck_mainprocess();
257 foreach my $f (@end) {
259 print STDERR "$us: cleanup: $@" if length $@;
264 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
268 sub forceable_fail ($$) {
269 my ($forceoptsl, $msg) = @_;
270 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
271 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
275 my ($forceoptsl) = @_;
276 my @got = grep { $forceopts{$_} } @$forceoptsl;
277 return 0 unless @got;
279 "warning: skipping checks or functionality due to --force-%s\n",
283 sub no_such_package () {
284 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
285 $us, $package, $isuite;
289 sub deliberately ($) {
291 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
294 sub deliberately_not_fast_forward () {
295 foreach (qw(not-fast-forward fresh-repo)) {
296 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
300 sub quiltmode_splitting () {
301 $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/;
304 sub do_split_brain () { !!($do_split_brain // confess) }
306 sub opts_opt_multi_cmd {
309 push @cmd, split /\s+/, shift @_;
316 return opts_opt_multi_cmd [], @gbp_pq;
319 sub dgit_privdir () {
320 our $dgit_privdir_made //= ensure_a_playground 'dgit';
324 my $r = $buildproductsdir;
325 $r = "$maindir/$r" unless $r =~ m{^/};
329 sub get_tree_of_commit ($) {
330 my ($commitish) = @_;
331 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
332 $cdata =~ m/\n\n/; $cdata = $`;
333 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
337 sub branch_gdr_info ($$) {
338 my ($symref, $head) = @_;
339 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
340 gdr_ffq_prev_branchinfo($symref);
341 return () unless $status eq 'branch';
342 $ffq_prev = git_get_ref $ffq_prev;
343 $gdrlast = git_get_ref $gdrlast;
344 $gdrlast &&= is_fast_fwd $gdrlast, $head;
345 return ($ffq_prev, $gdrlast);
348 sub branch_is_gdr_unstitched_ff ($$$) {
349 my ($symref, $head, $ancestor) = @_;
350 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
351 return 0 unless $ffq_prev;
352 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
356 sub branch_is_gdr ($) {
358 # This is quite like git-debrebase's keycommits.
359 # We have our own implementation because:
360 # - our algorighm can do fewer tests so is faster
361 # - it saves testing to see if gdr is installed
363 # NB we use this jsut for deciding whether to run gdr make-patches
364 # Before reusing this algorithm for somthing else, its
365 # suitability should be reconsidered.
368 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
369 printdebug "branch_is_gdr $head...\n";
370 my $get_patches = sub {
371 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
374 my $tip_patches = $get_patches->($head);
377 my $cdata = git_cat_file $walk, 'commit';
378 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
379 if ($msg =~ m{^\[git-debrebase\ (
380 anchor | changelog | make-patches |
381 merged-breakwater | pseudomerge
383 # no need to analyse this - it's sufficient
384 # (gdr classifications: Anchor, MergedBreakwaters)
385 # (made by gdr: Pseudomerge, Changelog)
386 printdebug "branch_is_gdr $walk gdr $1 YES\n";
389 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
391 my $walk_tree = get_tree_of_commit $walk;
392 foreach my $p (@parents) {
393 my $p_tree = get_tree_of_commit $p;
394 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
395 # (gdr classification: Pseudomerge; not made by gdr)
396 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
402 # some other non-gdr merge
403 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
404 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
408 # (gdr classification: ?)
409 printdebug "branch_is_gdr $walk ?-octopus NO\n";
413 printdebug "branch_is_gdr $walk origin\n";
416 if ($get_patches->($walk) ne $tip_patches) {
417 # Our parent added, removed, or edited patches, and wasn't
418 # a gdr make-patches commit. gdr make-patches probably
419 # won't do that well, then.
420 # (gdr classification of parent: AddPatches or ?)
421 printdebug "branch_is_gdr $walk ?-patches NO\n";
424 if ($tip_patches eq '' and
425 !defined git_cat_file "$walk~:debian" and
426 !quiltify_trees_differ "$walk~", $walk
428 # (gdr classification of parent: BreakwaterStart
429 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
432 # (gdr classification: Upstream Packaging Mixed Changelog)
433 printdebug "branch_is_gdr $walk plain\n"
439 #---------- remote protocol support, common ----------
441 # remote push initiator/responder protocol:
442 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
443 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
444 # < dgit-remote-push-ready <actual-proto-vsn>
451 # > supplementary-message NBYTES
456 # > file parsed-changelog
457 # [indicates that output of dpkg-parsechangelog follows]
458 # > data-block NBYTES
459 # > [NBYTES bytes of data (no newline)]
460 # [maybe some more blocks]
469 # > param head DGIT-VIEW-HEAD
470 # > param csuite SUITE
471 # > param tagformat new # $protovsn == 4
472 # > param maint-view MAINT-VIEW-HEAD
474 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
475 # > file buildinfo # for buildinfos to sign
477 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
478 # # goes into tag, for replay prevention
481 # [indicates that signed tag is wanted]
482 # < data-block NBYTES
483 # < [NBYTES bytes of data (no newline)]
484 # [maybe some more blocks]
488 # > want signed-dsc-changes
489 # < data-block NBYTES [transfer of signed dsc]
491 # < data-block NBYTES [transfer of signed changes]
493 # < data-block NBYTES [transfer of each signed buildinfo
494 # [etc] same number and order as "file buildinfo"]
502 sub i_child_report () {
503 # Sees if our child has died, and reap it if so. Returns a string
504 # describing how it died if it failed, or undef otherwise.
505 return undef unless $i_child_pid;
506 my $got = waitpid $i_child_pid, WNOHANG;
507 return undef if $got <= 0;
508 die unless $got == $i_child_pid;
509 $i_child_pid = undef;
510 return undef unless $?;
511 return f_ "build host child %s", waitstatusmsg();
516 fail f_ "connection lost: %s", $! if $fh->error;
517 fail f_ "protocol violation; %s not expected", $m;
520 sub badproto_badread ($$) {
522 fail f_ "connection lost: %s", $! if $!;
523 my $report = i_child_report();
524 fail $report if defined $report;
525 badproto $fh, f_ "eof (reading %s)", $wh;
528 sub protocol_expect (&$) {
529 my ($match, $fh) = @_;
532 defined && chomp or badproto_badread $fh, __ "protocol message";
540 badproto $fh, f_ "\`%s'", $_;
543 sub protocol_send_file ($$) {
544 my ($fh, $ourfn) = @_;
545 open PF, "<", $ourfn or die "$ourfn: $!";
548 my $got = read PF, $d, 65536;
549 die "$ourfn: $!" unless defined $got;
551 print $fh "data-block ".length($d)."\n" or confess "$!";
552 print $fh $d or confess "$!";
554 PF->error and die "$ourfn $!";
555 print $fh "data-end\n" or confess "$!";
559 sub protocol_read_bytes ($$) {
560 my ($fh, $nbytes) = @_;
561 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
563 my $got = read $fh, $d, $nbytes;
564 $got==$nbytes or badproto_badread $fh, __ "data block";
568 sub protocol_receive_file ($$) {
569 my ($fh, $ourfn) = @_;
570 printdebug "() $ourfn\n";
571 open PF, ">", $ourfn or die "$ourfn: $!";
573 my ($y,$l) = protocol_expect {
574 m/^data-block (.*)$/ ? (1,$1) :
575 m/^data-end$/ ? (0,) :
579 my $d = protocol_read_bytes $fh, $l;
580 print PF $d or confess "$!";
582 close PF or confess "$!";
585 #---------- remote protocol support, responder ----------
587 sub responder_send_command ($) {
589 return unless $we_are_responder;
590 # called even without $we_are_responder
591 printdebug ">> $command\n";
592 print PO $command, "\n" or confess "$!";
595 sub responder_send_file ($$) {
596 my ($keyword, $ourfn) = @_;
597 return unless $we_are_responder;
598 printdebug "]] $keyword $ourfn\n";
599 responder_send_command "file $keyword";
600 protocol_send_file \*PO, $ourfn;
603 sub responder_receive_files ($@) {
604 my ($keyword, @ourfns) = @_;
605 die unless $we_are_responder;
606 printdebug "[[ $keyword @ourfns\n";
607 responder_send_command "want $keyword";
608 foreach my $fn (@ourfns) {
609 protocol_receive_file \*PI, $fn;
612 protocol_expect { m/^files-end$/ } \*PI;
615 #---------- remote protocol support, initiator ----------
617 sub initiator_expect (&) {
619 protocol_expect { &$match } \*RO;
622 #---------- end remote code ----------
625 if ($we_are_responder) {
627 responder_send_command "progress ".length($m) or confess "$!";
628 print PO $m or confess "$!";
638 $ua = LWP::UserAgent->new();
642 progress "downloading $what...";
643 my $r = $ua->get(@_) or confess "$!";
644 return undef if $r->code == 404;
645 $r->is_success or fail f_ "failed to fetch %s: %s",
646 $what, $r->status_line;
647 return $r->decoded_content(charset => 'none');
650 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
652 sub act_local () { return $dryrun_level <= 1; }
653 sub act_scary () { return !$dryrun_level; }
656 if (!$dryrun_level) {
657 progress f_ "%s ok: %s", $us, "@_";
659 progress f_ "would be ok: %s (but dry run only)", "@_";
664 printcmd(\*STDERR,$debugprefix."#",@_);
667 sub runcmd_ordryrun {
675 sub runcmd_ordryrun_local {
683 our $helpmsg = i_ <<END;
685 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
686 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
687 dgit [dgit-opts] build [dpkg-buildpackage-opts]
688 dgit [dgit-opts] sbuild [sbuild-opts]
689 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
690 dgit [dgit-opts] push [dgit-opts] [suite]
691 dgit [dgit-opts] push-source [dgit-opts] [suite]
692 dgit [dgit-opts] rpush build-host:build-dir ...
693 important dgit options:
694 -k<keyid> sign tag and package with <keyid> instead of default
695 --dry-run -n do not change anything, but go through the motions
696 --damp-run -L like --dry-run but make local changes, without signing
697 --new -N allow introducing a new package
698 --debug -D increase debug level
699 -c<name>=<value> set git config option (used directly by dgit too)
702 our $later_warning_msg = i_ <<END;
703 Perhaps the upload is stuck in incoming. Using the version from git.
707 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
712 @ARGV or badusage __ "too few arguments";
713 return scalar shift @ARGV;
717 not_necessarily_a_tree();
720 print __ $helpmsg or confess "$!";
724 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
726 our %defcfg = ('dgit.default.distro' => 'debian',
727 'dgit.default.default-suite' => 'unstable',
728 'dgit.default.old-dsc-distro' => 'debian',
729 'dgit-suite.*-security.distro' => 'debian-security',
730 'dgit.default.username' => '',
731 'dgit.default.archive-query-default-component' => 'main',
732 'dgit.default.ssh' => 'ssh',
733 'dgit.default.archive-query' => 'madison:',
734 'dgit.default.sshpsql-dbname' => 'service=projectb',
735 'dgit.default.aptget-components' => 'main',
736 'dgit.default.source-only-uploads' => 'ok',
737 'dgit.dsc-url-proto-ok.http' => 'true',
738 'dgit.dsc-url-proto-ok.https' => 'true',
739 'dgit.dsc-url-proto-ok.git' => 'true',
740 'dgit.vcs-git.suites', => 'sid', # ;-separated
741 'dgit.default.dsc-url-proto-ok' => 'false',
742 # old means "repo server accepts pushes with old dgit tags"
743 # new means "repo server accepts pushes with new dgit tags"
744 # maint means "repo server accepts split brain pushes"
745 # hist means "repo server may have old pushes without new tag"
746 # ("hist" is implied by "old")
747 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
748 'dgit-distro.debian.git-check' => 'url',
749 'dgit-distro.debian.git-check-suffix' => '/info/refs',
750 'dgit-distro.debian.new-private-pushers' => 't',
751 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
752 'dgit-distro.debian/push.git-url' => '',
753 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
754 'dgit-distro.debian/push.git-user-force' => 'dgit',
755 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
756 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
757 'dgit-distro.debian/push.git-create' => 'true',
758 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
759 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
760 # 'dgit-distro.debian.archive-query-tls-key',
761 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
762 # ^ this does not work because curl is broken nowadays
763 # Fixing #790093 properly will involve providing providing the key
764 # in some pacagke and maybe updating these paths.
766 # 'dgit-distro.debian.archive-query-tls-curl-args',
767 # '--ca-path=/etc/ssl/ca-debian',
768 # ^ this is a workaround but works (only) on DSA-administered machines
769 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
770 'dgit-distro.debian.git-url-suffix' => '',
771 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
772 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
773 'dgit-distro.debian-security.archive-query' => 'aptget:',
774 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
775 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
776 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
777 'dgit-distro.debian-security.nominal-distro' => 'debian',
778 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
779 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
780 'dgit-distro.ubuntu.git-check' => 'false',
781 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
782 'dgit-distro.test-dummy.ssh' => "$td/ssh",
783 'dgit-distro.test-dummy.username' => "alice",
784 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
785 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
786 'dgit-distro.test-dummy.git-url' => "$td/git",
787 'dgit-distro.test-dummy.git-host' => "git",
788 'dgit-distro.test-dummy.git-path' => "$td/git",
789 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
790 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
791 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
792 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
796 our @gitcfgsources = qw(cmdline local global system);
797 our $invoked_in_git_tree = 1;
799 sub git_slurp_config () {
800 # This algoritm is a bit subtle, but this is needed so that for
801 # options which we want to be single-valued, we allow the
802 # different config sources to override properly. See #835858.
803 foreach my $src (@gitcfgsources) {
804 next if $src eq 'cmdline';
805 # we do this ourselves since git doesn't handle it
807 $gitcfgs{$src} = git_slurp_config_src $src;
811 sub git_get_config ($) {
813 foreach my $src (@gitcfgsources) {
814 my $l = $gitcfgs{$src}{$c};
815 confess "internal error ($l $c)" if $l && !ref $l;
816 printdebug"C $c ".(defined $l ?
817 join " ", map { messagequote "'$_'" } @$l :
822 f_ "multiple values for %s (in %s git config)", $c, $src
824 $l->[0] =~ m/\n/ and badcfg f_
825 "value for config option %s (in %s git config) contains newline(s)!",
834 return undef if $c =~ /RETURN-UNDEF/;
835 printdebug "C? $c\n" if $debuglevel >= 5;
836 my $v = git_get_config($c);
837 return $v if defined $v;
838 my $dv = $defcfg{$c};
840 printdebug "CD $c $dv\n" if $debuglevel >= 4;
845 "need value for one of: %s\n".
846 "%s: distro or suite appears not to be (properly) supported",
850 sub not_necessarily_a_tree () {
851 # needs to be called from pre_*
852 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
853 $invoked_in_git_tree = 0;
856 sub access_basedistro__noalias () {
857 if (defined $idistro) {
860 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
861 return $def if defined $def;
862 foreach my $src (@gitcfgsources, 'internal') {
863 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
865 foreach my $k (keys %$kl) {
866 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
868 next unless match_glob $dpat, $isuite;
872 return cfg("dgit.default.distro");
876 sub access_basedistro () {
877 my $noalias = access_basedistro__noalias();
878 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
879 return $canon // $noalias;
882 sub access_nomdistro () {
883 my $base = access_basedistro();
884 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
885 $r =~ m/^$distro_re$/ or badcfg
886 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
887 $r, "/^$distro_re$/";
891 sub access_quirk () {
892 # returns (quirk name, distro to use instead or undef, quirk-specific info)
893 my $basedistro = access_basedistro();
894 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
896 if (defined $backports_quirk) {
897 my $re = $backports_quirk;
898 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
900 $re =~ s/\%/([-0-9a-z_]+)/
901 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
902 if ($isuite =~ m/^$re$/) {
903 return ('backports',"$basedistro-backports",$1);
906 return ('none',undef);
911 sub parse_cfg_bool ($$$) {
912 my ($what,$def,$v) = @_;
915 $v =~ m/^[ty1]/ ? 1 :
916 $v =~ m/^[fn0]/ ? 0 :
917 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
921 sub access_forpush_config () {
922 my $d = access_basedistro();
926 parse_cfg_bool('new-private-pushers', 0,
927 cfg("dgit-distro.$d.new-private-pushers",
930 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
933 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
934 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
935 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
937 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
940 sub access_forpush () {
941 $access_forpush //= access_forpush_config();
942 return $access_forpush;
945 sub default_from_access_cfg ($$$;$) {
946 my ($var, $keybase, $defval, $permit_re) = @_;
947 return if defined $$var;
949 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
950 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
952 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
955 badcfg f_ "unknown %s \`%s'", $keybase, $$var
956 if defined $permit_re and $$var !~ m/$permit_re/;
960 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
961 defined $access_forpush and !$access_forpush;
962 badcfg __ "pushing but distro is configured readonly"
963 if access_forpush_config() eq '0';
965 $supplementary_message = __ <<'END' unless $we_are_responder;
966 Push failed, before we got started.
967 You can retry the push, after fixing the problem, if you like.
969 parseopts_late_defaults();
973 parseopts_late_defaults();
976 sub determine_whether_split_brain () {
977 my ($format,) = get_source_format();
980 local $access_forpush;
981 default_from_access_cfg(\$splitview_mode, 'split-view', 'auto',
982 $splitview_modes_re);
983 $do_split_brain = 1 if $splitview_mode eq 'always';
986 printdebug "format $format, quilt mode $quilt_mode\n";
988 if (madformat_wantfixup($format) && quiltmode_splitting()) {
989 $splitview_mode ne 'never' or
990 fail f_ "dgit: quilt mode \`%s' (for format \`%s')".
991 " implies split view, but split-view set to \`%s'",
992 $quilt_mode, $format, $splitview_mode;
995 $do_split_brain //= 0;
1000 sub supplementary_message ($) {
1002 if (!$we_are_responder) {
1003 $supplementary_message = $msg;
1006 responder_send_command "supplementary-message ".length($msg)
1008 print PO $msg or confess "$!";
1012 sub access_distros () {
1013 # Returns list of distros to try, in order
1016 # 0. `instead of' distro name(s) we have been pointed to
1017 # 1. the access_quirk distro, if any
1018 # 2a. the user's specified distro, or failing that } basedistro
1019 # 2b. the distro calculated from the suite }
1020 my @l = access_basedistro();
1022 my (undef,$quirkdistro) = access_quirk();
1023 unshift @l, $quirkdistro;
1024 unshift @l, $instead_distro;
1025 @l = grep { defined } @l;
1027 push @l, access_nomdistro();
1029 if (access_forpush()) {
1030 @l = map { ("$_/push", $_) } @l;
1035 sub access_cfg_cfgs (@) {
1038 # The nesting of these loops determines the search order. We put
1039 # the key loop on the outside so that we search all the distros
1040 # for each key, before going on to the next key. That means that
1041 # if access_cfg is called with a more specific, and then a less
1042 # specific, key, an earlier distro can override the less specific
1043 # without necessarily overriding any more specific keys. (If the
1044 # distro wants to override the more specific keys it can simply do
1045 # so; whereas if we did the loop the other way around, it would be
1046 # impossible to for an earlier distro to override a less specific
1047 # key but not the more specific ones without restating the unknown
1048 # values of the more specific keys.
1051 # We have to deal with RETURN-UNDEF specially, so that we don't
1052 # terminate the search prematurely.
1054 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1057 foreach my $d (access_distros()) {
1058 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1060 push @cfgs, map { "dgit.default.$_" } @realkeys;
1061 push @cfgs, @rundef;
1065 sub access_cfg (@) {
1067 my (@cfgs) = access_cfg_cfgs(@keys);
1068 my $value = cfg(@cfgs);
1072 sub access_cfg_bool ($$) {
1073 my ($def, @keys) = @_;
1074 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1077 sub string_to_ssh ($) {
1079 if ($spec =~ m/\s/) {
1080 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1086 sub access_cfg_ssh () {
1087 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1088 if (!defined $gitssh) {
1091 return string_to_ssh $gitssh;
1095 sub access_runeinfo ($) {
1097 return ": dgit ".access_basedistro()." $info ;";
1100 sub access_someuserhost ($) {
1102 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1103 defined($user) && length($user) or
1104 $user = access_cfg("$some-user",'username');
1105 my $host = access_cfg("$some-host");
1106 return length($user) ? "$user\@$host" : $host;
1109 sub access_gituserhost () {
1110 return access_someuserhost('git');
1113 sub access_giturl (;$) {
1114 my ($optional) = @_;
1115 my $url = access_cfg('git-url','RETURN-UNDEF');
1118 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1119 return undef unless defined $proto;
1122 access_gituserhost().
1123 access_cfg('git-path');
1125 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1128 return "$url/$package$suffix";
1131 sub commit_getclogp ($) {
1132 # Returns the parsed changelog hashref for a particular commit
1134 our %commit_getclogp_memo;
1135 my $memo = $commit_getclogp_memo{$objid};
1136 return $memo if $memo;
1138 my $mclog = dgit_privdir()."clog";
1139 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1140 "$objid:debian/changelog";
1141 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1144 sub parse_dscdata () {
1145 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1146 printdebug Dumper($dscdata) if $debuglevel>1;
1147 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1148 printdebug Dumper($dsc) if $debuglevel>1;
1153 sub archive_query ($;@) {
1154 my ($method) = shift @_;
1155 fail __ "this operation does not support multiple comma-separated suites"
1157 my $query = access_cfg('archive-query','RETURN-UNDEF');
1158 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1161 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1164 sub archive_query_prepend_mirror {
1165 my $m = access_cfg('mirror');
1166 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1169 sub pool_dsc_subpath ($$) {
1170 my ($vsn,$component) = @_; # $package is implict arg
1171 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1172 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1175 sub cfg_apply_map ($$$) {
1176 my ($varref, $what, $mapspec) = @_;
1177 return unless $mapspec;
1179 printdebug "config $what EVAL{ $mapspec; }\n";
1181 eval "package Dgit::Config; $mapspec;";
1186 #---------- `ftpmasterapi' archive query method (nascent) ----------
1188 sub archive_api_query_cmd ($) {
1190 my @cmd = (@curl, qw(-sS));
1191 my $url = access_cfg('archive-query-url');
1192 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1194 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1195 foreach my $key (split /\:/, $keys) {
1196 $key =~ s/\%HOST\%/$host/g;
1198 fail "for $url: stat $key: $!" unless $!==ENOENT;
1201 fail f_ "config requested specific TLS key but do not know".
1202 " how to get curl to use exactly that EE key (%s)",
1204 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1205 # # Sadly the above line does not work because of changes
1206 # # to gnutls. The real fix for #790093 may involve
1207 # # new curl options.
1210 # Fixing #790093 properly will involve providing a value
1211 # for this on clients.
1212 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1213 push @cmd, split / /, $kargs if defined $kargs;
1215 push @cmd, $url.$subpath;
1219 sub api_query ($$;$) {
1221 my ($data, $subpath, $ok404) = @_;
1222 badcfg __ "ftpmasterapi archive query method takes no data part"
1224 my @cmd = archive_api_query_cmd($subpath);
1225 my $url = $cmd[$#cmd];
1226 push @cmd, qw(-w %{http_code});
1227 my $json = cmdoutput @cmd;
1228 unless ($json =~ s/\d+\d+\d$//) {
1229 failedcmd_report_cmd undef, @cmd;
1230 fail __ "curl failed to print 3-digit HTTP code";
1233 return undef if $code eq '404' && $ok404;
1234 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1235 unless $url =~ m#^file://# or $code =~ m/^2/;
1236 return decode_json($json);
1239 sub canonicalise_suite_ftpmasterapi {
1240 my ($proto,$data) = @_;
1241 my $suites = api_query($data, 'suites');
1243 foreach my $entry (@$suites) {
1245 my $v = $entry->{$_};
1246 defined $v && $v eq $isuite;
1247 } qw(codename name);
1248 push @matched, $entry;
1250 fail f_ "unknown suite %s, maybe -d would help", $isuite
1254 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1255 $cn = "$matched[0]{codename}";
1256 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1257 $cn =~ m/^$suite_re$/
1258 or die f_ "suite %s maps to bad codename\n", $isuite;
1260 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1265 sub archive_query_ftpmasterapi {
1266 my ($proto,$data) = @_;
1267 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1269 my $digester = Digest::SHA->new(256);
1270 foreach my $entry (@$info) {
1272 my $vsn = "$entry->{version}";
1273 my ($ok,$msg) = version_check $vsn;
1274 die f_ "bad version: %s\n", $msg unless $ok;
1275 my $component = "$entry->{component}";
1276 $component =~ m/^$component_re$/ or die __ "bad component";
1277 my $filename = "$entry->{filename}";
1278 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1279 or die __ "bad filename";
1280 my $sha256sum = "$entry->{sha256sum}";
1281 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1282 push @rows, [ $vsn, "/pool/$component/$filename",
1283 $digester, $sha256sum ];
1285 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1288 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1289 return archive_query_prepend_mirror @rows;
1292 sub file_in_archive_ftpmasterapi {
1293 my ($proto,$data,$filename) = @_;
1294 my $pat = $filename;
1297 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1298 my $info = api_query($data, "file_in_archive/$pat", 1);
1301 sub package_not_wholly_new_ftpmasterapi {
1302 my ($proto,$data,$pkg) = @_;
1303 my $info = api_query($data,"madison?package=${pkg}&f=json");
1307 #---------- `aptget' archive query method ----------
1310 our $aptget_releasefile;
1311 our $aptget_configpath;
1313 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1314 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1316 sub aptget_cache_clean {
1317 runcmd_ordryrun_local qw(sh -ec),
1318 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1322 sub aptget_lock_acquire () {
1323 my $lockfile = "$aptget_base/lock";
1324 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1325 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1328 sub aptget_prep ($) {
1330 return if defined $aptget_base;
1332 badcfg __ "aptget archive query method takes no data part"
1335 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1338 ensuredir "$cache/dgit";
1340 access_cfg('aptget-cachekey','RETURN-UNDEF')
1341 // access_nomdistro();
1343 $aptget_base = "$cache/dgit/aptget";
1344 ensuredir $aptget_base;
1346 my $quoted_base = $aptget_base;
1347 confess "$quoted_base contains bad chars, cannot continue"
1348 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1350 ensuredir $aptget_base;
1352 aptget_lock_acquire();
1354 aptget_cache_clean();
1356 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1357 my $sourceslist = "source.list#$cachekey";
1359 my $aptsuites = $isuite;
1360 cfg_apply_map(\$aptsuites, 'suite map',
1361 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1363 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1364 printf SRCS "deb-src %s %s %s\n",
1365 access_cfg('mirror'),
1367 access_cfg('aptget-components')
1370 ensuredir "$aptget_base/cache";
1371 ensuredir "$aptget_base/lists";
1373 open CONF, ">", $aptget_configpath or confess "$!";
1375 Debug::NoLocking "true";
1376 APT::Get::List-Cleanup "false";
1377 #clear APT::Update::Post-Invoke-Success;
1378 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1379 Dir::State::Lists "$quoted_base/lists";
1380 Dir::Etc::preferences "$quoted_base/preferences";
1381 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1382 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1385 foreach my $key (qw(
1388 Dir::Cache::Archives
1389 Dir::Etc::SourceParts
1390 Dir::Etc::preferencesparts
1392 ensuredir "$aptget_base/$key";
1393 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1396 my $oldatime = (time // confess "$!") - 1;
1397 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1398 next unless stat_exists $oldlist;
1399 my ($mtime) = (stat _)[9];
1400 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1403 runcmd_ordryrun_local aptget_aptget(), qw(update);
1406 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1407 next unless stat_exists $oldlist;
1408 my ($atime) = (stat _)[8];
1409 next if $atime == $oldatime;
1410 push @releasefiles, $oldlist;
1412 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1413 @releasefiles = @inreleasefiles if @inreleasefiles;
1414 if (!@releasefiles) {
1415 fail f_ <<END, $isuite, $cache;
1416 apt seemed to not to update dgit's cached Release files for %s.
1418 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1421 confess "apt updated too many Release files (@releasefiles), erk"
1422 unless @releasefiles == 1;
1424 ($aptget_releasefile) = @releasefiles;
1427 sub canonicalise_suite_aptget {
1428 my ($proto,$data) = @_;
1431 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1433 foreach my $name (qw(Codename Suite)) {
1434 my $val = $release->{$name};
1436 printdebug "release file $name: $val\n";
1437 $val =~ m/^$suite_re$/o or fail f_
1438 "Release file (%s) specifies intolerable %s",
1439 $aptget_releasefile, $name;
1440 cfg_apply_map(\$val, 'suite rmap',
1441 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1448 sub archive_query_aptget {
1449 my ($proto,$data) = @_;
1452 ensuredir "$aptget_base/source";
1453 foreach my $old (<$aptget_base/source/*.dsc>) {
1454 unlink $old or die "$old: $!";
1457 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1458 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1459 # avoids apt-get source failing with ambiguous error code
1461 runcmd_ordryrun_local
1462 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1463 aptget_aptget(), qw(--download-only --only-source source), $package;
1465 my @dscs = <$aptget_base/source/*.dsc>;
1466 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1467 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1470 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1473 my $uri = "file://". uri_escape $dscs[0];
1474 $uri =~ s{\%2f}{/}gi;
1475 return [ (getfield $pre_dsc, 'Version'), $uri ];
1478 sub file_in_archive_aptget () { return undef; }
1479 sub package_not_wholly_new_aptget () { return undef; }
1481 #---------- `dummyapicat' archive query method ----------
1482 # (untranslated, because this is for testing purposes etc.)
1484 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1485 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1487 sub dummycatapi_run_in_mirror ($@) {
1488 # runs $fn with FIA open onto rune
1489 my ($rune, $argl, $fn) = @_;
1491 my $mirror = access_cfg('mirror');
1492 $mirror =~ s#^file://#/# or die "$mirror ?";
1493 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1494 qw(x), $mirror, @$argl);
1495 debugcmd "-|", @cmd;
1496 open FIA, "-|", @cmd or confess "$!";
1498 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1502 sub file_in_archive_dummycatapi ($$$) {
1503 my ($proto,$data,$filename) = @_;
1505 dummycatapi_run_in_mirror '
1506 find -name "$1" -print0 |
1508 ', [$filename], sub {
1511 printdebug "| $_\n";
1512 m/^(\w+) (\S+)$/ or die "$_ ?";
1513 push @out, { sha256sum => $1, filename => $2 };
1519 sub package_not_wholly_new_dummycatapi {
1520 my ($proto,$data,$pkg) = @_;
1521 dummycatapi_run_in_mirror "
1522 find -name ${pkg}_*.dsc
1529 #---------- `madison' archive query method ----------
1531 sub archive_query_madison {
1532 return archive_query_prepend_mirror
1533 map { [ @$_[0..1] ] } madison_get_parse(@_);
1536 sub madison_get_parse {
1537 my ($proto,$data) = @_;
1538 die unless $proto eq 'madison';
1539 if (!length $data) {
1540 $data= access_cfg('madison-distro','RETURN-UNDEF');
1541 $data //= access_basedistro();
1543 $rmad{$proto,$data,$package} ||= cmdoutput
1544 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1545 my $rmad = $rmad{$proto,$data,$package};
1548 foreach my $l (split /\n/, $rmad) {
1549 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1550 \s*( [^ \t|]+ )\s* \|
1551 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1552 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1553 $1 eq $package or die "$rmad $package ?";
1560 $component = access_cfg('archive-query-default-component');
1562 $5 eq 'source' or die "$rmad ?";
1563 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1565 return sort { -version_compare($a->[0],$b->[0]); } @out;
1568 sub canonicalise_suite_madison {
1569 # madison canonicalises for us
1570 my @r = madison_get_parse(@_);
1572 "unable to canonicalise suite using package %s".
1573 " which does not appear to exist in suite %s;".
1574 " --existing-package may help",
1579 sub file_in_archive_madison { return undef; }
1580 sub package_not_wholly_new_madison { return undef; }
1582 #---------- `sshpsql' archive query method ----------
1583 # (untranslated, because this is obsolete)
1586 my ($data,$runeinfo,$sql) = @_;
1587 if (!length $data) {
1588 $data= access_someuserhost('sshpsql').':'.
1589 access_cfg('sshpsql-dbname');
1591 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1592 my ($userhost,$dbname) = ($`,$'); #';
1594 my @cmd = (access_cfg_ssh, $userhost,
1595 access_runeinfo("ssh-psql $runeinfo").
1596 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1597 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1599 open P, "-|", @cmd or confess "$!";
1602 printdebug(">|$_|\n");
1605 $!=0; $?=0; close P or failedcmd @cmd;
1607 my $nrows = pop @rows;
1608 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1609 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1610 @rows = map { [ split /\|/, $_ ] } @rows;
1611 my $ncols = scalar @{ shift @rows };
1612 die if grep { scalar @$_ != $ncols } @rows;
1616 sub sql_injection_check {
1617 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1620 sub archive_query_sshpsql ($$) {
1621 my ($proto,$data) = @_;
1622 sql_injection_check $isuite, $package;
1623 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1624 SELECT source.version, component.name, files.filename, files.sha256sum
1626 JOIN src_associations ON source.id = src_associations.source
1627 JOIN suite ON suite.id = src_associations.suite
1628 JOIN dsc_files ON dsc_files.source = source.id
1629 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1630 JOIN component ON component.id = files_archive_map.component_id
1631 JOIN files ON files.id = dsc_files.file
1632 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1633 AND source.source='$package'
1634 AND files.filename LIKE '%.dsc';
1636 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1637 my $digester = Digest::SHA->new(256);
1639 my ($vsn,$component,$filename,$sha256sum) = @$_;
1640 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1642 return archive_query_prepend_mirror @rows;
1645 sub canonicalise_suite_sshpsql ($$) {
1646 my ($proto,$data) = @_;
1647 sql_injection_check $isuite;
1648 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1649 SELECT suite.codename
1650 FROM suite where suite_name='$isuite' or codename='$isuite';
1652 @rows = map { $_->[0] } @rows;
1653 fail "unknown suite $isuite" unless @rows;
1654 die "ambiguous $isuite: @rows ?" if @rows>1;
1658 sub file_in_archive_sshpsql ($$$) { return undef; }
1659 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1661 #---------- `dummycat' archive query method ----------
1662 # (untranslated, because this is for testing purposes etc.)
1664 sub canonicalise_suite_dummycat ($$) {
1665 my ($proto,$data) = @_;
1666 my $dpath = "$data/suite.$isuite";
1667 if (!open C, "<", $dpath) {
1668 $!==ENOENT or die "$dpath: $!";
1669 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1673 chomp or die "$dpath: $!";
1675 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1679 sub archive_query_dummycat ($$) {
1680 my ($proto,$data) = @_;
1681 canonicalise_suite();
1682 my $dpath = "$data/package.$csuite.$package";
1683 if (!open C, "<", $dpath) {
1684 $!==ENOENT or die "$dpath: $!";
1685 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1693 printdebug "dummycat query $csuite $package $dpath | $_\n";
1694 my @row = split /\s+/, $_;
1695 @row==2 or die "$dpath: $_ ?";
1698 C->error and die "$dpath: $!";
1700 return archive_query_prepend_mirror
1701 sort { -version_compare($a->[0],$b->[0]); } @rows;
1704 sub file_in_archive_dummycat () { return undef; }
1705 sub package_not_wholly_new_dummycat () { return undef; }
1707 #---------- archive query entrypoints and rest of program ----------
1709 sub canonicalise_suite () {
1710 return if defined $csuite;
1711 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1712 $csuite = archive_query('canonicalise_suite');
1713 if ($isuite ne $csuite) {
1714 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1716 progress f_ "canonical suite name is %s", $csuite;
1720 sub get_archive_dsc () {
1721 canonicalise_suite();
1722 my @vsns = archive_query('archive_query');
1723 foreach my $vinfo (@vsns) {
1724 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1725 $dscurl = $vsn_dscurl;
1726 $dscdata = url_get($dscurl);
1728 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1733 $digester->add($dscdata);
1734 my $got = $digester->hexdigest();
1736 fail f_ "%s has hash %s but archive told us to expect %s",
1737 $dscurl, $got, $digest;
1740 my $fmt = getfield $dsc, 'Format';
1741 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1742 f_ "unsupported source format %s, sorry", $fmt;
1744 $dsc_checked = !!$digester;
1745 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1749 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1752 sub check_for_git ();
1753 sub check_for_git () {
1755 my $how = access_cfg('git-check');
1756 if ($how eq 'ssh-cmd') {
1758 (access_cfg_ssh, access_gituserhost(),
1759 access_runeinfo("git-check $package").
1760 " set -e; cd ".access_cfg('git-path').";".
1761 " if test -d $package.git; then echo 1; else echo 0; fi");
1762 my $r= cmdoutput @cmd;
1763 if (defined $r and $r =~ m/^divert (\w+)$/) {
1765 my ($usedistro,) = access_distros();
1766 # NB that if we are pushing, $usedistro will be $distro/push
1767 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1768 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1769 progress f_ "diverting to %s (using config for %s)",
1770 $divert, $instead_distro;
1771 return check_for_git();
1773 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1775 } elsif ($how eq 'url') {
1776 my $prefix = access_cfg('git-check-url','git-url');
1777 my $suffix = access_cfg('git-check-suffix','git-suffix',
1778 'RETURN-UNDEF') // '.git';
1779 my $url = "$prefix/$package$suffix";
1780 my @cmd = (@curl, qw(-sS -I), $url);
1781 my $result = cmdoutput @cmd;
1782 $result =~ s/^\S+ 200 .*\n\r?\n//;
1783 # curl -sS -I with https_proxy prints
1784 # HTTP/1.0 200 Connection established
1785 $result =~ m/^\S+ (404|200) /s or
1786 fail +(__ "unexpected results from git check query - ").
1787 Dumper($prefix, $result);
1789 if ($code eq '404') {
1791 } elsif ($code eq '200') {
1796 } elsif ($how eq 'true') {
1798 } elsif ($how eq 'false') {
1801 badcfg f_ "unknown git-check \`%s'", $how;
1805 sub create_remote_git_repo () {
1806 my $how = access_cfg('git-create');
1807 if ($how eq 'ssh-cmd') {
1809 (access_cfg_ssh, access_gituserhost(),
1810 access_runeinfo("git-create $package").
1811 "set -e; cd ".access_cfg('git-path').";".
1812 " cp -a _template $package.git");
1813 } elsif ($how eq 'true') {
1816 badcfg f_ "unknown git-create \`%s'", $how;
1820 our ($dsc_hash,$lastpush_mergeinput);
1821 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1825 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1826 $playground = fresh_playground 'dgit/unpack';
1829 sub mktree_in_ud_here () {
1830 playtree_setup $gitcfgs{local};
1833 sub git_write_tree () {
1834 my $tree = cmdoutput @git, qw(write-tree);
1835 $tree =~ m/^\w+$/ or die "$tree ?";
1839 sub git_add_write_tree () {
1840 runcmd @git, qw(add -Af .);
1841 return git_write_tree();
1844 sub remove_stray_gits ($) {
1846 my @gitscmd = qw(find -name .git -prune -print0);
1847 debugcmd "|",@gitscmd;
1848 open GITS, "-|", @gitscmd or confess "$!";
1853 print STDERR f_ "%s: warning: removing from %s: %s\n",
1854 $us, $what, (messagequote $_);
1858 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1861 sub mktree_in_ud_from_only_subdir ($;$) {
1862 my ($what,$raw) = @_;
1863 # changes into the subdir
1866 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1867 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1871 remove_stray_gits($what);
1872 mktree_in_ud_here();
1874 my ($format, $fopts) = get_source_format();
1875 if (madformat($format)) {
1880 my $tree=git_add_write_tree();
1881 return ($tree,$dir);
1884 our @files_csum_info_fields =
1885 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1886 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1887 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1889 sub dsc_files_info () {
1890 foreach my $csumi (@files_csum_info_fields) {
1891 my ($fname, $module, $method) = @$csumi;
1892 my $field = $dsc->{$fname};
1893 next unless defined $field;
1894 eval "use $module; 1;" or die $@;
1896 foreach (split /\n/, $field) {
1898 m/^(\w+) (\d+) (\S+)$/ or
1899 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1900 my $digester = eval "$module"."->$method;" or die $@;
1905 Digester => $digester,
1910 fail f_ "missing any supported Checksums-* or Files field in %s",
1911 $dsc->get_option('name');
1915 map { $_->{Filename} } dsc_files_info();
1918 sub files_compare_inputs (@) {
1923 my $showinputs = sub {
1924 return join "; ", map { $_->get_option('name') } @$inputs;
1927 foreach my $in (@$inputs) {
1929 my $in_name = $in->get_option('name');
1931 printdebug "files_compare_inputs $in_name\n";
1933 foreach my $csumi (@files_csum_info_fields) {
1934 my ($fname) = @$csumi;
1935 printdebug "files_compare_inputs $in_name $fname\n";
1937 my $field = $in->{$fname};
1938 next unless defined $field;
1941 foreach (split /\n/, $field) {
1944 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1945 fail "could not parse $in_name $fname line \`$_'";
1947 printdebug "files_compare_inputs $in_name $fname $f\n";
1951 my $re = \ $record{$f}{$fname};
1953 $fchecked{$f}{$in_name} = 1;
1956 "hash or size of %s varies in %s fields (between: %s)",
1957 $f, $fname, $showinputs->();
1962 @files = sort @files;
1963 $expected_files //= \@files;
1964 "@$expected_files" eq "@files" or
1965 fail f_ "file list in %s varies between hash fields!",
1969 fail f_ "%s has no files list field(s)", $in_name;
1971 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1974 grep { keys %$_ == @$inputs-1 } values %fchecked
1975 or fail f_ "no file appears in all file lists (looked in: %s)",
1979 sub is_orig_file_in_dsc ($$) {
1980 my ($f, $dsc_files_info) = @_;
1981 return 0 if @$dsc_files_info <= 1;
1982 # One file means no origs, and the filename doesn't have a "what
1983 # part of dsc" component. (Consider versions ending `.orig'.)
1984 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1988 # This function determines whether a .changes file is source-only from
1989 # the point of view of dak. Thus, it permits *_source.buildinfo
1992 # It does not, however, permit any other buildinfo files. After a
1993 # source-only upload, the buildds will try to upload files like
1994 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1995 # named like this in their (otherwise) source-only upload, the uploads
1996 # of the buildd can be rejected by dak. Fixing the resultant
1997 # situation can require manual intervention. So we block such
1998 # .buildinfo files when the user tells us to perform a source-only
1999 # upload (such as when using the push-source subcommand with the -C
2000 # option, which calls this function).
2002 # Note, though, that when dgit is told to prepare a source-only
2003 # upload, such as when subcommands like build-source and push-source
2004 # without -C are used, dgit has a more restrictive notion of
2005 # source-only .changes than dak: such uploads will never include
2006 # *_source.buildinfo files. This is because there is no use for such
2007 # files when using a tool like dgit to produce the source package, as
2008 # dgit ensures the source is identical to git HEAD.
2009 sub test_source_only_changes ($) {
2011 foreach my $l (split /\n/, getfield $changes, 'Files') {
2012 $l =~ m/\S+$/ or next;
2013 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2014 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
2015 print f_ "purportedly source-only changes polluted by %s\n", $&;
2022 sub changes_update_origs_from_dsc ($$$$) {
2023 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2025 printdebug "checking origs needed ($upstreamvsn)...\n";
2026 $_ = getfield $changes, 'Files';
2027 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2028 fail __ "cannot find section/priority from .changes Files field";
2029 my $placementinfo = $1;
2031 printdebug "checking origs needed placement '$placementinfo'...\n";
2032 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2033 $l =~ m/\S+$/ or next;
2035 printdebug "origs $file | $l\n";
2036 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2037 printdebug "origs $file is_orig\n";
2038 my $have = archive_query('file_in_archive', $file);
2039 if (!defined $have) {
2040 print STDERR __ <<END;
2041 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2047 printdebug "origs $file \$#\$have=$#$have\n";
2048 foreach my $h (@$have) {
2051 foreach my $csumi (@files_csum_info_fields) {
2052 my ($fname, $module, $method, $archivefield) = @$csumi;
2053 next unless defined $h->{$archivefield};
2054 $_ = $dsc->{$fname};
2055 next unless defined;
2056 m/^(\w+) .* \Q$file\E$/m or
2057 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2058 if ($h->{$archivefield} eq $1) {
2062 "%s: %s (archive) != %s (local .dsc)",
2063 $archivefield, $h->{$archivefield}, $1;
2066 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2070 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2073 printdebug "origs $file f.same=$found_same".
2074 " #f._differ=$#found_differ\n";
2075 if (@found_differ && !$found_same) {
2077 (f_ "archive contains %s with different checksum", $file),
2080 # Now we edit the changes file to add or remove it
2081 foreach my $csumi (@files_csum_info_fields) {
2082 my ($fname, $module, $method, $archivefield) = @$csumi;
2083 next unless defined $changes->{$fname};
2085 # in archive, delete from .changes if it's there
2086 $changed{$file} = "removed" if
2087 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2088 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2089 # not in archive, but it's here in the .changes
2091 my $dsc_data = getfield $dsc, $fname;
2092 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2094 $extra =~ s/ \d+ /$&$placementinfo /
2095 or confess "$fname $extra >$dsc_data< ?"
2096 if $fname eq 'Files';
2097 $changes->{$fname} .= "\n". $extra;
2098 $changed{$file} = "added";
2103 foreach my $file (keys %changed) {
2105 "edited .changes for archive .orig contents: %s %s",
2106 $changed{$file}, $file;
2108 my $chtmp = "$changesfile.tmp";
2109 $changes->save($chtmp);
2111 rename $chtmp,$changesfile or die "$changesfile $!";
2113 progress f_ "[new .changes left in %s]", $changesfile;
2116 progress f_ "%s already has appropriate .orig(s) (if any)",
2121 sub clogp_authline ($) {
2123 my $author = getfield $clogp, 'Maintainer';
2124 if ($author =~ m/^[^"\@]+\,/) {
2125 # single entry Maintainer field with unquoted comma
2126 $author = ($& =~ y/,//rd).$'; # strip the comma
2128 # git wants a single author; any remaining commas in $author
2129 # are by now preceded by @ (or "). It seems safer to punt on
2130 # "..." for now rather than attempting to dequote or something.
2131 $author =~ s#,.*##ms unless $author =~ m/"/;
2132 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2133 my $authline = "$author $date";
2134 $authline =~ m/$git_authline_re/o or
2135 fail f_ "unexpected commit author line format \`%s'".
2136 " (was generated from changelog Maintainer field)",
2138 return ($1,$2,$3) if wantarray;
2142 sub vendor_patches_distro ($$) {
2143 my ($checkdistro, $what) = @_;
2144 return unless defined $checkdistro;
2146 my $series = "debian/patches/\L$checkdistro\E.series";
2147 printdebug "checking for vendor-specific $series ($what)\n";
2149 if (!open SERIES, "<", $series) {
2150 confess "$series $!" unless $!==ENOENT;
2157 print STDERR __ <<END;
2159 Unfortunately, this source package uses a feature of dpkg-source where
2160 the same source package unpacks to different source code on different
2161 distros. dgit cannot safely operate on such packages on affected
2162 distros, because the meaning of source packages is not stable.
2164 Please ask the distro/maintainer to remove the distro-specific series
2165 files and use a different technique (if necessary, uploading actually
2166 different packages, if different distros are supposed to have
2170 fail f_ "Found active distro-specific series file for".
2171 " %s (%s): %s, cannot continue",
2172 $checkdistro, $what, $series;
2174 die "$series $!" if SERIES->error;
2178 sub check_for_vendor_patches () {
2179 # This dpkg-source feature doesn't seem to be documented anywhere!
2180 # But it can be found in the changelog (reformatted):
2182 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2183 # Author: Raphael Hertzog <hertzog@debian.org>
2184 # Date: Sun Oct 3 09:36:48 2010 +0200
2186 # dpkg-source: correctly create .pc/.quilt_series with alternate
2189 # If you have debian/patches/ubuntu.series and you were
2190 # unpacking the source package on ubuntu, quilt was still
2191 # directed to debian/patches/series instead of
2192 # debian/patches/ubuntu.series.
2194 # debian/changelog | 3 +++
2195 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2196 # 2 files changed, 6 insertions(+), 1 deletion(-)
2199 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2200 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2201 __ "Dpkg::Vendor \`current vendor'");
2202 vendor_patches_distro(access_basedistro(),
2203 __ "(base) distro being accessed");
2204 vendor_patches_distro(access_nomdistro(),
2205 __ "(nominal) distro being accessed");
2208 sub check_bpd_exists () {
2209 stat $buildproductsdir
2210 or fail f_ "build-products-dir %s is not accessible: %s\n",
2211 $buildproductsdir, $!;
2214 sub dotdot_bpd_transfer_origs ($$$) {
2215 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2216 # checks is_orig_file_of_vsn and if
2217 # calls $wanted->{$leaf} and expects boolish
2219 return if $buildproductsdir eq '..';
2222 my $dotdot = $maindir;
2223 $dotdot =~ s{/[^/]+$}{};
2224 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2225 while ($!=0, defined(my $leaf = readdir DD)) {
2227 local ($debuglevel) = $debuglevel-1;
2228 printdebug "DD_BPD $leaf ?\n";
2230 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2231 next unless $wanted->($leaf);
2232 next if lstat "$bpd_abs/$leaf";
2235 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2238 $! == &ENOENT or fail f_
2239 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2240 lstat "$dotdot/$leaf" or fail f_
2241 "check orig file %s in ..: %s", $leaf, $!;
2243 stat "$dotdot/$leaf" or fail f_
2244 "check target of orig symlink %s in ..: %s", $leaf, $!;
2245 my $ltarget = readlink "$dotdot/$leaf" or
2246 die "readlink $dotdot/$leaf: $!";
2247 if ($ltarget !~ m{^/}) {
2248 $ltarget = "$dotdot/$ltarget";
2250 symlink $ltarget, "$bpd_abs/$leaf"
2251 or die "$ltarget $bpd_abs $leaf: $!";
2253 "%s: cloned orig symlink from ..: %s\n",
2255 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2257 "%s: hardlinked orig from ..: %s\n",
2259 } elsif ($! != EXDEV) {
2260 fail f_ "failed to make %s a hardlink to %s: %s",
2261 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2263 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2264 or die "$bpd_abs $dotdot $leaf $!";
2266 "%s: symmlinked orig from .. on other filesystem: %s\n",
2270 die "$dotdot; $!" if $!;
2274 sub import_tarball_tartrees ($$) {
2275 my ($upstreamv, $dfi) = @_;
2276 # cwd should be the playground
2278 # We unpack and record the orig tarballs first, so that we only
2279 # need disk space for one private copy of the unpacked source.
2280 # But we can't make them into commits until we have the metadata
2281 # from the debian/changelog, so we record the tree objects now and
2282 # make them into commits later.
2284 my $orig_f_base = srcfn $upstreamv, '';
2286 foreach my $fi (@$dfi) {
2287 # We actually import, and record as a commit, every tarball
2288 # (unless there is only one file, in which case there seems
2291 my $f = $fi->{Filename};
2292 printdebug "import considering $f ";
2293 (printdebug "only one dfi\n"), next if @$dfi == 1;
2294 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2295 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2299 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2301 printdebug "Y ", (join ' ', map { $_//"(none)" }
2302 $compr_ext, $orig_f_part
2305 my $input = new IO::File $f, '<' or die "$f $!";
2309 if (defined $compr_ext) {
2311 Dpkg::Compression::compression_guess_from_filename $f;
2312 fail "Dpkg::Compression cannot handle file $f in source package"
2313 if defined $compr_ext && !defined $cname;
2315 new Dpkg::Compression::Process compression => $cname;
2316 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2317 my $compr_fh = new IO::Handle;
2318 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2320 open STDIN, "<&", $input or confess "$!";
2322 die "dgit (child): exec $compr_cmd[0]: $!\n";
2327 rmtree "_unpack-tar";
2328 mkdir "_unpack-tar" or confess "$!";
2329 my @tarcmd = qw(tar -x -f -
2330 --no-same-owner --no-same-permissions
2331 --no-acls --no-xattrs --no-selinux);
2332 my $tar_pid = fork // confess "$!";
2334 chdir "_unpack-tar" or confess "$!";
2335 open STDIN, "<&", $input or confess "$!";
2337 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2339 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2340 !$? or failedcmd @tarcmd;
2343 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2345 # finally, we have the results in "tarball", but maybe
2346 # with the wrong permissions
2348 runcmd qw(chmod -R +rwX _unpack-tar);
2349 changedir "_unpack-tar";
2350 remove_stray_gits($f);
2351 mktree_in_ud_here();
2353 my ($tree) = git_add_write_tree();
2354 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2355 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2357 printdebug "one subtree $1\n";
2359 printdebug "multiple subtrees\n";
2362 rmtree "_unpack-tar";
2364 my $ent = [ $f, $tree ];
2366 Orig => !!$orig_f_part,
2367 Sort => (!$orig_f_part ? 2 :
2368 $orig_f_part =~ m/-/g ? 1 :
2376 # put any without "_" first (spec is not clear whether files
2377 # are always in the usual order). Tarballs without "_" are
2378 # the main orig or the debian tarball.
2379 $a->{Sort} <=> $b->{Sort} or
2386 sub generate_commits_from_dsc () {
2387 # See big comment in fetch_from_archive, below.
2388 # See also README.dsc-import.
2390 changedir $playground;
2392 my $bpd_abs = bpd_abs();
2393 my $upstreamv = upstreamversion $dsc->{version};
2394 my @dfi = dsc_files_info();
2396 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2397 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2399 foreach my $fi (@dfi) {
2400 my $f = $fi->{Filename};
2401 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2402 my $upper_f = "$bpd_abs/$f";
2404 printdebug "considering reusing $f: ";
2406 if (link_ltarget "$upper_f,fetch", $f) {
2407 printdebug "linked (using ...,fetch).\n";
2408 } elsif ((printdebug "($!) "),
2410 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2411 } elsif (link_ltarget $upper_f, $f) {
2412 printdebug "linked.\n";
2413 } elsif ((printdebug "($!) "),
2415 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2417 printdebug "absent.\n";
2421 complete_file_from_dsc('.', $fi, \$refetched)
2424 printdebug "considering saving $f: ";
2426 if (rename_link_xf 1, $f, $upper_f) {
2427 printdebug "linked.\n";
2428 } elsif ((printdebug "($@) "),
2430 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2431 } elsif (!$refetched) {
2432 printdebug "no need.\n";
2433 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2434 printdebug "linked (using ...,fetch).\n";
2435 } elsif ((printdebug "($@) "),
2437 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2439 printdebug "cannot.\n";
2443 my @tartrees = import_tarball_tartrees($upstreamv, \@dfi);
2445 my $any_orig = grep { $_->{Orig} } @tartrees;
2447 my $dscfn = "$package.dsc";
2449 my $treeimporthow = 'package';
2451 open D, ">", $dscfn or die "$dscfn: $!";
2452 print D $dscdata or die "$dscfn: $!";
2453 close D or die "$dscfn: $!";
2454 my @cmd = qw(dpkg-source);
2455 push @cmd, '--no-check' if $dsc_checked;
2456 if (madformat $dsc->{format}) {
2457 push @cmd, '--skip-patches';
2458 $treeimporthow = 'unpatched';
2460 push @cmd, qw(-x --), $dscfn;
2463 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2464 if (madformat $dsc->{format}) {
2465 check_for_vendor_patches();
2469 if (madformat $dsc->{format}) {
2470 my @pcmd = qw(dpkg-source --before-build .);
2471 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2473 $dappliedtree = git_add_write_tree();
2476 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2480 printdebug "import clog search...\n";
2481 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2482 my ($thisstanza, $desc) = @_;
2483 no warnings qw(exiting);
2485 $clogp //= $thisstanza;
2487 printdebug "import clog $thisstanza->{version} $desc...\n";
2489 last if !$any_orig; # we don't need $r1clogp
2491 # We look for the first (most recent) changelog entry whose
2492 # version number is lower than the upstream version of this
2493 # package. Then the last (least recent) previous changelog
2494 # entry is treated as the one which introduced this upstream
2495 # version and used for the synthetic commits for the upstream
2498 # One might think that a more sophisticated algorithm would be
2499 # necessary. But: we do not want to scan the whole changelog
2500 # file. Stopping when we see an earlier version, which
2501 # necessarily then is an earlier upstream version, is the only
2502 # realistic way to do that. Then, either the earliest
2503 # changelog entry we have seen so far is indeed the earliest
2504 # upload of this upstream version; or there are only changelog
2505 # entries relating to later upstream versions (which is not
2506 # possible unless the changelog and .dsc disagree about the
2507 # version). Then it remains to choose between the physically
2508 # last entry in the file, and the one with the lowest version
2509 # number. If these are not the same, we guess that the
2510 # versions were created in a non-monotonic order rather than
2511 # that the changelog entries have been misordered.
2513 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2515 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2516 $r1clogp = $thisstanza;
2518 printdebug "import clog $r1clogp->{version} becomes r1\n";
2521 $clogp or fail __ "package changelog has no entries!";
2523 my $authline = clogp_authline $clogp;
2524 my $changes = getfield $clogp, 'Changes';
2525 $changes =~ s/^\n//; # Changes: \n
2526 my $cversion = getfield $clogp, 'Version';
2529 $r1clogp //= $clogp; # maybe there's only one entry;
2530 my $r1authline = clogp_authline $r1clogp;
2531 # Strictly, r1authline might now be wrong if it's going to be
2532 # unused because !$any_orig. Whatever.
2534 printdebug "import tartrees authline $authline\n";
2535 printdebug "import tartrees r1authline $r1authline\n";
2537 foreach my $tt (@tartrees) {
2538 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2540 my $mbody = f_ "Import %s", $tt->{F};
2541 $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2544 committer $r1authline
2548 [dgit import orig $tt->{F}]
2556 [dgit import tarball $package $cversion $tt->{F}]
2561 printdebug "import main commit\n";
2563 open C, ">../commit.tmp" or confess "$!";
2564 print C <<END or confess "$!";
2567 print C <<END or confess "$!" foreach @tartrees;
2570 print C <<END or confess "$!";
2576 [dgit import $treeimporthow $package $cversion]
2579 close C or confess "$!";
2580 my $rawimport_hash = hash_commit qw(../commit.tmp);
2582 if (madformat $dsc->{format}) {
2583 printdebug "import apply patches...\n";
2585 # regularise the state of the working tree so that
2586 # the checkout of $rawimport_hash works nicely.
2587 my $dappliedcommit = hash_commit_text(<<END);
2594 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2596 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2598 # We need the answers to be reproducible
2599 my @authline = clogp_authline($clogp);
2600 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2601 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2602 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2603 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2604 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2605 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2607 my $path = $ENV{PATH} or die;
2609 # we use ../../gbp-pq-output, which (given that we are in
2610 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2613 foreach my $use_absurd (qw(0 1)) {
2614 runcmd @git, qw(checkout -q unpa);
2615 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2616 local $ENV{PATH} = $path;
2619 progress "warning: $@";
2620 $path = "$absurdity:$path";
2621 progress f_ "%s: trying slow absurd-git-apply...", $us;
2622 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2627 die "forbid absurd git-apply\n" if $use_absurd
2628 && forceing [qw(import-gitapply-no-absurd)];
2629 die "only absurd git-apply!\n" if !$use_absurd
2630 && forceing [qw(import-gitapply-absurd)];
2632 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2633 local $ENV{PATH} = $path if $use_absurd;
2635 my @showcmd = (gbp_pq, qw(import));
2636 my @realcmd = shell_cmd
2637 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2638 debugcmd "+",@realcmd;
2639 if (system @realcmd) {
2640 die f_ "%s failed: %s\n",
2641 +(shellquote @showcmd),
2642 failedcmd_waitstatus();
2645 my $gapplied = git_rev_parse('HEAD');
2646 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2647 $gappliedtree eq $dappliedtree or
2648 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2649 gbp-pq import and dpkg-source disagree!
2650 gbp-pq import gave commit %s
2651 gbp-pq import gave tree %s
2652 dpkg-source --before-build gave tree %s
2654 $rawimport_hash = $gapplied;
2659 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2664 progress f_ "synthesised git commit from .dsc %s", $cversion;
2666 my $rawimport_mergeinput = {
2667 Commit => $rawimport_hash,
2668 Info => __ "Import of source package",
2670 my @output = ($rawimport_mergeinput);
2672 if ($lastpush_mergeinput) {
2673 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2674 my $oversion = getfield $oldclogp, 'Version';
2676 version_compare($oversion, $cversion);
2678 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2679 { ReverseParents => 1,
2680 Message => (f_ <<END, $package, $cversion, $csuite) });
2681 Record %s (%s) in archive suite %s
2683 } elsif ($vcmp > 0) {
2684 print STDERR f_ <<END, $cversion, $oversion,
2686 Version actually in archive: %s (older)
2687 Last version pushed with dgit: %s (newer or same)
2690 __ $later_warning_msg or confess "$!";
2691 @output = $lastpush_mergeinput;
2693 # Same version. Use what's in the server git branch,
2694 # discarding our own import. (This could happen if the
2695 # server automatically imports all packages into git.)
2696 @output = $lastpush_mergeinput;
2704 sub complete_file_from_dsc ($$;$) {
2705 our ($dstdir, $fi, $refetched) = @_;
2706 # Ensures that we have, in $dstdir, the file $fi, with the correct
2707 # contents. (Downloading it from alongside $dscurl if necessary.)
2708 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2709 # and will set $$refetched=1 if it did so (or tried to).
2711 my $f = $fi->{Filename};
2712 my $tf = "$dstdir/$f";
2716 my $checkhash = sub {
2717 open F, "<", "$tf" or die "$tf: $!";
2718 $fi->{Digester}->reset();
2719 $fi->{Digester}->addfile(*F);
2720 F->error and confess "$!";
2721 $got = $fi->{Digester}->hexdigest();
2722 return $got eq $fi->{Hash};
2725 if (stat_exists $tf) {
2726 if ($checkhash->()) {
2727 progress f_ "using existing %s", $f;
2731 fail f_ "file %s has hash %s but .dsc demands hash %s".
2732 " (perhaps you should delete this file?)",
2733 $f, $got, $fi->{Hash};
2735 progress f_ "need to fetch correct version of %s", $f;
2736 unlink $tf or die "$tf $!";
2739 printdebug "$tf does not exist, need to fetch\n";
2743 $furl =~ s{/[^/]+$}{};
2745 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2746 die "$f ?" if $f =~ m#/#;
2747 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2748 return 0 if !act_local();
2751 fail f_ "file %s has hash %s but .dsc demands hash %s".
2752 " (got wrong file from archive!)",
2753 $f, $got, $fi->{Hash};
2758 sub ensure_we_have_orig () {
2759 my @dfi = dsc_files_info();
2760 foreach my $fi (@dfi) {
2761 my $f = $fi->{Filename};
2762 next unless is_orig_file_in_dsc($f, \@dfi);
2763 complete_file_from_dsc($buildproductsdir, $fi)
2768 #---------- git fetch ----------
2770 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2771 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2773 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2774 # locally fetched refs because they have unhelpful names and clutter
2775 # up gitk etc. So we track whether we have "used up" head ref (ie,
2776 # whether we have made another local ref which refers to this object).
2778 # (If we deleted them unconditionally, then we might end up
2779 # re-fetching the same git objects each time dgit fetch was run.)
2781 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2782 # in git_fetch_us to fetch the refs in question, and possibly a call
2783 # to lrfetchref_used.
2785 our (%lrfetchrefs_f, %lrfetchrefs_d);
2786 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2788 sub lrfetchref_used ($) {
2789 my ($fullrefname) = @_;
2790 my $objid = $lrfetchrefs_f{$fullrefname};
2791 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2794 sub git_lrfetch_sane {
2795 my ($url, $supplementary, @specs) = @_;
2796 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2797 # at least as regards @specs. Also leave the results in
2798 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2799 # able to clean these up.
2801 # With $supplementary==1, @specs must not contain wildcards
2802 # and we add to our previous fetches (non-atomically).
2804 # This is rather miserable:
2805 # When git fetch --prune is passed a fetchspec ending with a *,
2806 # it does a plausible thing. If there is no * then:
2807 # - it matches subpaths too, even if the supplied refspec
2808 # starts refs, and behaves completely madly if the source
2809 # has refs/refs/something. (See, for example, Debian #NNNN.)
2810 # - if there is no matching remote ref, it bombs out the whole
2812 # We want to fetch a fixed ref, and we don't know in advance
2813 # if it exists, so this is not suitable.
2815 # Our workaround is to use git ls-remote. git ls-remote has its
2816 # own qairks. Notably, it has the absurd multi-tail-matching
2817 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2818 # refs/refs/foo etc.
2820 # Also, we want an idempotent snapshot, but we have to make two
2821 # calls to the remote: one to git ls-remote and to git fetch. The
2822 # solution is use git ls-remote to obtain a target state, and
2823 # git fetch to try to generate it. If we don't manage to generate
2824 # the target state, we try again.
2826 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2828 my $specre = join '|', map {
2831 my $wildcard = $x =~ s/\\\*$/.*/;
2832 die if $wildcard && $supplementary;
2835 printdebug "git_lrfetch_sane specre=$specre\n";
2836 my $wanted_rref = sub {
2838 return m/^(?:$specre)$/;
2841 my $fetch_iteration = 0;
2844 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2845 if (++$fetch_iteration > 10) {
2846 fail __ "too many iterations trying to get sane fetch!";
2849 my @look = map { "refs/$_" } @specs;
2850 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2854 open GITLS, "-|", @lcmd or confess "$!";
2856 printdebug "=> ", $_;
2857 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2858 my ($objid,$rrefname) = ($1,$2);
2859 if (!$wanted_rref->($rrefname)) {
2860 print STDERR f_ <<END, "@look", $rrefname;
2861 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2865 $wantr{$rrefname} = $objid;
2868 close GITLS or failedcmd @lcmd;
2870 # OK, now %want is exactly what we want for refs in @specs
2872 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2873 "+refs/$_:".lrfetchrefs."/$_";
2876 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2878 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2879 runcmd_ordryrun_local @fcmd if @fspecs;
2881 if (!$supplementary) {
2882 %lrfetchrefs_f = ();
2886 git_for_each_ref(lrfetchrefs, sub {
2887 my ($objid,$objtype,$lrefname,$reftail) = @_;
2888 $lrfetchrefs_f{$lrefname} = $objid;
2889 $objgot{$objid} = 1;
2892 if ($supplementary) {
2896 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2897 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2898 if (!exists $wantr{$rrefname}) {
2899 if ($wanted_rref->($rrefname)) {
2901 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2904 print STDERR f_ <<END, "@fspecs", $lrefname
2905 warning: git fetch %s created %s; this is silly, deleting it.
2908 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2909 delete $lrfetchrefs_f{$lrefname};
2913 foreach my $rrefname (sort keys %wantr) {
2914 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2915 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2916 my $want = $wantr{$rrefname};
2917 next if $got eq $want;
2918 if (!defined $objgot{$want}) {
2919 fail __ <<END unless act_local();
2920 --dry-run specified but we actually wanted the results of git fetch,
2921 so this is not going to work. Try running dgit fetch first,
2922 or using --damp-run instead of --dry-run.
2924 print STDERR f_ <<END, $lrefname, $want;
2925 warning: git ls-remote suggests we want %s
2926 warning: and it should refer to %s
2927 warning: but git fetch didn't fetch that object to any relevant ref.
2928 warning: This may be due to a race with someone updating the server.
2929 warning: Will try again...
2931 next FETCH_ITERATION;
2934 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2936 runcmd_ordryrun_local @git, qw(update-ref -m),
2937 "dgit fetch git fetch fixup", $lrefname, $want;
2938 $lrfetchrefs_f{$lrefname} = $want;
2943 if (defined $csuite) {
2944 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2945 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2946 my ($objid,$objtype,$lrefname,$reftail) = @_;
2947 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2948 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2952 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2953 Dumper(\%lrfetchrefs_f);
2956 sub git_fetch_us () {
2957 # Want to fetch only what we are going to use, unless
2958 # deliberately-not-ff, in which case we must fetch everything.
2960 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2961 map { "tags/$_" } debiantags('*',access_nomdistro);
2962 push @specs, server_branch($csuite);
2963 push @specs, $rewritemap;
2964 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2966 my $url = access_giturl();
2967 git_lrfetch_sane $url, 0, @specs;
2970 my @tagpats = debiantags('*',access_nomdistro);
2972 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2973 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2974 printdebug "currently $fullrefname=$objid\n";
2975 $here{$fullrefname} = $objid;
2977 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2978 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2979 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2980 printdebug "offered $lref=$objid\n";
2981 if (!defined $here{$lref}) {
2982 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2983 runcmd_ordryrun_local @upd;
2984 lrfetchref_used $fullrefname;
2985 } elsif ($here{$lref} eq $objid) {
2986 lrfetchref_used $fullrefname;
2988 print STDERR f_ "Not updating %s from %s to %s.\n",
2989 $lref, $here{$lref}, $objid;
2994 #---------- dsc and archive handling ----------
2996 sub mergeinfo_getclogp ($) {
2997 # Ensures thit $mi->{Clogp} exists and returns it
2999 $mi->{Clogp} = commit_getclogp($mi->{Commit});
3002 sub mergeinfo_version ($) {
3003 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
3006 sub fetch_from_archive_record_1 ($) {
3008 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
3009 cmdoutput @git, qw(log -n2), $hash;
3010 # ... gives git a chance to complain if our commit is malformed
3013 sub fetch_from_archive_record_2 ($) {
3015 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3019 dryrun_report @upd_cmd;
3023 sub parse_dsc_field_def_dsc_distro () {
3024 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3025 dgit.default.distro);
3028 sub parse_dsc_field ($$) {
3029 my ($dsc, $what) = @_;
3031 foreach my $field (@ourdscfield) {
3032 $f = $dsc->{$field};
3037 progress f_ "%s: NO git hash", $what;
3038 parse_dsc_field_def_dsc_distro();
3039 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3040 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3041 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3042 $dsc_hint_tag = [ $dsc_hint_tag ];
3043 } elsif ($f =~ m/^\w+\s*$/) {
3045 parse_dsc_field_def_dsc_distro();
3046 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3048 progress f_ "%s: specified git hash", $what;
3050 fail f_ "%s: invalid Dgit info", $what;
3054 sub resolve_dsc_field_commit ($$) {
3055 my ($already_distro, $already_mapref) = @_;
3057 return unless defined $dsc_hash;
3060 defined $already_mapref &&
3061 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3062 ? $already_mapref : undef;
3066 my ($what, @fetch) = @_;
3068 local $idistro = $dsc_distro;
3069 my $lrf = lrfetchrefs;
3071 if (!$chase_dsc_distro) {
3072 progress f_ "not chasing .dsc distro %s: not fetching %s",
3077 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3079 my $url = access_giturl();
3080 if (!defined $url) {
3081 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3082 .dsc Dgit metadata is in context of distro %s
3083 for which we have no configured url and .dsc provides no hint
3086 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3087 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3088 parse_cfg_bool "dsc-url-proto-ok", 'false',
3089 cfg("dgit.dsc-url-proto-ok.$proto",
3090 "dgit.default.dsc-url-proto-ok")
3091 or fail f_ <<END, $dsc_distro, $proto;
3092 .dsc Dgit metadata is in context of distro %s
3093 for which we have no configured url;
3094 .dsc provides hinted url with protocol %s which is unsafe.
3095 (can be overridden by config - consult documentation)
3097 $url = $dsc_hint_url;
3100 git_lrfetch_sane $url, 1, @fetch;
3105 my $rewrite_enable = do {
3106 local $idistro = $dsc_distro;
3107 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3110 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3111 if (!defined $mapref) {
3112 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3113 $mapref = $lrf.'/'.$rewritemap;
3115 my $rewritemapdata = git_cat_file $mapref.':map';
3116 if (defined $rewritemapdata
3117 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3119 "server's git history rewrite map contains a relevant entry!";
3122 if (defined $dsc_hash) {
3123 progress __ "using rewritten git hash in place of .dsc value";
3125 progress __ "server data says .dsc hash is to be disregarded";
3130 if (!defined git_cat_file $dsc_hash) {
3131 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3132 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3133 defined git_cat_file $dsc_hash
3134 or fail f_ <<END, $dsc_hash;
3135 .dsc Dgit metadata requires commit %s
3136 but we could not obtain that object anywhere.
3138 foreach my $t (@tags) {
3139 my $fullrefname = $lrf.'/'.$t;
3140 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3141 next unless $lrfetchrefs_f{$fullrefname};
3142 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3143 lrfetchref_used $fullrefname;
3148 sub fetch_from_archive () {
3150 ensure_setup_existing_tree();
3152 # Ensures that lrref() is what is actually in the archive, one way
3153 # or another, according to us - ie this client's
3154 # appropritaely-updated archive view. Also returns the commit id.
3155 # If there is nothing in the archive, leaves lrref alone and
3156 # returns undef. git_fetch_us must have already been called.
3160 parse_dsc_field($dsc, __ 'last upload to archive');
3161 resolve_dsc_field_commit access_basedistro,
3162 lrfetchrefs."/".$rewritemap
3164 progress __ "no version available from the archive";
3167 # If the archive's .dsc has a Dgit field, there are three
3168 # relevant git commitids we need to choose between and/or merge
3170 # 1. $dsc_hash: the Dgit field from the archive
3171 # 2. $lastpush_hash: the suite branch on the dgit git server
3172 # 3. $lastfetch_hash: our local tracking brach for the suite
3174 # These may all be distinct and need not be in any fast forward
3177 # If the dsc was pushed to this suite, then the server suite
3178 # branch will have been updated; but it might have been pushed to
3179 # a different suite and copied by the archive. Conversely a more
3180 # recent version may have been pushed with dgit but not appeared
3181 # in the archive (yet).
3183 # $lastfetch_hash may be awkward because archive imports
3184 # (particularly, imports of Dgit-less .dscs) are performed only as
3185 # needed on individual clients, so different clients may perform a
3186 # different subset of them - and these imports are only made
3187 # public during push. So $lastfetch_hash may represent a set of
3188 # imports different to a subsequent upload by a different dgit
3191 # Our approach is as follows:
3193 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3194 # descendant of $dsc_hash, then it was pushed by a dgit user who
3195 # had based their work on $dsc_hash, so we should prefer it.
3196 # Otherwise, $dsc_hash was installed into this suite in the
3197 # archive other than by a dgit push, and (necessarily) after the
3198 # last dgit push into that suite (since a dgit push would have
3199 # been descended from the dgit server git branch); thus, in that
3200 # case, we prefer the archive's version (and produce a
3201 # pseudo-merge to overwrite the dgit server git branch).
3203 # (If there is no Dgit field in the archive's .dsc then
3204 # generate_commit_from_dsc uses the version numbers to decide
3205 # whether the suite branch or the archive is newer. If the suite
3206 # branch is newer it ignores the archive's .dsc; otherwise it
3207 # generates an import of the .dsc, and produces a pseudo-merge to
3208 # overwrite the suite branch with the archive contents.)
3210 # The outcome of that part of the algorithm is the `public view',
3211 # and is same for all dgit clients: it does not depend on any
3212 # unpublished history in the local tracking branch.
3214 # As between the public view and the local tracking branch: The
3215 # local tracking branch is only updated by dgit fetch, and
3216 # whenever dgit fetch runs it includes the public view in the
3217 # local tracking branch. Therefore if the public view is not
3218 # descended from the local tracking branch, the local tracking
3219 # branch must contain history which was imported from the archive
3220 # but never pushed; and, its tip is now out of date. So, we make
3221 # a pseudo-merge to overwrite the old imports and stitch the old
3224 # Finally: we do not necessarily reify the public view (as
3225 # described above). This is so that we do not end up stacking two
3226 # pseudo-merges. So what we actually do is figure out the inputs
3227 # to any public view pseudo-merge and put them in @mergeinputs.
3230 # $mergeinputs[]{Commit}
3231 # $mergeinputs[]{Info}
3232 # $mergeinputs[0] is the one whose tree we use
3233 # @mergeinputs is in the order we use in the actual commit)
3236 # $mergeinputs[]{Message} is a commit message to use
3237 # $mergeinputs[]{ReverseParents} if def specifies that parent
3238 # list should be in opposite order
3239 # Such an entry has no Commit or Info. It applies only when found
3240 # in the last entry. (This ugliness is to support making
3241 # identical imports to previous dgit versions.)
3243 my $lastpush_hash = git_get_ref(lrfetchref());
3244 printdebug "previous reference hash=$lastpush_hash\n";
3245 $lastpush_mergeinput = $lastpush_hash && {
3246 Commit => $lastpush_hash,
3247 Info => (__ "dgit suite branch on dgit git server"),
3250 my $lastfetch_hash = git_get_ref(lrref());
3251 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3252 my $lastfetch_mergeinput = $lastfetch_hash && {
3253 Commit => $lastfetch_hash,
3254 Info => (__ "dgit client's archive history view"),
3257 my $dsc_mergeinput = $dsc_hash && {
3258 Commit => $dsc_hash,
3259 Info => (__ "Dgit field in .dsc from archive"),
3263 my $del_lrfetchrefs = sub {
3266 printdebug "del_lrfetchrefs...\n";
3267 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3268 my $objid = $lrfetchrefs_d{$fullrefname};
3269 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3271 $gur ||= new IO::Handle;
3272 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3274 printf $gur "delete %s %s\n", $fullrefname, $objid;
3277 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3281 if (defined $dsc_hash) {
3282 ensure_we_have_orig();
3283 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3284 @mergeinputs = $dsc_mergeinput
3285 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3286 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3288 Git commit in archive is behind the last version allegedly pushed/uploaded.
3289 Commit referred to by archive: %s
3290 Last version pushed with dgit: %s
3293 __ $later_warning_msg or confess "$!";
3294 @mergeinputs = ($lastpush_mergeinput);
3296 # Archive has .dsc which is not a descendant of the last dgit
3297 # push. This can happen if the archive moves .dscs about.
3298 # Just follow its lead.
3299 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3300 progress __ "archive .dsc names newer git commit";
3301 @mergeinputs = ($dsc_mergeinput);
3303 progress __ "archive .dsc names other git commit, fixing up";
3304 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3308 @mergeinputs = generate_commits_from_dsc();
3309 # We have just done an import. Now, our import algorithm might
3310 # have been improved. But even so we do not want to generate
3311 # a new different import of the same package. So if the
3312 # version numbers are the same, just use our existing version.
3313 # If the version numbers are different, the archive has changed
3314 # (perhaps, rewound).
3315 if ($lastfetch_mergeinput &&
3316 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3317 (mergeinfo_version $mergeinputs[0]) )) {
3318 @mergeinputs = ($lastfetch_mergeinput);
3320 } elsif ($lastpush_hash) {
3321 # only in git, not in the archive yet
3322 @mergeinputs = ($lastpush_mergeinput);
3323 print STDERR f_ <<END,
3325 Package not found in the archive, but has allegedly been pushed using dgit.
3328 __ $later_warning_msg or confess "$!";
3330 printdebug "nothing found!\n";
3331 if (defined $skew_warning_vsn) {
3332 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3334 Warning: relevant archive skew detected.
3335 Archive allegedly contains %s
3336 But we were not able to obtain any version from the archive or git.
3340 unshift @end, $del_lrfetchrefs;
3344 if ($lastfetch_hash &&
3346 my $h = $_->{Commit};
3347 $h and is_fast_fwd($lastfetch_hash, $h);
3348 # If true, one of the existing parents of this commit
3349 # is a descendant of the $lastfetch_hash, so we'll
3350 # be ff from that automatically.
3354 push @mergeinputs, $lastfetch_mergeinput;
3357 printdebug "fetch mergeinfos:\n";
3358 foreach my $mi (@mergeinputs) {
3360 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3362 printdebug sprintf " ReverseParents=%d Message=%s",
3363 $mi->{ReverseParents}, $mi->{Message};
3367 my $compat_info= pop @mergeinputs
3368 if $mergeinputs[$#mergeinputs]{Message};
3370 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3373 if (@mergeinputs > 1) {
3375 my $tree_commit = $mergeinputs[0]{Commit};
3377 my $tree = get_tree_of_commit $tree_commit;;
3379 # We use the changelog author of the package in question the
3380 # author of this pseudo-merge. This is (roughly) correct if
3381 # this commit is simply representing aa non-dgit upload.
3382 # (Roughly because it does not record sponsorship - but we
3383 # don't have sponsorship info because that's in the .changes,
3384 # which isn't in the archivw.)
3386 # But, it might be that we are representing archive history
3387 # updates (including in-archive copies). These are not really
3388 # the responsibility of the person who created the .dsc, but
3389 # there is no-one whose name we should better use. (The
3390 # author of the .dsc-named commit is clearly worse.)
3392 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3393 my $author = clogp_authline $useclogp;
3394 my $cversion = getfield $useclogp, 'Version';
3396 my $mcf = dgit_privdir()."/mergecommit";
3397 open MC, ">", $mcf or die "$mcf $!";
3398 print MC <<END or confess "$!";
3402 my @parents = grep { $_->{Commit} } @mergeinputs;
3403 @parents = reverse @parents if $compat_info->{ReverseParents};
3404 print MC <<END or confess "$!" foreach @parents;
3408 print MC <<END or confess "$!";
3414 if (defined $compat_info->{Message}) {
3415 print MC $compat_info->{Message} or confess "$!";
3417 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3418 Record %s (%s) in archive suite %s
3422 my $message_add_info = sub {
3424 my $mversion = mergeinfo_version $mi;
3425 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3429 $message_add_info->($mergeinputs[0]);
3430 print MC __ <<END or confess "$!";
3431 should be treated as descended from
3433 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3436 close MC or confess "$!";
3437 $hash = hash_commit $mcf;
3439 $hash = $mergeinputs[0]{Commit};
3441 printdebug "fetch hash=$hash\n";
3444 my ($lasth, $what) = @_;
3445 return unless $lasth;
3446 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3449 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3451 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3453 fetch_from_archive_record_1($hash);
3455 if (defined $skew_warning_vsn) {
3456 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3457 my $gotclogp = commit_getclogp($hash);
3458 my $got_vsn = getfield $gotclogp, 'Version';
3459 printdebug "SKEW CHECK GOT $got_vsn\n";
3460 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3461 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3463 Warning: archive skew detected. Using the available version:
3464 Archive allegedly contains %s
3465 We were able to obtain only %s
3471 if ($lastfetch_hash ne $hash) {
3472 fetch_from_archive_record_2($hash);
3475 lrfetchref_used lrfetchref();
3477 check_gitattrs($hash, __ "fetched source tree");
3479 unshift @end, $del_lrfetchrefs;
3483 sub set_local_git_config ($$) {
3485 runcmd @git, qw(config), $k, $v;
3488 sub setup_mergechangelogs (;$) {
3490 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3492 my $driver = 'dpkg-mergechangelogs';
3493 my $cb = "merge.$driver";
3494 confess unless defined $maindir;
3495 my $attrs = "$maindir_gitcommon/info/attributes";
3496 ensuredir "$maindir_gitcommon/info";
3498 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3499 if (!open ATTRS, "<", $attrs) {
3500 $!==ENOENT or die "$attrs: $!";
3504 next if m{^debian/changelog\s};
3505 print NATTRS $_, "\n" or confess "$!";
3507 ATTRS->error and confess "$!";
3510 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3513 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3514 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3516 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3519 sub setup_useremail (;$) {
3521 return unless $always || access_cfg_bool(1, 'setup-useremail');
3524 my ($k, $envvar) = @_;
3525 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3526 return unless defined $v;
3527 set_local_git_config "user.$k", $v;
3530 $setup->('email', 'DEBEMAIL');
3531 $setup->('name', 'DEBFULLNAME');
3534 sub ensure_setup_existing_tree () {
3535 my $k = "remote.$remotename.skipdefaultupdate";
3536 my $c = git_get_config $k;
3537 return if defined $c;
3538 set_local_git_config $k, 'true';
3541 sub open_main_gitattrs () {
3542 confess 'internal error no maindir' unless defined $maindir;
3543 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3545 or die "open $maindir_gitcommon/info/attributes: $!";
3549 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3551 sub is_gitattrs_setup () {
3554 # 1: gitattributes set up and should be left alone
3556 # 0: there is a dgit-defuse-attrs but it needs fixing
3557 # undef: there is none
3558 my $gai = open_main_gitattrs();
3559 return 0 unless $gai;
3561 next unless m{$gitattrs_ourmacro_re};
3562 return 1 if m{\s-working-tree-encoding\s};
3563 printdebug "is_gitattrs_setup: found old macro\n";
3566 $gai->error and confess "$!";
3567 printdebug "is_gitattrs_setup: found nothing\n";
3571 sub setup_gitattrs (;$) {
3573 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3575 my $already = is_gitattrs_setup();
3578 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3579 not doing further gitattributes setup
3583 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3584 my $af = "$maindir_gitcommon/info/attributes";
3585 ensuredir "$maindir_gitcommon/info";
3587 open GAO, "> $af.new" or confess "$!";
3588 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3592 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3594 my $gai = open_main_gitattrs();
3597 if (m{$gitattrs_ourmacro_re}) {
3598 die unless defined $already;
3602 print GAO $_, "\n" or confess "$!";
3604 $gai->error and confess "$!";
3606 close GAO or confess "$!";
3607 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3610 sub setup_new_tree () {
3611 setup_mergechangelogs();
3616 sub check_gitattrs ($$) {
3617 my ($treeish, $what) = @_;
3619 return if is_gitattrs_setup;
3622 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3624 my $gafl = new IO::File;
3625 open $gafl, "-|", @cmd or confess "$!";
3628 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3630 next unless m{(?:^|/)\.gitattributes$};
3632 # oh dear, found one
3633 print STDERR f_ <<END, $what;
3634 dgit: warning: %s contains .gitattributes
3635 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3640 # tree contains no .gitattributes files
3641 $?=0; $!=0; close $gafl or failedcmd @cmd;
3645 sub multisuite_suite_child ($$$) {
3646 my ($tsuite, $mergeinputs, $fn) = @_;
3647 # in child, sets things up, calls $fn->(), and returns undef
3648 # in parent, returns canonical suite name for $tsuite
3649 my $canonsuitefh = IO::File::new_tmpfile;
3650 my $pid = fork // confess "$!";
3654 $us .= " [$isuite]";
3655 $debugprefix .= " ";
3656 progress f_ "fetching %s...", $tsuite;
3657 canonicalise_suite();
3658 print $canonsuitefh $csuite, "\n" or confess "$!";
3659 close $canonsuitefh or confess "$!";
3663 waitpid $pid,0 == $pid or confess "$!";
3664 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3666 seek $canonsuitefh,0,0 or confess "$!";
3667 local $csuite = <$canonsuitefh>;
3668 confess "$!" unless defined $csuite && chomp $csuite;
3670 printdebug "multisuite $tsuite missing\n";
3673 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3674 push @$mergeinputs, {
3681 sub fork_for_multisuite ($) {
3682 my ($before_fetch_merge) = @_;
3683 # if nothing unusual, just returns ''
3686 # returns 0 to caller in child, to do first of the specified suites
3687 # in child, $csuite is not yet set
3689 # returns 1 to caller in parent, to finish up anything needed after
3690 # in parent, $csuite is set to canonicalised portmanteau
3692 my $org_isuite = $isuite;
3693 my @suites = split /\,/, $isuite;
3694 return '' unless @suites > 1;
3695 printdebug "fork_for_multisuite: @suites\n";
3699 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3701 return 0 unless defined $cbasesuite;
3703 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3704 unless @mergeinputs;
3706 my @csuites = ($cbasesuite);
3708 $before_fetch_merge->();
3710 foreach my $tsuite (@suites[1..$#suites]) {
3711 $tsuite =~ s/^-/$cbasesuite-/;
3712 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3719 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3720 push @csuites, $csubsuite;
3723 foreach my $mi (@mergeinputs) {
3724 my $ref = git_get_ref $mi->{Ref};
3725 die "$mi->{Ref} ?" unless length $ref;
3726 $mi->{Commit} = $ref;
3729 $csuite = join ",", @csuites;
3731 my $previous = git_get_ref lrref;
3733 unshift @mergeinputs, {
3734 Commit => $previous,
3735 Info => (__ "local combined tracking branch"),
3737 "archive seems to have rewound: local tracking branch is ahead!"),
3741 foreach my $ix (0..$#mergeinputs) {
3742 $mergeinputs[$ix]{Index} = $ix;
3745 @mergeinputs = sort {
3746 -version_compare(mergeinfo_version $a,
3747 mergeinfo_version $b) # highest version first
3749 $a->{Index} <=> $b->{Index}; # earliest in spec first
3755 foreach my $mi (@mergeinputs) {
3756 printdebug "multisuite merge check $mi->{Info}\n";
3757 foreach my $previous (@needed) {
3758 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3759 printdebug "multisuite merge un-needed $previous->{Info}\n";
3763 printdebug "multisuite merge this-needed\n";
3764 $mi->{Character} = '+';
3767 $needed[0]{Character} = '*';
3769 my $output = $needed[0]{Commit};
3772 printdebug "multisuite merge nontrivial\n";
3773 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3775 my $commit = "tree $tree\n";
3776 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3777 "Input branches:\n",
3780 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3781 printdebug "multisuite merge include $mi->{Info}\n";
3782 $mi->{Character} //= ' ';
3783 $commit .= "parent $mi->{Commit}\n";
3784 $msg .= sprintf " %s %-25s %s\n",
3786 (mergeinfo_version $mi),
3789 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3790 $msg .= __ "\nKey\n".
3791 " * marks the highest version branch, which choose to use\n".
3792 " + marks each branch which was not already an ancestor\n\n";
3794 "[dgit multi-suite $csuite]\n";
3796 "author $authline\n".
3797 "committer $authline\n\n";
3798 $output = hash_commit_text $commit.$msg;
3799 printdebug "multisuite merge generated $output\n";
3802 fetch_from_archive_record_1($output);
3803 fetch_from_archive_record_2($output);
3805 progress f_ "calculated combined tracking suite %s", $csuite;
3810 sub clone_set_head () {
3811 open H, "> .git/HEAD" or confess "$!";
3812 print H "ref: ".lref()."\n" or confess "$!";
3813 close H or confess "$!";
3815 sub clone_finish ($) {
3817 runcmd @git, qw(reset --hard), lrref();
3818 runcmd qw(bash -ec), <<'END';
3820 git ls-tree -r --name-only -z HEAD | \
3821 xargs -0r touch -h -r . --
3823 printdone f_ "ready for work in %s", $dstdir;
3827 # in multisuite, returns twice!
3828 # once in parent after first suite fetched,
3829 # and then again in child after everything is finished
3831 badusage __ "dry run makes no sense with clone" unless act_local();
3833 my $multi_fetched = fork_for_multisuite(sub {
3834 printdebug "multi clone before fetch merge\n";
3838 if ($multi_fetched) {
3839 printdebug "multi clone after fetch merge\n";
3841 clone_finish($dstdir);
3844 printdebug "clone main body\n";
3846 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3850 canonicalise_suite();
3851 my $hasgit = check_for_git();
3853 runcmd @git, qw(init -q);
3857 my $giturl = access_giturl(1);
3858 if (defined $giturl) {
3859 runcmd @git, qw(remote add), 'origin', $giturl;
3862 progress __ "fetching existing git history";
3864 runcmd_ordryrun_local @git, qw(fetch origin);
3866 progress __ "starting new git history";
3868 fetch_from_archive() or no_such_package;
3869 my $vcsgiturl = $dsc->{'Vcs-Git'};
3870 if (length $vcsgiturl) {
3871 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3872 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3874 clone_finish($dstdir);
3878 canonicalise_suite();
3879 if (check_for_git()) {
3882 fetch_from_archive() or no_such_package();
3884 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3885 if (length $vcsgiturl and
3886 (grep { $csuite eq $_ }
3888 cfg 'dgit.vcs-git.suites')) {
3889 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3890 if (defined $current && $current ne $vcsgiturl) {
3891 print STDERR f_ <<END, $csuite;
3892 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3893 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3897 printdone f_ "fetched into %s", lrref();
3901 my $multi_fetched = fork_for_multisuite(sub { });
3902 fetch_one() unless $multi_fetched; # parent
3903 finish 0 if $multi_fetched eq '0'; # child
3908 runcmd_ordryrun_local @git, qw(merge -m),
3909 (f_ "Merge from %s [dgit]", $csuite),
3911 printdone f_ "fetched to %s and merged into HEAD", lrref();
3914 sub check_not_dirty () {
3915 my @forbid = qw(local-options local-patch-header);
3916 @forbid = map { "debian/source/$_" } @forbid;
3917 foreach my $f (@forbid) {
3918 if (stat_exists $f) {
3919 fail f_ "git tree contains %s", $f;
3923 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3924 push @cmd, qw(debian/source/format debian/source/options);
3927 my $bad = cmdoutput @cmd;
3930 "you have uncommitted changes to critical files, cannot continue:\n").
3934 return if $includedirty;
3936 git_check_unmodified();
3939 sub commit_admin ($) {
3942 runcmd_ordryrun_local @git, qw(commit -m), $m;
3945 sub quiltify_nofix_bail ($$) {
3946 my ($headinfo, $xinfo) = @_;
3947 if ($quilt_mode eq 'nofix') {
3949 "quilt fixup required but quilt mode is \`nofix'\n".
3950 "HEAD commit%s differs from tree implied by debian/patches%s",
3955 sub commit_quilty_patch () {
3956 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3958 foreach my $l (split /\n/, $output) {
3959 next unless $l =~ m/\S/;
3960 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3964 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3966 progress __ "nothing quilty to commit, ok.";
3969 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3970 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3971 runcmd_ordryrun_local @git, qw(add -f), @adds;
3972 commit_admin +(__ <<ENDT).<<END
3973 Commit Debian 3.0 (quilt) metadata
3976 [dgit ($our_version) quilt-fixup]
3980 sub get_source_format () {
3982 if (open F, "debian/source/options") {
3986 s/\s+$//; # ignore missing final newline
3988 my ($k, $v) = ($`, $'); #');
3989 $v =~ s/^"(.*)"$/$1/;
3995 F->error and confess "$!";
3998 confess "$!" unless $!==&ENOENT;
4001 if (!open F, "debian/source/format") {
4002 confess "$!" unless $!==&ENOENT;
4006 F->error and confess "$!";
4008 return ($_, \%options);
4011 sub madformat_wantfixup ($) {
4013 return 0 unless $format eq '3.0 (quilt)';
4014 our $quilt_mode_warned;
4015 if ($quilt_mode eq 'nocheck') {
4016 progress f_ "Not doing any fixup of \`%s'".
4017 " due to ----no-quilt-fixup or --quilt=nocheck", $format
4018 unless $quilt_mode_warned++;
4021 progress f_ "Format \`%s', need to check/update patch stack", $format
4022 unless $quilt_mode_warned++;
4026 sub maybe_split_brain_save ($$$) {
4027 my ($headref, $dgitview, $msg) = @_;
4028 # => message fragment "$saved" describing disposition of $dgitview
4029 # (used inside parens, in the English texts)
4030 my $save = $internal_object_save{'dgit-view'};
4031 return f_ "commit id %s", $dgitview unless defined $save;
4032 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4034 "dgit --dgit-view-save $msg HEAD=$headref",
4037 return f_ "and left in %s", $save;
4040 # An "infopair" is a tuple [ $thing, $what ]
4041 # (often $thing is a commit hash; $what is a description)
4043 sub infopair_cond_equal ($$) {
4045 $x->[0] eq $y->[0] or fail <<END;
4046 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4050 sub infopair_lrf_tag_lookup ($$) {
4051 my ($tagnames, $what) = @_;
4052 # $tagname may be an array ref
4053 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4054 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4055 foreach my $tagname (@tagnames) {
4056 my $lrefname = lrfetchrefs."/tags/$tagname";
4057 my $tagobj = $lrfetchrefs_f{$lrefname};
4058 next unless defined $tagobj;
4059 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4060 return [ git_rev_parse($tagobj), $what ];
4062 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4063 Wanted tag %s (%s) on dgit server, but not found
4065 : (f_ <<END, $what, "@tagnames");
4066 Wanted tag %s (one of: %s) on dgit server, but not found
4070 sub infopair_cond_ff ($$) {
4071 my ($anc,$desc) = @_;
4072 is_fast_fwd($anc->[0], $desc->[0]) or
4073 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4074 %s (%s) .. %s (%s) is not fast forward
4078 sub pseudomerge_version_check ($$) {
4079 my ($clogp, $archive_hash) = @_;
4081 my $arch_clogp = commit_getclogp $archive_hash;
4082 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4083 __ 'version currently in archive' ];
4084 if (defined $overwrite_version) {
4085 if (length $overwrite_version) {
4086 infopair_cond_equal([ $overwrite_version,
4087 '--overwrite= version' ],
4090 my $v = $i_arch_v->[0];
4092 "Checking package changelog for archive version %s ...", $v;
4095 my @xa = ("-f$v", "-t$v");
4096 my $vclogp = parsechangelog @xa;
4099 [ (getfield $vclogp, $fn),
4100 (f_ "%s field from dpkg-parsechangelog %s",
4103 my $cv = $gf->('Version');
4104 infopair_cond_equal($i_arch_v, $cv);
4105 $cd = $gf->('Distribution');
4109 $@ =~ s/^dgit: //gm;
4111 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4113 fail f_ <<END, $cd->[1], $cd->[0], $v
4115 Your tree seems to based on earlier (not uploaded) %s.
4117 if $cd->[0] =~ m/UNRELEASED/;
4121 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4125 sub pseudomerge_hash_commit ($$$$ $$) {
4126 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4127 $msg_cmd, $msg_msg) = @_;
4128 progress f_ "Declaring that HEAD includes all changes in %s...",
4131 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4132 my $authline = clogp_authline $clogp;
4136 !defined $overwrite_version ? ""
4137 : !length $overwrite_version ? " --overwrite"
4138 : " --overwrite=".$overwrite_version;
4140 # Contributing parent is the first parent - that makes
4141 # git rev-list --first-parent DTRT.
4142 my $pmf = dgit_privdir()."/pseudomerge";
4143 open MC, ">", $pmf or die "$pmf $!";
4144 print MC <<END or confess "$!";
4147 parent $archive_hash
4155 close MC or confess "$!";
4157 return hash_commit($pmf);
4160 sub splitbrain_pseudomerge ($$$$) {
4161 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4162 # => $merged_dgitview
4163 printdebug "splitbrain_pseudomerge...\n";
4165 # We: debian/PREVIOUS HEAD($maintview)
4166 # expect: o ----------------- o
4169 # a/d/PREVIOUS $dgitview
4172 # we do: `------------------ o
4176 return $dgitview unless defined $archive_hash;
4177 return $dgitview if deliberately_not_fast_forward();
4179 printdebug "splitbrain_pseudomerge...\n";
4181 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4183 if (!defined $overwrite_version) {
4184 progress __ "Checking that HEAD includes all changes in archive...";
4187 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4189 if (defined $overwrite_version) {
4191 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4192 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4193 __ "maintainer view tag");
4194 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4195 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4196 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4198 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4200 infopair_cond_equal($i_dgit, $i_archive);
4201 infopair_cond_ff($i_dep14, $i_dgit);
4202 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4205 $@ =~ s/^\n//; chomp $@;
4206 print STDERR <<END.(__ <<ENDT);
4209 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4214 my $arch_v = $i_arch_v->[0];
4215 my $r = pseudomerge_hash_commit
4216 $clogp, $dgitview, $archive_hash, $i_arch_v,
4217 "dgit --quilt=$quilt_mode",
4218 (defined $overwrite_version
4219 ? f_ "Declare fast forward from %s\n", $arch_v
4220 : f_ "Make fast forward from %s\n", $arch_v);
4222 maybe_split_brain_save $maintview, $r, "pseudomerge";
4224 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4228 sub plain_overwrite_pseudomerge ($$$) {
4229 my ($clogp, $head, $archive_hash) = @_;
4231 printdebug "plain_overwrite_pseudomerge...";
4233 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4235 return $head if is_fast_fwd $archive_hash, $head;
4237 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4239 my $r = pseudomerge_hash_commit
4240 $clogp, $head, $archive_hash, $i_arch_v,
4243 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4245 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4249 sub push_parse_changelog ($) {
4252 my $clogp = Dpkg::Control::Hash->new();
4253 $clogp->load($clogpfn) or die;
4255 my $clogpackage = getfield $clogp, 'Source';
4256 $package //= $clogpackage;
4257 fail f_ "-p specified %s but changelog specified %s",
4258 $package, $clogpackage
4259 unless $package eq $clogpackage;
4260 my $cversion = getfield $clogp, 'Version';
4262 if (!$we_are_initiator) {
4263 # rpush initiator can't do this because it doesn't have $isuite yet
4264 my $tag = debiantag_new($cversion, access_nomdistro);
4265 runcmd @git, qw(check-ref-format), $tag;
4268 my $dscfn = dscfn($cversion);
4270 return ($clogp, $cversion, $dscfn);
4273 sub push_parse_dsc ($$$) {
4274 my ($dscfn,$dscfnwhat, $cversion) = @_;
4275 $dsc = parsecontrol($dscfn,$dscfnwhat);
4276 my $dversion = getfield $dsc, 'Version';
4277 my $dscpackage = getfield $dsc, 'Source';
4278 ($dscpackage eq $package && $dversion eq $cversion) or
4279 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4280 $dscfn, $dscpackage, $dversion,
4281 $package, $cversion;
4284 sub push_tagwants ($$$$) {
4285 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4288 TagFn => \&debiantag_new,
4293 if (defined $maintviewhead) {
4295 TagFn => \&debiantag_maintview,
4296 Objid => $maintviewhead,
4297 TfSuffix => '-maintview',
4300 } elsif ($dodep14tag ne 'no') {
4302 TagFn => \&debiantag_maintview,
4304 TfSuffix => '-dgit',
4308 foreach my $tw (@tagwants) {
4309 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4310 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4312 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4316 sub push_mktags ($$ $$ $) {
4318 $changesfile,$changesfilewhat,
4321 die unless $tagwants->[0]{View} eq 'dgit';
4323 my $declaredistro = access_nomdistro();
4324 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4325 $dsc->{$ourdscfield[0]} = join " ",
4326 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4328 $dsc->save("$dscfn.tmp") or confess "$!";
4330 my $changes = parsecontrol($changesfile,$changesfilewhat);
4331 foreach my $field (qw(Source Distribution Version)) {
4332 $changes->{$field} eq $clogp->{$field} or
4333 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4334 $field, $changes->{$field}, $clogp->{$field};
4337 my $cversion = getfield $clogp, 'Version';
4338 my $clogsuite = getfield $clogp, 'Distribution';
4340 # We make the git tag by hand because (a) that makes it easier
4341 # to control the "tagger" (b) we can do remote signing
4342 my $authline = clogp_authline $clogp;
4343 my $delibs = join(" ", "",@deliberatelies);
4347 my $tfn = $tw->{Tfn};
4348 my $head = $tw->{Objid};
4349 my $tag = $tw->{Tag};
4351 open TO, '>', $tfn->('.tmp') or confess "$!";
4352 print TO <<END or confess "$!";
4359 if ($tw->{View} eq 'dgit') {
4360 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4361 %s release %s for %s (%s) [dgit]
4364 print TO <<END or confess "$!";
4365 [dgit distro=$declaredistro$delibs]
4367 foreach my $ref (sort keys %previously) {
4368 print TO <<END or confess "$!";
4369 [dgit previously:$ref=$previously{$ref}]
4372 } elsif ($tw->{View} eq 'maint') {
4373 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4374 %s release %s for %s (%s)
4375 (maintainer view tag generated by dgit --quilt=%s)
4380 confess Dumper($tw)."?";
4383 close TO or confess "$!";
4385 my $tagobjfn = $tfn->('.tmp');
4387 if (!defined $keyid) {
4388 $keyid = access_cfg('keyid','RETURN-UNDEF');
4390 if (!defined $keyid) {
4391 $keyid = getfield $clogp, 'Maintainer';
4393 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4394 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4395 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4396 push @sign_cmd, $tfn->('.tmp');
4397 runcmd_ordryrun @sign_cmd;
4399 $tagobjfn = $tfn->('.signed.tmp');
4400 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4401 $tfn->('.tmp'), $tfn->('.tmp.asc');
4407 my @r = map { $mktag->($_); } @$tagwants;
4411 sub sign_changes ($) {
4412 my ($changesfile) = @_;
4414 my @debsign_cmd = @debsign;
4415 push @debsign_cmd, "-k$keyid" if defined $keyid;
4416 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4417 push @debsign_cmd, $changesfile;
4418 runcmd_ordryrun @debsign_cmd;
4423 printdebug "actually entering push\n";
4425 supplementary_message(__ <<'END');
4426 Push failed, while checking state of the archive.
4427 You can retry the push, after fixing the problem, if you like.
4429 if (check_for_git()) {
4432 my $archive_hash = fetch_from_archive();
4433 if (!$archive_hash) {
4435 fail __ "package appears to be new in this suite;".
4436 " if this is intentional, use --new";
4439 supplementary_message(__ <<'END');
4440 Push failed, while preparing your push.
4441 You can retry the push, after fixing the problem, if you like.
4446 access_giturl(); # check that success is vaguely likely
4447 rpush_handle_protovsn_bothends() if $we_are_initiator;
4449 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4450 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4452 responder_send_file('parsed-changelog', $clogpfn);
4454 my ($clogp, $cversion, $dscfn) =
4455 push_parse_changelog("$clogpfn");
4457 my $dscpath = "$buildproductsdir/$dscfn";
4458 stat_exists $dscpath or
4459 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4462 responder_send_file('dsc', $dscpath);
4464 push_parse_dsc($dscpath, $dscfn, $cversion);
4466 my $format = getfield $dsc, 'Format';
4468 my $symref = git_get_symref();
4469 my $actualhead = git_rev_parse('HEAD');
4471 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4472 if (quiltmode_splitting()) {
4473 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4474 fail f_ <<END, $ffq_prev, $quilt_mode;
4475 Branch is managed by git-debrebase (%s
4476 exists), but quilt mode (%s) implies a split view.
4477 Pass the right --quilt option or adjust your git config.
4478 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4481 runcmd_ordryrun_local @git_debrebase, 'stitch';
4482 $actualhead = git_rev_parse('HEAD');
4485 my $dgithead = $actualhead;
4486 my $maintviewhead = undef;
4488 my $upstreamversion = upstreamversion $clogp->{Version};
4490 if (madformat_wantfixup($format)) {
4491 # user might have not used dgit build, so maybe do this now:
4492 if (do_split_brain()) {
4493 changedir $playground;
4495 ($dgithead, $cachekey) =
4496 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4497 $dgithead or fail f_
4498 "--quilt=%s but no cached dgit view:
4499 perhaps HEAD changed since dgit build[-source] ?",
4502 if (!do_split_brain()) {
4503 # In split brain mode, do not attempt to incorporate dirty
4504 # stuff from the user's working tree. That would be mad.
4505 commit_quilty_patch();
4508 if (do_split_brain()) {
4509 $made_split_brain = 1;
4510 $dgithead = splitbrain_pseudomerge($clogp,
4511 $actualhead, $dgithead,
4513 $maintviewhead = $actualhead;
4515 prep_ud(); # so _only_subdir() works, below
4518 if (defined $overwrite_version && !defined $maintviewhead
4520 $dgithead = plain_overwrite_pseudomerge($clogp,
4528 if ($archive_hash) {
4529 if (is_fast_fwd($archive_hash, $dgithead)) {
4531 } elsif (deliberately_not_fast_forward) {
4534 fail __ "dgit push: HEAD is not a descendant".
4535 " of the archive's version.\n".
4536 "To overwrite the archive's contents,".
4537 " pass --overwrite[=VERSION].\n".
4538 "To rewind history, if permitted by the archive,".
4539 " use --deliberately-not-fast-forward.";
4543 confess unless !!$made_split_brain == do_split_brain();
4545 changedir $playground;
4546 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4547 runcmd qw(dpkg-source -x --),
4548 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4549 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4550 check_for_vendor_patches() if madformat($dsc->{format});
4552 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4553 debugcmd "+",@diffcmd;
4555 my $r = system @diffcmd;
4558 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4559 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4562 my $raw = cmdoutput @git,
4563 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4565 foreach (split /\0/, $raw) {
4566 if (defined $changed) {
4567 push @mode_changes, "$changed: $_\n" if $changed;
4570 } elsif (m/^:0+ 0+ /) {
4572 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4573 $changed = "Mode change from $1 to $2"
4578 if (@mode_changes) {
4579 fail +(f_ <<ENDT, $dscfn).<<END
4580 HEAD specifies a different tree to %s:
4584 .(join '', @mode_changes)
4585 .(f_ <<ENDT, $tree, $referent);
4586 There is a problem with your source tree (see dgit(7) for some hints).
4587 To see a full diff, run git diff %s %s
4591 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4592 HEAD specifies a different tree to %s:
4596 Perhaps you forgot to build. Or perhaps there is a problem with your
4597 source tree (see dgit(7) for some hints). To see a full diff, run
4604 if (!$changesfile) {
4605 my $pat = changespat $cversion;
4606 my @cs = glob "$buildproductsdir/$pat";
4607 fail f_ "failed to find unique changes file".
4608 " (looked for %s in %s);".
4609 " perhaps you need to use dgit -C",
4610 $pat, $buildproductsdir
4612 ($changesfile) = @cs;
4614 $changesfile = "$buildproductsdir/$changesfile";
4617 # Check that changes and .dsc agree enough
4618 $changesfile =~ m{[^/]*$};
4619 my $changes = parsecontrol($changesfile,$&);
4620 files_compare_inputs($dsc, $changes)
4621 unless forceing [qw(dsc-changes-mismatch)];
4623 # Check whether this is a source only upload
4624 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4625 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4626 if ($sourceonlypolicy eq 'ok') {
4627 } elsif ($sourceonlypolicy eq 'always') {
4628 forceable_fail [qw(uploading-binaries)],
4629 __ "uploading binaries, although distro policy is source only"
4631 } elsif ($sourceonlypolicy eq 'never') {
4632 forceable_fail [qw(uploading-source-only)],
4633 __ "source-only upload, although distro policy requires .debs"
4635 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4636 forceable_fail [qw(uploading-source-only)],
4637 f_ "source-only upload, even though package is entirely NEW\n".
4638 "(this is contrary to policy in %s)",
4642 && !(archive_query('package_not_wholly_new', $package) // 1);
4644 badcfg f_ "unknown source-only-uploads policy \`%s'",
4648 # Perhaps adjust .dsc to contain right set of origs
4649 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4651 unless forceing [qw(changes-origs-exactly)];
4653 # Checks complete, we're going to try and go ahead:
4655 responder_send_file('changes',$changesfile);
4656 responder_send_command("param head $dgithead");
4657 responder_send_command("param csuite $csuite");
4658 responder_send_command("param isuite $isuite");
4659 responder_send_command("param tagformat new"); # needed in $protovsn==4
4660 if (defined $maintviewhead) {
4661 responder_send_command("param maint-view $maintviewhead");
4664 # Perhaps send buildinfo(s) for signing
4665 my $changes_files = getfield $changes, 'Files';
4666 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4667 foreach my $bi (@buildinfos) {
4668 responder_send_command("param buildinfo-filename $bi");
4669 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4672 if (deliberately_not_fast_forward) {
4673 git_for_each_ref(lrfetchrefs, sub {
4674 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4675 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4676 responder_send_command("previously $rrefname=$objid");
4677 $previously{$rrefname} = $objid;
4681 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4682 dgit_privdir()."/tag");
4685 supplementary_message(__ <<'END');
4686 Push failed, while signing the tag.
4687 You can retry the push, after fixing the problem, if you like.
4689 # If we manage to sign but fail to record it anywhere, it's fine.
4690 if ($we_are_responder) {
4691 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4692 responder_receive_files('signed-tag', @tagobjfns);
4694 @tagobjfns = push_mktags($clogp,$dscpath,
4695 $changesfile,$changesfile,
4698 supplementary_message(__ <<'END');
4699 Push failed, *after* signing the tag.
4700 If you want to try again, you should use a new version number.
4703 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4705 foreach my $tw (@tagwants) {
4706 my $tag = $tw->{Tag};
4707 my $tagobjfn = $tw->{TagObjFn};
4709 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4710 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4711 runcmd_ordryrun_local
4712 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4715 supplementary_message(__ <<'END');
4716 Push failed, while updating the remote git repository - see messages above.
4717 If you want to try again, you should use a new version number.
4719 if (!check_for_git()) {
4720 create_remote_git_repo();
4723 my @pushrefs = $forceflag.$dgithead.":".rrref();
4724 foreach my $tw (@tagwants) {
4725 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4728 runcmd_ordryrun @git,
4729 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4730 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4732 supplementary_message(__ <<'END');
4733 Push failed, while obtaining signatures on the .changes and .dsc.
4734 If it was just that the signature failed, you may try again by using
4735 debsign by hand to sign the changes file (see the command dgit tried,
4736 above), and then dput that changes file to complete the upload.
4737 If you need to change the package, you must use a new version number.
4739 if ($we_are_responder) {
4740 my $dryrunsuffix = act_local() ? "" : ".tmp";
4741 my @rfiles = ($dscpath, $changesfile);
4742 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4743 responder_receive_files('signed-dsc-changes',
4744 map { "$_$dryrunsuffix" } @rfiles);
4747 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4749 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4751 sign_changes $changesfile;
4754 supplementary_message(f_ <<END, $changesfile);
4755 Push failed, while uploading package(s) to the archive server.
4756 You can retry the upload of exactly these same files with dput of:
4758 If that .changes file is broken, you will need to use a new version
4759 number for your next attempt at the upload.
4761 my $host = access_cfg('upload-host','RETURN-UNDEF');
4762 my @hostarg = defined($host) ? ($host,) : ();
4763 runcmd_ordryrun @dput, @hostarg, $changesfile;
4764 printdone f_ "pushed and uploaded %s", $cversion;
4766 supplementary_message('');
4767 responder_send_command("complete");
4771 not_necessarily_a_tree();
4776 badusage __ "-p is not allowed with clone; specify as argument instead"
4777 if defined $package;
4780 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4781 ($package,$isuite) = @ARGV;
4782 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4783 ($package,$dstdir) = @ARGV;
4784 } elsif (@ARGV==3) {
4785 ($package,$isuite,$dstdir) = @ARGV;
4787 badusage __ "incorrect arguments to dgit clone";
4791 $dstdir ||= "$package";
4792 if (stat_exists $dstdir) {
4793 fail f_ "%s already exists", $dstdir;
4797 if ($rmonerror && !$dryrun_level) {
4798 $cwd_remove= getcwd();
4800 return unless defined $cwd_remove;
4801 if (!chdir "$cwd_remove") {
4802 return if $!==&ENOENT;
4803 confess "chdir $cwd_remove: $!";
4805 printdebug "clone rmonerror removing $dstdir\n";
4807 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4808 } elsif (grep { $! == $_ }
4809 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4811 print STDERR f_ "check whether to remove %s: %s\n",
4818 $cwd_remove = undef;
4821 sub branchsuite () {
4822 my $branch = git_get_symref();
4823 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4830 sub package_from_d_control () {
4831 if (!defined $package) {
4832 my $sourcep = parsecontrol('debian/control','debian/control');
4833 $package = getfield $sourcep, 'Source';
4837 sub fetchpullargs () {
4838 package_from_d_control();
4840 $isuite = branchsuite();
4842 my $clogp = parsechangelog();
4843 my $clogsuite = getfield $clogp, 'Distribution';
4844 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4846 } elsif (@ARGV==1) {
4849 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4863 determine_whether_split_brain();
4864 if (do_split_brain()) {
4865 my ($format, $fopts) = get_source_format();
4866 madformat($format) and fail f_ <<END, $quilt_mode
4867 dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
4875 package_from_d_control();
4876 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4880 foreach my $canon (qw(0 1)) {
4885 canonicalise_suite();
4887 if (length git_get_ref lref()) {
4888 # local branch already exists, yay
4891 if (!length git_get_ref lrref()) {
4899 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4902 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4903 "dgit checkout $isuite";
4904 runcmd (@git, qw(checkout), lbranch());
4907 sub cmd_update_vcs_git () {
4909 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4910 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4912 ($specsuite) = (@ARGV);
4917 if ($ARGV[0] eq '-') {
4919 } elsif ($ARGV[0] eq '-') {
4924 package_from_d_control();
4926 if ($specsuite eq '.') {
4927 $ctrl = parsecontrol 'debian/control', 'debian/control';
4929 $isuite = $specsuite;
4933 my $url = getfield $ctrl, 'Vcs-Git';
4936 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4937 if (!defined $orgurl) {
4938 print STDERR f_ "setting up vcs-git: %s\n", $url;
4939 @cmd = (@git, qw(remote add vcs-git), $url);
4940 } elsif ($orgurl eq $url) {
4941 print STDERR f_ "vcs git already configured: %s\n", $url;
4943 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4944 @cmd = (@git, qw(remote set-url vcs-git), $url);
4946 runcmd_ordryrun_local @cmd;
4948 print f_ "fetching (%s)\n", "@ARGV";
4949 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4955 build_or_push_prep_early();
4957 build_or_push_prep_modes();
4961 } elsif (@ARGV==1) {
4962 ($specsuite) = (@ARGV);
4964 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4967 local ($package) = $existing_package; # this is a hack
4968 canonicalise_suite();
4970 canonicalise_suite();
4972 if (defined $specsuite &&
4973 $specsuite ne $isuite &&
4974 $specsuite ne $csuite) {
4975 fail f_ "dgit %s: changelog specifies %s (%s)".
4976 " but command line specifies %s",
4977 $subcommand, $isuite, $csuite, $specsuite;
4986 #---------- remote commands' implementation ----------
4988 sub pre_remote_push_build_host {
4989 my ($nrargs) = shift @ARGV;
4990 my (@rargs) = @ARGV[0..$nrargs-1];
4991 @ARGV = @ARGV[$nrargs..$#ARGV];
4993 my ($dir,$vsnwant) = @rargs;
4994 # vsnwant is a comma-separated list; we report which we have
4995 # chosen in our ready response (so other end can tell if they
4998 $we_are_responder = 1;
4999 $us .= " (build host)";
5001 open PI, "<&STDIN" or confess "$!";
5002 open STDIN, "/dev/null" or confess "$!";
5003 open PO, ">&STDOUT" or confess "$!";
5005 open STDOUT, ">&STDERR" or confess "$!";
5009 ($protovsn) = grep {
5010 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5011 } @rpushprotovsn_support;
5013 fail f_ "build host has dgit rpush protocol versions %s".
5014 " but invocation host has %s",
5015 (join ",", @rpushprotovsn_support), $vsnwant
5016 unless defined $protovsn;
5020 sub cmd_remote_push_build_host {
5021 responder_send_command("dgit-remote-push-ready $protovsn");
5025 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5026 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5027 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5028 # a good error message)
5030 sub rpush_handle_protovsn_bothends () {
5037 my $report = i_child_report();
5038 if (defined $report) {
5039 printdebug "($report)\n";
5040 } elsif ($i_child_pid) {
5041 printdebug "(killing build host child $i_child_pid)\n";
5042 kill 15, $i_child_pid;
5044 if (defined $i_tmp && !defined $initiator_tempdir) {
5046 eval { rmtree $i_tmp; };
5051 return unless forkcheck_mainprocess();
5056 my ($base,$selector,@args) = @_;
5057 $selector =~ s/\-/_/g;
5058 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5062 not_necessarily_a_tree();
5067 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5075 push @rargs, join ",", @rpushprotovsn_support;
5078 push @rdgit, @ropts;
5079 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5081 my @cmd = (@ssh, $host, shellquote @rdgit);
5084 $we_are_initiator=1;
5086 if (defined $initiator_tempdir) {
5087 rmtree $initiator_tempdir;
5088 mkdir $initiator_tempdir, 0700
5089 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5090 $i_tmp = $initiator_tempdir;
5094 $i_child_pid = open2(\*RO, \*RI, @cmd);
5096 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5097 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5100 my ($icmd,$iargs) = initiator_expect {
5101 m/^(\S+)(?: (.*))?$/;
5104 i_method "i_resp", $icmd, $iargs;
5108 sub i_resp_progress ($) {
5110 my $msg = protocol_read_bytes \*RO, $rhs;
5114 sub i_resp_supplementary_message ($) {
5116 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5119 sub i_resp_complete {
5120 my $pid = $i_child_pid;
5121 $i_child_pid = undef; # prevents killing some other process with same pid
5122 printdebug "waiting for build host child $pid...\n";
5123 my $got = waitpid $pid, 0;
5124 confess "$!" unless $got == $pid;
5125 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5128 printdebug __ "all done\n";
5132 sub i_resp_file ($) {
5134 my $localname = i_method "i_localname", $keyword;
5135 my $localpath = "$i_tmp/$localname";
5136 stat_exists $localpath and
5137 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5138 protocol_receive_file \*RO, $localpath;
5139 i_method "i_file", $keyword;
5144 sub i_resp_param ($) {
5145 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5149 sub i_resp_previously ($) {
5150 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5151 or badproto \*RO, __ "bad previously spec";
5152 my $r = system qw(git check-ref-format), $1;
5153 confess "bad previously ref spec ($r)" if $r;
5154 $previously{$1} = $2;
5159 sub i_resp_want ($) {
5161 die "$keyword ?" if $i_wanted{$keyword}++;
5163 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5164 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5165 die unless $isuite =~ m/^$suite_re$/;
5168 rpush_handle_protovsn_bothends();
5170 my @localpaths = i_method "i_want", $keyword;
5171 printdebug "[[ $keyword @localpaths\n";
5172 foreach my $localpath (@localpaths) {
5173 protocol_send_file \*RI, $localpath;
5175 print RI "files-end\n" or confess "$!";
5178 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5180 sub i_localname_parsed_changelog {
5181 return "remote-changelog.822";
5183 sub i_file_parsed_changelog {
5184 ($i_clogp, $i_version, $i_dscfn) =
5185 push_parse_changelog "$i_tmp/remote-changelog.822";
5186 die if $i_dscfn =~ m#/|^\W#;
5189 sub i_localname_dsc {
5190 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5195 sub i_localname_buildinfo ($) {
5196 my $bi = $i_param{'buildinfo-filename'};
5197 defined $bi or badproto \*RO, "buildinfo before filename";
5198 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5199 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5200 or badproto \*RO, "improper buildinfo filename";
5203 sub i_file_buildinfo {
5204 my $bi = $i_param{'buildinfo-filename'};
5205 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5206 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5207 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5208 files_compare_inputs($bd, $ch);
5209 (getfield $bd, $_) eq (getfield $ch, $_) or
5210 fail f_ "buildinfo mismatch in field %s", $_
5211 foreach qw(Source Version);
5212 !defined $bd->{$_} or
5213 fail f_ "buildinfo contains forbidden field %s", $_
5214 foreach qw(Changes Changed-by Distribution);
5216 push @i_buildinfos, $bi;
5217 delete $i_param{'buildinfo-filename'};
5220 sub i_localname_changes {
5221 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5222 $i_changesfn = $i_dscfn;
5223 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5224 return $i_changesfn;
5226 sub i_file_changes { }
5228 sub i_want_signed_tag {
5229 printdebug Dumper(\%i_param, $i_dscfn);
5230 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5231 && defined $i_param{'csuite'}
5232 or badproto \*RO, "premature desire for signed-tag";
5233 my $head = $i_param{'head'};
5234 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5236 my $maintview = $i_param{'maint-view'};
5237 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5239 if ($protovsn == 4) {
5240 my $p = $i_param{'tagformat'} // '<undef>';
5242 or badproto \*RO, "tag format mismatch: $p vs. new";
5245 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5247 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5249 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5252 push_mktags $i_clogp, $i_dscfn,
5253 $i_changesfn, (__ 'remote changes file'),
5257 sub i_want_signed_dsc_changes {
5258 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5259 sign_changes $i_changesfn;
5260 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5263 #---------- building etc. ----------
5269 #----- `3.0 (quilt)' handling -----
5271 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5273 sub quiltify_dpkg_commit ($$$;$) {
5274 my ($patchname,$author,$msg, $xinfo) = @_;
5277 mkpath '.git/dgit'; # we are in playtree
5278 my $descfn = ".git/dgit/quilt-description.tmp";
5279 open O, '>', $descfn or confess "$descfn: $!";
5280 $msg =~ s/\n+/\n\n/;
5281 print O <<END or confess "$!";
5283 ${xinfo}Subject: $msg
5287 close O or confess "$!";
5290 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5291 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5292 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5293 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5297 sub quiltify_trees_differ ($$;$$$) {
5298 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5299 # returns true iff the two tree objects differ other than in debian/
5300 # with $finegrained,
5301 # returns bitmask 01 - differ in upstream files except .gitignore
5302 # 02 - differ in .gitignore
5303 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5304 # is set for each modified .gitignore filename $fn
5305 # if $unrepres is defined, array ref to which is appeneded
5306 # a list of unrepresentable changes (removals of upstream files
5309 my @cmd = (@git, qw(diff-tree -z --no-renames));
5310 push @cmd, qw(--name-only) unless $unrepres;
5311 push @cmd, qw(-r) if $finegrained || $unrepres;
5313 my $diffs= cmdoutput @cmd;
5316 foreach my $f (split /\0/, $diffs) {
5317 if ($unrepres && !@lmodes) {
5318 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5321 my ($oldmode,$newmode) = @lmodes;
5324 next if $f =~ m#^debian(?:/.*)?$#s;
5328 die __ "not a plain file or symlink\n"
5329 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5330 $oldmode =~ m/^(?:10|12)\d{4}$/;
5331 if ($oldmode =~ m/[^0]/ &&
5332 $newmode =~ m/[^0]/) {
5333 # both old and new files exist
5334 die __ "mode or type changed\n" if $oldmode ne $newmode;
5335 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5336 } elsif ($oldmode =~ m/[^0]/) {
5338 die __ "deletion of symlink\n"
5339 unless $oldmode =~ m/^10/;
5342 die __ "creation with non-default mode\n"
5343 unless $newmode =~ m/^100644$/ or
5344 $newmode =~ m/^120000$/;
5348 local $/="\n"; chomp $@;
5349 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5353 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5354 $r |= $isignore ? 02 : 01;
5355 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5357 printdebug "quiltify_trees_differ $x $y => $r\n";
5361 sub quiltify_tree_sentinelfiles ($) {
5362 # lists the `sentinel' files present in the tree
5364 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5365 qw(-- debian/rules debian/control);
5370 sub quiltify_splitting ($$$$$$$) {
5371 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5372 $editedignores, $cachekey) = @_;
5373 my $gitignore_special = 1;
5374 if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
5375 # treat .gitignore just like any other upstream file
5376 $diffbits = { %$diffbits };
5377 $_ = !!$_ foreach values %$diffbits;
5378 $gitignore_special = 0;
5380 # We would like any commits we generate to be reproducible
5381 my @authline = clogp_authline($clogp);
5382 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5383 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5384 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5385 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5386 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5387 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5389 confess unless do_split_brain();
5391 my $fulldiffhint = sub {
5393 my $cmd = "git diff $x $y -- :/ ':!debian'";
5394 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5395 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5399 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5400 ($diffbits->{O2H} & 01)) {
5402 "--quilt=%s specified, implying patches-unapplied git tree\n".
5403 " but git tree differs from orig in upstream files.",
5405 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5406 if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
5408 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5412 if ($quilt_mode =~ m/dpm/ &&
5413 ($diffbits->{H2A} & 01)) {
5414 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5415 --quilt=%s specified, implying patches-applied git tree
5416 but git tree differs from result of applying debian/patches to upstream
5419 if ($quilt_mode =~ m/baredebian/) {
5420 # We need to construct a merge which has upstream files from
5421 # upstream and debian/ files from HEAD.
5423 read_tree_upstream $quilt_upstream_commitish, 1, $headref;
5424 my $version = getfield $clogp, 'Version';
5425 my $upsversion = upstreamversion $version;
5426 my $merge = make_commit
5427 [ $headref, $quilt_upstream_commitish ],
5428 [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
5429 Combine debian/ with upstream source for %s
5431 [dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
5433 runcmd @git, qw(reset -q --hard), $merge;
5435 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5436 ($diffbits->{O2A} & 01)) { # some patches
5437 progress __ "dgit view: creating patches-applied version using gbp pq";
5438 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5439 # gbp pq import creates a fresh branch; push back to dgit-view
5440 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5441 runcmd @git, qw(checkout -q dgit-view);
5443 if ($quilt_mode =~ m/gbp|dpm/ &&
5444 ($diffbits->{O2A} & 02)) {
5445 fail f_ <<END, $quilt_mode;
5446 --quilt=%s specified, implying that HEAD is for use with a
5447 tool which does not create patches for changes to upstream
5448 .gitignores: but, such patches exist in debian/patches.
5451 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5452 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5454 "dgit view: creating patch to represent .gitignore changes";
5455 ensuredir "debian/patches";
5456 my $gipatch = "debian/patches/auto-gitignore";
5457 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5458 stat GIPATCH or confess "$gipatch: $!";
5459 fail f_ "%s already exists; but want to create it".
5460 " to record .gitignore changes",
5463 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5464 Subject: Update .gitignore from Debian packaging branch
5466 The Debian packaging git branch contains these updates to the upstream
5467 .gitignore file(s). This patch is autogenerated, to provide these
5468 updates to users of the official Debian archive view of the package.
5471 [dgit ($our_version) update-gitignore]
5474 close GIPATCH or die "$gipatch: $!";
5475 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5476 $unapplied, $headref, "--", sort keys %$editedignores;
5477 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5478 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5480 defined read SERIES, $newline, 1 or confess "$!";
5481 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5482 print SERIES "auto-gitignore\n" or confess "$!";
5483 close SERIES or die $!;
5484 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5485 commit_admin +(__ <<END).<<ENDU
5486 Commit patch to update .gitignore
5489 [dgit ($our_version) update-gitignore-quilt-fixup]
5494 sub quiltify ($$$$) {
5495 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5497 # Quilt patchification algorithm
5499 # We search backwards through the history of the main tree's HEAD
5500 # (T) looking for a start commit S whose tree object is identical
5501 # to to the patch tip tree (ie the tree corresponding to the
5502 # current dpkg-committed patch series). For these purposes
5503 # `identical' disregards anything in debian/ - this wrinkle is
5504 # necessary because dpkg-source treates debian/ specially.
5506 # We can only traverse edges where at most one of the ancestors'
5507 # trees differs (in changes outside in debian/). And we cannot
5508 # handle edges which change .pc/ or debian/patches. To avoid
5509 # going down a rathole we avoid traversing edges which introduce
5510 # debian/rules or debian/control. And we set a limit on the
5511 # number of edges we are willing to look at.
5513 # If we succeed, we walk forwards again. For each traversed edge
5514 # PC (with P parent, C child) (starting with P=S and ending with
5515 # C=T) to we do this:
5517 # - dpkg-source --commit with a patch name and message derived from C
5518 # After traversing PT, we git commit the changes which
5519 # should be contained within debian/patches.
5521 # The search for the path S..T is breadth-first. We maintain a
5522 # todo list containing search nodes. A search node identifies a
5523 # commit, and looks something like this:
5525 # Commit => $git_commit_id,
5526 # Child => $c, # or undef if P=T
5527 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5528 # Nontrivial => true iff $p..$c has relevant changes
5535 my %considered; # saves being exponential on some weird graphs
5537 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5540 my ($search,$whynot) = @_;
5541 printdebug " search NOT $search->{Commit} $whynot\n";
5542 $search->{Whynot} = $whynot;
5543 push @nots, $search;
5544 no warnings qw(exiting);
5553 my $c = shift @todo;
5554 next if $considered{$c->{Commit}}++;
5556 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5558 printdebug "quiltify investigate $c->{Commit}\n";
5561 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5562 printdebug " search finished hooray!\n";
5567 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5568 if ($quilt_mode eq 'smash') {
5569 printdebug " search quitting smash\n";
5573 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5574 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5575 if $c_sentinels ne $t_sentinels;
5577 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5578 $commitdata =~ m/\n\n/;
5580 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5581 @parents = map { { Commit => $_, Child => $c } } @parents;
5583 $not->($c, __ "root commit") if !@parents;
5585 foreach my $p (@parents) {
5586 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5588 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5589 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5592 foreach my $p (@parents) {
5593 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5595 my @cmd= (@git, qw(diff-tree -r --name-only),
5596 $p->{Commit},$c->{Commit},
5597 qw(-- debian/patches .pc debian/source/format));
5598 my $patchstackchange = cmdoutput @cmd;
5599 if (length $patchstackchange) {
5600 $patchstackchange =~ s/\n/,/g;
5601 $not->($p, f_ "changed %s", $patchstackchange);
5604 printdebug " search queue P=$p->{Commit} ",
5605 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5611 printdebug "quiltify want to smash\n";
5614 my $x = $_[0]{Commit};
5615 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5618 if ($quilt_mode eq 'linear') {
5620 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5622 my $all_gdr = !!@nots;
5623 foreach my $notp (@nots) {
5624 my $c = $notp->{Child};
5625 my $cprange = $abbrev->($notp);
5626 $cprange .= "..".$abbrev->($c) if $c;
5627 print STDERR f_ "%s: %s: %s\n",
5628 $us, $cprange, $notp->{Whynot};
5629 $all_gdr &&= $notp->{Child} &&
5630 (git_cat_file $notp->{Child}{Commit}, 'commit')
5631 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5635 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5637 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5639 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5640 } elsif ($quilt_mode eq 'smash') {
5641 } elsif ($quilt_mode eq 'auto') {
5642 progress __ "quilt fixup cannot be linear, smashing...";
5644 confess "$quilt_mode ?";
5647 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5648 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5650 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5652 quiltify_dpkg_commit "auto-$version-$target-$time",
5653 (getfield $clogp, 'Maintainer'),
5654 (f_ "Automatically generated patch (%s)\n".
5655 "Last (up to) %s git changes, FYI:\n\n",
5656 $clogp->{Version}, $ncommits).
5661 progress __ "quiltify linearisation planning successful, executing...";
5663 for (my $p = $sref_S;
5664 my $c = $p->{Child};
5666 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5667 next unless $p->{Nontrivial};
5669 my $cc = $c->{Commit};
5671 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5672 $commitdata =~ m/\n\n/ or die "$c ?";
5675 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5678 my $commitdate = cmdoutput
5679 @git, qw(log -n1 --pretty=format:%aD), $cc;
5681 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5683 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5690 my $gbp_check_suitable = sub {
5695 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5696 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5697 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5698 die __ "is series file\n" if m{$series_filename_re}o;
5699 die __ "too long\n" if length > 200;
5701 return $_ unless $@;
5703 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5708 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5710 (\S+) \s* \n //ixm) {
5711 $patchname = $gbp_check_suitable->($1, 'Name');
5713 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5715 (\S+) \s* \n //ixm) {
5716 $patchdir = $gbp_check_suitable->($1, 'Topic');
5721 if (!defined $patchname) {
5722 $patchname = $title;
5723 $patchname =~ s/[.:]$//;
5726 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5727 my $translitname = $converter->convert($patchname);
5728 die unless defined $translitname;
5729 $patchname = $translitname;
5732 +(f_ "dgit: patch title transliteration error: %s", $@)
5734 $patchname =~ y/ A-Z/-a-z/;
5735 $patchname =~ y/-a-z0-9_.+=~//cd;
5736 $patchname =~ s/^\W/x-$&/;
5737 $patchname = substr($patchname,0,40);
5738 $patchname .= ".patch";
5740 if (!defined $patchdir) {
5743 if (length $patchdir) {
5744 $patchname = "$patchdir/$patchname";
5746 if ($patchname =~ m{^(.*)/}) {
5747 mkpath "debian/patches/$1";
5752 stat "debian/patches/$patchname$index";
5754 $!==ENOENT or confess "$patchname$index $!";
5756 runcmd @git, qw(checkout -q), $cc;
5758 # We use the tip's changelog so that dpkg-source doesn't
5759 # produce complaining messages from dpkg-parsechangelog. None
5760 # of the information dpkg-source gets from the changelog is
5761 # actually relevant - it gets put into the original message
5762 # which dpkg-source provides our stunt editor, and then
5764 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5766 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5767 "Date: $commitdate\n".
5768 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5770 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5774 sub build_maybe_quilt_fixup () {
5775 my ($format,$fopts) = get_source_format;
5776 return unless madformat_wantfixup $format;
5779 check_for_vendor_patches();
5781 my $clogp = parsechangelog();
5782 my $headref = git_rev_parse('HEAD');
5783 my $symref = git_get_symref();
5784 my $upstreamversion = upstreamversion $version;
5787 changedir $playground;
5789 my $splitbrain_cachekey;
5791 if (do_split_brain()) {
5793 ($cachehit, $splitbrain_cachekey) =
5794 quilt_check_splitbrain_cache($headref, $upstreamversion);
5801 unpack_playtree_need_cd_work($headref);
5802 if (do_split_brain()) {
5803 runcmd @git, qw(checkout -q -b dgit-view);
5804 # so long as work is not deleted, its current branch will
5805 # remain dgit-view, rather than master, so subsequent calls to
5806 # unpack_playtree_need_cd_work
5807 # will DTRT, resetting dgit-view.
5808 confess if $made_split_brain;
5809 $made_split_brain = 1;
5813 if ($fopts->{'single-debian-patch'}) {
5815 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5817 if quiltmode_splitting();
5818 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5820 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5821 $splitbrain_cachekey);
5824 if (do_split_brain()) {
5825 my $dgitview = git_rev_parse 'HEAD';
5828 reflog_cache_insert "refs/$splitbraincache",
5829 $splitbrain_cachekey, $dgitview;
5831 changedir "$playground/work";
5833 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5834 progress f_ "dgit view: created (%s)", $saved;
5838 runcmd_ordryrun_local
5839 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5842 sub build_check_quilt_splitbrain () {
5843 build_maybe_quilt_fixup();
5846 sub unpack_playtree_need_cd_work ($) {
5849 # prep_ud() must have been called already.
5850 if (!chdir "work") {
5851 # Check in the filesystem because sometimes we run prep_ud
5852 # in between multiple calls to unpack_playtree_need_cd_work.
5853 confess "$!" unless $!==ENOENT;
5854 mkdir "work" or confess "$!";
5856 mktree_in_ud_here();
5858 runcmd @git, qw(reset -q --hard), $headref;
5861 sub unpack_playtree_linkorigs ($$) {
5862 my ($upstreamversion, $fn) = @_;
5863 # calls $fn->($leafname);
5865 my $bpd_abs = bpd_abs();
5867 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5869 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5870 while ($!=0, defined(my $leaf = readdir QFD)) {
5871 my $f = bpd_abs()."/".$leaf;
5873 local ($debuglevel) = $debuglevel-1;
5874 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5876 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5877 printdebug "QF linkorigs $leaf, $f Y\n";
5878 link_ltarget $f, $leaf or die "$leaf $!";
5881 die "$buildproductsdir: $!" if $!;
5885 sub quilt_fixup_delete_pc () {
5886 runcmd @git, qw(rm -rqf .pc);
5887 commit_admin +(__ <<END).<<ENDU
5888 Commit removal of .pc (quilt series tracking data)
5891 [dgit ($our_version) upgrade quilt-remove-pc]
5895 sub quilt_fixup_singlepatch ($$$) {
5896 my ($clogp, $headref, $upstreamversion) = @_;
5898 progress __ "starting quiltify (single-debian-patch)";
5900 # dpkg-source --commit generates new patches even if
5901 # single-debian-patch is in debian/source/options. In order to
5902 # get it to generate debian/patches/debian-changes, it is
5903 # necessary to build the source package.
5905 unpack_playtree_linkorigs($upstreamversion, sub { });
5906 unpack_playtree_need_cd_work($headref);
5908 rmtree("debian/patches");
5910 runcmd @dpkgsource, qw(-b .);
5912 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5913 rename srcfn("$upstreamversion", "/debian/patches"),
5914 "work/debian/patches"
5916 or confess "install d/patches: $!";
5919 commit_quilty_patch();
5922 sub quilt_need_fake_dsc ($) {
5923 # cwd should be playground
5924 my ($upstreamversion) = @_;
5926 return if stat_exists "fake.dsc";
5927 # ^ OK to test this as a sentinel because if we created it
5928 # we must either have done the rest too, or crashed.
5930 my $fakeversion="$upstreamversion-~~DGITFAKE";
5932 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5933 print $fakedsc <<END or confess "$!";
5936 Version: $fakeversion
5940 my $dscaddfile=sub {
5943 my $md = new Digest::MD5;
5945 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5946 stat $fh or confess "$!";
5950 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5953 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5955 my @files=qw(debian/source/format debian/rules
5956 debian/control debian/changelog);
5957 foreach my $maybe (qw(debian/patches debian/source/options
5958 debian/tests/control)) {
5959 next unless stat_exists "$maindir/$maybe";
5960 push @files, $maybe;
5963 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5964 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5966 $dscaddfile->($debtar);
5967 close $fakedsc or confess "$!";
5970 sub quilt_fakedsc2unapplied ($$) {
5971 my ($headref, $upstreamversion) = @_;
5972 # must be run in the playground
5973 # quilt_need_fake_dsc must have been called
5975 quilt_need_fake_dsc($upstreamversion);
5977 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5979 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5980 rename $fakexdir, "fake" or die "$fakexdir $!";
5984 remove_stray_gits(__ "source package");
5985 mktree_in_ud_here();
5989 rmtree 'debian'; # git checkout commitish paths does not delete!
5990 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5991 my $unapplied=git_add_write_tree();
5992 printdebug "fake orig tree object $unapplied\n";
5996 sub quilt_check_splitbrain_cache ($$) {
5997 my ($headref, $upstreamversion) = @_;
5998 # Called only if we are in (potentially) split brain mode.
5999 # Called in playground.
6000 # Computes the cache key and looks in the cache.
6001 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
6003 quilt_need_fake_dsc($upstreamversion);
6005 my $splitbrain_cachekey;
6008 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6010 # we look in the reflog of dgit-intern/quilt-cache
6011 # we look for an entry whose message is the key for the cache lookup
6012 my @cachekey = (qw(dgit), $our_version);
6013 push @cachekey, $upstreamversion;
6014 push @cachekey, $quilt_mode;
6015 push @cachekey, $headref;
6016 push @cachekey, $quilt_upstream_commitish // '-';
6018 push @cachekey, hashfile('fake.dsc');
6020 my $srcshash = Digest::SHA->new(256);
6021 my %sfs = ( %INC, '$0(dgit)' => $0 );
6022 foreach my $sfk (sort keys %sfs) {
6023 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6024 $srcshash->add($sfk," ");
6025 $srcshash->add(hashfile($sfs{$sfk}));
6026 $srcshash->add("\n");
6028 push @cachekey, $srcshash->hexdigest();
6029 $splitbrain_cachekey = "@cachekey";
6031 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6033 my $cachehit = reflog_cache_lookup
6034 "refs/$splitbraincache", $splitbrain_cachekey;
6037 unpack_playtree_need_cd_work($headref);
6038 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6039 if ($cachehit ne $headref) {
6040 progress f_ "dgit view: found cached (%s)", $saved;
6041 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6042 $made_split_brain = 1;
6043 return ($cachehit, $splitbrain_cachekey);
6045 progress __ "dgit view: found cached, no changes required";
6046 return ($headref, $splitbrain_cachekey);
6049 printdebug "splitbrain cache miss\n";
6050 return (undef, $splitbrain_cachekey);
6053 sub quilt_fixup_multipatch ($$$) {
6054 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6056 progress f_ "examining quilt state (multiple patches, %s mode)",
6060 # - honour any existing .pc in case it has any strangeness
6061 # - determine the git commit corresponding to the tip of
6062 # the patch stack (if there is one)
6063 # - if there is such a git commit, convert each subsequent
6064 # git commit into a quilt patch with dpkg-source --commit
6065 # - otherwise convert all the differences in the tree into
6066 # a single git commit
6070 # Our git tree doesn't necessarily contain .pc. (Some versions of
6071 # dgit would include the .pc in the git tree.) If there isn't
6072 # one, we need to generate one by unpacking the patches that we
6075 # We first look for a .pc in the git tree. If there is one, we
6076 # will use it. (This is not the normal case.)
6078 # Otherwise need to regenerate .pc so that dpkg-source --commit
6079 # can work. We do this as follows:
6080 # 1. Collect all relevant .orig from parent directory
6081 # 2. Generate a debian.tar.gz out of
6082 # debian/{patches,rules,source/format,source/options}
6083 # 3. Generate a fake .dsc containing just these fields:
6084 # Format Source Version Files
6085 # 4. Extract the fake .dsc
6086 # Now the fake .dsc has a .pc directory.
6087 # (In fact we do this in every case, because in future we will
6088 # want to search for a good base commit for generating patches.)
6090 # Then we can actually do the dpkg-source --commit
6091 # 1. Make a new working tree with the same object
6092 # store as our main tree and check out the main
6094 # 2. Copy .pc from the fake's extraction, if necessary
6095 # 3. Run dpkg-source --commit
6096 # 4. If the result has changes to debian/, then
6097 # - git add them them
6098 # - git add .pc if we had a .pc in-tree
6100 # 5. If we had a .pc in-tree, delete it, and git commit
6101 # 6. Back in the main tree, fast forward to the new HEAD
6103 # Another situation we may have to cope with is gbp-style
6104 # patches-unapplied trees.
6106 # We would want to detect these, so we know to escape into
6107 # quilt_fixup_gbp. However, this is in general not possible.
6108 # Consider a package with a one patch which the dgit user reverts
6109 # (with git revert or the moral equivalent).
6111 # That is indistinguishable in contents from a patches-unapplied
6112 # tree. And looking at the history to distinguish them is not
6113 # useful because the user might have made a confusing-looking git
6114 # history structure (which ought to produce an error if dgit can't
6115 # cope, not a silent reintroduction of an unwanted patch).
6117 # So gbp users will have to pass an option. But we can usually
6118 # detect their failure to do so: if the tree is not a clean
6119 # patches-applied tree, quilt linearisation fails, but the tree
6120 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6121 # they want --quilt=unapplied.
6123 # To help detect this, when we are extracting the fake dsc, we
6124 # first extract it with --skip-patches, and then apply the patches
6125 # afterwards with dpkg-source --before-build. That lets us save a
6126 # tree object corresponding to .origs.
6128 if ($quilt_mode eq 'linear'
6129 && branch_is_gdr($headref)) {
6130 # This is much faster. It also makes patches that gdr
6131 # likes better for future updates without laundering.
6133 # However, it can fail in some casses where we would
6134 # succeed: if there are existing patches, which correspond
6135 # to a prefix of the branch, but are not in gbp/gdr
6136 # format, gdr will fail (exiting status 7), but we might
6137 # be able to figure out where to start linearising. That
6138 # will be slower so hopefully there's not much to do.
6140 unpack_playtree_need_cd_work $headref;
6142 my @cmd = (@git_debrebase,
6143 qw(--noop-ok -funclean-mixed -funclean-ordering
6144 make-patches --quiet-would-amend));
6145 # We tolerate soe snags that gdr wouldn't, by default.
6151 and not ($? == 7*256 or
6152 $? == -1 && $!==ENOENT);
6156 $headref = git_rev_parse('HEAD');
6161 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6165 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6167 if (system @bbcmd) {
6168 failedcmd @bbcmd if $? < 0;
6170 failed to apply your git tree's patch stack (from debian/patches/) to
6171 the corresponding upstream tarball(s). Your source tree and .orig
6172 are probably too inconsistent. dgit can only fix up certain kinds of
6173 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6179 unpack_playtree_need_cd_work($headref);
6182 if (stat_exists ".pc") {
6184 progress __ "Tree already contains .pc - will use it then delete it.";
6187 rename '../fake/.pc','.pc' or confess "$!";
6190 changedir '../fake';
6192 my $oldtiptree=git_add_write_tree();
6193 printdebug "fake o+d/p tree object $unapplied\n";
6194 changedir '../work';
6197 # We calculate some guesswork now about what kind of tree this might
6198 # be. This is mostly for error reporting.
6200 my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
6201 my $onlydebian = $tentries eq "debian\0";
6203 my $uheadref = $headref;
6204 my $uhead_whatshort = 'HEAD';
6206 if ($quilt_mode =~ m/baredebian/) {
6207 $uheadref = $quilt_upstream_commitish;
6208 # TRANSLATORS: this translation must fit in the ASCII art
6209 # quilt differences display. The untranslated display
6210 # says %9.9s, so with that display it must be at most 9
6212 $uhead_whatshort = __ 'upstream';
6219 # O = orig, without patches applied
6220 # A = "applied", ie orig with H's debian/patches applied
6221 O2H => quiltify_trees_differ($unapplied,$uheadref, 1,
6222 \%editedignores, \@unrepres),
6223 H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
6224 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6228 foreach my $bits (qw(01 02)) {
6229 foreach my $v (qw(O2H O2A H2A)) {
6230 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6233 printdebug "differences \@dl @dl.\n";
6236 "%s: base trees orig=%.20s o+d/p=%.20s",
6237 $us, $unapplied, $oldtiptree;
6238 # TRANSLATORS: Try to keep this ascii-art layout right. The 0s in
6239 # %9.00009s will be ignored and are there to make the format the
6240 # same length (9 characters) as the output it generates. If you
6241 # change the value 9, your translation of "upstream" must fit into
6242 # the new length, and you should change the number of 0s. Do
6243 # not reduce it below 4 as HEAD has to fit too.
6245 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6246 "%s: quilt differences: %9.00009s %s o+d/p %9.00009s %s o+d/p",
6247 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6248 $us, $uhead_whatshort, $dl[2], $uhead_whatshort, $dl[5];
6250 if (@unrepres && $quilt_mode !~ m/baredebian/) {
6251 # With baredebian, even if the upstream commitish has this
6252 # problem, we don't want to print this message, as nothing
6253 # is going to try to make a patch out of it anyway.
6254 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6257 forceable_fail [qw(unrepresentable)], __ <<END;
6258 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6264 push @failsuggestion, [ 'onlydebian', __
6265 "This has only a debian/ directory; you probably want --quilt=bare debian." ]
6266 unless $quilt_mode =~ m/baredebian/;
6267 } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
6268 push @failsuggestion, [ 'unapplied', __
6269 "This might be a patches-unapplied branch." ];
6270 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6271 push @failsuggestion, [ 'applied', __
6272 "This might be a patches-applied branch." ];
6274 push @failsuggestion, [ 'quilt-mode', __
6275 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6277 push @failsuggestion, [ 'gitattrs', __
6278 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6279 if stat_exists '.gitattributes';
6281 push @failsuggestion, [ 'origs', __
6282 "Maybe orig tarball(s) are not identical to git representation?" ]
6283 unless $onlydebian && $quilt_mode !~ m/baredebian/;
6284 # ^ in that case, we didn't really look properly
6286 if (quiltmode_splitting()) {
6287 quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6288 $diffbits, \%editedignores,
6289 $splitbrain_cachekey);
6293 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6294 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6295 runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6297 if (!open P, '>>', ".pc/applied-patches") {
6298 $!==&ENOENT or confess "$!";
6303 commit_quilty_patch();
6305 if ($mustdeletepc) {
6306 quilt_fixup_delete_pc();
6310 sub quilt_fixup_editor () {
6311 my $descfn = $ENV{$fakeeditorenv};
6312 my $editing = $ARGV[$#ARGV];
6313 open I1, '<', $descfn or confess "$descfn: $!";
6314 open I2, '<', $editing or confess "$editing: $!";
6315 unlink $editing or confess "$editing: $!";
6316 open O, '>', $editing or confess "$editing: $!";
6317 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6320 $copying ||= m/^\-\-\- /;
6321 next unless $copying;
6322 print O or confess "$!";
6324 I2->error and confess "$!";
6329 sub maybe_apply_patches_dirtily () {
6330 return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
6331 print STDERR __ <<END or confess "$!";
6333 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6334 dgit: Have to apply the patches - making the tree dirty.
6335 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6338 $patches_applied_dirtily = 01;
6339 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6340 runcmd qw(dpkg-source --before-build .);
6343 sub maybe_unapply_patches_again () {
6344 progress __ "dgit: Unapplying patches again to tidy up the tree."
6345 if $patches_applied_dirtily;
6346 runcmd qw(dpkg-source --after-build .)
6347 if $patches_applied_dirtily & 01;
6349 if $patches_applied_dirtily & 02;
6350 $patches_applied_dirtily = 0;
6353 #----- other building -----
6355 sub clean_tree_check_git ($$$) {
6356 my ($honour_ignores, $message, $ignmessage) = @_;
6357 my @cmd = (@git, qw(clean -dn));
6358 push @cmd, qw(-x) unless $honour_ignores;
6359 my $leftovers = cmdoutput @cmd;
6360 if (length $leftovers) {
6361 print STDERR $leftovers, "\n" or confess "$!";
6362 $message .= $ignmessage if $honour_ignores;
6367 sub clean_tree_check_git_wd ($) {
6369 return if $cleanmode =~ m{no-check};
6370 return if $patches_applied_dirtily; # yuk
6371 clean_tree_check_git +($cleanmode !~ m{all-check}),
6372 $message, "\n".__ <<END;
6373 If this is just missing .gitignore entries, use a different clean
6374 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6375 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6379 sub clean_tree_check () {
6380 # This function needs to not care about modified but tracked files.
6381 # That was done by check_not_dirty, and by now we may have run
6382 # the rules clean target which might modify tracked files (!)
6383 if ($cleanmode =~ m{^check}) {
6384 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6385 "tree contains uncommitted files and --clean=check specified", '';
6386 } elsif ($cleanmode =~ m{^dpkg-source}) {
6387 clean_tree_check_git_wd __
6388 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6389 } elsif ($cleanmode =~ m{^git}) {
6390 clean_tree_check_git 1, __
6391 "tree contains uncommited, untracked, unignored files\n".
6392 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6393 } elsif ($cleanmode eq 'none') {
6395 confess "$cleanmode ?";
6400 # We always clean the tree ourselves, rather than leave it to the
6401 # builder (dpkg-source, or soemthing which calls dpkg-source).
6402 if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
6403 fail f_ <<END, $quilt_mode, $cleanmode;
6404 quilt mode %s (generally needs untracked upstream files)
6405 contradicts clean mode %s (which would delete them)
6407 # This is not 100% true: dgit build-source and push-source
6408 # (for example) could operate just fine with no upstream
6409 # source in the working tree. But it doesn't seem likely that
6410 # the user wants dgit to proactively delete such things.
6411 # -wn, for example, would produce identical output without
6412 # deleting anything from the working tree.
6414 if ($cleanmode =~ m{^dpkg-source}) {
6415 my @cmd = @dpkgbuildpackage;
6416 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6417 push @cmd, qw(-T clean);
6418 maybe_apply_patches_dirtily();
6419 runcmd_ordryrun_local @cmd;
6420 clean_tree_check_git_wd __
6421 "tree contains uncommitted files (after running rules clean)";
6422 } elsif ($cleanmode =~ m{^git(?!-)}) {
6423 runcmd_ordryrun_local @git, qw(clean -xdf);
6424 } elsif ($cleanmode =~ m{^git-ff}) {
6425 runcmd_ordryrun_local @git, qw(clean -xdff);
6426 } elsif ($cleanmode =~ m{^check}) {
6428 } elsif ($cleanmode eq 'none') {
6430 confess "$cleanmode ?";
6435 badusage __ "clean takes no additional arguments" if @ARGV;
6438 maybe_unapply_patches_again();
6441 # return values from massage_dbp_args are one or both of these flags
6442 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6443 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6445 sub build_or_push_prep_early () {
6446 our $build_or_push_prep_early_done //= 0;
6447 return if $build_or_push_prep_early_done++;
6448 badusage f_ "-p is not allowed with dgit %s", $subcommand
6449 if defined $package;
6450 my $clogp = parsechangelog();
6451 $isuite = getfield $clogp, 'Distribution';
6452 $package = getfield $clogp, 'Source';
6453 $version = getfield $clogp, 'Version';
6454 $dscfn = dscfn($version);
6457 sub build_or_push_prep_modes () {
6458 my ($format,) = determine_whether_split_brain();
6460 fail __ "dgit: --include-dirty is not supported with split view".
6461 " (including with view-splitting quilt modes)"
6462 if do_split_brain() && $includedirty;
6464 if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
6465 ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
6466 $quilt_upstream_commitish_message)
6467 = resolve_upstream_version
6468 $quilt_upstream_commitish, upstreamversion $version;
6469 progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
6470 $quilt_upstream_commitish_message;
6471 } elsif (defined $quilt_upstream_commitish) {
6473 "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
6477 sub build_prep_early () {
6478 build_or_push_prep_early();
6480 build_or_push_prep_modes();
6484 sub build_prep ($) {
6488 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6489 # Clean the tree because we're going to use the contents of
6490 # $maindir. (We trying to include dirty changes in the source
6491 # package, or we are running the builder in $maindir.)
6492 || $cleanmode =~ m{always}) {
6493 # Or because the user asked us to.
6496 # We don't actually need to do anything in $maindir, but we
6497 # should do some kind of cleanliness check because (i) the
6498 # user may have forgotten a `git add', and (ii) if the user
6499 # said -wc we should still do the check.
6502 build_check_quilt_splitbrain();
6504 my $pat = changespat $version;
6505 foreach my $f (glob "$buildproductsdir/$pat") {
6508 fail f_ "remove old changes file %s: %s", $f, $!;
6510 progress f_ "would remove %s", $f;
6516 sub changesopts_initial () {
6517 my @opts =@changesopts[1..$#changesopts];
6520 sub changesopts_version () {
6521 if (!defined $changes_since_version) {
6524 @vsns = archive_query('archive_query');
6525 my @quirk = access_quirk();
6526 if ($quirk[0] eq 'backports') {
6527 local $isuite = $quirk[2];
6529 canonicalise_suite();
6530 push @vsns, archive_query('archive_query');
6536 "archive query failed (queried because --since-version not specified)";
6539 @vsns = map { $_->[0] } @vsns;
6540 @vsns = sort { -version_compare($a, $b) } @vsns;
6541 $changes_since_version = $vsns[0];
6542 progress f_ "changelog will contain changes since %s", $vsns[0];
6544 $changes_since_version = '_';
6545 progress __ "package seems new, not specifying -v<version>";
6548 if ($changes_since_version ne '_') {
6549 return ("-v$changes_since_version");
6555 sub changesopts () {
6556 return (changesopts_initial(), changesopts_version());
6559 sub massage_dbp_args ($;$) {
6560 my ($cmd,$xargs) = @_;
6561 # Since we split the source build out so we can do strange things
6562 # to it, massage the arguments to dpkg-buildpackage so that the
6563 # main build doessn't build source (or add an argument to stop it
6564 # building source by default).
6565 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6566 # -nc has the side effect of specifying -b if nothing else specified
6567 # and some combinations of -S, -b, et al, are errors, rather than
6568 # later simply overriding earlie. So we need to:
6569 # - search the command line for these options
6570 # - pick the last one
6571 # - perhaps add our own as a default
6572 # - perhaps adjust it to the corresponding non-source-building version
6574 foreach my $l ($cmd, $xargs) {
6576 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6579 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6580 my $r = WANTSRC_BUILDER;
6581 printdebug "massage split $dmode.\n";
6582 if ($dmode =~ s/^--build=//) {
6584 my @d = split /,/, $dmode;
6585 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6586 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6587 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6588 fail __ "Wanted to build nothing!" unless $r;
6589 $dmode = '--build='. join ',', grep m/./, @d;
6592 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6593 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6594 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6597 printdebug "massage done $r $dmode.\n";
6599 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6605 my $wasdir = must_getcwd();
6606 changedir $buildproductsdir;
6611 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6612 sub postbuild_mergechanges ($) {
6613 my ($msg_if_onlyone) = @_;
6614 # If there is only one .changes file, fail with $msg_if_onlyone,
6615 # or if that is undef, be a no-op.
6616 # Returns the changes file to report to the user.
6617 my $pat = changespat $version;
6618 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6619 @changesfiles = sort {
6620 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6624 if (@changesfiles==1) {
6625 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6626 only one changes file from build (%s)
6628 if defined $msg_if_onlyone;
6629 $result = $changesfiles[0];
6630 } elsif (@changesfiles==2) {
6631 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6632 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6633 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6636 runcmd_ordryrun_local @mergechanges, @changesfiles;
6637 my $multichanges = changespat $version,'multi';
6639 stat_exists $multichanges or fail f_
6640 "%s unexpectedly not created by build", $multichanges;
6641 foreach my $cf (glob $pat) {
6642 next if $cf eq $multichanges;
6643 rename "$cf", "$cf.inmulti" or fail f_
6644 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6647 $result = $multichanges;
6649 fail f_ "wrong number of different changes files (%s)",
6652 printdone f_ "build successful, results in %s\n", $result
6656 sub midbuild_checkchanges () {
6657 my $pat = changespat $version;
6658 return if $rmchanges;
6659 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6661 $_ ne changespat $version,'source' and
6662 $_ ne changespat $version,'multi'
6664 fail +(f_ <<END, $pat, "@unwanted")
6665 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6666 Suggest you delete %s.
6671 sub midbuild_checkchanges_vanilla ($) {
6673 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6676 sub postbuild_mergechanges_vanilla ($) {
6678 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6680 postbuild_mergechanges(undef);
6683 printdone __ "build successful\n";
6689 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6690 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6691 %s: warning: build-products-dir will be ignored; files will go to ..
6693 $buildproductsdir = '..';
6694 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6695 my $wantsrc = massage_dbp_args \@dbp;
6696 build_prep($wantsrc);
6697 if ($wantsrc & WANTSRC_SOURCE) {
6699 midbuild_checkchanges_vanilla $wantsrc;
6701 if ($wantsrc & WANTSRC_BUILDER) {
6702 push @dbp, changesopts_version();
6703 maybe_apply_patches_dirtily();
6704 runcmd_ordryrun_local @dbp;
6706 maybe_unapply_patches_again();
6707 postbuild_mergechanges_vanilla $wantsrc;
6711 $quilt_mode //= 'gbp';
6717 # gbp can make .origs out of thin air. In my tests it does this
6718 # even for a 1.0 format package, with no origs present. So I
6719 # guess it keys off just the version number. We don't know
6720 # exactly what .origs ought to exist, but let's assume that we
6721 # should run gbp if: the version has an upstream part and the main
6723 my $upstreamversion = upstreamversion $version;
6724 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6725 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6727 if ($gbp_make_orig) {
6729 $cleanmode = 'none'; # don't do it again
6732 my @dbp = @dpkgbuildpackage;
6734 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6736 if (!length $gbp_build[0]) {
6737 if (length executable_on_path('git-buildpackage')) {
6738 $gbp_build[0] = qw(git-buildpackage);
6740 $gbp_build[0] = 'gbp buildpackage';
6743 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6745 push @cmd, (qw(-us -uc --git-no-sign-tags),
6746 "--git-builder=".(shellquote @dbp));
6748 if ($gbp_make_orig) {
6749 my $priv = dgit_privdir();
6750 my $ok = "$priv/origs-gen-ok";
6751 unlink $ok or $!==&ENOENT or confess "$!";
6752 my @origs_cmd = @cmd;
6753 push @origs_cmd, qw(--git-cleaner=true);
6754 push @origs_cmd, "--git-prebuild=".
6755 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6756 push @origs_cmd, @ARGV;
6758 debugcmd @origs_cmd;
6760 do { local $!; stat_exists $ok; }
6761 or failedcmd @origs_cmd;
6763 dryrun_report @origs_cmd;
6767 build_prep($wantsrc);
6768 if ($wantsrc & WANTSRC_SOURCE) {
6770 midbuild_checkchanges_vanilla $wantsrc;
6772 push @cmd, '--git-cleaner=true';
6774 maybe_unapply_patches_again();
6775 if ($wantsrc & WANTSRC_BUILDER) {
6776 push @cmd, changesopts();
6777 runcmd_ordryrun_local @cmd, @ARGV;
6779 postbuild_mergechanges_vanilla $wantsrc;
6781 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6783 sub building_source_in_playtree {
6784 # If $includedirty, we have to build the source package from the
6785 # working tree, not a playtree, so that uncommitted changes are
6786 # included (copying or hardlinking them into the playtree could
6789 # Note that if we are building a source package in split brain
6790 # mode we do not support including uncommitted changes, because
6791 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6792 # building a source package)) => !$includedirty
6793 return !$includedirty;
6797 $sourcechanges = changespat $version,'source';
6799 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6800 or fail f_ "remove %s: %s", $sourcechanges, $!;
6802 # confess unless !!$made_split_brain == do_split_brain();
6804 my @cmd = (@dpkgsource, qw(-b --));
6806 if (building_source_in_playtree()) {
6808 my $headref = git_rev_parse('HEAD');
6809 # If we are in split brain, there is already a playtree with
6810 # the thing we should package into a .dsc (thanks to quilt
6811 # fixup). If not, make a playtree
6812 prep_ud() unless $made_split_brain;
6813 changedir $playground;
6814 unless ($made_split_brain) {
6815 my $upstreamversion = upstreamversion $version;
6816 unpack_playtree_linkorigs($upstreamversion, sub { });
6817 unpack_playtree_need_cd_work($headref);
6821 $leafdir = basename $maindir;
6823 if ($buildproductsdir ne '..') {
6824 # Well, we are going to run dpkg-source -b which consumes
6825 # origs from .. and generates output there. To make this
6826 # work when the bpd is not .. , we would have to (i) link
6827 # origs from bpd to .. , (ii) check for files that
6828 # dpkg-source -b would/might overwrite, and afterwards
6829 # (iii) move all the outputs back to the bpd (iv) except
6830 # for the origs which should be deleted from .. if they
6831 # weren't there beforehand. And if there is an error and
6832 # we don't run to completion we would necessarily leave a
6833 # mess. This is too much. The real way to fix this
6834 # is for dpkg-source to have bpd support.
6835 confess unless $includedirty;
6837 "--include-dirty not supported with --build-products-dir, sorry";
6842 runcmd_ordryrun_local @cmd, $leafdir;
6845 runcmd_ordryrun_local qw(sh -ec),
6846 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6847 @dpkggenchanges, qw(-S), changesopts();
6850 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6851 $dsc = parsecontrol($dscfn, "source package");
6855 printdebug " renaming ($why) $l\n";
6856 rename_link_xf 0, "$l", bpd_abs()."/$l"
6857 or fail f_ "put in place new built file (%s): %s", $l, $@;
6859 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6860 $l =~ m/\S+$/ or next;
6863 $mv->('dsc', $dscfn);
6864 $mv->('changes', $sourcechanges);
6869 sub cmd_build_source {
6870 badusage __ "build-source takes no additional arguments" if @ARGV;
6871 build_prep(WANTSRC_SOURCE);
6873 maybe_unapply_patches_again();
6874 printdone f_ "source built, results in %s and %s",
6875 $dscfn, $sourcechanges;
6878 sub cmd_push_source {
6881 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6882 "sense with push-source!"
6884 build_check_quilt_splitbrain();
6886 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6887 __ "source changes file");
6888 unless (test_source_only_changes($changes)) {
6889 fail __ "user-specified changes file is not source-only";
6892 # Building a source package is very fast, so just do it
6894 confess "er, patches are applied dirtily but shouldn't be.."
6895 if $patches_applied_dirtily;
6896 $changesfile = $sourcechanges;
6901 sub binary_builder {
6902 my ($bbuilder, $pbmc_msg, @args) = @_;
6903 build_prep(WANTSRC_SOURCE);
6905 midbuild_checkchanges();
6908 stat_exists $dscfn or fail f_
6909 "%s (in build products dir): %s", $dscfn, $!;
6910 stat_exists $sourcechanges or fail f_
6911 "%s (in build products dir): %s", $sourcechanges, $!;
6913 runcmd_ordryrun_local @$bbuilder, @args;
6915 maybe_unapply_patches_again();
6917 postbuild_mergechanges($pbmc_msg);
6923 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6924 perhaps you need to pass -A ? (sbuild's default is to build only
6925 arch-specific binaries; dgit 1.4 used to override that.)
6930 my ($pbuilder) = @_;
6932 # @ARGV is allowed to contain only things that should be passed to
6933 # pbuilder under debbuildopts; just massage those
6934 my $wantsrc = massage_dbp_args \@ARGV;
6936 "you asked for a builder but your debbuildopts didn't ask for".
6937 " any binaries -- is this really what you meant?"
6938 unless $wantsrc & WANTSRC_BUILDER;
6940 "we must build a .dsc to pass to the builder but your debbuiltopts".
6941 " forbids the building of a source package; cannot continue"
6942 unless $wantsrc & WANTSRC_SOURCE;
6943 # We do not want to include the verb "build" in @pbuilder because
6944 # the user can customise @pbuilder and they shouldn't be required
6945 # to include "build" in their customised value. However, if the
6946 # user passes any additional args to pbuilder using the dgit
6947 # option --pbuilder:foo, such args need to come after the "build"
6948 # verb. opts_opt_multi_cmd does all of that.
6949 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6950 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6955 pbuilder(\@pbuilder);
6958 sub cmd_cowbuilder {
6959 pbuilder(\@cowbuilder);
6962 sub cmd_quilt_fixup {
6963 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6966 build_maybe_quilt_fixup();
6969 sub cmd_print_unapplied_treeish {
6970 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6972 my $headref = git_rev_parse('HEAD');
6973 my $clogp = commit_getclogp $headref;
6974 $package = getfield $clogp, 'Source';
6975 $version = getfield $clogp, 'Version';
6976 $isuite = getfield $clogp, 'Distribution';
6977 $csuite = $isuite; # we want this to be offline!
6981 changedir $playground;
6982 my $uv = upstreamversion $version;
6983 my $u = quilt_fakedsc2unapplied($headref, $uv);
6984 print $u, "\n" or confess "$!";
6987 sub import_dsc_result {
6988 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6989 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6991 check_gitattrs($newhash, __ "source tree");
6993 progress f_ "dgit: import-dsc: %s", $what_msg;
6996 sub cmd_import_dsc {
7000 last unless $ARGV[0] =~ m/^-/;
7003 if (m/^--require-valid-signature$/) {
7006 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
7010 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
7012 my ($dscfn, $dstbranch) = @ARGV;
7014 badusage __ "dry run makes no sense with import-dsc"
7017 my $force = $dstbranch =~ s/^\+// ? +1 :
7018 $dstbranch =~ s/^\.\.// ? -1 :
7020 my $info = $force ? " $&" : '';
7021 $info = "$dscfn$info";
7023 my $specbranch = $dstbranch;
7024 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
7025 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
7027 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
7028 my $chead = cmdoutput_errok @symcmd;
7029 defined $chead or $?==256 or failedcmd @symcmd;
7031 fail f_ "%s is checked out - will not update it", $dstbranch
7032 if defined $chead and $chead eq $dstbranch;
7034 my $oldhash = git_get_ref $dstbranch;
7036 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
7037 $dscdata = do { local $/ = undef; <D>; };
7038 D->error and fail f_ "read %s: %s", $dscfn, $!;
7041 # we don't normally need this so import it here
7042 use Dpkg::Source::Package;
7043 my $dp = new Dpkg::Source::Package filename => $dscfn,
7044 require_valid_signature => $needsig;
7046 local $SIG{__WARN__} = sub {
7048 return unless $needsig;
7049 fail __ "import-dsc signature check failed";
7051 if (!$dp->is_signed()) {
7052 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
7054 my $r = $dp->check_signature();
7055 confess "->check_signature => $r" if $needsig && $r;
7061 $package = getfield $dsc, 'Source';
7063 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
7064 unless forceing [qw(import-dsc-with-dgit-field)];
7065 parse_dsc_field_def_dsc_distro();
7067 $isuite = 'DGIT-IMPORT-DSC';
7068 $idistro //= $dsc_distro;
7072 if (defined $dsc_hash) {
7074 "dgit: import-dsc of .dsc with Dgit field, using git hash";
7075 resolve_dsc_field_commit undef, undef;
7077 if (defined $dsc_hash) {
7078 my @cmd = (qw(sh -ec),
7079 "echo $dsc_hash | git cat-file --batch-check");
7080 my $objgot = cmdoutput @cmd;
7081 if ($objgot =~ m#^\w+ missing\b#) {
7082 fail f_ <<END, $dsc_hash
7083 .dsc contains Dgit field referring to object %s
7084 Your git tree does not have that object. Try `git fetch' from a
7085 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7088 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7090 progress __ "Not fast forward, forced update.";
7092 fail f_ "Not fast forward to %s", $dsc_hash;
7095 import_dsc_result $dstbranch, $dsc_hash,
7096 "dgit import-dsc (Dgit): $info",
7097 f_ "updated git ref %s", $dstbranch;
7101 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7102 Branch %s already exists
7103 Specify ..%s for a pseudo-merge, binding in existing history
7104 Specify +%s to overwrite, discarding existing history
7106 if $oldhash && !$force;
7108 my @dfi = dsc_files_info();
7109 foreach my $fi (@dfi) {
7110 my $f = $fi->{Filename};
7111 # We transfer all the pieces of the dsc to the bpd, not just
7112 # origs. This is by analogy with dgit fetch, which wants to
7113 # keep them somewhere to avoid downloading them again.
7114 # We make symlinks, though. If the user wants copies, then
7115 # they can copy the parts of the dsc to the bpd using dcmd,
7117 my $here = "$buildproductsdir/$f";
7122 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7124 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7125 printdebug "not in bpd, $f ...\n";
7126 # $f does not exist in bpd, we need to transfer it
7128 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7129 # $there is file we want, relative to user's cwd, or abs
7130 printdebug "not in bpd, $f, test $there ...\n";
7131 stat $there or fail f_
7132 "import %s requires %s, but: %s", $dscfn, $there, $!;
7133 if ($there =~ m#^(?:\./+)?\.\./+#) {
7134 # $there is relative to user's cwd
7135 my $there_from_parent = $';
7136 if ($buildproductsdir !~ m{^/}) {
7137 # abs2rel, despite its name, can take two relative paths
7138 $there = File::Spec->abs2rel($there,$buildproductsdir);
7139 # now $there is relative to bpd, great
7140 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7142 $there = (dirname $maindir)."/$there_from_parent";
7143 # now $there is absoute
7144 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7146 } elsif ($there =~ m#^/#) {
7147 # $there is absolute already
7148 printdebug "not in bpd, $f, abs, $there ...\n";
7151 "cannot import %s which seems to be inside working tree!",
7154 symlink $there, $here or fail f_
7155 "symlink %s to %s: %s", $there, $here, $!;
7156 progress f_ "made symlink %s -> %s", $here, $there;
7157 # print STDERR Dumper($fi);
7159 my @mergeinputs = generate_commits_from_dsc();
7160 die unless @mergeinputs == 1;
7162 my $newhash = $mergeinputs[0]{Commit};
7167 "Import, forced update - synthetic orphan git history.";
7168 } elsif ($force < 0) {
7169 progress __ "Import, merging.";
7170 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7171 my $version = getfield $dsc, 'Version';
7172 my $clogp = commit_getclogp $newhash;
7173 my $authline = clogp_authline $clogp;
7174 $newhash = hash_commit_text <<ENDU
7182 .(f_ <<END, $package, $version, $dstbranch);
7183 Merge %s (%s) import into %s
7186 die; # caught earlier
7190 import_dsc_result $dstbranch, $newhash,
7191 "dgit import-dsc: $info",
7192 f_ "results are in git ref %s", $dstbranch;
7195 sub pre_archive_api_query () {
7196 not_necessarily_a_tree();
7198 sub cmd_archive_api_query {
7199 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7200 my ($subpath) = @ARGV;
7201 local $isuite = 'DGIT-API-QUERY-CMD';
7202 my @cmd = archive_api_query_cmd($subpath);
7205 exec @cmd or fail f_ "exec curl: %s\n", $!;
7208 sub repos_server_url () {
7209 $package = '_dgit-repos-server';
7210 local $access_forpush = 1;
7211 local $isuite = 'DGIT-REPOS-SERVER';
7212 my $url = access_giturl();
7215 sub pre_clone_dgit_repos_server () {
7216 not_necessarily_a_tree();
7218 sub cmd_clone_dgit_repos_server {
7219 badusage __ "need destination argument" unless @ARGV==1;
7220 my ($destdir) = @ARGV;
7221 my $url = repos_server_url();
7222 my @cmd = (@git, qw(clone), $url, $destdir);
7224 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7227 sub pre_print_dgit_repos_server_source_url () {
7228 not_necessarily_a_tree();
7230 sub cmd_print_dgit_repos_server_source_url {
7232 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7234 my $url = repos_server_url();
7235 print $url, "\n" or confess "$!";
7238 sub pre_print_dpkg_source_ignores {
7239 not_necessarily_a_tree();
7241 sub cmd_print_dpkg_source_ignores {
7243 "no arguments allowed to dgit print-dpkg-source-ignores"
7245 print "@dpkg_source_ignores\n" or confess "$!";
7248 sub cmd_setup_mergechangelogs {
7249 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7251 local $isuite = 'DGIT-SETUP-TREE';
7252 setup_mergechangelogs(1);
7255 sub cmd_setup_useremail {
7256 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7257 local $isuite = 'DGIT-SETUP-TREE';
7261 sub cmd_setup_gitattributes {
7262 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7263 local $isuite = 'DGIT-SETUP-TREE';
7267 sub cmd_setup_new_tree {
7268 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7269 local $isuite = 'DGIT-SETUP-TREE';
7273 #---------- argument parsing and main program ----------
7276 print "dgit version $our_version\n" or confess "$!";
7280 our (%valopts_long, %valopts_short);
7281 our (%funcopts_long);
7283 our (@modeopt_cfgs);
7285 sub defvalopt ($$$$) {
7286 my ($long,$short,$val_re,$how) = @_;
7287 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7288 $valopts_long{$long} = $oi;
7289 $valopts_short{$short} = $oi;
7290 # $how subref should:
7291 # do whatever assignemnt or thing it likes with $_[0]
7292 # if the option should not be passed on to remote, @rvalopts=()
7293 # or $how can be a scalar ref, meaning simply assign the value
7296 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7297 defvalopt '--distro', '-d', '.+', \$idistro;
7298 defvalopt '', '-k', '.+', \$keyid;
7299 defvalopt '--existing-package','', '.*', \$existing_package;
7300 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7301 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7302 defvalopt '--package', '-p', $package_re, \$package;
7303 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7305 defvalopt '', '-C', '.+', sub {
7306 ($changesfile) = (@_);
7307 if ($changesfile =~ s#^(.*)/##) {
7308 $buildproductsdir = $1;
7312 defvalopt '--initiator-tempdir','','.*', sub {
7313 ($initiator_tempdir) = (@_);
7314 $initiator_tempdir =~ m#^/# or
7315 badusage __ "--initiator-tempdir must be used specify an".
7316 " absolute, not relative, directory."
7319 sub defoptmodes ($@) {
7320 my ($varref, $cfgkey, $default, %optmap) = @_;
7322 while (my ($opt,$val) = each %optmap) {
7323 $funcopts_long{$opt} = sub { $$varref = $val; };
7324 $permit{$val} = $val;
7326 push @modeopt_cfgs, {
7329 Default => $default,
7334 defoptmodes \$dodep14tag, qw( dep14tag want
7337 --always-dep14tag always );
7342 if (defined $ENV{'DGIT_SSH'}) {
7343 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7344 } elsif (defined $ENV{'GIT_SSH'}) {
7345 @ssh = ($ENV{'GIT_SSH'});
7353 if (!defined $val) {
7354 badusage f_ "%s needs a value", $what unless @ARGV;
7356 push @rvalopts, $val;
7358 badusage f_ "bad value \`%s' for %s", $val, $what unless
7359 $val =~ m/^$oi->{Re}$(?!\n)/s;
7360 my $how = $oi->{How};
7361 if (ref($how) eq 'SCALAR') {
7366 push @ropts, @rvalopts;
7370 last unless $ARGV[0] =~ m/^-/;
7374 if (m/^--dry-run$/) {
7377 } elsif (m/^--damp-run$/) {
7380 } elsif (m/^--no-sign$/) {
7383 } elsif (m/^--help$/) {
7385 } elsif (m/^--version$/) {
7387 } elsif (m/^--new$/) {
7390 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7391 ($om = $opts_opt_map{$1}) &&
7395 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7396 !$opts_opt_cmdonly{$1} &&
7397 ($om = $opts_opt_map{$1})) {
7400 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7401 !$opts_opt_cmdonly{$1} &&
7402 ($om = $opts_opt_map{$1})) {
7404 my $cmd = shift @$om;
7405 @$om = ($cmd, grep { $_ ne $2 } @$om);
7406 } elsif (m/^--($quilt_options_re)$/s) {
7407 push @ropts, "--quilt=$1";
7409 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7412 } elsif (m/^--no-quilt-fixup$/s) {
7414 $quilt_mode = 'nocheck';
7415 } elsif (m/^--no-rm-on-error$/s) {
7418 } elsif (m/^--no-chase-dsc-distro$/s) {
7420 $chase_dsc_distro = 0;
7421 } elsif (m/^--overwrite$/s) {
7423 $overwrite_version = '';
7424 } elsif (m/^--split-(?:view|brain)$/s) {
7426 $splitview_mode = 'always';
7427 } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7429 $splitview_mode = $1;
7430 } elsif (m/^--overwrite=(.+)$/s) {
7432 $overwrite_version = $1;
7433 } elsif (m/^--delayed=(\d+)$/s) {
7436 } elsif (m/^--upstream-commitish=(.+)$/s) {
7438 $quilt_upstream_commitish = $1;
7439 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7440 m/^--(dgit-view)-save=(.+)$/s
7442 my ($k,$v) = ($1,$2);
7444 $v =~ s#^(?!refs/)#refs/heads/#;
7445 $internal_object_save{$k} = $v;
7446 } elsif (m/^--(no-)?rm-old-changes$/s) {
7449 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7451 push @deliberatelies, $&;
7452 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7456 } elsif (m/^--force-/) {
7458 f_ "%s: warning: ignoring unknown force option %s\n",
7461 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7462 # undocumented, for testing
7464 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7465 # ^ it's supposed to be an array ref
7466 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7467 $val = $2 ? $' : undef; #';
7468 $valopt->($oi->{Long});
7469 } elsif ($funcopts_long{$_}) {
7471 $funcopts_long{$_}();
7473 badusage f_ "unknown long option \`%s'", $_;
7480 } elsif (s/^-L/-/) {
7483 } elsif (s/^-h/-/) {
7485 } elsif (s/^-D/-/) {
7489 } elsif (s/^-N/-/) {
7494 push @changesopts, $_;
7496 } elsif (s/^-wn$//s) {
7498 $cleanmode = 'none';
7499 } elsif (s/^-wg(f?)(a?)$//s) {
7502 $cleanmode .= '-ff' if $1;
7503 $cleanmode .= ',always' if $2;
7504 } elsif (s/^-wd(d?)([na]?)$//s) {
7506 $cleanmode = 'dpkg-source';
7507 $cleanmode .= '-d' if $1;
7508 $cleanmode .= ',no-check' if $2 eq 'n';
7509 $cleanmode .= ',all-check' if $2 eq 'a';
7510 } elsif (s/^-wc$//s) {
7512 $cleanmode = 'check';
7513 } elsif (s/^-wci$//s) {
7515 $cleanmode = 'check,ignores';
7516 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7517 push @git, '-c', $&;
7518 $gitcfgs{cmdline}{$1} = [ $2 ];
7519 } elsif (s/^-c([^=]+)$//s) {
7520 push @git, '-c', $&;
7521 $gitcfgs{cmdline}{$1} = [ 'true' ];
7522 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7524 $val = undef unless length $val;
7525 $valopt->($oi->{Short});
7528 badusage f_ "unknown short option \`%s'", $_;
7535 sub check_env_sanity () {
7536 my $blocked = new POSIX::SigSet;
7537 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7540 foreach my $name (qw(PIPE CHLD)) {
7541 my $signame = "SIG$name";
7542 my $signum = eval "POSIX::$signame" // die;
7543 die f_ "%s is set to something other than SIG_DFL\n",
7545 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7546 $blocked->ismember($signum) and
7547 die f_ "%s is blocked\n", $signame;
7553 On entry to dgit, %s
7554 This is a bug produced by something in your execution environment.
7560 sub parseopts_late_defaults () {
7561 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7562 if defined $idistro;
7563 $isuite //= cfg('dgit.default.default-suite');
7565 foreach my $k (keys %opts_opt_map) {
7566 my $om = $opts_opt_map{$k};
7568 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7570 badcfg f_ "cannot set command for %s", $k
7571 unless length $om->[0];
7575 foreach my $c (access_cfg_cfgs("opts-$k")) {
7577 map { $_ ? @$_ : () }
7578 map { $gitcfgs{$_}{$c} }
7579 reverse @gitcfgsources;
7580 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7581 "\n" if $debuglevel >= 4;
7583 badcfg f_ "cannot configure options for %s", $k
7584 if $opts_opt_cmdonly{$k};
7585 my $insertpos = $opts_cfg_insertpos{$k};
7586 @$om = ( @$om[0..$insertpos-1],
7588 @$om[$insertpos..$#$om] );
7592 if (!defined $rmchanges) {
7593 local $access_forpush;
7594 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7597 if (!defined $quilt_mode) {
7598 local $access_forpush;
7599 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7600 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7602 $quilt_mode =~ m/^($quilt_modes_re)$/
7603 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7607 foreach my $moc (@modeopt_cfgs) {
7608 local $access_forpush;
7609 my $vr = $moc->{Var};
7610 next if defined $$vr;
7611 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7612 my $v = $moc->{Vals}{$$vr};
7613 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7619 local $access_forpush;
7620 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7624 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7625 $buildproductsdir //= '..';
7626 $bpd_glob = $buildproductsdir;
7627 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7630 setlocale(LC_MESSAGES, "");
7633 if ($ENV{$fakeeditorenv}) {
7635 quilt_fixup_editor();
7641 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7642 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7643 if $dryrun_level == 1;
7645 print STDERR __ $helpmsg or confess "$!";
7648 $cmd = $subcommand = shift @ARGV;
7651 my $pre_fn = ${*::}{"pre_$cmd"};
7652 $pre_fn->() if $pre_fn;
7654 if ($invoked_in_git_tree) {
7655 changedir_git_toplevel();
7660 my $fn = ${*::}{"cmd_$cmd"};
7661 $fn or badusage f_ "unknown operation %s", $cmd;