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;
92 our $chase_dsc_distro=1;
94 our %forceopts = map { $_=>0 }
95 qw(unrepresentable unsupported-source-format
96 dsc-changes-mismatch changes-origs-exactly
97 uploading-binaries uploading-source-only
98 import-gitapply-absurd
99 import-gitapply-no-absurd
100 import-dsc-with-dgit-field);
102 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
104 our $suite_re = '[-+.0-9a-z]+';
105 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
106 | (?: git | git-ff ) (?: ,always )?
107 | check (?: ,ignores )?
111 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
112 our $splitbraincache = 'dgit-intern/quilt-cache';
113 our $rewritemap = 'dgit-rewrite/map';
115 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
117 our (@git) = qw(git);
118 our (@dget) = qw(dget);
119 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
120 our (@dput) = qw(dput);
121 our (@debsign) = qw(debsign);
122 our (@gpg) = qw(gpg);
123 our (@sbuild) = (qw(sbuild --no-source));
125 our (@dgit) = qw(dgit);
126 our (@git_debrebase) = qw(git-debrebase);
127 our (@aptget) = qw(apt-get);
128 our (@aptcache) = qw(apt-cache);
129 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
130 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
131 our (@dpkggenchanges) = qw(dpkg-genchanges);
132 our (@mergechanges) = qw(mergechanges -f);
133 our (@gbp_build) = ('');
134 our (@gbp_pq) = ('gbp pq');
135 our (@changesopts) = ('');
136 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
137 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
139 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
142 'debsign' => \@debsign,
144 'sbuild' => \@sbuild,
148 'git-debrebase' => \@git_debrebase,
149 'apt-get' => \@aptget,
150 'apt-cache' => \@aptcache,
151 'dpkg-source' => \@dpkgsource,
152 'dpkg-buildpackage' => \@dpkgbuildpackage,
153 'dpkg-genchanges' => \@dpkggenchanges,
154 'gbp-build' => \@gbp_build,
155 'gbp-pq' => \@gbp_pq,
156 'ch' => \@changesopts,
157 'mergechanges' => \@mergechanges,
158 'pbuilder' => \@pbuilder,
159 'cowbuilder' => \@cowbuilder);
161 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
162 our %opts_cfg_insertpos = map {
164 scalar @{ $opts_opt_map{$_} }
165 } keys %opts_opt_map;
167 sub parseopts_late_defaults();
168 sub quiltify_trees_differ ($$;$$$);
169 sub setup_gitattrs(;$);
170 sub check_gitattrs($$);
177 our $supplementary_message = '';
178 our $split_brain = 0;
179 our $do_split_brain = 0;
183 return unless forkcheck_mainprocess();
184 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
187 our $remotename = 'dgit';
188 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
192 if (!defined $absurdity) {
194 $absurdity =~ s{/[^/]+$}{/absurd} or die;
198 my ($v,$distro) = @_;
199 return $tagformatfn->($v, $distro);
202 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
204 sub lbranch () { return "$branchprefix/$csuite"; }
205 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
206 sub lref () { return "refs/heads/".lbranch(); }
207 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
208 sub rrref () { return server_ref($csuite); }
211 my ($vsn, $sfx) = @_;
212 return &source_file_leafname($package, $vsn, $sfx);
214 sub is_orig_file_of_vsn ($$) {
215 my ($f, $upstreamvsn) = @_;
216 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
221 return srcfn($vsn,".dsc");
224 sub changespat ($;$) {
225 my ($vsn, $arch) = @_;
226 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
235 return unless forkcheck_mainprocess();
236 foreach my $f (@end) {
238 print STDERR "$us: cleanup: $@" if length $@;
243 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
247 sub forceable_fail ($$) {
248 my ($forceoptsl, $msg) = @_;
249 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
250 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
254 my ($forceoptsl) = @_;
255 my @got = grep { $forceopts{$_} } @$forceoptsl;
256 return 0 unless @got;
258 "warning: skipping checks or functionality due to --force-%s\n",
262 sub no_such_package () {
263 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
264 $us, $package, $isuite;
268 sub deliberately ($) {
270 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
273 sub deliberately_not_fast_forward () {
274 foreach (qw(not-fast-forward fresh-repo)) {
275 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
279 sub quiltmode_splitbrain () {
280 $quilt_mode =~ m/gbp|dpm|unapplied/;
283 sub opts_opt_multi_cmd {
286 push @cmd, split /\s+/, shift @_;
293 return opts_opt_multi_cmd [], @gbp_pq;
296 sub dgit_privdir () {
297 our $dgit_privdir_made //= ensure_a_playground 'dgit';
301 my $r = $buildproductsdir;
302 $r = "$maindir/$r" unless $r =~ m{^/};
306 sub get_tree_of_commit ($) {
307 my ($commitish) = @_;
308 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
309 $cdata =~ m/\n\n/; $cdata = $`;
310 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
314 sub branch_gdr_info ($$) {
315 my ($symref, $head) = @_;
316 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
317 gdr_ffq_prev_branchinfo($symref);
318 return () unless $status eq 'branch';
319 $ffq_prev = git_get_ref $ffq_prev;
320 $gdrlast = git_get_ref $gdrlast;
321 $gdrlast &&= is_fast_fwd $gdrlast, $head;
322 return ($ffq_prev, $gdrlast);
325 sub branch_is_gdr_unstitched_ff ($$$) {
326 my ($symref, $head, $ancestor) = @_;
327 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
328 return 0 unless $ffq_prev;
329 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
333 sub branch_is_gdr ($) {
335 # This is quite like git-debrebase's keycommits.
336 # We have our own implementation because:
337 # - our algorighm can do fewer tests so is faster
338 # - it saves testing to see if gdr is installed
340 # NB we use this jsut for deciding whether to run gdr make-patches
341 # Before reusing this algorithm for somthing else, its
342 # suitability should be reconsidered.
345 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
346 printdebug "branch_is_gdr $head...\n";
347 my $get_patches = sub {
348 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
351 my $tip_patches = $get_patches->($head);
354 my $cdata = git_cat_file $walk, 'commit';
355 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
356 if ($msg =~ m{^\[git-debrebase\ (
357 anchor | changelog | make-patches |
358 merged-breakwater | pseudomerge
360 # no need to analyse this - it's sufficient
361 # (gdr classifications: Anchor, MergedBreakwaters)
362 # (made by gdr: Pseudomerge, Changelog)
363 printdebug "branch_is_gdr $walk gdr $1 YES\n";
366 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
368 my $walk_tree = get_tree_of_commit $walk;
369 foreach my $p (@parents) {
370 my $p_tree = get_tree_of_commit $p;
371 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
372 # (gdr classification: Pseudomerge; not made by gdr)
373 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
379 # some other non-gdr merge
380 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
381 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
385 # (gdr classification: ?)
386 printdebug "branch_is_gdr $walk ?-octopus NO\n";
390 printdebug "branch_is_gdr $walk origin\n";
393 if ($get_patches->($walk) ne $tip_patches) {
394 # Our parent added, removed, or edited patches, and wasn't
395 # a gdr make-patches commit. gdr make-patches probably
396 # won't do that well, then.
397 # (gdr classification of parent: AddPatches or ?)
398 printdebug "branch_is_gdr $walk ?-patches NO\n";
401 if ($tip_patches eq '' and
402 !defined git_cat_file "$walk~:debian" and
403 !quiltify_trees_differ "$walk~", $walk
405 # (gdr classification of parent: BreakwaterStart
406 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
409 # (gdr classification: Upstream Packaging Mixed Changelog)
410 printdebug "branch_is_gdr $walk plain\n"
416 #---------- remote protocol support, common ----------
418 # remote push initiator/responder protocol:
419 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
420 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
421 # < dgit-remote-push-ready <actual-proto-vsn>
428 # > supplementary-message NBYTES # $protovsn >= 3
433 # > file parsed-changelog
434 # [indicates that output of dpkg-parsechangelog follows]
435 # > data-block NBYTES
436 # > [NBYTES bytes of data (no newline)]
437 # [maybe some more blocks]
446 # > param head DGIT-VIEW-HEAD
447 # > param csuite SUITE
448 # > param tagformat old|new
449 # > param maint-view MAINT-VIEW-HEAD
451 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
452 # > file buildinfo # for buildinfos to sign
454 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
455 # # goes into tag, for replay prevention
458 # [indicates that signed tag is wanted]
459 # < data-block NBYTES
460 # < [NBYTES bytes of data (no newline)]
461 # [maybe some more blocks]
465 # > want signed-dsc-changes
466 # < data-block NBYTES [transfer of signed dsc]
468 # < data-block NBYTES [transfer of signed changes]
470 # < data-block NBYTES [transfer of each signed buildinfo
471 # [etc] same number and order as "file buildinfo"]
479 sub i_child_report () {
480 # Sees if our child has died, and reap it if so. Returns a string
481 # describing how it died if it failed, or undef otherwise.
482 return undef unless $i_child_pid;
483 my $got = waitpid $i_child_pid, WNOHANG;
484 return undef if $got <= 0;
485 die unless $got == $i_child_pid;
486 $i_child_pid = undef;
487 return undef unless $?;
488 return f_ "build host child %s", waitstatusmsg();
493 fail f_ "connection lost: %s", $! if $fh->error;
494 fail f_ "protocol violation; %s not expected", $m;
497 sub badproto_badread ($$) {
499 fail f_ "connection lost: %s", $! if $!;
500 my $report = i_child_report();
501 fail $report if defined $report;
502 badproto $fh, f_ "eof (reading %s)", $wh;
505 sub protocol_expect (&$) {
506 my ($match, $fh) = @_;
509 defined && chomp or badproto_badread $fh, __ "protocol message";
517 badproto $fh, f_ "\`%s'", $_;
520 sub protocol_send_file ($$) {
521 my ($fh, $ourfn) = @_;
522 open PF, "<", $ourfn or die "$ourfn: $!";
525 my $got = read PF, $d, 65536;
526 die "$ourfn: $!" unless defined $got;
528 print $fh "data-block ".length($d)."\n" or confess "$!";
529 print $fh $d or confess "$!";
531 PF->error and die "$ourfn $!";
532 print $fh "data-end\n" or confess "$!";
536 sub protocol_read_bytes ($$) {
537 my ($fh, $nbytes) = @_;
538 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
540 my $got = read $fh, $d, $nbytes;
541 $got==$nbytes or badproto_badread $fh, __ "data block";
545 sub protocol_receive_file ($$) {
546 my ($fh, $ourfn) = @_;
547 printdebug "() $ourfn\n";
548 open PF, ">", $ourfn or die "$ourfn: $!";
550 my ($y,$l) = protocol_expect {
551 m/^data-block (.*)$/ ? (1,$1) :
552 m/^data-end$/ ? (0,) :
556 my $d = protocol_read_bytes $fh, $l;
557 print PF $d or confess "$!";
559 close PF or confess "$!";
562 #---------- remote protocol support, responder ----------
564 sub responder_send_command ($) {
566 return unless $we_are_responder;
567 # called even without $we_are_responder
568 printdebug ">> $command\n";
569 print PO $command, "\n" or confess "$!";
572 sub responder_send_file ($$) {
573 my ($keyword, $ourfn) = @_;
574 return unless $we_are_responder;
575 printdebug "]] $keyword $ourfn\n";
576 responder_send_command "file $keyword";
577 protocol_send_file \*PO, $ourfn;
580 sub responder_receive_files ($@) {
581 my ($keyword, @ourfns) = @_;
582 die unless $we_are_responder;
583 printdebug "[[ $keyword @ourfns\n";
584 responder_send_command "want $keyword";
585 foreach my $fn (@ourfns) {
586 protocol_receive_file \*PI, $fn;
589 protocol_expect { m/^files-end$/ } \*PI;
592 #---------- remote protocol support, initiator ----------
594 sub initiator_expect (&) {
596 protocol_expect { &$match } \*RO;
599 #---------- end remote code ----------
602 if ($we_are_responder) {
604 responder_send_command "progress ".length($m) or confess "$!";
605 print PO $m or confess "$!";
615 $ua = LWP::UserAgent->new();
619 progress "downloading $what...";
620 my $r = $ua->get(@_) or confess "$!";
621 return undef if $r->code == 404;
622 $r->is_success or fail f_ "failed to fetch %s: %s",
623 $what, $r->status_line;
624 return $r->decoded_content(charset => 'none');
627 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
629 sub act_local () { return $dryrun_level <= 1; }
630 sub act_scary () { return !$dryrun_level; }
633 if (!$dryrun_level) {
634 progress f_ "%s ok: %s", $us, "@_";
636 progress f_ "would be ok: %s (but dry run only)", "@_";
641 printcmd(\*STDERR,$debugprefix."#",@_);
644 sub runcmd_ordryrun {
652 sub runcmd_ordryrun_local {
660 our $helpmsg = i_ <<END;
662 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
663 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
664 dgit [dgit-opts] build [dpkg-buildpackage-opts]
665 dgit [dgit-opts] sbuild [sbuild-opts]
666 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
667 dgit [dgit-opts] push [dgit-opts] [suite]
668 dgit [dgit-opts] push-source [dgit-opts] [suite]
669 dgit [dgit-opts] rpush build-host:build-dir ...
670 important dgit options:
671 -k<keyid> sign tag and package with <keyid> instead of default
672 --dry-run -n do not change anything, but go through the motions
673 --damp-run -L like --dry-run but make local changes, without signing
674 --new -N allow introducing a new package
675 --debug -D increase debug level
676 -c<name>=<value> set git config option (used directly by dgit too)
679 our $later_warning_msg = i_ <<END;
680 Perhaps the upload is stuck in incoming. Using the version from git.
684 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
689 @ARGV or badusage __ "too few arguments";
690 return scalar shift @ARGV;
694 not_necessarily_a_tree();
697 print __ $helpmsg or confess "$!";
701 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
703 our %defcfg = ('dgit.default.distro' => 'debian',
704 'dgit.default.default-suite' => 'unstable',
705 'dgit.default.old-dsc-distro' => 'debian',
706 'dgit-suite.*-security.distro' => 'debian-security',
707 'dgit.default.username' => '',
708 'dgit.default.archive-query-default-component' => 'main',
709 'dgit.default.ssh' => 'ssh',
710 'dgit.default.archive-query' => 'madison:',
711 'dgit.default.sshpsql-dbname' => 'service=projectb',
712 'dgit.default.aptget-components' => 'main',
713 'dgit.default.dgit-tag-format' => 'new,old,maint',
714 'dgit.default.source-only-uploads' => 'ok',
715 'dgit.dsc-url-proto-ok.http' => 'true',
716 'dgit.dsc-url-proto-ok.https' => 'true',
717 'dgit.dsc-url-proto-ok.git' => 'true',
718 'dgit.vcs-git.suites', => 'sid', # ;-separated
719 'dgit.default.dsc-url-proto-ok' => 'false',
720 # old means "repo server accepts pushes with old dgit tags"
721 # new means "repo server accepts pushes with new dgit tags"
722 # maint means "repo server accepts split brain pushes"
723 # hist means "repo server may have old pushes without new tag"
724 # ("hist" is implied by "old")
725 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
726 'dgit-distro.debian.git-check' => 'url',
727 'dgit-distro.debian.git-check-suffix' => '/info/refs',
728 'dgit-distro.debian.new-private-pushers' => 't',
729 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
730 'dgit-distro.debian/push.git-url' => '',
731 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
732 'dgit-distro.debian/push.git-user-force' => 'dgit',
733 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
734 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
735 'dgit-distro.debian/push.git-create' => 'true',
736 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
737 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
738 # 'dgit-distro.debian.archive-query-tls-key',
739 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
740 # ^ this does not work because curl is broken nowadays
741 # Fixing #790093 properly will involve providing providing the key
742 # in some pacagke and maybe updating these paths.
744 # 'dgit-distro.debian.archive-query-tls-curl-args',
745 # '--ca-path=/etc/ssl/ca-debian',
746 # ^ this is a workaround but works (only) on DSA-administered machines
747 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
748 'dgit-distro.debian.git-url-suffix' => '',
749 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
750 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
751 'dgit-distro.debian-security.archive-query' => 'aptget:',
752 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
753 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
754 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
755 'dgit-distro.debian-security.nominal-distro' => 'debian',
756 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
757 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
758 'dgit-distro.ubuntu.git-check' => 'false',
759 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
760 'dgit-distro.test-dummy.ssh' => "$td/ssh",
761 'dgit-distro.test-dummy.username' => "alice",
762 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
763 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
764 'dgit-distro.test-dummy.git-url' => "$td/git",
765 'dgit-distro.test-dummy.git-host' => "git",
766 'dgit-distro.test-dummy.git-path' => "$td/git",
767 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
768 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
769 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
770 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
774 our @gitcfgsources = qw(cmdline local global system);
775 our $invoked_in_git_tree = 1;
777 sub git_slurp_config () {
778 # This algoritm is a bit subtle, but this is needed so that for
779 # options which we want to be single-valued, we allow the
780 # different config sources to override properly. See #835858.
781 foreach my $src (@gitcfgsources) {
782 next if $src eq 'cmdline';
783 # we do this ourselves since git doesn't handle it
785 $gitcfgs{$src} = git_slurp_config_src $src;
789 sub git_get_config ($) {
791 foreach my $src (@gitcfgsources) {
792 my $l = $gitcfgs{$src}{$c};
793 confess "internal error ($l $c)" if $l && !ref $l;
794 printdebug"C $c ".(defined $l ?
795 join " ", map { messagequote "'$_'" } @$l :
800 f_ "multiple values for %s (in %s git config)", $c, $src
802 $l->[0] =~ m/\n/ and badcfg f_
803 "value for config option %s (in %s git config) contains newline(s)!",
812 return undef if $c =~ /RETURN-UNDEF/;
813 printdebug "C? $c\n" if $debuglevel >= 5;
814 my $v = git_get_config($c);
815 return $v if defined $v;
816 my $dv = $defcfg{$c};
818 printdebug "CD $c $dv\n" if $debuglevel >= 4;
823 "need value for one of: %s\n".
824 "%s: distro or suite appears not to be (properly) supported",
828 sub not_necessarily_a_tree () {
829 # needs to be called from pre_*
830 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
831 $invoked_in_git_tree = 0;
834 sub access_basedistro__noalias () {
835 if (defined $idistro) {
838 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
839 return $def if defined $def;
840 foreach my $src (@gitcfgsources, 'internal') {
841 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
843 foreach my $k (keys %$kl) {
844 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
846 next unless match_glob $dpat, $isuite;
850 return cfg("dgit.default.distro");
854 sub access_basedistro () {
855 my $noalias = access_basedistro__noalias();
856 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
857 return $canon // $noalias;
860 sub access_nomdistro () {
861 my $base = access_basedistro();
862 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
863 $r =~ m/^$distro_re$/ or badcfg
864 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
865 $r, "/^$distro_re$/";
869 sub access_quirk () {
870 # returns (quirk name, distro to use instead or undef, quirk-specific info)
871 my $basedistro = access_basedistro();
872 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
874 if (defined $backports_quirk) {
875 my $re = $backports_quirk;
876 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
878 $re =~ s/\%/([-0-9a-z_]+)/
879 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
880 if ($isuite =~ m/^$re$/) {
881 return ('backports',"$basedistro-backports",$1);
884 return ('none',undef);
889 sub parse_cfg_bool ($$$) {
890 my ($what,$def,$v) = @_;
893 $v =~ m/^[ty1]/ ? 1 :
894 $v =~ m/^[fn0]/ ? 0 :
895 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
899 sub access_forpush_config () {
900 my $d = access_basedistro();
904 parse_cfg_bool('new-private-pushers', 0,
905 cfg("dgit-distro.$d.new-private-pushers",
908 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
911 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
912 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
913 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
915 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
918 sub access_forpush () {
919 $access_forpush //= access_forpush_config();
920 return $access_forpush;
924 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
925 defined $access_forpush and !$access_forpush;
926 badcfg __ "pushing but distro is configured readonly"
927 if access_forpush_config() eq '0';
929 $supplementary_message = __ <<'END' unless $we_are_responder;
930 Push failed, before we got started.
931 You can retry the push, after fixing the problem, if you like.
933 parseopts_late_defaults();
937 parseopts_late_defaults();
940 sub supplementary_message ($) {
942 if (!$we_are_responder) {
943 $supplementary_message = $msg;
945 } elsif ($protovsn >= 3) {
946 responder_send_command "supplementary-message ".length($msg)
948 print PO $msg or confess "$!";
952 sub access_distros () {
953 # Returns list of distros to try, in order
956 # 0. `instead of' distro name(s) we have been pointed to
957 # 1. the access_quirk distro, if any
958 # 2a. the user's specified distro, or failing that } basedistro
959 # 2b. the distro calculated from the suite }
960 my @l = access_basedistro();
962 my (undef,$quirkdistro) = access_quirk();
963 unshift @l, $quirkdistro;
964 unshift @l, $instead_distro;
965 @l = grep { defined } @l;
967 push @l, access_nomdistro();
969 if (access_forpush()) {
970 @l = map { ("$_/push", $_) } @l;
975 sub access_cfg_cfgs (@) {
978 # The nesting of these loops determines the search order. We put
979 # the key loop on the outside so that we search all the distros
980 # for each key, before going on to the next key. That means that
981 # if access_cfg is called with a more specific, and then a less
982 # specific, key, an earlier distro can override the less specific
983 # without necessarily overriding any more specific keys. (If the
984 # distro wants to override the more specific keys it can simply do
985 # so; whereas if we did the loop the other way around, it would be
986 # impossible to for an earlier distro to override a less specific
987 # key but not the more specific ones without restating the unknown
988 # values of the more specific keys.
991 # We have to deal with RETURN-UNDEF specially, so that we don't
992 # terminate the search prematurely.
994 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
997 foreach my $d (access_distros()) {
998 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1000 push @cfgs, map { "dgit.default.$_" } @realkeys;
1001 push @cfgs, @rundef;
1005 sub access_cfg (@) {
1007 my (@cfgs) = access_cfg_cfgs(@keys);
1008 my $value = cfg(@cfgs);
1012 sub access_cfg_bool ($$) {
1013 my ($def, @keys) = @_;
1014 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1017 sub string_to_ssh ($) {
1019 if ($spec =~ m/\s/) {
1020 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1026 sub access_cfg_ssh () {
1027 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1028 if (!defined $gitssh) {
1031 return string_to_ssh $gitssh;
1035 sub access_runeinfo ($) {
1037 return ": dgit ".access_basedistro()." $info ;";
1040 sub access_someuserhost ($) {
1042 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1043 defined($user) && length($user) or
1044 $user = access_cfg("$some-user",'username');
1045 my $host = access_cfg("$some-host");
1046 return length($user) ? "$user\@$host" : $host;
1049 sub access_gituserhost () {
1050 return access_someuserhost('git');
1053 sub access_giturl (;$) {
1054 my ($optional) = @_;
1055 my $url = access_cfg('git-url','RETURN-UNDEF');
1058 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1059 return undef unless defined $proto;
1062 access_gituserhost().
1063 access_cfg('git-path');
1065 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1068 return "$url/$package$suffix";
1071 sub commit_getclogp ($) {
1072 # Returns the parsed changelog hashref for a particular commit
1074 our %commit_getclogp_memo;
1075 my $memo = $commit_getclogp_memo{$objid};
1076 return $memo if $memo;
1078 my $mclog = dgit_privdir()."clog";
1079 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1080 "$objid:debian/changelog";
1081 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1084 sub parse_dscdata () {
1085 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1086 printdebug Dumper($dscdata) if $debuglevel>1;
1087 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1088 printdebug Dumper($dsc) if $debuglevel>1;
1093 sub archive_query ($;@) {
1094 my ($method) = shift @_;
1095 fail __ "this operation does not support multiple comma-separated suites"
1097 my $query = access_cfg('archive-query','RETURN-UNDEF');
1098 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1101 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1104 sub archive_query_prepend_mirror {
1105 my $m = access_cfg('mirror');
1106 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1109 sub pool_dsc_subpath ($$) {
1110 my ($vsn,$component) = @_; # $package is implict arg
1111 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1112 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1115 sub cfg_apply_map ($$$) {
1116 my ($varref, $what, $mapspec) = @_;
1117 return unless $mapspec;
1119 printdebug "config $what EVAL{ $mapspec; }\n";
1121 eval "package Dgit::Config; $mapspec;";
1126 #---------- `ftpmasterapi' archive query method (nascent) ----------
1128 sub archive_api_query_cmd ($) {
1130 my @cmd = (@curl, qw(-sS));
1131 my $url = access_cfg('archive-query-url');
1132 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1134 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1135 foreach my $key (split /\:/, $keys) {
1136 $key =~ s/\%HOST\%/$host/g;
1138 fail "for $url: stat $key: $!" unless $!==ENOENT;
1141 fail f_ "config requested specific TLS key but do not know".
1142 " how to get curl to use exactly that EE key (%s)",
1144 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1145 # # Sadly the above line does not work because of changes
1146 # # to gnutls. The real fix for #790093 may involve
1147 # # new curl options.
1150 # Fixing #790093 properly will involve providing a value
1151 # for this on clients.
1152 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1153 push @cmd, split / /, $kargs if defined $kargs;
1155 push @cmd, $url.$subpath;
1159 sub api_query ($$;$) {
1161 my ($data, $subpath, $ok404) = @_;
1162 badcfg __ "ftpmasterapi archive query method takes no data part"
1164 my @cmd = archive_api_query_cmd($subpath);
1165 my $url = $cmd[$#cmd];
1166 push @cmd, qw(-w %{http_code});
1167 my $json = cmdoutput @cmd;
1168 unless ($json =~ s/\d+\d+\d$//) {
1169 failedcmd_report_cmd undef, @cmd;
1170 fail __ "curl failed to print 3-digit HTTP code";
1173 return undef if $code eq '404' && $ok404;
1174 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1175 unless $url =~ m#^file://# or $code =~ m/^2/;
1176 return decode_json($json);
1179 sub canonicalise_suite_ftpmasterapi {
1180 my ($proto,$data) = @_;
1181 my $suites = api_query($data, 'suites');
1183 foreach my $entry (@$suites) {
1185 my $v = $entry->{$_};
1186 defined $v && $v eq $isuite;
1187 } qw(codename name);
1188 push @matched, $entry;
1190 fail f_ "unknown suite %s, maybe -d would help", $isuite
1194 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1195 $cn = "$matched[0]{codename}";
1196 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1197 $cn =~ m/^$suite_re$/
1198 or die f_ "suite %s maps to bad codename\n", $isuite;
1200 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1205 sub archive_query_ftpmasterapi {
1206 my ($proto,$data) = @_;
1207 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1209 my $digester = Digest::SHA->new(256);
1210 foreach my $entry (@$info) {
1212 my $vsn = "$entry->{version}";
1213 my ($ok,$msg) = version_check $vsn;
1214 die f_ "bad version: %s\n", $msg unless $ok;
1215 my $component = "$entry->{component}";
1216 $component =~ m/^$component_re$/ or die __ "bad component";
1217 my $filename = "$entry->{filename}";
1218 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1219 or die __ "bad filename";
1220 my $sha256sum = "$entry->{sha256sum}";
1221 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1222 push @rows, [ $vsn, "/pool/$component/$filename",
1223 $digester, $sha256sum ];
1225 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1228 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1229 return archive_query_prepend_mirror @rows;
1232 sub file_in_archive_ftpmasterapi {
1233 my ($proto,$data,$filename) = @_;
1234 my $pat = $filename;
1237 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1238 my $info = api_query($data, "file_in_archive/$pat", 1);
1241 sub package_not_wholly_new_ftpmasterapi {
1242 my ($proto,$data,$pkg) = @_;
1243 my $info = api_query($data,"madison?package=${pkg}&f=json");
1247 #---------- `aptget' archive query method ----------
1250 our $aptget_releasefile;
1251 our $aptget_configpath;
1253 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1254 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1256 sub aptget_cache_clean {
1257 runcmd_ordryrun_local qw(sh -ec),
1258 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1262 sub aptget_lock_acquire () {
1263 my $lockfile = "$aptget_base/lock";
1264 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1265 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1268 sub aptget_prep ($) {
1270 return if defined $aptget_base;
1272 badcfg __ "aptget archive query method takes no data part"
1275 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1278 ensuredir "$cache/dgit";
1280 access_cfg('aptget-cachekey','RETURN-UNDEF')
1281 // access_nomdistro();
1283 $aptget_base = "$cache/dgit/aptget";
1284 ensuredir $aptget_base;
1286 my $quoted_base = $aptget_base;
1287 confess "$quoted_base contains bad chars, cannot continue"
1288 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1290 ensuredir $aptget_base;
1292 aptget_lock_acquire();
1294 aptget_cache_clean();
1296 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1297 my $sourceslist = "source.list#$cachekey";
1299 my $aptsuites = $isuite;
1300 cfg_apply_map(\$aptsuites, 'suite map',
1301 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1303 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1304 printf SRCS "deb-src %s %s %s\n",
1305 access_cfg('mirror'),
1307 access_cfg('aptget-components')
1310 ensuredir "$aptget_base/cache";
1311 ensuredir "$aptget_base/lists";
1313 open CONF, ">", $aptget_configpath or confess "$!";
1315 Debug::NoLocking "true";
1316 APT::Get::List-Cleanup "false";
1317 #clear APT::Update::Post-Invoke-Success;
1318 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1319 Dir::State::Lists "$quoted_base/lists";
1320 Dir::Etc::preferences "$quoted_base/preferences";
1321 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1322 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1325 foreach my $key (qw(
1328 Dir::Cache::Archives
1329 Dir::Etc::SourceParts
1330 Dir::Etc::preferencesparts
1332 ensuredir "$aptget_base/$key";
1333 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1336 my $oldatime = (time // confess "$!") - 1;
1337 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1338 next unless stat_exists $oldlist;
1339 my ($mtime) = (stat _)[9];
1340 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1343 runcmd_ordryrun_local aptget_aptget(), qw(update);
1346 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1347 next unless stat_exists $oldlist;
1348 my ($atime) = (stat _)[8];
1349 next if $atime == $oldatime;
1350 push @releasefiles, $oldlist;
1352 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1353 @releasefiles = @inreleasefiles if @inreleasefiles;
1354 if (!@releasefiles) {
1355 fail f_ <<END, $isuite, $cache;
1356 apt seemed to not to update dgit's cached Release files for %s.
1358 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1361 confess "apt updated too many Release files (@releasefiles), erk"
1362 unless @releasefiles == 1;
1364 ($aptget_releasefile) = @releasefiles;
1367 sub canonicalise_suite_aptget {
1368 my ($proto,$data) = @_;
1371 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1373 foreach my $name (qw(Codename Suite)) {
1374 my $val = $release->{$name};
1376 printdebug "release file $name: $val\n";
1377 $val =~ m/^$suite_re$/o or fail f_
1378 "Release file (%s) specifies intolerable %s",
1379 $aptget_releasefile, $name;
1380 cfg_apply_map(\$val, 'suite rmap',
1381 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1388 sub archive_query_aptget {
1389 my ($proto,$data) = @_;
1392 ensuredir "$aptget_base/source";
1393 foreach my $old (<$aptget_base/source/*.dsc>) {
1394 unlink $old or die "$old: $!";
1397 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1398 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1399 # avoids apt-get source failing with ambiguous error code
1401 runcmd_ordryrun_local
1402 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1403 aptget_aptget(), qw(--download-only --only-source source), $package;
1405 my @dscs = <$aptget_base/source/*.dsc>;
1406 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1407 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1410 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1413 my $uri = "file://". uri_escape $dscs[0];
1414 $uri =~ s{\%2f}{/}gi;
1415 return [ (getfield $pre_dsc, 'Version'), $uri ];
1418 sub file_in_archive_aptget () { return undef; }
1419 sub package_not_wholly_new_aptget () { return undef; }
1421 #---------- `dummyapicat' archive query method ----------
1422 # (untranslated, because this is for testing purposes etc.)
1424 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1425 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1427 sub dummycatapi_run_in_mirror ($@) {
1428 # runs $fn with FIA open onto rune
1429 my ($rune, $argl, $fn) = @_;
1431 my $mirror = access_cfg('mirror');
1432 $mirror =~ s#^file://#/# or die "$mirror ?";
1433 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1434 qw(x), $mirror, @$argl);
1435 debugcmd "-|", @cmd;
1436 open FIA, "-|", @cmd or confess "$!";
1438 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1442 sub file_in_archive_dummycatapi ($$$) {
1443 my ($proto,$data,$filename) = @_;
1445 dummycatapi_run_in_mirror '
1446 find -name "$1" -print0 |
1448 ', [$filename], sub {
1451 printdebug "| $_\n";
1452 m/^(\w+) (\S+)$/ or die "$_ ?";
1453 push @out, { sha256sum => $1, filename => $2 };
1459 sub package_not_wholly_new_dummycatapi {
1460 my ($proto,$data,$pkg) = @_;
1461 dummycatapi_run_in_mirror "
1462 find -name ${pkg}_*.dsc
1469 #---------- `madison' archive query method ----------
1471 sub archive_query_madison {
1472 return archive_query_prepend_mirror
1473 map { [ @$_[0..1] ] } madison_get_parse(@_);
1476 sub madison_get_parse {
1477 my ($proto,$data) = @_;
1478 die unless $proto eq 'madison';
1479 if (!length $data) {
1480 $data= access_cfg('madison-distro','RETURN-UNDEF');
1481 $data //= access_basedistro();
1483 $rmad{$proto,$data,$package} ||= cmdoutput
1484 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1485 my $rmad = $rmad{$proto,$data,$package};
1488 foreach my $l (split /\n/, $rmad) {
1489 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1490 \s*( [^ \t|]+ )\s* \|
1491 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1492 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1493 $1 eq $package or die "$rmad $package ?";
1500 $component = access_cfg('archive-query-default-component');
1502 $5 eq 'source' or die "$rmad ?";
1503 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1505 return sort { -version_compare($a->[0],$b->[0]); } @out;
1508 sub canonicalise_suite_madison {
1509 # madison canonicalises for us
1510 my @r = madison_get_parse(@_);
1512 "unable to canonicalise suite using package %s".
1513 " which does not appear to exist in suite %s;".
1514 " --existing-package may help",
1519 sub file_in_archive_madison { return undef; }
1520 sub package_not_wholly_new_madison { return undef; }
1522 #---------- `sshpsql' archive query method ----------
1523 # (untranslated, because this is obsolete)
1526 my ($data,$runeinfo,$sql) = @_;
1527 if (!length $data) {
1528 $data= access_someuserhost('sshpsql').':'.
1529 access_cfg('sshpsql-dbname');
1531 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1532 my ($userhost,$dbname) = ($`,$'); #';
1534 my @cmd = (access_cfg_ssh, $userhost,
1535 access_runeinfo("ssh-psql $runeinfo").
1536 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1537 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1539 open P, "-|", @cmd or confess "$!";
1542 printdebug(">|$_|\n");
1545 $!=0; $?=0; close P or failedcmd @cmd;
1547 my $nrows = pop @rows;
1548 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1549 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1550 @rows = map { [ split /\|/, $_ ] } @rows;
1551 my $ncols = scalar @{ shift @rows };
1552 die if grep { scalar @$_ != $ncols } @rows;
1556 sub sql_injection_check {
1557 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1560 sub archive_query_sshpsql ($$) {
1561 my ($proto,$data) = @_;
1562 sql_injection_check $isuite, $package;
1563 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1564 SELECT source.version, component.name, files.filename, files.sha256sum
1566 JOIN src_associations ON source.id = src_associations.source
1567 JOIN suite ON suite.id = src_associations.suite
1568 JOIN dsc_files ON dsc_files.source = source.id
1569 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1570 JOIN component ON component.id = files_archive_map.component_id
1571 JOIN files ON files.id = dsc_files.file
1572 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1573 AND source.source='$package'
1574 AND files.filename LIKE '%.dsc';
1576 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1577 my $digester = Digest::SHA->new(256);
1579 my ($vsn,$component,$filename,$sha256sum) = @$_;
1580 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1582 return archive_query_prepend_mirror @rows;
1585 sub canonicalise_suite_sshpsql ($$) {
1586 my ($proto,$data) = @_;
1587 sql_injection_check $isuite;
1588 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1589 SELECT suite.codename
1590 FROM suite where suite_name='$isuite' or codename='$isuite';
1592 @rows = map { $_->[0] } @rows;
1593 fail "unknown suite $isuite" unless @rows;
1594 die "ambiguous $isuite: @rows ?" if @rows>1;
1598 sub file_in_archive_sshpsql ($$$) { return undef; }
1599 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1601 #---------- `dummycat' archive query method ----------
1602 # (untranslated, because this is for testing purposes etc.)
1604 sub canonicalise_suite_dummycat ($$) {
1605 my ($proto,$data) = @_;
1606 my $dpath = "$data/suite.$isuite";
1607 if (!open C, "<", $dpath) {
1608 $!==ENOENT or die "$dpath: $!";
1609 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1613 chomp or die "$dpath: $!";
1615 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1619 sub archive_query_dummycat ($$) {
1620 my ($proto,$data) = @_;
1621 canonicalise_suite();
1622 my $dpath = "$data/package.$csuite.$package";
1623 if (!open C, "<", $dpath) {
1624 $!==ENOENT or die "$dpath: $!";
1625 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1633 printdebug "dummycat query $csuite $package $dpath | $_\n";
1634 my @row = split /\s+/, $_;
1635 @row==2 or die "$dpath: $_ ?";
1638 C->error and die "$dpath: $!";
1640 return archive_query_prepend_mirror
1641 sort { -version_compare($a->[0],$b->[0]); } @rows;
1644 sub file_in_archive_dummycat () { return undef; }
1645 sub package_not_wholly_new_dummycat () { return undef; }
1647 #---------- tag format handling ----------
1648 # (untranslated, because everything should be new tag format by now)
1650 sub access_cfg_tagformats () {
1651 split /\,/, access_cfg('dgit-tag-format');
1654 sub access_cfg_tagformats_can_splitbrain () {
1655 my %y = map { $_ => 1 } access_cfg_tagformats;
1656 foreach my $needtf (qw(new maint)) {
1657 next if $y{$needtf};
1663 sub need_tagformat ($$) {
1664 my ($fmt, $why) = @_;
1665 fail "need to use tag format $fmt ($why) but also need".
1666 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1667 " - no way to proceed"
1668 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1669 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1672 sub select_tagformat () {
1674 return if $tagformatfn && !$tagformat_want;
1675 die 'bug' if $tagformatfn && $tagformat_want;
1676 # ... $tagformat_want assigned after previous select_tagformat
1678 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1679 printdebug "select_tagformat supported @supported\n";
1681 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1682 printdebug "select_tagformat specified @$tagformat_want\n";
1684 my ($fmt,$why,$override) = @$tagformat_want;
1686 fail "target distro supports tag formats @supported".
1687 " but have to use $fmt ($why)"
1689 or grep { $_ eq $fmt } @supported;
1691 $tagformat_want = undef;
1693 $tagformatfn = ${*::}{"debiantag_$fmt"};
1695 fail "trying to use unknown tag format \`$fmt' ($why) !"
1696 unless $tagformatfn;
1699 #---------- archive query entrypoints and rest of program ----------
1701 sub canonicalise_suite () {
1702 return if defined $csuite;
1703 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1704 $csuite = archive_query('canonicalise_suite');
1705 if ($isuite ne $csuite) {
1706 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1708 progress f_ "canonical suite name is %s", $csuite;
1712 sub get_archive_dsc () {
1713 canonicalise_suite();
1714 my @vsns = archive_query('archive_query');
1715 foreach my $vinfo (@vsns) {
1716 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1717 $dscurl = $vsn_dscurl;
1718 $dscdata = url_get($dscurl);
1720 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1725 $digester->add($dscdata);
1726 my $got = $digester->hexdigest();
1728 fail f_ "%s has hash %s but archive told us to expect %s",
1729 $dscurl, $got, $digest;
1732 my $fmt = getfield $dsc, 'Format';
1733 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1734 f_ "unsupported source format %s, sorry", $fmt;
1736 $dsc_checked = !!$digester;
1737 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1741 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1744 sub check_for_git ();
1745 sub check_for_git () {
1747 my $how = access_cfg('git-check');
1748 if ($how eq 'ssh-cmd') {
1750 (access_cfg_ssh, access_gituserhost(),
1751 access_runeinfo("git-check $package").
1752 " set -e; cd ".access_cfg('git-path').";".
1753 " if test -d $package.git; then echo 1; else echo 0; fi");
1754 my $r= cmdoutput @cmd;
1755 if (defined $r and $r =~ m/^divert (\w+)$/) {
1757 my ($usedistro,) = access_distros();
1758 # NB that if we are pushing, $usedistro will be $distro/push
1759 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1760 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1761 progress f_ "diverting to %s (using config for %s)",
1762 $divert, $instead_distro;
1763 return check_for_git();
1765 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1767 } elsif ($how eq 'url') {
1768 my $prefix = access_cfg('git-check-url','git-url');
1769 my $suffix = access_cfg('git-check-suffix','git-suffix',
1770 'RETURN-UNDEF') // '.git';
1771 my $url = "$prefix/$package$suffix";
1772 my @cmd = (@curl, qw(-sS -I), $url);
1773 my $result = cmdoutput @cmd;
1774 $result =~ s/^\S+ 200 .*\n\r?\n//;
1775 # curl -sS -I with https_proxy prints
1776 # HTTP/1.0 200 Connection established
1777 $result =~ m/^\S+ (404|200) /s or
1778 fail +(__ "unexpected results from git check query - ").
1779 Dumper($prefix, $result);
1781 if ($code eq '404') {
1783 } elsif ($code eq '200') {
1788 } elsif ($how eq 'true') {
1790 } elsif ($how eq 'false') {
1793 badcfg f_ "unknown git-check \`%s'", $how;
1797 sub create_remote_git_repo () {
1798 my $how = access_cfg('git-create');
1799 if ($how eq 'ssh-cmd') {
1801 (access_cfg_ssh, access_gituserhost(),
1802 access_runeinfo("git-create $package").
1803 "set -e; cd ".access_cfg('git-path').";".
1804 " cp -a _template $package.git");
1805 } elsif ($how eq 'true') {
1808 badcfg f_ "unknown git-create \`%s'", $how;
1812 our ($dsc_hash,$lastpush_mergeinput);
1813 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1817 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1818 $playground = fresh_playground 'dgit/unpack';
1821 sub mktree_in_ud_here () {
1822 playtree_setup $gitcfgs{local};
1825 sub git_write_tree () {
1826 my $tree = cmdoutput @git, qw(write-tree);
1827 $tree =~ m/^\w+$/ or die "$tree ?";
1831 sub git_add_write_tree () {
1832 runcmd @git, qw(add -Af .);
1833 return git_write_tree();
1836 sub remove_stray_gits ($) {
1838 my @gitscmd = qw(find -name .git -prune -print0);
1839 debugcmd "|",@gitscmd;
1840 open GITS, "-|", @gitscmd or confess "$!";
1845 print STDERR f_ "%s: warning: removing from %s: %s\n",
1846 $us, $what, (messagequote $_);
1850 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1853 sub mktree_in_ud_from_only_subdir ($;$) {
1854 my ($what,$raw) = @_;
1855 # changes into the subdir
1858 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1859 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1863 remove_stray_gits($what);
1864 mktree_in_ud_here();
1866 my ($format, $fopts) = get_source_format();
1867 if (madformat($format)) {
1872 my $tree=git_add_write_tree();
1873 return ($tree,$dir);
1876 our @files_csum_info_fields =
1877 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1878 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1879 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1881 sub dsc_files_info () {
1882 foreach my $csumi (@files_csum_info_fields) {
1883 my ($fname, $module, $method) = @$csumi;
1884 my $field = $dsc->{$fname};
1885 next unless defined $field;
1886 eval "use $module; 1;" or die $@;
1888 foreach (split /\n/, $field) {
1890 m/^(\w+) (\d+) (\S+)$/ or
1891 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1892 my $digester = eval "$module"."->$method;" or die $@;
1897 Digester => $digester,
1902 fail f_ "missing any supported Checksums-* or Files field in %s",
1903 $dsc->get_option('name');
1907 map { $_->{Filename} } dsc_files_info();
1910 sub files_compare_inputs (@) {
1915 my $showinputs = sub {
1916 return join "; ", map { $_->get_option('name') } @$inputs;
1919 foreach my $in (@$inputs) {
1921 my $in_name = $in->get_option('name');
1923 printdebug "files_compare_inputs $in_name\n";
1925 foreach my $csumi (@files_csum_info_fields) {
1926 my ($fname) = @$csumi;
1927 printdebug "files_compare_inputs $in_name $fname\n";
1929 my $field = $in->{$fname};
1930 next unless defined $field;
1933 foreach (split /\n/, $field) {
1936 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1937 fail "could not parse $in_name $fname line \`$_'";
1939 printdebug "files_compare_inputs $in_name $fname $f\n";
1943 my $re = \ $record{$f}{$fname};
1945 $fchecked{$f}{$in_name} = 1;
1948 "hash or size of %s varies in %s fields (between: %s)",
1949 $f, $fname, $showinputs->();
1954 @files = sort @files;
1955 $expected_files //= \@files;
1956 "@$expected_files" eq "@files" or
1957 fail f_ "file list in %s varies between hash fields!",
1961 fail f_ "%s has no files list field(s)", $in_name;
1963 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1966 grep { keys %$_ == @$inputs-1 } values %fchecked
1967 or fail f_ "no file appears in all file lists (looked in: %s)",
1971 sub is_orig_file_in_dsc ($$) {
1972 my ($f, $dsc_files_info) = @_;
1973 return 0 if @$dsc_files_info <= 1;
1974 # One file means no origs, and the filename doesn't have a "what
1975 # part of dsc" component. (Consider versions ending `.orig'.)
1976 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1980 # This function determines whether a .changes file is source-only from
1981 # the point of view of dak. Thus, it permits *_source.buildinfo
1984 # It does not, however, permit any other buildinfo files. After a
1985 # source-only upload, the buildds will try to upload files like
1986 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1987 # named like this in their (otherwise) source-only upload, the uploads
1988 # of the buildd can be rejected by dak. Fixing the resultant
1989 # situation can require manual intervention. So we block such
1990 # .buildinfo files when the user tells us to perform a source-only
1991 # upload (such as when using the push-source subcommand with the -C
1992 # option, which calls this function).
1994 # Note, though, that when dgit is told to prepare a source-only
1995 # upload, such as when subcommands like build-source and push-source
1996 # without -C are used, dgit has a more restrictive notion of
1997 # source-only .changes than dak: such uploads will never include
1998 # *_source.buildinfo files. This is because there is no use for such
1999 # files when using a tool like dgit to produce the source package, as
2000 # dgit ensures the source is identical to git HEAD.
2001 sub test_source_only_changes ($) {
2003 foreach my $l (split /\n/, getfield $changes, 'Files') {
2004 $l =~ m/\S+$/ or next;
2005 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2006 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
2007 print f_ "purportedly source-only changes polluted by %s\n", $&;
2014 sub changes_update_origs_from_dsc ($$$$) {
2015 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2017 printdebug "checking origs needed ($upstreamvsn)...\n";
2018 $_ = getfield $changes, 'Files';
2019 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2020 fail __ "cannot find section/priority from .changes Files field";
2021 my $placementinfo = $1;
2023 printdebug "checking origs needed placement '$placementinfo'...\n";
2024 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2025 $l =~ m/\S+$/ or next;
2027 printdebug "origs $file | $l\n";
2028 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2029 printdebug "origs $file is_orig\n";
2030 my $have = archive_query('file_in_archive', $file);
2031 if (!defined $have) {
2032 print STDERR __ <<END;
2033 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2039 printdebug "origs $file \$#\$have=$#$have\n";
2040 foreach my $h (@$have) {
2043 foreach my $csumi (@files_csum_info_fields) {
2044 my ($fname, $module, $method, $archivefield) = @$csumi;
2045 next unless defined $h->{$archivefield};
2046 $_ = $dsc->{$fname};
2047 next unless defined;
2048 m/^(\w+) .* \Q$file\E$/m or
2049 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2050 if ($h->{$archivefield} eq $1) {
2054 "%s: %s (archive) != %s (local .dsc)",
2055 $archivefield, $h->{$archivefield}, $1;
2058 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2062 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2065 printdebug "origs $file f.same=$found_same".
2066 " #f._differ=$#found_differ\n";
2067 if (@found_differ && !$found_same) {
2069 (f_ "archive contains %s with different checksum", $file),
2072 # Now we edit the changes file to add or remove it
2073 foreach my $csumi (@files_csum_info_fields) {
2074 my ($fname, $module, $method, $archivefield) = @$csumi;
2075 next unless defined $changes->{$fname};
2077 # in archive, delete from .changes if it's there
2078 $changed{$file} = "removed" if
2079 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2080 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2081 # not in archive, but it's here in the .changes
2083 my $dsc_data = getfield $dsc, $fname;
2084 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2086 $extra =~ s/ \d+ /$&$placementinfo /
2087 or confess "$fname $extra >$dsc_data< ?"
2088 if $fname eq 'Files';
2089 $changes->{$fname} .= "\n". $extra;
2090 $changed{$file} = "added";
2095 foreach my $file (keys %changed) {
2097 "edited .changes for archive .orig contents: %s %s",
2098 $changed{$file}, $file;
2100 my $chtmp = "$changesfile.tmp";
2101 $changes->save($chtmp);
2103 rename $chtmp,$changesfile or die "$changesfile $!";
2105 progress f_ "[new .changes left in %s]", $changesfile;
2108 progress f_ "%s already has appropriate .orig(s) (if any)",
2113 sub make_commit ($) {
2115 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2118 sub clogp_authline ($) {
2120 my $author = getfield $clogp, 'Maintainer';
2121 if ($author =~ m/^[^"\@]+\,/) {
2122 # single entry Maintainer field with unquoted comma
2123 $author = ($& =~ y/,//rd).$'; # strip the comma
2125 # git wants a single author; any remaining commas in $author
2126 # are by now preceded by @ (or "). It seems safer to punt on
2127 # "..." for now rather than attempting to dequote or something.
2128 $author =~ s#,.*##ms unless $author =~ m/"/;
2129 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2130 my $authline = "$author $date";
2131 $authline =~ m/$git_authline_re/o or
2132 fail f_ "unexpected commit author line format \`%s'".
2133 " (was generated from changelog Maintainer field)",
2135 return ($1,$2,$3) if wantarray;
2139 sub vendor_patches_distro ($$) {
2140 my ($checkdistro, $what) = @_;
2141 return unless defined $checkdistro;
2143 my $series = "debian/patches/\L$checkdistro\E.series";
2144 printdebug "checking for vendor-specific $series ($what)\n";
2146 if (!open SERIES, "<", $series) {
2147 confess "$series $!" unless $!==ENOENT;
2154 print STDERR __ <<END;
2156 Unfortunately, this source package uses a feature of dpkg-source where
2157 the same source package unpacks to different source code on different
2158 distros. dgit cannot safely operate on such packages on affected
2159 distros, because the meaning of source packages is not stable.
2161 Please ask the distro/maintainer to remove the distro-specific series
2162 files and use a different technique (if necessary, uploading actually
2163 different packages, if different distros are supposed to have
2167 fail f_ "Found active distro-specific series file for".
2168 " %s (%s): %s, cannot continue",
2169 $checkdistro, $what, $series;
2171 die "$series $!" if SERIES->error;
2175 sub check_for_vendor_patches () {
2176 # This dpkg-source feature doesn't seem to be documented anywhere!
2177 # But it can be found in the changelog (reformatted):
2179 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2180 # Author: Raphael Hertzog <hertzog@debian.org>
2181 # Date: Sun Oct 3 09:36:48 2010 +0200
2183 # dpkg-source: correctly create .pc/.quilt_series with alternate
2186 # If you have debian/patches/ubuntu.series and you were
2187 # unpacking the source package on ubuntu, quilt was still
2188 # directed to debian/patches/series instead of
2189 # debian/patches/ubuntu.series.
2191 # debian/changelog | 3 +++
2192 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2193 # 2 files changed, 6 insertions(+), 1 deletion(-)
2196 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2197 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2198 __ "Dpkg::Vendor \`current vendor'");
2199 vendor_patches_distro(access_basedistro(),
2200 __ "(base) distro being accessed");
2201 vendor_patches_distro(access_nomdistro(),
2202 __ "(nominal) distro being accessed");
2205 sub check_bpd_exists () {
2206 stat $buildproductsdir
2207 or fail f_ "build-products-dir %s is not accessible: %s\n",
2208 $buildproductsdir, $!;
2211 sub dotdot_bpd_transfer_origs ($$$) {
2212 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2213 # checks is_orig_file_of_vsn and if
2214 # calls $wanted->{$leaf} and expects boolish
2216 return if $buildproductsdir eq '..';
2219 my $dotdot = $maindir;
2220 $dotdot =~ s{/[^/]+$}{};
2221 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2222 while ($!=0, defined(my $leaf = readdir DD)) {
2224 local ($debuglevel) = $debuglevel-1;
2225 printdebug "DD_BPD $leaf ?\n";
2227 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2228 next unless $wanted->($leaf);
2229 next if lstat "$bpd_abs/$leaf";
2232 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2235 $! == &ENOENT or fail f_
2236 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2237 lstat "$dotdot/$leaf" or fail f_
2238 "check orig file %s in ..: %s", $leaf, $!;
2240 stat "$dotdot/$leaf" or fail f_
2241 "check target of orig symlink %s in ..: %s", $leaf, $!;
2242 my $ltarget = readlink "$dotdot/$leaf" or
2243 die "readlink $dotdot/$leaf: $!";
2244 if ($ltarget !~ m{^/}) {
2245 $ltarget = "$dotdot/$ltarget";
2247 symlink $ltarget, "$bpd_abs/$leaf"
2248 or die "$ltarget $bpd_abs $leaf: $!";
2250 "%s: cloned orig symlink from ..: %s\n",
2252 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2254 "%s: hardlinked orig from ..: %s\n",
2256 } elsif ($! != EXDEV) {
2257 fail f_ "failed to make %s a hardlink to %s: %s",
2258 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2260 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2261 or die "$bpd_abs $dotdot $leaf $!";
2263 "%s: symmlinked orig from .. on other filesystem: %s\n",
2267 die "$dotdot; $!" if $!;
2271 sub generate_commits_from_dsc () {
2272 # See big comment in fetch_from_archive, below.
2273 # See also README.dsc-import.
2275 changedir $playground;
2277 my $bpd_abs = bpd_abs();
2278 my $upstreamv = upstreamversion $dsc->{version};
2279 my @dfi = dsc_files_info();
2281 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2282 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2284 foreach my $fi (@dfi) {
2285 my $f = $fi->{Filename};
2286 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2287 my $upper_f = "$bpd_abs/$f";
2289 printdebug "considering reusing $f: ";
2291 if (link_ltarget "$upper_f,fetch", $f) {
2292 printdebug "linked (using ...,fetch).\n";
2293 } elsif ((printdebug "($!) "),
2295 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2296 } elsif (link_ltarget $upper_f, $f) {
2297 printdebug "linked.\n";
2298 } elsif ((printdebug "($!) "),
2300 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2302 printdebug "absent.\n";
2306 complete_file_from_dsc('.', $fi, \$refetched)
2309 printdebug "considering saving $f: ";
2311 if (rename_link_xf 1, $f, $upper_f) {
2312 printdebug "linked.\n";
2313 } elsif ((printdebug "($@) "),
2315 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2316 } elsif (!$refetched) {
2317 printdebug "no need.\n";
2318 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2319 printdebug "linked (using ...,fetch).\n";
2320 } elsif ((printdebug "($@) "),
2322 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2324 printdebug "cannot.\n";
2328 # We unpack and record the orig tarballs first, so that we only
2329 # need disk space for one private copy of the unpacked source.
2330 # But we can't make them into commits until we have the metadata
2331 # from the debian/changelog, so we record the tree objects now and
2332 # make them into commits later.
2334 my $orig_f_base = srcfn $upstreamv, '';
2336 foreach my $fi (@dfi) {
2337 # We actually import, and record as a commit, every tarball
2338 # (unless there is only one file, in which case there seems
2341 my $f = $fi->{Filename};
2342 printdebug "import considering $f ";
2343 (printdebug "only one dfi\n"), next if @dfi == 1;
2344 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2345 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2349 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2351 printdebug "Y ", (join ' ', map { $_//"(none)" }
2352 $compr_ext, $orig_f_part
2355 my $input = new IO::File $f, '<' or die "$f $!";
2359 if (defined $compr_ext) {
2361 Dpkg::Compression::compression_guess_from_filename $f;
2362 fail "Dpkg::Compression cannot handle file $f in source package"
2363 if defined $compr_ext && !defined $cname;
2365 new Dpkg::Compression::Process compression => $cname;
2366 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2367 my $compr_fh = new IO::Handle;
2368 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2370 open STDIN, "<&", $input or confess "$!";
2372 die "dgit (child): exec $compr_cmd[0]: $!\n";
2377 rmtree "_unpack-tar";
2378 mkdir "_unpack-tar" or confess "$!";
2379 my @tarcmd = qw(tar -x -f -
2380 --no-same-owner --no-same-permissions
2381 --no-acls --no-xattrs --no-selinux);
2382 my $tar_pid = fork // confess "$!";
2384 chdir "_unpack-tar" or confess "$!";
2385 open STDIN, "<&", $input or confess "$!";
2387 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2389 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2390 !$? or failedcmd @tarcmd;
2393 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2395 # finally, we have the results in "tarball", but maybe
2396 # with the wrong permissions
2398 runcmd qw(chmod -R +rwX _unpack-tar);
2399 changedir "_unpack-tar";
2400 remove_stray_gits($f);
2401 mktree_in_ud_here();
2403 my ($tree) = git_add_write_tree();
2404 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2405 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2407 printdebug "one subtree $1\n";
2409 printdebug "multiple subtrees\n";
2412 rmtree "_unpack-tar";
2414 my $ent = [ $f, $tree ];
2416 Orig => !!$orig_f_part,
2417 Sort => (!$orig_f_part ? 2 :
2418 $orig_f_part =~ m/-/g ? 1 :
2426 # put any without "_" first (spec is not clear whether files
2427 # are always in the usual order). Tarballs without "_" are
2428 # the main orig or the debian tarball.
2429 $a->{Sort} <=> $b->{Sort} or
2433 my $any_orig = grep { $_->{Orig} } @tartrees;
2435 my $dscfn = "$package.dsc";
2437 my $treeimporthow = 'package';
2439 open D, ">", $dscfn or die "$dscfn: $!";
2440 print D $dscdata or die "$dscfn: $!";
2441 close D or die "$dscfn: $!";
2442 my @cmd = qw(dpkg-source);
2443 push @cmd, '--no-check' if $dsc_checked;
2444 if (madformat $dsc->{format}) {
2445 push @cmd, '--skip-patches';
2446 $treeimporthow = 'unpatched';
2448 push @cmd, qw(-x --), $dscfn;
2451 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2452 if (madformat $dsc->{format}) {
2453 check_for_vendor_patches();
2457 if (madformat $dsc->{format}) {
2458 my @pcmd = qw(dpkg-source --before-build .);
2459 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2461 $dappliedtree = git_add_write_tree();
2464 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2468 printdebug "import clog search...\n";
2469 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2470 my ($thisstanza, $desc) = @_;
2471 no warnings qw(exiting);
2473 $clogp //= $thisstanza;
2475 printdebug "import clog $thisstanza->{version} $desc...\n";
2477 last if !$any_orig; # we don't need $r1clogp
2479 # We look for the first (most recent) changelog entry whose
2480 # version number is lower than the upstream version of this
2481 # package. Then the last (least recent) previous changelog
2482 # entry is treated as the one which introduced this upstream
2483 # version and used for the synthetic commits for the upstream
2486 # One might think that a more sophisticated algorithm would be
2487 # necessary. But: we do not want to scan the whole changelog
2488 # file. Stopping when we see an earlier version, which
2489 # necessarily then is an earlier upstream version, is the only
2490 # realistic way to do that. Then, either the earliest
2491 # changelog entry we have seen so far is indeed the earliest
2492 # upload of this upstream version; or there are only changelog
2493 # entries relating to later upstream versions (which is not
2494 # possible unless the changelog and .dsc disagree about the
2495 # version). Then it remains to choose between the physically
2496 # last entry in the file, and the one with the lowest version
2497 # number. If these are not the same, we guess that the
2498 # versions were created in a non-monotonic order rather than
2499 # that the changelog entries have been misordered.
2501 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2503 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2504 $r1clogp = $thisstanza;
2506 printdebug "import clog $r1clogp->{version} becomes r1\n";
2509 $clogp or fail __ "package changelog has no entries!";
2511 my $authline = clogp_authline $clogp;
2512 my $changes = getfield $clogp, 'Changes';
2513 $changes =~ s/^\n//; # Changes: \n
2514 my $cversion = getfield $clogp, 'Version';
2517 $r1clogp //= $clogp; # maybe there's only one entry;
2518 my $r1authline = clogp_authline $r1clogp;
2519 # Strictly, r1authline might now be wrong if it's going to be
2520 # unused because !$any_orig. Whatever.
2522 printdebug "import tartrees authline $authline\n";
2523 printdebug "import tartrees r1authline $r1authline\n";
2525 foreach my $tt (@tartrees) {
2526 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2528 my $mbody = f_ "Import %s", $tt->{F};
2529 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2532 committer $r1authline
2536 [dgit import orig $tt->{F}]
2544 [dgit import tarball $package $cversion $tt->{F}]
2549 printdebug "import main commit\n";
2551 open C, ">../commit.tmp" or confess "$!";
2552 print C <<END or confess "$!";
2555 print C <<END or confess "$!" foreach @tartrees;
2558 print C <<END or confess "$!";
2564 [dgit import $treeimporthow $package $cversion]
2567 close C or confess "$!";
2568 my $rawimport_hash = make_commit qw(../commit.tmp);
2570 if (madformat $dsc->{format}) {
2571 printdebug "import apply patches...\n";
2573 # regularise the state of the working tree so that
2574 # the checkout of $rawimport_hash works nicely.
2575 my $dappliedcommit = make_commit_text(<<END);
2582 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2584 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2586 # We need the answers to be reproducible
2587 my @authline = clogp_authline($clogp);
2588 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2589 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2590 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2591 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2592 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2593 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2595 my $path = $ENV{PATH} or die;
2597 # we use ../../gbp-pq-output, which (given that we are in
2598 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2601 foreach my $use_absurd (qw(0 1)) {
2602 runcmd @git, qw(checkout -q unpa);
2603 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2604 local $ENV{PATH} = $path;
2607 progress "warning: $@";
2608 $path = "$absurdity:$path";
2609 progress f_ "%s: trying slow absurd-git-apply...", $us;
2610 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2615 die "forbid absurd git-apply\n" if $use_absurd
2616 && forceing [qw(import-gitapply-no-absurd)];
2617 die "only absurd git-apply!\n" if !$use_absurd
2618 && forceing [qw(import-gitapply-absurd)];
2620 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2621 local $ENV{PATH} = $path if $use_absurd;
2623 my @showcmd = (gbp_pq, qw(import));
2624 my @realcmd = shell_cmd
2625 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2626 debugcmd "+",@realcmd;
2627 if (system @realcmd) {
2628 die f_ "%s failed: %s\n",
2629 +(shellquote @showcmd),
2630 failedcmd_waitstatus();
2633 my $gapplied = git_rev_parse('HEAD');
2634 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2635 $gappliedtree eq $dappliedtree or
2636 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2637 gbp-pq import and dpkg-source disagree!
2638 gbp-pq import gave commit %s
2639 gbp-pq import gave tree %s
2640 dpkg-source --before-build gave tree %s
2642 $rawimport_hash = $gapplied;
2647 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2652 progress f_ "synthesised git commit from .dsc %s", $cversion;
2654 my $rawimport_mergeinput = {
2655 Commit => $rawimport_hash,
2656 Info => __ "Import of source package",
2658 my @output = ($rawimport_mergeinput);
2660 if ($lastpush_mergeinput) {
2661 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2662 my $oversion = getfield $oldclogp, 'Version';
2664 version_compare($oversion, $cversion);
2666 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2667 { ReverseParents => 1,
2668 Message => (f_ <<END, $package, $cversion, $csuite) });
2669 Record %s (%s) in archive suite %s
2671 } elsif ($vcmp > 0) {
2672 print STDERR f_ <<END, $cversion, $oversion,
2674 Version actually in archive: %s (older)
2675 Last version pushed with dgit: %s (newer or same)
2678 __ $later_warning_msg or confess "$!";
2679 @output = $lastpush_mergeinput;
2681 # Same version. Use what's in the server git branch,
2682 # discarding our own import. (This could happen if the
2683 # server automatically imports all packages into git.)
2684 @output = $lastpush_mergeinput;
2692 sub complete_file_from_dsc ($$;$) {
2693 our ($dstdir, $fi, $refetched) = @_;
2694 # Ensures that we have, in $dstdir, the file $fi, with the correct
2695 # contents. (Downloading it from alongside $dscurl if necessary.)
2696 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2697 # and will set $$refetched=1 if it did so (or tried to).
2699 my $f = $fi->{Filename};
2700 my $tf = "$dstdir/$f";
2704 my $checkhash = sub {
2705 open F, "<", "$tf" or die "$tf: $!";
2706 $fi->{Digester}->reset();
2707 $fi->{Digester}->addfile(*F);
2708 F->error and confess "$!";
2709 $got = $fi->{Digester}->hexdigest();
2710 return $got eq $fi->{Hash};
2713 if (stat_exists $tf) {
2714 if ($checkhash->()) {
2715 progress f_ "using existing %s", $f;
2719 fail f_ "file %s has hash %s but .dsc demands hash %s".
2720 " (perhaps you should delete this file?)",
2721 $f, $got, $fi->{Hash};
2723 progress f_ "need to fetch correct version of %s", $f;
2724 unlink $tf or die "$tf $!";
2727 printdebug "$tf does not exist, need to fetch\n";
2731 $furl =~ s{/[^/]+$}{};
2733 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2734 die "$f ?" if $f =~ m#/#;
2735 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2736 return 0 if !act_local();
2739 fail f_ "file %s has hash %s but .dsc demands hash %s".
2740 " (got wrong file from archive!)",
2741 $f, $got, $fi->{Hash};
2746 sub ensure_we_have_orig () {
2747 my @dfi = dsc_files_info();
2748 foreach my $fi (@dfi) {
2749 my $f = $fi->{Filename};
2750 next unless is_orig_file_in_dsc($f, \@dfi);
2751 complete_file_from_dsc($buildproductsdir, $fi)
2756 #---------- git fetch ----------
2758 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2759 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2761 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2762 # locally fetched refs because they have unhelpful names and clutter
2763 # up gitk etc. So we track whether we have "used up" head ref (ie,
2764 # whether we have made another local ref which refers to this object).
2766 # (If we deleted them unconditionally, then we might end up
2767 # re-fetching the same git objects each time dgit fetch was run.)
2769 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2770 # in git_fetch_us to fetch the refs in question, and possibly a call
2771 # to lrfetchref_used.
2773 our (%lrfetchrefs_f, %lrfetchrefs_d);
2774 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2776 sub lrfetchref_used ($) {
2777 my ($fullrefname) = @_;
2778 my $objid = $lrfetchrefs_f{$fullrefname};
2779 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2782 sub git_lrfetch_sane {
2783 my ($url, $supplementary, @specs) = @_;
2784 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2785 # at least as regards @specs. Also leave the results in
2786 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2787 # able to clean these up.
2789 # With $supplementary==1, @specs must not contain wildcards
2790 # and we add to our previous fetches (non-atomically).
2792 # This is rather miserable:
2793 # When git fetch --prune is passed a fetchspec ending with a *,
2794 # it does a plausible thing. If there is no * then:
2795 # - it matches subpaths too, even if the supplied refspec
2796 # starts refs, and behaves completely madly if the source
2797 # has refs/refs/something. (See, for example, Debian #NNNN.)
2798 # - if there is no matching remote ref, it bombs out the whole
2800 # We want to fetch a fixed ref, and we don't know in advance
2801 # if it exists, so this is not suitable.
2803 # Our workaround is to use git ls-remote. git ls-remote has its
2804 # own qairks. Notably, it has the absurd multi-tail-matching
2805 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2806 # refs/refs/foo etc.
2808 # Also, we want an idempotent snapshot, but we have to make two
2809 # calls to the remote: one to git ls-remote and to git fetch. The
2810 # solution is use git ls-remote to obtain a target state, and
2811 # git fetch to try to generate it. If we don't manage to generate
2812 # the target state, we try again.
2814 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2816 my $specre = join '|', map {
2819 my $wildcard = $x =~ s/\\\*$/.*/;
2820 die if $wildcard && $supplementary;
2823 printdebug "git_lrfetch_sane specre=$specre\n";
2824 my $wanted_rref = sub {
2826 return m/^(?:$specre)$/;
2829 my $fetch_iteration = 0;
2832 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2833 if (++$fetch_iteration > 10) {
2834 fail __ "too many iterations trying to get sane fetch!";
2837 my @look = map { "refs/$_" } @specs;
2838 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2842 open GITLS, "-|", @lcmd or confess "$!";
2844 printdebug "=> ", $_;
2845 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2846 my ($objid,$rrefname) = ($1,$2);
2847 if (!$wanted_rref->($rrefname)) {
2848 print STDERR f_ <<END, "@look", $rrefname;
2849 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2853 $wantr{$rrefname} = $objid;
2856 close GITLS or failedcmd @lcmd;
2858 # OK, now %want is exactly what we want for refs in @specs
2860 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2861 "+refs/$_:".lrfetchrefs."/$_";
2864 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2866 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2867 runcmd_ordryrun_local @fcmd if @fspecs;
2869 if (!$supplementary) {
2870 %lrfetchrefs_f = ();
2874 git_for_each_ref(lrfetchrefs, sub {
2875 my ($objid,$objtype,$lrefname,$reftail) = @_;
2876 $lrfetchrefs_f{$lrefname} = $objid;
2877 $objgot{$objid} = 1;
2880 if ($supplementary) {
2884 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2885 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2886 if (!exists $wantr{$rrefname}) {
2887 if ($wanted_rref->($rrefname)) {
2889 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2892 print STDERR f_ <<END, "@fspecs", $lrefname
2893 warning: git fetch %s created %s; this is silly, deleting it.
2896 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2897 delete $lrfetchrefs_f{$lrefname};
2901 foreach my $rrefname (sort keys %wantr) {
2902 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2903 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2904 my $want = $wantr{$rrefname};
2905 next if $got eq $want;
2906 if (!defined $objgot{$want}) {
2907 fail __ <<END unless act_local();
2908 --dry-run specified but we actually wanted the results of git fetch,
2909 so this is not going to work. Try running dgit fetch first,
2910 or using --damp-run instead of --dry-run.
2912 print STDERR f_ <<END, $lrefname, $want;
2913 warning: git ls-remote suggests we want %s
2914 warning: and it should refer to %s
2915 warning: but git fetch didn't fetch that object to any relevant ref.
2916 warning: This may be due to a race with someone updating the server.
2917 warning: Will try again...
2919 next FETCH_ITERATION;
2922 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2924 runcmd_ordryrun_local @git, qw(update-ref -m),
2925 "dgit fetch git fetch fixup", $lrefname, $want;
2926 $lrfetchrefs_f{$lrefname} = $want;
2931 if (defined $csuite) {
2932 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2933 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2934 my ($objid,$objtype,$lrefname,$reftail) = @_;
2935 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2936 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2940 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2941 Dumper(\%lrfetchrefs_f);
2944 sub git_fetch_us () {
2945 # Want to fetch only what we are going to use, unless
2946 # deliberately-not-ff, in which case we must fetch everything.
2948 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2950 (quiltmode_splitbrain
2951 ? (map { $_->('*',access_nomdistro) }
2952 \&debiantag_new, \&debiantag_maintview)
2953 : debiantags('*',access_nomdistro));
2954 push @specs, server_branch($csuite);
2955 push @specs, $rewritemap;
2956 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2958 my $url = access_giturl();
2959 git_lrfetch_sane $url, 0, @specs;
2962 my @tagpats = debiantags('*',access_nomdistro);
2964 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2965 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2966 printdebug "currently $fullrefname=$objid\n";
2967 $here{$fullrefname} = $objid;
2969 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2970 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2971 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2972 printdebug "offered $lref=$objid\n";
2973 if (!defined $here{$lref}) {
2974 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2975 runcmd_ordryrun_local @upd;
2976 lrfetchref_used $fullrefname;
2977 } elsif ($here{$lref} eq $objid) {
2978 lrfetchref_used $fullrefname;
2980 print STDERR f_ "Not updating %s from %s to %s.\n",
2981 $lref, $here{$lref}, $objid;
2986 #---------- dsc and archive handling ----------
2988 sub mergeinfo_getclogp ($) {
2989 # Ensures thit $mi->{Clogp} exists and returns it
2991 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2994 sub mergeinfo_version ($) {
2995 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2998 sub fetch_from_archive_record_1 ($) {
3000 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
3001 cmdoutput @git, qw(log -n2), $hash;
3002 # ... gives git a chance to complain if our commit is malformed
3005 sub fetch_from_archive_record_2 ($) {
3007 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3011 dryrun_report @upd_cmd;
3015 sub parse_dsc_field_def_dsc_distro () {
3016 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3017 dgit.default.distro);
3020 sub parse_dsc_field ($$) {
3021 my ($dsc, $what) = @_;
3023 foreach my $field (@ourdscfield) {
3024 $f = $dsc->{$field};
3029 progress f_ "%s: NO git hash", $what;
3030 parse_dsc_field_def_dsc_distro();
3031 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3032 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3033 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3034 $dsc_hint_tag = [ $dsc_hint_tag ];
3035 } elsif ($f =~ m/^\w+\s*$/) {
3037 parse_dsc_field_def_dsc_distro();
3038 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3040 progress f_ "%s: specified git hash", $what;
3042 fail f_ "%s: invalid Dgit info", $what;
3046 sub resolve_dsc_field_commit ($$) {
3047 my ($already_distro, $already_mapref) = @_;
3049 return unless defined $dsc_hash;
3052 defined $already_mapref &&
3053 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3054 ? $already_mapref : undef;
3058 my ($what, @fetch) = @_;
3060 local $idistro = $dsc_distro;
3061 my $lrf = lrfetchrefs;
3063 if (!$chase_dsc_distro) {
3064 progress f_ "not chasing .dsc distro %s: not fetching %s",
3069 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3071 my $url = access_giturl();
3072 if (!defined $url) {
3073 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3074 .dsc Dgit metadata is in context of distro %s
3075 for which we have no configured url and .dsc provides no hint
3078 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3079 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3080 parse_cfg_bool "dsc-url-proto-ok", 'false',
3081 cfg("dgit.dsc-url-proto-ok.$proto",
3082 "dgit.default.dsc-url-proto-ok")
3083 or fail f_ <<END, $dsc_distro, $proto;
3084 .dsc Dgit metadata is in context of distro %s
3085 for which we have no configured url;
3086 .dsc provides hinted url with protocol %s which is unsafe.
3087 (can be overridden by config - consult documentation)
3089 $url = $dsc_hint_url;
3092 git_lrfetch_sane $url, 1, @fetch;
3097 my $rewrite_enable = do {
3098 local $idistro = $dsc_distro;
3099 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3102 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3103 if (!defined $mapref) {
3104 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3105 $mapref = $lrf.'/'.$rewritemap;
3107 my $rewritemapdata = git_cat_file $mapref.':map';
3108 if (defined $rewritemapdata
3109 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3111 "server's git history rewrite map contains a relevant entry!";
3114 if (defined $dsc_hash) {
3115 progress __ "using rewritten git hash in place of .dsc value";
3117 progress __ "server data says .dsc hash is to be disregarded";
3122 if (!defined git_cat_file $dsc_hash) {
3123 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3124 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3125 defined git_cat_file $dsc_hash
3126 or fail f_ <<END, $dsc_hash;
3127 .dsc Dgit metadata requires commit %s
3128 but we could not obtain that object anywhere.
3130 foreach my $t (@tags) {
3131 my $fullrefname = $lrf.'/'.$t;
3132 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3133 next unless $lrfetchrefs_f{$fullrefname};
3134 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3135 lrfetchref_used $fullrefname;
3140 sub fetch_from_archive () {
3142 ensure_setup_existing_tree();
3144 # Ensures that lrref() is what is actually in the archive, one way
3145 # or another, according to us - ie this client's
3146 # appropritaely-updated archive view. Also returns the commit id.
3147 # If there is nothing in the archive, leaves lrref alone and
3148 # returns undef. git_fetch_us must have already been called.
3152 parse_dsc_field($dsc, __ 'last upload to archive');
3153 resolve_dsc_field_commit access_basedistro,
3154 lrfetchrefs."/".$rewritemap
3156 progress __ "no version available from the archive";
3159 # If the archive's .dsc has a Dgit field, there are three
3160 # relevant git commitids we need to choose between and/or merge
3162 # 1. $dsc_hash: the Dgit field from the archive
3163 # 2. $lastpush_hash: the suite branch on the dgit git server
3164 # 3. $lastfetch_hash: our local tracking brach for the suite
3166 # These may all be distinct and need not be in any fast forward
3169 # If the dsc was pushed to this suite, then the server suite
3170 # branch will have been updated; but it might have been pushed to
3171 # a different suite and copied by the archive. Conversely a more
3172 # recent version may have been pushed with dgit but not appeared
3173 # in the archive (yet).
3175 # $lastfetch_hash may be awkward because archive imports
3176 # (particularly, imports of Dgit-less .dscs) are performed only as
3177 # needed on individual clients, so different clients may perform a
3178 # different subset of them - and these imports are only made
3179 # public during push. So $lastfetch_hash may represent a set of
3180 # imports different to a subsequent upload by a different dgit
3183 # Our approach is as follows:
3185 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3186 # descendant of $dsc_hash, then it was pushed by a dgit user who
3187 # had based their work on $dsc_hash, so we should prefer it.
3188 # Otherwise, $dsc_hash was installed into this suite in the
3189 # archive other than by a dgit push, and (necessarily) after the
3190 # last dgit push into that suite (since a dgit push would have
3191 # been descended from the dgit server git branch); thus, in that
3192 # case, we prefer the archive's version (and produce a
3193 # pseudo-merge to overwrite the dgit server git branch).
3195 # (If there is no Dgit field in the archive's .dsc then
3196 # generate_commit_from_dsc uses the version numbers to decide
3197 # whether the suite branch or the archive is newer. If the suite
3198 # branch is newer it ignores the archive's .dsc; otherwise it
3199 # generates an import of the .dsc, and produces a pseudo-merge to
3200 # overwrite the suite branch with the archive contents.)
3202 # The outcome of that part of the algorithm is the `public view',
3203 # and is same for all dgit clients: it does not depend on any
3204 # unpublished history in the local tracking branch.
3206 # As between the public view and the local tracking branch: The
3207 # local tracking branch is only updated by dgit fetch, and
3208 # whenever dgit fetch runs it includes the public view in the
3209 # local tracking branch. Therefore if the public view is not
3210 # descended from the local tracking branch, the local tracking
3211 # branch must contain history which was imported from the archive
3212 # but never pushed; and, its tip is now out of date. So, we make
3213 # a pseudo-merge to overwrite the old imports and stitch the old
3216 # Finally: we do not necessarily reify the public view (as
3217 # described above). This is so that we do not end up stacking two
3218 # pseudo-merges. So what we actually do is figure out the inputs
3219 # to any public view pseudo-merge and put them in @mergeinputs.
3222 # $mergeinputs[]{Commit}
3223 # $mergeinputs[]{Info}
3224 # $mergeinputs[0] is the one whose tree we use
3225 # @mergeinputs is in the order we use in the actual commit)
3228 # $mergeinputs[]{Message} is a commit message to use
3229 # $mergeinputs[]{ReverseParents} if def specifies that parent
3230 # list should be in opposite order
3231 # Such an entry has no Commit or Info. It applies only when found
3232 # in the last entry. (This ugliness is to support making
3233 # identical imports to previous dgit versions.)
3235 my $lastpush_hash = git_get_ref(lrfetchref());
3236 printdebug "previous reference hash=$lastpush_hash\n";
3237 $lastpush_mergeinput = $lastpush_hash && {
3238 Commit => $lastpush_hash,
3239 Info => (__ "dgit suite branch on dgit git server"),
3242 my $lastfetch_hash = git_get_ref(lrref());
3243 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3244 my $lastfetch_mergeinput = $lastfetch_hash && {
3245 Commit => $lastfetch_hash,
3246 Info => (__ "dgit client's archive history view"),
3249 my $dsc_mergeinput = $dsc_hash && {
3250 Commit => $dsc_hash,
3251 Info => (__ "Dgit field in .dsc from archive"),
3255 my $del_lrfetchrefs = sub {
3258 printdebug "del_lrfetchrefs...\n";
3259 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3260 my $objid = $lrfetchrefs_d{$fullrefname};
3261 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3263 $gur ||= new IO::Handle;
3264 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3266 printf $gur "delete %s %s\n", $fullrefname, $objid;
3269 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3273 if (defined $dsc_hash) {
3274 ensure_we_have_orig();
3275 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3276 @mergeinputs = $dsc_mergeinput
3277 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3278 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3280 Git commit in archive is behind the last version allegedly pushed/uploaded.
3281 Commit referred to by archive: %s
3282 Last version pushed with dgit: %s
3285 __ $later_warning_msg or confess "$!";
3286 @mergeinputs = ($lastpush_mergeinput);
3288 # Archive has .dsc which is not a descendant of the last dgit
3289 # push. This can happen if the archive moves .dscs about.
3290 # Just follow its lead.
3291 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3292 progress __ "archive .dsc names newer git commit";
3293 @mergeinputs = ($dsc_mergeinput);
3295 progress __ "archive .dsc names other git commit, fixing up";
3296 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3300 @mergeinputs = generate_commits_from_dsc();
3301 # We have just done an import. Now, our import algorithm might
3302 # have been improved. But even so we do not want to generate
3303 # a new different import of the same package. So if the
3304 # version numbers are the same, just use our existing version.
3305 # If the version numbers are different, the archive has changed
3306 # (perhaps, rewound).
3307 if ($lastfetch_mergeinput &&
3308 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3309 (mergeinfo_version $mergeinputs[0]) )) {
3310 @mergeinputs = ($lastfetch_mergeinput);
3312 } elsif ($lastpush_hash) {
3313 # only in git, not in the archive yet
3314 @mergeinputs = ($lastpush_mergeinput);
3315 print STDERR f_ <<END,
3317 Package not found in the archive, but has allegedly been pushed using dgit.
3320 __ $later_warning_msg or confess "$!";
3322 printdebug "nothing found!\n";
3323 if (defined $skew_warning_vsn) {
3324 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3326 Warning: relevant archive skew detected.
3327 Archive allegedly contains %s
3328 But we were not able to obtain any version from the archive or git.
3332 unshift @end, $del_lrfetchrefs;
3336 if ($lastfetch_hash &&
3338 my $h = $_->{Commit};
3339 $h and is_fast_fwd($lastfetch_hash, $h);
3340 # If true, one of the existing parents of this commit
3341 # is a descendant of the $lastfetch_hash, so we'll
3342 # be ff from that automatically.
3346 push @mergeinputs, $lastfetch_mergeinput;
3349 printdebug "fetch mergeinfos:\n";
3350 foreach my $mi (@mergeinputs) {
3352 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3354 printdebug sprintf " ReverseParents=%d Message=%s",
3355 $mi->{ReverseParents}, $mi->{Message};
3359 my $compat_info= pop @mergeinputs
3360 if $mergeinputs[$#mergeinputs]{Message};
3362 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3365 if (@mergeinputs > 1) {
3367 my $tree_commit = $mergeinputs[0]{Commit};
3369 my $tree = get_tree_of_commit $tree_commit;;
3371 # We use the changelog author of the package in question the
3372 # author of this pseudo-merge. This is (roughly) correct if
3373 # this commit is simply representing aa non-dgit upload.
3374 # (Roughly because it does not record sponsorship - but we
3375 # don't have sponsorship info because that's in the .changes,
3376 # which isn't in the archivw.)
3378 # But, it might be that we are representing archive history
3379 # updates (including in-archive copies). These are not really
3380 # the responsibility of the person who created the .dsc, but
3381 # there is no-one whose name we should better use. (The
3382 # author of the .dsc-named commit is clearly worse.)
3384 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3385 my $author = clogp_authline $useclogp;
3386 my $cversion = getfield $useclogp, 'Version';
3388 my $mcf = dgit_privdir()."/mergecommit";
3389 open MC, ">", $mcf or die "$mcf $!";
3390 print MC <<END or confess "$!";
3394 my @parents = grep { $_->{Commit} } @mergeinputs;
3395 @parents = reverse @parents if $compat_info->{ReverseParents};
3396 print MC <<END or confess "$!" foreach @parents;
3400 print MC <<END or confess "$!";
3406 if (defined $compat_info->{Message}) {
3407 print MC $compat_info->{Message} or confess "$!";
3409 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3410 Record %s (%s) in archive suite %s
3414 my $message_add_info = sub {
3416 my $mversion = mergeinfo_version $mi;
3417 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3421 $message_add_info->($mergeinputs[0]);
3422 print MC __ <<END or confess "$!";
3423 should be treated as descended from
3425 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3428 close MC or confess "$!";
3429 $hash = make_commit $mcf;
3431 $hash = $mergeinputs[0]{Commit};
3433 printdebug "fetch hash=$hash\n";
3436 my ($lasth, $what) = @_;
3437 return unless $lasth;
3438 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3441 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3443 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3445 fetch_from_archive_record_1($hash);
3447 if (defined $skew_warning_vsn) {
3448 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3449 my $gotclogp = commit_getclogp($hash);
3450 my $got_vsn = getfield $gotclogp, 'Version';
3451 printdebug "SKEW CHECK GOT $got_vsn\n";
3452 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3453 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3455 Warning: archive skew detected. Using the available version:
3456 Archive allegedly contains %s
3457 We were able to obtain only %s
3463 if ($lastfetch_hash ne $hash) {
3464 fetch_from_archive_record_2($hash);
3467 lrfetchref_used lrfetchref();
3469 check_gitattrs($hash, __ "fetched source tree");
3471 unshift @end, $del_lrfetchrefs;
3475 sub set_local_git_config ($$) {
3477 runcmd @git, qw(config), $k, $v;
3480 sub setup_mergechangelogs (;$) {
3482 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3484 my $driver = 'dpkg-mergechangelogs';
3485 my $cb = "merge.$driver";
3486 confess unless defined $maindir;
3487 my $attrs = "$maindir_gitcommon/info/attributes";
3488 ensuredir "$maindir_gitcommon/info";
3490 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3491 if (!open ATTRS, "<", $attrs) {
3492 $!==ENOENT or die "$attrs: $!";
3496 next if m{^debian/changelog\s};
3497 print NATTRS $_, "\n" or confess "$!";
3499 ATTRS->error and confess "$!";
3502 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3505 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3506 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3508 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3511 sub setup_useremail (;$) {
3513 return unless $always || access_cfg_bool(1, 'setup-useremail');
3516 my ($k, $envvar) = @_;
3517 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3518 return unless defined $v;
3519 set_local_git_config "user.$k", $v;
3522 $setup->('email', 'DEBEMAIL');
3523 $setup->('name', 'DEBFULLNAME');
3526 sub ensure_setup_existing_tree () {
3527 my $k = "remote.$remotename.skipdefaultupdate";
3528 my $c = git_get_config $k;
3529 return if defined $c;
3530 set_local_git_config $k, 'true';
3533 sub open_main_gitattrs () {
3534 confess 'internal error no maindir' unless defined $maindir;
3535 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3537 or die "open $maindir_gitcommon/info/attributes: $!";
3541 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3543 sub is_gitattrs_setup () {
3546 # 1: gitattributes set up and should be left alone
3548 # 0: there is a dgit-defuse-attrs but it needs fixing
3549 # undef: there is none
3550 my $gai = open_main_gitattrs();
3551 return 0 unless $gai;
3553 next unless m{$gitattrs_ourmacro_re};
3554 return 1 if m{\s-working-tree-encoding\s};
3555 printdebug "is_gitattrs_setup: found old macro\n";
3558 $gai->error and confess "$!";
3559 printdebug "is_gitattrs_setup: found nothing\n";
3563 sub setup_gitattrs (;$) {
3565 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3567 my $already = is_gitattrs_setup();
3570 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3571 not doing further gitattributes setup
3575 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3576 my $af = "$maindir_gitcommon/info/attributes";
3577 ensuredir "$maindir_gitcommon/info";
3579 open GAO, "> $af.new" or confess "$!";
3580 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3584 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3586 my $gai = open_main_gitattrs();
3589 if (m{$gitattrs_ourmacro_re}) {
3590 die unless defined $already;
3594 print GAO $_, "\n" or confess "$!";
3596 $gai->error and confess "$!";
3598 close GAO or confess "$!";
3599 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3602 sub setup_new_tree () {
3603 setup_mergechangelogs();
3608 sub check_gitattrs ($$) {
3609 my ($treeish, $what) = @_;
3611 return if is_gitattrs_setup;
3614 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3616 my $gafl = new IO::File;
3617 open $gafl, "-|", @cmd or confess "$!";
3620 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3622 next unless m{(?:^|/)\.gitattributes$};
3624 # oh dear, found one
3625 print STDERR f_ <<END, $what;
3626 dgit: warning: %s contains .gitattributes
3627 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3632 # tree contains no .gitattributes files
3633 $?=0; $!=0; close $gafl or failedcmd @cmd;
3637 sub multisuite_suite_child ($$$) {
3638 my ($tsuite, $mergeinputs, $fn) = @_;
3639 # in child, sets things up, calls $fn->(), and returns undef
3640 # in parent, returns canonical suite name for $tsuite
3641 my $canonsuitefh = IO::File::new_tmpfile;
3642 my $pid = fork // confess "$!";
3646 $us .= " [$isuite]";
3647 $debugprefix .= " ";
3648 progress f_ "fetching %s...", $tsuite;
3649 canonicalise_suite();
3650 print $canonsuitefh $csuite, "\n" or confess "$!";
3651 close $canonsuitefh or confess "$!";
3655 waitpid $pid,0 == $pid or confess "$!";
3656 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3658 seek $canonsuitefh,0,0 or confess "$!";
3659 local $csuite = <$canonsuitefh>;
3660 confess "$!" unless defined $csuite && chomp $csuite;
3662 printdebug "multisuite $tsuite missing\n";
3665 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3666 push @$mergeinputs, {
3673 sub fork_for_multisuite ($) {
3674 my ($before_fetch_merge) = @_;
3675 # if nothing unusual, just returns ''
3678 # returns 0 to caller in child, to do first of the specified suites
3679 # in child, $csuite is not yet set
3681 # returns 1 to caller in parent, to finish up anything needed after
3682 # in parent, $csuite is set to canonicalised portmanteau
3684 my $org_isuite = $isuite;
3685 my @suites = split /\,/, $isuite;
3686 return '' unless @suites > 1;
3687 printdebug "fork_for_multisuite: @suites\n";
3691 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3693 return 0 unless defined $cbasesuite;
3695 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3696 unless @mergeinputs;
3698 my @csuites = ($cbasesuite);
3700 $before_fetch_merge->();
3702 foreach my $tsuite (@suites[1..$#suites]) {
3703 $tsuite =~ s/^-/$cbasesuite-/;
3704 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3711 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3712 push @csuites, $csubsuite;
3715 foreach my $mi (@mergeinputs) {
3716 my $ref = git_get_ref $mi->{Ref};
3717 die "$mi->{Ref} ?" unless length $ref;
3718 $mi->{Commit} = $ref;
3721 $csuite = join ",", @csuites;
3723 my $previous = git_get_ref lrref;
3725 unshift @mergeinputs, {
3726 Commit => $previous,
3727 Info => (__ "local combined tracking branch"),
3729 "archive seems to have rewound: local tracking branch is ahead!"),
3733 foreach my $ix (0..$#mergeinputs) {
3734 $mergeinputs[$ix]{Index} = $ix;
3737 @mergeinputs = sort {
3738 -version_compare(mergeinfo_version $a,
3739 mergeinfo_version $b) # highest version first
3741 $a->{Index} <=> $b->{Index}; # earliest in spec first
3747 foreach my $mi (@mergeinputs) {
3748 printdebug "multisuite merge check $mi->{Info}\n";
3749 foreach my $previous (@needed) {
3750 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3751 printdebug "multisuite merge un-needed $previous->{Info}\n";
3755 printdebug "multisuite merge this-needed\n";
3756 $mi->{Character} = '+';
3759 $needed[0]{Character} = '*';
3761 my $output = $needed[0]{Commit};
3764 printdebug "multisuite merge nontrivial\n";
3765 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3767 my $commit = "tree $tree\n";
3768 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3769 "Input branches:\n",
3772 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3773 printdebug "multisuite merge include $mi->{Info}\n";
3774 $mi->{Character} //= ' ';
3775 $commit .= "parent $mi->{Commit}\n";
3776 $msg .= sprintf " %s %-25s %s\n",
3778 (mergeinfo_version $mi),
3781 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3782 $msg .= __ "\nKey\n".
3783 " * marks the highest version branch, which choose to use\n".
3784 " + marks each branch which was not already an ancestor\n\n";
3786 "[dgit multi-suite $csuite]\n";
3788 "author $authline\n".
3789 "committer $authline\n\n";
3790 $output = make_commit_text $commit.$msg;
3791 printdebug "multisuite merge generated $output\n";
3794 fetch_from_archive_record_1($output);
3795 fetch_from_archive_record_2($output);
3797 progress f_ "calculated combined tracking suite %s", $csuite;
3802 sub clone_set_head () {
3803 open H, "> .git/HEAD" or confess "$!";
3804 print H "ref: ".lref()."\n" or confess "$!";
3805 close H or confess "$!";
3807 sub clone_finish ($) {
3809 runcmd @git, qw(reset --hard), lrref();
3810 runcmd qw(bash -ec), <<'END';
3812 git ls-tree -r --name-only -z HEAD | \
3813 xargs -0r touch -h -r . --
3815 printdone f_ "ready for work in %s", $dstdir;
3819 # in multisuite, returns twice!
3820 # once in parent after first suite fetched,
3821 # and then again in child after everything is finished
3823 badusage __ "dry run makes no sense with clone" unless act_local();
3825 my $multi_fetched = fork_for_multisuite(sub {
3826 printdebug "multi clone before fetch merge\n";
3830 if ($multi_fetched) {
3831 printdebug "multi clone after fetch merge\n";
3833 clone_finish($dstdir);
3836 printdebug "clone main body\n";
3838 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3842 canonicalise_suite();
3843 my $hasgit = check_for_git();
3845 runcmd @git, qw(init -q);
3849 my $giturl = access_giturl(1);
3850 if (defined $giturl) {
3851 runcmd @git, qw(remote add), 'origin', $giturl;
3854 progress __ "fetching existing git history";
3856 runcmd_ordryrun_local @git, qw(fetch origin);
3858 progress __ "starting new git history";
3860 fetch_from_archive() or no_such_package;
3861 my $vcsgiturl = $dsc->{'Vcs-Git'};
3862 if (length $vcsgiturl) {
3863 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3864 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3866 clone_finish($dstdir);
3870 canonicalise_suite();
3871 if (check_for_git()) {
3874 fetch_from_archive() or no_such_package();
3876 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3877 if (length $vcsgiturl and
3878 (grep { $csuite eq $_ }
3880 cfg 'dgit.vcs-git.suites')) {
3881 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3882 if (defined $current && $current ne $vcsgiturl) {
3883 print STDERR f_ <<END, $csuite;
3884 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3885 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3889 printdone f_ "fetched into %s", lrref();
3893 my $multi_fetched = fork_for_multisuite(sub { });
3894 fetch_one() unless $multi_fetched; # parent
3895 finish 0 if $multi_fetched eq '0'; # child
3900 runcmd_ordryrun_local @git, qw(merge -m),
3901 (f_ "Merge from %s [dgit]", $csuite),
3903 printdone f_ "fetched to %s and merged into HEAD", lrref();
3906 sub check_not_dirty () {
3907 my @forbid = qw(local-options local-patch-header);
3908 @forbid = map { "debian/source/$_" } @forbid;
3909 foreach my $f (@forbid) {
3910 if (stat_exists $f) {
3911 fail f_ "git tree contains %s", $f;
3915 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3916 push @cmd, qw(debian/source/format debian/source/options);
3919 my $bad = cmdoutput @cmd;
3922 "you have uncommitted changes to critical files, cannot continue:\n").
3926 return if $includedirty;
3928 git_check_unmodified();
3931 sub commit_admin ($) {
3934 runcmd_ordryrun_local @git, qw(commit -m), $m;
3937 sub quiltify_nofix_bail ($$) {
3938 my ($headinfo, $xinfo) = @_;
3939 if ($quilt_mode eq 'nofix') {
3941 "quilt fixup required but quilt mode is \`nofix'\n".
3942 "HEAD commit%s differs from tree implied by debian/patches%s",
3947 sub commit_quilty_patch () {
3948 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3950 foreach my $l (split /\n/, $output) {
3951 next unless $l =~ m/\S/;
3952 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3956 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3958 progress __ "nothing quilty to commit, ok.";
3961 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3962 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3963 runcmd_ordryrun_local @git, qw(add -f), @adds;
3964 commit_admin +(__ <<ENDT).<<END
3965 Commit Debian 3.0 (quilt) metadata
3968 [dgit ($our_version) quilt-fixup]
3972 sub get_source_format () {
3974 if (open F, "debian/source/options") {
3978 s/\s+$//; # ignore missing final newline
3980 my ($k, $v) = ($`, $'); #');
3981 $v =~ s/^"(.*)"$/$1/;
3987 F->error and confess "$!";
3990 confess "$!" unless $!==&ENOENT;
3993 if (!open F, "debian/source/format") {
3994 confess "$!" unless $!==&ENOENT;
3998 F->error and confess "$!";
4000 return ($_, \%options);
4003 sub madformat_wantfixup ($) {
4005 return 0 unless $format eq '3.0 (quilt)';
4006 our $quilt_mode_warned;
4007 if ($quilt_mode eq 'nocheck') {
4008 progress f_ "Not doing any fixup of \`%s'".
4009 " due to ----no-quilt-fixup or --quilt=nocheck", $format
4010 unless $quilt_mode_warned++;
4013 progress f_ "Format \`%s', need to check/update patch stack", $format
4014 unless $quilt_mode_warned++;
4018 sub maybe_split_brain_save ($$$) {
4019 my ($headref, $dgitview, $msg) = @_;
4020 # => message fragment "$saved" describing disposition of $dgitview
4021 # (used inside parens, in the English texts)
4022 my $save = $internal_object_save{'dgit-view'};
4023 return f_ "commit id %s", $dgitview unless defined $save;
4024 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4026 "dgit --dgit-view-save $msg HEAD=$headref",
4029 return f_ "and left in %s", $save;
4032 # An "infopair" is a tuple [ $thing, $what ]
4033 # (often $thing is a commit hash; $what is a description)
4035 sub infopair_cond_equal ($$) {
4037 $x->[0] eq $y->[0] or fail <<END;
4038 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4042 sub infopair_lrf_tag_lookup ($$) {
4043 my ($tagnames, $what) = @_;
4044 # $tagname may be an array ref
4045 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4046 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4047 foreach my $tagname (@tagnames) {
4048 my $lrefname = lrfetchrefs."/tags/$tagname";
4049 my $tagobj = $lrfetchrefs_f{$lrefname};
4050 next unless defined $tagobj;
4051 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4052 return [ git_rev_parse($tagobj), $what ];
4054 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4055 Wanted tag %s (%s) on dgit server, but not found
4057 : (f_ <<END, $what, "@tagnames");
4058 Wanted tag %s (one of: %s) on dgit server, but not found
4062 sub infopair_cond_ff ($$) {
4063 my ($anc,$desc) = @_;
4064 is_fast_fwd($anc->[0], $desc->[0]) or
4065 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4066 %s (%s) .. %s (%s) is not fast forward
4070 sub pseudomerge_version_check ($$) {
4071 my ($clogp, $archive_hash) = @_;
4073 my $arch_clogp = commit_getclogp $archive_hash;
4074 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4075 __ 'version currently in archive' ];
4076 if (defined $overwrite_version) {
4077 if (length $overwrite_version) {
4078 infopair_cond_equal([ $overwrite_version,
4079 '--overwrite= version' ],
4082 my $v = $i_arch_v->[0];
4084 "Checking package changelog for archive version %s ...", $v;
4087 my @xa = ("-f$v", "-t$v");
4088 my $vclogp = parsechangelog @xa;
4091 [ (getfield $vclogp, $fn),
4092 (f_ "%s field from dpkg-parsechangelog %s",
4095 my $cv = $gf->('Version');
4096 infopair_cond_equal($i_arch_v, $cv);
4097 $cd = $gf->('Distribution');
4100 $@ =~ s/^dgit: //gm;
4102 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4104 fail f_ <<END, $cd->[1], $cd->[0], $v
4106 Your tree seems to based on earlier (not uploaded) %s.
4108 if $cd->[0] =~ m/UNRELEASED/;
4112 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4116 sub pseudomerge_make_commit ($$$$ $$) {
4117 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4118 $msg_cmd, $msg_msg) = @_;
4119 progress f_ "Declaring that HEAD includes all changes in %s...",
4122 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4123 my $authline = clogp_authline $clogp;
4127 !defined $overwrite_version ? ""
4128 : !length $overwrite_version ? " --overwrite"
4129 : " --overwrite=".$overwrite_version;
4131 # Contributing parent is the first parent - that makes
4132 # git rev-list --first-parent DTRT.
4133 my $pmf = dgit_privdir()."/pseudomerge";
4134 open MC, ">", $pmf or die "$pmf $!";
4135 print MC <<END or confess "$!";
4138 parent $archive_hash
4146 close MC or confess "$!";
4148 return make_commit($pmf);
4151 sub splitbrain_pseudomerge ($$$$) {
4152 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4153 # => $merged_dgitview
4154 printdebug "splitbrain_pseudomerge...\n";
4156 # We: debian/PREVIOUS HEAD($maintview)
4157 # expect: o ----------------- o
4160 # a/d/PREVIOUS $dgitview
4163 # we do: `------------------ o
4167 return $dgitview unless defined $archive_hash;
4168 return $dgitview if deliberately_not_fast_forward();
4170 printdebug "splitbrain_pseudomerge...\n";
4172 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4174 if (!defined $overwrite_version) {
4175 progress __ "Checking that HEAD includes all changes in archive...";
4178 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4180 if (defined $overwrite_version) {
4182 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4183 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4184 __ "maintainer view tag");
4185 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4186 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4187 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4189 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4191 infopair_cond_equal($i_dgit, $i_archive);
4192 infopair_cond_ff($i_dep14, $i_dgit);
4193 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4196 $@ =~ s/^\n//; chomp $@;
4197 print STDERR <<END.(__ <<ENDT);
4200 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4205 my $arch_v = $i_arch_v->[0];
4206 my $r = pseudomerge_make_commit
4207 $clogp, $dgitview, $archive_hash, $i_arch_v,
4208 "dgit --quilt=$quilt_mode",
4209 (defined $overwrite_version
4210 ? f_ "Declare fast forward from %s\n", $arch_v
4211 : f_ "Make fast forward from %s\n", $arch_v);
4213 maybe_split_brain_save $maintview, $r, "pseudomerge";
4215 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4219 sub plain_overwrite_pseudomerge ($$$) {
4220 my ($clogp, $head, $archive_hash) = @_;
4222 printdebug "plain_overwrite_pseudomerge...";
4224 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4226 return $head if is_fast_fwd $archive_hash, $head;
4228 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4230 my $r = pseudomerge_make_commit
4231 $clogp, $head, $archive_hash, $i_arch_v,
4234 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4236 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4240 sub push_parse_changelog ($) {
4243 my $clogp = Dpkg::Control::Hash->new();
4244 $clogp->load($clogpfn) or die;
4246 my $clogpackage = getfield $clogp, 'Source';
4247 $package //= $clogpackage;
4248 fail f_ "-p specified %s but changelog specified %s",
4249 $package, $clogpackage
4250 unless $package eq $clogpackage;
4251 my $cversion = getfield $clogp, 'Version';
4253 if (!$we_are_initiator) {
4254 # rpush initiator can't do this because it doesn't have $isuite yet
4255 my $tag = debiantag($cversion, access_nomdistro);
4256 runcmd @git, qw(check-ref-format), $tag;
4259 my $dscfn = dscfn($cversion);
4261 return ($clogp, $cversion, $dscfn);
4264 sub push_parse_dsc ($$$) {
4265 my ($dscfn,$dscfnwhat, $cversion) = @_;
4266 $dsc = parsecontrol($dscfn,$dscfnwhat);
4267 my $dversion = getfield $dsc, 'Version';
4268 my $dscpackage = getfield $dsc, 'Source';
4269 ($dscpackage eq $package && $dversion eq $cversion) or
4270 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4271 $dscfn, $dscpackage, $dversion,
4272 $package, $cversion;
4275 sub push_tagwants ($$$$) {
4276 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4279 TagFn => \&debiantag,
4284 if (defined $maintviewhead) {
4286 TagFn => \&debiantag_maintview,
4287 Objid => $maintviewhead,
4288 TfSuffix => '-maintview',
4291 } elsif ($dodep14tag eq 'no' ? 0
4292 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4293 : $dodep14tag eq 'always'
4294 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4295 --dep14tag-always (or equivalent in config) means server must support
4296 both "new" and "maint" tag formats, but config says it doesn't.
4298 : die "$dodep14tag ?") {
4300 TagFn => \&debiantag_maintview,
4302 TfSuffix => '-dgit',
4306 foreach my $tw (@tagwants) {
4307 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4308 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4310 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4314 sub push_mktags ($$ $$ $) {
4316 $changesfile,$changesfilewhat,
4319 die unless $tagwants->[0]{View} eq 'dgit';
4321 my $declaredistro = access_nomdistro();
4322 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4323 $dsc->{$ourdscfield[0]} = join " ",
4324 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4326 $dsc->save("$dscfn.tmp") or confess "$!";
4328 my $changes = parsecontrol($changesfile,$changesfilewhat);
4329 foreach my $field (qw(Source Distribution Version)) {
4330 $changes->{$field} eq $clogp->{$field} or
4331 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4332 $field, $changes->{$field}, $clogp->{$field};
4335 my $cversion = getfield $clogp, 'Version';
4336 my $clogsuite = getfield $clogp, 'Distribution';
4338 # We make the git tag by hand because (a) that makes it easier
4339 # to control the "tagger" (b) we can do remote signing
4340 my $authline = clogp_authline $clogp;
4341 my $delibs = join(" ", "",@deliberatelies);
4345 my $tfn = $tw->{Tfn};
4346 my $head = $tw->{Objid};
4347 my $tag = $tw->{Tag};
4349 open TO, '>', $tfn->('.tmp') or confess "$!";
4350 print TO <<END or confess "$!";
4357 if ($tw->{View} eq 'dgit') {
4358 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4359 %s release %s for %s (%s) [dgit]
4362 print TO <<END or confess "$!";
4363 [dgit distro=$declaredistro$delibs]
4365 foreach my $ref (sort keys %previously) {
4366 print TO <<END or confess "$!";
4367 [dgit previously:$ref=$previously{$ref}]
4370 } elsif ($tw->{View} eq 'maint') {
4371 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4372 %s release %s for %s (%s)
4373 (maintainer view tag generated by dgit --quilt=%s)
4378 confess Dumper($tw)."?";
4381 close TO or confess "$!";
4383 my $tagobjfn = $tfn->('.tmp');
4385 if (!defined $keyid) {
4386 $keyid = access_cfg('keyid','RETURN-UNDEF');
4388 if (!defined $keyid) {
4389 $keyid = getfield $clogp, 'Maintainer';
4391 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4392 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4393 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4394 push @sign_cmd, $tfn->('.tmp');
4395 runcmd_ordryrun @sign_cmd;
4397 $tagobjfn = $tfn->('.signed.tmp');
4398 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4399 $tfn->('.tmp'), $tfn->('.tmp.asc');
4405 my @r = map { $mktag->($_); } @$tagwants;
4409 sub sign_changes ($) {
4410 my ($changesfile) = @_;
4412 my @debsign_cmd = @debsign;
4413 push @debsign_cmd, "-k$keyid" if defined $keyid;
4414 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4415 push @debsign_cmd, $changesfile;
4416 runcmd_ordryrun @debsign_cmd;
4421 printdebug "actually entering push\n";
4423 supplementary_message(__ <<'END');
4424 Push failed, while checking state of the archive.
4425 You can retry the push, after fixing the problem, if you like.
4427 if (check_for_git()) {
4430 my $archive_hash = fetch_from_archive();
4431 if (!$archive_hash) {
4433 fail __ "package appears to be new in this suite;".
4434 " if this is intentional, use --new";
4437 supplementary_message(__ <<'END');
4438 Push failed, while preparing your push.
4439 You can retry the push, after fixing the problem, if you like.
4442 need_tagformat 'new', "quilt mode $quilt_mode"
4443 if quiltmode_splitbrain;
4447 access_giturl(); # check that success is vaguely likely
4448 rpush_handle_protovsn_bothends() if $we_are_initiator;
4451 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4452 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4454 responder_send_file('parsed-changelog', $clogpfn);
4456 my ($clogp, $cversion, $dscfn) =
4457 push_parse_changelog("$clogpfn");
4459 my $dscpath = "$buildproductsdir/$dscfn";
4460 stat_exists $dscpath or
4461 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4464 responder_send_file('dsc', $dscpath);
4466 push_parse_dsc($dscpath, $dscfn, $cversion);
4468 my $format = getfield $dsc, 'Format';
4469 printdebug "format $format\n";
4471 my $symref = git_get_symref();
4472 my $actualhead = git_rev_parse('HEAD');
4474 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4475 if (quiltmode_splitbrain()) {
4476 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4477 fail f_ <<END, $ffq_prev, $quilt_mode;
4478 Branch is managed by git-debrebase (%s
4479 exists), but quilt mode (%s) implies a split view.
4480 Pass the right --quilt option or adjust your git config.
4481 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4484 runcmd_ordryrun_local @git_debrebase, 'stitch';
4485 $actualhead = git_rev_parse('HEAD');
4488 my $dgithead = $actualhead;
4489 my $maintviewhead = undef;
4491 my $upstreamversion = upstreamversion $clogp->{Version};
4493 if (madformat_wantfixup($format)) {
4494 # user might have not used dgit build, so maybe do this now:
4495 if (quiltmode_splitbrain()) {
4496 $do_split_brain = 1;
4497 changedir $playground;
4498 quilt_need_fake_dsc($upstreamversion);
4500 ($dgithead, $cachekey) =
4501 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4502 $dgithead or fail f_
4503 "--quilt=%s but no cached dgit view:
4504 perhaps HEAD changed since dgit build[-source] ?",
4507 if (!$do_split_brain) {
4508 # In split brain mode, do not attempt to incorporate dirty
4509 # stuff from the user's working tree. That would be mad.
4510 commit_quilty_patch();
4513 if ($do_split_brain) {
4515 $dgithead = splitbrain_pseudomerge($clogp,
4516 $actualhead, $dgithead,
4518 $maintviewhead = $actualhead;
4520 prep_ud(); # so _only_subdir() works, below
4523 if (defined $overwrite_version && !defined $maintviewhead
4525 $dgithead = plain_overwrite_pseudomerge($clogp,
4533 if ($archive_hash) {
4534 if (is_fast_fwd($archive_hash, $dgithead)) {
4536 } elsif (deliberately_not_fast_forward) {
4539 fail __ "dgit push: HEAD is not a descendant".
4540 " of the archive's version.\n".
4541 "To overwrite the archive's contents,".
4542 " pass --overwrite[=VERSION].\n".
4543 "To rewind history, if permitted by the archive,".
4544 " use --deliberately-not-fast-forward.";
4548 changedir $playground;
4549 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4550 runcmd qw(dpkg-source -x --),
4551 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4552 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4553 check_for_vendor_patches() if madformat($dsc->{format});
4555 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4556 debugcmd "+",@diffcmd;
4558 my $r = system @diffcmd;
4561 my $referent = $split_brain ? $dgithead : 'HEAD';
4562 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4565 my $raw = cmdoutput @git,
4566 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4568 foreach (split /\0/, $raw) {
4569 if (defined $changed) {
4570 push @mode_changes, "$changed: $_\n" if $changed;
4573 } elsif (m/^:0+ 0+ /) {
4575 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4576 $changed = "Mode change from $1 to $2"
4581 if (@mode_changes) {
4582 fail +(f_ <<ENDT, $dscfn).<<END
4583 HEAD specifies a different tree to %s:
4587 .(join '', @mode_changes)
4588 .(f_ <<ENDT, $tree, $referent);
4589 There is a problem with your source tree (see dgit(7) for some hints).
4590 To see a full diff, run git diff %s %s
4594 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4595 HEAD specifies a different tree to %s:
4599 Perhaps you forgot to build. Or perhaps there is a problem with your
4600 source tree (see dgit(7) for some hints). To see a full diff, run
4607 if (!$changesfile) {
4608 my $pat = changespat $cversion;
4609 my @cs = glob "$buildproductsdir/$pat";
4610 fail f_ "failed to find unique changes file".
4611 " (looked for %s in %s);".
4612 " perhaps you need to use dgit -C",
4613 $pat, $buildproductsdir
4615 ($changesfile) = @cs;
4617 $changesfile = "$buildproductsdir/$changesfile";
4620 # Check that changes and .dsc agree enough
4621 $changesfile =~ m{[^/]*$};
4622 my $changes = parsecontrol($changesfile,$&);
4623 files_compare_inputs($dsc, $changes)
4624 unless forceing [qw(dsc-changes-mismatch)];
4626 # Check whether this is a source only upload
4627 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4628 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4629 if ($sourceonlypolicy eq 'ok') {
4630 } elsif ($sourceonlypolicy eq 'always') {
4631 forceable_fail [qw(uploading-binaries)],
4632 __ "uploading binaries, although distro policy is source only"
4634 } elsif ($sourceonlypolicy eq 'never') {
4635 forceable_fail [qw(uploading-source-only)],
4636 __ "source-only upload, although distro policy requires .debs"
4638 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4639 forceable_fail [qw(uploading-source-only)],
4640 f_ "source-only upload, even though package is entirely NEW\n".
4641 "(this is contrary to policy in %s)",
4645 && !(archive_query('package_not_wholly_new', $package) // 1);
4647 badcfg f_ "unknown source-only-uploads policy \`%s'",
4651 # Perhaps adjust .dsc to contain right set of origs
4652 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4654 unless forceing [qw(changes-origs-exactly)];
4656 # Checks complete, we're going to try and go ahead:
4658 responder_send_file('changes',$changesfile);
4659 responder_send_command("param head $dgithead");
4660 responder_send_command("param csuite $csuite");
4661 responder_send_command("param isuite $isuite");
4662 responder_send_command("param tagformat $tagformat");
4663 if (defined $maintviewhead) {
4664 confess "internal error (protovsn=$protovsn)"
4665 if defined $protovsn and $protovsn < 4;
4666 responder_send_command("param maint-view $maintviewhead");
4669 # Perhaps send buildinfo(s) for signing
4670 my $changes_files = getfield $changes, 'Files';
4671 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4672 foreach my $bi (@buildinfos) {
4673 responder_send_command("param buildinfo-filename $bi");
4674 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4677 if (deliberately_not_fast_forward) {
4678 git_for_each_ref(lrfetchrefs, sub {
4679 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4680 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4681 responder_send_command("previously $rrefname=$objid");
4682 $previously{$rrefname} = $objid;
4686 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4687 dgit_privdir()."/tag");
4690 supplementary_message(__ <<'END');
4691 Push failed, while signing the tag.
4692 You can retry the push, after fixing the problem, if you like.
4694 # If we manage to sign but fail to record it anywhere, it's fine.
4695 if ($we_are_responder) {
4696 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4697 responder_receive_files('signed-tag', @tagobjfns);
4699 @tagobjfns = push_mktags($clogp,$dscpath,
4700 $changesfile,$changesfile,
4703 supplementary_message(__ <<'END');
4704 Push failed, *after* signing the tag.
4705 If you want to try again, you should use a new version number.
4708 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4710 foreach my $tw (@tagwants) {
4711 my $tag = $tw->{Tag};
4712 my $tagobjfn = $tw->{TagObjFn};
4714 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4715 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4716 runcmd_ordryrun_local
4717 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4720 supplementary_message(__ <<'END');
4721 Push failed, while updating the remote git repository - see messages above.
4722 If you want to try again, you should use a new version number.
4724 if (!check_for_git()) {
4725 create_remote_git_repo();
4728 my @pushrefs = $forceflag.$dgithead.":".rrref();
4729 foreach my $tw (@tagwants) {
4730 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4733 runcmd_ordryrun @git,
4734 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4735 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4737 supplementary_message(__ <<'END');
4738 Push failed, while obtaining signatures on the .changes and .dsc.
4739 If it was just that the signature failed, you may try again by using
4740 debsign by hand to sign the changes file (see the command dgit tried,
4741 above), and then dput that changes file to complete the upload.
4742 If you need to change the package, you must use a new version number.
4744 if ($we_are_responder) {
4745 my $dryrunsuffix = act_local() ? "" : ".tmp";
4746 my @rfiles = ($dscpath, $changesfile);
4747 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4748 responder_receive_files('signed-dsc-changes',
4749 map { "$_$dryrunsuffix" } @rfiles);
4752 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4754 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4756 sign_changes $changesfile;
4759 supplementary_message(f_ <<END, $changesfile);
4760 Push failed, while uploading package(s) to the archive server.
4761 You can retry the upload of exactly these same files with dput of:
4763 If that .changes file is broken, you will need to use a new version
4764 number for your next attempt at the upload.
4766 my $host = access_cfg('upload-host','RETURN-UNDEF');
4767 my @hostarg = defined($host) ? ($host,) : ();
4768 runcmd_ordryrun @dput, @hostarg, $changesfile;
4769 printdone f_ "pushed and uploaded %s", $cversion;
4771 supplementary_message('');
4772 responder_send_command("complete");
4776 not_necessarily_a_tree();
4781 badusage __ "-p is not allowed with clone; specify as argument instead"
4782 if defined $package;
4785 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4786 ($package,$isuite) = @ARGV;
4787 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4788 ($package,$dstdir) = @ARGV;
4789 } elsif (@ARGV==3) {
4790 ($package,$isuite,$dstdir) = @ARGV;
4792 badusage __ "incorrect arguments to dgit clone";
4796 $dstdir ||= "$package";
4797 if (stat_exists $dstdir) {
4798 fail f_ "%s already exists", $dstdir;
4802 if ($rmonerror && !$dryrun_level) {
4803 $cwd_remove= getcwd();
4805 return unless defined $cwd_remove;
4806 if (!chdir "$cwd_remove") {
4807 return if $!==&ENOENT;
4808 confess "chdir $cwd_remove: $!";
4810 printdebug "clone rmonerror removing $dstdir\n";
4812 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4813 } elsif (grep { $! == $_ }
4814 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4816 print STDERR f_ "check whether to remove %s: %s\n",
4823 $cwd_remove = undef;
4826 sub branchsuite () {
4827 my $branch = git_get_symref();
4828 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4835 sub package_from_d_control () {
4836 if (!defined $package) {
4837 my $sourcep = parsecontrol('debian/control','debian/control');
4838 $package = getfield $sourcep, 'Source';
4842 sub fetchpullargs () {
4843 package_from_d_control();
4845 $isuite = branchsuite();
4847 my $clogp = parsechangelog();
4848 my $clogsuite = getfield $clogp, 'Distribution';
4849 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4851 } elsif (@ARGV==1) {
4854 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4868 if (quiltmode_splitbrain()) {
4869 my ($format, $fopts) = get_source_format();
4870 madformat($format) and fail f_ <<END, $quilt_mode
4871 dgit pull not yet supported in split view mode (--quilt=%s)
4879 package_from_d_control();
4880 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4884 foreach my $canon (qw(0 1)) {
4889 canonicalise_suite();
4891 if (length git_get_ref lref()) {
4892 # local branch already exists, yay
4895 if (!length git_get_ref lrref()) {
4903 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4906 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4907 "dgit checkout $isuite";
4908 runcmd (@git, qw(checkout), lbranch());
4911 sub cmd_update_vcs_git () {
4913 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4914 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4916 ($specsuite) = (@ARGV);
4921 if ($ARGV[0] eq '-') {
4923 } elsif ($ARGV[0] eq '-') {
4928 package_from_d_control();
4930 if ($specsuite eq '.') {
4931 $ctrl = parsecontrol 'debian/control', 'debian/control';
4933 $isuite = $specsuite;
4937 my $url = getfield $ctrl, 'Vcs-Git';
4940 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4941 if (!defined $orgurl) {
4942 print STDERR f_ "setting up vcs-git: %s\n", $url;
4943 @cmd = (@git, qw(remote add vcs-git), $url);
4944 } elsif ($orgurl eq $url) {
4945 print STDERR f_ "vcs git already configured: %s\n", $url;
4947 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4948 @cmd = (@git, qw(remote set-url vcs-git), $url);
4950 runcmd_ordryrun_local @cmd;
4952 print f_ "fetching (%s)\n", "@ARGV";
4953 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4959 build_or_push_prep_early();
4964 } elsif (@ARGV==1) {
4965 ($specsuite) = (@ARGV);
4967 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4970 local ($package) = $existing_package; # this is a hack
4971 canonicalise_suite();
4973 canonicalise_suite();
4975 if (defined $specsuite &&
4976 $specsuite ne $isuite &&
4977 $specsuite ne $csuite) {
4978 fail f_ "dgit %s: changelog specifies %s (%s)".
4979 " but command line specifies %s",
4980 $subcommand, $isuite, $csuite, $specsuite;
4989 #---------- remote commands' implementation ----------
4991 sub pre_remote_push_build_host {
4992 my ($nrargs) = shift @ARGV;
4993 my (@rargs) = @ARGV[0..$nrargs-1];
4994 @ARGV = @ARGV[$nrargs..$#ARGV];
4996 my ($dir,$vsnwant) = @rargs;
4997 # vsnwant is a comma-separated list; we report which we have
4998 # chosen in our ready response (so other end can tell if they
5001 $we_are_responder = 1;
5002 $us .= " (build host)";
5004 open PI, "<&STDIN" or confess "$!";
5005 open STDIN, "/dev/null" or confess "$!";
5006 open PO, ">&STDOUT" or confess "$!";
5008 open STDOUT, ">&STDERR" or confess "$!";
5012 ($protovsn) = grep {
5013 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5014 } @rpushprotovsn_support;
5016 fail f_ "build host has dgit rpush protocol versions %s".
5017 " but invocation host has %s",
5018 (join ",", @rpushprotovsn_support), $vsnwant
5019 unless defined $protovsn;
5023 sub cmd_remote_push_build_host {
5024 responder_send_command("dgit-remote-push-ready $protovsn");
5028 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5029 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5030 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5031 # a good error message)
5033 sub rpush_handle_protovsn_bothends () {
5034 if ($protovsn < 4) {
5035 need_tagformat 'old', "rpush negotiated protocol $protovsn";
5044 my $report = i_child_report();
5045 if (defined $report) {
5046 printdebug "($report)\n";
5047 } elsif ($i_child_pid) {
5048 printdebug "(killing build host child $i_child_pid)\n";
5049 kill 15, $i_child_pid;
5051 if (defined $i_tmp && !defined $initiator_tempdir) {
5053 eval { rmtree $i_tmp; };
5058 return unless forkcheck_mainprocess();
5063 my ($base,$selector,@args) = @_;
5064 $selector =~ s/\-/_/g;
5065 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5069 not_necessarily_a_tree();
5074 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5082 push @rargs, join ",", @rpushprotovsn_support;
5085 push @rdgit, @ropts;
5086 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5088 my @cmd = (@ssh, $host, shellquote @rdgit);
5091 $we_are_initiator=1;
5093 if (defined $initiator_tempdir) {
5094 rmtree $initiator_tempdir;
5095 mkdir $initiator_tempdir, 0700
5096 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5097 $i_tmp = $initiator_tempdir;
5101 $i_child_pid = open2(\*RO, \*RI, @cmd);
5103 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5104 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5105 $supplementary_message = '' unless $protovsn >= 3;
5108 my ($icmd,$iargs) = initiator_expect {
5109 m/^(\S+)(?: (.*))?$/;
5112 i_method "i_resp", $icmd, $iargs;
5116 sub i_resp_progress ($) {
5118 my $msg = protocol_read_bytes \*RO, $rhs;
5122 sub i_resp_supplementary_message ($) {
5124 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5127 sub i_resp_complete {
5128 my $pid = $i_child_pid;
5129 $i_child_pid = undef; # prevents killing some other process with same pid
5130 printdebug "waiting for build host child $pid...\n";
5131 my $got = waitpid $pid, 0;
5132 confess "$!" unless $got == $pid;
5133 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5136 printdebug __ "all done\n";
5140 sub i_resp_file ($) {
5142 my $localname = i_method "i_localname", $keyword;
5143 my $localpath = "$i_tmp/$localname";
5144 stat_exists $localpath and
5145 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5146 protocol_receive_file \*RO, $localpath;
5147 i_method "i_file", $keyword;
5152 sub i_resp_param ($) {
5153 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5157 sub i_resp_previously ($) {
5158 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5159 or badproto \*RO, __ "bad previously spec";
5160 my $r = system qw(git check-ref-format), $1;
5161 confess "bad previously ref spec ($r)" if $r;
5162 $previously{$1} = $2;
5167 sub i_resp_want ($) {
5169 die "$keyword ?" if $i_wanted{$keyword}++;
5171 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5172 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5173 die unless $isuite =~ m/^$suite_re$/;
5176 rpush_handle_protovsn_bothends();
5178 fail f_ "rpush negotiated protocol version %s".
5179 " which does not support quilt mode %s",
5180 $protovsn, $quilt_mode
5181 if quiltmode_splitbrain && $protovsn < 4;
5183 my @localpaths = i_method "i_want", $keyword;
5184 printdebug "[[ $keyword @localpaths\n";
5185 foreach my $localpath (@localpaths) {
5186 protocol_send_file \*RI, $localpath;
5188 print RI "files-end\n" or confess "$!";
5191 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5193 sub i_localname_parsed_changelog {
5194 return "remote-changelog.822";
5196 sub i_file_parsed_changelog {
5197 ($i_clogp, $i_version, $i_dscfn) =
5198 push_parse_changelog "$i_tmp/remote-changelog.822";
5199 die if $i_dscfn =~ m#/|^\W#;
5202 sub i_localname_dsc {
5203 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5208 sub i_localname_buildinfo ($) {
5209 my $bi = $i_param{'buildinfo-filename'};
5210 defined $bi or badproto \*RO, "buildinfo before filename";
5211 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5212 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5213 or badproto \*RO, "improper buildinfo filename";
5216 sub i_file_buildinfo {
5217 my $bi = $i_param{'buildinfo-filename'};
5218 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5219 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5220 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5221 files_compare_inputs($bd, $ch);
5222 (getfield $bd, $_) eq (getfield $ch, $_) or
5223 fail f_ "buildinfo mismatch in field %s", $_
5224 foreach qw(Source Version);
5225 !defined $bd->{$_} or
5226 fail f_ "buildinfo contains forbidden field %s", $_
5227 foreach qw(Changes Changed-by Distribution);
5229 push @i_buildinfos, $bi;
5230 delete $i_param{'buildinfo-filename'};
5233 sub i_localname_changes {
5234 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5235 $i_changesfn = $i_dscfn;
5236 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5237 return $i_changesfn;
5239 sub i_file_changes { }
5241 sub i_want_signed_tag {
5242 printdebug Dumper(\%i_param, $i_dscfn);
5243 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5244 && defined $i_param{'csuite'}
5245 or badproto \*RO, "premature desire for signed-tag";
5246 my $head = $i_param{'head'};
5247 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5249 my $maintview = $i_param{'maint-view'};
5250 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5253 if ($protovsn >= 4) {
5254 my $p = $i_param{'tagformat'} // '<undef>';
5256 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5259 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5261 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5263 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5266 push_mktags $i_clogp, $i_dscfn,
5267 $i_changesfn, (__ 'remote changes file'),
5271 sub i_want_signed_dsc_changes {
5272 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5273 sign_changes $i_changesfn;
5274 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5277 #---------- building etc. ----------
5283 #----- `3.0 (quilt)' handling -----
5285 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5287 sub quiltify_dpkg_commit ($$$;$) {
5288 my ($patchname,$author,$msg, $xinfo) = @_;
5291 mkpath '.git/dgit'; # we are in playtree
5292 my $descfn = ".git/dgit/quilt-description.tmp";
5293 open O, '>', $descfn or confess "$descfn: $!";
5294 $msg =~ s/\n+/\n\n/;
5295 print O <<END or confess "$!";
5297 ${xinfo}Subject: $msg
5301 close O or confess "$!";
5304 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5305 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5306 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5307 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5311 sub quiltify_trees_differ ($$;$$$) {
5312 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5313 # returns true iff the two tree objects differ other than in debian/
5314 # with $finegrained,
5315 # returns bitmask 01 - differ in upstream files except .gitignore
5316 # 02 - differ in .gitignore
5317 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5318 # is set for each modified .gitignore filename $fn
5319 # if $unrepres is defined, array ref to which is appeneded
5320 # a list of unrepresentable changes (removals of upstream files
5323 my @cmd = (@git, qw(diff-tree -z --no-renames));
5324 push @cmd, qw(--name-only) unless $unrepres;
5325 push @cmd, qw(-r) if $finegrained || $unrepres;
5327 my $diffs= cmdoutput @cmd;
5330 foreach my $f (split /\0/, $diffs) {
5331 if ($unrepres && !@lmodes) {
5332 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5335 my ($oldmode,$newmode) = @lmodes;
5338 next if $f =~ m#^debian(?:/.*)?$#s;
5342 die __ "not a plain file or symlink\n"
5343 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5344 $oldmode =~ m/^(?:10|12)\d{4}$/;
5345 if ($oldmode =~ m/[^0]/ &&
5346 $newmode =~ m/[^0]/) {
5347 # both old and new files exist
5348 die __ "mode or type changed\n" if $oldmode ne $newmode;
5349 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5350 } elsif ($oldmode =~ m/[^0]/) {
5352 die __ "deletion of symlink\n"
5353 unless $oldmode =~ m/^10/;
5356 die __ "creation with non-default mode\n"
5357 unless $newmode =~ m/^100644$/ or
5358 $newmode =~ m/^120000$/;
5362 local $/="\n"; chomp $@;
5363 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5367 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5368 $r |= $isignore ? 02 : 01;
5369 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5371 printdebug "quiltify_trees_differ $x $y => $r\n";
5375 sub quiltify_tree_sentinelfiles ($) {
5376 # lists the `sentinel' files present in the tree
5378 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5379 qw(-- debian/rules debian/control);
5384 sub quiltify_splitbrain ($$$$$$$) {
5385 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5386 $editedignores, $cachekey) = @_;
5387 my $gitignore_special = 1;
5388 if ($quilt_mode !~ m/gbp|dpm/) {
5389 # treat .gitignore just like any other upstream file
5390 $diffbits = { %$diffbits };
5391 $_ = !!$_ foreach values %$diffbits;
5392 $gitignore_special = 0;
5394 # We would like any commits we generate to be reproducible
5395 my @authline = clogp_authline($clogp);
5396 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5397 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5398 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5399 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5400 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5401 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5403 die unless $do_split_brain;
5405 my $fulldiffhint = sub {
5407 my $cmd = "git diff $x $y -- :/ ':!debian'";
5408 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5409 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5413 if ($quilt_mode =~ m/gbp|unapplied/ &&
5414 ($diffbits->{O2H} & 01)) {
5416 "--quilt=%s specified, implying patches-unapplied git tree\n".
5417 " but git tree differs from orig in upstream files.",
5419 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5420 if (!stat_exists "debian/patches") {
5422 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5426 if ($quilt_mode =~ m/dpm/ &&
5427 ($diffbits->{H2A} & 01)) {
5428 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5429 --quilt=%s specified, implying patches-applied git tree
5430 but git tree differs from result of applying debian/patches to upstream
5433 if ($quilt_mode =~ m/gbp|unapplied/ &&
5434 ($diffbits->{O2A} & 01)) { # some patches
5435 progress __ "dgit view: creating patches-applied version using gbp pq";
5436 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5437 # gbp pq import creates a fresh branch; push back to dgit-view
5438 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5439 runcmd @git, qw(checkout -q dgit-view);
5441 if ($quilt_mode =~ m/gbp|dpm/ &&
5442 ($diffbits->{O2A} & 02)) {
5443 fail f_ <<END, $quilt_mode;
5444 --quilt=%s specified, implying that HEAD is for use with a
5445 tool which does not create patches for changes to upstream
5446 .gitignores: but, such patches exist in debian/patches.
5449 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5450 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5452 "dgit view: creating patch to represent .gitignore changes";
5453 ensuredir "debian/patches";
5454 my $gipatch = "debian/patches/auto-gitignore";
5455 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5456 stat GIPATCH or confess "$gipatch: $!";
5457 fail f_ "%s already exists; but want to create it".
5458 " to record .gitignore changes",
5461 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5462 Subject: Update .gitignore from Debian packaging branch
5464 The Debian packaging git branch contains these updates to the upstream
5465 .gitignore file(s). This patch is autogenerated, to provide these
5466 updates to users of the official Debian archive view of the package.
5469 [dgit ($our_version) update-gitignore]
5472 close GIPATCH or die "$gipatch: $!";
5473 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5474 $unapplied, $headref, "--", sort keys %$editedignores;
5475 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5476 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5478 defined read SERIES, $newline, 1 or confess "$!";
5479 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5480 print SERIES "auto-gitignore\n" or confess "$!";
5481 close SERIES or die $!;
5482 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5483 commit_admin +(__ <<END).<<ENDU
5484 Commit patch to update .gitignore
5487 [dgit ($our_version) update-gitignore-quilt-fixup]
5491 my $dgitview = git_rev_parse 'HEAD';
5494 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5496 changedir "$playground/work";
5498 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5499 progress f_ "dgit view: created (%s)", $saved;
5502 sub quiltify ($$$$) {
5503 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5505 # Quilt patchification algorithm
5507 # We search backwards through the history of the main tree's HEAD
5508 # (T) looking for a start commit S whose tree object is identical
5509 # to to the patch tip tree (ie the tree corresponding to the
5510 # current dpkg-committed patch series). For these purposes
5511 # `identical' disregards anything in debian/ - this wrinkle is
5512 # necessary because dpkg-source treates debian/ specially.
5514 # We can only traverse edges where at most one of the ancestors'
5515 # trees differs (in changes outside in debian/). And we cannot
5516 # handle edges which change .pc/ or debian/patches. To avoid
5517 # going down a rathole we avoid traversing edges which introduce
5518 # debian/rules or debian/control. And we set a limit on the
5519 # number of edges we are willing to look at.
5521 # If we succeed, we walk forwards again. For each traversed edge
5522 # PC (with P parent, C child) (starting with P=S and ending with
5523 # C=T) to we do this:
5525 # - dpkg-source --commit with a patch name and message derived from C
5526 # After traversing PT, we git commit the changes which
5527 # should be contained within debian/patches.
5529 # The search for the path S..T is breadth-first. We maintain a
5530 # todo list containing search nodes. A search node identifies a
5531 # commit, and looks something like this:
5533 # Commit => $git_commit_id,
5534 # Child => $c, # or undef if P=T
5535 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5536 # Nontrivial => true iff $p..$c has relevant changes
5543 my %considered; # saves being exponential on some weird graphs
5545 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5548 my ($search,$whynot) = @_;
5549 printdebug " search NOT $search->{Commit} $whynot\n";
5550 $search->{Whynot} = $whynot;
5551 push @nots, $search;
5552 no warnings qw(exiting);
5561 my $c = shift @todo;
5562 next if $considered{$c->{Commit}}++;
5564 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5566 printdebug "quiltify investigate $c->{Commit}\n";
5569 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5570 printdebug " search finished hooray!\n";
5575 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5576 if ($quilt_mode eq 'smash') {
5577 printdebug " search quitting smash\n";
5581 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5582 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5583 if $c_sentinels ne $t_sentinels;
5585 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5586 $commitdata =~ m/\n\n/;
5588 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5589 @parents = map { { Commit => $_, Child => $c } } @parents;
5591 $not->($c, __ "root commit") if !@parents;
5593 foreach my $p (@parents) {
5594 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5596 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5597 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5600 foreach my $p (@parents) {
5601 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5603 my @cmd= (@git, qw(diff-tree -r --name-only),
5604 $p->{Commit},$c->{Commit},
5605 qw(-- debian/patches .pc debian/source/format));
5606 my $patchstackchange = cmdoutput @cmd;
5607 if (length $patchstackchange) {
5608 $patchstackchange =~ s/\n/,/g;
5609 $not->($p, f_ "changed %s", $patchstackchange);
5612 printdebug " search queue P=$p->{Commit} ",
5613 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5619 printdebug "quiltify want to smash\n";
5622 my $x = $_[0]{Commit};
5623 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5626 if ($quilt_mode eq 'linear') {
5628 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5630 my $all_gdr = !!@nots;
5631 foreach my $notp (@nots) {
5632 my $c = $notp->{Child};
5633 my $cprange = $abbrev->($notp);
5634 $cprange .= "..".$abbrev->($c) if $c;
5635 print STDERR f_ "%s: %s: %s\n",
5636 $us, $cprange, $notp->{Whynot};
5637 $all_gdr &&= $notp->{Child} &&
5638 (git_cat_file $notp->{Child}{Commit}, 'commit')
5639 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5643 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5645 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5647 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5648 } elsif ($quilt_mode eq 'smash') {
5649 } elsif ($quilt_mode eq 'auto') {
5650 progress __ "quilt fixup cannot be linear, smashing...";
5652 confess "$quilt_mode ?";
5655 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5656 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5658 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5660 quiltify_dpkg_commit "auto-$version-$target-$time",
5661 (getfield $clogp, 'Maintainer'),
5662 (f_ "Automatically generated patch (%s)\n".
5663 "Last (up to) %s git changes, FYI:\n\n",
5664 $clogp->{Version}, $ncommits).
5669 progress __ "quiltify linearisation planning successful, executing...";
5671 for (my $p = $sref_S;
5672 my $c = $p->{Child};
5674 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5675 next unless $p->{Nontrivial};
5677 my $cc = $c->{Commit};
5679 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5680 $commitdata =~ m/\n\n/ or die "$c ?";
5683 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5686 my $commitdate = cmdoutput
5687 @git, qw(log -n1 --pretty=format:%aD), $cc;
5689 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5691 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5698 my $gbp_check_suitable = sub {
5703 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5704 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5705 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5706 die __ "is series file\n" if m{$series_filename_re}o;
5707 die __ "too long\n" if length > 200;
5709 return $_ unless $@;
5711 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5716 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5718 (\S+) \s* \n //ixm) {
5719 $patchname = $gbp_check_suitable->($1, 'Name');
5721 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5723 (\S+) \s* \n //ixm) {
5724 $patchdir = $gbp_check_suitable->($1, 'Topic');
5729 if (!defined $patchname) {
5730 $patchname = $title;
5731 $patchname =~ s/[.:]$//;
5734 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5735 my $translitname = $converter->convert($patchname);
5736 die unless defined $translitname;
5737 $patchname = $translitname;
5740 +(f_ "dgit: patch title transliteration error: %s", $@)
5742 $patchname =~ y/ A-Z/-a-z/;
5743 $patchname =~ y/-a-z0-9_.+=~//cd;
5744 $patchname =~ s/^\W/x-$&/;
5745 $patchname = substr($patchname,0,40);
5746 $patchname .= ".patch";
5748 if (!defined $patchdir) {
5751 if (length $patchdir) {
5752 $patchname = "$patchdir/$patchname";
5754 if ($patchname =~ m{^(.*)/}) {
5755 mkpath "debian/patches/$1";
5760 stat "debian/patches/$patchname$index";
5762 $!==ENOENT or confess "$patchname$index $!";
5764 runcmd @git, qw(checkout -q), $cc;
5766 # We use the tip's changelog so that dpkg-source doesn't
5767 # produce complaining messages from dpkg-parsechangelog. None
5768 # of the information dpkg-source gets from the changelog is
5769 # actually relevant - it gets put into the original message
5770 # which dpkg-source provides our stunt editor, and then
5772 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5774 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5775 "Date: $commitdate\n".
5776 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5778 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5781 runcmd @git, qw(checkout -q master);
5784 sub build_maybe_quilt_fixup () {
5785 my ($format,$fopts) = get_source_format;
5786 return unless madformat_wantfixup $format;
5789 check_for_vendor_patches();
5791 $do_split_brain = 1 if quiltmode_splitbrain();
5793 my $clogp = parsechangelog();
5794 my $headref = git_rev_parse('HEAD');
5795 my $symref = git_get_symref();
5797 if ($quilt_mode eq 'linear'
5798 && !$fopts->{'single-debian-patch'}
5799 && branch_is_gdr($headref)) {
5800 # This is much faster. It also makes patches that gdr
5801 # likes better for future updates without laundering.
5803 # However, it can fail in some casses where we would
5804 # succeed: if there are existing patches, which correspond
5805 # to a prefix of the branch, but are not in gbp/gdr
5806 # format, gdr will fail (exiting status 7), but we might
5807 # be able to figure out where to start linearising. That
5808 # will be slower so hopefully there's not much to do.
5809 my @cmd = (@git_debrebase,
5810 qw(--noop-ok -funclean-mixed -funclean-ordering
5811 make-patches --quiet-would-amend));
5812 # We tolerate soe snags that gdr wouldn't, by default.
5818 and not ($? == 7*256 or
5819 $? == -1 && $!==ENOENT);
5823 $headref = git_rev_parse('HEAD');
5827 changedir $playground;
5829 my $upstreamversion = upstreamversion $version;
5831 if ($fopts->{'single-debian-patch'}) {
5832 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5834 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5838 runcmd_ordryrun_local
5839 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5842 sub build_check_quilt_splitbrain () {
5843 build_maybe_quilt_fixup();
5845 if ($do_split_brain) {
5846 fail <<END unless access_cfg_tagformats_can_splitbrain;
5847 quilt mode $quilt_mode requires split view so server needs to support
5848 both "new" and "maint" tag formats, but config says it doesn't.
5853 sub unpack_playtree_need_cd_work ($) {
5856 # prep_ud() must have been called already.
5857 if (!chdir "work") {
5858 # Check in the filesystem because sometimes we run prep_ud
5859 # in between multiple calls to unpack_playtree_need_cd_work.
5860 confess "$!" unless $!==ENOENT;
5861 mkdir "work" or confess "$!";
5863 mktree_in_ud_here();
5865 runcmd @git, qw(reset -q --hard), $headref;
5868 sub unpack_playtree_linkorigs ($$) {
5869 my ($upstreamversion, $fn) = @_;
5870 # calls $fn->($leafname);
5872 my $bpd_abs = bpd_abs();
5874 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5876 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5877 while ($!=0, defined(my $leaf = readdir QFD)) {
5878 my $f = bpd_abs()."/".$leaf;
5880 local ($debuglevel) = $debuglevel-1;
5881 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5883 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5884 printdebug "QF linkorigs $leaf, $f Y\n";
5885 link_ltarget $f, $leaf or die "$leaf $!";
5888 die "$buildproductsdir: $!" if $!;
5892 sub quilt_fixup_delete_pc () {
5893 runcmd @git, qw(rm -rqf .pc);
5894 commit_admin +(__ <<END).<<ENDU
5895 Commit removal of .pc (quilt series tracking data)
5898 [dgit ($our_version) upgrade quilt-remove-pc]
5902 sub quilt_fixup_singlepatch ($$$) {
5903 my ($clogp, $headref, $upstreamversion) = @_;
5905 progress __ "starting quiltify (single-debian-patch)";
5907 # dpkg-source --commit generates new patches even if
5908 # single-debian-patch is in debian/source/options. In order to
5909 # get it to generate debian/patches/debian-changes, it is
5910 # necessary to build the source package.
5912 unpack_playtree_linkorigs($upstreamversion, sub { });
5913 unpack_playtree_need_cd_work($headref);
5915 rmtree("debian/patches");
5917 runcmd @dpkgsource, qw(-b .);
5919 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5920 rename srcfn("$upstreamversion", "/debian/patches"),
5921 "work/debian/patches"
5923 or confess "install d/patches: $!";
5926 commit_quilty_patch();
5929 sub quilt_need_fake_dsc ($) {
5930 # cwd should be playground
5931 my ($upstreamversion) = @_;
5933 return if stat_exists "fake.dsc";
5934 # ^ OK to test this as a sentinel because if we created it
5935 # we must either have done the rest too, or crashed.
5937 my $fakeversion="$upstreamversion-~~DGITFAKE";
5939 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5940 print $fakedsc <<END or confess "$!";
5943 Version: $fakeversion
5947 my $dscaddfile=sub {
5950 my $md = new Digest::MD5;
5952 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5953 stat $fh or confess "$!";
5957 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5960 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5962 my @files=qw(debian/source/format debian/rules
5963 debian/control debian/changelog);
5964 foreach my $maybe (qw(debian/patches debian/source/options
5965 debian/tests/control)) {
5966 next unless stat_exists "$maindir/$maybe";
5967 push @files, $maybe;
5970 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5971 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5973 $dscaddfile->($debtar);
5974 close $fakedsc or confess "$!";
5977 sub quilt_fakedsc2unapplied ($$) {
5978 my ($headref, $upstreamversion) = @_;
5979 # must be run in the playground
5980 # quilt_need_fake_dsc must have been called
5983 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5985 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5986 rename $fakexdir, "fake" or die "$fakexdir $!";
5990 remove_stray_gits(__ "source package");
5991 mktree_in_ud_here();
5995 rmtree 'debian'; # git checkout commitish paths does not delete!
5996 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5997 my $unapplied=git_add_write_tree();
5998 printdebug "fake orig tree object $unapplied\n";
6002 sub quilt_check_splitbrain_cache ($$) {
6003 my ($headref, $upstreamversion) = @_;
6004 # Called only if we are in (potentially) split brain mode.
6005 # Called in playground.
6006 # Computes the cache key and looks in the cache.
6007 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
6009 my $splitbrain_cachekey;
6012 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6014 # we look in the reflog of dgit-intern/quilt-cache
6015 # we look for an entry whose message is the key for the cache lookup
6016 my @cachekey = (qw(dgit), $our_version);
6017 push @cachekey, $upstreamversion;
6018 push @cachekey, $quilt_mode;
6019 push @cachekey, $headref;
6021 push @cachekey, hashfile('fake.dsc');
6023 my $srcshash = Digest::SHA->new(256);
6024 my %sfs = ( %INC, '$0(dgit)' => $0 );
6025 foreach my $sfk (sort keys %sfs) {
6026 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6027 $srcshash->add($sfk," ");
6028 $srcshash->add(hashfile($sfs{$sfk}));
6029 $srcshash->add("\n");
6031 push @cachekey, $srcshash->hexdigest();
6032 $splitbrain_cachekey = "@cachekey";
6034 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6036 my $cachehit = reflog_cache_lookup
6037 "refs/$splitbraincache", $splitbrain_cachekey;
6040 unpack_playtree_need_cd_work($headref);
6041 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6042 if ($cachehit ne $headref) {
6043 progress f_ "dgit view: found cached (%s)", $saved;
6044 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6046 return ($cachehit, $splitbrain_cachekey);
6048 progress __ "dgit view: found cached, no changes required";
6049 return ($headref, $splitbrain_cachekey);
6052 printdebug "splitbrain cache miss\n";
6053 return (undef, $splitbrain_cachekey);
6056 sub quilt_fixup_multipatch ($$$) {
6057 my ($clogp, $headref, $upstreamversion) = @_;
6059 progress f_ "examining quilt state (multiple patches, %s mode)",
6063 # - honour any existing .pc in case it has any strangeness
6064 # - determine the git commit corresponding to the tip of
6065 # the patch stack (if there is one)
6066 # - if there is such a git commit, convert each subsequent
6067 # git commit into a quilt patch with dpkg-source --commit
6068 # - otherwise convert all the differences in the tree into
6069 # a single git commit
6073 # Our git tree doesn't necessarily contain .pc. (Some versions of
6074 # dgit would include the .pc in the git tree.) If there isn't
6075 # one, we need to generate one by unpacking the patches that we
6078 # We first look for a .pc in the git tree. If there is one, we
6079 # will use it. (This is not the normal case.)
6081 # Otherwise need to regenerate .pc so that dpkg-source --commit
6082 # can work. We do this as follows:
6083 # 1. Collect all relevant .orig from parent directory
6084 # 2. Generate a debian.tar.gz out of
6085 # debian/{patches,rules,source/format,source/options}
6086 # 3. Generate a fake .dsc containing just these fields:
6087 # Format Source Version Files
6088 # 4. Extract the fake .dsc
6089 # Now the fake .dsc has a .pc directory.
6090 # (In fact we do this in every case, because in future we will
6091 # want to search for a good base commit for generating patches.)
6093 # Then we can actually do the dpkg-source --commit
6094 # 1. Make a new working tree with the same object
6095 # store as our main tree and check out the main
6097 # 2. Copy .pc from the fake's extraction, if necessary
6098 # 3. Run dpkg-source --commit
6099 # 4. If the result has changes to debian/, then
6100 # - git add them them
6101 # - git add .pc if we had a .pc in-tree
6103 # 5. If we had a .pc in-tree, delete it, and git commit
6104 # 6. Back in the main tree, fast forward to the new HEAD
6106 # Another situation we may have to cope with is gbp-style
6107 # patches-unapplied trees.
6109 # We would want to detect these, so we know to escape into
6110 # quilt_fixup_gbp. However, this is in general not possible.
6111 # Consider a package with a one patch which the dgit user reverts
6112 # (with git revert or the moral equivalent).
6114 # That is indistinguishable in contents from a patches-unapplied
6115 # tree. And looking at the history to distinguish them is not
6116 # useful because the user might have made a confusing-looking git
6117 # history structure (which ought to produce an error if dgit can't
6118 # cope, not a silent reintroduction of an unwanted patch).
6120 # So gbp users will have to pass an option. But we can usually
6121 # detect their failure to do so: if the tree is not a clean
6122 # patches-applied tree, quilt linearisation fails, but the tree
6123 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6124 # they want --quilt=unapplied.
6126 # To help detect this, when we are extracting the fake dsc, we
6127 # first extract it with --skip-patches, and then apply the patches
6128 # afterwards with dpkg-source --before-build. That lets us save a
6129 # tree object corresponding to .origs.
6131 my $splitbrain_cachekey;
6133 quilt_need_fake_dsc($upstreamversion);
6135 if (quiltmode_splitbrain()) {
6137 ($cachehit, $splitbrain_cachekey) =
6138 quilt_check_splitbrain_cache($headref, $upstreamversion);
6139 return if $cachehit;
6141 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6145 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6147 if (system @bbcmd) {
6148 failedcmd @bbcmd if $? < 0;
6150 failed to apply your git tree's patch stack (from debian/patches/) to
6151 the corresponding upstream tarball(s). Your source tree and .orig
6152 are probably too inconsistent. dgit can only fix up certain kinds of
6153 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6159 unpack_playtree_need_cd_work($headref);
6162 if (stat_exists ".pc") {
6164 progress __ "Tree already contains .pc - will use it then delete it.";
6167 rename '../fake/.pc','.pc' or confess "$!";
6170 changedir '../fake';
6172 my $oldtiptree=git_add_write_tree();
6173 printdebug "fake o+d/p tree object $unapplied\n";
6174 changedir '../work';
6177 # We calculate some guesswork now about what kind of tree this might
6178 # be. This is mostly for error reporting.
6184 # O = orig, without patches applied
6185 # A = "applied", ie orig with H's debian/patches applied
6186 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6187 \%editedignores, \@unrepres),
6188 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6189 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6193 foreach my $bits (qw(01 02)) {
6194 foreach my $v (qw(O2H O2A H2A)) {
6195 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6198 printdebug "differences \@dl @dl.\n";
6201 "%s: base trees orig=%.20s o+d/p=%.20s",
6202 $us, $unapplied, $oldtiptree;
6204 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6205 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6206 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6207 $us, $dl[2], $dl[5];
6210 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6213 forceable_fail [qw(unrepresentable)], __ <<END;
6214 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6219 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6220 push @failsuggestion, [ 'unapplied', __
6221 "This might be a patches-unapplied branch." ];
6222 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6223 push @failsuggestion, [ 'applied', __
6224 "This might be a patches-applied branch." ];
6226 push @failsuggestion, [ 'quilt-mode', __
6227 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6229 push @failsuggestion, [ 'gitattrs', __
6230 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6231 if stat_exists '.gitattributes';
6233 push @failsuggestion, [ 'origs', __
6234 "Maybe orig tarball(s) are not identical to git representation?" ];
6236 if ($do_split_brain) {
6237 runcmd @git, qw(checkout -q -b dgit-view);
6238 die if $split_brain;
6241 if (quiltmode_splitbrain()) {
6242 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6243 $diffbits, \%editedignores,
6244 $splitbrain_cachekey);
6248 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6249 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6251 if (!open P, '>>', ".pc/applied-patches") {
6252 $!==&ENOENT or confess "$!";
6257 commit_quilty_patch();
6259 if ($mustdeletepc) {
6260 quilt_fixup_delete_pc();
6264 sub quilt_fixup_editor () {
6265 my $descfn = $ENV{$fakeeditorenv};
6266 my $editing = $ARGV[$#ARGV];
6267 open I1, '<', $descfn or confess "$descfn: $!";
6268 open I2, '<', $editing or confess "$editing: $!";
6269 unlink $editing or confess "$editing: $!";
6270 open O, '>', $editing or confess "$editing: $!";
6271 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6274 $copying ||= m/^\-\-\- /;
6275 next unless $copying;
6276 print O or confess "$!";
6278 I2->error and confess "$!";
6283 sub maybe_apply_patches_dirtily () {
6284 return unless $quilt_mode =~ m/gbp|unapplied/;
6285 print STDERR __ <<END or confess "$!";
6287 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6288 dgit: Have to apply the patches - making the tree dirty.
6289 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6292 $patches_applied_dirtily = 01;
6293 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6294 runcmd qw(dpkg-source --before-build .);
6297 sub maybe_unapply_patches_again () {
6298 progress __ "dgit: Unapplying patches again to tidy up the tree."
6299 if $patches_applied_dirtily;
6300 runcmd qw(dpkg-source --after-build .)
6301 if $patches_applied_dirtily & 01;
6303 if $patches_applied_dirtily & 02;
6304 $patches_applied_dirtily = 0;
6307 #----- other building -----
6309 sub clean_tree_check_git ($$$) {
6310 my ($honour_ignores, $message, $ignmessage) = @_;
6311 my @cmd = (@git, qw(clean -dn));
6312 push @cmd, qw(-x) unless $honour_ignores;
6313 my $leftovers = cmdoutput @cmd;
6314 if (length $leftovers) {
6315 print STDERR $leftovers, "\n" or confess "$!";
6316 $message .= $ignmessage if $honour_ignores;
6321 sub clean_tree_check_git_wd ($) {
6323 return if $cleanmode =~ m{no-check};
6324 return if $patches_applied_dirtily; # yuk
6325 clean_tree_check_git +($cleanmode !~ m{all-check}),
6326 $message, "\n".__ <<END;
6327 If this is just missing .gitignore entries, use a different clean
6328 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6329 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6333 sub clean_tree_check () {
6334 # This function needs to not care about modified but tracked files.
6335 # That was done by check_not_dirty, and by now we may have run
6336 # the rules clean target which might modify tracked files (!)
6337 if ($cleanmode =~ m{^check}) {
6338 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6339 "tree contains uncommitted files and --clean=check specified", '';
6340 } elsif ($cleanmode =~ m{^dpkg-source}) {
6341 clean_tree_check_git_wd __
6342 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6343 } elsif ($cleanmode =~ m{^git}) {
6344 clean_tree_check_git 1, __
6345 "tree contains uncommited, untracked, unignored files\n".
6346 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6347 } elsif ($cleanmode eq 'none') {
6349 confess "$cleanmode ?";
6354 # We always clean the tree ourselves, rather than leave it to the
6355 # builder (dpkg-source, or soemthing which calls dpkg-source).
6356 if ($cleanmode =~ m{^dpkg-source}) {
6357 my @cmd = @dpkgbuildpackage;
6358 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6359 push @cmd, qw(-T clean);
6360 maybe_apply_patches_dirtily();
6361 runcmd_ordryrun_local @cmd;
6362 clean_tree_check_git_wd __
6363 "tree contains uncommitted files (after running rules clean)";
6364 } elsif ($cleanmode =~ m{^git(?!-)}) {
6365 runcmd_ordryrun_local @git, qw(clean -xdf);
6366 } elsif ($cleanmode =~ m{^git-ff}) {
6367 runcmd_ordryrun_local @git, qw(clean -xdff);
6368 } elsif ($cleanmode =~ m{^check}) {
6370 } elsif ($cleanmode eq 'none') {
6372 confess "$cleanmode ?";
6377 badusage __ "clean takes no additional arguments" if @ARGV;
6380 maybe_unapply_patches_again();
6383 # return values from massage_dbp_args are one or both of these flags
6384 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6385 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6387 sub build_or_push_prep_early () {
6388 our $build_or_push_prep_early_done //= 0;
6389 return if $build_or_push_prep_early_done++;
6390 badusage f_ "-p is not allowed with dgit %s", $subcommand
6391 if defined $package;
6392 my $clogp = parsechangelog();
6393 $isuite = getfield $clogp, 'Distribution';
6394 $package = getfield $clogp, 'Source';
6395 $version = getfield $clogp, 'Version';
6396 $dscfn = dscfn($version);
6399 sub build_prep_early () {
6400 build_or_push_prep_early();
6405 sub build_prep ($) {
6409 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6410 # Clean the tree because we're going to use the contents of
6411 # $maindir. (We trying to include dirty changes in the source
6412 # package, or we are running the builder in $maindir.)
6413 || $cleanmode =~ m{always}) {
6414 # Or because the user asked us to.
6417 # We don't actually need to do anything in $maindir, but we
6418 # should do some kind of cleanliness check because (i) the
6419 # user may have forgotten a `git add', and (ii) if the user
6420 # said -wc we should still do the check.
6423 build_check_quilt_splitbrain();
6425 my $pat = changespat $version;
6426 foreach my $f (glob "$buildproductsdir/$pat") {
6429 fail f_ "remove old changes file %s: %s", $f, $!;
6431 progress f_ "would remove %s", $f;
6437 sub changesopts_initial () {
6438 my @opts =@changesopts[1..$#changesopts];
6441 sub changesopts_version () {
6442 if (!defined $changes_since_version) {
6445 @vsns = archive_query('archive_query');
6446 my @quirk = access_quirk();
6447 if ($quirk[0] eq 'backports') {
6448 local $isuite = $quirk[2];
6450 canonicalise_suite();
6451 push @vsns, archive_query('archive_query');
6457 "archive query failed (queried because --since-version not specified)";
6460 @vsns = map { $_->[0] } @vsns;
6461 @vsns = sort { -version_compare($a, $b) } @vsns;
6462 $changes_since_version = $vsns[0];
6463 progress f_ "changelog will contain changes since %s", $vsns[0];
6465 $changes_since_version = '_';
6466 progress __ "package seems new, not specifying -v<version>";
6469 if ($changes_since_version ne '_') {
6470 return ("-v$changes_since_version");
6476 sub changesopts () {
6477 return (changesopts_initial(), changesopts_version());
6480 sub massage_dbp_args ($;$) {
6481 my ($cmd,$xargs) = @_;
6482 # Since we split the source build out so we can do strange things
6483 # to it, massage the arguments to dpkg-buildpackage so that the
6484 # main build doessn't build source (or add an argument to stop it
6485 # building source by default).
6486 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6487 # -nc has the side effect of specifying -b if nothing else specified
6488 # and some combinations of -S, -b, et al, are errors, rather than
6489 # later simply overriding earlie. So we need to:
6490 # - search the command line for these options
6491 # - pick the last one
6492 # - perhaps add our own as a default
6493 # - perhaps adjust it to the corresponding non-source-building version
6495 foreach my $l ($cmd, $xargs) {
6497 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6500 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6501 my $r = WANTSRC_BUILDER;
6502 printdebug "massage split $dmode.\n";
6503 if ($dmode =~ s/^--build=//) {
6505 my @d = split /,/, $dmode;
6506 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6507 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6508 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6509 fail __ "Wanted to build nothing!" unless $r;
6510 $dmode = '--build='. join ',', grep m/./, @d;
6513 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6514 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6515 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6518 printdebug "massage done $r $dmode.\n";
6520 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6526 my $wasdir = must_getcwd();
6527 changedir $buildproductsdir;
6532 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6533 sub postbuild_mergechanges ($) {
6534 my ($msg_if_onlyone) = @_;
6535 # If there is only one .changes file, fail with $msg_if_onlyone,
6536 # or if that is undef, be a no-op.
6537 # Returns the changes file to report to the user.
6538 my $pat = changespat $version;
6539 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6540 @changesfiles = sort {
6541 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6545 if (@changesfiles==1) {
6546 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6547 only one changes file from build (%s)
6549 if defined $msg_if_onlyone;
6550 $result = $changesfiles[0];
6551 } elsif (@changesfiles==2) {
6552 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6553 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6554 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6557 runcmd_ordryrun_local @mergechanges, @changesfiles;
6558 my $multichanges = changespat $version,'multi';
6560 stat_exists $multichanges or fail f_
6561 "%s unexpectedly not created by build", $multichanges;
6562 foreach my $cf (glob $pat) {
6563 next if $cf eq $multichanges;
6564 rename "$cf", "$cf.inmulti" or fail f_
6565 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6568 $result = $multichanges;
6570 fail f_ "wrong number of different changes files (%s)",
6573 printdone f_ "build successful, results in %s\n", $result
6577 sub midbuild_checkchanges () {
6578 my $pat = changespat $version;
6579 return if $rmchanges;
6580 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6582 $_ ne changespat $version,'source' and
6583 $_ ne changespat $version,'multi'
6585 fail +(f_ <<END, $pat, "@unwanted")
6586 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6587 Suggest you delete %s.
6592 sub midbuild_checkchanges_vanilla ($) {
6594 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6597 sub postbuild_mergechanges_vanilla ($) {
6599 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6601 postbuild_mergechanges(undef);
6604 printdone __ "build successful\n";
6610 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6611 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6612 %s: warning: build-products-dir will be ignored; files will go to ..
6614 $buildproductsdir = '..';
6615 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6616 my $wantsrc = massage_dbp_args \@dbp;
6617 build_prep($wantsrc);
6618 if ($wantsrc & WANTSRC_SOURCE) {
6620 midbuild_checkchanges_vanilla $wantsrc;
6622 if ($wantsrc & WANTSRC_BUILDER) {
6623 push @dbp, changesopts_version();
6624 maybe_apply_patches_dirtily();
6625 runcmd_ordryrun_local @dbp;
6627 maybe_unapply_patches_again();
6628 postbuild_mergechanges_vanilla $wantsrc;
6632 $quilt_mode //= 'gbp';
6638 # gbp can make .origs out of thin air. In my tests it does this
6639 # even for a 1.0 format package, with no origs present. So I
6640 # guess it keys off just the version number. We don't know
6641 # exactly what .origs ought to exist, but let's assume that we
6642 # should run gbp if: the version has an upstream part and the main
6644 my $upstreamversion = upstreamversion $version;
6645 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6646 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6648 if ($gbp_make_orig) {
6650 $cleanmode = 'none'; # don't do it again
6653 my @dbp = @dpkgbuildpackage;
6655 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6657 if (!length $gbp_build[0]) {
6658 if (length executable_on_path('git-buildpackage')) {
6659 $gbp_build[0] = qw(git-buildpackage);
6661 $gbp_build[0] = 'gbp buildpackage';
6664 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6666 push @cmd, (qw(-us -uc --git-no-sign-tags),
6667 "--git-builder=".(shellquote @dbp));
6669 if ($gbp_make_orig) {
6670 my $priv = dgit_privdir();
6671 my $ok = "$priv/origs-gen-ok";
6672 unlink $ok or $!==&ENOENT or confess "$!";
6673 my @origs_cmd = @cmd;
6674 push @origs_cmd, qw(--git-cleaner=true);
6675 push @origs_cmd, "--git-prebuild=".
6676 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6677 push @origs_cmd, @ARGV;
6679 debugcmd @origs_cmd;
6681 do { local $!; stat_exists $ok; }
6682 or failedcmd @origs_cmd;
6684 dryrun_report @origs_cmd;
6688 build_prep($wantsrc);
6689 if ($wantsrc & WANTSRC_SOURCE) {
6691 midbuild_checkchanges_vanilla $wantsrc;
6693 push @cmd, '--git-cleaner=true';
6695 maybe_unapply_patches_again();
6696 if ($wantsrc & WANTSRC_BUILDER) {
6697 push @cmd, changesopts();
6698 runcmd_ordryrun_local @cmd, @ARGV;
6700 postbuild_mergechanges_vanilla $wantsrc;
6702 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6704 sub building_source_in_playtree {
6705 # If $includedirty, we have to build the source package from the
6706 # working tree, not a playtree, so that uncommitted changes are
6707 # included (copying or hardlinking them into the playtree could
6710 # Note that if we are building a source package in split brain
6711 # mode we do not support including uncommitted changes, because
6712 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6713 # building a source package)) => !$includedirty
6714 return !$includedirty;
6718 $sourcechanges = changespat $version,'source';
6720 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6721 or fail f_ "remove %s: %s", $sourcechanges, $!;
6723 my @cmd = (@dpkgsource, qw(-b --));
6725 if (building_source_in_playtree()) {
6727 my $headref = git_rev_parse('HEAD');
6728 # If we are in split brain, there is already a playtree with
6729 # the thing we should package into a .dsc (thanks to quilt
6730 # fixup). If not, make a playtree
6731 prep_ud() unless $split_brain;
6732 changedir $playground;
6733 unless ($split_brain) {
6734 my $upstreamversion = upstreamversion $version;
6735 unpack_playtree_linkorigs($upstreamversion, sub { });
6736 unpack_playtree_need_cd_work($headref);
6740 $leafdir = basename $maindir;
6742 if ($buildproductsdir ne '..') {
6743 # Well, we are going to run dpkg-source -b which consumes
6744 # origs from .. and generates output there. To make this
6745 # work when the bpd is not .. , we would have to (i) link
6746 # origs from bpd to .. , (ii) check for files that
6747 # dpkg-source -b would/might overwrite, and afterwards
6748 # (iii) move all the outputs back to the bpd (iv) except
6749 # for the origs which should be deleted from .. if they
6750 # weren't there beforehand. And if there is an error and
6751 # we don't run to completion we would necessarily leave a
6752 # mess. This is too much. The real way to fix this
6753 # is for dpkg-source to have bpd support.
6754 confess unless $includedirty;
6756 "--include-dirty not supported with --build-products-dir, sorry";
6761 runcmd_ordryrun_local @cmd, $leafdir;
6764 runcmd_ordryrun_local qw(sh -ec),
6765 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6766 @dpkggenchanges, qw(-S), changesopts();
6769 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6770 $dsc = parsecontrol($dscfn, "source package");
6774 printdebug " renaming ($why) $l\n";
6775 rename_link_xf 0, "$l", bpd_abs()."/$l"
6776 or fail f_ "put in place new built file (%s): %s", $l, $@;
6778 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6779 $l =~ m/\S+$/ or next;
6782 $mv->('dsc', $dscfn);
6783 $mv->('changes', $sourcechanges);
6788 sub cmd_build_source {
6789 badusage __ "build-source takes no additional arguments" if @ARGV;
6790 build_prep(WANTSRC_SOURCE);
6792 maybe_unapply_patches_again();
6793 printdone f_ "source built, results in %s and %s",
6794 $dscfn, $sourcechanges;
6797 sub cmd_push_source {
6800 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6801 "sense with push-source!"
6803 build_check_quilt_splitbrain();
6805 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6806 __ "source changes file");
6807 unless (test_source_only_changes($changes)) {
6808 fail __ "user-specified changes file is not source-only";
6811 # Building a source package is very fast, so just do it
6813 confess "er, patches are applied dirtily but shouldn't be.."
6814 if $patches_applied_dirtily;
6815 $changesfile = $sourcechanges;
6820 sub binary_builder {
6821 my ($bbuilder, $pbmc_msg, @args) = @_;
6822 build_prep(WANTSRC_SOURCE);
6824 midbuild_checkchanges();
6827 stat_exists $dscfn or fail f_
6828 "%s (in build products dir): %s", $dscfn, $!;
6829 stat_exists $sourcechanges or fail f_
6830 "%s (in build products dir): %s", $sourcechanges, $!;
6832 runcmd_ordryrun_local @$bbuilder, @args;
6834 maybe_unapply_patches_again();
6836 postbuild_mergechanges($pbmc_msg);
6842 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6843 perhaps you need to pass -A ? (sbuild's default is to build only
6844 arch-specific binaries; dgit 1.4 used to override that.)
6849 my ($pbuilder) = @_;
6851 # @ARGV is allowed to contain only things that should be passed to
6852 # pbuilder under debbuildopts; just massage those
6853 my $wantsrc = massage_dbp_args \@ARGV;
6855 "you asked for a builder but your debbuildopts didn't ask for".
6856 " any binaries -- is this really what you meant?"
6857 unless $wantsrc & WANTSRC_BUILDER;
6859 "we must build a .dsc to pass to the builder but your debbuiltopts".
6860 " forbids the building of a source package; cannot continue"
6861 unless $wantsrc & WANTSRC_SOURCE;
6862 # We do not want to include the verb "build" in @pbuilder because
6863 # the user can customise @pbuilder and they shouldn't be required
6864 # to include "build" in their customised value. However, if the
6865 # user passes any additional args to pbuilder using the dgit
6866 # option --pbuilder:foo, such args need to come after the "build"
6867 # verb. opts_opt_multi_cmd does all of that.
6868 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6869 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6874 pbuilder(\@pbuilder);
6877 sub cmd_cowbuilder {
6878 pbuilder(\@cowbuilder);
6881 sub cmd_quilt_fixup {
6882 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6885 build_maybe_quilt_fixup();
6888 sub cmd_print_unapplied_treeish {
6889 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6891 my $headref = git_rev_parse('HEAD');
6892 my $clogp = commit_getclogp $headref;
6893 $package = getfield $clogp, 'Source';
6894 $version = getfield $clogp, 'Version';
6895 $isuite = getfield $clogp, 'Distribution';
6896 $csuite = $isuite; # we want this to be offline!
6900 changedir $playground;
6901 my $uv = upstreamversion $version;
6902 quilt_need_fake_dsc($uv);
6903 my $u = quilt_fakedsc2unapplied($headref, $uv);
6904 print $u, "\n" or confess "$!";
6907 sub import_dsc_result {
6908 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6909 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6911 check_gitattrs($newhash, __ "source tree");
6913 progress f_ "dgit: import-dsc: %s", $what_msg;
6916 sub cmd_import_dsc {
6920 last unless $ARGV[0] =~ m/^-/;
6923 if (m/^--require-valid-signature$/) {
6926 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6930 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6932 my ($dscfn, $dstbranch) = @ARGV;
6934 badusage __ "dry run makes no sense with import-dsc"
6937 my $force = $dstbranch =~ s/^\+// ? +1 :
6938 $dstbranch =~ s/^\.\.// ? -1 :
6940 my $info = $force ? " $&" : '';
6941 $info = "$dscfn$info";
6943 my $specbranch = $dstbranch;
6944 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6945 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6947 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6948 my $chead = cmdoutput_errok @symcmd;
6949 defined $chead or $?==256 or failedcmd @symcmd;
6951 fail f_ "%s is checked out - will not update it", $dstbranch
6952 if defined $chead and $chead eq $dstbranch;
6954 my $oldhash = git_get_ref $dstbranch;
6956 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6957 $dscdata = do { local $/ = undef; <D>; };
6958 D->error and fail f_ "read %s: %s", $dscfn, $!;
6961 # we don't normally need this so import it here
6962 use Dpkg::Source::Package;
6963 my $dp = new Dpkg::Source::Package filename => $dscfn,
6964 require_valid_signature => $needsig;
6966 local $SIG{__WARN__} = sub {
6968 return unless $needsig;
6969 fail __ "import-dsc signature check failed";
6971 if (!$dp->is_signed()) {
6972 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6974 my $r = $dp->check_signature();
6975 confess "->check_signature => $r" if $needsig && $r;
6981 $package = getfield $dsc, 'Source';
6983 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6984 unless forceing [qw(import-dsc-with-dgit-field)];
6985 parse_dsc_field_def_dsc_distro();
6987 $isuite = 'DGIT-IMPORT-DSC';
6988 $idistro //= $dsc_distro;
6992 if (defined $dsc_hash) {
6994 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6995 resolve_dsc_field_commit undef, undef;
6997 if (defined $dsc_hash) {
6998 my @cmd = (qw(sh -ec),
6999 "echo $dsc_hash | git cat-file --batch-check");
7000 my $objgot = cmdoutput @cmd;
7001 if ($objgot =~ m#^\w+ missing\b#) {
7002 fail f_ <<END, $dsc_hash
7003 .dsc contains Dgit field referring to object %s
7004 Your git tree does not have that object. Try `git fetch' from a
7005 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7008 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7010 progress __ "Not fast forward, forced update.";
7012 fail f_ "Not fast forward to %s", $dsc_hash;
7015 import_dsc_result $dstbranch, $dsc_hash,
7016 "dgit import-dsc (Dgit): $info",
7017 f_ "updated git ref %s", $dstbranch;
7021 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7022 Branch %s already exists
7023 Specify ..%s for a pseudo-merge, binding in existing history
7024 Specify +%s to overwrite, discarding existing history
7026 if $oldhash && !$force;
7028 my @dfi = dsc_files_info();
7029 foreach my $fi (@dfi) {
7030 my $f = $fi->{Filename};
7031 # We transfer all the pieces of the dsc to the bpd, not just
7032 # origs. This is by analogy with dgit fetch, which wants to
7033 # keep them somewhere to avoid downloading them again.
7034 # We make symlinks, though. If the user wants copies, then
7035 # they can copy the parts of the dsc to the bpd using dcmd,
7037 my $here = "$buildproductsdir/$f";
7042 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7044 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7045 printdebug "not in bpd, $f ...\n";
7046 # $f does not exist in bpd, we need to transfer it
7048 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7049 # $there is file we want, relative to user's cwd, or abs
7050 printdebug "not in bpd, $f, test $there ...\n";
7051 stat $there or fail f_
7052 "import %s requires %s, but: %s", $dscfn, $there, $!;
7053 if ($there =~ m#^(?:\./+)?\.\./+#) {
7054 # $there is relative to user's cwd
7055 my $there_from_parent = $';
7056 if ($buildproductsdir !~ m{^/}) {
7057 # abs2rel, despite its name, can take two relative paths
7058 $there = File::Spec->abs2rel($there,$buildproductsdir);
7059 # now $there is relative to bpd, great
7060 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7062 $there = (dirname $maindir)."/$there_from_parent";
7063 # now $there is absoute
7064 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7066 } elsif ($there =~ m#^/#) {
7067 # $there is absolute already
7068 printdebug "not in bpd, $f, abs, $there ...\n";
7071 "cannot import %s which seems to be inside working tree!",
7074 symlink $there, $here or fail f_
7075 "symlink %s to %s: %s", $there, $here, $!;
7076 progress f_ "made symlink %s -> %s", $here, $there;
7077 # print STDERR Dumper($fi);
7079 my @mergeinputs = generate_commits_from_dsc();
7080 die unless @mergeinputs == 1;
7082 my $newhash = $mergeinputs[0]{Commit};
7087 "Import, forced update - synthetic orphan git history.";
7088 } elsif ($force < 0) {
7089 progress __ "Import, merging.";
7090 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7091 my $version = getfield $dsc, 'Version';
7092 my $clogp = commit_getclogp $newhash;
7093 my $authline = clogp_authline $clogp;
7094 $newhash = make_commit_text <<ENDU
7102 .(f_ <<END, $package, $version, $dstbranch);
7103 Merge %s (%s) import into %s
7106 die; # caught earlier
7110 import_dsc_result $dstbranch, $newhash,
7111 "dgit import-dsc: $info",
7112 f_ "results are in git ref %s", $dstbranch;
7115 sub pre_archive_api_query () {
7116 not_necessarily_a_tree();
7118 sub cmd_archive_api_query {
7119 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7120 my ($subpath) = @ARGV;
7121 local $isuite = 'DGIT-API-QUERY-CMD';
7122 my @cmd = archive_api_query_cmd($subpath);
7125 exec @cmd or fail f_ "exec curl: %s\n", $!;
7128 sub repos_server_url () {
7129 $package = '_dgit-repos-server';
7130 local $access_forpush = 1;
7131 local $isuite = 'DGIT-REPOS-SERVER';
7132 my $url = access_giturl();
7135 sub pre_clone_dgit_repos_server () {
7136 not_necessarily_a_tree();
7138 sub cmd_clone_dgit_repos_server {
7139 badusage __ "need destination argument" unless @ARGV==1;
7140 my ($destdir) = @ARGV;
7141 my $url = repos_server_url();
7142 my @cmd = (@git, qw(clone), $url, $destdir);
7144 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7147 sub pre_print_dgit_repos_server_source_url () {
7148 not_necessarily_a_tree();
7150 sub cmd_print_dgit_repos_server_source_url {
7152 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7154 my $url = repos_server_url();
7155 print $url, "\n" or confess "$!";
7158 sub pre_print_dpkg_source_ignores {
7159 not_necessarily_a_tree();
7161 sub cmd_print_dpkg_source_ignores {
7163 "no arguments allowed to dgit print-dpkg-source-ignores"
7165 print "@dpkg_source_ignores\n" or confess "$!";
7168 sub cmd_setup_mergechangelogs {
7169 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7171 local $isuite = 'DGIT-SETUP-TREE';
7172 setup_mergechangelogs(1);
7175 sub cmd_setup_useremail {
7176 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7177 local $isuite = 'DGIT-SETUP-TREE';
7181 sub cmd_setup_gitattributes {
7182 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7183 local $isuite = 'DGIT-SETUP-TREE';
7187 sub cmd_setup_new_tree {
7188 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7189 local $isuite = 'DGIT-SETUP-TREE';
7193 #---------- argument parsing and main program ----------
7196 print "dgit version $our_version\n" or confess "$!";
7200 our (%valopts_long, %valopts_short);
7201 our (%funcopts_long);
7203 our (@modeopt_cfgs);
7205 sub defvalopt ($$$$) {
7206 my ($long,$short,$val_re,$how) = @_;
7207 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7208 $valopts_long{$long} = $oi;
7209 $valopts_short{$short} = $oi;
7210 # $how subref should:
7211 # do whatever assignemnt or thing it likes with $_[0]
7212 # if the option should not be passed on to remote, @rvalopts=()
7213 # or $how can be a scalar ref, meaning simply assign the value
7216 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7217 defvalopt '--distro', '-d', '.+', \$idistro;
7218 defvalopt '', '-k', '.+', \$keyid;
7219 defvalopt '--existing-package','', '.*', \$existing_package;
7220 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7221 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7222 defvalopt '--package', '-p', $package_re, \$package;
7223 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7225 defvalopt '', '-C', '.+', sub {
7226 ($changesfile) = (@_);
7227 if ($changesfile =~ s#^(.*)/##) {
7228 $buildproductsdir = $1;
7232 defvalopt '--initiator-tempdir','','.*', sub {
7233 ($initiator_tempdir) = (@_);
7234 $initiator_tempdir =~ m#^/# or
7235 badusage __ "--initiator-tempdir must be used specify an".
7236 " absolute, not relative, directory."
7239 sub defoptmodes ($@) {
7240 my ($varref, $cfgkey, $default, %optmap) = @_;
7242 while (my ($opt,$val) = each %optmap) {
7243 $funcopts_long{$opt} = sub { $$varref = $val; };
7244 $permit{$val} = $val;
7246 push @modeopt_cfgs, {
7249 Default => $default,
7254 defoptmodes \$dodep14tag, qw( dep14tag want
7257 --always-dep14tag always );
7262 if (defined $ENV{'DGIT_SSH'}) {
7263 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7264 } elsif (defined $ENV{'GIT_SSH'}) {
7265 @ssh = ($ENV{'GIT_SSH'});
7273 if (!defined $val) {
7274 badusage f_ "%s needs a value", $what unless @ARGV;
7276 push @rvalopts, $val;
7278 badusage f_ "bad value \`%s' for %s", $val, $what unless
7279 $val =~ m/^$oi->{Re}$(?!\n)/s;
7280 my $how = $oi->{How};
7281 if (ref($how) eq 'SCALAR') {
7286 push @ropts, @rvalopts;
7290 last unless $ARGV[0] =~ m/^-/;
7294 if (m/^--dry-run$/) {
7297 } elsif (m/^--damp-run$/) {
7300 } elsif (m/^--no-sign$/) {
7303 } elsif (m/^--help$/) {
7305 } elsif (m/^--version$/) {
7307 } elsif (m/^--new$/) {
7310 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7311 ($om = $opts_opt_map{$1}) &&
7315 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7316 !$opts_opt_cmdonly{$1} &&
7317 ($om = $opts_opt_map{$1})) {
7320 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7321 !$opts_opt_cmdonly{$1} &&
7322 ($om = $opts_opt_map{$1})) {
7324 my $cmd = shift @$om;
7325 @$om = ($cmd, grep { $_ ne $2 } @$om);
7326 } elsif (m/^--(gbp|dpm)$/s) {
7327 push @ropts, "--quilt=$1";
7329 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7332 } elsif (m/^--no-quilt-fixup$/s) {
7334 $quilt_mode = 'nocheck';
7335 } elsif (m/^--no-rm-on-error$/s) {
7338 } elsif (m/^--no-chase-dsc-distro$/s) {
7340 $chase_dsc_distro = 0;
7341 } elsif (m/^--overwrite$/s) {
7343 $overwrite_version = '';
7344 } elsif (m/^--overwrite=(.+)$/s) {
7346 $overwrite_version = $1;
7347 } elsif (m/^--delayed=(\d+)$/s) {
7350 } elsif (my ($k,$v) =
7351 m/^--save-(dgit-view)=(.+)$/s ||
7352 m/^--(dgit-view)-save=(.+)$/s
7355 $v =~ s#^(?!refs/)#refs/heads/#;
7356 $internal_object_save{$k} = $v;
7357 } elsif (m/^--(no-)?rm-old-changes$/s) {
7360 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7362 push @deliberatelies, $&;
7363 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7367 } elsif (m/^--force-/) {
7369 f_ "%s: warning: ignoring unknown force option %s\n",
7372 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7373 # undocumented, for testing
7375 $tagformat_want = [ $1, 'command line', 1 ];
7376 # 1 menas overrides distro configuration
7377 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7378 # undocumented, for testing
7380 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7381 # ^ it's supposed to be an array ref
7382 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7383 $val = $2 ? $' : undef; #';
7384 $valopt->($oi->{Long});
7385 } elsif ($funcopts_long{$_}) {
7387 $funcopts_long{$_}();
7389 badusage f_ "unknown long option \`%s'", $_;
7396 } elsif (s/^-L/-/) {
7399 } elsif (s/^-h/-/) {
7401 } elsif (s/^-D/-/) {
7405 } elsif (s/^-N/-/) {
7410 push @changesopts, $_;
7412 } elsif (s/^-wn$//s) {
7414 $cleanmode = 'none';
7415 } elsif (s/^-wg(f?)(a?)$//s) {
7418 $cleanmode .= '-ff' if $1;
7419 $cleanmode .= ',always' if $2;
7420 } elsif (s/^-wd(d?)([na]?)$//s) {
7422 $cleanmode = 'dpkg-source';
7423 $cleanmode .= '-d' if $1;
7424 $cleanmode .= ',no-check' if $2 eq 'n';
7425 $cleanmode .= ',all-check' if $2 eq 'a';
7426 } elsif (s/^-wc$//s) {
7428 $cleanmode = 'check';
7429 } elsif (s/^-wci$//s) {
7431 $cleanmode = 'check,ignores';
7432 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7433 push @git, '-c', $&;
7434 $gitcfgs{cmdline}{$1} = [ $2 ];
7435 } elsif (s/^-c([^=]+)$//s) {
7436 push @git, '-c', $&;
7437 $gitcfgs{cmdline}{$1} = [ 'true' ];
7438 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7440 $val = undef unless length $val;
7441 $valopt->($oi->{Short});
7444 badusage f_ "unknown short option \`%s'", $_;
7451 sub check_env_sanity () {
7452 my $blocked = new POSIX::SigSet;
7453 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7456 foreach my $name (qw(PIPE CHLD)) {
7457 my $signame = "SIG$name";
7458 my $signum = eval "POSIX::$signame" // die;
7459 die f_ "%s is set to something other than SIG_DFL\n",
7461 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7462 $blocked->ismember($signum) and
7463 die f_ "%s is blocked\n", $signame;
7469 On entry to dgit, %s
7470 This is a bug produced by something in your execution environment.
7476 sub parseopts_late_defaults () {
7477 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7478 if defined $idistro;
7479 $isuite //= cfg('dgit.default.default-suite');
7481 foreach my $k (keys %opts_opt_map) {
7482 my $om = $opts_opt_map{$k};
7484 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7486 badcfg f_ "cannot set command for %s", $k
7487 unless length $om->[0];
7491 foreach my $c (access_cfg_cfgs("opts-$k")) {
7493 map { $_ ? @$_ : () }
7494 map { $gitcfgs{$_}{$c} }
7495 reverse @gitcfgsources;
7496 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7497 "\n" if $debuglevel >= 4;
7499 badcfg f_ "cannot configure options for %s", $k
7500 if $opts_opt_cmdonly{$k};
7501 my $insertpos = $opts_cfg_insertpos{$k};
7502 @$om = ( @$om[0..$insertpos-1],
7504 @$om[$insertpos..$#$om] );
7508 if (!defined $rmchanges) {
7509 local $access_forpush;
7510 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7513 if (!defined $quilt_mode) {
7514 local $access_forpush;
7515 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7516 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7518 $quilt_mode =~ m/^($quilt_modes_re)$/
7519 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7523 foreach my $moc (@modeopt_cfgs) {
7524 local $access_forpush;
7525 my $vr = $moc->{Var};
7526 next if defined $$vr;
7527 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7528 my $v = $moc->{Vals}{$$vr};
7529 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7534 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7535 if $split_brain && $includedirty;
7537 if (!defined $cleanmode) {
7538 local $access_forpush;
7539 $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
7540 $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
7542 $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
7543 $cleanmode //= 'dpkg-source';
7545 badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7546 $cleanmode =~ m/$cleanmode_re/;
7549 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7550 $buildproductsdir //= '..';
7551 $bpd_glob = $buildproductsdir;
7552 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7555 setlocale(LC_MESSAGES, "");
7558 if ($ENV{$fakeeditorenv}) {
7560 quilt_fixup_editor();
7566 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7567 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7568 if $dryrun_level == 1;
7570 print STDERR __ $helpmsg or confess "$!";
7573 $cmd = $subcommand = shift @ARGV;
7576 my $pre_fn = ${*::}{"pre_$cmd"};
7577 $pre_fn->() if $pre_fn;
7579 if ($invoked_in_git_tree) {
7580 changedir_git_toplevel();
7585 my $fn = ${*::}{"cmd_$cmd"};
7586 $fn or badusage f_ "unknown operation %s", $cmd;