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 3 2); # 4 is new tag format
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_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
84 our %internal_object_save;
85 our $we_are_responder;
86 our $we_are_initiator;
87 our $initiator_tempdir;
88 our $patches_applied_dirtily = 00;
89 our $chase_dsc_distro=1;
91 our %forceopts = map { $_=>0 }
92 qw(unrepresentable unsupported-source-format
93 dsc-changes-mismatch changes-origs-exactly
94 uploading-binaries uploading-source-only
95 import-gitapply-absurd
96 import-gitapply-no-absurd
97 import-dsc-with-dgit-field);
99 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
101 our $suite_re = '[-+.0-9a-z]+';
102 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
103 | (?: git | git-ff ) (?: ,always )?
104 | check (?: ,ignores )?
108 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
109 our $splitbraincache = 'dgit-intern/quilt-cache';
110 our $rewritemap = 'dgit-rewrite/map';
112 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
114 our (@git) = qw(git);
115 our (@dget) = qw(dget);
116 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
117 our (@dput) = qw(dput);
118 our (@debsign) = qw(debsign);
119 our (@gpg) = qw(gpg);
120 our (@sbuild) = (qw(sbuild --no-source));
122 our (@dgit) = qw(dgit);
123 our (@git_debrebase) = qw(git-debrebase);
124 our (@aptget) = qw(apt-get);
125 our (@aptcache) = qw(apt-cache);
126 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
127 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
128 our (@dpkggenchanges) = qw(dpkg-genchanges);
129 our (@mergechanges) = qw(mergechanges -f);
130 our (@gbp_build) = ('');
131 our (@gbp_pq) = ('gbp pq');
132 our (@changesopts) = ('');
133 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
134 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
136 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
139 'debsign' => \@debsign,
141 'sbuild' => \@sbuild,
145 'git-debrebase' => \@git_debrebase,
146 'apt-get' => \@aptget,
147 'apt-cache' => \@aptcache,
148 'dpkg-source' => \@dpkgsource,
149 'dpkg-buildpackage' => \@dpkgbuildpackage,
150 'dpkg-genchanges' => \@dpkggenchanges,
151 'gbp-build' => \@gbp_build,
152 'gbp-pq' => \@gbp_pq,
153 'ch' => \@changesopts,
154 'mergechanges' => \@mergechanges,
155 'pbuilder' => \@pbuilder,
156 'cowbuilder' => \@cowbuilder);
158 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
159 our %opts_cfg_insertpos = map {
161 scalar @{ $opts_opt_map{$_} }
162 } keys %opts_opt_map;
164 sub parseopts_late_defaults();
165 sub quiltify_trees_differ ($$;$$$);
166 sub setup_gitattrs(;$);
167 sub check_gitattrs($$);
174 our $supplementary_message = '';
175 our $made_split_brain = 0;
176 our $do_split_brain = 0;
178 # Interactions between quilt mode and split brain
179 # (currently, split brain only implemented iff
180 # madformat_wantfixup && quiltmode_splitbrain)
182 # source format sane `3.0 (quilt)'
183 # madformat_wantfixup()
185 # quilt mode normal quiltmode
186 # (eg linear) _splitbrain
188 # ------------ ------------------------------------------------
190 # no split no q cache no q cache forbidden,
191 # brain PM on master q fixup on master prevented
192 # !$do_split_brain PM on master
194 # split brain no q cache q fixup cached, to dgit view
195 # PM in dgit view PM in dgit view
197 # PM = pseudomerge to make ff, due to overwrite (or split view)
198 # "no q cache" = do not record in cache on build, do not check cache
199 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
203 return unless forkcheck_mainprocess();
204 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
207 our $remotename = 'dgit';
208 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
212 if (!defined $absurdity) {
214 $absurdity =~ s{/[^/]+$}{/absurd} or die;
218 my ($v,$distro) = @_;
219 return debiantag_new($v, $distro);
222 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
224 sub lbranch () { return "$branchprefix/$csuite"; }
225 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
226 sub lref () { return "refs/heads/".lbranch(); }
227 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
228 sub rrref () { return server_ref($csuite); }
231 my ($vsn, $sfx) = @_;
232 return &source_file_leafname($package, $vsn, $sfx);
234 sub is_orig_file_of_vsn ($$) {
235 my ($f, $upstreamvsn) = @_;
236 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
241 return srcfn($vsn,".dsc");
244 sub changespat ($;$) {
245 my ($vsn, $arch) = @_;
246 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
255 return unless forkcheck_mainprocess();
256 foreach my $f (@end) {
258 print STDERR "$us: cleanup: $@" if length $@;
263 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
267 sub forceable_fail ($$) {
268 my ($forceoptsl, $msg) = @_;
269 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
270 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
274 my ($forceoptsl) = @_;
275 my @got = grep { $forceopts{$_} } @$forceoptsl;
276 return 0 unless @got;
278 "warning: skipping checks or functionality due to --force-%s\n",
282 sub no_such_package () {
283 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
284 $us, $package, $isuite;
288 sub deliberately ($) {
290 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
293 sub deliberately_not_fast_forward () {
294 foreach (qw(not-fast-forward fresh-repo)) {
295 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
299 sub quiltmode_splitbrain () {
300 $quilt_mode =~ m/gbp|dpm|unapplied/;
303 sub opts_opt_multi_cmd {
306 push @cmd, split /\s+/, shift @_;
313 return opts_opt_multi_cmd [], @gbp_pq;
316 sub dgit_privdir () {
317 our $dgit_privdir_made //= ensure_a_playground 'dgit';
321 my $r = $buildproductsdir;
322 $r = "$maindir/$r" unless $r =~ m{^/};
326 sub get_tree_of_commit ($) {
327 my ($commitish) = @_;
328 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
329 $cdata =~ m/\n\n/; $cdata = $`;
330 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
334 sub branch_gdr_info ($$) {
335 my ($symref, $head) = @_;
336 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
337 gdr_ffq_prev_branchinfo($symref);
338 return () unless $status eq 'branch';
339 $ffq_prev = git_get_ref $ffq_prev;
340 $gdrlast = git_get_ref $gdrlast;
341 $gdrlast &&= is_fast_fwd $gdrlast, $head;
342 return ($ffq_prev, $gdrlast);
345 sub branch_is_gdr_unstitched_ff ($$$) {
346 my ($symref, $head, $ancestor) = @_;
347 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
348 return 0 unless $ffq_prev;
349 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
353 sub branch_is_gdr ($) {
355 # This is quite like git-debrebase's keycommits.
356 # We have our own implementation because:
357 # - our algorighm can do fewer tests so is faster
358 # - it saves testing to see if gdr is installed
360 # NB we use this jsut for deciding whether to run gdr make-patches
361 # Before reusing this algorithm for somthing else, its
362 # suitability should be reconsidered.
365 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
366 printdebug "branch_is_gdr $head...\n";
367 my $get_patches = sub {
368 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
371 my $tip_patches = $get_patches->($head);
374 my $cdata = git_cat_file $walk, 'commit';
375 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
376 if ($msg =~ m{^\[git-debrebase\ (
377 anchor | changelog | make-patches |
378 merged-breakwater | pseudomerge
380 # no need to analyse this - it's sufficient
381 # (gdr classifications: Anchor, MergedBreakwaters)
382 # (made by gdr: Pseudomerge, Changelog)
383 printdebug "branch_is_gdr $walk gdr $1 YES\n";
386 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
388 my $walk_tree = get_tree_of_commit $walk;
389 foreach my $p (@parents) {
390 my $p_tree = get_tree_of_commit $p;
391 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
392 # (gdr classification: Pseudomerge; not made by gdr)
393 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
399 # some other non-gdr merge
400 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
401 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
405 # (gdr classification: ?)
406 printdebug "branch_is_gdr $walk ?-octopus NO\n";
410 printdebug "branch_is_gdr $walk origin\n";
413 if ($get_patches->($walk) ne $tip_patches) {
414 # Our parent added, removed, or edited patches, and wasn't
415 # a gdr make-patches commit. gdr make-patches probably
416 # won't do that well, then.
417 # (gdr classification of parent: AddPatches or ?)
418 printdebug "branch_is_gdr $walk ?-patches NO\n";
421 if ($tip_patches eq '' and
422 !defined git_cat_file "$walk~:debian" and
423 !quiltify_trees_differ "$walk~", $walk
425 # (gdr classification of parent: BreakwaterStart
426 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
429 # (gdr classification: Upstream Packaging Mixed Changelog)
430 printdebug "branch_is_gdr $walk plain\n"
436 #---------- remote protocol support, common ----------
438 # remote push initiator/responder protocol:
439 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
440 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
441 # < dgit-remote-push-ready <actual-proto-vsn>
448 # > supplementary-message NBYTES # $protovsn >= 3
453 # > file parsed-changelog
454 # [indicates that output of dpkg-parsechangelog follows]
455 # > data-block NBYTES
456 # > [NBYTES bytes of data (no newline)]
457 # [maybe some more blocks]
466 # > param head DGIT-VIEW-HEAD
467 # > param csuite SUITE
468 # > param tagformat new # $protovsn >= 4
469 # > param maint-view MAINT-VIEW-HEAD
471 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
472 # > file buildinfo # for buildinfos to sign
474 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
475 # # goes into tag, for replay prevention
478 # [indicates that signed tag is wanted]
479 # < data-block NBYTES
480 # < [NBYTES bytes of data (no newline)]
481 # [maybe some more blocks]
485 # > want signed-dsc-changes
486 # < data-block NBYTES [transfer of signed dsc]
488 # < data-block NBYTES [transfer of signed changes]
490 # < data-block NBYTES [transfer of each signed buildinfo
491 # [etc] same number and order as "file buildinfo"]
499 sub i_child_report () {
500 # Sees if our child has died, and reap it if so. Returns a string
501 # describing how it died if it failed, or undef otherwise.
502 return undef unless $i_child_pid;
503 my $got = waitpid $i_child_pid, WNOHANG;
504 return undef if $got <= 0;
505 die unless $got == $i_child_pid;
506 $i_child_pid = undef;
507 return undef unless $?;
508 return f_ "build host child %s", waitstatusmsg();
513 fail f_ "connection lost: %s", $! if $fh->error;
514 fail f_ "protocol violation; %s not expected", $m;
517 sub badproto_badread ($$) {
519 fail f_ "connection lost: %s", $! if $!;
520 my $report = i_child_report();
521 fail $report if defined $report;
522 badproto $fh, f_ "eof (reading %s)", $wh;
525 sub protocol_expect (&$) {
526 my ($match, $fh) = @_;
529 defined && chomp or badproto_badread $fh, __ "protocol message";
537 badproto $fh, f_ "\`%s'", $_;
540 sub protocol_send_file ($$) {
541 my ($fh, $ourfn) = @_;
542 open PF, "<", $ourfn or die "$ourfn: $!";
545 my $got = read PF, $d, 65536;
546 die "$ourfn: $!" unless defined $got;
548 print $fh "data-block ".length($d)."\n" or confess "$!";
549 print $fh $d or confess "$!";
551 PF->error and die "$ourfn $!";
552 print $fh "data-end\n" or confess "$!";
556 sub protocol_read_bytes ($$) {
557 my ($fh, $nbytes) = @_;
558 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
560 my $got = read $fh, $d, $nbytes;
561 $got==$nbytes or badproto_badread $fh, __ "data block";
565 sub protocol_receive_file ($$) {
566 my ($fh, $ourfn) = @_;
567 printdebug "() $ourfn\n";
568 open PF, ">", $ourfn or die "$ourfn: $!";
570 my ($y,$l) = protocol_expect {
571 m/^data-block (.*)$/ ? (1,$1) :
572 m/^data-end$/ ? (0,) :
576 my $d = protocol_read_bytes $fh, $l;
577 print PF $d or confess "$!";
579 close PF or confess "$!";
582 #---------- remote protocol support, responder ----------
584 sub responder_send_command ($) {
586 return unless $we_are_responder;
587 # called even without $we_are_responder
588 printdebug ">> $command\n";
589 print PO $command, "\n" or confess "$!";
592 sub responder_send_file ($$) {
593 my ($keyword, $ourfn) = @_;
594 return unless $we_are_responder;
595 printdebug "]] $keyword $ourfn\n";
596 responder_send_command "file $keyword";
597 protocol_send_file \*PO, $ourfn;
600 sub responder_receive_files ($@) {
601 my ($keyword, @ourfns) = @_;
602 die unless $we_are_responder;
603 printdebug "[[ $keyword @ourfns\n";
604 responder_send_command "want $keyword";
605 foreach my $fn (@ourfns) {
606 protocol_receive_file \*PI, $fn;
609 protocol_expect { m/^files-end$/ } \*PI;
612 #---------- remote protocol support, initiator ----------
614 sub initiator_expect (&) {
616 protocol_expect { &$match } \*RO;
619 #---------- end remote code ----------
622 if ($we_are_responder) {
624 responder_send_command "progress ".length($m) or confess "$!";
625 print PO $m or confess "$!";
635 $ua = LWP::UserAgent->new();
639 progress "downloading $what...";
640 my $r = $ua->get(@_) or confess "$!";
641 return undef if $r->code == 404;
642 $r->is_success or fail f_ "failed to fetch %s: %s",
643 $what, $r->status_line;
644 return $r->decoded_content(charset => 'none');
647 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
649 sub act_local () { return $dryrun_level <= 1; }
650 sub act_scary () { return !$dryrun_level; }
653 if (!$dryrun_level) {
654 progress f_ "%s ok: %s", $us, "@_";
656 progress f_ "would be ok: %s (but dry run only)", "@_";
661 printcmd(\*STDERR,$debugprefix."#",@_);
664 sub runcmd_ordryrun {
672 sub runcmd_ordryrun_local {
680 our $helpmsg = i_ <<END;
682 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
683 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
684 dgit [dgit-opts] build [dpkg-buildpackage-opts]
685 dgit [dgit-opts] sbuild [sbuild-opts]
686 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
687 dgit [dgit-opts] push [dgit-opts] [suite]
688 dgit [dgit-opts] push-source [dgit-opts] [suite]
689 dgit [dgit-opts] rpush build-host:build-dir ...
690 important dgit options:
691 -k<keyid> sign tag and package with <keyid> instead of default
692 --dry-run -n do not change anything, but go through the motions
693 --damp-run -L like --dry-run but make local changes, without signing
694 --new -N allow introducing a new package
695 --debug -D increase debug level
696 -c<name>=<value> set git config option (used directly by dgit too)
699 our $later_warning_msg = i_ <<END;
700 Perhaps the upload is stuck in incoming. Using the version from git.
704 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
709 @ARGV or badusage __ "too few arguments";
710 return scalar shift @ARGV;
714 not_necessarily_a_tree();
717 print __ $helpmsg or confess "$!";
721 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
723 our %defcfg = ('dgit.default.distro' => 'debian',
724 'dgit.default.default-suite' => 'unstable',
725 'dgit.default.old-dsc-distro' => 'debian',
726 'dgit-suite.*-security.distro' => 'debian-security',
727 'dgit.default.username' => '',
728 'dgit.default.archive-query-default-component' => 'main',
729 'dgit.default.ssh' => 'ssh',
730 'dgit.default.archive-query' => 'madison:',
731 'dgit.default.sshpsql-dbname' => 'service=projectb',
732 'dgit.default.aptget-components' => 'main',
733 'dgit.default.source-only-uploads' => 'ok',
734 'dgit.dsc-url-proto-ok.http' => 'true',
735 'dgit.dsc-url-proto-ok.https' => 'true',
736 'dgit.dsc-url-proto-ok.git' => 'true',
737 'dgit.vcs-git.suites', => 'sid', # ;-separated
738 'dgit.default.dsc-url-proto-ok' => 'false',
739 # old means "repo server accepts pushes with old dgit tags"
740 # new means "repo server accepts pushes with new dgit tags"
741 # maint means "repo server accepts split brain pushes"
742 # hist means "repo server may have old pushes without new tag"
743 # ("hist" is implied by "old")
744 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
745 'dgit-distro.debian.git-check' => 'url',
746 'dgit-distro.debian.git-check-suffix' => '/info/refs',
747 'dgit-distro.debian.new-private-pushers' => 't',
748 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
749 'dgit-distro.debian/push.git-url' => '',
750 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
751 'dgit-distro.debian/push.git-user-force' => 'dgit',
752 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
753 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
754 'dgit-distro.debian/push.git-create' => 'true',
755 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
756 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
757 # 'dgit-distro.debian.archive-query-tls-key',
758 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
759 # ^ this does not work because curl is broken nowadays
760 # Fixing #790093 properly will involve providing providing the key
761 # in some pacagke and maybe updating these paths.
763 # 'dgit-distro.debian.archive-query-tls-curl-args',
764 # '--ca-path=/etc/ssl/ca-debian',
765 # ^ this is a workaround but works (only) on DSA-administered machines
766 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
767 'dgit-distro.debian.git-url-suffix' => '',
768 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
769 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
770 'dgit-distro.debian-security.archive-query' => 'aptget:',
771 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
772 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
773 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
774 'dgit-distro.debian-security.nominal-distro' => 'debian',
775 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
776 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
777 'dgit-distro.ubuntu.git-check' => 'false',
778 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
779 'dgit-distro.test-dummy.ssh' => "$td/ssh",
780 'dgit-distro.test-dummy.username' => "alice",
781 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
782 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
783 'dgit-distro.test-dummy.git-url' => "$td/git",
784 'dgit-distro.test-dummy.git-host' => "git",
785 'dgit-distro.test-dummy.git-path' => "$td/git",
786 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
787 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
788 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
789 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
793 our @gitcfgsources = qw(cmdline local global system);
794 our $invoked_in_git_tree = 1;
796 sub git_slurp_config () {
797 # This algoritm is a bit subtle, but this is needed so that for
798 # options which we want to be single-valued, we allow the
799 # different config sources to override properly. See #835858.
800 foreach my $src (@gitcfgsources) {
801 next if $src eq 'cmdline';
802 # we do this ourselves since git doesn't handle it
804 $gitcfgs{$src} = git_slurp_config_src $src;
808 sub git_get_config ($) {
810 foreach my $src (@gitcfgsources) {
811 my $l = $gitcfgs{$src}{$c};
812 confess "internal error ($l $c)" if $l && !ref $l;
813 printdebug"C $c ".(defined $l ?
814 join " ", map { messagequote "'$_'" } @$l :
819 f_ "multiple values for %s (in %s git config)", $c, $src
821 $l->[0] =~ m/\n/ and badcfg f_
822 "value for config option %s (in %s git config) contains newline(s)!",
831 return undef if $c =~ /RETURN-UNDEF/;
832 printdebug "C? $c\n" if $debuglevel >= 5;
833 my $v = git_get_config($c);
834 return $v if defined $v;
835 my $dv = $defcfg{$c};
837 printdebug "CD $c $dv\n" if $debuglevel >= 4;
842 "need value for one of: %s\n".
843 "%s: distro or suite appears not to be (properly) supported",
847 sub not_necessarily_a_tree () {
848 # needs to be called from pre_*
849 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
850 $invoked_in_git_tree = 0;
853 sub access_basedistro__noalias () {
854 if (defined $idistro) {
857 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
858 return $def if defined $def;
859 foreach my $src (@gitcfgsources, 'internal') {
860 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
862 foreach my $k (keys %$kl) {
863 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
865 next unless match_glob $dpat, $isuite;
869 return cfg("dgit.default.distro");
873 sub access_basedistro () {
874 my $noalias = access_basedistro__noalias();
875 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
876 return $canon // $noalias;
879 sub access_nomdistro () {
880 my $base = access_basedistro();
881 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
882 $r =~ m/^$distro_re$/ or badcfg
883 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
884 $r, "/^$distro_re$/";
888 sub access_quirk () {
889 # returns (quirk name, distro to use instead or undef, quirk-specific info)
890 my $basedistro = access_basedistro();
891 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
893 if (defined $backports_quirk) {
894 my $re = $backports_quirk;
895 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
897 $re =~ s/\%/([-0-9a-z_]+)/
898 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
899 if ($isuite =~ m/^$re$/) {
900 return ('backports',"$basedistro-backports",$1);
903 return ('none',undef);
908 sub parse_cfg_bool ($$$) {
909 my ($what,$def,$v) = @_;
912 $v =~ m/^[ty1]/ ? 1 :
913 $v =~ m/^[fn0]/ ? 0 :
914 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
918 sub access_forpush_config () {
919 my $d = access_basedistro();
923 parse_cfg_bool('new-private-pushers', 0,
924 cfg("dgit-distro.$d.new-private-pushers",
927 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
930 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
931 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
932 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
934 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
937 sub access_forpush () {
938 $access_forpush //= access_forpush_config();
939 return $access_forpush;
942 sub default_from_access_cfg ($$$;$) {
943 my ($var, $keybase, $defval, $permit_re) = @_;
944 return if defined $$var;
946 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
947 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
949 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
952 badcfg f_ "unknown %s \`%s'", $keybase, $$var
953 if defined $permit_re and $$var !~ m/$permit_re/;
957 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
958 defined $access_forpush and !$access_forpush;
959 badcfg __ "pushing but distro is configured readonly"
960 if access_forpush_config() eq '0';
962 $supplementary_message = __ <<'END' unless $we_are_responder;
963 Push failed, before we got started.
964 You can retry the push, after fixing the problem, if you like.
966 parseopts_late_defaults();
970 parseopts_late_defaults();
973 sub supplementary_message ($) {
975 if (!$we_are_responder) {
976 $supplementary_message = $msg;
978 } elsif ($protovsn >= 3) {
979 responder_send_command "supplementary-message ".length($msg)
981 print PO $msg or confess "$!";
985 sub access_distros () {
986 # Returns list of distros to try, in order
989 # 0. `instead of' distro name(s) we have been pointed to
990 # 1. the access_quirk distro, if any
991 # 2a. the user's specified distro, or failing that } basedistro
992 # 2b. the distro calculated from the suite }
993 my @l = access_basedistro();
995 my (undef,$quirkdistro) = access_quirk();
996 unshift @l, $quirkdistro;
997 unshift @l, $instead_distro;
998 @l = grep { defined } @l;
1000 push @l, access_nomdistro();
1002 if (access_forpush()) {
1003 @l = map { ("$_/push", $_) } @l;
1008 sub access_cfg_cfgs (@) {
1011 # The nesting of these loops determines the search order. We put
1012 # the key loop on the outside so that we search all the distros
1013 # for each key, before going on to the next key. That means that
1014 # if access_cfg is called with a more specific, and then a less
1015 # specific, key, an earlier distro can override the less specific
1016 # without necessarily overriding any more specific keys. (If the
1017 # distro wants to override the more specific keys it can simply do
1018 # so; whereas if we did the loop the other way around, it would be
1019 # impossible to for an earlier distro to override a less specific
1020 # key but not the more specific ones without restating the unknown
1021 # values of the more specific keys.
1024 # We have to deal with RETURN-UNDEF specially, so that we don't
1025 # terminate the search prematurely.
1027 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1030 foreach my $d (access_distros()) {
1031 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1033 push @cfgs, map { "dgit.default.$_" } @realkeys;
1034 push @cfgs, @rundef;
1038 sub access_cfg (@) {
1040 my (@cfgs) = access_cfg_cfgs(@keys);
1041 my $value = cfg(@cfgs);
1045 sub access_cfg_bool ($$) {
1046 my ($def, @keys) = @_;
1047 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1050 sub string_to_ssh ($) {
1052 if ($spec =~ m/\s/) {
1053 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1059 sub access_cfg_ssh () {
1060 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1061 if (!defined $gitssh) {
1064 return string_to_ssh $gitssh;
1068 sub access_runeinfo ($) {
1070 return ": dgit ".access_basedistro()." $info ;";
1073 sub access_someuserhost ($) {
1075 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1076 defined($user) && length($user) or
1077 $user = access_cfg("$some-user",'username');
1078 my $host = access_cfg("$some-host");
1079 return length($user) ? "$user\@$host" : $host;
1082 sub access_gituserhost () {
1083 return access_someuserhost('git');
1086 sub access_giturl (;$) {
1087 my ($optional) = @_;
1088 my $url = access_cfg('git-url','RETURN-UNDEF');
1091 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1092 return undef unless defined $proto;
1095 access_gituserhost().
1096 access_cfg('git-path');
1098 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1101 return "$url/$package$suffix";
1104 sub commit_getclogp ($) {
1105 # Returns the parsed changelog hashref for a particular commit
1107 our %commit_getclogp_memo;
1108 my $memo = $commit_getclogp_memo{$objid};
1109 return $memo if $memo;
1111 my $mclog = dgit_privdir()."clog";
1112 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1113 "$objid:debian/changelog";
1114 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1117 sub parse_dscdata () {
1118 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1119 printdebug Dumper($dscdata) if $debuglevel>1;
1120 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1121 printdebug Dumper($dsc) if $debuglevel>1;
1126 sub archive_query ($;@) {
1127 my ($method) = shift @_;
1128 fail __ "this operation does not support multiple comma-separated suites"
1130 my $query = access_cfg('archive-query','RETURN-UNDEF');
1131 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1134 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1137 sub archive_query_prepend_mirror {
1138 my $m = access_cfg('mirror');
1139 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1142 sub pool_dsc_subpath ($$) {
1143 my ($vsn,$component) = @_; # $package is implict arg
1144 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1145 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1148 sub cfg_apply_map ($$$) {
1149 my ($varref, $what, $mapspec) = @_;
1150 return unless $mapspec;
1152 printdebug "config $what EVAL{ $mapspec; }\n";
1154 eval "package Dgit::Config; $mapspec;";
1159 #---------- `ftpmasterapi' archive query method (nascent) ----------
1161 sub archive_api_query_cmd ($) {
1163 my @cmd = (@curl, qw(-sS));
1164 my $url = access_cfg('archive-query-url');
1165 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1167 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1168 foreach my $key (split /\:/, $keys) {
1169 $key =~ s/\%HOST\%/$host/g;
1171 fail "for $url: stat $key: $!" unless $!==ENOENT;
1174 fail f_ "config requested specific TLS key but do not know".
1175 " how to get curl to use exactly that EE key (%s)",
1177 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1178 # # Sadly the above line does not work because of changes
1179 # # to gnutls. The real fix for #790093 may involve
1180 # # new curl options.
1183 # Fixing #790093 properly will involve providing a value
1184 # for this on clients.
1185 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1186 push @cmd, split / /, $kargs if defined $kargs;
1188 push @cmd, $url.$subpath;
1192 sub api_query ($$;$) {
1194 my ($data, $subpath, $ok404) = @_;
1195 badcfg __ "ftpmasterapi archive query method takes no data part"
1197 my @cmd = archive_api_query_cmd($subpath);
1198 my $url = $cmd[$#cmd];
1199 push @cmd, qw(-w %{http_code});
1200 my $json = cmdoutput @cmd;
1201 unless ($json =~ s/\d+\d+\d$//) {
1202 failedcmd_report_cmd undef, @cmd;
1203 fail __ "curl failed to print 3-digit HTTP code";
1206 return undef if $code eq '404' && $ok404;
1207 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1208 unless $url =~ m#^file://# or $code =~ m/^2/;
1209 return decode_json($json);
1212 sub canonicalise_suite_ftpmasterapi {
1213 my ($proto,$data) = @_;
1214 my $suites = api_query($data, 'suites');
1216 foreach my $entry (@$suites) {
1218 my $v = $entry->{$_};
1219 defined $v && $v eq $isuite;
1220 } qw(codename name);
1221 push @matched, $entry;
1223 fail f_ "unknown suite %s, maybe -d would help", $isuite
1227 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1228 $cn = "$matched[0]{codename}";
1229 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1230 $cn =~ m/^$suite_re$/
1231 or die f_ "suite %s maps to bad codename\n", $isuite;
1233 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1238 sub archive_query_ftpmasterapi {
1239 my ($proto,$data) = @_;
1240 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1242 my $digester = Digest::SHA->new(256);
1243 foreach my $entry (@$info) {
1245 my $vsn = "$entry->{version}";
1246 my ($ok,$msg) = version_check $vsn;
1247 die f_ "bad version: %s\n", $msg unless $ok;
1248 my $component = "$entry->{component}";
1249 $component =~ m/^$component_re$/ or die __ "bad component";
1250 my $filename = "$entry->{filename}";
1251 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1252 or die __ "bad filename";
1253 my $sha256sum = "$entry->{sha256sum}";
1254 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1255 push @rows, [ $vsn, "/pool/$component/$filename",
1256 $digester, $sha256sum ];
1258 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1261 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1262 return archive_query_prepend_mirror @rows;
1265 sub file_in_archive_ftpmasterapi {
1266 my ($proto,$data,$filename) = @_;
1267 my $pat = $filename;
1270 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1271 my $info = api_query($data, "file_in_archive/$pat", 1);
1274 sub package_not_wholly_new_ftpmasterapi {
1275 my ($proto,$data,$pkg) = @_;
1276 my $info = api_query($data,"madison?package=${pkg}&f=json");
1280 #---------- `aptget' archive query method ----------
1283 our $aptget_releasefile;
1284 our $aptget_configpath;
1286 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1287 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1289 sub aptget_cache_clean {
1290 runcmd_ordryrun_local qw(sh -ec),
1291 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1295 sub aptget_lock_acquire () {
1296 my $lockfile = "$aptget_base/lock";
1297 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1298 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1301 sub aptget_prep ($) {
1303 return if defined $aptget_base;
1305 badcfg __ "aptget archive query method takes no data part"
1308 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1311 ensuredir "$cache/dgit";
1313 access_cfg('aptget-cachekey','RETURN-UNDEF')
1314 // access_nomdistro();
1316 $aptget_base = "$cache/dgit/aptget";
1317 ensuredir $aptget_base;
1319 my $quoted_base = $aptget_base;
1320 confess "$quoted_base contains bad chars, cannot continue"
1321 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1323 ensuredir $aptget_base;
1325 aptget_lock_acquire();
1327 aptget_cache_clean();
1329 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1330 my $sourceslist = "source.list#$cachekey";
1332 my $aptsuites = $isuite;
1333 cfg_apply_map(\$aptsuites, 'suite map',
1334 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1336 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1337 printf SRCS "deb-src %s %s %s\n",
1338 access_cfg('mirror'),
1340 access_cfg('aptget-components')
1343 ensuredir "$aptget_base/cache";
1344 ensuredir "$aptget_base/lists";
1346 open CONF, ">", $aptget_configpath or confess "$!";
1348 Debug::NoLocking "true";
1349 APT::Get::List-Cleanup "false";
1350 #clear APT::Update::Post-Invoke-Success;
1351 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1352 Dir::State::Lists "$quoted_base/lists";
1353 Dir::Etc::preferences "$quoted_base/preferences";
1354 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1355 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1358 foreach my $key (qw(
1361 Dir::Cache::Archives
1362 Dir::Etc::SourceParts
1363 Dir::Etc::preferencesparts
1365 ensuredir "$aptget_base/$key";
1366 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1369 my $oldatime = (time // confess "$!") - 1;
1370 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1371 next unless stat_exists $oldlist;
1372 my ($mtime) = (stat _)[9];
1373 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1376 runcmd_ordryrun_local aptget_aptget(), qw(update);
1379 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1380 next unless stat_exists $oldlist;
1381 my ($atime) = (stat _)[8];
1382 next if $atime == $oldatime;
1383 push @releasefiles, $oldlist;
1385 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1386 @releasefiles = @inreleasefiles if @inreleasefiles;
1387 if (!@releasefiles) {
1388 fail f_ <<END, $isuite, $cache;
1389 apt seemed to not to update dgit's cached Release files for %s.
1391 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1394 confess "apt updated too many Release files (@releasefiles), erk"
1395 unless @releasefiles == 1;
1397 ($aptget_releasefile) = @releasefiles;
1400 sub canonicalise_suite_aptget {
1401 my ($proto,$data) = @_;
1404 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1406 foreach my $name (qw(Codename Suite)) {
1407 my $val = $release->{$name};
1409 printdebug "release file $name: $val\n";
1410 $val =~ m/^$suite_re$/o or fail f_
1411 "Release file (%s) specifies intolerable %s",
1412 $aptget_releasefile, $name;
1413 cfg_apply_map(\$val, 'suite rmap',
1414 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1421 sub archive_query_aptget {
1422 my ($proto,$data) = @_;
1425 ensuredir "$aptget_base/source";
1426 foreach my $old (<$aptget_base/source/*.dsc>) {
1427 unlink $old or die "$old: $!";
1430 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1431 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1432 # avoids apt-get source failing with ambiguous error code
1434 runcmd_ordryrun_local
1435 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1436 aptget_aptget(), qw(--download-only --only-source source), $package;
1438 my @dscs = <$aptget_base/source/*.dsc>;
1439 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1440 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1443 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1446 my $uri = "file://". uri_escape $dscs[0];
1447 $uri =~ s{\%2f}{/}gi;
1448 return [ (getfield $pre_dsc, 'Version'), $uri ];
1451 sub file_in_archive_aptget () { return undef; }
1452 sub package_not_wholly_new_aptget () { return undef; }
1454 #---------- `dummyapicat' archive query method ----------
1455 # (untranslated, because this is for testing purposes etc.)
1457 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1458 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1460 sub dummycatapi_run_in_mirror ($@) {
1461 # runs $fn with FIA open onto rune
1462 my ($rune, $argl, $fn) = @_;
1464 my $mirror = access_cfg('mirror');
1465 $mirror =~ s#^file://#/# or die "$mirror ?";
1466 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1467 qw(x), $mirror, @$argl);
1468 debugcmd "-|", @cmd;
1469 open FIA, "-|", @cmd or confess "$!";
1471 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1475 sub file_in_archive_dummycatapi ($$$) {
1476 my ($proto,$data,$filename) = @_;
1478 dummycatapi_run_in_mirror '
1479 find -name "$1" -print0 |
1481 ', [$filename], sub {
1484 printdebug "| $_\n";
1485 m/^(\w+) (\S+)$/ or die "$_ ?";
1486 push @out, { sha256sum => $1, filename => $2 };
1492 sub package_not_wholly_new_dummycatapi {
1493 my ($proto,$data,$pkg) = @_;
1494 dummycatapi_run_in_mirror "
1495 find -name ${pkg}_*.dsc
1502 #---------- `madison' archive query method ----------
1504 sub archive_query_madison {
1505 return archive_query_prepend_mirror
1506 map { [ @$_[0..1] ] } madison_get_parse(@_);
1509 sub madison_get_parse {
1510 my ($proto,$data) = @_;
1511 die unless $proto eq 'madison';
1512 if (!length $data) {
1513 $data= access_cfg('madison-distro','RETURN-UNDEF');
1514 $data //= access_basedistro();
1516 $rmad{$proto,$data,$package} ||= cmdoutput
1517 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1518 my $rmad = $rmad{$proto,$data,$package};
1521 foreach my $l (split /\n/, $rmad) {
1522 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1523 \s*( [^ \t|]+ )\s* \|
1524 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1525 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1526 $1 eq $package or die "$rmad $package ?";
1533 $component = access_cfg('archive-query-default-component');
1535 $5 eq 'source' or die "$rmad ?";
1536 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1538 return sort { -version_compare($a->[0],$b->[0]); } @out;
1541 sub canonicalise_suite_madison {
1542 # madison canonicalises for us
1543 my @r = madison_get_parse(@_);
1545 "unable to canonicalise suite using package %s".
1546 " which does not appear to exist in suite %s;".
1547 " --existing-package may help",
1552 sub file_in_archive_madison { return undef; }
1553 sub package_not_wholly_new_madison { return undef; }
1555 #---------- `sshpsql' archive query method ----------
1556 # (untranslated, because this is obsolete)
1559 my ($data,$runeinfo,$sql) = @_;
1560 if (!length $data) {
1561 $data= access_someuserhost('sshpsql').':'.
1562 access_cfg('sshpsql-dbname');
1564 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1565 my ($userhost,$dbname) = ($`,$'); #';
1567 my @cmd = (access_cfg_ssh, $userhost,
1568 access_runeinfo("ssh-psql $runeinfo").
1569 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1570 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1572 open P, "-|", @cmd or confess "$!";
1575 printdebug(">|$_|\n");
1578 $!=0; $?=0; close P or failedcmd @cmd;
1580 my $nrows = pop @rows;
1581 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1582 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1583 @rows = map { [ split /\|/, $_ ] } @rows;
1584 my $ncols = scalar @{ shift @rows };
1585 die if grep { scalar @$_ != $ncols } @rows;
1589 sub sql_injection_check {
1590 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1593 sub archive_query_sshpsql ($$) {
1594 my ($proto,$data) = @_;
1595 sql_injection_check $isuite, $package;
1596 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1597 SELECT source.version, component.name, files.filename, files.sha256sum
1599 JOIN src_associations ON source.id = src_associations.source
1600 JOIN suite ON suite.id = src_associations.suite
1601 JOIN dsc_files ON dsc_files.source = source.id
1602 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1603 JOIN component ON component.id = files_archive_map.component_id
1604 JOIN files ON files.id = dsc_files.file
1605 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1606 AND source.source='$package'
1607 AND files.filename LIKE '%.dsc';
1609 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1610 my $digester = Digest::SHA->new(256);
1612 my ($vsn,$component,$filename,$sha256sum) = @$_;
1613 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1615 return archive_query_prepend_mirror @rows;
1618 sub canonicalise_suite_sshpsql ($$) {
1619 my ($proto,$data) = @_;
1620 sql_injection_check $isuite;
1621 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1622 SELECT suite.codename
1623 FROM suite where suite_name='$isuite' or codename='$isuite';
1625 @rows = map { $_->[0] } @rows;
1626 fail "unknown suite $isuite" unless @rows;
1627 die "ambiguous $isuite: @rows ?" if @rows>1;
1631 sub file_in_archive_sshpsql ($$$) { return undef; }
1632 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1634 #---------- `dummycat' archive query method ----------
1635 # (untranslated, because this is for testing purposes etc.)
1637 sub canonicalise_suite_dummycat ($$) {
1638 my ($proto,$data) = @_;
1639 my $dpath = "$data/suite.$isuite";
1640 if (!open C, "<", $dpath) {
1641 $!==ENOENT or die "$dpath: $!";
1642 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1646 chomp or die "$dpath: $!";
1648 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1652 sub archive_query_dummycat ($$) {
1653 my ($proto,$data) = @_;
1654 canonicalise_suite();
1655 my $dpath = "$data/package.$csuite.$package";
1656 if (!open C, "<", $dpath) {
1657 $!==ENOENT or die "$dpath: $!";
1658 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1666 printdebug "dummycat query $csuite $package $dpath | $_\n";
1667 my @row = split /\s+/, $_;
1668 @row==2 or die "$dpath: $_ ?";
1671 C->error and die "$dpath: $!";
1673 return archive_query_prepend_mirror
1674 sort { -version_compare($a->[0],$b->[0]); } @rows;
1677 sub file_in_archive_dummycat () { return undef; }
1678 sub package_not_wholly_new_dummycat () { return undef; }
1680 #---------- tag format handling ----------
1681 # (untranslated, because everything should be new tag format by now)
1683 sub access_cfg_tagformats_can_splitbrain () {
1687 #---------- archive query entrypoints and rest of program ----------
1689 sub canonicalise_suite () {
1690 return if defined $csuite;
1691 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1692 $csuite = archive_query('canonicalise_suite');
1693 if ($isuite ne $csuite) {
1694 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1696 progress f_ "canonical suite name is %s", $csuite;
1700 sub get_archive_dsc () {
1701 canonicalise_suite();
1702 my @vsns = archive_query('archive_query');
1703 foreach my $vinfo (@vsns) {
1704 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1705 $dscurl = $vsn_dscurl;
1706 $dscdata = url_get($dscurl);
1708 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1713 $digester->add($dscdata);
1714 my $got = $digester->hexdigest();
1716 fail f_ "%s has hash %s but archive told us to expect %s",
1717 $dscurl, $got, $digest;
1720 my $fmt = getfield $dsc, 'Format';
1721 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1722 f_ "unsupported source format %s, sorry", $fmt;
1724 $dsc_checked = !!$digester;
1725 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1729 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1732 sub check_for_git ();
1733 sub check_for_git () {
1735 my $how = access_cfg('git-check');
1736 if ($how eq 'ssh-cmd') {
1738 (access_cfg_ssh, access_gituserhost(),
1739 access_runeinfo("git-check $package").
1740 " set -e; cd ".access_cfg('git-path').";".
1741 " if test -d $package.git; then echo 1; else echo 0; fi");
1742 my $r= cmdoutput @cmd;
1743 if (defined $r and $r =~ m/^divert (\w+)$/) {
1745 my ($usedistro,) = access_distros();
1746 # NB that if we are pushing, $usedistro will be $distro/push
1747 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1748 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1749 progress f_ "diverting to %s (using config for %s)",
1750 $divert, $instead_distro;
1751 return check_for_git();
1753 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1755 } elsif ($how eq 'url') {
1756 my $prefix = access_cfg('git-check-url','git-url');
1757 my $suffix = access_cfg('git-check-suffix','git-suffix',
1758 'RETURN-UNDEF') // '.git';
1759 my $url = "$prefix/$package$suffix";
1760 my @cmd = (@curl, qw(-sS -I), $url);
1761 my $result = cmdoutput @cmd;
1762 $result =~ s/^\S+ 200 .*\n\r?\n//;
1763 # curl -sS -I with https_proxy prints
1764 # HTTP/1.0 200 Connection established
1765 $result =~ m/^\S+ (404|200) /s or
1766 fail +(__ "unexpected results from git check query - ").
1767 Dumper($prefix, $result);
1769 if ($code eq '404') {
1771 } elsif ($code eq '200') {
1776 } elsif ($how eq 'true') {
1778 } elsif ($how eq 'false') {
1781 badcfg f_ "unknown git-check \`%s'", $how;
1785 sub create_remote_git_repo () {
1786 my $how = access_cfg('git-create');
1787 if ($how eq 'ssh-cmd') {
1789 (access_cfg_ssh, access_gituserhost(),
1790 access_runeinfo("git-create $package").
1791 "set -e; cd ".access_cfg('git-path').";".
1792 " cp -a _template $package.git");
1793 } elsif ($how eq 'true') {
1796 badcfg f_ "unknown git-create \`%s'", $how;
1800 our ($dsc_hash,$lastpush_mergeinput);
1801 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1805 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1806 $playground = fresh_playground 'dgit/unpack';
1809 sub mktree_in_ud_here () {
1810 playtree_setup $gitcfgs{local};
1813 sub git_write_tree () {
1814 my $tree = cmdoutput @git, qw(write-tree);
1815 $tree =~ m/^\w+$/ or die "$tree ?";
1819 sub git_add_write_tree () {
1820 runcmd @git, qw(add -Af .);
1821 return git_write_tree();
1824 sub remove_stray_gits ($) {
1826 my @gitscmd = qw(find -name .git -prune -print0);
1827 debugcmd "|",@gitscmd;
1828 open GITS, "-|", @gitscmd or confess "$!";
1833 print STDERR f_ "%s: warning: removing from %s: %s\n",
1834 $us, $what, (messagequote $_);
1838 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1841 sub mktree_in_ud_from_only_subdir ($;$) {
1842 my ($what,$raw) = @_;
1843 # changes into the subdir
1846 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1847 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1851 remove_stray_gits($what);
1852 mktree_in_ud_here();
1854 my ($format, $fopts) = get_source_format();
1855 if (madformat($format)) {
1860 my $tree=git_add_write_tree();
1861 return ($tree,$dir);
1864 our @files_csum_info_fields =
1865 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1866 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1867 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1869 sub dsc_files_info () {
1870 foreach my $csumi (@files_csum_info_fields) {
1871 my ($fname, $module, $method) = @$csumi;
1872 my $field = $dsc->{$fname};
1873 next unless defined $field;
1874 eval "use $module; 1;" or die $@;
1876 foreach (split /\n/, $field) {
1878 m/^(\w+) (\d+) (\S+)$/ or
1879 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1880 my $digester = eval "$module"."->$method;" or die $@;
1885 Digester => $digester,
1890 fail f_ "missing any supported Checksums-* or Files field in %s",
1891 $dsc->get_option('name');
1895 map { $_->{Filename} } dsc_files_info();
1898 sub files_compare_inputs (@) {
1903 my $showinputs = sub {
1904 return join "; ", map { $_->get_option('name') } @$inputs;
1907 foreach my $in (@$inputs) {
1909 my $in_name = $in->get_option('name');
1911 printdebug "files_compare_inputs $in_name\n";
1913 foreach my $csumi (@files_csum_info_fields) {
1914 my ($fname) = @$csumi;
1915 printdebug "files_compare_inputs $in_name $fname\n";
1917 my $field = $in->{$fname};
1918 next unless defined $field;
1921 foreach (split /\n/, $field) {
1924 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1925 fail "could not parse $in_name $fname line \`$_'";
1927 printdebug "files_compare_inputs $in_name $fname $f\n";
1931 my $re = \ $record{$f}{$fname};
1933 $fchecked{$f}{$in_name} = 1;
1936 "hash or size of %s varies in %s fields (between: %s)",
1937 $f, $fname, $showinputs->();
1942 @files = sort @files;
1943 $expected_files //= \@files;
1944 "@$expected_files" eq "@files" or
1945 fail f_ "file list in %s varies between hash fields!",
1949 fail f_ "%s has no files list field(s)", $in_name;
1951 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1954 grep { keys %$_ == @$inputs-1 } values %fchecked
1955 or fail f_ "no file appears in all file lists (looked in: %s)",
1959 sub is_orig_file_in_dsc ($$) {
1960 my ($f, $dsc_files_info) = @_;
1961 return 0 if @$dsc_files_info <= 1;
1962 # One file means no origs, and the filename doesn't have a "what
1963 # part of dsc" component. (Consider versions ending `.orig'.)
1964 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1968 # This function determines whether a .changes file is source-only from
1969 # the point of view of dak. Thus, it permits *_source.buildinfo
1972 # It does not, however, permit any other buildinfo files. After a
1973 # source-only upload, the buildds will try to upload files like
1974 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1975 # named like this in their (otherwise) source-only upload, the uploads
1976 # of the buildd can be rejected by dak. Fixing the resultant
1977 # situation can require manual intervention. So we block such
1978 # .buildinfo files when the user tells us to perform a source-only
1979 # upload (such as when using the push-source subcommand with the -C
1980 # option, which calls this function).
1982 # Note, though, that when dgit is told to prepare a source-only
1983 # upload, such as when subcommands like build-source and push-source
1984 # without -C are used, dgit has a more restrictive notion of
1985 # source-only .changes than dak: such uploads will never include
1986 # *_source.buildinfo files. This is because there is no use for such
1987 # files when using a tool like dgit to produce the source package, as
1988 # dgit ensures the source is identical to git HEAD.
1989 sub test_source_only_changes ($) {
1991 foreach my $l (split /\n/, getfield $changes, 'Files') {
1992 $l =~ m/\S+$/ or next;
1993 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1994 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1995 print f_ "purportedly source-only changes polluted by %s\n", $&;
2002 sub changes_update_origs_from_dsc ($$$$) {
2003 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2005 printdebug "checking origs needed ($upstreamvsn)...\n";
2006 $_ = getfield $changes, 'Files';
2007 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2008 fail __ "cannot find section/priority from .changes Files field";
2009 my $placementinfo = $1;
2011 printdebug "checking origs needed placement '$placementinfo'...\n";
2012 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2013 $l =~ m/\S+$/ or next;
2015 printdebug "origs $file | $l\n";
2016 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2017 printdebug "origs $file is_orig\n";
2018 my $have = archive_query('file_in_archive', $file);
2019 if (!defined $have) {
2020 print STDERR __ <<END;
2021 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2027 printdebug "origs $file \$#\$have=$#$have\n";
2028 foreach my $h (@$have) {
2031 foreach my $csumi (@files_csum_info_fields) {
2032 my ($fname, $module, $method, $archivefield) = @$csumi;
2033 next unless defined $h->{$archivefield};
2034 $_ = $dsc->{$fname};
2035 next unless defined;
2036 m/^(\w+) .* \Q$file\E$/m or
2037 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2038 if ($h->{$archivefield} eq $1) {
2042 "%s: %s (archive) != %s (local .dsc)",
2043 $archivefield, $h->{$archivefield}, $1;
2046 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2050 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2053 printdebug "origs $file f.same=$found_same".
2054 " #f._differ=$#found_differ\n";
2055 if (@found_differ && !$found_same) {
2057 (f_ "archive contains %s with different checksum", $file),
2060 # Now we edit the changes file to add or remove it
2061 foreach my $csumi (@files_csum_info_fields) {
2062 my ($fname, $module, $method, $archivefield) = @$csumi;
2063 next unless defined $changes->{$fname};
2065 # in archive, delete from .changes if it's there
2066 $changed{$file} = "removed" if
2067 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2068 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2069 # not in archive, but it's here in the .changes
2071 my $dsc_data = getfield $dsc, $fname;
2072 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2074 $extra =~ s/ \d+ /$&$placementinfo /
2075 or confess "$fname $extra >$dsc_data< ?"
2076 if $fname eq 'Files';
2077 $changes->{$fname} .= "\n". $extra;
2078 $changed{$file} = "added";
2083 foreach my $file (keys %changed) {
2085 "edited .changes for archive .orig contents: %s %s",
2086 $changed{$file}, $file;
2088 my $chtmp = "$changesfile.tmp";
2089 $changes->save($chtmp);
2091 rename $chtmp,$changesfile or die "$changesfile $!";
2093 progress f_ "[new .changes left in %s]", $changesfile;
2096 progress f_ "%s already has appropriate .orig(s) (if any)",
2101 sub make_commit ($) {
2103 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2106 sub clogp_authline ($) {
2108 my $author = getfield $clogp, 'Maintainer';
2109 if ($author =~ m/^[^"\@]+\,/) {
2110 # single entry Maintainer field with unquoted comma
2111 $author = ($& =~ y/,//rd).$'; # strip the comma
2113 # git wants a single author; any remaining commas in $author
2114 # are by now preceded by @ (or "). It seems safer to punt on
2115 # "..." for now rather than attempting to dequote or something.
2116 $author =~ s#,.*##ms unless $author =~ m/"/;
2117 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2118 my $authline = "$author $date";
2119 $authline =~ m/$git_authline_re/o or
2120 fail f_ "unexpected commit author line format \`%s'".
2121 " (was generated from changelog Maintainer field)",
2123 return ($1,$2,$3) if wantarray;
2127 sub vendor_patches_distro ($$) {
2128 my ($checkdistro, $what) = @_;
2129 return unless defined $checkdistro;
2131 my $series = "debian/patches/\L$checkdistro\E.series";
2132 printdebug "checking for vendor-specific $series ($what)\n";
2134 if (!open SERIES, "<", $series) {
2135 confess "$series $!" unless $!==ENOENT;
2142 print STDERR __ <<END;
2144 Unfortunately, this source package uses a feature of dpkg-source where
2145 the same source package unpacks to different source code on different
2146 distros. dgit cannot safely operate on such packages on affected
2147 distros, because the meaning of source packages is not stable.
2149 Please ask the distro/maintainer to remove the distro-specific series
2150 files and use a different technique (if necessary, uploading actually
2151 different packages, if different distros are supposed to have
2155 fail f_ "Found active distro-specific series file for".
2156 " %s (%s): %s, cannot continue",
2157 $checkdistro, $what, $series;
2159 die "$series $!" if SERIES->error;
2163 sub check_for_vendor_patches () {
2164 # This dpkg-source feature doesn't seem to be documented anywhere!
2165 # But it can be found in the changelog (reformatted):
2167 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2168 # Author: Raphael Hertzog <hertzog@debian.org>
2169 # Date: Sun Oct 3 09:36:48 2010 +0200
2171 # dpkg-source: correctly create .pc/.quilt_series with alternate
2174 # If you have debian/patches/ubuntu.series and you were
2175 # unpacking the source package on ubuntu, quilt was still
2176 # directed to debian/patches/series instead of
2177 # debian/patches/ubuntu.series.
2179 # debian/changelog | 3 +++
2180 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2181 # 2 files changed, 6 insertions(+), 1 deletion(-)
2184 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2185 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2186 __ "Dpkg::Vendor \`current vendor'");
2187 vendor_patches_distro(access_basedistro(),
2188 __ "(base) distro being accessed");
2189 vendor_patches_distro(access_nomdistro(),
2190 __ "(nominal) distro being accessed");
2193 sub check_bpd_exists () {
2194 stat $buildproductsdir
2195 or fail f_ "build-products-dir %s is not accessible: %s\n",
2196 $buildproductsdir, $!;
2199 sub dotdot_bpd_transfer_origs ($$$) {
2200 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2201 # checks is_orig_file_of_vsn and if
2202 # calls $wanted->{$leaf} and expects boolish
2204 return if $buildproductsdir eq '..';
2207 my $dotdot = $maindir;
2208 $dotdot =~ s{/[^/]+$}{};
2209 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2210 while ($!=0, defined(my $leaf = readdir DD)) {
2212 local ($debuglevel) = $debuglevel-1;
2213 printdebug "DD_BPD $leaf ?\n";
2215 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2216 next unless $wanted->($leaf);
2217 next if lstat "$bpd_abs/$leaf";
2220 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2223 $! == &ENOENT or fail f_
2224 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2225 lstat "$dotdot/$leaf" or fail f_
2226 "check orig file %s in ..: %s", $leaf, $!;
2228 stat "$dotdot/$leaf" or fail f_
2229 "check target of orig symlink %s in ..: %s", $leaf, $!;
2230 my $ltarget = readlink "$dotdot/$leaf" or
2231 die "readlink $dotdot/$leaf: $!";
2232 if ($ltarget !~ m{^/}) {
2233 $ltarget = "$dotdot/$ltarget";
2235 symlink $ltarget, "$bpd_abs/$leaf"
2236 or die "$ltarget $bpd_abs $leaf: $!";
2238 "%s: cloned orig symlink from ..: %s\n",
2240 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2242 "%s: hardlinked orig from ..: %s\n",
2244 } elsif ($! != EXDEV) {
2245 fail f_ "failed to make %s a hardlink to %s: %s",
2246 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2248 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2249 or die "$bpd_abs $dotdot $leaf $!";
2251 "%s: symmlinked orig from .. on other filesystem: %s\n",
2255 die "$dotdot; $!" if $!;
2259 sub generate_commits_from_dsc () {
2260 # See big comment in fetch_from_archive, below.
2261 # See also README.dsc-import.
2263 changedir $playground;
2265 my $bpd_abs = bpd_abs();
2266 my $upstreamv = upstreamversion $dsc->{version};
2267 my @dfi = dsc_files_info();
2269 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2270 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2272 foreach my $fi (@dfi) {
2273 my $f = $fi->{Filename};
2274 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2275 my $upper_f = "$bpd_abs/$f";
2277 printdebug "considering reusing $f: ";
2279 if (link_ltarget "$upper_f,fetch", $f) {
2280 printdebug "linked (using ...,fetch).\n";
2281 } elsif ((printdebug "($!) "),
2283 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2284 } elsif (link_ltarget $upper_f, $f) {
2285 printdebug "linked.\n";
2286 } elsif ((printdebug "($!) "),
2288 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2290 printdebug "absent.\n";
2294 complete_file_from_dsc('.', $fi, \$refetched)
2297 printdebug "considering saving $f: ";
2299 if (rename_link_xf 1, $f, $upper_f) {
2300 printdebug "linked.\n";
2301 } elsif ((printdebug "($@) "),
2303 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2304 } elsif (!$refetched) {
2305 printdebug "no need.\n";
2306 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2307 printdebug "linked (using ...,fetch).\n";
2308 } elsif ((printdebug "($@) "),
2310 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2312 printdebug "cannot.\n";
2316 # We unpack and record the orig tarballs first, so that we only
2317 # need disk space for one private copy of the unpacked source.
2318 # But we can't make them into commits until we have the metadata
2319 # from the debian/changelog, so we record the tree objects now and
2320 # make them into commits later.
2322 my $orig_f_base = srcfn $upstreamv, '';
2324 foreach my $fi (@dfi) {
2325 # We actually import, and record as a commit, every tarball
2326 # (unless there is only one file, in which case there seems
2329 my $f = $fi->{Filename};
2330 printdebug "import considering $f ";
2331 (printdebug "only one dfi\n"), next if @dfi == 1;
2332 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2333 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2337 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2339 printdebug "Y ", (join ' ', map { $_//"(none)" }
2340 $compr_ext, $orig_f_part
2343 my $input = new IO::File $f, '<' or die "$f $!";
2347 if (defined $compr_ext) {
2349 Dpkg::Compression::compression_guess_from_filename $f;
2350 fail "Dpkg::Compression cannot handle file $f in source package"
2351 if defined $compr_ext && !defined $cname;
2353 new Dpkg::Compression::Process compression => $cname;
2354 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2355 my $compr_fh = new IO::Handle;
2356 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2358 open STDIN, "<&", $input or confess "$!";
2360 die "dgit (child): exec $compr_cmd[0]: $!\n";
2365 rmtree "_unpack-tar";
2366 mkdir "_unpack-tar" or confess "$!";
2367 my @tarcmd = qw(tar -x -f -
2368 --no-same-owner --no-same-permissions
2369 --no-acls --no-xattrs --no-selinux);
2370 my $tar_pid = fork // confess "$!";
2372 chdir "_unpack-tar" or confess "$!";
2373 open STDIN, "<&", $input or confess "$!";
2375 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2377 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2378 !$? or failedcmd @tarcmd;
2381 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2383 # finally, we have the results in "tarball", but maybe
2384 # with the wrong permissions
2386 runcmd qw(chmod -R +rwX _unpack-tar);
2387 changedir "_unpack-tar";
2388 remove_stray_gits($f);
2389 mktree_in_ud_here();
2391 my ($tree) = git_add_write_tree();
2392 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2393 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2395 printdebug "one subtree $1\n";
2397 printdebug "multiple subtrees\n";
2400 rmtree "_unpack-tar";
2402 my $ent = [ $f, $tree ];
2404 Orig => !!$orig_f_part,
2405 Sort => (!$orig_f_part ? 2 :
2406 $orig_f_part =~ m/-/g ? 1 :
2414 # put any without "_" first (spec is not clear whether files
2415 # are always in the usual order). Tarballs without "_" are
2416 # the main orig or the debian tarball.
2417 $a->{Sort} <=> $b->{Sort} or
2421 my $any_orig = grep { $_->{Orig} } @tartrees;
2423 my $dscfn = "$package.dsc";
2425 my $treeimporthow = 'package';
2427 open D, ">", $dscfn or die "$dscfn: $!";
2428 print D $dscdata or die "$dscfn: $!";
2429 close D or die "$dscfn: $!";
2430 my @cmd = qw(dpkg-source);
2431 push @cmd, '--no-check' if $dsc_checked;
2432 if (madformat $dsc->{format}) {
2433 push @cmd, '--skip-patches';
2434 $treeimporthow = 'unpatched';
2436 push @cmd, qw(-x --), $dscfn;
2439 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2440 if (madformat $dsc->{format}) {
2441 check_for_vendor_patches();
2445 if (madformat $dsc->{format}) {
2446 my @pcmd = qw(dpkg-source --before-build .);
2447 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2449 $dappliedtree = git_add_write_tree();
2452 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2456 printdebug "import clog search...\n";
2457 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2458 my ($thisstanza, $desc) = @_;
2459 no warnings qw(exiting);
2461 $clogp //= $thisstanza;
2463 printdebug "import clog $thisstanza->{version} $desc...\n";
2465 last if !$any_orig; # we don't need $r1clogp
2467 # We look for the first (most recent) changelog entry whose
2468 # version number is lower than the upstream version of this
2469 # package. Then the last (least recent) previous changelog
2470 # entry is treated as the one which introduced this upstream
2471 # version and used for the synthetic commits for the upstream
2474 # One might think that a more sophisticated algorithm would be
2475 # necessary. But: we do not want to scan the whole changelog
2476 # file. Stopping when we see an earlier version, which
2477 # necessarily then is an earlier upstream version, is the only
2478 # realistic way to do that. Then, either the earliest
2479 # changelog entry we have seen so far is indeed the earliest
2480 # upload of this upstream version; or there are only changelog
2481 # entries relating to later upstream versions (which is not
2482 # possible unless the changelog and .dsc disagree about the
2483 # version). Then it remains to choose between the physically
2484 # last entry in the file, and the one with the lowest version
2485 # number. If these are not the same, we guess that the
2486 # versions were created in a non-monotonic order rather than
2487 # that the changelog entries have been misordered.
2489 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2491 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2492 $r1clogp = $thisstanza;
2494 printdebug "import clog $r1clogp->{version} becomes r1\n";
2497 $clogp or fail __ "package changelog has no entries!";
2499 my $authline = clogp_authline $clogp;
2500 my $changes = getfield $clogp, 'Changes';
2501 $changes =~ s/^\n//; # Changes: \n
2502 my $cversion = getfield $clogp, 'Version';
2505 $r1clogp //= $clogp; # maybe there's only one entry;
2506 my $r1authline = clogp_authline $r1clogp;
2507 # Strictly, r1authline might now be wrong if it's going to be
2508 # unused because !$any_orig. Whatever.
2510 printdebug "import tartrees authline $authline\n";
2511 printdebug "import tartrees r1authline $r1authline\n";
2513 foreach my $tt (@tartrees) {
2514 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2516 my $mbody = f_ "Import %s", $tt->{F};
2517 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2520 committer $r1authline
2524 [dgit import orig $tt->{F}]
2532 [dgit import tarball $package $cversion $tt->{F}]
2537 printdebug "import main commit\n";
2539 open C, ">../commit.tmp" or confess "$!";
2540 print C <<END or confess "$!";
2543 print C <<END or confess "$!" foreach @tartrees;
2546 print C <<END or confess "$!";
2552 [dgit import $treeimporthow $package $cversion]
2555 close C or confess "$!";
2556 my $rawimport_hash = make_commit qw(../commit.tmp);
2558 if (madformat $dsc->{format}) {
2559 printdebug "import apply patches...\n";
2561 # regularise the state of the working tree so that
2562 # the checkout of $rawimport_hash works nicely.
2563 my $dappliedcommit = make_commit_text(<<END);
2570 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2572 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2574 # We need the answers to be reproducible
2575 my @authline = clogp_authline($clogp);
2576 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2577 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2578 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2579 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2580 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2581 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2583 my $path = $ENV{PATH} or die;
2585 # we use ../../gbp-pq-output, which (given that we are in
2586 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2589 foreach my $use_absurd (qw(0 1)) {
2590 runcmd @git, qw(checkout -q unpa);
2591 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2592 local $ENV{PATH} = $path;
2595 progress "warning: $@";
2596 $path = "$absurdity:$path";
2597 progress f_ "%s: trying slow absurd-git-apply...", $us;
2598 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2603 die "forbid absurd git-apply\n" if $use_absurd
2604 && forceing [qw(import-gitapply-no-absurd)];
2605 die "only absurd git-apply!\n" if !$use_absurd
2606 && forceing [qw(import-gitapply-absurd)];
2608 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2609 local $ENV{PATH} = $path if $use_absurd;
2611 my @showcmd = (gbp_pq, qw(import));
2612 my @realcmd = shell_cmd
2613 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2614 debugcmd "+",@realcmd;
2615 if (system @realcmd) {
2616 die f_ "%s failed: %s\n",
2617 +(shellquote @showcmd),
2618 failedcmd_waitstatus();
2621 my $gapplied = git_rev_parse('HEAD');
2622 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2623 $gappliedtree eq $dappliedtree or
2624 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2625 gbp-pq import and dpkg-source disagree!
2626 gbp-pq import gave commit %s
2627 gbp-pq import gave tree %s
2628 dpkg-source --before-build gave tree %s
2630 $rawimport_hash = $gapplied;
2635 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2640 progress f_ "synthesised git commit from .dsc %s", $cversion;
2642 my $rawimport_mergeinput = {
2643 Commit => $rawimport_hash,
2644 Info => __ "Import of source package",
2646 my @output = ($rawimport_mergeinput);
2648 if ($lastpush_mergeinput) {
2649 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2650 my $oversion = getfield $oldclogp, 'Version';
2652 version_compare($oversion, $cversion);
2654 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2655 { ReverseParents => 1,
2656 Message => (f_ <<END, $package, $cversion, $csuite) });
2657 Record %s (%s) in archive suite %s
2659 } elsif ($vcmp > 0) {
2660 print STDERR f_ <<END, $cversion, $oversion,
2662 Version actually in archive: %s (older)
2663 Last version pushed with dgit: %s (newer or same)
2666 __ $later_warning_msg or confess "$!";
2667 @output = $lastpush_mergeinput;
2669 # Same version. Use what's in the server git branch,
2670 # discarding our own import. (This could happen if the
2671 # server automatically imports all packages into git.)
2672 @output = $lastpush_mergeinput;
2680 sub complete_file_from_dsc ($$;$) {
2681 our ($dstdir, $fi, $refetched) = @_;
2682 # Ensures that we have, in $dstdir, the file $fi, with the correct
2683 # contents. (Downloading it from alongside $dscurl if necessary.)
2684 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2685 # and will set $$refetched=1 if it did so (or tried to).
2687 my $f = $fi->{Filename};
2688 my $tf = "$dstdir/$f";
2692 my $checkhash = sub {
2693 open F, "<", "$tf" or die "$tf: $!";
2694 $fi->{Digester}->reset();
2695 $fi->{Digester}->addfile(*F);
2696 F->error and confess "$!";
2697 $got = $fi->{Digester}->hexdigest();
2698 return $got eq $fi->{Hash};
2701 if (stat_exists $tf) {
2702 if ($checkhash->()) {
2703 progress f_ "using existing %s", $f;
2707 fail f_ "file %s has hash %s but .dsc demands hash %s".
2708 " (perhaps you should delete this file?)",
2709 $f, $got, $fi->{Hash};
2711 progress f_ "need to fetch correct version of %s", $f;
2712 unlink $tf or die "$tf $!";
2715 printdebug "$tf does not exist, need to fetch\n";
2719 $furl =~ s{/[^/]+$}{};
2721 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2722 die "$f ?" if $f =~ m#/#;
2723 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2724 return 0 if !act_local();
2727 fail f_ "file %s has hash %s but .dsc demands hash %s".
2728 " (got wrong file from archive!)",
2729 $f, $got, $fi->{Hash};
2734 sub ensure_we_have_orig () {
2735 my @dfi = dsc_files_info();
2736 foreach my $fi (@dfi) {
2737 my $f = $fi->{Filename};
2738 next unless is_orig_file_in_dsc($f, \@dfi);
2739 complete_file_from_dsc($buildproductsdir, $fi)
2744 #---------- git fetch ----------
2746 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2747 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2749 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2750 # locally fetched refs because they have unhelpful names and clutter
2751 # up gitk etc. So we track whether we have "used up" head ref (ie,
2752 # whether we have made another local ref which refers to this object).
2754 # (If we deleted them unconditionally, then we might end up
2755 # re-fetching the same git objects each time dgit fetch was run.)
2757 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2758 # in git_fetch_us to fetch the refs in question, and possibly a call
2759 # to lrfetchref_used.
2761 our (%lrfetchrefs_f, %lrfetchrefs_d);
2762 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2764 sub lrfetchref_used ($) {
2765 my ($fullrefname) = @_;
2766 my $objid = $lrfetchrefs_f{$fullrefname};
2767 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2770 sub git_lrfetch_sane {
2771 my ($url, $supplementary, @specs) = @_;
2772 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2773 # at least as regards @specs. Also leave the results in
2774 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2775 # able to clean these up.
2777 # With $supplementary==1, @specs must not contain wildcards
2778 # and we add to our previous fetches (non-atomically).
2780 # This is rather miserable:
2781 # When git fetch --prune is passed a fetchspec ending with a *,
2782 # it does a plausible thing. If there is no * then:
2783 # - it matches subpaths too, even if the supplied refspec
2784 # starts refs, and behaves completely madly if the source
2785 # has refs/refs/something. (See, for example, Debian #NNNN.)
2786 # - if there is no matching remote ref, it bombs out the whole
2788 # We want to fetch a fixed ref, and we don't know in advance
2789 # if it exists, so this is not suitable.
2791 # Our workaround is to use git ls-remote. git ls-remote has its
2792 # own qairks. Notably, it has the absurd multi-tail-matching
2793 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2794 # refs/refs/foo etc.
2796 # Also, we want an idempotent snapshot, but we have to make two
2797 # calls to the remote: one to git ls-remote and to git fetch. The
2798 # solution is use git ls-remote to obtain a target state, and
2799 # git fetch to try to generate it. If we don't manage to generate
2800 # the target state, we try again.
2802 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2804 my $specre = join '|', map {
2807 my $wildcard = $x =~ s/\\\*$/.*/;
2808 die if $wildcard && $supplementary;
2811 printdebug "git_lrfetch_sane specre=$specre\n";
2812 my $wanted_rref = sub {
2814 return m/^(?:$specre)$/;
2817 my $fetch_iteration = 0;
2820 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2821 if (++$fetch_iteration > 10) {
2822 fail __ "too many iterations trying to get sane fetch!";
2825 my @look = map { "refs/$_" } @specs;
2826 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2830 open GITLS, "-|", @lcmd or confess "$!";
2832 printdebug "=> ", $_;
2833 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2834 my ($objid,$rrefname) = ($1,$2);
2835 if (!$wanted_rref->($rrefname)) {
2836 print STDERR f_ <<END, "@look", $rrefname;
2837 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2841 $wantr{$rrefname} = $objid;
2844 close GITLS or failedcmd @lcmd;
2846 # OK, now %want is exactly what we want for refs in @specs
2848 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2849 "+refs/$_:".lrfetchrefs."/$_";
2852 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2854 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2855 runcmd_ordryrun_local @fcmd if @fspecs;
2857 if (!$supplementary) {
2858 %lrfetchrefs_f = ();
2862 git_for_each_ref(lrfetchrefs, sub {
2863 my ($objid,$objtype,$lrefname,$reftail) = @_;
2864 $lrfetchrefs_f{$lrefname} = $objid;
2865 $objgot{$objid} = 1;
2868 if ($supplementary) {
2872 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2873 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2874 if (!exists $wantr{$rrefname}) {
2875 if ($wanted_rref->($rrefname)) {
2877 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2880 print STDERR f_ <<END, "@fspecs", $lrefname
2881 warning: git fetch %s created %s; this is silly, deleting it.
2884 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2885 delete $lrfetchrefs_f{$lrefname};
2889 foreach my $rrefname (sort keys %wantr) {
2890 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2891 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2892 my $want = $wantr{$rrefname};
2893 next if $got eq $want;
2894 if (!defined $objgot{$want}) {
2895 fail __ <<END unless act_local();
2896 --dry-run specified but we actually wanted the results of git fetch,
2897 so this is not going to work. Try running dgit fetch first,
2898 or using --damp-run instead of --dry-run.
2900 print STDERR f_ <<END, $lrefname, $want;
2901 warning: git ls-remote suggests we want %s
2902 warning: and it should refer to %s
2903 warning: but git fetch didn't fetch that object to any relevant ref.
2904 warning: This may be due to a race with someone updating the server.
2905 warning: Will try again...
2907 next FETCH_ITERATION;
2910 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2912 runcmd_ordryrun_local @git, qw(update-ref -m),
2913 "dgit fetch git fetch fixup", $lrefname, $want;
2914 $lrfetchrefs_f{$lrefname} = $want;
2919 if (defined $csuite) {
2920 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2921 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2922 my ($objid,$objtype,$lrefname,$reftail) = @_;
2923 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2924 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2928 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2929 Dumper(\%lrfetchrefs_f);
2932 sub git_fetch_us () {
2933 # Want to fetch only what we are going to use, unless
2934 # deliberately-not-ff, in which case we must fetch everything.
2936 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2938 (quiltmode_splitbrain
2939 ? (map { $_->('*',access_nomdistro) }
2940 \&debiantag_new, \&debiantag_maintview)
2941 : debiantags('*',access_nomdistro));
2942 push @specs, server_branch($csuite);
2943 push @specs, $rewritemap;
2944 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2946 my $url = access_giturl();
2947 git_lrfetch_sane $url, 0, @specs;
2950 my @tagpats = debiantags('*',access_nomdistro);
2952 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2953 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2954 printdebug "currently $fullrefname=$objid\n";
2955 $here{$fullrefname} = $objid;
2957 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2958 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2959 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2960 printdebug "offered $lref=$objid\n";
2961 if (!defined $here{$lref}) {
2962 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2963 runcmd_ordryrun_local @upd;
2964 lrfetchref_used $fullrefname;
2965 } elsif ($here{$lref} eq $objid) {
2966 lrfetchref_used $fullrefname;
2968 print STDERR f_ "Not updating %s from %s to %s.\n",
2969 $lref, $here{$lref}, $objid;
2974 #---------- dsc and archive handling ----------
2976 sub mergeinfo_getclogp ($) {
2977 # Ensures thit $mi->{Clogp} exists and returns it
2979 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2982 sub mergeinfo_version ($) {
2983 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2986 sub fetch_from_archive_record_1 ($) {
2988 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2989 cmdoutput @git, qw(log -n2), $hash;
2990 # ... gives git a chance to complain if our commit is malformed
2993 sub fetch_from_archive_record_2 ($) {
2995 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2999 dryrun_report @upd_cmd;
3003 sub parse_dsc_field_def_dsc_distro () {
3004 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3005 dgit.default.distro);
3008 sub parse_dsc_field ($$) {
3009 my ($dsc, $what) = @_;
3011 foreach my $field (@ourdscfield) {
3012 $f = $dsc->{$field};
3017 progress f_ "%s: NO git hash", $what;
3018 parse_dsc_field_def_dsc_distro();
3019 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3020 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3021 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3022 $dsc_hint_tag = [ $dsc_hint_tag ];
3023 } elsif ($f =~ m/^\w+\s*$/) {
3025 parse_dsc_field_def_dsc_distro();
3026 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3028 progress f_ "%s: specified git hash", $what;
3030 fail f_ "%s: invalid Dgit info", $what;
3034 sub resolve_dsc_field_commit ($$) {
3035 my ($already_distro, $already_mapref) = @_;
3037 return unless defined $dsc_hash;
3040 defined $already_mapref &&
3041 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3042 ? $already_mapref : undef;
3046 my ($what, @fetch) = @_;
3048 local $idistro = $dsc_distro;
3049 my $lrf = lrfetchrefs;
3051 if (!$chase_dsc_distro) {
3052 progress f_ "not chasing .dsc distro %s: not fetching %s",
3057 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3059 my $url = access_giturl();
3060 if (!defined $url) {
3061 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3062 .dsc Dgit metadata is in context of distro %s
3063 for which we have no configured url and .dsc provides no hint
3066 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3067 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3068 parse_cfg_bool "dsc-url-proto-ok", 'false',
3069 cfg("dgit.dsc-url-proto-ok.$proto",
3070 "dgit.default.dsc-url-proto-ok")
3071 or fail f_ <<END, $dsc_distro, $proto;
3072 .dsc Dgit metadata is in context of distro %s
3073 for which we have no configured url;
3074 .dsc provides hinted url with protocol %s which is unsafe.
3075 (can be overridden by config - consult documentation)
3077 $url = $dsc_hint_url;
3080 git_lrfetch_sane $url, 1, @fetch;
3085 my $rewrite_enable = do {
3086 local $idistro = $dsc_distro;
3087 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3090 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3091 if (!defined $mapref) {
3092 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3093 $mapref = $lrf.'/'.$rewritemap;
3095 my $rewritemapdata = git_cat_file $mapref.':map';
3096 if (defined $rewritemapdata
3097 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3099 "server's git history rewrite map contains a relevant entry!";
3102 if (defined $dsc_hash) {
3103 progress __ "using rewritten git hash in place of .dsc value";
3105 progress __ "server data says .dsc hash is to be disregarded";
3110 if (!defined git_cat_file $dsc_hash) {
3111 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3112 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3113 defined git_cat_file $dsc_hash
3114 or fail f_ <<END, $dsc_hash;
3115 .dsc Dgit metadata requires commit %s
3116 but we could not obtain that object anywhere.
3118 foreach my $t (@tags) {
3119 my $fullrefname = $lrf.'/'.$t;
3120 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3121 next unless $lrfetchrefs_f{$fullrefname};
3122 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3123 lrfetchref_used $fullrefname;
3128 sub fetch_from_archive () {
3130 ensure_setup_existing_tree();
3132 # Ensures that lrref() is what is actually in the archive, one way
3133 # or another, according to us - ie this client's
3134 # appropritaely-updated archive view. Also returns the commit id.
3135 # If there is nothing in the archive, leaves lrref alone and
3136 # returns undef. git_fetch_us must have already been called.
3140 parse_dsc_field($dsc, __ 'last upload to archive');
3141 resolve_dsc_field_commit access_basedistro,
3142 lrfetchrefs."/".$rewritemap
3144 progress __ "no version available from the archive";
3147 # If the archive's .dsc has a Dgit field, there are three
3148 # relevant git commitids we need to choose between and/or merge
3150 # 1. $dsc_hash: the Dgit field from the archive
3151 # 2. $lastpush_hash: the suite branch on the dgit git server
3152 # 3. $lastfetch_hash: our local tracking brach for the suite
3154 # These may all be distinct and need not be in any fast forward
3157 # If the dsc was pushed to this suite, then the server suite
3158 # branch will have been updated; but it might have been pushed to
3159 # a different suite and copied by the archive. Conversely a more
3160 # recent version may have been pushed with dgit but not appeared
3161 # in the archive (yet).
3163 # $lastfetch_hash may be awkward because archive imports
3164 # (particularly, imports of Dgit-less .dscs) are performed only as
3165 # needed on individual clients, so different clients may perform a
3166 # different subset of them - and these imports are only made
3167 # public during push. So $lastfetch_hash may represent a set of
3168 # imports different to a subsequent upload by a different dgit
3171 # Our approach is as follows:
3173 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3174 # descendant of $dsc_hash, then it was pushed by a dgit user who
3175 # had based their work on $dsc_hash, so we should prefer it.
3176 # Otherwise, $dsc_hash was installed into this suite in the
3177 # archive other than by a dgit push, and (necessarily) after the
3178 # last dgit push into that suite (since a dgit push would have
3179 # been descended from the dgit server git branch); thus, in that
3180 # case, we prefer the archive's version (and produce a
3181 # pseudo-merge to overwrite the dgit server git branch).
3183 # (If there is no Dgit field in the archive's .dsc then
3184 # generate_commit_from_dsc uses the version numbers to decide
3185 # whether the suite branch or the archive is newer. If the suite
3186 # branch is newer it ignores the archive's .dsc; otherwise it
3187 # generates an import of the .dsc, and produces a pseudo-merge to
3188 # overwrite the suite branch with the archive contents.)
3190 # The outcome of that part of the algorithm is the `public view',
3191 # and is same for all dgit clients: it does not depend on any
3192 # unpublished history in the local tracking branch.
3194 # As between the public view and the local tracking branch: The
3195 # local tracking branch is only updated by dgit fetch, and
3196 # whenever dgit fetch runs it includes the public view in the
3197 # local tracking branch. Therefore if the public view is not
3198 # descended from the local tracking branch, the local tracking
3199 # branch must contain history which was imported from the archive
3200 # but never pushed; and, its tip is now out of date. So, we make
3201 # a pseudo-merge to overwrite the old imports and stitch the old
3204 # Finally: we do not necessarily reify the public view (as
3205 # described above). This is so that we do not end up stacking two
3206 # pseudo-merges. So what we actually do is figure out the inputs
3207 # to any public view pseudo-merge and put them in @mergeinputs.
3210 # $mergeinputs[]{Commit}
3211 # $mergeinputs[]{Info}
3212 # $mergeinputs[0] is the one whose tree we use
3213 # @mergeinputs is in the order we use in the actual commit)
3216 # $mergeinputs[]{Message} is a commit message to use
3217 # $mergeinputs[]{ReverseParents} if def specifies that parent
3218 # list should be in opposite order
3219 # Such an entry has no Commit or Info. It applies only when found
3220 # in the last entry. (This ugliness is to support making
3221 # identical imports to previous dgit versions.)
3223 my $lastpush_hash = git_get_ref(lrfetchref());
3224 printdebug "previous reference hash=$lastpush_hash\n";
3225 $lastpush_mergeinput = $lastpush_hash && {
3226 Commit => $lastpush_hash,
3227 Info => (__ "dgit suite branch on dgit git server"),
3230 my $lastfetch_hash = git_get_ref(lrref());
3231 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3232 my $lastfetch_mergeinput = $lastfetch_hash && {
3233 Commit => $lastfetch_hash,
3234 Info => (__ "dgit client's archive history view"),
3237 my $dsc_mergeinput = $dsc_hash && {
3238 Commit => $dsc_hash,
3239 Info => (__ "Dgit field in .dsc from archive"),
3243 my $del_lrfetchrefs = sub {
3246 printdebug "del_lrfetchrefs...\n";
3247 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3248 my $objid = $lrfetchrefs_d{$fullrefname};
3249 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3251 $gur ||= new IO::Handle;
3252 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3254 printf $gur "delete %s %s\n", $fullrefname, $objid;
3257 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3261 if (defined $dsc_hash) {
3262 ensure_we_have_orig();
3263 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3264 @mergeinputs = $dsc_mergeinput
3265 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3266 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3268 Git commit in archive is behind the last version allegedly pushed/uploaded.
3269 Commit referred to by archive: %s
3270 Last version pushed with dgit: %s
3273 __ $later_warning_msg or confess "$!";
3274 @mergeinputs = ($lastpush_mergeinput);
3276 # Archive has .dsc which is not a descendant of the last dgit
3277 # push. This can happen if the archive moves .dscs about.
3278 # Just follow its lead.
3279 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3280 progress __ "archive .dsc names newer git commit";
3281 @mergeinputs = ($dsc_mergeinput);
3283 progress __ "archive .dsc names other git commit, fixing up";
3284 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3288 @mergeinputs = generate_commits_from_dsc();
3289 # We have just done an import. Now, our import algorithm might
3290 # have been improved. But even so we do not want to generate
3291 # a new different import of the same package. So if the
3292 # version numbers are the same, just use our existing version.
3293 # If the version numbers are different, the archive has changed
3294 # (perhaps, rewound).
3295 if ($lastfetch_mergeinput &&
3296 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3297 (mergeinfo_version $mergeinputs[0]) )) {
3298 @mergeinputs = ($lastfetch_mergeinput);
3300 } elsif ($lastpush_hash) {
3301 # only in git, not in the archive yet
3302 @mergeinputs = ($lastpush_mergeinput);
3303 print STDERR f_ <<END,
3305 Package not found in the archive, but has allegedly been pushed using dgit.
3308 __ $later_warning_msg or confess "$!";
3310 printdebug "nothing found!\n";
3311 if (defined $skew_warning_vsn) {
3312 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3314 Warning: relevant archive skew detected.
3315 Archive allegedly contains %s
3316 But we were not able to obtain any version from the archive or git.
3320 unshift @end, $del_lrfetchrefs;
3324 if ($lastfetch_hash &&
3326 my $h = $_->{Commit};
3327 $h and is_fast_fwd($lastfetch_hash, $h);
3328 # If true, one of the existing parents of this commit
3329 # is a descendant of the $lastfetch_hash, so we'll
3330 # be ff from that automatically.
3334 push @mergeinputs, $lastfetch_mergeinput;
3337 printdebug "fetch mergeinfos:\n";
3338 foreach my $mi (@mergeinputs) {
3340 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3342 printdebug sprintf " ReverseParents=%d Message=%s",
3343 $mi->{ReverseParents}, $mi->{Message};
3347 my $compat_info= pop @mergeinputs
3348 if $mergeinputs[$#mergeinputs]{Message};
3350 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3353 if (@mergeinputs > 1) {
3355 my $tree_commit = $mergeinputs[0]{Commit};
3357 my $tree = get_tree_of_commit $tree_commit;;
3359 # We use the changelog author of the package in question the
3360 # author of this pseudo-merge. This is (roughly) correct if
3361 # this commit is simply representing aa non-dgit upload.
3362 # (Roughly because it does not record sponsorship - but we
3363 # don't have sponsorship info because that's in the .changes,
3364 # which isn't in the archivw.)
3366 # But, it might be that we are representing archive history
3367 # updates (including in-archive copies). These are not really
3368 # the responsibility of the person who created the .dsc, but
3369 # there is no-one whose name we should better use. (The
3370 # author of the .dsc-named commit is clearly worse.)
3372 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3373 my $author = clogp_authline $useclogp;
3374 my $cversion = getfield $useclogp, 'Version';
3376 my $mcf = dgit_privdir()."/mergecommit";
3377 open MC, ">", $mcf or die "$mcf $!";
3378 print MC <<END or confess "$!";
3382 my @parents = grep { $_->{Commit} } @mergeinputs;
3383 @parents = reverse @parents if $compat_info->{ReverseParents};
3384 print MC <<END or confess "$!" foreach @parents;
3388 print MC <<END or confess "$!";
3394 if (defined $compat_info->{Message}) {
3395 print MC $compat_info->{Message} or confess "$!";
3397 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3398 Record %s (%s) in archive suite %s
3402 my $message_add_info = sub {
3404 my $mversion = mergeinfo_version $mi;
3405 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3409 $message_add_info->($mergeinputs[0]);
3410 print MC __ <<END or confess "$!";
3411 should be treated as descended from
3413 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3416 close MC or confess "$!";
3417 $hash = make_commit $mcf;
3419 $hash = $mergeinputs[0]{Commit};
3421 printdebug "fetch hash=$hash\n";
3424 my ($lasth, $what) = @_;
3425 return unless $lasth;
3426 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3429 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3431 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3433 fetch_from_archive_record_1($hash);
3435 if (defined $skew_warning_vsn) {
3436 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3437 my $gotclogp = commit_getclogp($hash);
3438 my $got_vsn = getfield $gotclogp, 'Version';
3439 printdebug "SKEW CHECK GOT $got_vsn\n";
3440 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3441 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3443 Warning: archive skew detected. Using the available version:
3444 Archive allegedly contains %s
3445 We were able to obtain only %s
3451 if ($lastfetch_hash ne $hash) {
3452 fetch_from_archive_record_2($hash);
3455 lrfetchref_used lrfetchref();
3457 check_gitattrs($hash, __ "fetched source tree");
3459 unshift @end, $del_lrfetchrefs;
3463 sub set_local_git_config ($$) {
3465 runcmd @git, qw(config), $k, $v;
3468 sub setup_mergechangelogs (;$) {
3470 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3472 my $driver = 'dpkg-mergechangelogs';
3473 my $cb = "merge.$driver";
3474 confess unless defined $maindir;
3475 my $attrs = "$maindir_gitcommon/info/attributes";
3476 ensuredir "$maindir_gitcommon/info";
3478 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3479 if (!open ATTRS, "<", $attrs) {
3480 $!==ENOENT or die "$attrs: $!";
3484 next if m{^debian/changelog\s};
3485 print NATTRS $_, "\n" or confess "$!";
3487 ATTRS->error and confess "$!";
3490 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3493 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3494 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3496 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3499 sub setup_useremail (;$) {
3501 return unless $always || access_cfg_bool(1, 'setup-useremail');
3504 my ($k, $envvar) = @_;
3505 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3506 return unless defined $v;
3507 set_local_git_config "user.$k", $v;
3510 $setup->('email', 'DEBEMAIL');
3511 $setup->('name', 'DEBFULLNAME');
3514 sub ensure_setup_existing_tree () {
3515 my $k = "remote.$remotename.skipdefaultupdate";
3516 my $c = git_get_config $k;
3517 return if defined $c;
3518 set_local_git_config $k, 'true';
3521 sub open_main_gitattrs () {
3522 confess 'internal error no maindir' unless defined $maindir;
3523 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3525 or die "open $maindir_gitcommon/info/attributes: $!";
3529 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3531 sub is_gitattrs_setup () {
3534 # 1: gitattributes set up and should be left alone
3536 # 0: there is a dgit-defuse-attrs but it needs fixing
3537 # undef: there is none
3538 my $gai = open_main_gitattrs();
3539 return 0 unless $gai;
3541 next unless m{$gitattrs_ourmacro_re};
3542 return 1 if m{\s-working-tree-encoding\s};
3543 printdebug "is_gitattrs_setup: found old macro\n";
3546 $gai->error and confess "$!";
3547 printdebug "is_gitattrs_setup: found nothing\n";
3551 sub setup_gitattrs (;$) {
3553 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3555 my $already = is_gitattrs_setup();
3558 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3559 not doing further gitattributes setup
3563 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3564 my $af = "$maindir_gitcommon/info/attributes";
3565 ensuredir "$maindir_gitcommon/info";
3567 open GAO, "> $af.new" or confess "$!";
3568 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3572 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3574 my $gai = open_main_gitattrs();
3577 if (m{$gitattrs_ourmacro_re}) {
3578 die unless defined $already;
3582 print GAO $_, "\n" or confess "$!";
3584 $gai->error and confess "$!";
3586 close GAO or confess "$!";
3587 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3590 sub setup_new_tree () {
3591 setup_mergechangelogs();
3596 sub check_gitattrs ($$) {
3597 my ($treeish, $what) = @_;
3599 return if is_gitattrs_setup;
3602 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3604 my $gafl = new IO::File;
3605 open $gafl, "-|", @cmd or confess "$!";
3608 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3610 next unless m{(?:^|/)\.gitattributes$};
3612 # oh dear, found one
3613 print STDERR f_ <<END, $what;
3614 dgit: warning: %s contains .gitattributes
3615 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3620 # tree contains no .gitattributes files
3621 $?=0; $!=0; close $gafl or failedcmd @cmd;
3625 sub multisuite_suite_child ($$$) {
3626 my ($tsuite, $mergeinputs, $fn) = @_;
3627 # in child, sets things up, calls $fn->(), and returns undef
3628 # in parent, returns canonical suite name for $tsuite
3629 my $canonsuitefh = IO::File::new_tmpfile;
3630 my $pid = fork // confess "$!";
3634 $us .= " [$isuite]";
3635 $debugprefix .= " ";
3636 progress f_ "fetching %s...", $tsuite;
3637 canonicalise_suite();
3638 print $canonsuitefh $csuite, "\n" or confess "$!";
3639 close $canonsuitefh or confess "$!";
3643 waitpid $pid,0 == $pid or confess "$!";
3644 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3646 seek $canonsuitefh,0,0 or confess "$!";
3647 local $csuite = <$canonsuitefh>;
3648 confess "$!" unless defined $csuite && chomp $csuite;
3650 printdebug "multisuite $tsuite missing\n";
3653 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3654 push @$mergeinputs, {
3661 sub fork_for_multisuite ($) {
3662 my ($before_fetch_merge) = @_;
3663 # if nothing unusual, just returns ''
3666 # returns 0 to caller in child, to do first of the specified suites
3667 # in child, $csuite is not yet set
3669 # returns 1 to caller in parent, to finish up anything needed after
3670 # in parent, $csuite is set to canonicalised portmanteau
3672 my $org_isuite = $isuite;
3673 my @suites = split /\,/, $isuite;
3674 return '' unless @suites > 1;
3675 printdebug "fork_for_multisuite: @suites\n";
3679 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3681 return 0 unless defined $cbasesuite;
3683 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3684 unless @mergeinputs;
3686 my @csuites = ($cbasesuite);
3688 $before_fetch_merge->();
3690 foreach my $tsuite (@suites[1..$#suites]) {
3691 $tsuite =~ s/^-/$cbasesuite-/;
3692 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3699 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3700 push @csuites, $csubsuite;
3703 foreach my $mi (@mergeinputs) {
3704 my $ref = git_get_ref $mi->{Ref};
3705 die "$mi->{Ref} ?" unless length $ref;
3706 $mi->{Commit} = $ref;
3709 $csuite = join ",", @csuites;
3711 my $previous = git_get_ref lrref;
3713 unshift @mergeinputs, {
3714 Commit => $previous,
3715 Info => (__ "local combined tracking branch"),
3717 "archive seems to have rewound: local tracking branch is ahead!"),
3721 foreach my $ix (0..$#mergeinputs) {
3722 $mergeinputs[$ix]{Index} = $ix;
3725 @mergeinputs = sort {
3726 -version_compare(mergeinfo_version $a,
3727 mergeinfo_version $b) # highest version first
3729 $a->{Index} <=> $b->{Index}; # earliest in spec first
3735 foreach my $mi (@mergeinputs) {
3736 printdebug "multisuite merge check $mi->{Info}\n";
3737 foreach my $previous (@needed) {
3738 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3739 printdebug "multisuite merge un-needed $previous->{Info}\n";
3743 printdebug "multisuite merge this-needed\n";
3744 $mi->{Character} = '+';
3747 $needed[0]{Character} = '*';
3749 my $output = $needed[0]{Commit};
3752 printdebug "multisuite merge nontrivial\n";
3753 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3755 my $commit = "tree $tree\n";
3756 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3757 "Input branches:\n",
3760 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3761 printdebug "multisuite merge include $mi->{Info}\n";
3762 $mi->{Character} //= ' ';
3763 $commit .= "parent $mi->{Commit}\n";
3764 $msg .= sprintf " %s %-25s %s\n",
3766 (mergeinfo_version $mi),
3769 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3770 $msg .= __ "\nKey\n".
3771 " * marks the highest version branch, which choose to use\n".
3772 " + marks each branch which was not already an ancestor\n\n";
3774 "[dgit multi-suite $csuite]\n";
3776 "author $authline\n".
3777 "committer $authline\n\n";
3778 $output = make_commit_text $commit.$msg;
3779 printdebug "multisuite merge generated $output\n";
3782 fetch_from_archive_record_1($output);
3783 fetch_from_archive_record_2($output);
3785 progress f_ "calculated combined tracking suite %s", $csuite;
3790 sub clone_set_head () {
3791 open H, "> .git/HEAD" or confess "$!";
3792 print H "ref: ".lref()."\n" or confess "$!";
3793 close H or confess "$!";
3795 sub clone_finish ($) {
3797 runcmd @git, qw(reset --hard), lrref();
3798 runcmd qw(bash -ec), <<'END';
3800 git ls-tree -r --name-only -z HEAD | \
3801 xargs -0r touch -h -r . --
3803 printdone f_ "ready for work in %s", $dstdir;
3807 # in multisuite, returns twice!
3808 # once in parent after first suite fetched,
3809 # and then again in child after everything is finished
3811 badusage __ "dry run makes no sense with clone" unless act_local();
3813 my $multi_fetched = fork_for_multisuite(sub {
3814 printdebug "multi clone before fetch merge\n";
3818 if ($multi_fetched) {
3819 printdebug "multi clone after fetch merge\n";
3821 clone_finish($dstdir);
3824 printdebug "clone main body\n";
3826 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3830 canonicalise_suite();
3831 my $hasgit = check_for_git();
3833 runcmd @git, qw(init -q);
3837 my $giturl = access_giturl(1);
3838 if (defined $giturl) {
3839 runcmd @git, qw(remote add), 'origin', $giturl;
3842 progress __ "fetching existing git history";
3844 runcmd_ordryrun_local @git, qw(fetch origin);
3846 progress __ "starting new git history";
3848 fetch_from_archive() or no_such_package;
3849 my $vcsgiturl = $dsc->{'Vcs-Git'};
3850 if (length $vcsgiturl) {
3851 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3852 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3854 clone_finish($dstdir);
3858 canonicalise_suite();
3859 if (check_for_git()) {
3862 fetch_from_archive() or no_such_package();
3864 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3865 if (length $vcsgiturl and
3866 (grep { $csuite eq $_ }
3868 cfg 'dgit.vcs-git.suites')) {
3869 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3870 if (defined $current && $current ne $vcsgiturl) {
3871 print STDERR f_ <<END, $csuite;
3872 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3873 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3877 printdone f_ "fetched into %s", lrref();
3881 my $multi_fetched = fork_for_multisuite(sub { });
3882 fetch_one() unless $multi_fetched; # parent
3883 finish 0 if $multi_fetched eq '0'; # child
3888 runcmd_ordryrun_local @git, qw(merge -m),
3889 (f_ "Merge from %s [dgit]", $csuite),
3891 printdone f_ "fetched to %s and merged into HEAD", lrref();
3894 sub check_not_dirty () {
3895 my @forbid = qw(local-options local-patch-header);
3896 @forbid = map { "debian/source/$_" } @forbid;
3897 foreach my $f (@forbid) {
3898 if (stat_exists $f) {
3899 fail f_ "git tree contains %s", $f;
3903 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3904 push @cmd, qw(debian/source/format debian/source/options);
3907 my $bad = cmdoutput @cmd;
3910 "you have uncommitted changes to critical files, cannot continue:\n").
3914 return if $includedirty;
3916 git_check_unmodified();
3919 sub commit_admin ($) {
3922 runcmd_ordryrun_local @git, qw(commit -m), $m;
3925 sub quiltify_nofix_bail ($$) {
3926 my ($headinfo, $xinfo) = @_;
3927 if ($quilt_mode eq 'nofix') {
3929 "quilt fixup required but quilt mode is \`nofix'\n".
3930 "HEAD commit%s differs from tree implied by debian/patches%s",
3935 sub commit_quilty_patch () {
3936 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3938 foreach my $l (split /\n/, $output) {
3939 next unless $l =~ m/\S/;
3940 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3944 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3946 progress __ "nothing quilty to commit, ok.";
3949 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3950 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3951 runcmd_ordryrun_local @git, qw(add -f), @adds;
3952 commit_admin +(__ <<ENDT).<<END
3953 Commit Debian 3.0 (quilt) metadata
3956 [dgit ($our_version) quilt-fixup]
3960 sub get_source_format () {
3962 if (open F, "debian/source/options") {
3966 s/\s+$//; # ignore missing final newline
3968 my ($k, $v) = ($`, $'); #');
3969 $v =~ s/^"(.*)"$/$1/;
3975 F->error and confess "$!";
3978 confess "$!" unless $!==&ENOENT;
3981 if (!open F, "debian/source/format") {
3982 confess "$!" unless $!==&ENOENT;
3986 F->error and confess "$!";
3988 return ($_, \%options);
3991 sub madformat_wantfixup ($) {
3993 return 0 unless $format eq '3.0 (quilt)';
3994 our $quilt_mode_warned;
3995 if ($quilt_mode eq 'nocheck') {
3996 progress f_ "Not doing any fixup of \`%s'".
3997 " due to ----no-quilt-fixup or --quilt=nocheck", $format
3998 unless $quilt_mode_warned++;
4001 progress f_ "Format \`%s', need to check/update patch stack", $format
4002 unless $quilt_mode_warned++;
4006 sub maybe_split_brain_save ($$$) {
4007 my ($headref, $dgitview, $msg) = @_;
4008 # => message fragment "$saved" describing disposition of $dgitview
4009 # (used inside parens, in the English texts)
4010 my $save = $internal_object_save{'dgit-view'};
4011 return f_ "commit id %s", $dgitview unless defined $save;
4012 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4014 "dgit --dgit-view-save $msg HEAD=$headref",
4017 return f_ "and left in %s", $save;
4020 # An "infopair" is a tuple [ $thing, $what ]
4021 # (often $thing is a commit hash; $what is a description)
4023 sub infopair_cond_equal ($$) {
4025 $x->[0] eq $y->[0] or fail <<END;
4026 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4030 sub infopair_lrf_tag_lookup ($$) {
4031 my ($tagnames, $what) = @_;
4032 # $tagname may be an array ref
4033 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4034 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4035 foreach my $tagname (@tagnames) {
4036 my $lrefname = lrfetchrefs."/tags/$tagname";
4037 my $tagobj = $lrfetchrefs_f{$lrefname};
4038 next unless defined $tagobj;
4039 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4040 return [ git_rev_parse($tagobj), $what ];
4042 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4043 Wanted tag %s (%s) on dgit server, but not found
4045 : (f_ <<END, $what, "@tagnames");
4046 Wanted tag %s (one of: %s) on dgit server, but not found
4050 sub infopair_cond_ff ($$) {
4051 my ($anc,$desc) = @_;
4052 is_fast_fwd($anc->[0], $desc->[0]) or
4053 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4054 %s (%s) .. %s (%s) is not fast forward
4058 sub pseudomerge_version_check ($$) {
4059 my ($clogp, $archive_hash) = @_;
4061 my $arch_clogp = commit_getclogp $archive_hash;
4062 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4063 __ 'version currently in archive' ];
4064 if (defined $overwrite_version) {
4065 if (length $overwrite_version) {
4066 infopair_cond_equal([ $overwrite_version,
4067 '--overwrite= version' ],
4070 my $v = $i_arch_v->[0];
4072 "Checking package changelog for archive version %s ...", $v;
4075 my @xa = ("-f$v", "-t$v");
4076 my $vclogp = parsechangelog @xa;
4079 [ (getfield $vclogp, $fn),
4080 (f_ "%s field from dpkg-parsechangelog %s",
4083 my $cv = $gf->('Version');
4084 infopair_cond_equal($i_arch_v, $cv);
4085 $cd = $gf->('Distribution');
4089 $@ =~ s/^dgit: //gm;
4091 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4093 fail f_ <<END, $cd->[1], $cd->[0], $v
4095 Your tree seems to based on earlier (not uploaded) %s.
4097 if $cd->[0] =~ m/UNRELEASED/;
4101 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4105 sub pseudomerge_make_commit ($$$$ $$) {
4106 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4107 $msg_cmd, $msg_msg) = @_;
4108 progress f_ "Declaring that HEAD includes all changes in %s...",
4111 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4112 my $authline = clogp_authline $clogp;
4116 !defined $overwrite_version ? ""
4117 : !length $overwrite_version ? " --overwrite"
4118 : " --overwrite=".$overwrite_version;
4120 # Contributing parent is the first parent - that makes
4121 # git rev-list --first-parent DTRT.
4122 my $pmf = dgit_privdir()."/pseudomerge";
4123 open MC, ">", $pmf or die "$pmf $!";
4124 print MC <<END or confess "$!";
4127 parent $archive_hash
4135 close MC or confess "$!";
4137 return make_commit($pmf);
4140 sub splitbrain_pseudomerge ($$$$) {
4141 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4142 # => $merged_dgitview
4143 printdebug "splitbrain_pseudomerge...\n";
4145 # We: debian/PREVIOUS HEAD($maintview)
4146 # expect: o ----------------- o
4149 # a/d/PREVIOUS $dgitview
4152 # we do: `------------------ o
4156 return $dgitview unless defined $archive_hash;
4157 return $dgitview if deliberately_not_fast_forward();
4159 printdebug "splitbrain_pseudomerge...\n";
4161 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4163 if (!defined $overwrite_version) {
4164 progress __ "Checking that HEAD includes all changes in archive...";
4167 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4169 if (defined $overwrite_version) {
4171 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4172 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4173 __ "maintainer view tag");
4174 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4175 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4176 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4178 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4180 infopair_cond_equal($i_dgit, $i_archive);
4181 infopair_cond_ff($i_dep14, $i_dgit);
4182 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4185 $@ =~ s/^\n//; chomp $@;
4186 print STDERR <<END.(__ <<ENDT);
4189 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4194 my $arch_v = $i_arch_v->[0];
4195 my $r = pseudomerge_make_commit
4196 $clogp, $dgitview, $archive_hash, $i_arch_v,
4197 "dgit --quilt=$quilt_mode",
4198 (defined $overwrite_version
4199 ? f_ "Declare fast forward from %s\n", $arch_v
4200 : f_ "Make fast forward from %s\n", $arch_v);
4202 maybe_split_brain_save $maintview, $r, "pseudomerge";
4204 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4208 sub plain_overwrite_pseudomerge ($$$) {
4209 my ($clogp, $head, $archive_hash) = @_;
4211 printdebug "plain_overwrite_pseudomerge...";
4213 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4215 return $head if is_fast_fwd $archive_hash, $head;
4217 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4219 my $r = pseudomerge_make_commit
4220 $clogp, $head, $archive_hash, $i_arch_v,
4223 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4225 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4229 sub push_parse_changelog ($) {
4232 my $clogp = Dpkg::Control::Hash->new();
4233 $clogp->load($clogpfn) or die;
4235 my $clogpackage = getfield $clogp, 'Source';
4236 $package //= $clogpackage;
4237 fail f_ "-p specified %s but changelog specified %s",
4238 $package, $clogpackage
4239 unless $package eq $clogpackage;
4240 my $cversion = getfield $clogp, 'Version';
4242 if (!$we_are_initiator) {
4243 # rpush initiator can't do this because it doesn't have $isuite yet
4244 my $tag = debiantag($cversion, access_nomdistro);
4245 runcmd @git, qw(check-ref-format), $tag;
4248 my $dscfn = dscfn($cversion);
4250 return ($clogp, $cversion, $dscfn);
4253 sub push_parse_dsc ($$$) {
4254 my ($dscfn,$dscfnwhat, $cversion) = @_;
4255 $dsc = parsecontrol($dscfn,$dscfnwhat);
4256 my $dversion = getfield $dsc, 'Version';
4257 my $dscpackage = getfield $dsc, 'Source';
4258 ($dscpackage eq $package && $dversion eq $cversion) or
4259 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4260 $dscfn, $dscpackage, $dversion,
4261 $package, $cversion;
4264 sub push_tagwants ($$$$) {
4265 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4268 TagFn => \&debiantag,
4273 if (defined $maintviewhead) {
4275 TagFn => \&debiantag_maintview,
4276 Objid => $maintviewhead,
4277 TfSuffix => '-maintview',
4280 } elsif ($dodep14tag eq 'no' ? 0
4281 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4282 : $dodep14tag eq 'always'
4283 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4284 --dep14tag-always (or equivalent in config) means server must support
4285 both "new" and "maint" tag formats, but config says it doesn't.
4287 : die "$dodep14tag ?") {
4289 TagFn => \&debiantag_maintview,
4291 TfSuffix => '-dgit',
4295 foreach my $tw (@tagwants) {
4296 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4297 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4299 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4303 sub push_mktags ($$ $$ $) {
4305 $changesfile,$changesfilewhat,
4308 die unless $tagwants->[0]{View} eq 'dgit';
4310 my $declaredistro = access_nomdistro();
4311 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4312 $dsc->{$ourdscfield[0]} = join " ",
4313 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4315 $dsc->save("$dscfn.tmp") or confess "$!";
4317 my $changes = parsecontrol($changesfile,$changesfilewhat);
4318 foreach my $field (qw(Source Distribution Version)) {
4319 $changes->{$field} eq $clogp->{$field} or
4320 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4321 $field, $changes->{$field}, $clogp->{$field};
4324 my $cversion = getfield $clogp, 'Version';
4325 my $clogsuite = getfield $clogp, 'Distribution';
4327 # We make the git tag by hand because (a) that makes it easier
4328 # to control the "tagger" (b) we can do remote signing
4329 my $authline = clogp_authline $clogp;
4330 my $delibs = join(" ", "",@deliberatelies);
4334 my $tfn = $tw->{Tfn};
4335 my $head = $tw->{Objid};
4336 my $tag = $tw->{Tag};
4338 open TO, '>', $tfn->('.tmp') or confess "$!";
4339 print TO <<END or confess "$!";
4346 if ($tw->{View} eq 'dgit') {
4347 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4348 %s release %s for %s (%s) [dgit]
4351 print TO <<END or confess "$!";
4352 [dgit distro=$declaredistro$delibs]
4354 foreach my $ref (sort keys %previously) {
4355 print TO <<END or confess "$!";
4356 [dgit previously:$ref=$previously{$ref}]
4359 } elsif ($tw->{View} eq 'maint') {
4360 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4361 %s release %s for %s (%s)
4362 (maintainer view tag generated by dgit --quilt=%s)
4367 confess Dumper($tw)."?";
4370 close TO or confess "$!";
4372 my $tagobjfn = $tfn->('.tmp');
4374 if (!defined $keyid) {
4375 $keyid = access_cfg('keyid','RETURN-UNDEF');
4377 if (!defined $keyid) {
4378 $keyid = getfield $clogp, 'Maintainer';
4380 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4381 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4382 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4383 push @sign_cmd, $tfn->('.tmp');
4384 runcmd_ordryrun @sign_cmd;
4386 $tagobjfn = $tfn->('.signed.tmp');
4387 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4388 $tfn->('.tmp'), $tfn->('.tmp.asc');
4394 my @r = map { $mktag->($_); } @$tagwants;
4398 sub sign_changes ($) {
4399 my ($changesfile) = @_;
4401 my @debsign_cmd = @debsign;
4402 push @debsign_cmd, "-k$keyid" if defined $keyid;
4403 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4404 push @debsign_cmd, $changesfile;
4405 runcmd_ordryrun @debsign_cmd;
4410 printdebug "actually entering push\n";
4412 supplementary_message(__ <<'END');
4413 Push failed, while checking state of the archive.
4414 You can retry the push, after fixing the problem, if you like.
4416 if (check_for_git()) {
4419 my $archive_hash = fetch_from_archive();
4420 if (!$archive_hash) {
4422 fail __ "package appears to be new in this suite;".
4423 " if this is intentional, use --new";
4426 supplementary_message(__ <<'END');
4427 Push failed, while preparing your push.
4428 You can retry the push, after fixing the problem, if you like.
4433 access_giturl(); # check that success is vaguely likely
4434 rpush_handle_protovsn_bothends() if $we_are_initiator;
4436 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4437 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4439 responder_send_file('parsed-changelog', $clogpfn);
4441 my ($clogp, $cversion, $dscfn) =
4442 push_parse_changelog("$clogpfn");
4444 my $dscpath = "$buildproductsdir/$dscfn";
4445 stat_exists $dscpath or
4446 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4449 responder_send_file('dsc', $dscpath);
4451 push_parse_dsc($dscpath, $dscfn, $cversion);
4453 my $format = getfield $dsc, 'Format';
4455 my $symref = git_get_symref();
4456 my $actualhead = git_rev_parse('HEAD');
4458 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4459 if (quiltmode_splitbrain()) {
4460 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4461 fail f_ <<END, $ffq_prev, $quilt_mode;
4462 Branch is managed by git-debrebase (%s
4463 exists), but quilt mode (%s) implies a split view.
4464 Pass the right --quilt option or adjust your git config.
4465 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4468 runcmd_ordryrun_local @git_debrebase, 'stitch';
4469 $actualhead = git_rev_parse('HEAD');
4472 my $dgithead = $actualhead;
4473 my $maintviewhead = undef;
4475 my $upstreamversion = upstreamversion $clogp->{Version};
4477 if (madformat_wantfixup($format)) {
4478 # user might have not used dgit build, so maybe do this now:
4479 if ($do_split_brain) {
4480 changedir $playground;
4482 ($dgithead, $cachekey) =
4483 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4484 $dgithead or fail f_
4485 "--quilt=%s but no cached dgit view:
4486 perhaps HEAD changed since dgit build[-source] ?",
4489 if (!$do_split_brain) {
4490 # In split brain mode, do not attempt to incorporate dirty
4491 # stuff from the user's working tree. That would be mad.
4492 commit_quilty_patch();
4495 if ($do_split_brain) {
4496 $made_split_brain = 1;
4497 $dgithead = splitbrain_pseudomerge($clogp,
4498 $actualhead, $dgithead,
4500 $maintviewhead = $actualhead;
4502 prep_ud(); # so _only_subdir() works, below
4505 if (defined $overwrite_version && !defined $maintviewhead
4507 $dgithead = plain_overwrite_pseudomerge($clogp,
4515 if ($archive_hash) {
4516 if (is_fast_fwd($archive_hash, $dgithead)) {
4518 } elsif (deliberately_not_fast_forward) {
4521 fail __ "dgit push: HEAD is not a descendant".
4522 " of the archive's version.\n".
4523 "To overwrite the archive's contents,".
4524 " pass --overwrite[=VERSION].\n".
4525 "To rewind history, if permitted by the archive,".
4526 " use --deliberately-not-fast-forward.";
4530 confess unless !!$made_split_brain == !!$do_split_brain;
4532 changedir $playground;
4533 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4534 runcmd qw(dpkg-source -x --),
4535 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4536 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4537 check_for_vendor_patches() if madformat($dsc->{format});
4539 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4540 debugcmd "+",@diffcmd;
4542 my $r = system @diffcmd;
4545 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4546 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4549 my $raw = cmdoutput @git,
4550 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4552 foreach (split /\0/, $raw) {
4553 if (defined $changed) {
4554 push @mode_changes, "$changed: $_\n" if $changed;
4557 } elsif (m/^:0+ 0+ /) {
4559 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4560 $changed = "Mode change from $1 to $2"
4565 if (@mode_changes) {
4566 fail +(f_ <<ENDT, $dscfn).<<END
4567 HEAD specifies a different tree to %s:
4571 .(join '', @mode_changes)
4572 .(f_ <<ENDT, $tree, $referent);
4573 There is a problem with your source tree (see dgit(7) for some hints).
4574 To see a full diff, run git diff %s %s
4578 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4579 HEAD specifies a different tree to %s:
4583 Perhaps you forgot to build. Or perhaps there is a problem with your
4584 source tree (see dgit(7) for some hints). To see a full diff, run
4591 if (!$changesfile) {
4592 my $pat = changespat $cversion;
4593 my @cs = glob "$buildproductsdir/$pat";
4594 fail f_ "failed to find unique changes file".
4595 " (looked for %s in %s);".
4596 " perhaps you need to use dgit -C",
4597 $pat, $buildproductsdir
4599 ($changesfile) = @cs;
4601 $changesfile = "$buildproductsdir/$changesfile";
4604 # Check that changes and .dsc agree enough
4605 $changesfile =~ m{[^/]*$};
4606 my $changes = parsecontrol($changesfile,$&);
4607 files_compare_inputs($dsc, $changes)
4608 unless forceing [qw(dsc-changes-mismatch)];
4610 # Check whether this is a source only upload
4611 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4612 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4613 if ($sourceonlypolicy eq 'ok') {
4614 } elsif ($sourceonlypolicy eq 'always') {
4615 forceable_fail [qw(uploading-binaries)],
4616 __ "uploading binaries, although distro policy is source only"
4618 } elsif ($sourceonlypolicy eq 'never') {
4619 forceable_fail [qw(uploading-source-only)],
4620 __ "source-only upload, although distro policy requires .debs"
4622 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4623 forceable_fail [qw(uploading-source-only)],
4624 f_ "source-only upload, even though package is entirely NEW\n".
4625 "(this is contrary to policy in %s)",
4629 && !(archive_query('package_not_wholly_new', $package) // 1);
4631 badcfg f_ "unknown source-only-uploads policy \`%s'",
4635 # Perhaps adjust .dsc to contain right set of origs
4636 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4638 unless forceing [qw(changes-origs-exactly)];
4640 # Checks complete, we're going to try and go ahead:
4642 responder_send_file('changes',$changesfile);
4643 responder_send_command("param head $dgithead");
4644 responder_send_command("param csuite $csuite");
4645 responder_send_command("param isuite $isuite");
4646 responder_send_command("param tagformat new");
4647 if (defined $maintviewhead) {
4648 confess "internal error (protovsn=$protovsn)"
4649 if defined $protovsn and $protovsn < 4;
4650 responder_send_command("param maint-view $maintviewhead");
4653 # Perhaps send buildinfo(s) for signing
4654 my $changes_files = getfield $changes, 'Files';
4655 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4656 foreach my $bi (@buildinfos) {
4657 responder_send_command("param buildinfo-filename $bi");
4658 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4661 if (deliberately_not_fast_forward) {
4662 git_for_each_ref(lrfetchrefs, sub {
4663 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4664 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4665 responder_send_command("previously $rrefname=$objid");
4666 $previously{$rrefname} = $objid;
4670 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4671 dgit_privdir()."/tag");
4674 supplementary_message(__ <<'END');
4675 Push failed, while signing the tag.
4676 You can retry the push, after fixing the problem, if you like.
4678 # If we manage to sign but fail to record it anywhere, it's fine.
4679 if ($we_are_responder) {
4680 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4681 responder_receive_files('signed-tag', @tagobjfns);
4683 @tagobjfns = push_mktags($clogp,$dscpath,
4684 $changesfile,$changesfile,
4687 supplementary_message(__ <<'END');
4688 Push failed, *after* signing the tag.
4689 If you want to try again, you should use a new version number.
4692 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4694 foreach my $tw (@tagwants) {
4695 my $tag = $tw->{Tag};
4696 my $tagobjfn = $tw->{TagObjFn};
4698 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4699 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4700 runcmd_ordryrun_local
4701 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4704 supplementary_message(__ <<'END');
4705 Push failed, while updating the remote git repository - see messages above.
4706 If you want to try again, you should use a new version number.
4708 if (!check_for_git()) {
4709 create_remote_git_repo();
4712 my @pushrefs = $forceflag.$dgithead.":".rrref();
4713 foreach my $tw (@tagwants) {
4714 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4717 runcmd_ordryrun @git,
4718 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4719 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4721 supplementary_message(__ <<'END');
4722 Push failed, while obtaining signatures on the .changes and .dsc.
4723 If it was just that the signature failed, you may try again by using
4724 debsign by hand to sign the changes file (see the command dgit tried,
4725 above), and then dput that changes file to complete the upload.
4726 If you need to change the package, you must use a new version number.
4728 if ($we_are_responder) {
4729 my $dryrunsuffix = act_local() ? "" : ".tmp";
4730 my @rfiles = ($dscpath, $changesfile);
4731 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4732 responder_receive_files('signed-dsc-changes',
4733 map { "$_$dryrunsuffix" } @rfiles);
4736 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4738 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4740 sign_changes $changesfile;
4743 supplementary_message(f_ <<END, $changesfile);
4744 Push failed, while uploading package(s) to the archive server.
4745 You can retry the upload of exactly these same files with dput of:
4747 If that .changes file is broken, you will need to use a new version
4748 number for your next attempt at the upload.
4750 my $host = access_cfg('upload-host','RETURN-UNDEF');
4751 my @hostarg = defined($host) ? ($host,) : ();
4752 runcmd_ordryrun @dput, @hostarg, $changesfile;
4753 printdone f_ "pushed and uploaded %s", $cversion;
4755 supplementary_message('');
4756 responder_send_command("complete");
4760 not_necessarily_a_tree();
4765 badusage __ "-p is not allowed with clone; specify as argument instead"
4766 if defined $package;
4769 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4770 ($package,$isuite) = @ARGV;
4771 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4772 ($package,$dstdir) = @ARGV;
4773 } elsif (@ARGV==3) {
4774 ($package,$isuite,$dstdir) = @ARGV;
4776 badusage __ "incorrect arguments to dgit clone";
4780 $dstdir ||= "$package";
4781 if (stat_exists $dstdir) {
4782 fail f_ "%s already exists", $dstdir;
4786 if ($rmonerror && !$dryrun_level) {
4787 $cwd_remove= getcwd();
4789 return unless defined $cwd_remove;
4790 if (!chdir "$cwd_remove") {
4791 return if $!==&ENOENT;
4792 confess "chdir $cwd_remove: $!";
4794 printdebug "clone rmonerror removing $dstdir\n";
4796 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4797 } elsif (grep { $! == $_ }
4798 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4800 print STDERR f_ "check whether to remove %s: %s\n",
4807 $cwd_remove = undef;
4810 sub branchsuite () {
4811 my $branch = git_get_symref();
4812 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4819 sub package_from_d_control () {
4820 if (!defined $package) {
4821 my $sourcep = parsecontrol('debian/control','debian/control');
4822 $package = getfield $sourcep, 'Source';
4826 sub fetchpullargs () {
4827 package_from_d_control();
4829 $isuite = branchsuite();
4831 my $clogp = parsechangelog();
4832 my $clogsuite = getfield $clogp, 'Distribution';
4833 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4835 } elsif (@ARGV==1) {
4838 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4852 if (quiltmode_splitbrain()) {
4853 my ($format, $fopts) = get_source_format();
4854 madformat($format) and fail f_ <<END, $quilt_mode
4855 dgit pull not yet supported in split view mode (--quilt=%s)
4863 package_from_d_control();
4864 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4868 foreach my $canon (qw(0 1)) {
4873 canonicalise_suite();
4875 if (length git_get_ref lref()) {
4876 # local branch already exists, yay
4879 if (!length git_get_ref lrref()) {
4887 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4890 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4891 "dgit checkout $isuite";
4892 runcmd (@git, qw(checkout), lbranch());
4895 sub cmd_update_vcs_git () {
4897 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4898 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4900 ($specsuite) = (@ARGV);
4905 if ($ARGV[0] eq '-') {
4907 } elsif ($ARGV[0] eq '-') {
4912 package_from_d_control();
4914 if ($specsuite eq '.') {
4915 $ctrl = parsecontrol 'debian/control', 'debian/control';
4917 $isuite = $specsuite;
4921 my $url = getfield $ctrl, 'Vcs-Git';
4924 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4925 if (!defined $orgurl) {
4926 print STDERR f_ "setting up vcs-git: %s\n", $url;
4927 @cmd = (@git, qw(remote add vcs-git), $url);
4928 } elsif ($orgurl eq $url) {
4929 print STDERR f_ "vcs git already configured: %s\n", $url;
4931 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4932 @cmd = (@git, qw(remote set-url vcs-git), $url);
4934 runcmd_ordryrun_local @cmd;
4936 print f_ "fetching (%s)\n", "@ARGV";
4937 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4943 build_or_push_prep_early();
4945 build_or_push_prep_modes();
4949 } elsif (@ARGV==1) {
4950 ($specsuite) = (@ARGV);
4952 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4955 local ($package) = $existing_package; # this is a hack
4956 canonicalise_suite();
4958 canonicalise_suite();
4960 if (defined $specsuite &&
4961 $specsuite ne $isuite &&
4962 $specsuite ne $csuite) {
4963 fail f_ "dgit %s: changelog specifies %s (%s)".
4964 " but command line specifies %s",
4965 $subcommand, $isuite, $csuite, $specsuite;
4974 #---------- remote commands' implementation ----------
4976 sub pre_remote_push_build_host {
4977 my ($nrargs) = shift @ARGV;
4978 my (@rargs) = @ARGV[0..$nrargs-1];
4979 @ARGV = @ARGV[$nrargs..$#ARGV];
4981 my ($dir,$vsnwant) = @rargs;
4982 # vsnwant is a comma-separated list; we report which we have
4983 # chosen in our ready response (so other end can tell if they
4986 $we_are_responder = 1;
4987 $us .= " (build host)";
4989 open PI, "<&STDIN" or confess "$!";
4990 open STDIN, "/dev/null" or confess "$!";
4991 open PO, ">&STDOUT" or confess "$!";
4993 open STDOUT, ">&STDERR" or confess "$!";
4997 ($protovsn) = grep {
4998 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4999 } @rpushprotovsn_support;
5001 fail f_ "build host has dgit rpush protocol versions %s".
5002 " but invocation host has %s",
5003 (join ",", @rpushprotovsn_support), $vsnwant
5004 unless defined $protovsn;
5008 sub cmd_remote_push_build_host {
5009 responder_send_command("dgit-remote-push-ready $protovsn");
5013 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5014 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5015 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5016 # a good error message)
5018 sub rpush_handle_protovsn_bothends () {
5019 if ($protovsn < 4) {
5020 fail "negotiated protocol version $protovsn but need at least 4";
5028 my $report = i_child_report();
5029 if (defined $report) {
5030 printdebug "($report)\n";
5031 } elsif ($i_child_pid) {
5032 printdebug "(killing build host child $i_child_pid)\n";
5033 kill 15, $i_child_pid;
5035 if (defined $i_tmp && !defined $initiator_tempdir) {
5037 eval { rmtree $i_tmp; };
5042 return unless forkcheck_mainprocess();
5047 my ($base,$selector,@args) = @_;
5048 $selector =~ s/\-/_/g;
5049 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5053 not_necessarily_a_tree();
5058 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5066 push @rargs, join ",", @rpushprotovsn_support;
5069 push @rdgit, @ropts;
5070 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5072 my @cmd = (@ssh, $host, shellquote @rdgit);
5075 $we_are_initiator=1;
5077 if (defined $initiator_tempdir) {
5078 rmtree $initiator_tempdir;
5079 mkdir $initiator_tempdir, 0700
5080 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5081 $i_tmp = $initiator_tempdir;
5085 $i_child_pid = open2(\*RO, \*RI, @cmd);
5087 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5088 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5089 $supplementary_message = '' unless $protovsn >= 3;
5092 my ($icmd,$iargs) = initiator_expect {
5093 m/^(\S+)(?: (.*))?$/;
5096 i_method "i_resp", $icmd, $iargs;
5100 sub i_resp_progress ($) {
5102 my $msg = protocol_read_bytes \*RO, $rhs;
5106 sub i_resp_supplementary_message ($) {
5108 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5111 sub i_resp_complete {
5112 my $pid = $i_child_pid;
5113 $i_child_pid = undef; # prevents killing some other process with same pid
5114 printdebug "waiting for build host child $pid...\n";
5115 my $got = waitpid $pid, 0;
5116 confess "$!" unless $got == $pid;
5117 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5120 printdebug __ "all done\n";
5124 sub i_resp_file ($) {
5126 my $localname = i_method "i_localname", $keyword;
5127 my $localpath = "$i_tmp/$localname";
5128 stat_exists $localpath and
5129 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5130 protocol_receive_file \*RO, $localpath;
5131 i_method "i_file", $keyword;
5136 sub i_resp_param ($) {
5137 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5141 sub i_resp_previously ($) {
5142 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5143 or badproto \*RO, __ "bad previously spec";
5144 my $r = system qw(git check-ref-format), $1;
5145 confess "bad previously ref spec ($r)" if $r;
5146 $previously{$1} = $2;
5151 sub i_resp_want ($) {
5153 die "$keyword ?" if $i_wanted{$keyword}++;
5155 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5156 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5157 die unless $isuite =~ m/^$suite_re$/;
5160 rpush_handle_protovsn_bothends();
5162 fail f_ "rpush negotiated protocol version %s".
5163 " which does not support quilt mode %s",
5164 $protovsn, $quilt_mode
5165 if quiltmode_splitbrain && $protovsn < 4;
5167 my @localpaths = i_method "i_want", $keyword;
5168 printdebug "[[ $keyword @localpaths\n";
5169 foreach my $localpath (@localpaths) {
5170 protocol_send_file \*RI, $localpath;
5172 print RI "files-end\n" or confess "$!";
5175 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5177 sub i_localname_parsed_changelog {
5178 return "remote-changelog.822";
5180 sub i_file_parsed_changelog {
5181 ($i_clogp, $i_version, $i_dscfn) =
5182 push_parse_changelog "$i_tmp/remote-changelog.822";
5183 die if $i_dscfn =~ m#/|^\W#;
5186 sub i_localname_dsc {
5187 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5192 sub i_localname_buildinfo ($) {
5193 my $bi = $i_param{'buildinfo-filename'};
5194 defined $bi or badproto \*RO, "buildinfo before filename";
5195 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5196 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5197 or badproto \*RO, "improper buildinfo filename";
5200 sub i_file_buildinfo {
5201 my $bi = $i_param{'buildinfo-filename'};
5202 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5203 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5204 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5205 files_compare_inputs($bd, $ch);
5206 (getfield $bd, $_) eq (getfield $ch, $_) or
5207 fail f_ "buildinfo mismatch in field %s", $_
5208 foreach qw(Source Version);
5209 !defined $bd->{$_} or
5210 fail f_ "buildinfo contains forbidden field %s", $_
5211 foreach qw(Changes Changed-by Distribution);
5213 push @i_buildinfos, $bi;
5214 delete $i_param{'buildinfo-filename'};
5217 sub i_localname_changes {
5218 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5219 $i_changesfn = $i_dscfn;
5220 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5221 return $i_changesfn;
5223 sub i_file_changes { }
5225 sub i_want_signed_tag {
5226 printdebug Dumper(\%i_param, $i_dscfn);
5227 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5228 && defined $i_param{'csuite'}
5229 or badproto \*RO, "premature desire for signed-tag";
5230 my $head = $i_param{'head'};
5231 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5233 my $maintview = $i_param{'maint-view'};
5234 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5236 if ($protovsn >= 4) {
5237 my $p = $i_param{'tagformat'} // '<undef>';
5239 or badproto \*RO, "tag format mismatch: $p vs. new";
5242 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5244 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5246 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5249 push_mktags $i_clogp, $i_dscfn,
5250 $i_changesfn, (__ 'remote changes file'),
5254 sub i_want_signed_dsc_changes {
5255 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5256 sign_changes $i_changesfn;
5257 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5260 #---------- building etc. ----------
5266 #----- `3.0 (quilt)' handling -----
5268 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5270 sub quiltify_dpkg_commit ($$$;$) {
5271 my ($patchname,$author,$msg, $xinfo) = @_;
5274 mkpath '.git/dgit'; # we are in playtree
5275 my $descfn = ".git/dgit/quilt-description.tmp";
5276 open O, '>', $descfn or confess "$descfn: $!";
5277 $msg =~ s/\n+/\n\n/;
5278 print O <<END or confess "$!";
5280 ${xinfo}Subject: $msg
5284 close O or confess "$!";
5287 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5288 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5289 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5290 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5294 sub quiltify_trees_differ ($$;$$$) {
5295 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5296 # returns true iff the two tree objects differ other than in debian/
5297 # with $finegrained,
5298 # returns bitmask 01 - differ in upstream files except .gitignore
5299 # 02 - differ in .gitignore
5300 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5301 # is set for each modified .gitignore filename $fn
5302 # if $unrepres is defined, array ref to which is appeneded
5303 # a list of unrepresentable changes (removals of upstream files
5306 my @cmd = (@git, qw(diff-tree -z --no-renames));
5307 push @cmd, qw(--name-only) unless $unrepres;
5308 push @cmd, qw(-r) if $finegrained || $unrepres;
5310 my $diffs= cmdoutput @cmd;
5313 foreach my $f (split /\0/, $diffs) {
5314 if ($unrepres && !@lmodes) {
5315 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5318 my ($oldmode,$newmode) = @lmodes;
5321 next if $f =~ m#^debian(?:/.*)?$#s;
5325 die __ "not a plain file or symlink\n"
5326 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5327 $oldmode =~ m/^(?:10|12)\d{4}$/;
5328 if ($oldmode =~ m/[^0]/ &&
5329 $newmode =~ m/[^0]/) {
5330 # both old and new files exist
5331 die __ "mode or type changed\n" if $oldmode ne $newmode;
5332 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5333 } elsif ($oldmode =~ m/[^0]/) {
5335 die __ "deletion of symlink\n"
5336 unless $oldmode =~ m/^10/;
5339 die __ "creation with non-default mode\n"
5340 unless $newmode =~ m/^100644$/ or
5341 $newmode =~ m/^120000$/;
5345 local $/="\n"; chomp $@;
5346 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5350 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5351 $r |= $isignore ? 02 : 01;
5352 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5354 printdebug "quiltify_trees_differ $x $y => $r\n";
5358 sub quiltify_tree_sentinelfiles ($) {
5359 # lists the `sentinel' files present in the tree
5361 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5362 qw(-- debian/rules debian/control);
5367 sub quiltify_splitbrain ($$$$$$$) {
5368 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5369 $editedignores, $cachekey) = @_;
5370 my $gitignore_special = 1;
5371 if ($quilt_mode !~ m/gbp|dpm/) {
5372 # treat .gitignore just like any other upstream file
5373 $diffbits = { %$diffbits };
5374 $_ = !!$_ foreach values %$diffbits;
5375 $gitignore_special = 0;
5377 # We would like any commits we generate to be reproducible
5378 my @authline = clogp_authline($clogp);
5379 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5380 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5381 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5382 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5383 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5384 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5386 confess unless $do_split_brain;
5388 my $fulldiffhint = sub {
5390 my $cmd = "git diff $x $y -- :/ ':!debian'";
5391 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5392 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5396 if ($quilt_mode =~ m/gbp|unapplied/ &&
5397 ($diffbits->{O2H} & 01)) {
5399 "--quilt=%s specified, implying patches-unapplied git tree\n".
5400 " but git tree differs from orig in upstream files.",
5402 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5403 if (!stat_exists "debian/patches") {
5405 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5409 if ($quilt_mode =~ m/dpm/ &&
5410 ($diffbits->{H2A} & 01)) {
5411 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5412 --quilt=%s specified, implying patches-applied git tree
5413 but git tree differs from result of applying debian/patches to upstream
5416 if ($quilt_mode =~ m/gbp|unapplied/ &&
5417 ($diffbits->{O2A} & 01)) { # some patches
5418 progress __ "dgit view: creating patches-applied version using gbp pq";
5419 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5420 # gbp pq import creates a fresh branch; push back to dgit-view
5421 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5422 runcmd @git, qw(checkout -q dgit-view);
5424 if ($quilt_mode =~ m/gbp|dpm/ &&
5425 ($diffbits->{O2A} & 02)) {
5426 fail f_ <<END, $quilt_mode;
5427 --quilt=%s specified, implying that HEAD is for use with a
5428 tool which does not create patches for changes to upstream
5429 .gitignores: but, such patches exist in debian/patches.
5432 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5433 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5435 "dgit view: creating patch to represent .gitignore changes";
5436 ensuredir "debian/patches";
5437 my $gipatch = "debian/patches/auto-gitignore";
5438 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5439 stat GIPATCH or confess "$gipatch: $!";
5440 fail f_ "%s already exists; but want to create it".
5441 " to record .gitignore changes",
5444 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5445 Subject: Update .gitignore from Debian packaging branch
5447 The Debian packaging git branch contains these updates to the upstream
5448 .gitignore file(s). This patch is autogenerated, to provide these
5449 updates to users of the official Debian archive view of the package.
5452 [dgit ($our_version) update-gitignore]
5455 close GIPATCH or die "$gipatch: $!";
5456 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5457 $unapplied, $headref, "--", sort keys %$editedignores;
5458 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5459 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5461 defined read SERIES, $newline, 1 or confess "$!";
5462 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5463 print SERIES "auto-gitignore\n" or confess "$!";
5464 close SERIES or die $!;
5465 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5466 commit_admin +(__ <<END).<<ENDU
5467 Commit patch to update .gitignore
5470 [dgit ($our_version) update-gitignore-quilt-fixup]
5475 sub quiltify ($$$$) {
5476 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5478 # Quilt patchification algorithm
5480 # We search backwards through the history of the main tree's HEAD
5481 # (T) looking for a start commit S whose tree object is identical
5482 # to to the patch tip tree (ie the tree corresponding to the
5483 # current dpkg-committed patch series). For these purposes
5484 # `identical' disregards anything in debian/ - this wrinkle is
5485 # necessary because dpkg-source treates debian/ specially.
5487 # We can only traverse edges where at most one of the ancestors'
5488 # trees differs (in changes outside in debian/). And we cannot
5489 # handle edges which change .pc/ or debian/patches. To avoid
5490 # going down a rathole we avoid traversing edges which introduce
5491 # debian/rules or debian/control. And we set a limit on the
5492 # number of edges we are willing to look at.
5494 # If we succeed, we walk forwards again. For each traversed edge
5495 # PC (with P parent, C child) (starting with P=S and ending with
5496 # C=T) to we do this:
5498 # - dpkg-source --commit with a patch name and message derived from C
5499 # After traversing PT, we git commit the changes which
5500 # should be contained within debian/patches.
5502 # The search for the path S..T is breadth-first. We maintain a
5503 # todo list containing search nodes. A search node identifies a
5504 # commit, and looks something like this:
5506 # Commit => $git_commit_id,
5507 # Child => $c, # or undef if P=T
5508 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5509 # Nontrivial => true iff $p..$c has relevant changes
5516 my %considered; # saves being exponential on some weird graphs
5518 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5521 my ($search,$whynot) = @_;
5522 printdebug " search NOT $search->{Commit} $whynot\n";
5523 $search->{Whynot} = $whynot;
5524 push @nots, $search;
5525 no warnings qw(exiting);
5534 my $c = shift @todo;
5535 next if $considered{$c->{Commit}}++;
5537 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5539 printdebug "quiltify investigate $c->{Commit}\n";
5542 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5543 printdebug " search finished hooray!\n";
5548 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5549 if ($quilt_mode eq 'smash') {
5550 printdebug " search quitting smash\n";
5554 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5555 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5556 if $c_sentinels ne $t_sentinels;
5558 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5559 $commitdata =~ m/\n\n/;
5561 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5562 @parents = map { { Commit => $_, Child => $c } } @parents;
5564 $not->($c, __ "root commit") if !@parents;
5566 foreach my $p (@parents) {
5567 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5569 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5570 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5573 foreach my $p (@parents) {
5574 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5576 my @cmd= (@git, qw(diff-tree -r --name-only),
5577 $p->{Commit},$c->{Commit},
5578 qw(-- debian/patches .pc debian/source/format));
5579 my $patchstackchange = cmdoutput @cmd;
5580 if (length $patchstackchange) {
5581 $patchstackchange =~ s/\n/,/g;
5582 $not->($p, f_ "changed %s", $patchstackchange);
5585 printdebug " search queue P=$p->{Commit} ",
5586 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5592 printdebug "quiltify want to smash\n";
5595 my $x = $_[0]{Commit};
5596 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5599 if ($quilt_mode eq 'linear') {
5601 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5603 my $all_gdr = !!@nots;
5604 foreach my $notp (@nots) {
5605 my $c = $notp->{Child};
5606 my $cprange = $abbrev->($notp);
5607 $cprange .= "..".$abbrev->($c) if $c;
5608 print STDERR f_ "%s: %s: %s\n",
5609 $us, $cprange, $notp->{Whynot};
5610 $all_gdr &&= $notp->{Child} &&
5611 (git_cat_file $notp->{Child}{Commit}, 'commit')
5612 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5616 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5618 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5620 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5621 } elsif ($quilt_mode eq 'smash') {
5622 } elsif ($quilt_mode eq 'auto') {
5623 progress __ "quilt fixup cannot be linear, smashing...";
5625 confess "$quilt_mode ?";
5628 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5629 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5631 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5633 quiltify_dpkg_commit "auto-$version-$target-$time",
5634 (getfield $clogp, 'Maintainer'),
5635 (f_ "Automatically generated patch (%s)\n".
5636 "Last (up to) %s git changes, FYI:\n\n",
5637 $clogp->{Version}, $ncommits).
5642 progress __ "quiltify linearisation planning successful, executing...";
5644 for (my $p = $sref_S;
5645 my $c = $p->{Child};
5647 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5648 next unless $p->{Nontrivial};
5650 my $cc = $c->{Commit};
5652 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5653 $commitdata =~ m/\n\n/ or die "$c ?";
5656 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5659 my $commitdate = cmdoutput
5660 @git, qw(log -n1 --pretty=format:%aD), $cc;
5662 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5664 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5671 my $gbp_check_suitable = sub {
5676 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5677 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5678 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5679 die __ "is series file\n" if m{$series_filename_re}o;
5680 die __ "too long\n" if length > 200;
5682 return $_ unless $@;
5684 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5689 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5691 (\S+) \s* \n //ixm) {
5692 $patchname = $gbp_check_suitable->($1, 'Name');
5694 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5696 (\S+) \s* \n //ixm) {
5697 $patchdir = $gbp_check_suitable->($1, 'Topic');
5702 if (!defined $patchname) {
5703 $patchname = $title;
5704 $patchname =~ s/[.:]$//;
5707 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5708 my $translitname = $converter->convert($patchname);
5709 die unless defined $translitname;
5710 $patchname = $translitname;
5713 +(f_ "dgit: patch title transliteration error: %s", $@)
5715 $patchname =~ y/ A-Z/-a-z/;
5716 $patchname =~ y/-a-z0-9_.+=~//cd;
5717 $patchname =~ s/^\W/x-$&/;
5718 $patchname = substr($patchname,0,40);
5719 $patchname .= ".patch";
5721 if (!defined $patchdir) {
5724 if (length $patchdir) {
5725 $patchname = "$patchdir/$patchname";
5727 if ($patchname =~ m{^(.*)/}) {
5728 mkpath "debian/patches/$1";
5733 stat "debian/patches/$patchname$index";
5735 $!==ENOENT or confess "$patchname$index $!";
5737 runcmd @git, qw(checkout -q), $cc;
5739 # We use the tip's changelog so that dpkg-source doesn't
5740 # produce complaining messages from dpkg-parsechangelog. None
5741 # of the information dpkg-source gets from the changelog is
5742 # actually relevant - it gets put into the original message
5743 # which dpkg-source provides our stunt editor, and then
5745 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5747 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5748 "Date: $commitdate\n".
5749 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5751 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5755 sub build_maybe_quilt_fixup () {
5756 my ($format,$fopts) = get_source_format;
5757 return unless madformat_wantfixup $format;
5760 check_for_vendor_patches();
5762 my $clogp = parsechangelog();
5763 my $headref = git_rev_parse('HEAD');
5764 my $symref = git_get_symref();
5765 my $upstreamversion = upstreamversion $version;
5768 changedir $playground;
5770 my $splitbrain_cachekey;
5772 if ($do_split_brain) {
5774 ($cachehit, $splitbrain_cachekey) =
5775 quilt_check_splitbrain_cache($headref, $upstreamversion);
5782 unpack_playtree_need_cd_work($headref);
5783 if ($do_split_brain) {
5784 runcmd @git, qw(checkout -q -b dgit-view);
5785 # so long as work is not deleted, its current branch will
5786 # remain dgit-view, rather than master, so subsequent calls to
5787 # unpack_playtree_need_cd_work
5788 # will DTRT, resetting dgit-view.
5789 confess if $made_split_brain;
5790 $made_split_brain = 1;
5794 if ($fopts->{'single-debian-patch'}) {
5796 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5798 if quiltmode_splitbrain();
5799 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5801 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5802 $splitbrain_cachekey);
5805 if ($do_split_brain) {
5806 my $dgitview = git_rev_parse 'HEAD';
5809 reflog_cache_insert "refs/$splitbraincache",
5810 $splitbrain_cachekey, $dgitview;
5812 changedir "$playground/work";
5814 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5815 progress f_ "dgit view: created (%s)", $saved;
5819 runcmd_ordryrun_local
5820 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5823 sub build_check_quilt_splitbrain () {
5824 build_maybe_quilt_fixup();
5826 if ($do_split_brain) {
5827 fail <<END unless access_cfg_tagformats_can_splitbrain;
5828 quilt mode $quilt_mode requires split view so server needs to support
5829 both "new" and "maint" tag formats, but config says it doesn't.
5834 sub unpack_playtree_need_cd_work ($) {
5837 # prep_ud() must have been called already.
5838 if (!chdir "work") {
5839 # Check in the filesystem because sometimes we run prep_ud
5840 # in between multiple calls to unpack_playtree_need_cd_work.
5841 confess "$!" unless $!==ENOENT;
5842 mkdir "work" or confess "$!";
5844 mktree_in_ud_here();
5846 runcmd @git, qw(reset -q --hard), $headref;
5849 sub unpack_playtree_linkorigs ($$) {
5850 my ($upstreamversion, $fn) = @_;
5851 # calls $fn->($leafname);
5853 my $bpd_abs = bpd_abs();
5855 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5857 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5858 while ($!=0, defined(my $leaf = readdir QFD)) {
5859 my $f = bpd_abs()."/".$leaf;
5861 local ($debuglevel) = $debuglevel-1;
5862 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5864 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5865 printdebug "QF linkorigs $leaf, $f Y\n";
5866 link_ltarget $f, $leaf or die "$leaf $!";
5869 die "$buildproductsdir: $!" if $!;
5873 sub quilt_fixup_delete_pc () {
5874 runcmd @git, qw(rm -rqf .pc);
5875 commit_admin +(__ <<END).<<ENDU
5876 Commit removal of .pc (quilt series tracking data)
5879 [dgit ($our_version) upgrade quilt-remove-pc]
5883 sub quilt_fixup_singlepatch ($$$) {
5884 my ($clogp, $headref, $upstreamversion) = @_;
5886 progress __ "starting quiltify (single-debian-patch)";
5888 # dpkg-source --commit generates new patches even if
5889 # single-debian-patch is in debian/source/options. In order to
5890 # get it to generate debian/patches/debian-changes, it is
5891 # necessary to build the source package.
5893 unpack_playtree_linkorigs($upstreamversion, sub { });
5894 unpack_playtree_need_cd_work($headref);
5896 rmtree("debian/patches");
5898 runcmd @dpkgsource, qw(-b .);
5900 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5901 rename srcfn("$upstreamversion", "/debian/patches"),
5902 "work/debian/patches"
5904 or confess "install d/patches: $!";
5907 commit_quilty_patch();
5910 sub quilt_need_fake_dsc ($) {
5911 # cwd should be playground
5912 my ($upstreamversion) = @_;
5914 return if stat_exists "fake.dsc";
5915 # ^ OK to test this as a sentinel because if we created it
5916 # we must either have done the rest too, or crashed.
5918 my $fakeversion="$upstreamversion-~~DGITFAKE";
5920 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5921 print $fakedsc <<END or confess "$!";
5924 Version: $fakeversion
5928 my $dscaddfile=sub {
5931 my $md = new Digest::MD5;
5933 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5934 stat $fh or confess "$!";
5938 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5941 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5943 my @files=qw(debian/source/format debian/rules
5944 debian/control debian/changelog);
5945 foreach my $maybe (qw(debian/patches debian/source/options
5946 debian/tests/control)) {
5947 next unless stat_exists "$maindir/$maybe";
5948 push @files, $maybe;
5951 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5952 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5954 $dscaddfile->($debtar);
5955 close $fakedsc or confess "$!";
5958 sub quilt_fakedsc2unapplied ($$) {
5959 my ($headref, $upstreamversion) = @_;
5960 # must be run in the playground
5961 # quilt_need_fake_dsc must have been called
5963 quilt_need_fake_dsc($upstreamversion);
5965 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5967 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5968 rename $fakexdir, "fake" or die "$fakexdir $!";
5972 remove_stray_gits(__ "source package");
5973 mktree_in_ud_here();
5977 rmtree 'debian'; # git checkout commitish paths does not delete!
5978 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5979 my $unapplied=git_add_write_tree();
5980 printdebug "fake orig tree object $unapplied\n";
5984 sub quilt_check_splitbrain_cache ($$) {
5985 my ($headref, $upstreamversion) = @_;
5986 # Called only if we are in (potentially) split brain mode.
5987 # Called in playground.
5988 # Computes the cache key and looks in the cache.
5989 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5991 quilt_need_fake_dsc($upstreamversion);
5993 my $splitbrain_cachekey;
5996 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5998 # we look in the reflog of dgit-intern/quilt-cache
5999 # we look for an entry whose message is the key for the cache lookup
6000 my @cachekey = (qw(dgit), $our_version);
6001 push @cachekey, $upstreamversion;
6002 push @cachekey, $quilt_mode;
6003 push @cachekey, $headref;
6005 push @cachekey, hashfile('fake.dsc');
6007 my $srcshash = Digest::SHA->new(256);
6008 my %sfs = ( %INC, '$0(dgit)' => $0 );
6009 foreach my $sfk (sort keys %sfs) {
6010 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6011 $srcshash->add($sfk," ");
6012 $srcshash->add(hashfile($sfs{$sfk}));
6013 $srcshash->add("\n");
6015 push @cachekey, $srcshash->hexdigest();
6016 $splitbrain_cachekey = "@cachekey";
6018 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6020 my $cachehit = reflog_cache_lookup
6021 "refs/$splitbraincache", $splitbrain_cachekey;
6024 unpack_playtree_need_cd_work($headref);
6025 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6026 if ($cachehit ne $headref) {
6027 progress f_ "dgit view: found cached (%s)", $saved;
6028 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6029 $made_split_brain = 1;
6030 return ($cachehit, $splitbrain_cachekey);
6032 progress __ "dgit view: found cached, no changes required";
6033 return ($headref, $splitbrain_cachekey);
6036 printdebug "splitbrain cache miss\n";
6037 return (undef, $splitbrain_cachekey);
6040 sub quilt_fixup_multipatch ($$$) {
6041 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6043 progress f_ "examining quilt state (multiple patches, %s mode)",
6047 # - honour any existing .pc in case it has any strangeness
6048 # - determine the git commit corresponding to the tip of
6049 # the patch stack (if there is one)
6050 # - if there is such a git commit, convert each subsequent
6051 # git commit into a quilt patch with dpkg-source --commit
6052 # - otherwise convert all the differences in the tree into
6053 # a single git commit
6057 # Our git tree doesn't necessarily contain .pc. (Some versions of
6058 # dgit would include the .pc in the git tree.) If there isn't
6059 # one, we need to generate one by unpacking the patches that we
6062 # We first look for a .pc in the git tree. If there is one, we
6063 # will use it. (This is not the normal case.)
6065 # Otherwise need to regenerate .pc so that dpkg-source --commit
6066 # can work. We do this as follows:
6067 # 1. Collect all relevant .orig from parent directory
6068 # 2. Generate a debian.tar.gz out of
6069 # debian/{patches,rules,source/format,source/options}
6070 # 3. Generate a fake .dsc containing just these fields:
6071 # Format Source Version Files
6072 # 4. Extract the fake .dsc
6073 # Now the fake .dsc has a .pc directory.
6074 # (In fact we do this in every case, because in future we will
6075 # want to search for a good base commit for generating patches.)
6077 # Then we can actually do the dpkg-source --commit
6078 # 1. Make a new working tree with the same object
6079 # store as our main tree and check out the main
6081 # 2. Copy .pc from the fake's extraction, if necessary
6082 # 3. Run dpkg-source --commit
6083 # 4. If the result has changes to debian/, then
6084 # - git add them them
6085 # - git add .pc if we had a .pc in-tree
6087 # 5. If we had a .pc in-tree, delete it, and git commit
6088 # 6. Back in the main tree, fast forward to the new HEAD
6090 # Another situation we may have to cope with is gbp-style
6091 # patches-unapplied trees.
6093 # We would want to detect these, so we know to escape into
6094 # quilt_fixup_gbp. However, this is in general not possible.
6095 # Consider a package with a one patch which the dgit user reverts
6096 # (with git revert or the moral equivalent).
6098 # That is indistinguishable in contents from a patches-unapplied
6099 # tree. And looking at the history to distinguish them is not
6100 # useful because the user might have made a confusing-looking git
6101 # history structure (which ought to produce an error if dgit can't
6102 # cope, not a silent reintroduction of an unwanted patch).
6104 # So gbp users will have to pass an option. But we can usually
6105 # detect their failure to do so: if the tree is not a clean
6106 # patches-applied tree, quilt linearisation fails, but the tree
6107 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6108 # they want --quilt=unapplied.
6110 # To help detect this, when we are extracting the fake dsc, we
6111 # first extract it with --skip-patches, and then apply the patches
6112 # afterwards with dpkg-source --before-build. That lets us save a
6113 # tree object corresponding to .origs.
6115 if ($quilt_mode eq 'linear'
6116 && branch_is_gdr($headref)) {
6117 # This is much faster. It also makes patches that gdr
6118 # likes better for future updates without laundering.
6120 # However, it can fail in some casses where we would
6121 # succeed: if there are existing patches, which correspond
6122 # to a prefix of the branch, but are not in gbp/gdr
6123 # format, gdr will fail (exiting status 7), but we might
6124 # be able to figure out where to start linearising. That
6125 # will be slower so hopefully there's not much to do.
6127 unpack_playtree_need_cd_work $headref;
6129 my @cmd = (@git_debrebase,
6130 qw(--noop-ok -funclean-mixed -funclean-ordering
6131 make-patches --quiet-would-amend));
6132 # We tolerate soe snags that gdr wouldn't, by default.
6138 and not ($? == 7*256 or
6139 $? == -1 && $!==ENOENT);
6143 $headref = git_rev_parse('HEAD');
6148 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6152 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6154 if (system @bbcmd) {
6155 failedcmd @bbcmd if $? < 0;
6157 failed to apply your git tree's patch stack (from debian/patches/) to
6158 the corresponding upstream tarball(s). Your source tree and .orig
6159 are probably too inconsistent. dgit can only fix up certain kinds of
6160 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6166 unpack_playtree_need_cd_work($headref);
6169 if (stat_exists ".pc") {
6171 progress __ "Tree already contains .pc - will use it then delete it.";
6174 rename '../fake/.pc','.pc' or confess "$!";
6177 changedir '../fake';
6179 my $oldtiptree=git_add_write_tree();
6180 printdebug "fake o+d/p tree object $unapplied\n";
6181 changedir '../work';
6184 # We calculate some guesswork now about what kind of tree this might
6185 # be. This is mostly for error reporting.
6191 # O = orig, without patches applied
6192 # A = "applied", ie orig with H's debian/patches applied
6193 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6194 \%editedignores, \@unrepres),
6195 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6196 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6200 foreach my $bits (qw(01 02)) {
6201 foreach my $v (qw(O2H O2A H2A)) {
6202 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6205 printdebug "differences \@dl @dl.\n";
6208 "%s: base trees orig=%.20s o+d/p=%.20s",
6209 $us, $unapplied, $oldtiptree;
6211 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6212 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6213 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6214 $us, $dl[2], $dl[5];
6217 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6220 forceable_fail [qw(unrepresentable)], __ <<END;
6221 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6226 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6227 push @failsuggestion, [ 'unapplied', __
6228 "This might be a patches-unapplied branch." ];
6229 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6230 push @failsuggestion, [ 'applied', __
6231 "This might be a patches-applied branch." ];
6233 push @failsuggestion, [ 'quilt-mode', __
6234 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6236 push @failsuggestion, [ 'gitattrs', __
6237 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6238 if stat_exists '.gitattributes';
6240 push @failsuggestion, [ 'origs', __
6241 "Maybe orig tarball(s) are not identical to git representation?" ];
6243 if (quiltmode_splitbrain()) {
6244 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6245 $diffbits, \%editedignores,
6246 $splitbrain_cachekey);
6250 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6251 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6252 runcmd @git, qw(checkout -q), (qw(master dgit-view)[!!$do_split_brain]);
6254 if (!open P, '>>', ".pc/applied-patches") {
6255 $!==&ENOENT or confess "$!";
6260 commit_quilty_patch();
6262 if ($mustdeletepc) {
6263 quilt_fixup_delete_pc();
6267 sub quilt_fixup_editor () {
6268 my $descfn = $ENV{$fakeeditorenv};
6269 my $editing = $ARGV[$#ARGV];
6270 open I1, '<', $descfn or confess "$descfn: $!";
6271 open I2, '<', $editing or confess "$editing: $!";
6272 unlink $editing or confess "$editing: $!";
6273 open O, '>', $editing or confess "$editing: $!";
6274 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6277 $copying ||= m/^\-\-\- /;
6278 next unless $copying;
6279 print O or confess "$!";
6281 I2->error and confess "$!";
6286 sub maybe_apply_patches_dirtily () {
6287 return unless $quilt_mode =~ m/gbp|unapplied/;
6288 print STDERR __ <<END or confess "$!";
6290 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6291 dgit: Have to apply the patches - making the tree dirty.
6292 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6295 $patches_applied_dirtily = 01;
6296 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6297 runcmd qw(dpkg-source --before-build .);
6300 sub maybe_unapply_patches_again () {
6301 progress __ "dgit: Unapplying patches again to tidy up the tree."
6302 if $patches_applied_dirtily;
6303 runcmd qw(dpkg-source --after-build .)
6304 if $patches_applied_dirtily & 01;
6306 if $patches_applied_dirtily & 02;
6307 $patches_applied_dirtily = 0;
6310 #----- other building -----
6312 sub clean_tree_check_git ($$$) {
6313 my ($honour_ignores, $message, $ignmessage) = @_;
6314 my @cmd = (@git, qw(clean -dn));
6315 push @cmd, qw(-x) unless $honour_ignores;
6316 my $leftovers = cmdoutput @cmd;
6317 if (length $leftovers) {
6318 print STDERR $leftovers, "\n" or confess "$!";
6319 $message .= $ignmessage if $honour_ignores;
6324 sub clean_tree_check_git_wd ($) {
6326 return if $cleanmode =~ m{no-check};
6327 return if $patches_applied_dirtily; # yuk
6328 clean_tree_check_git +($cleanmode !~ m{all-check}),
6329 $message, "\n".__ <<END;
6330 If this is just missing .gitignore entries, use a different clean
6331 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6332 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6336 sub clean_tree_check () {
6337 # This function needs to not care about modified but tracked files.
6338 # That was done by check_not_dirty, and by now we may have run
6339 # the rules clean target which might modify tracked files (!)
6340 if ($cleanmode =~ m{^check}) {
6341 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6342 "tree contains uncommitted files and --clean=check specified", '';
6343 } elsif ($cleanmode =~ m{^dpkg-source}) {
6344 clean_tree_check_git_wd __
6345 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6346 } elsif ($cleanmode =~ m{^git}) {
6347 clean_tree_check_git 1, __
6348 "tree contains uncommited, untracked, unignored files\n".
6349 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6350 } elsif ($cleanmode eq 'none') {
6352 confess "$cleanmode ?";
6357 # We always clean the tree ourselves, rather than leave it to the
6358 # builder (dpkg-source, or soemthing which calls dpkg-source).
6359 if ($cleanmode =~ m{^dpkg-source}) {
6360 my @cmd = @dpkgbuildpackage;
6361 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6362 push @cmd, qw(-T clean);
6363 maybe_apply_patches_dirtily();
6364 runcmd_ordryrun_local @cmd;
6365 clean_tree_check_git_wd __
6366 "tree contains uncommitted files (after running rules clean)";
6367 } elsif ($cleanmode =~ m{^git(?!-)}) {
6368 runcmd_ordryrun_local @git, qw(clean -xdf);
6369 } elsif ($cleanmode =~ m{^git-ff}) {
6370 runcmd_ordryrun_local @git, qw(clean -xdff);
6371 } elsif ($cleanmode =~ m{^check}) {
6373 } elsif ($cleanmode eq 'none') {
6375 confess "$cleanmode ?";
6380 badusage __ "clean takes no additional arguments" if @ARGV;
6383 maybe_unapply_patches_again();
6386 # return values from massage_dbp_args are one or both of these flags
6387 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6388 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6390 sub build_or_push_prep_early () {
6391 our $build_or_push_prep_early_done //= 0;
6392 return if $build_or_push_prep_early_done++;
6393 badusage f_ "-p is not allowed with dgit %s", $subcommand
6394 if defined $package;
6395 my $clogp = parsechangelog();
6396 $isuite = getfield $clogp, 'Distribution';
6397 $package = getfield $clogp, 'Source';
6398 $version = getfield $clogp, 'Version';
6399 $dscfn = dscfn($version);
6402 sub build_or_push_prep_modes () {
6403 my ($format,) = get_source_format();
6404 printdebug "format $format, quilt mode $quilt_mode\n";
6405 if (madformat_wantfixup($format) && quiltmode_splitbrain()) {
6406 $do_split_brain = 1;
6408 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
6409 if $do_split_brain && $includedirty;
6412 sub build_prep_early () {
6413 build_or_push_prep_early();
6415 build_or_push_prep_modes();
6419 sub build_prep ($) {
6423 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6424 # Clean the tree because we're going to use the contents of
6425 # $maindir. (We trying to include dirty changes in the source
6426 # package, or we are running the builder in $maindir.)
6427 || $cleanmode =~ m{always}) {
6428 # Or because the user asked us to.
6431 # We don't actually need to do anything in $maindir, but we
6432 # should do some kind of cleanliness check because (i) the
6433 # user may have forgotten a `git add', and (ii) if the user
6434 # said -wc we should still do the check.
6437 build_check_quilt_splitbrain();
6439 my $pat = changespat $version;
6440 foreach my $f (glob "$buildproductsdir/$pat") {
6443 fail f_ "remove old changes file %s: %s", $f, $!;
6445 progress f_ "would remove %s", $f;
6451 sub changesopts_initial () {
6452 my @opts =@changesopts[1..$#changesopts];
6455 sub changesopts_version () {
6456 if (!defined $changes_since_version) {
6459 @vsns = archive_query('archive_query');
6460 my @quirk = access_quirk();
6461 if ($quirk[0] eq 'backports') {
6462 local $isuite = $quirk[2];
6464 canonicalise_suite();
6465 push @vsns, archive_query('archive_query');
6471 "archive query failed (queried because --since-version not specified)";
6474 @vsns = map { $_->[0] } @vsns;
6475 @vsns = sort { -version_compare($a, $b) } @vsns;
6476 $changes_since_version = $vsns[0];
6477 progress f_ "changelog will contain changes since %s", $vsns[0];
6479 $changes_since_version = '_';
6480 progress __ "package seems new, not specifying -v<version>";
6483 if ($changes_since_version ne '_') {
6484 return ("-v$changes_since_version");
6490 sub changesopts () {
6491 return (changesopts_initial(), changesopts_version());
6494 sub massage_dbp_args ($;$) {
6495 my ($cmd,$xargs) = @_;
6496 # Since we split the source build out so we can do strange things
6497 # to it, massage the arguments to dpkg-buildpackage so that the
6498 # main build doessn't build source (or add an argument to stop it
6499 # building source by default).
6500 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6501 # -nc has the side effect of specifying -b if nothing else specified
6502 # and some combinations of -S, -b, et al, are errors, rather than
6503 # later simply overriding earlie. So we need to:
6504 # - search the command line for these options
6505 # - pick the last one
6506 # - perhaps add our own as a default
6507 # - perhaps adjust it to the corresponding non-source-building version
6509 foreach my $l ($cmd, $xargs) {
6511 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6514 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6515 my $r = WANTSRC_BUILDER;
6516 printdebug "massage split $dmode.\n";
6517 if ($dmode =~ s/^--build=//) {
6519 my @d = split /,/, $dmode;
6520 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6521 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6522 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6523 fail __ "Wanted to build nothing!" unless $r;
6524 $dmode = '--build='. join ',', grep m/./, @d;
6527 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6528 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6529 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6532 printdebug "massage done $r $dmode.\n";
6534 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6540 my $wasdir = must_getcwd();
6541 changedir $buildproductsdir;
6546 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6547 sub postbuild_mergechanges ($) {
6548 my ($msg_if_onlyone) = @_;
6549 # If there is only one .changes file, fail with $msg_if_onlyone,
6550 # or if that is undef, be a no-op.
6551 # Returns the changes file to report to the user.
6552 my $pat = changespat $version;
6553 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6554 @changesfiles = sort {
6555 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6559 if (@changesfiles==1) {
6560 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6561 only one changes file from build (%s)
6563 if defined $msg_if_onlyone;
6564 $result = $changesfiles[0];
6565 } elsif (@changesfiles==2) {
6566 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6567 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6568 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6571 runcmd_ordryrun_local @mergechanges, @changesfiles;
6572 my $multichanges = changespat $version,'multi';
6574 stat_exists $multichanges or fail f_
6575 "%s unexpectedly not created by build", $multichanges;
6576 foreach my $cf (glob $pat) {
6577 next if $cf eq $multichanges;
6578 rename "$cf", "$cf.inmulti" or fail f_
6579 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6582 $result = $multichanges;
6584 fail f_ "wrong number of different changes files (%s)",
6587 printdone f_ "build successful, results in %s\n", $result
6591 sub midbuild_checkchanges () {
6592 my $pat = changespat $version;
6593 return if $rmchanges;
6594 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6596 $_ ne changespat $version,'source' and
6597 $_ ne changespat $version,'multi'
6599 fail +(f_ <<END, $pat, "@unwanted")
6600 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6601 Suggest you delete %s.
6606 sub midbuild_checkchanges_vanilla ($) {
6608 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6611 sub postbuild_mergechanges_vanilla ($) {
6613 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6615 postbuild_mergechanges(undef);
6618 printdone __ "build successful\n";
6624 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6625 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6626 %s: warning: build-products-dir will be ignored; files will go to ..
6628 $buildproductsdir = '..';
6629 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6630 my $wantsrc = massage_dbp_args \@dbp;
6631 build_prep($wantsrc);
6632 if ($wantsrc & WANTSRC_SOURCE) {
6634 midbuild_checkchanges_vanilla $wantsrc;
6636 if ($wantsrc & WANTSRC_BUILDER) {
6637 push @dbp, changesopts_version();
6638 maybe_apply_patches_dirtily();
6639 runcmd_ordryrun_local @dbp;
6641 maybe_unapply_patches_again();
6642 postbuild_mergechanges_vanilla $wantsrc;
6646 $quilt_mode //= 'gbp';
6652 # gbp can make .origs out of thin air. In my tests it does this
6653 # even for a 1.0 format package, with no origs present. So I
6654 # guess it keys off just the version number. We don't know
6655 # exactly what .origs ought to exist, but let's assume that we
6656 # should run gbp if: the version has an upstream part and the main
6658 my $upstreamversion = upstreamversion $version;
6659 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6660 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6662 if ($gbp_make_orig) {
6664 $cleanmode = 'none'; # don't do it again
6667 my @dbp = @dpkgbuildpackage;
6669 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6671 if (!length $gbp_build[0]) {
6672 if (length executable_on_path('git-buildpackage')) {
6673 $gbp_build[0] = qw(git-buildpackage);
6675 $gbp_build[0] = 'gbp buildpackage';
6678 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6680 push @cmd, (qw(-us -uc --git-no-sign-tags),
6681 "--git-builder=".(shellquote @dbp));
6683 if ($gbp_make_orig) {
6684 my $priv = dgit_privdir();
6685 my $ok = "$priv/origs-gen-ok";
6686 unlink $ok or $!==&ENOENT or confess "$!";
6687 my @origs_cmd = @cmd;
6688 push @origs_cmd, qw(--git-cleaner=true);
6689 push @origs_cmd, "--git-prebuild=".
6690 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6691 push @origs_cmd, @ARGV;
6693 debugcmd @origs_cmd;
6695 do { local $!; stat_exists $ok; }
6696 or failedcmd @origs_cmd;
6698 dryrun_report @origs_cmd;
6702 build_prep($wantsrc);
6703 if ($wantsrc & WANTSRC_SOURCE) {
6705 midbuild_checkchanges_vanilla $wantsrc;
6707 push @cmd, '--git-cleaner=true';
6709 maybe_unapply_patches_again();
6710 if ($wantsrc & WANTSRC_BUILDER) {
6711 push @cmd, changesopts();
6712 runcmd_ordryrun_local @cmd, @ARGV;
6714 postbuild_mergechanges_vanilla $wantsrc;
6716 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6718 sub building_source_in_playtree {
6719 # If $includedirty, we have to build the source package from the
6720 # working tree, not a playtree, so that uncommitted changes are
6721 # included (copying or hardlinking them into the playtree could
6724 # Note that if we are building a source package in split brain
6725 # mode we do not support including uncommitted changes, because
6726 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6727 # building a source package)) => !$includedirty
6728 return !$includedirty;
6732 $sourcechanges = changespat $version,'source';
6734 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6735 or fail f_ "remove %s: %s", $sourcechanges, $!;
6737 # confess unless !!$made_split_brain == !!$do_split_brain;
6739 my @cmd = (@dpkgsource, qw(-b --));
6741 if (building_source_in_playtree()) {
6743 my $headref = git_rev_parse('HEAD');
6744 # If we are in split brain, there is already a playtree with
6745 # the thing we should package into a .dsc (thanks to quilt
6746 # fixup). If not, make a playtree
6747 prep_ud() unless $made_split_brain;
6748 changedir $playground;
6749 unless ($made_split_brain) {
6750 my $upstreamversion = upstreamversion $version;
6751 unpack_playtree_linkorigs($upstreamversion, sub { });
6752 unpack_playtree_need_cd_work($headref);
6756 $leafdir = basename $maindir;
6758 if ($buildproductsdir ne '..') {
6759 # Well, we are going to run dpkg-source -b which consumes
6760 # origs from .. and generates output there. To make this
6761 # work when the bpd is not .. , we would have to (i) link
6762 # origs from bpd to .. , (ii) check for files that
6763 # dpkg-source -b would/might overwrite, and afterwards
6764 # (iii) move all the outputs back to the bpd (iv) except
6765 # for the origs which should be deleted from .. if they
6766 # weren't there beforehand. And if there is an error and
6767 # we don't run to completion we would necessarily leave a
6768 # mess. This is too much. The real way to fix this
6769 # is for dpkg-source to have bpd support.
6770 confess unless $includedirty;
6772 "--include-dirty not supported with --build-products-dir, sorry";
6777 runcmd_ordryrun_local @cmd, $leafdir;
6780 runcmd_ordryrun_local qw(sh -ec),
6781 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6782 @dpkggenchanges, qw(-S), changesopts();
6785 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6786 $dsc = parsecontrol($dscfn, "source package");
6790 printdebug " renaming ($why) $l\n";
6791 rename_link_xf 0, "$l", bpd_abs()."/$l"
6792 or fail f_ "put in place new built file (%s): %s", $l, $@;
6794 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6795 $l =~ m/\S+$/ or next;
6798 $mv->('dsc', $dscfn);
6799 $mv->('changes', $sourcechanges);
6804 sub cmd_build_source {
6805 badusage __ "build-source takes no additional arguments" if @ARGV;
6806 build_prep(WANTSRC_SOURCE);
6808 maybe_unapply_patches_again();
6809 printdone f_ "source built, results in %s and %s",
6810 $dscfn, $sourcechanges;
6813 sub cmd_push_source {
6816 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6817 "sense with push-source!"
6819 build_check_quilt_splitbrain();
6821 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6822 __ "source changes file");
6823 unless (test_source_only_changes($changes)) {
6824 fail __ "user-specified changes file is not source-only";
6827 # Building a source package is very fast, so just do it
6829 confess "er, patches are applied dirtily but shouldn't be.."
6830 if $patches_applied_dirtily;
6831 $changesfile = $sourcechanges;
6836 sub binary_builder {
6837 my ($bbuilder, $pbmc_msg, @args) = @_;
6838 build_prep(WANTSRC_SOURCE);
6840 midbuild_checkchanges();
6843 stat_exists $dscfn or fail f_
6844 "%s (in build products dir): %s", $dscfn, $!;
6845 stat_exists $sourcechanges or fail f_
6846 "%s (in build products dir): %s", $sourcechanges, $!;
6848 runcmd_ordryrun_local @$bbuilder, @args;
6850 maybe_unapply_patches_again();
6852 postbuild_mergechanges($pbmc_msg);
6858 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6859 perhaps you need to pass -A ? (sbuild's default is to build only
6860 arch-specific binaries; dgit 1.4 used to override that.)
6865 my ($pbuilder) = @_;
6867 # @ARGV is allowed to contain only things that should be passed to
6868 # pbuilder under debbuildopts; just massage those
6869 my $wantsrc = massage_dbp_args \@ARGV;
6871 "you asked for a builder but your debbuildopts didn't ask for".
6872 " any binaries -- is this really what you meant?"
6873 unless $wantsrc & WANTSRC_BUILDER;
6875 "we must build a .dsc to pass to the builder but your debbuiltopts".
6876 " forbids the building of a source package; cannot continue"
6877 unless $wantsrc & WANTSRC_SOURCE;
6878 # We do not want to include the verb "build" in @pbuilder because
6879 # the user can customise @pbuilder and they shouldn't be required
6880 # to include "build" in their customised value. However, if the
6881 # user passes any additional args to pbuilder using the dgit
6882 # option --pbuilder:foo, such args need to come after the "build"
6883 # verb. opts_opt_multi_cmd does all of that.
6884 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6885 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6890 pbuilder(\@pbuilder);
6893 sub cmd_cowbuilder {
6894 pbuilder(\@cowbuilder);
6897 sub cmd_quilt_fixup {
6898 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6901 build_maybe_quilt_fixup();
6904 sub cmd_print_unapplied_treeish {
6905 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6907 my $headref = git_rev_parse('HEAD');
6908 my $clogp = commit_getclogp $headref;
6909 $package = getfield $clogp, 'Source';
6910 $version = getfield $clogp, 'Version';
6911 $isuite = getfield $clogp, 'Distribution';
6912 $csuite = $isuite; # we want this to be offline!
6916 changedir $playground;
6917 my $uv = upstreamversion $version;
6918 my $u = quilt_fakedsc2unapplied($headref, $uv);
6919 print $u, "\n" or confess "$!";
6922 sub import_dsc_result {
6923 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6924 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6926 check_gitattrs($newhash, __ "source tree");
6928 progress f_ "dgit: import-dsc: %s", $what_msg;
6931 sub cmd_import_dsc {
6935 last unless $ARGV[0] =~ m/^-/;
6938 if (m/^--require-valid-signature$/) {
6941 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6945 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6947 my ($dscfn, $dstbranch) = @ARGV;
6949 badusage __ "dry run makes no sense with import-dsc"
6952 my $force = $dstbranch =~ s/^\+// ? +1 :
6953 $dstbranch =~ s/^\.\.// ? -1 :
6955 my $info = $force ? " $&" : '';
6956 $info = "$dscfn$info";
6958 my $specbranch = $dstbranch;
6959 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6960 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6962 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6963 my $chead = cmdoutput_errok @symcmd;
6964 defined $chead or $?==256 or failedcmd @symcmd;
6966 fail f_ "%s is checked out - will not update it", $dstbranch
6967 if defined $chead and $chead eq $dstbranch;
6969 my $oldhash = git_get_ref $dstbranch;
6971 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6972 $dscdata = do { local $/ = undef; <D>; };
6973 D->error and fail f_ "read %s: %s", $dscfn, $!;
6976 # we don't normally need this so import it here
6977 use Dpkg::Source::Package;
6978 my $dp = new Dpkg::Source::Package filename => $dscfn,
6979 require_valid_signature => $needsig;
6981 local $SIG{__WARN__} = sub {
6983 return unless $needsig;
6984 fail __ "import-dsc signature check failed";
6986 if (!$dp->is_signed()) {
6987 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6989 my $r = $dp->check_signature();
6990 confess "->check_signature => $r" if $needsig && $r;
6996 $package = getfield $dsc, 'Source';
6998 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6999 unless forceing [qw(import-dsc-with-dgit-field)];
7000 parse_dsc_field_def_dsc_distro();
7002 $isuite = 'DGIT-IMPORT-DSC';
7003 $idistro //= $dsc_distro;
7007 if (defined $dsc_hash) {
7009 "dgit: import-dsc of .dsc with Dgit field, using git hash";
7010 resolve_dsc_field_commit undef, undef;
7012 if (defined $dsc_hash) {
7013 my @cmd = (qw(sh -ec),
7014 "echo $dsc_hash | git cat-file --batch-check");
7015 my $objgot = cmdoutput @cmd;
7016 if ($objgot =~ m#^\w+ missing\b#) {
7017 fail f_ <<END, $dsc_hash
7018 .dsc contains Dgit field referring to object %s
7019 Your git tree does not have that object. Try `git fetch' from a
7020 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7023 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7025 progress __ "Not fast forward, forced update.";
7027 fail f_ "Not fast forward to %s", $dsc_hash;
7030 import_dsc_result $dstbranch, $dsc_hash,
7031 "dgit import-dsc (Dgit): $info",
7032 f_ "updated git ref %s", $dstbranch;
7036 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7037 Branch %s already exists
7038 Specify ..%s for a pseudo-merge, binding in existing history
7039 Specify +%s to overwrite, discarding existing history
7041 if $oldhash && !$force;
7043 my @dfi = dsc_files_info();
7044 foreach my $fi (@dfi) {
7045 my $f = $fi->{Filename};
7046 # We transfer all the pieces of the dsc to the bpd, not just
7047 # origs. This is by analogy with dgit fetch, which wants to
7048 # keep them somewhere to avoid downloading them again.
7049 # We make symlinks, though. If the user wants copies, then
7050 # they can copy the parts of the dsc to the bpd using dcmd,
7052 my $here = "$buildproductsdir/$f";
7057 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7059 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7060 printdebug "not in bpd, $f ...\n";
7061 # $f does not exist in bpd, we need to transfer it
7063 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7064 # $there is file we want, relative to user's cwd, or abs
7065 printdebug "not in bpd, $f, test $there ...\n";
7066 stat $there or fail f_
7067 "import %s requires %s, but: %s", $dscfn, $there, $!;
7068 if ($there =~ m#^(?:\./+)?\.\./+#) {
7069 # $there is relative to user's cwd
7070 my $there_from_parent = $';
7071 if ($buildproductsdir !~ m{^/}) {
7072 # abs2rel, despite its name, can take two relative paths
7073 $there = File::Spec->abs2rel($there,$buildproductsdir);
7074 # now $there is relative to bpd, great
7075 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7077 $there = (dirname $maindir)."/$there_from_parent";
7078 # now $there is absoute
7079 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7081 } elsif ($there =~ m#^/#) {
7082 # $there is absolute already
7083 printdebug "not in bpd, $f, abs, $there ...\n";
7086 "cannot import %s which seems to be inside working tree!",
7089 symlink $there, $here or fail f_
7090 "symlink %s to %s: %s", $there, $here, $!;
7091 progress f_ "made symlink %s -> %s", $here, $there;
7092 # print STDERR Dumper($fi);
7094 my @mergeinputs = generate_commits_from_dsc();
7095 die unless @mergeinputs == 1;
7097 my $newhash = $mergeinputs[0]{Commit};
7102 "Import, forced update - synthetic orphan git history.";
7103 } elsif ($force < 0) {
7104 progress __ "Import, merging.";
7105 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7106 my $version = getfield $dsc, 'Version';
7107 my $clogp = commit_getclogp $newhash;
7108 my $authline = clogp_authline $clogp;
7109 $newhash = make_commit_text <<ENDU
7117 .(f_ <<END, $package, $version, $dstbranch);
7118 Merge %s (%s) import into %s
7121 die; # caught earlier
7125 import_dsc_result $dstbranch, $newhash,
7126 "dgit import-dsc: $info",
7127 f_ "results are in git ref %s", $dstbranch;
7130 sub pre_archive_api_query () {
7131 not_necessarily_a_tree();
7133 sub cmd_archive_api_query {
7134 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7135 my ($subpath) = @ARGV;
7136 local $isuite = 'DGIT-API-QUERY-CMD';
7137 my @cmd = archive_api_query_cmd($subpath);
7140 exec @cmd or fail f_ "exec curl: %s\n", $!;
7143 sub repos_server_url () {
7144 $package = '_dgit-repos-server';
7145 local $access_forpush = 1;
7146 local $isuite = 'DGIT-REPOS-SERVER';
7147 my $url = access_giturl();
7150 sub pre_clone_dgit_repos_server () {
7151 not_necessarily_a_tree();
7153 sub cmd_clone_dgit_repos_server {
7154 badusage __ "need destination argument" unless @ARGV==1;
7155 my ($destdir) = @ARGV;
7156 my $url = repos_server_url();
7157 my @cmd = (@git, qw(clone), $url, $destdir);
7159 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7162 sub pre_print_dgit_repos_server_source_url () {
7163 not_necessarily_a_tree();
7165 sub cmd_print_dgit_repos_server_source_url {
7167 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7169 my $url = repos_server_url();
7170 print $url, "\n" or confess "$!";
7173 sub pre_print_dpkg_source_ignores {
7174 not_necessarily_a_tree();
7176 sub cmd_print_dpkg_source_ignores {
7178 "no arguments allowed to dgit print-dpkg-source-ignores"
7180 print "@dpkg_source_ignores\n" or confess "$!";
7183 sub cmd_setup_mergechangelogs {
7184 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7186 local $isuite = 'DGIT-SETUP-TREE';
7187 setup_mergechangelogs(1);
7190 sub cmd_setup_useremail {
7191 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7192 local $isuite = 'DGIT-SETUP-TREE';
7196 sub cmd_setup_gitattributes {
7197 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7198 local $isuite = 'DGIT-SETUP-TREE';
7202 sub cmd_setup_new_tree {
7203 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7204 local $isuite = 'DGIT-SETUP-TREE';
7208 #---------- argument parsing and main program ----------
7211 print "dgit version $our_version\n" or confess "$!";
7215 our (%valopts_long, %valopts_short);
7216 our (%funcopts_long);
7218 our (@modeopt_cfgs);
7220 sub defvalopt ($$$$) {
7221 my ($long,$short,$val_re,$how) = @_;
7222 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7223 $valopts_long{$long} = $oi;
7224 $valopts_short{$short} = $oi;
7225 # $how subref should:
7226 # do whatever assignemnt or thing it likes with $_[0]
7227 # if the option should not be passed on to remote, @rvalopts=()
7228 # or $how can be a scalar ref, meaning simply assign the value
7231 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7232 defvalopt '--distro', '-d', '.+', \$idistro;
7233 defvalopt '', '-k', '.+', \$keyid;
7234 defvalopt '--existing-package','', '.*', \$existing_package;
7235 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7236 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7237 defvalopt '--package', '-p', $package_re, \$package;
7238 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7240 defvalopt '', '-C', '.+', sub {
7241 ($changesfile) = (@_);
7242 if ($changesfile =~ s#^(.*)/##) {
7243 $buildproductsdir = $1;
7247 defvalopt '--initiator-tempdir','','.*', sub {
7248 ($initiator_tempdir) = (@_);
7249 $initiator_tempdir =~ m#^/# or
7250 badusage __ "--initiator-tempdir must be used specify an".
7251 " absolute, not relative, directory."
7254 sub defoptmodes ($@) {
7255 my ($varref, $cfgkey, $default, %optmap) = @_;
7257 while (my ($opt,$val) = each %optmap) {
7258 $funcopts_long{$opt} = sub { $$varref = $val; };
7259 $permit{$val} = $val;
7261 push @modeopt_cfgs, {
7264 Default => $default,
7269 defoptmodes \$dodep14tag, qw( dep14tag want
7272 --always-dep14tag always );
7277 if (defined $ENV{'DGIT_SSH'}) {
7278 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7279 } elsif (defined $ENV{'GIT_SSH'}) {
7280 @ssh = ($ENV{'GIT_SSH'});
7288 if (!defined $val) {
7289 badusage f_ "%s needs a value", $what unless @ARGV;
7291 push @rvalopts, $val;
7293 badusage f_ "bad value \`%s' for %s", $val, $what unless
7294 $val =~ m/^$oi->{Re}$(?!\n)/s;
7295 my $how = $oi->{How};
7296 if (ref($how) eq 'SCALAR') {
7301 push @ropts, @rvalopts;
7305 last unless $ARGV[0] =~ m/^-/;
7309 if (m/^--dry-run$/) {
7312 } elsif (m/^--damp-run$/) {
7315 } elsif (m/^--no-sign$/) {
7318 } elsif (m/^--help$/) {
7320 } elsif (m/^--version$/) {
7322 } elsif (m/^--new$/) {
7325 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7326 ($om = $opts_opt_map{$1}) &&
7330 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7331 !$opts_opt_cmdonly{$1} &&
7332 ($om = $opts_opt_map{$1})) {
7335 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7336 !$opts_opt_cmdonly{$1} &&
7337 ($om = $opts_opt_map{$1})) {
7339 my $cmd = shift @$om;
7340 @$om = ($cmd, grep { $_ ne $2 } @$om);
7341 } elsif (m/^--(gbp|dpm)$/s) {
7342 push @ropts, "--quilt=$1";
7344 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7347 } elsif (m/^--no-quilt-fixup$/s) {
7349 $quilt_mode = 'nocheck';
7350 } elsif (m/^--no-rm-on-error$/s) {
7353 } elsif (m/^--no-chase-dsc-distro$/s) {
7355 $chase_dsc_distro = 0;
7356 } elsif (m/^--overwrite$/s) {
7358 $overwrite_version = '';
7359 } elsif (m/^--overwrite=(.+)$/s) {
7361 $overwrite_version = $1;
7362 } elsif (m/^--delayed=(\d+)$/s) {
7365 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7366 m/^--(dgit-view)-save=(.+)$/s
7368 my ($k,$v) = ($1,$2);
7370 $v =~ s#^(?!refs/)#refs/heads/#;
7371 $internal_object_save{$k} = $v;
7372 } elsif (m/^--(no-)?rm-old-changes$/s) {
7375 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7377 push @deliberatelies, $&;
7378 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7382 } elsif (m/^--force-/) {
7384 f_ "%s: warning: ignoring unknown force option %s\n",
7387 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7388 # undocumented, for testing
7390 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7391 # ^ it's supposed to be an array ref
7392 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7393 $val = $2 ? $' : undef; #';
7394 $valopt->($oi->{Long});
7395 } elsif ($funcopts_long{$_}) {
7397 $funcopts_long{$_}();
7399 badusage f_ "unknown long option \`%s'", $_;
7406 } elsif (s/^-L/-/) {
7409 } elsif (s/^-h/-/) {
7411 } elsif (s/^-D/-/) {
7415 } elsif (s/^-N/-/) {
7420 push @changesopts, $_;
7422 } elsif (s/^-wn$//s) {
7424 $cleanmode = 'none';
7425 } elsif (s/^-wg(f?)(a?)$//s) {
7428 $cleanmode .= '-ff' if $1;
7429 $cleanmode .= ',always' if $2;
7430 } elsif (s/^-wd(d?)([na]?)$//s) {
7432 $cleanmode = 'dpkg-source';
7433 $cleanmode .= '-d' if $1;
7434 $cleanmode .= ',no-check' if $2 eq 'n';
7435 $cleanmode .= ',all-check' if $2 eq 'a';
7436 } elsif (s/^-wc$//s) {
7438 $cleanmode = 'check';
7439 } elsif (s/^-wci$//s) {
7441 $cleanmode = 'check,ignores';
7442 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7443 push @git, '-c', $&;
7444 $gitcfgs{cmdline}{$1} = [ $2 ];
7445 } elsif (s/^-c([^=]+)$//s) {
7446 push @git, '-c', $&;
7447 $gitcfgs{cmdline}{$1} = [ 'true' ];
7448 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7450 $val = undef unless length $val;
7451 $valopt->($oi->{Short});
7454 badusage f_ "unknown short option \`%s'", $_;
7461 sub check_env_sanity () {
7462 my $blocked = new POSIX::SigSet;
7463 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7466 foreach my $name (qw(PIPE CHLD)) {
7467 my $signame = "SIG$name";
7468 my $signum = eval "POSIX::$signame" // die;
7469 die f_ "%s is set to something other than SIG_DFL\n",
7471 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7472 $blocked->ismember($signum) and
7473 die f_ "%s is blocked\n", $signame;
7479 On entry to dgit, %s
7480 This is a bug produced by something in your execution environment.
7486 sub parseopts_late_defaults () {
7487 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7488 if defined $idistro;
7489 $isuite //= cfg('dgit.default.default-suite');
7491 foreach my $k (keys %opts_opt_map) {
7492 my $om = $opts_opt_map{$k};
7494 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7496 badcfg f_ "cannot set command for %s", $k
7497 unless length $om->[0];
7501 foreach my $c (access_cfg_cfgs("opts-$k")) {
7503 map { $_ ? @$_ : () }
7504 map { $gitcfgs{$_}{$c} }
7505 reverse @gitcfgsources;
7506 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7507 "\n" if $debuglevel >= 4;
7509 badcfg f_ "cannot configure options for %s", $k
7510 if $opts_opt_cmdonly{$k};
7511 my $insertpos = $opts_cfg_insertpos{$k};
7512 @$om = ( @$om[0..$insertpos-1],
7514 @$om[$insertpos..$#$om] );
7518 if (!defined $rmchanges) {
7519 local $access_forpush;
7520 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7523 if (!defined $quilt_mode) {
7524 local $access_forpush;
7525 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7526 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7528 $quilt_mode =~ m/^($quilt_modes_re)$/
7529 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7533 foreach my $moc (@modeopt_cfgs) {
7534 local $access_forpush;
7535 my $vr = $moc->{Var};
7536 next if defined $$vr;
7537 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7538 my $v = $moc->{Vals}{$$vr};
7539 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7545 local $access_forpush;
7546 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7550 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7551 $buildproductsdir //= '..';
7552 $bpd_glob = $buildproductsdir;
7553 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7556 setlocale(LC_MESSAGES, "");
7559 if ($ENV{$fakeeditorenv}) {
7561 quilt_fixup_editor();
7567 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7568 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7569 if $dryrun_level == 1;
7571 print STDERR __ $helpmsg or confess "$!";
7574 $cmd = $subcommand = shift @ARGV;
7577 my $pre_fn = ${*::}{"pre_$cmd"};
7578 $pre_fn->() if $pre_fn;
7580 if ($invoked_in_git_tree) {
7581 changedir_git_toplevel();
7586 my $fn = ${*::}{"cmd_$cmd"};
7587 $fn or badusage f_ "unknown operation %s", $cmd;