3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2019 Ian Jackson
6 # Copyright (C)2017-2019 Sean Whitton
7 # Copyright (C)2019 Matthew Vernon / Genome Research Limited
9 # This program is free software: you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation, either version 3 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program. If not, see <http://www.gnu.org/licenses/>.
22 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
23 use Debian::Dgit::ExitStatus;
24 use Debian::Dgit::I18n;
28 use Debian::Dgit qw(:DEFAULT :playground);
34 use Dpkg::Control::Hash;
37 use File::Temp qw(tempdir);
41 use Dpkg::Compression;
42 use Dpkg::Compression::Process;
48 use List::MoreUtils qw(pairwise);
49 use Text::Glob qw(match_glob);
51 use Fcntl qw(:DEFAULT :flock);
56 our $our_version = 'UNRELEASED'; ###substituted###
57 our $absurdity = undef; ###substituted###
59 $SIG{INT} = 'DEFAULT'; # work around #932841
61 our @rpushprotovsn_support = qw(6 5 4); # Reverse order!
72 our $dryrun_level = 0;
74 our $buildproductsdir;
77 our $includedirty = 0;
81 our $existing_package = 'dpkg';
83 our $changes_since_version;
85 our $overwrite_version; # undef: not specified; '': check changelog
87 our $quilt_upstream_commitish;
88 our $quilt_upstream_commitish_used;
89 our $quilt_upstream_commitish_message;
90 our $quilt_options_re = 'gbp|dpm|baredebian(?:\+tarball|\+git)?';
91 our $quilt_modes_re = "linear|smash|auto|nofix|nocheck|unapplied|$quilt_options_re";
93 our $splitview_modes_re = qr{auto|always|never};
95 our %internal_object_save;
96 our $we_are_responder;
97 our $we_are_initiator;
98 our $initiator_tempdir;
99 our $patches_applied_dirtily = 00;
100 our $chase_dsc_distro=1;
102 our %forceopts = map { $_=>0 }
103 qw(unrepresentable unsupported-source-format
104 dsc-changes-mismatch changes-origs-exactly
105 uploading-binaries uploading-source-only
107 import-gitapply-absurd
108 import-gitapply-no-absurd
109 import-dsc-with-dgit-field);
111 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
113 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
114 | (?: git | git-ff ) (?: ,always )?
115 | check (?: ,ignores )?
119 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
120 our $splitbraincache = 'dgit-intern/quilt-cache';
121 our $rewritemap = 'dgit-rewrite/map';
123 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
125 our (@dget) = qw(dget);
126 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
127 our (@dput) = qw(dput);
128 our (@debsign) = qw(debsign);
129 our (@gpg) = qw(gpg);
130 our (@sbuild) = (qw(sbuild --no-source));
132 our (@dgit) = qw(dgit);
133 our (@git_debrebase) = qw(git-debrebase);
134 our (@aptget) = qw(apt-get);
135 our (@aptcache) = qw(apt-cache);
136 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
137 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
138 our (@dpkggenchanges) = qw(dpkg-genchanges);
139 our (@mergechanges) = qw(mergechanges -f);
140 our (@gbp_build) = ('');
141 our (@gbp_pq) = ('gbp pq');
142 our (@changesopts) = ('');
143 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
144 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
146 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
149 'debsign' => \@debsign,
151 'sbuild' => \@sbuild,
155 'git-debrebase' => \@git_debrebase,
156 'apt-get' => \@aptget,
157 'apt-cache' => \@aptcache,
158 'dpkg-source' => \@dpkgsource,
159 'dpkg-buildpackage' => \@dpkgbuildpackage,
160 'dpkg-genchanges' => \@dpkggenchanges,
161 'gbp-build' => \@gbp_build,
162 'gbp-pq' => \@gbp_pq,
163 'ch' => \@changesopts,
164 'mergechanges' => \@mergechanges,
165 'pbuilder' => \@pbuilder,
166 'cowbuilder' => \@cowbuilder);
168 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
169 our %opts_cfg_insertpos = map {
171 scalar @{ $opts_opt_map{$_} }
172 } keys %opts_opt_map;
174 sub parseopts_late_defaults();
175 sub quiltify_trees_differ ($$;$$$);
176 sub setup_gitattrs(;$);
177 sub check_gitattrs($$);
184 our $supplementary_message = '';
185 our $made_split_brain = 0;
188 # Interactions between quilt mode and split brain
189 # (currently, split brain only implemented iff
190 # madformat_wantfixup && quiltmode_splitting)
192 # source format sane `3.0 (quilt)'
193 # madformat_wantfixup()
195 # quilt mode normal quiltmode
196 # (eg linear) _splitbrain
198 # ------------ ------------------------------------------------
200 # no split no q cache no q cache forbidden,
201 # brain PM on master q fixup on master prevented
202 # !do_split_brain() PM on master
204 # split brain no q cache q fixup cached, to dgit view
205 # PM in dgit view PM in dgit view
207 # PM = pseudomerge to make ff, due to overwrite (or split view)
208 # "no q cache" = do not record in cache on build, do not check cache
209 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
213 return unless forkcheck_mainprocess();
214 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
217 our $remotename = 'dgit';
218 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
222 if (!defined $absurdity) {
224 $absurdity =~ s{/[^/]+$}{/absurd} or die;
227 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
229 sub lbranch () { return "$branchprefix/$csuite"; }
230 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
231 sub lref () { return "refs/heads/".lbranch(); }
232 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
233 sub rrref () { return server_ref($csuite); }
236 my ($vsn, $sfx) = @_;
237 return &source_file_leafname($package, $vsn, $sfx);
239 sub is_orig_file_of_vsn ($$) {
240 my ($f, $upstreamvsn) = @_;
241 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
246 return srcfn($vsn,".dsc");
249 sub changespat ($;$) {
250 my ($vsn, $arch) = @_;
251 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
260 return unless forkcheck_mainprocess();
261 foreach my $f (@end) {
263 print STDERR "$us: cleanup: $@" if length $@;
268 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
272 sub forceable_fail ($$) {
273 my ($forceoptsl, $msg) = @_;
274 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
275 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
279 my ($forceoptsl) = @_;
280 my @got = grep { $forceopts{$_} } @$forceoptsl;
281 return 0 unless @got;
283 "warning: skipping checks or functionality due to --force-%s\n",
287 sub no_such_package () {
288 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
289 $us, $package, $isuite;
293 sub deliberately ($) {
295 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
298 sub deliberately_not_fast_forward () {
299 foreach (qw(not-fast-forward fresh-repo)) {
300 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
304 sub quiltmode_splitting () {
305 $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/;
307 sub format_quiltmode_splitting ($) {
309 return madformat_wantfixup($format) && quiltmode_splitting();
312 sub do_split_brain () { !!($do_split_brain // confess) }
314 sub opts_opt_multi_cmd {
317 push @cmd, split /\s+/, shift @_;
324 return opts_opt_multi_cmd [], @gbp_pq;
327 sub dgit_privdir () {
328 our $dgit_privdir_made //= ensure_a_playground 'dgit';
332 my $r = $buildproductsdir;
333 $r = "$maindir/$r" unless $r =~ m{^/};
337 sub get_tree_of_commit ($) {
338 my ($commitish) = @_;
339 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
340 $cdata =~ m/\n\n/; $cdata = $`;
341 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
345 sub branch_gdr_info ($$) {
346 my ($symref, $head) = @_;
347 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
348 gdr_ffq_prev_branchinfo($symref);
349 return () unless $status eq 'branch';
350 $ffq_prev = git_get_ref $ffq_prev;
351 $gdrlast = git_get_ref $gdrlast;
352 $gdrlast &&= is_fast_fwd $gdrlast, $head;
353 return ($ffq_prev, $gdrlast);
356 sub branch_is_gdr_unstitched_ff ($$$) {
357 my ($symref, $head, $ancestor) = @_;
358 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
359 return 0 unless $ffq_prev;
360 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
364 sub branch_is_gdr ($) {
366 # This is quite like git-debrebase's keycommits.
367 # We have our own implementation because:
368 # - our algorighm can do fewer tests so is faster
369 # - it saves testing to see if gdr is installed
371 # NB we use this jsut for deciding whether to run gdr make-patches
372 # Before reusing this algorithm for somthing else, its
373 # suitability should be reconsidered.
376 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
377 printdebug "branch_is_gdr $head...\n";
378 my $get_patches = sub {
379 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
382 my $tip_patches = $get_patches->($head);
385 my $cdata = git_cat_file $walk, 'commit';
386 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
387 if ($msg =~ m{^\[git-debrebase\ (
388 anchor | changelog | make-patches |
389 merged-breakwater | pseudomerge
391 # no need to analyse this - it's sufficient
392 # (gdr classifications: Anchor, MergedBreakwaters)
393 # (made by gdr: Pseudomerge, Changelog)
394 printdebug "branch_is_gdr $walk gdr $1 YES\n";
397 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
399 my $walk_tree = get_tree_of_commit $walk;
400 foreach my $p (@parents) {
401 my $p_tree = get_tree_of_commit $p;
402 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
403 # (gdr classification: Pseudomerge; not made by gdr)
404 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
410 # some other non-gdr merge
411 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
412 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
416 # (gdr classification: ?)
417 printdebug "branch_is_gdr $walk ?-octopus NO\n";
421 printdebug "branch_is_gdr $walk origin\n";
424 if ($get_patches->($walk) ne $tip_patches) {
425 # Our parent added, removed, or edited patches, and wasn't
426 # a gdr make-patches commit. gdr make-patches probably
427 # won't do that well, then.
428 # (gdr classification of parent: AddPatches or ?)
429 printdebug "branch_is_gdr $walk ?-patches NO\n";
432 if ($tip_patches eq '' and
433 !defined git_cat_file "$walk~:debian" and
434 !quiltify_trees_differ "$walk~", $walk
436 # (gdr classification of parent: BreakwaterStart
437 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
440 # (gdr classification: Upstream Packaging Mixed Changelog)
441 printdebug "branch_is_gdr $walk plain\n"
447 #---------- remote protocol support, common ----------
449 # remote push initiator/responder protocol:
450 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
451 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
452 # < dgit-remote-push-ready <actual-proto-vsn>
459 # > supplementary-message NBYTES
464 # > file parsed-changelog
465 # [indicates that output of dpkg-parsechangelog follows]
466 # > data-block NBYTES
467 # > [NBYTES bytes of data (no newline)]
468 # [maybe some more blocks]
477 # > param head DGIT-VIEW-HEAD
478 # > param csuite SUITE
479 # > param tagformat new # $protovsn == 4
480 # > param splitbrain 0|1 # $protovsn >= 6
481 # > param maint-view MAINT-VIEW-HEAD
483 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
484 # > file buildinfo # for buildinfos to sign
486 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
487 # # goes into tag, for replay prevention
490 # [indicates that signed tag is wanted]
491 # < data-block NBYTES
492 # < [NBYTES bytes of data (no newline)]
493 # [maybe some more blocks]
497 # > want signed-dsc-changes
498 # < data-block NBYTES [transfer of signed dsc]
500 # < data-block NBYTES [transfer of signed changes]
502 # < data-block NBYTES [transfer of each signed buildinfo
503 # [etc] same number and order as "file buildinfo"]
511 sub i_child_report () {
512 # Sees if our child has died, and reap it if so. Returns a string
513 # describing how it died if it failed, or undef otherwise.
514 return undef unless $i_child_pid;
515 my $got = waitpid $i_child_pid, WNOHANG;
516 return undef if $got <= 0;
517 die unless $got == $i_child_pid;
518 $i_child_pid = undef;
519 return undef unless $?;
520 return f_ "build host child %s", waitstatusmsg();
525 fail f_ "connection lost: %s", $! if $fh->error;
526 fail f_ "protocol violation; %s not expected", $m;
529 sub badproto_badread ($$) {
531 fail f_ "connection lost: %s", $! if $!;
532 my $report = i_child_report();
533 fail $report if defined $report;
534 badproto $fh, f_ "eof (reading %s)", $wh;
537 sub protocol_expect (&$) {
538 my ($match, $fh) = @_;
541 defined && chomp or badproto_badread $fh, __ "protocol message";
549 badproto $fh, f_ "\`%s'", $_;
552 sub protocol_send_file ($$) {
553 my ($fh, $ourfn) = @_;
554 open PF, "<", $ourfn or die "$ourfn: $!";
557 my $got = read PF, $d, 65536;
558 die "$ourfn: $!" unless defined $got;
560 print $fh "data-block ".length($d)."\n" or confess "$!";
561 print $fh $d or confess "$!";
563 PF->error and die "$ourfn $!";
564 print $fh "data-end\n" or confess "$!";
568 sub protocol_read_bytes ($$) {
569 my ($fh, $nbytes) = @_;
570 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
572 my $got = read $fh, $d, $nbytes;
573 $got==$nbytes or badproto_badread $fh, __ "data block";
577 sub protocol_receive_file ($$) {
578 my ($fh, $ourfn) = @_;
579 printdebug "() $ourfn\n";
580 open PF, ">", $ourfn or die "$ourfn: $!";
582 my ($y,$l) = protocol_expect {
583 m/^data-block (.*)$/ ? (1,$1) :
584 m/^data-end$/ ? (0,) :
588 my $d = protocol_read_bytes $fh, $l;
589 print PF $d or confess "$!";
591 close PF or confess "$!";
594 #---------- remote protocol support, responder ----------
596 sub responder_send_command ($) {
598 return unless $we_are_responder;
599 # called even without $we_are_responder
600 printdebug ">> $command\n";
601 print PO $command, "\n" or confess "$!";
604 sub responder_send_file ($$) {
605 my ($keyword, $ourfn) = @_;
606 return unless $we_are_responder;
607 printdebug "]] $keyword $ourfn\n";
608 responder_send_command "file $keyword";
609 protocol_send_file \*PO, $ourfn;
612 sub responder_receive_files ($@) {
613 my ($keyword, @ourfns) = @_;
614 die unless $we_are_responder;
615 printdebug "[[ $keyword @ourfns\n";
616 responder_send_command "want $keyword";
617 foreach my $fn (@ourfns) {
618 protocol_receive_file \*PI, $fn;
621 protocol_expect { m/^files-end$/ } \*PI;
624 #---------- remote protocol support, initiator ----------
626 sub initiator_expect (&) {
628 protocol_expect { &$match } \*RO;
631 #---------- end remote code ----------
634 if ($we_are_responder) {
636 responder_send_command "progress ".length($m) or confess "$!";
637 print PO $m or confess "$!";
645 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
647 sub act_local () { return $dryrun_level <= 1; }
648 sub act_scary () { return !$dryrun_level; }
651 if (!$dryrun_level) {
652 progress f_ "%s ok: %s", $us, "@_";
654 progress f_ "would be ok: %s (but dry run only)", "@_";
659 printcmd(\*STDERR,$debugprefix."#",@_);
662 sub runcmd_ordryrun {
670 sub runcmd_ordryrun_local {
678 our $helpmsg = i_ <<END;
680 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
681 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
682 dgit [dgit-opts] build [dpkg-buildpackage-opts]
683 dgit [dgit-opts] sbuild [sbuild-opts]
684 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
685 dgit [dgit-opts] push [dgit-opts] [suite]
686 dgit [dgit-opts] push-source [dgit-opts] [suite]
687 dgit [dgit-opts] rpush build-host:build-dir ...
688 important dgit options:
689 -k<keyid> sign tag and package with <keyid> instead of default
690 --dry-run -n do not change anything, but go through the motions
691 --damp-run -L like --dry-run but make local changes, without signing
692 --new -N allow introducing a new package
693 --debug -D increase debug level
694 -c<name>=<value> set git config option (used directly by dgit too)
697 our $later_warning_msg = i_ <<END;
698 Perhaps the upload is stuck in incoming. Using the version from git.
702 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
707 @ARGV or badusage __ "too few arguments";
708 return scalar shift @ARGV;
712 not_necessarily_a_tree();
715 print __ $helpmsg or confess "$!";
719 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
721 our %defcfg = ('dgit.default.distro' => 'debian',
722 'dgit.default.default-suite' => 'unstable',
723 'dgit.default.old-dsc-distro' => 'debian',
724 'dgit-suite.*-security.distro' => 'debian-security',
725 'dgit.default.username' => '',
726 'dgit.default.archive-query-default-component' => 'main',
727 'dgit.default.ssh' => 'ssh',
728 'dgit.default.archive-query' => 'madison:',
729 'dgit.default.sshpsql-dbname' => 'service=projectb',
730 'dgit.default.aptget-components' => 'main',
731 'dgit.default.source-only-uploads' => 'ok',
732 'dgit.dsc-url-proto-ok.http' => 'true',
733 'dgit.dsc-url-proto-ok.https' => 'true',
734 'dgit.dsc-url-proto-ok.git' => 'true',
735 'dgit.vcs-git.suites', => 'sid', # ;-separated
736 'dgit.default.dsc-url-proto-ok' => 'false',
737 # old means "repo server accepts pushes with old dgit tags"
738 # new means "repo server accepts pushes with new dgit tags"
739 # maint means "repo server accepts split brain pushes"
740 # hist means "repo server may have old pushes without new tag"
741 # ("hist" is implied by "old")
742 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
743 'dgit-distro.debian.git-check' => 'url',
744 'dgit-distro.debian.git-check-suffix' => '/info/refs',
745 'dgit-distro.debian.new-private-pushers' => 't',
746 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
747 'dgit-distro.debian/push.git-url' => '',
748 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
749 'dgit-distro.debian/push.git-user-force' => 'dgit',
750 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
751 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
752 'dgit-distro.debian/push.git-create' => 'true',
753 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
754 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
755 # 'dgit-distro.debian.archive-query-tls-key',
756 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
757 # ^ this does not work because curl is broken nowadays
758 # Fixing #790093 properly will involve providing providing the key
759 # in some pacagke and maybe updating these paths.
761 # 'dgit-distro.debian.archive-query-tls-curl-args',
762 # '--ca-path=/etc/ssl/ca-debian',
763 # ^ this is a workaround but works (only) on DSA-administered machines
764 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
765 'dgit-distro.debian.git-url-suffix' => '',
766 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
767 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
768 'dgit-distro.debian-security.archive-query' => 'aptget:',
769 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
770 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
771 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
772 'dgit-distro.debian-security.nominal-distro' => 'debian',
773 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
774 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
775 'dgit-distro.ubuntu.git-check' => 'false',
776 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
777 'dgit-distro.ubuntucloud.git-check' => 'false',
778 'dgit-distro.ubuntucloud.nominal-distro' => 'ubuntu',
779 'dgit-distro.ubuntucloud.archive-query' => 'aptget:',
780 'dgit-distro.ubuntucloud.mirror' => 'http://ubuntu-cloud.archive.canonical.com/ubuntu',
781 'dgit-distro.ubuntucloud.aptget-suite-map' => 's#^([^-]+):([^:]+)$#${1}-updates/$2#; s#^(.+)-(.+):(.+)#$1-$2/$3#;',
782 'dgit-distro.ubuntucloud.aptget-suite-rmap' => 's#/(.+)$#-$1#',
783 'dgit-distro.test-dummy.ssh' => "$td/ssh",
784 'dgit-distro.test-dummy.username' => "alice",
785 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
786 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
787 'dgit-distro.test-dummy.git-url' => "$td/git",
788 'dgit-distro.test-dummy.git-host' => "git",
789 'dgit-distro.test-dummy.git-path' => "$td/git",
790 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
791 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
792 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
793 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
797 our @gitcfgsources = qw(cmdline local global system);
798 our $invoked_in_git_tree = 1;
800 sub git_slurp_config () {
801 # This algoritm is a bit subtle, but this is needed so that for
802 # options which we want to be single-valued, we allow the
803 # different config sources to override properly. See #835858.
804 foreach my $src (@gitcfgsources) {
805 next if $src eq 'cmdline';
806 # we do this ourselves since git doesn't handle it
808 $gitcfgs{$src} = git_slurp_config_src $src;
812 sub git_get_config ($) {
814 foreach my $src (@gitcfgsources) {
815 my $l = $gitcfgs{$src}{$c};
816 confess "internal error ($l $c)" if $l && !ref $l;
817 printdebug"C $c ".(defined $l ?
818 join " ", map { messagequote "'$_'" } @$l :
823 f_ "multiple values for %s (in %s git config)", $c, $src
825 $l->[0] =~ m/\n/ and badcfg f_
826 "value for config option %s (in %s git config) contains newline(s)!",
835 return undef if $c =~ /RETURN-UNDEF/;
836 printdebug "C? $c\n" if $debuglevel >= 5;
837 my $v = git_get_config($c);
838 return $v if defined $v;
839 my $dv = $defcfg{$c};
841 printdebug "CD $c $dv\n" if $debuglevel >= 4;
846 "need value for one of: %s\n".
847 "%s: distro or suite appears not to be (properly) supported",
851 sub not_necessarily_a_tree () {
852 # needs to be called from pre_*
853 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
854 $invoked_in_git_tree = 0;
857 sub access_basedistro__noalias () {
858 if (defined $idistro) {
861 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
862 return $def if defined $def;
863 foreach my $src (@gitcfgsources, 'internal') {
864 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
866 foreach my $k (keys %$kl) {
867 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
869 next unless match_glob $dpat, $isuite;
873 foreach my $csvf (</usr/share/distro-info/*.csv>) {
875 $csvf =~ m{/(\w+)\.csv$} ? $1 : do {
876 printdebug "skipping $csvf\n";
879 my $csv = Text::CSV->new({ binary => 1, auto_diag => 2 }) or die;
880 my $fh = new IO::File $csvf, "<:encoding(utf8)"
881 or die "open $csvf: $!";
882 while (my $cols = $csv->getline($fh)) {
883 next unless $cols->[2] eq $isuite;
886 die "$csvf $!" if $fh->error;
889 return cfg("dgit.default.distro");
893 sub access_basedistro () {
894 my $noalias = access_basedistro__noalias();
895 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
896 return $canon // $noalias;
899 sub access_nomdistro () {
900 my $base = access_basedistro();
901 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
902 $r =~ m/^$distro_re$/ or badcfg
903 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
904 $r, "/^$distro_re$/";
908 sub access_quirk () {
909 # returns (quirk name, distro to use instead or undef, quirk-specific info)
910 my $basedistro = access_basedistro();
911 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
913 if (defined $backports_quirk) {
914 my $re = $backports_quirk;
915 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
917 $re =~ s/\%/([-0-9a-z_]+)/
918 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
919 if ($isuite =~ m/^$re$/) {
920 return ('backports',"$basedistro-backports",$1);
923 return ('none',undef);
928 sub parse_cfg_bool ($$$) {
929 my ($what,$def,$v) = @_;
932 $v =~ m/^[ty1]/ ? 1 :
933 $v =~ m/^[fn0]/ ? 0 :
934 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
938 sub access_forpush_config () {
939 my $d = access_basedistro();
943 parse_cfg_bool('new-private-pushers', 0,
944 cfg("dgit-distro.$d.new-private-pushers",
947 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
950 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
951 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
952 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
954 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
957 sub access_forpush () {
958 $access_forpush //= access_forpush_config();
959 return $access_forpush;
962 sub default_from_access_cfg ($$$;$) {
963 my ($var, $keybase, $defval, $permit_re) = @_;
964 return if defined $$var;
966 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
967 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
969 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
972 badcfg f_ "unknown %s \`%s'", $keybase, $$var
973 if defined $permit_re and $$var !~ m/$permit_re/;
977 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
978 defined $access_forpush and !$access_forpush;
979 badcfg __ "pushing but distro is configured readonly"
980 if access_forpush_config() eq '0';
982 $supplementary_message = __ <<'END' unless $we_are_responder;
983 Push failed, before we got started.
984 You can retry the push, after fixing the problem, if you like.
986 parseopts_late_defaults();
990 parseopts_late_defaults();
993 sub determine_whether_split_brain ($) {
996 local $access_forpush;
997 default_from_access_cfg(\$splitview_mode, 'split-view', 'auto',
998 $splitview_modes_re);
999 $do_split_brain = 1 if $splitview_mode eq 'always';
1002 printdebug "format $format, quilt mode $quilt_mode\n";
1004 if (format_quiltmode_splitting $format) {
1005 $splitview_mode ne 'never' or
1006 fail f_ "dgit: quilt mode \`%s' (for format \`%s')".
1007 " implies split view, but split-view set to \`%s'",
1008 $quilt_mode, $format, $splitview_mode;
1009 $do_split_brain = 1;
1011 $do_split_brain //= 0;
1014 sub supplementary_message ($) {
1016 if (!$we_are_responder) {
1017 $supplementary_message = $msg;
1020 responder_send_command "supplementary-message ".length($msg)
1022 print PO $msg or confess "$!";
1026 sub access_distros () {
1027 # Returns list of distros to try, in order
1030 # 0. `instead of' distro name(s) we have been pointed to
1031 # 1. the access_quirk distro, if any
1032 # 2a. the user's specified distro, or failing that } basedistro
1033 # 2b. the distro calculated from the suite }
1034 my @l = access_basedistro();
1036 my (undef,$quirkdistro) = access_quirk();
1037 unshift @l, $quirkdistro;
1038 unshift @l, $instead_distro;
1039 @l = grep { defined } @l;
1041 push @l, access_nomdistro();
1043 if (access_forpush()) {
1044 @l = map { ("$_/push", $_) } @l;
1049 sub access_cfg_cfgs (@) {
1052 # The nesting of these loops determines the search order. We put
1053 # the key loop on the outside so that we search all the distros
1054 # for each key, before going on to the next key. That means that
1055 # if access_cfg is called with a more specific, and then a less
1056 # specific, key, an earlier distro can override the less specific
1057 # without necessarily overriding any more specific keys. (If the
1058 # distro wants to override the more specific keys it can simply do
1059 # so; whereas if we did the loop the other way around, it would be
1060 # impossible to for an earlier distro to override a less specific
1061 # key but not the more specific ones without restating the unknown
1062 # values of the more specific keys.
1065 # We have to deal with RETURN-UNDEF specially, so that we don't
1066 # terminate the search prematurely.
1068 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1071 foreach my $d (access_distros()) {
1072 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1074 push @cfgs, map { "dgit.default.$_" } @realkeys;
1075 push @cfgs, @rundef;
1079 sub access_cfg (@) {
1081 my (@cfgs) = access_cfg_cfgs(@keys);
1082 my $value = cfg(@cfgs);
1086 sub access_cfg_bool ($$) {
1087 my ($def, @keys) = @_;
1088 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1091 sub string_to_ssh ($) {
1093 if ($spec =~ m/\s/) {
1094 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1100 sub access_cfg_ssh () {
1101 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1102 if (!defined $gitssh) {
1105 return string_to_ssh $gitssh;
1109 sub access_runeinfo ($) {
1111 return ": dgit ".access_basedistro()." $info ;";
1114 sub access_someuserhost ($) {
1116 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1117 defined($user) && length($user) or
1118 $user = access_cfg("$some-user",'username');
1119 my $host = access_cfg("$some-host");
1120 return length($user) ? "$user\@$host" : $host;
1123 sub access_gituserhost () {
1124 return access_someuserhost('git');
1127 sub access_giturl (;$) {
1128 my ($optional) = @_;
1129 my $url = access_cfg('git-url','RETURN-UNDEF');
1132 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1133 return undef unless defined $proto;
1136 access_gituserhost().
1137 access_cfg('git-path');
1139 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1142 return "$url/$package$suffix";
1145 sub commit_getclogp ($) {
1146 # Returns the parsed changelog hashref for a particular commit
1148 our %commit_getclogp_memo;
1149 my $memo = $commit_getclogp_memo{$objid};
1150 return $memo if $memo;
1152 my $mclog = dgit_privdir()."clog";
1153 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1154 "$objid:debian/changelog";
1155 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1158 sub parse_dscdata () {
1159 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1160 printdebug Dumper($dscdata) if $debuglevel>1;
1161 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1162 printdebug Dumper($dsc) if $debuglevel>1;
1167 sub archive_query ($;@) {
1168 my ($method) = shift @_;
1169 fail __ "this operation does not support multiple comma-separated suites"
1171 my $query = access_cfg('archive-query','RETURN-UNDEF');
1172 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1175 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1178 sub archive_query_prepend_mirror {
1179 my $m = access_cfg('mirror');
1180 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1183 sub pool_dsc_subpath ($$) {
1184 my ($vsn,$component) = @_; # $package is implict arg
1185 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1186 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1189 sub cfg_apply_map ($$$) {
1190 my ($varref, $what, $mapspec) = @_;
1191 return unless $mapspec;
1193 printdebug "config $what EVAL{ $mapspec; }\n";
1195 eval "package Dgit::Config; $mapspec;";
1200 sub url_fetch ($;@) {
1201 my ($url, %xopts) = @_;
1202 # Ok404 => 1 means give undef for 404
1203 # AccessBase => 'archive-query' (eg)
1204 # CurlOpts => { key => value }
1206 my $curl = WWW::Curl::Easy->new;
1209 my $x = $curl->setopt($k, $v);
1210 confess "$k $v ".$curl->strerror($x)." ?" if $x;
1213 my $response_body = '';
1214 $setopt->(CURLOPT_FOLLOWLOCATION, 1);
1215 $setopt->(CURLOPT_REDIR_PROTOCOLS, CURLPROTO_HTTPS|CURLPROTO_HTTP);
1216 $setopt->(CURLOPT_URL, $url);
1217 $setopt->(CURLOPT_NOSIGNAL, 1);
1218 $setopt->(CURLOPT_WRITEDATA, \$response_body);
1220 my $xcurlopts = $xopts{CurlOpts} // { };
1222 while (my ($k,$v) = each %$xcurlopts) { $setopt->($k,$v); }
1224 if ($xopts{AccessBase} && $url =~ m#^https://([-.0-9a-z]+)/#) {
1225 foreach my $k ("$xopts{AccessBase}-tls-key",
1226 "$xopts{AccessBase}-tls-curl-ca-args") {
1227 fail "config option $k is obsolete and no longer supported"
1228 if defined access_cfg($k, 'RETURN-UNDEF');
1232 printdebug "query: fetching $url...\n";
1234 local $SIG{PIPE} = 'IGNORE';
1236 my $x = $curl->perform();
1237 fail f_ "fetch of %s failed (%s): %s",
1238 $url, $curl->strerror($x), $curl->errbuf
1241 my $code = $curl->getinfo(CURLINFO_HTTP_CODE);
1242 if ($code eq '404' && $xopts{Ok404}) { return undef; }
1244 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1245 unless $url =~ m#^file://# or $code =~ m/^2/;
1247 confess unless defined $response_body;
1248 return $response_body;
1251 #---------- `ftpmasterapi' archive query method (nascent) ----------
1253 sub api_query_raw ($;$) {
1254 my ($subpath, $ok404) = @_;
1255 my $url = access_cfg('archive-query-url');
1257 return url_fetch $url,
1259 AccessBase => 'archive-query';
1262 sub api_query ($$;$) {
1263 my ($data, $subpath, $ok404) = @_;
1265 badcfg __ "ftpmasterapi archive query method takes no data part"
1267 my $json = api_query_raw $subpath, $ok404;
1268 return undef unless defined $json;
1269 return decode_json($json);
1272 sub canonicalise_suite_ftpmasterapi {
1273 my ($proto,$data) = @_;
1274 my $suites = api_query($data, 'suites');
1276 foreach my $entry (@$suites) {
1278 my $v = $entry->{$_};
1279 defined $v && $v eq $isuite;
1280 } qw(codename name);
1281 push @matched, $entry;
1283 fail f_ "unknown suite %s, maybe -d would help", $isuite
1287 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1288 $cn = "$matched[0]{codename}";
1289 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1290 $cn =~ m/^$suite_re$/
1291 or die f_ "suite %s maps to bad codename\n", $isuite;
1293 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1298 sub archive_query_ftpmasterapi {
1299 my ($proto,$data) = @_;
1300 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1302 my $digester = Digest::SHA->new(256);
1303 foreach my $entry (@$info) {
1305 my $vsn = "$entry->{version}";
1306 my ($ok,$msg) = version_check $vsn;
1307 die f_ "bad version: %s\n", $msg unless $ok;
1308 my $component = "$entry->{component}";
1309 $component =~ m/^$component_re$/ or die __ "bad component";
1310 my $filename = "$entry->{filename}";
1311 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1312 or die __ "bad filename";
1313 my $sha256sum = "$entry->{sha256sum}";
1314 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1315 push @rows, [ $vsn, "/pool/$component/$filename",
1316 $digester, $sha256sum ];
1318 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1321 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1322 return archive_query_prepend_mirror @rows;
1325 sub file_in_archive_ftpmasterapi {
1326 my ($proto,$data,$filename) = @_;
1327 my $pat = $filename;
1330 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1331 my $info = api_query($data, "file_in_archive/$pat", 1);
1334 sub package_not_wholly_new_ftpmasterapi {
1335 my ($proto,$data,$pkg) = @_;
1336 my $info = api_query($data,"madison?package=${pkg}&f=json");
1340 #---------- `aptget' archive query method ----------
1343 our $aptget_releasefile;
1344 our $aptget_configpath;
1346 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1347 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1349 sub aptget_cache_clean {
1350 runcmd_ordryrun_local qw(sh -ec),
1351 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1355 sub aptget_lock_acquire () {
1356 my $lockfile = "$aptget_base/lock";
1357 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1358 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1361 sub aptget_prep ($) {
1363 return if defined $aptget_base;
1365 badcfg __ "aptget archive query method takes no data part"
1368 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1371 ensuredir "$cache/dgit";
1373 access_cfg('aptget-cachekey','RETURN-UNDEF')
1374 // access_nomdistro();
1376 $aptget_base = "$cache/dgit/aptget";
1377 ensuredir $aptget_base;
1379 my $quoted_base = $aptget_base;
1380 confess "$quoted_base contains bad chars, cannot continue"
1381 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1383 ensuredir $aptget_base;
1385 aptget_lock_acquire();
1387 aptget_cache_clean();
1389 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1390 my $sourceslist = "source.list#$cachekey";
1392 my $aptsuites = $isuite;
1393 cfg_apply_map(\$aptsuites, 'suite map',
1394 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1396 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1397 printf SRCS "deb-src %s %s %s\n",
1398 access_cfg('mirror'),
1400 access_cfg('aptget-components')
1403 ensuredir "$aptget_base/cache";
1404 ensuredir "$aptget_base/lists";
1406 open CONF, ">", $aptget_configpath or confess "$!";
1408 Debug::NoLocking "true";
1409 APT::Get::List-Cleanup "false";
1410 #clear APT::Update::Post-Invoke-Success;
1411 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1412 Dir::State::Lists "$quoted_base/lists";
1413 Dir::Etc::preferences "$quoted_base/preferences";
1414 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1415 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1418 foreach my $key (qw(
1421 Dir::Cache::Archives
1422 Dir::Etc::SourceParts
1423 Dir::Etc::preferencesparts
1425 ensuredir "$aptget_base/$key";
1426 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1429 my $oldatime = (time // confess "$!") - 1;
1430 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1431 next unless stat_exists $oldlist;
1432 my ($mtime) = (stat _)[9];
1433 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1436 runcmd_ordryrun_local aptget_aptget(), qw(update);
1439 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1440 next unless stat_exists $oldlist;
1441 my ($atime) = (stat _)[8];
1442 next if $atime == $oldatime;
1443 push @releasefiles, $oldlist;
1445 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1446 @releasefiles = @inreleasefiles if @inreleasefiles;
1447 if (!@releasefiles) {
1448 fail f_ <<END, $isuite, $cache;
1449 apt seemed to not to update dgit's cached Release files for %s.
1451 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1454 confess "apt updated too many Release files (@releasefiles), erk"
1455 unless @releasefiles == 1;
1457 ($aptget_releasefile) = @releasefiles;
1460 sub canonicalise_suite_aptget {
1461 my ($proto,$data) = @_;
1464 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1466 foreach my $name (qw(Codename Suite)) {
1467 my $val = $release->{$name};
1469 printdebug "release file $name: $val\n";
1470 cfg_apply_map(\$val, 'suite rmap',
1471 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1472 $val =~ m/^$suite_re$/o or fail f_
1473 "Release file (%s) specifies intolerable %s",
1474 $aptget_releasefile, $name;
1481 sub archive_query_aptget {
1482 my ($proto,$data) = @_;
1485 ensuredir "$aptget_base/source";
1486 foreach my $old (<$aptget_base/source/*.dsc>) {
1487 unlink $old or die "$old: $!";
1490 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1491 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1492 # avoids apt-get source failing with ambiguous error code
1494 runcmd_ordryrun_local
1495 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1496 aptget_aptget(), qw(--download-only --only-source source), $package;
1498 my @dscs = <$aptget_base/source/*.dsc>;
1499 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1500 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1503 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1506 my $uri = "file://". uri_escape $dscs[0];
1507 $uri =~ s{\%2f}{/}gi;
1508 return [ (getfield $pre_dsc, 'Version'), $uri ];
1511 sub file_in_archive_aptget () { return undef; }
1512 sub package_not_wholly_new_aptget () { return undef; }
1514 #---------- `dummyapicat' archive query method ----------
1515 # (untranslated, because this is for testing purposes etc.)
1517 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1518 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1520 sub dummycatapi_run_in_mirror ($@) {
1521 # runs $fn with FIA open onto rune
1522 my ($rune, $argl, $fn) = @_;
1524 my $mirror = access_cfg('mirror');
1525 $mirror =~ s#^file://#/# or die "$mirror ?";
1526 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1527 qw(x), $mirror, @$argl);
1528 debugcmd "-|", @cmd;
1529 open FIA, "-|", @cmd or confess "$!";
1531 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1535 sub file_in_archive_dummycatapi ($$$) {
1536 my ($proto,$data,$filename) = @_;
1538 dummycatapi_run_in_mirror '
1539 find -name "$1" -print0 |
1541 ', [$filename], sub {
1544 printdebug "| $_\n";
1545 m/^(\w+) (\S+)$/ or die "$_ ?";
1546 push @out, { sha256sum => $1, filename => $2 };
1552 sub package_not_wholly_new_dummycatapi {
1553 my ($proto,$data,$pkg) = @_;
1554 dummycatapi_run_in_mirror "
1555 find -name ${pkg}_*.dsc
1562 #---------- `madison' archive query method ----------
1564 sub archive_query_madison {
1565 return archive_query_prepend_mirror
1566 map { [ @$_[0..1] ] } madison_get_parse(@_);
1569 sub madison_get_parse {
1570 my ($proto,$data) = @_;
1571 die unless $proto eq 'madison';
1572 if (!length $data) {
1573 $data= access_cfg('madison-distro','RETURN-UNDEF');
1574 $data //= access_basedistro();
1576 $rmad{$proto,$data,$package} ||= cmdoutput
1577 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1578 my $rmad = $rmad{$proto,$data,$package};
1581 foreach my $l (split /\n/, $rmad) {
1582 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1583 \s*( [^ \t|]+ )\s* \|
1584 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1585 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1586 $1 eq $package or die "$rmad $package ?";
1593 $component = access_cfg('archive-query-default-component');
1595 $5 eq 'source' or die "$rmad ?";
1596 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1598 return sort { -version_compare($a->[0],$b->[0]); } @out;
1601 sub canonicalise_suite_madison {
1602 # madison canonicalises for us
1603 my @r = madison_get_parse(@_);
1605 "unable to canonicalise suite using package %s".
1606 " which does not appear to exist in suite %s;".
1607 " --existing-package may help",
1612 sub file_in_archive_madison { return undef; }
1613 sub package_not_wholly_new_madison { return undef; }
1615 #---------- `sshpsql' archive query method ----------
1616 # (untranslated, because this is obsolete)
1619 my ($data,$runeinfo,$sql) = @_;
1620 if (!length $data) {
1621 $data= access_someuserhost('sshpsql').':'.
1622 access_cfg('sshpsql-dbname');
1624 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1625 my ($userhost,$dbname) = ($`,$'); #';
1627 my @cmd = (access_cfg_ssh, $userhost,
1628 access_runeinfo("ssh-psql $runeinfo").
1629 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1630 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1632 open P, "-|", @cmd or confess "$!";
1635 printdebug(">|$_|\n");
1638 $!=0; $?=0; close P or failedcmd @cmd;
1640 my $nrows = pop @rows;
1641 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1642 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1643 @rows = map { [ split /\|/, $_ ] } @rows;
1644 my $ncols = scalar @{ shift @rows };
1645 die if grep { scalar @$_ != $ncols } @rows;
1649 sub sql_injection_check {
1650 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1653 sub archive_query_sshpsql ($$) {
1654 my ($proto,$data) = @_;
1655 sql_injection_check $isuite, $package;
1656 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1657 SELECT source.version, component.name, files.filename, files.sha256sum
1659 JOIN src_associations ON source.id = src_associations.source
1660 JOIN suite ON suite.id = src_associations.suite
1661 JOIN dsc_files ON dsc_files.source = source.id
1662 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1663 JOIN component ON component.id = files_archive_map.component_id
1664 JOIN files ON files.id = dsc_files.file
1665 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1666 AND source.source='$package'
1667 AND files.filename LIKE '%.dsc';
1669 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1670 my $digester = Digest::SHA->new(256);
1672 my ($vsn,$component,$filename,$sha256sum) = @$_;
1673 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1675 return archive_query_prepend_mirror @rows;
1678 sub canonicalise_suite_sshpsql ($$) {
1679 my ($proto,$data) = @_;
1680 sql_injection_check $isuite;
1681 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1682 SELECT suite.codename
1683 FROM suite where suite_name='$isuite' or codename='$isuite';
1685 @rows = map { $_->[0] } @rows;
1686 fail "unknown suite $isuite" unless @rows;
1687 die "ambiguous $isuite: @rows ?" if @rows>1;
1691 sub file_in_archive_sshpsql ($$$) { return undef; }
1692 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1694 #---------- `dummycat' archive query method ----------
1695 # (untranslated, because this is for testing purposes etc.)
1697 sub canonicalise_suite_dummycat ($$) {
1698 my ($proto,$data) = @_;
1699 my $dpath = "$data/suite.$isuite";
1700 if (!open C, "<", $dpath) {
1701 $!==ENOENT or die "$dpath: $!";
1702 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1706 chomp or die "$dpath: $!";
1708 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1712 sub archive_query_dummycat ($$) {
1713 my ($proto,$data) = @_;
1714 canonicalise_suite();
1715 my $dpath = "$data/package.$csuite.$package";
1716 if (!open C, "<", $dpath) {
1717 $!==ENOENT or die "$dpath: $!";
1718 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1726 printdebug "dummycat query $csuite $package $dpath | $_\n";
1727 my @row = split /\s+/, $_;
1728 @row==2 or die "$dpath: $_ ?";
1731 C->error and die "$dpath: $!";
1733 return archive_query_prepend_mirror
1734 sort { -version_compare($a->[0],$b->[0]); } @rows;
1737 sub file_in_archive_dummycat () { return undef; }
1738 sub package_not_wholly_new_dummycat () { return undef; }
1740 #---------- archive query entrypoints and rest of program ----------
1742 sub canonicalise_suite () {
1743 return if defined $csuite;
1744 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1745 $csuite = archive_query('canonicalise_suite');
1746 if ($isuite ne $csuite) {
1747 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1749 progress f_ "canonical suite name is %s", $csuite;
1753 sub get_archive_dsc () {
1754 canonicalise_suite();
1755 my @vsns = archive_query('archive_query');
1756 foreach my $vinfo (@vsns) {
1757 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1758 $dscurl = $vsn_dscurl;
1759 $dscdata = url_fetch($dscurl, Ok404 => 1 );
1761 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1766 $digester->add($dscdata);
1767 my $got = $digester->hexdigest();
1769 fail f_ "%s has hash %s but archive told us to expect %s",
1770 $dscurl, $got, $digest;
1773 my $fmt = getfield $dsc, 'Format';
1774 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1775 f_ "unsupported source format %s, sorry", $fmt;
1777 $dsc_checked = !!$digester;
1778 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1782 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1785 sub check_for_git ();
1786 sub check_for_git () {
1788 my $how = access_cfg('git-check');
1789 if ($how eq 'ssh-cmd') {
1791 (access_cfg_ssh, access_gituserhost(),
1792 access_runeinfo("git-check $package").
1793 " set -e; cd ".access_cfg('git-path').";".
1794 " if test -d $package.git; then echo 1; else echo 0; fi");
1795 my $r= cmdoutput @cmd;
1796 if (defined $r and $r =~ m/^divert (\w+)$/) {
1798 my ($usedistro,) = access_distros();
1799 # NB that if we are pushing, $usedistro will be $distro/push
1800 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1801 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1802 progress f_ "diverting to %s (using config for %s)",
1803 $divert, $instead_distro;
1804 return check_for_git();
1806 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1808 } elsif ($how eq 'url') {
1809 my $prefix = access_cfg('git-check-url','git-url');
1810 my $suffix = access_cfg('git-check-suffix','git-suffix',
1811 'RETURN-UNDEF') // '.git';
1812 my $url = "$prefix/$package$suffix";
1813 my $result = url_fetch $url,
1814 CurlOpts => { CURLOPT_NOBODY() => 1 },
1816 AccessBase => 'git-check';
1817 $result = defined $result;
1818 printdebug "dgit-repos check_for_git => $result.\n";
1820 } elsif ($how eq 'true') {
1822 } elsif ($how eq 'false') {
1825 badcfg f_ "unknown git-check \`%s'", $how;
1829 sub create_remote_git_repo () {
1830 my $how = access_cfg('git-create');
1831 if ($how eq 'ssh-cmd') {
1833 (access_cfg_ssh, access_gituserhost(),
1834 access_runeinfo("git-create $package").
1835 "set -e; cd ".access_cfg('git-path').";".
1836 " cp -a _template $package.git");
1837 } elsif ($how eq 'true') {
1840 badcfg f_ "unknown git-create \`%s'", $how;
1844 our ($dsc_hash,$lastpush_mergeinput);
1845 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1849 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1850 $playground = fresh_playground 'dgit/unpack';
1853 sub mktree_in_ud_here () {
1857 sub git_write_tree () {
1858 my $tree = cmdoutput @git, qw(write-tree);
1859 $tree =~ m/^\w+$/ or die "$tree ?";
1863 sub git_add_write_tree () {
1864 runcmd @git, qw(add -Af .);
1865 return git_write_tree();
1868 sub remove_stray_gits ($) {
1870 my @gitscmd = qw(find -name .git -prune -print0);
1871 debugcmd "|",@gitscmd;
1872 open GITS, "-|", @gitscmd or confess "$!";
1877 print STDERR f_ "%s: warning: removing from %s: %s\n",
1878 $us, $what, (messagequote $_);
1882 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1885 sub mktree_in_ud_from_only_subdir ($;$) {
1886 my ($what,$raw) = @_;
1887 # changes into the subdir
1890 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1891 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1895 remove_stray_gits($what);
1896 mktree_in_ud_here();
1898 my ($format, $fopts) = get_source_format();
1899 if (madformat($format)) {
1904 my $tree=git_add_write_tree();
1905 return ($tree,$dir);
1908 our @files_csum_info_fields =
1909 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1910 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1911 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1913 sub dsc_files_info () {
1914 foreach my $csumi (@files_csum_info_fields) {
1915 my ($fname, $module, $method) = @$csumi;
1916 my $field = $dsc->{$fname};
1917 next unless defined $field;
1918 eval "use $module; 1;" or die $@;
1920 foreach (split /\n/, $field) {
1922 m/^(\w+) (\d+) (\S+)$/ or
1923 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1924 my $digester = eval "$module"."->$method;" or die $@;
1929 Digester => $digester,
1934 fail f_ "missing any supported Checksums-* or Files field in %s",
1935 $dsc->get_option('name');
1939 map { $_->{Filename} } dsc_files_info();
1942 sub files_compare_inputs (@) {
1947 my $showinputs = sub {
1948 return join "; ", map { $_->get_option('name') } @$inputs;
1951 foreach my $in (@$inputs) {
1953 my $in_name = $in->get_option('name');
1955 printdebug "files_compare_inputs $in_name\n";
1957 foreach my $csumi (@files_csum_info_fields) {
1958 my ($fname) = @$csumi;
1959 printdebug "files_compare_inputs $in_name $fname\n";
1961 my $field = $in->{$fname};
1962 next unless defined $field;
1965 foreach (split /\n/, $field) {
1968 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1969 fail "could not parse $in_name $fname line \`$_'";
1971 printdebug "files_compare_inputs $in_name $fname $f\n";
1975 my $re = \ $record{$f}{$fname};
1977 $fchecked{$f}{$in_name} = 1;
1980 "hash or size of %s varies in %s fields (between: %s)",
1981 $f, $fname, $showinputs->();
1986 @files = sort @files;
1987 $expected_files //= \@files;
1988 "@$expected_files" eq "@files" or
1989 fail f_ "file list in %s varies between hash fields!",
1993 fail f_ "%s has no files list field(s)", $in_name;
1995 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1998 grep { keys %$_ == @$inputs-1 } values %fchecked
1999 or fail f_ "no file appears in all file lists (looked in: %s)",
2003 sub is_orig_file_in_dsc ($$) {
2004 my ($f, $dsc_files_info) = @_;
2005 return 0 if @$dsc_files_info <= 1;
2006 # One file means no origs, and the filename doesn't have a "what
2007 # part of dsc" component. (Consider versions ending `.orig'.)
2008 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
2012 # This function determines whether a .changes file is source-only from
2013 # the point of view of dak. Thus, it permits *_source.buildinfo
2016 # It does not, however, permit any other buildinfo files. After a
2017 # source-only upload, the buildds will try to upload files like
2018 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
2019 # named like this in their (otherwise) source-only upload, the uploads
2020 # of the buildd can be rejected by dak. Fixing the resultant
2021 # situation can require manual intervention. So we block such
2022 # .buildinfo files when the user tells us to perform a source-only
2023 # upload (such as when using the push-source subcommand with the -C
2024 # option, which calls this function).
2026 # Note, though, that when dgit is told to prepare a source-only
2027 # upload, such as when subcommands like build-source and push-source
2028 # without -C are used, dgit has a more restrictive notion of
2029 # source-only .changes than dak: such uploads will never include
2030 # *_source.buildinfo files. This is because there is no use for such
2031 # files when using a tool like dgit to produce the source package, as
2032 # dgit ensures the source is identical to git HEAD.
2033 sub test_source_only_changes ($) {
2035 foreach my $l (split /\n/, getfield $changes, 'Files') {
2036 $l =~ m/\S+$/ or next;
2037 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2038 unless ($& =~ m/(?:\.dsc|\.diff\.gz|$tarball_f_ext_re|_source\.buildinfo)$/) {
2039 print f_ "purportedly source-only changes polluted by %s\n", $&;
2046 sub changes_update_origs_from_dsc ($$$$) {
2047 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2049 printdebug "checking origs needed ($upstreamvsn)...\n";
2050 $_ = getfield $changes, 'Files';
2051 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2052 fail __ "cannot find section/priority from .changes Files field";
2053 my $placementinfo = $1;
2055 printdebug "checking origs needed placement '$placementinfo'...\n";
2056 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2057 $l =~ m/\S+$/ or next;
2059 printdebug "origs $file | $l\n";
2060 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2061 printdebug "origs $file is_orig\n";
2062 my $have = archive_query('file_in_archive', $file);
2063 if (!defined $have) {
2064 print STDERR __ <<END;
2065 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2071 printdebug "origs $file \$#\$have=$#$have\n";
2072 foreach my $h (@$have) {
2075 foreach my $csumi (@files_csum_info_fields) {
2076 my ($fname, $module, $method, $archivefield) = @$csumi;
2077 next unless defined $h->{$archivefield};
2078 $_ = $dsc->{$fname};
2079 next unless defined;
2080 m/^(\w+) .* \Q$file\E$/m or
2081 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2082 if ($h->{$archivefield} eq $1) {
2086 "%s: %s (archive) != %s (local .dsc)",
2087 $archivefield, $h->{$archivefield}, $1;
2090 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2094 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2097 printdebug "origs $file f.same=$found_same".
2098 " #f._differ=$#found_differ\n";
2099 if (@found_differ && !$found_same) {
2101 (f_ "archive contains %s with different checksum", $file),
2104 # Now we edit the changes file to add or remove it
2105 foreach my $csumi (@files_csum_info_fields) {
2106 my ($fname, $module, $method, $archivefield) = @$csumi;
2107 next unless defined $changes->{$fname};
2109 # in archive, delete from .changes if it's there
2110 $changed{$file} = "removed" if
2111 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2112 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2113 # not in archive, but it's here in the .changes
2115 my $dsc_data = getfield $dsc, $fname;
2116 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2118 $extra =~ s/ \d+ /$&$placementinfo /
2119 or confess "$fname $extra >$dsc_data< ?"
2120 if $fname eq 'Files';
2121 $changes->{$fname} .= "\n". $extra;
2122 $changed{$file} = "added";
2127 foreach my $file (keys %changed) {
2129 "edited .changes for archive .orig contents: %s %s",
2130 $changed{$file}, $file;
2132 my $chtmp = "$changesfile.tmp";
2133 $changes->save($chtmp);
2135 rename $chtmp,$changesfile or die "$changesfile $!";
2137 progress f_ "[new .changes left in %s]", $changesfile;
2140 progress f_ "%s already has appropriate .orig(s) (if any)",
2145 sub clogp_authline ($) {
2147 my $author = getfield $clogp, 'Maintainer';
2148 if ($author =~ m/^[^"\@]+\,/) {
2149 # single entry Maintainer field with unquoted comma
2150 $author = ($& =~ y/,//rd).$'; # strip the comma
2152 # git wants a single author; any remaining commas in $author
2153 # are by now preceded by @ (or "). It seems safer to punt on
2154 # "..." for now rather than attempting to dequote or something.
2155 $author =~ s#,.*##ms unless $author =~ m/"/;
2156 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2157 my $authline = "$author $date";
2158 $authline =~ m/$git_authline_re/o or
2159 fail f_ "unexpected commit author line format \`%s'".
2160 " (was generated from changelog Maintainer field)",
2162 return ($1,$2,$3) if wantarray;
2166 sub vendor_patches_distro ($$) {
2167 my ($checkdistro, $what) = @_;
2168 return unless defined $checkdistro;
2170 my $series = "debian/patches/\L$checkdistro\E.series";
2171 printdebug "checking for vendor-specific $series ($what)\n";
2173 if (!open SERIES, "<", $series) {
2174 confess "$series $!" unless $!==ENOENT;
2181 print STDERR __ <<END;
2183 Unfortunately, this source package uses a feature of dpkg-source where
2184 the same source package unpacks to different source code on different
2185 distros. dgit cannot safely operate on such packages on affected
2186 distros, because the meaning of source packages is not stable.
2188 Please ask the distro/maintainer to remove the distro-specific series
2189 files and use a different technique (if necessary, uploading actually
2190 different packages, if different distros are supposed to have
2194 fail f_ "Found active distro-specific series file for".
2195 " %s (%s): %s, cannot continue",
2196 $checkdistro, $what, $series;
2198 die "$series $!" if SERIES->error;
2202 sub check_for_vendor_patches () {
2203 # This dpkg-source feature doesn't seem to be documented anywhere!
2204 # But it can be found in the changelog (reformatted):
2206 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2207 # Author: Raphael Hertzog <hertzog@debian.org>
2208 # Date: Sun Oct 3 09:36:48 2010 +0200
2210 # dpkg-source: correctly create .pc/.quilt_series with alternate
2213 # If you have debian/patches/ubuntu.series and you were
2214 # unpacking the source package on ubuntu, quilt was still
2215 # directed to debian/patches/series instead of
2216 # debian/patches/ubuntu.series.
2218 # debian/changelog | 3 +++
2219 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2220 # 2 files changed, 6 insertions(+), 1 deletion(-)
2223 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2224 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2225 __ "Dpkg::Vendor \`current vendor'");
2226 vendor_patches_distro(access_basedistro(),
2227 __ "(base) distro being accessed");
2228 vendor_patches_distro(access_nomdistro(),
2229 __ "(nominal) distro being accessed");
2232 sub check_bpd_exists () {
2233 stat $buildproductsdir
2234 or fail f_ "build-products-dir %s is not accessible: %s\n",
2235 $buildproductsdir, $!;
2238 sub dotdot_bpd_transfer_origs ($$$) {
2239 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2240 # checks is_orig_file_of_vsn and if
2241 # calls $wanted->{$leaf} and expects boolish
2243 return if $buildproductsdir eq '..';
2246 my $dotdot = $maindir;
2247 $dotdot =~ s{/[^/]+$}{};
2248 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2249 while ($!=0, defined(my $leaf = readdir DD)) {
2251 local ($debuglevel) = $debuglevel-1;
2252 printdebug "DD_BPD $leaf ?\n";
2254 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2255 next unless $wanted->($leaf);
2256 next if lstat "$bpd_abs/$leaf";
2259 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2262 $! == &ENOENT or fail f_
2263 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2264 lstat "$dotdot/$leaf" or fail f_
2265 "check orig file %s in ..: %s", $leaf, $!;
2267 stat "$dotdot/$leaf" or fail f_
2268 "check target of orig symlink %s in ..: %s", $leaf, $!;
2269 my $ltarget = readlink "$dotdot/$leaf" or
2270 die "readlink $dotdot/$leaf: $!";
2271 if ($ltarget !~ m{^/}) {
2272 $ltarget = "$dotdot/$ltarget";
2274 symlink $ltarget, "$bpd_abs/$leaf"
2275 or die "$ltarget $bpd_abs $leaf: $!";
2277 "%s: cloned orig symlink from ..: %s\n",
2279 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2281 "%s: hardlinked orig from ..: %s\n",
2283 } elsif ($! != EXDEV) {
2284 fail f_ "failed to make %s a hardlink to %s: %s",
2285 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2287 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2288 or die "$bpd_abs $dotdot $leaf $!";
2290 "%s: symmlinked orig from .. on other filesystem: %s\n",
2294 die "$dotdot; $!" if $!;
2298 sub import_tarball_tartrees ($$) {
2299 my ($upstreamv, $dfi) = @_;
2300 # cwd should be the playground
2302 # We unpack and record the orig tarballs first, so that we only
2303 # need disk space for one private copy of the unpacked source.
2304 # But we can't make them into commits until we have the metadata
2305 # from the debian/changelog, so we record the tree objects now and
2306 # make them into commits later.
2308 my $orig_f_base = srcfn $upstreamv, '';
2310 foreach my $fi (@$dfi) {
2311 # We actually import, and record as a commit, every tarball
2312 # (unless there is only one file, in which case there seems
2315 my $f = $fi->{Filename};
2316 printdebug "import considering $f ";
2317 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2318 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2322 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2324 printdebug "Y ", (join ' ', map { $_//"(none)" }
2325 $compr_ext, $orig_f_part
2328 my $path = $fi->{Path} // $f;
2329 my $input = new IO::File $f, '<' or die "$f $!";
2333 if (defined $compr_ext) {
2335 Dpkg::Compression::compression_guess_from_filename $f;
2336 fail "Dpkg::Compression cannot handle file $f in source package"
2337 if defined $compr_ext && !defined $cname;
2339 new Dpkg::Compression::Process compression => $cname;
2340 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2341 my $compr_fh = new IO::Handle;
2342 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2344 open STDIN, "<&", $input or confess "$!";
2346 die "dgit (child): exec $compr_cmd[0]: $!\n";
2351 rmtree "_unpack-tar";
2352 mkdir "_unpack-tar" or confess "$!";
2353 my @tarcmd = qw(tar -x -f -
2354 --no-same-owner --no-same-permissions
2355 --no-acls --no-xattrs --no-selinux);
2356 my $tar_pid = fork // confess "$!";
2358 chdir "_unpack-tar" or confess "$!";
2359 open STDIN, "<&", $input or confess "$!";
2361 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2363 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2364 !$? or failedcmd @tarcmd;
2367 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2369 # finally, we have the results in "tarball", but maybe
2370 # with the wrong permissions
2372 runcmd qw(chmod -R +rwX _unpack-tar);
2373 changedir "_unpack-tar";
2374 remove_stray_gits($f);
2375 mktree_in_ud_here();
2377 my ($tree) = git_add_write_tree();
2378 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2379 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2381 printdebug "one subtree $1\n";
2383 printdebug "multiple subtrees\n";
2386 rmtree "_unpack-tar";
2388 my $ent = [ $f, $tree ];
2390 Orig => !!$orig_f_part,
2391 Sort => (!$orig_f_part ? 2 :
2392 $orig_f_part =~ m/-/g ? 1 :
2394 OrigPart => $orig_f_part, # 'orig', 'orig-XXX', or undef
2401 # put any without "_" first (spec is not clear whether files
2402 # are always in the usual order). Tarballs without "_" are
2403 # the main orig or the debian tarball.
2404 $a->{Sort} <=> $b->{Sort} or
2411 sub import_tarball_commits ($$) {
2412 my ($tartrees, $upstreamv) = @_;
2413 # cwd should be a playtree which has a relevant debian/changelog
2414 # fills in $tt->{Commit} for each one
2416 my $any_orig = grep { $_->{Orig} } @$tartrees;
2418 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2422 printdebug "import clog search...\n";
2423 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2424 my ($thisstanza, $desc) = @_;
2425 no warnings qw(exiting);
2427 $clogp //= $thisstanza;
2429 printdebug "import clog $thisstanza->{version} $desc...\n";
2431 last if !$any_orig; # we don't need $r1clogp
2433 # We look for the first (most recent) changelog entry whose
2434 # version number is lower than the upstream version of this
2435 # package. Then the last (least recent) previous changelog
2436 # entry is treated as the one which introduced this upstream
2437 # version and used for the synthetic commits for the upstream
2440 # One might think that a more sophisticated algorithm would be
2441 # necessary. But: we do not want to scan the whole changelog
2442 # file. Stopping when we see an earlier version, which
2443 # necessarily then is an earlier upstream version, is the only
2444 # realistic way to do that. Then, either the earliest
2445 # changelog entry we have seen so far is indeed the earliest
2446 # upload of this upstream version; or there are only changelog
2447 # entries relating to later upstream versions (which is not
2448 # possible unless the changelog and .dsc disagree about the
2449 # version). Then it remains to choose between the physically
2450 # last entry in the file, and the one with the lowest version
2451 # number. If these are not the same, we guess that the
2452 # versions were created in a non-monotonic order rather than
2453 # that the changelog entries have been misordered.
2455 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2457 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2458 $r1clogp = $thisstanza;
2460 printdebug "import clog $r1clogp->{version} becomes r1\n";
2463 $clogp or fail __ "package changelog has no entries!";
2465 my $authline = clogp_authline $clogp;
2466 my $changes = getfield $clogp, 'Changes';
2467 $changes =~ s/^\n//; # Changes: \n
2468 my $cversion = getfield $clogp, 'Version';
2472 $r1clogp //= $clogp; # maybe there's only one entry;
2473 $r1authline = clogp_authline $r1clogp;
2474 # Strictly, r1authline might now be wrong if it's going to be
2475 # unused because !$any_orig. Whatever.
2477 printdebug "import tartrees authline $authline\n";
2478 printdebug "import tartrees r1authline $r1authline\n";
2480 foreach my $tt (@$tartrees) {
2481 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2483 # untranslated so that different people's imports are identical
2484 my $mbody = sprintf "Import %s", $tt->{F};
2485 $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2488 committer $r1authline
2492 [dgit import orig $tt->{F}]
2500 [dgit import tarball $package $cversion $tt->{F}]
2505 return ($authline, $r1authline, $clogp, $changes);
2508 sub generate_commits_from_dsc () {
2509 # See big comment in fetch_from_archive, below.
2510 # See also README.dsc-import.
2512 changedir $playground;
2514 my $bpd_abs = bpd_abs();
2515 my $upstreamv = upstreamversion $dsc->{version};
2516 my @dfi = dsc_files_info();
2518 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2519 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2521 foreach my $fi (@dfi) {
2522 my $f = $fi->{Filename};
2523 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2524 my $upper_f = "$bpd_abs/$f";
2526 printdebug "considering reusing $f: ";
2528 if (link_ltarget "$upper_f,fetch", $f) {
2529 printdebug "linked (using ...,fetch).\n";
2530 } elsif ((printdebug "($!) "),
2532 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2533 } elsif (link_ltarget $upper_f, $f) {
2534 printdebug "linked.\n";
2535 } elsif ((printdebug "($!) "),
2537 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2539 printdebug "absent.\n";
2543 complete_file_from_dsc('.', $fi, \$refetched)
2546 printdebug "considering saving $f: ";
2548 if (rename_link_xf 1, $f, $upper_f) {
2549 printdebug "linked.\n";
2550 } elsif ((printdebug "($@) "),
2552 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2553 } elsif (!$refetched) {
2554 printdebug "no need.\n";
2555 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2556 printdebug "linked (using ...,fetch).\n";
2557 } elsif ((printdebug "($@) "),
2559 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2561 printdebug "cannot.\n";
2566 @tartrees = import_tarball_tartrees($upstreamv, \@dfi)
2567 unless @dfi == 1; # only one file in .dsc
2569 my $dscfn = "$package.dsc";
2571 my $treeimporthow = 'package';
2573 open D, ">", $dscfn or die "$dscfn: $!";
2574 print D $dscdata or die "$dscfn: $!";
2575 close D or die "$dscfn: $!";
2576 my @cmd = qw(dpkg-source);
2577 push @cmd, '--no-check' if $dsc_checked;
2578 if (madformat $dsc->{format}) {
2579 push @cmd, '--skip-patches';
2580 $treeimporthow = 'unpatched';
2582 push @cmd, qw(-x --), $dscfn;
2585 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2586 if (madformat $dsc->{format}) {
2587 check_for_vendor_patches();
2591 if (madformat $dsc->{format}) {
2592 my @pcmd = qw(dpkg-source --before-build .);
2593 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2595 $dappliedtree = git_add_write_tree();
2598 my ($authline, $r1authline, $clogp, $changes) =
2599 import_tarball_commits(\@tartrees, $upstreamv);
2601 my $cversion = getfield $clogp, 'Version';
2603 printdebug "import main commit\n";
2605 open C, ">../commit.tmp" or confess "$!";
2606 print C <<END or confess "$!";
2609 print C <<END or confess "$!" foreach @tartrees;
2612 print C <<END or confess "$!";
2618 [dgit import $treeimporthow $package $cversion]
2621 close C or confess "$!";
2622 my $rawimport_hash = hash_commit qw(../commit.tmp);
2624 if (madformat $dsc->{format}) {
2625 printdebug "import apply patches...\n";
2627 # regularise the state of the working tree so that
2628 # the checkout of $rawimport_hash works nicely.
2629 my $dappliedcommit = hash_commit_text(<<END);
2636 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2638 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2640 # We need the answers to be reproducible
2641 my @authline = clogp_authline($clogp);
2642 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2643 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2644 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2645 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2646 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2647 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2649 my $path = $ENV{PATH} or die;
2651 # we use ../../gbp-pq-output, which (given that we are in
2652 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2655 foreach my $use_absurd (qw(0 1)) {
2656 runcmd @git, qw(checkout -q unpa);
2657 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2658 local $ENV{PATH} = $path;
2661 progress "warning: $@";
2662 $path = "$absurdity:$path";
2663 open T, ">../../absurd-apply-warnings" or die $!;
2665 progress f_ "%s: trying slow absurd-git-apply...", $us;
2666 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2671 die "forbid absurd git-apply\n" if $use_absurd
2672 && forceing [qw(import-gitapply-no-absurd)];
2673 die "only absurd git-apply!\n" if !$use_absurd
2674 && forceing [qw(import-gitapply-absurd)];
2676 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2677 local $ENV{PATH} = $path if $use_absurd;
2679 my @showcmd = (gbp_pq, qw(import));
2680 my @realcmd = shell_cmd
2681 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2682 debugcmd "+",@realcmd;
2683 if (system @realcmd) {
2684 die f_ "%s failed: %s\n",
2685 +(shellquote @showcmd),
2686 failedcmd_waitstatus();
2689 my $gapplied = git_rev_parse('HEAD');
2690 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2691 $gappliedtree eq $dappliedtree or
2692 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2693 gbp-pq import and dpkg-source disagree!
2694 gbp-pq import gave commit %s
2695 gbp-pq import gave tree %s
2696 dpkg-source --before-build gave tree %s
2698 $rawimport_hash = $gapplied;
2701 File::Copy::copy("../../absurd-apply-warnings", \*STDERR)
2708 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2713 progress f_ "synthesised git commit from .dsc %s", $cversion;
2715 my $rawimport_mergeinput = {
2716 Commit => $rawimport_hash,
2717 Info => __ "Import of source package",
2719 my @output = ($rawimport_mergeinput);
2721 if ($lastpush_mergeinput) {
2722 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2723 my $oversion = getfield $oldclogp, 'Version';
2725 version_compare($oversion, $cversion);
2727 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2728 { ReverseParents => 1,
2729 # untranslated so that different people's pseudomerges
2730 # are not needlessly different (although they will
2731 # still differ if the series of pulls is different)
2732 Message => (sprintf <<END, $package, $cversion, $csuite) });
2733 Record %s (%s) in archive suite %s
2735 } elsif ($vcmp > 0) {
2736 print STDERR f_ <<END, $cversion, $oversion,
2738 Version actually in archive: %s (older)
2739 Last version pushed with dgit: %s (newer or same)
2742 __ $later_warning_msg or confess "$!";
2743 @output = $lastpush_mergeinput;
2745 # Same version. Use what's in the server git branch,
2746 # discarding our own import. (This could happen if the
2747 # server automatically imports all packages into git.)
2748 @output = $lastpush_mergeinput;
2756 sub complete_file_from_dsc ($$;$) {
2757 our ($dstdir, $fi, $refetched) = @_;
2758 # Ensures that we have, in $dstdir, the file $fi, with the correct
2759 # contents. (Downloading it from alongside $dscurl if necessary.)
2760 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2761 # and will set $$refetched=1 if it did so (or tried to).
2763 my $f = $fi->{Filename};
2764 my $tf = "$dstdir/$f";
2768 my $checkhash = sub {
2769 open F, "<", "$tf" or die "$tf: $!";
2770 $fi->{Digester}->reset();
2771 $fi->{Digester}->addfile(*F);
2772 F->error and confess "$!";
2773 $got = $fi->{Digester}->hexdigest();
2774 return $got eq $fi->{Hash};
2777 if (stat_exists $tf) {
2778 if ($checkhash->()) {
2779 progress f_ "using existing %s", $f;
2783 fail f_ "file %s has hash %s but .dsc demands hash %s".
2784 " (perhaps you should delete this file?)",
2785 $f, $got, $fi->{Hash};
2787 progress f_ "need to fetch correct version of %s", $f;
2788 unlink $tf or die "$tf $!";
2791 printdebug "$tf does not exist, need to fetch\n";
2795 $furl =~ s{/[^/]+$}{};
2797 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2798 die "$f ?" if $f =~ m#/#;
2799 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2800 return 0 if !act_local();
2803 fail f_ "file %s has hash %s but .dsc demands hash %s".
2804 " (got wrong file from archive!)",
2805 $f, $got, $fi->{Hash};
2810 sub ensure_we_have_orig () {
2811 my @dfi = dsc_files_info();
2812 foreach my $fi (@dfi) {
2813 my $f = $fi->{Filename};
2814 next unless is_orig_file_in_dsc($f, \@dfi);
2815 complete_file_from_dsc($buildproductsdir, $fi)
2820 #---------- git fetch ----------
2822 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2823 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2825 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2826 # locally fetched refs because they have unhelpful names and clutter
2827 # up gitk etc. So we track whether we have "used up" head ref (ie,
2828 # whether we have made another local ref which refers to this object).
2830 # (If we deleted them unconditionally, then we might end up
2831 # re-fetching the same git objects each time dgit fetch was run.)
2833 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2834 # in git_fetch_us to fetch the refs in question, and possibly a call
2835 # to lrfetchref_used.
2837 our (%lrfetchrefs_f, %lrfetchrefs_d);
2838 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2840 sub lrfetchref_used ($) {
2841 my ($fullrefname) = @_;
2842 my $objid = $lrfetchrefs_f{$fullrefname};
2843 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2846 sub git_lrfetch_sane {
2847 my ($url, $supplementary, @specs) = @_;
2848 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2849 # at least as regards @specs. Also leave the results in
2850 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2851 # able to clean these up.
2853 # With $supplementary==1, @specs must not contain wildcards
2854 # and we add to our previous fetches (non-atomically).
2856 # This is rather miserable:
2857 # When git fetch --prune is passed a fetchspec ending with a *,
2858 # it does a plausible thing. If there is no * then:
2859 # - it matches subpaths too, even if the supplied refspec
2860 # starts refs, and behaves completely madly if the source
2861 # has refs/refs/something. (See, for example, Debian #NNNN.)
2862 # - if there is no matching remote ref, it bombs out the whole
2864 # We want to fetch a fixed ref, and we don't know in advance
2865 # if it exists, so this is not suitable.
2867 # Our workaround is to use git ls-remote. git ls-remote has its
2868 # own qairks. Notably, it has the absurd multi-tail-matching
2869 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2870 # refs/refs/foo etc.
2872 # Also, we want an idempotent snapshot, but we have to make two
2873 # calls to the remote: one to git ls-remote and to git fetch. The
2874 # solution is use git ls-remote to obtain a target state, and
2875 # git fetch to try to generate it. If we don't manage to generate
2876 # the target state, we try again.
2878 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2880 my $specre = join '|', map {
2883 my $wildcard = $x =~ s/\\\*$/.*/;
2884 die if $wildcard && $supplementary;
2887 printdebug "git_lrfetch_sane specre=$specre\n";
2888 my $wanted_rref = sub {
2890 return m/^(?:$specre)$/;
2893 my $fetch_iteration = 0;
2896 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2897 if (++$fetch_iteration > 10) {
2898 fail __ "too many iterations trying to get sane fetch!";
2901 my @look = map { "refs/$_" } @specs;
2902 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2906 open GITLS, "-|", @lcmd or confess "$!";
2908 printdebug "=> ", $_;
2909 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2910 my ($objid,$rrefname) = ($1,$2);
2911 if (!$wanted_rref->($rrefname)) {
2912 print STDERR f_ <<END, "@look", $rrefname;
2913 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2917 $wantr{$rrefname} = $objid;
2920 close GITLS or failedcmd @lcmd;
2922 # OK, now %want is exactly what we want for refs in @specs
2924 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2925 "+refs/$_:".lrfetchrefs."/$_";
2928 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2930 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2931 runcmd_ordryrun_local @fcmd if @fspecs;
2933 if (!$supplementary) {
2934 %lrfetchrefs_f = ();
2938 git_for_each_ref(lrfetchrefs, sub {
2939 my ($objid,$objtype,$lrefname,$reftail) = @_;
2940 $lrfetchrefs_f{$lrefname} = $objid;
2941 $objgot{$objid} = 1;
2944 if ($supplementary) {
2948 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2949 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2950 if (!exists $wantr{$rrefname}) {
2951 if ($wanted_rref->($rrefname)) {
2953 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2956 print STDERR f_ <<END, "@fspecs", $lrefname
2957 warning: git fetch %s created %s; this is silly, deleting it.
2960 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2961 delete $lrfetchrefs_f{$lrefname};
2965 foreach my $rrefname (sort keys %wantr) {
2966 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2967 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2968 my $want = $wantr{$rrefname};
2969 next if $got eq $want;
2970 if (!defined $objgot{$want}) {
2971 fail __ <<END unless act_local();
2972 --dry-run specified but we actually wanted the results of git fetch,
2973 so this is not going to work. Try running dgit fetch first,
2974 or using --damp-run instead of --dry-run.
2976 print STDERR f_ <<END, $lrefname, $want;
2977 warning: git ls-remote suggests we want %s
2978 warning: and it should refer to %s
2979 warning: but git fetch didn't fetch that object to any relevant ref.
2980 warning: This may be due to a race with someone updating the server.
2981 warning: Will try again...
2983 next FETCH_ITERATION;
2986 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2988 runcmd_ordryrun_local @git, qw(update-ref -m),
2989 "dgit fetch git fetch fixup", $lrefname, $want;
2990 $lrfetchrefs_f{$lrefname} = $want;
2995 if (defined $csuite) {
2996 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2997 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2998 my ($objid,$objtype,$lrefname,$reftail) = @_;
2999 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
3000 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
3004 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
3005 Dumper(\%lrfetchrefs_f);
3008 sub git_fetch_us () {
3009 # Want to fetch only what we are going to use, unless
3010 # deliberately-not-ff, in which case we must fetch everything.
3012 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
3013 map { "tags/$_" } debiantags('*',access_nomdistro);
3014 push @specs, server_branch($csuite);
3015 push @specs, $rewritemap;
3016 push @specs, qw(heads/*) if deliberately_not_fast_forward;
3018 my $url = access_giturl();
3019 git_lrfetch_sane $url, 0, @specs;
3022 my @tagpats = debiantags('*',access_nomdistro);
3024 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
3025 my ($objid,$objtype,$fullrefname,$reftail) = @_;
3026 printdebug "currently $fullrefname=$objid\n";
3027 $here{$fullrefname} = $objid;
3029 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
3030 my ($objid,$objtype,$fullrefname,$reftail) = @_;
3031 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
3032 printdebug "offered $lref=$objid\n";
3033 if (!defined $here{$lref}) {
3034 my @upd = (@git, qw(update-ref), $lref, $objid, '');
3035 runcmd_ordryrun_local @upd;
3036 lrfetchref_used $fullrefname;
3037 } elsif ($here{$lref} eq $objid) {
3038 lrfetchref_used $fullrefname;
3040 print STDERR f_ "Not updating %s from %s to %s.\n",
3041 $lref, $here{$lref}, $objid;
3046 #---------- dsc and archive handling ----------
3048 sub mergeinfo_getclogp ($) {
3049 # Ensures thit $mi->{Clogp} exists and returns it
3051 $mi->{Clogp} = commit_getclogp($mi->{Commit});
3054 sub mergeinfo_version ($) {
3055 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
3058 sub fetch_from_archive_record_1 ($) {
3060 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
3061 cmdoutput @git, qw(log -n2), $hash;
3062 # ... gives git a chance to complain if our commit is malformed
3065 sub fetch_from_archive_record_2 ($) {
3067 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3071 dryrun_report @upd_cmd;
3075 sub parse_dsc_field_def_dsc_distro () {
3076 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3077 dgit.default.distro);
3080 sub parse_dsc_field ($$) {
3081 my ($dsc, $what) = @_;
3083 foreach my $field (@ourdscfield) {
3084 $f = $dsc->{$field};
3089 progress f_ "%s: NO git hash", $what;
3090 parse_dsc_field_def_dsc_distro();
3091 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3092 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3093 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3094 $dsc_hint_tag = [ $dsc_hint_tag ];
3095 } elsif ($f =~ m/^\w+\s*$/) {
3097 parse_dsc_field_def_dsc_distro();
3098 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3100 progress f_ "%s: specified git hash", $what;
3102 fail f_ "%s: invalid Dgit info", $what;
3106 sub resolve_dsc_field_commit ($$) {
3107 my ($already_distro, $already_mapref) = @_;
3109 return unless defined $dsc_hash;
3112 defined $already_mapref &&
3113 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3114 ? $already_mapref : undef;
3118 my ($what, @fetch) = @_;
3120 local $idistro = $dsc_distro;
3121 my $lrf = lrfetchrefs;
3123 if (!$chase_dsc_distro) {
3124 progress f_ "not chasing .dsc distro %s: not fetching %s",
3129 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3131 my $url = access_giturl();
3132 if (!defined $url) {
3133 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3134 .dsc Dgit metadata is in context of distro %s
3135 for which we have no configured url and .dsc provides no hint
3138 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3139 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3140 parse_cfg_bool "dsc-url-proto-ok", 'false',
3141 cfg("dgit.dsc-url-proto-ok.$proto",
3142 "dgit.default.dsc-url-proto-ok")
3143 or fail f_ <<END, $dsc_distro, $proto;
3144 .dsc Dgit metadata is in context of distro %s
3145 for which we have no configured url;
3146 .dsc provides hinted url with protocol %s which is unsafe.
3147 (can be overridden by config - consult documentation)
3149 $url = $dsc_hint_url;
3152 git_lrfetch_sane $url, 1, @fetch;
3157 my $rewrite_enable = do {
3158 local $idistro = $dsc_distro;
3159 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3162 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3163 if (!defined $mapref) {
3164 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3165 $mapref = $lrf.'/'.$rewritemap;
3167 my $rewritemapdata = git_cat_file $mapref.':map';
3168 if (defined $rewritemapdata
3169 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3171 "server's git history rewrite map contains a relevant entry!";
3174 if (defined $dsc_hash) {
3175 progress __ "using rewritten git hash in place of .dsc value";
3177 progress __ "server data says .dsc hash is to be disregarded";
3182 if (!defined git_cat_file $dsc_hash) {
3183 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3184 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3185 defined git_cat_file $dsc_hash
3186 or fail f_ <<END, $dsc_hash;
3187 .dsc Dgit metadata requires commit %s
3188 but we could not obtain that object anywhere.
3190 foreach my $t (@tags) {
3191 my $fullrefname = $lrf.'/'.$t;
3192 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3193 next unless $lrfetchrefs_f{$fullrefname};
3194 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3195 lrfetchref_used $fullrefname;
3200 sub fetch_from_archive () {
3202 ensure_setup_existing_tree();
3204 # Ensures that lrref() is what is actually in the archive, one way
3205 # or another, according to us - ie this client's
3206 # appropritaely-updated archive view. Also returns the commit id.
3207 # If there is nothing in the archive, leaves lrref alone and
3208 # returns undef. git_fetch_us must have already been called.
3212 parse_dsc_field($dsc, __ 'last upload to archive');
3213 resolve_dsc_field_commit access_basedistro,
3214 lrfetchrefs."/".$rewritemap
3216 progress __ "no version available from the archive";
3219 # If the archive's .dsc has a Dgit field, there are three
3220 # relevant git commitids we need to choose between and/or merge
3222 # 1. $dsc_hash: the Dgit field from the archive
3223 # 2. $lastpush_hash: the suite branch on the dgit git server
3224 # 3. $lastfetch_hash: our local tracking brach for the suite
3226 # These may all be distinct and need not be in any fast forward
3229 # If the dsc was pushed to this suite, then the server suite
3230 # branch will have been updated; but it might have been pushed to
3231 # a different suite and copied by the archive. Conversely a more
3232 # recent version may have been pushed with dgit but not appeared
3233 # in the archive (yet).
3235 # $lastfetch_hash may be awkward because archive imports
3236 # (particularly, imports of Dgit-less .dscs) are performed only as
3237 # needed on individual clients, so different clients may perform a
3238 # different subset of them - and these imports are only made
3239 # public during push. So $lastfetch_hash may represent a set of
3240 # imports different to a subsequent upload by a different dgit
3243 # Our approach is as follows:
3245 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3246 # descendant of $dsc_hash, then it was pushed by a dgit user who
3247 # had based their work on $dsc_hash, so we should prefer it.
3248 # Otherwise, $dsc_hash was installed into this suite in the
3249 # archive other than by a dgit push, and (necessarily) after the
3250 # last dgit push into that suite (since a dgit push would have
3251 # been descended from the dgit server git branch); thus, in that
3252 # case, we prefer the archive's version (and produce a
3253 # pseudo-merge to overwrite the dgit server git branch).
3255 # (If there is no Dgit field in the archive's .dsc then
3256 # generate_commit_from_dsc uses the version numbers to decide
3257 # whether the suite branch or the archive is newer. If the suite
3258 # branch is newer it ignores the archive's .dsc; otherwise it
3259 # generates an import of the .dsc, and produces a pseudo-merge to
3260 # overwrite the suite branch with the archive contents.)
3262 # The outcome of that part of the algorithm is the `public view',
3263 # and is same for all dgit clients: it does not depend on any
3264 # unpublished history in the local tracking branch.
3266 # As between the public view and the local tracking branch: The
3267 # local tracking branch is only updated by dgit fetch, and
3268 # whenever dgit fetch runs it includes the public view in the
3269 # local tracking branch. Therefore if the public view is not
3270 # descended from the local tracking branch, the local tracking
3271 # branch must contain history which was imported from the archive
3272 # but never pushed; and, its tip is now out of date. So, we make
3273 # a pseudo-merge to overwrite the old imports and stitch the old
3276 # Finally: we do not necessarily reify the public view (as
3277 # described above). This is so that we do not end up stacking two
3278 # pseudo-merges. So what we actually do is figure out the inputs
3279 # to any public view pseudo-merge and put them in @mergeinputs.
3282 # $mergeinputs[]{Commit}
3283 # $mergeinputs[]{Info}
3284 # $mergeinputs[0] is the one whose tree we use
3285 # @mergeinputs is in the order we use in the actual commit)
3288 # $mergeinputs[]{Message} is a commit message to use
3289 # $mergeinputs[]{ReverseParents} if def specifies that parent
3290 # list should be in opposite order
3291 # Such an entry has no Commit or Info. It applies only when found
3292 # in the last entry. (This ugliness is to support making
3293 # identical imports to previous dgit versions.)
3295 my $lastpush_hash = git_get_ref(lrfetchref());
3296 printdebug "previous reference hash=$lastpush_hash\n";
3297 $lastpush_mergeinput = $lastpush_hash && {
3298 Commit => $lastpush_hash,
3299 Info => (__ "dgit suite branch on dgit git server"),
3302 my $lastfetch_hash = git_get_ref(lrref());
3303 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3304 my $lastfetch_mergeinput = $lastfetch_hash && {
3305 Commit => $lastfetch_hash,
3306 Info => (__ "dgit client's archive history view"),
3309 my $dsc_mergeinput = $dsc_hash && {
3310 Commit => $dsc_hash,
3311 Info => (__ "Dgit field in .dsc from archive"),
3315 my $del_lrfetchrefs = sub {
3318 printdebug "del_lrfetchrefs...\n";
3319 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3320 my $objid = $lrfetchrefs_d{$fullrefname};
3321 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3323 $gur ||= new IO::Handle;
3324 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3326 printf $gur "delete %s %s\n", $fullrefname, $objid;
3329 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3333 if (defined $dsc_hash) {
3334 ensure_we_have_orig();
3335 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3336 @mergeinputs = $dsc_mergeinput
3337 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3338 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3340 Git commit in archive is behind the last version allegedly pushed/uploaded.
3341 Commit referred to by archive: %s
3342 Last version pushed with dgit: %s
3345 __ $later_warning_msg or confess "$!";
3346 @mergeinputs = ($lastpush_mergeinput);
3348 # Archive has .dsc which is not a descendant of the last dgit
3349 # push. This can happen if the archive moves .dscs about.
3350 # Just follow its lead.
3351 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3352 progress __ "archive .dsc names newer git commit";
3353 @mergeinputs = ($dsc_mergeinput);
3355 progress __ "archive .dsc names other git commit, fixing up";
3356 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3360 @mergeinputs = generate_commits_from_dsc();
3361 # We have just done an import. Now, our import algorithm might
3362 # have been improved. But even so we do not want to generate
3363 # a new different import of the same package. So if the
3364 # version numbers are the same, just use our existing version.
3365 # If the version numbers are different, the archive has changed
3366 # (perhaps, rewound).
3367 if ($lastfetch_mergeinput &&
3368 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3369 (mergeinfo_version $mergeinputs[0]) )) {
3370 @mergeinputs = ($lastfetch_mergeinput);
3372 } elsif ($lastpush_hash) {
3373 # only in git, not in the archive yet
3374 @mergeinputs = ($lastpush_mergeinput);
3375 print STDERR f_ <<END,
3377 Package not found in the archive, but has allegedly been pushed using dgit.
3380 __ $later_warning_msg or confess "$!";
3382 printdebug "nothing found!\n";
3383 if (defined $skew_warning_vsn) {
3384 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3386 Warning: relevant archive skew detected.
3387 Archive allegedly contains %s
3388 But we were not able to obtain any version from the archive or git.
3392 unshift @end, $del_lrfetchrefs;
3396 if ($lastfetch_hash &&
3398 my $h = $_->{Commit};
3399 $h and is_fast_fwd($lastfetch_hash, $h);
3400 # If true, one of the existing parents of this commit
3401 # is a descendant of the $lastfetch_hash, so we'll
3402 # be ff from that automatically.
3406 push @mergeinputs, $lastfetch_mergeinput;
3409 printdebug "fetch mergeinfos:\n";
3410 foreach my $mi (@mergeinputs) {
3412 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3414 printdebug sprintf " ReverseParents=%d Message=%s",
3415 $mi->{ReverseParents}, $mi->{Message};
3419 my $compat_info= pop @mergeinputs
3420 if $mergeinputs[$#mergeinputs]{Message};
3422 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3425 if (@mergeinputs > 1) {
3427 my $tree_commit = $mergeinputs[0]{Commit};
3429 my $tree = get_tree_of_commit $tree_commit;;
3431 # We use the changelog author of the package in question the
3432 # author of this pseudo-merge. This is (roughly) correct if
3433 # this commit is simply representing aa non-dgit upload.
3434 # (Roughly because it does not record sponsorship - but we
3435 # don't have sponsorship info because that's in the .changes,
3436 # which isn't in the archivw.)
3438 # But, it might be that we are representing archive history
3439 # updates (including in-archive copies). These are not really
3440 # the responsibility of the person who created the .dsc, but
3441 # there is no-one whose name we should better use. (The
3442 # author of the .dsc-named commit is clearly worse.)
3444 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3445 my $author = clogp_authline $useclogp;
3446 my $cversion = getfield $useclogp, 'Version';
3448 my $mcf = dgit_privdir()."/mergecommit";
3449 open MC, ">", $mcf or die "$mcf $!";
3450 print MC <<END or confess "$!";
3454 my @parents = grep { $_->{Commit} } @mergeinputs;
3455 @parents = reverse @parents if $compat_info->{ReverseParents};
3456 print MC <<END or confess "$!" foreach @parents;
3460 print MC <<END or confess "$!";
3466 if (defined $compat_info->{Message}) {
3467 print MC $compat_info->{Message} or confess "$!";
3469 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3470 Record %s (%s) in archive suite %s
3474 my $message_add_info = sub {
3476 my $mversion = mergeinfo_version $mi;
3477 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3481 $message_add_info->($mergeinputs[0]);
3482 print MC __ <<END or confess "$!";
3483 should be treated as descended from
3485 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3488 close MC or confess "$!";
3489 $hash = hash_commit $mcf;
3491 $hash = $mergeinputs[0]{Commit};
3493 printdebug "fetch hash=$hash\n";
3496 my ($lasth, $what) = @_;
3497 return unless $lasth;
3498 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3501 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3503 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3505 fetch_from_archive_record_1($hash);
3507 if (defined $skew_warning_vsn) {
3508 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3509 my $gotclogp = commit_getclogp($hash);
3510 my $got_vsn = getfield $gotclogp, 'Version';
3511 printdebug "SKEW CHECK GOT $got_vsn\n";
3512 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3513 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3515 Warning: archive skew detected. Using the available version:
3516 Archive allegedly contains %s
3517 We were able to obtain only %s
3523 if ($lastfetch_hash ne $hash) {
3524 fetch_from_archive_record_2($hash);
3527 lrfetchref_used lrfetchref();
3529 check_gitattrs($hash, __ "fetched source tree");
3531 unshift @end, $del_lrfetchrefs;
3535 sub set_local_git_config ($$) {
3537 runcmd @git, qw(config), $k, $v;
3540 sub setup_mergechangelogs (;$) {
3542 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3544 my $driver = 'dpkg-mergechangelogs';
3545 my $cb = "merge.$driver";
3546 confess unless defined $maindir;
3547 my $attrs = "$maindir_gitcommon/info/attributes";
3548 ensuredir "$maindir_gitcommon/info";
3550 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3551 if (!open ATTRS, "<", $attrs) {
3552 $!==ENOENT or die "$attrs: $!";
3556 next if m{^debian/changelog\s};
3557 print NATTRS $_, "\n" or confess "$!";
3559 ATTRS->error and confess "$!";
3562 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3565 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3566 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3568 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3571 sub setup_useremail (;$) {
3573 return unless $always || access_cfg_bool(1, 'setup-useremail');
3576 my ($k, $envvar) = @_;
3577 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3578 return unless defined $v;
3579 set_local_git_config "user.$k", $v;
3582 $setup->('email', 'DEBEMAIL');
3583 $setup->('name', 'DEBFULLNAME');
3586 sub ensure_setup_existing_tree () {
3587 my $k = "remote.$remotename.skipdefaultupdate";
3588 my $c = git_get_config $k;
3589 return if defined $c;
3590 set_local_git_config $k, 'true';
3593 sub open_main_gitattrs () {
3594 confess 'internal error no maindir' unless defined $maindir;
3595 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3597 or die "open $maindir_gitcommon/info/attributes: $!";
3601 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3603 sub is_gitattrs_setup () {
3606 # 1: gitattributes set up and should be left alone
3608 # 0: there is a dgit-defuse-attrs but it needs fixing
3609 # undef: there is none
3610 my $gai = open_main_gitattrs();
3611 return undef unless $gai;
3613 next unless m{$gitattrs_ourmacro_re};
3614 return 1 if m{\s-working-tree-encoding\s};
3615 printdebug "is_gitattrs_setup: found old macro\n";
3618 $gai->error and confess "$!";
3619 printdebug "is_gitattrs_setup: found nothing\n";
3623 sub setup_gitattrs (;$) {
3625 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3627 my $already = is_gitattrs_setup();
3630 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3631 not doing further gitattributes setup
3635 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3636 my $af = "$maindir_gitcommon/info/attributes";
3637 ensuredir "$maindir_gitcommon/info";
3639 open GAO, "> $af.new" or confess "$!";
3640 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3644 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3646 my $gai = open_main_gitattrs();
3649 if (m{$gitattrs_ourmacro_re}) {
3650 die unless defined $already;
3654 print GAO $_, "\n" or confess "$!";
3656 $gai->error and confess "$!";
3658 close GAO or confess "$!";
3659 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3662 sub setup_new_tree () {
3663 setup_mergechangelogs();
3668 sub check_gitattrs ($$) {
3669 my ($treeish, $what) = @_;
3671 return if is_gitattrs_setup;
3674 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3676 my $gafl = new IO::File;
3677 open $gafl, "-|", @cmd or confess "$!";
3680 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3682 next unless m{(?:^|/)\.gitattributes$};
3684 # oh dear, found one
3685 print STDERR f_ <<END, $what;
3686 dgit: warning: %s contains .gitattributes
3687 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3692 # tree contains no .gitattributes files
3693 $?=0; $!=0; close $gafl or failedcmd @cmd;
3697 sub multisuite_suite_child ($$$) {
3698 my ($tsuite, $mergeinputs, $fn) = @_;
3699 # in child, sets things up, calls $fn->(), and returns undef
3700 # in parent, returns canonical suite name for $tsuite
3701 my $canonsuitefh = IO::File::new_tmpfile;
3702 my $pid = fork // confess "$!";
3706 $us .= " [$isuite]";
3707 $debugprefix .= " ";
3708 progress f_ "fetching %s...", $tsuite;
3709 canonicalise_suite();
3710 print $canonsuitefh $csuite, "\n" or confess "$!";
3711 close $canonsuitefh or confess "$!";
3715 waitpid $pid,0 == $pid or confess "$!";
3716 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3718 seek $canonsuitefh,0,0 or confess "$!";
3719 local $csuite = <$canonsuitefh>;
3720 confess "$!" unless defined $csuite && chomp $csuite;
3722 printdebug "multisuite $tsuite missing\n";
3725 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3726 push @$mergeinputs, {
3733 sub fork_for_multisuite ($) {
3734 my ($before_fetch_merge) = @_;
3735 # if nothing unusual, just returns ''
3738 # returns 0 to caller in child, to do first of the specified suites
3739 # in child, $csuite is not yet set
3741 # returns 1 to caller in parent, to finish up anything needed after
3742 # in parent, $csuite is set to canonicalised portmanteau
3744 my $org_isuite = $isuite;
3745 my @suites = split /\,/, $isuite;
3746 return '' unless @suites > 1;
3747 printdebug "fork_for_multisuite: @suites\n";
3751 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3753 return 0 unless defined $cbasesuite;
3755 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3756 unless @mergeinputs;
3758 my @csuites = ($cbasesuite);
3760 $before_fetch_merge->();
3762 foreach my $tsuite (@suites[1..$#suites]) {
3763 $tsuite =~ s/^-/$cbasesuite-/;
3764 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3771 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3772 push @csuites, $csubsuite;
3775 foreach my $mi (@mergeinputs) {
3776 my $ref = git_get_ref $mi->{Ref};
3777 die "$mi->{Ref} ?" unless length $ref;
3778 $mi->{Commit} = $ref;
3781 $csuite = join ",", @csuites;
3783 my $previous = git_get_ref lrref;
3785 unshift @mergeinputs, {
3786 Commit => $previous,
3787 Info => (__ "local combined tracking branch"),
3789 "archive seems to have rewound: local tracking branch is ahead!"),
3793 foreach my $ix (0..$#mergeinputs) {
3794 $mergeinputs[$ix]{Index} = $ix;
3797 @mergeinputs = sort {
3798 -version_compare(mergeinfo_version $a,
3799 mergeinfo_version $b) # highest version first
3801 $a->{Index} <=> $b->{Index}; # earliest in spec first
3807 foreach my $mi (@mergeinputs) {
3808 printdebug "multisuite merge check $mi->{Info}\n";
3809 foreach my $previous (@needed) {
3810 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3811 printdebug "multisuite merge un-needed $previous->{Info}\n";
3815 printdebug "multisuite merge this-needed\n";
3816 $mi->{Character} = '+';
3819 $needed[0]{Character} = '*';
3821 my $output = $needed[0]{Commit};
3824 printdebug "multisuite merge nontrivial\n";
3825 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3827 my $commit = "tree $tree\n";
3828 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3829 "Input branches:\n",
3832 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3833 printdebug "multisuite merge include $mi->{Info}\n";
3834 $mi->{Character} //= ' ';
3835 $commit .= "parent $mi->{Commit}\n";
3836 $msg .= sprintf " %s %-25s %s\n",
3838 (mergeinfo_version $mi),
3841 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3842 $msg .= __ "\nKey\n".
3843 " * marks the highest version branch, which choose to use\n".
3844 " + marks each branch which was not already an ancestor\n\n";
3846 "[dgit multi-suite $csuite]\n";
3848 "author $authline\n".
3849 "committer $authline\n\n";
3850 $output = hash_commit_text $commit.$msg;
3851 printdebug "multisuite merge generated $output\n";
3854 fetch_from_archive_record_1($output);
3855 fetch_from_archive_record_2($output);
3857 progress f_ "calculated combined tracking suite %s", $csuite;
3862 sub clone_set_head () {
3863 open H, "> .git/HEAD" or confess "$!";
3864 print H "ref: ".lref()."\n" or confess "$!";
3865 close H or confess "$!";
3867 sub clone_finish ($) {
3869 runcmd @git, qw(reset --hard), lrref();
3870 runcmd qw(bash -ec), <<'END';
3872 git ls-tree -r --name-only -z HEAD | \
3873 xargs -0r touch -h -r . --
3875 printdone f_ "ready for work in %s", $dstdir;
3878 sub vcs_git_url_of_ctrl ($) {
3880 my $vcsgiturl = $ctrl->{'Vcs-Git'};
3881 if (length $vcsgiturl) {
3882 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3883 $vcsgiturl =~ s/\s+\[[^][]*\]//g;
3889 # in multisuite, returns twice!
3890 # once in parent after first suite fetched,
3891 # and then again in child after everything is finished
3893 badusage __ "dry run makes no sense with clone" unless act_local();
3895 my $multi_fetched = fork_for_multisuite(sub {
3896 printdebug "multi clone before fetch merge\n";
3900 if ($multi_fetched) {
3901 printdebug "multi clone after fetch merge\n";
3903 clone_finish($dstdir);
3906 printdebug "clone main body\n";
3908 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3912 canonicalise_suite();
3913 my $hasgit = check_for_git();
3915 runcmd @git, qw(init -q);
3920 progress __ "fetching existing git history";
3923 progress __ "starting new git history";
3925 fetch_from_archive() or no_such_package;
3926 my $vcsgiturl = vcs_git_url_of_ctrl $dsc;
3927 if (length $vcsgiturl) {
3928 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3930 clone_finish($dstdir);
3934 canonicalise_suite();
3935 if (check_for_git()) {
3938 fetch_from_archive() or no_such_package();
3940 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3941 if (length $vcsgiturl and
3942 (grep { $csuite eq $_ }
3944 cfg 'dgit.vcs-git.suites')) {
3945 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3946 if (defined $current && $current ne $vcsgiturl) {
3947 print STDERR f_ <<END, $csuite;
3948 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3949 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3953 printdone f_ "fetched into %s", lrref();
3957 my $multi_fetched = fork_for_multisuite(sub { });
3958 fetch_one() unless $multi_fetched; # parent
3959 finish 0 if $multi_fetched eq '0'; # child
3964 runcmd_ordryrun_local @git, qw(merge -m),
3965 (f_ "Merge from %s [dgit]", $csuite),
3967 printdone f_ "fetched to %s and merged into HEAD", lrref();
3970 sub check_not_dirty () {
3971 my @forbid = qw(local-options local-patch-header);
3972 @forbid = map { "debian/source/$_" } @forbid;
3973 foreach my $f (@forbid) {
3974 if (stat_exists $f) {
3975 fail f_ "git tree contains %s", $f;
3979 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3980 push @cmd, qw(debian/source/format debian/source/options);
3983 my $bad = cmdoutput @cmd;
3986 "you have uncommitted changes to critical files, cannot continue:\n").
3990 return if $includedirty;
3992 git_check_unmodified();
3995 sub commit_admin ($) {
3998 runcmd_ordryrun_local @git, qw(commit -m), $m;
4001 sub quiltify_nofix_bail ($$) {
4002 my ($headinfo, $xinfo) = @_;
4003 if ($quilt_mode eq 'nofix') {
4005 "quilt fixup required but quilt mode is \`nofix'\n".
4006 "HEAD commit%s differs from tree implied by debian/patches%s",
4011 sub commit_quilty_patch () {
4012 my $output = cmdoutput @git, qw(status --ignored --porcelain);
4014 foreach my $l (split /\n/, $output) {
4015 next unless $l =~ m/\S/;
4016 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
4020 delete $adds{'.pc'}; # if there wasn't one before, don't add it
4022 progress __ "nothing quilty to commit, ok.";
4025 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
4026 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
4027 runcmd_ordryrun_local @git, qw(add -f), @adds;
4028 commit_admin +(__ <<ENDT).<<END
4029 Commit Debian 3.0 (quilt) metadata
4032 [dgit ($our_version) quilt-fixup]
4036 sub get_source_format () {
4038 if (open F, "debian/source/options") {
4042 s/\s+$//; # ignore missing final newline
4044 my ($k, $v) = ($`, $'); #');
4045 $v =~ s/^"(.*)"$/$1/;
4051 F->error and confess "$!";
4054 confess "$!" unless $!==&ENOENT;
4057 if (!open F, "debian/source/format") {
4058 confess "$!" unless $!==&ENOENT;
4062 F->error and confess "$!";
4065 return ($_, \%options);
4068 sub madformat_wantfixup ($) {
4070 return 0 unless $format eq '3.0 (quilt)';
4071 our $quilt_mode_warned;
4072 if ($quilt_mode eq 'nocheck') {
4073 progress f_ "Not doing any fixup of \`%s'".
4074 " due to ----no-quilt-fixup or --quilt=nocheck", $format
4075 unless $quilt_mode_warned++;
4078 progress f_ "Format \`%s', need to check/update patch stack", $format
4079 unless $quilt_mode_warned++;
4083 sub maybe_split_brain_save ($$$) {
4084 my ($headref, $dgitview, $msg) = @_;
4085 # => message fragment "$saved" describing disposition of $dgitview
4086 # (used inside parens, in the English texts)
4087 my $save = $internal_object_save{'dgit-view'};
4088 return f_ "commit id %s", $dgitview unless defined $save;
4089 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4091 "dgit --dgit-view-save $msg HEAD=$headref",
4094 return f_ "and left in %s", $save;
4097 # An "infopair" is a tuple [ $thing, $what ]
4098 # (often $thing is a commit hash; $what is a description)
4100 sub infopair_cond_equal ($$) {
4102 $x->[0] eq $y->[0] or fail <<END;
4103 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4107 sub infopair_lrf_tag_lookup ($$) {
4108 my ($tagnames, $what) = @_;
4109 # $tagname may be an array ref
4110 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4111 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4112 foreach my $tagname (@tagnames) {
4113 my $lrefname = lrfetchrefs."/tags/$tagname";
4114 my $tagobj = $lrfetchrefs_f{$lrefname};
4115 next unless defined $tagobj;
4116 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4117 return [ git_rev_parse($tagobj), $what ];
4119 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4120 Wanted tag %s (%s) on dgit server, but not found
4122 : (f_ <<END, $what, "@tagnames");
4123 Wanted tag %s (one of: %s) on dgit server, but not found
4127 sub infopair_cond_ff ($$) {
4128 my ($anc,$desc) = @_;
4129 is_fast_fwd($anc->[0], $desc->[0]) or
4130 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4131 %s (%s) .. %s (%s) is not fast forward
4135 sub pseudomerge_version_check ($$) {
4136 my ($clogp, $archive_hash) = @_;
4138 my $arch_clogp = commit_getclogp $archive_hash;
4139 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4140 __ 'version currently in archive' ];
4141 if (defined $overwrite_version) {
4142 if (length $overwrite_version) {
4143 infopair_cond_equal([ $overwrite_version,
4144 '--overwrite= version' ],
4147 my $v = $i_arch_v->[0];
4149 "Checking package changelog for archive version %s ...", $v;
4152 my @xa = ("-f$v", "-t$v");
4153 my $vclogp = parsechangelog @xa;
4156 [ (getfield $vclogp, $fn),
4157 (f_ "%s field from dpkg-parsechangelog %s",
4160 my $cv = $gf->('Version');
4161 infopair_cond_equal($i_arch_v, $cv);
4162 $cd = $gf->('Distribution');
4166 $@ =~ s/^dgit: //gm;
4168 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4170 fail f_ <<END, $cd->[1], $cd->[0], $v
4172 Your tree seems to based on earlier (not uploaded) %s.
4174 if $cd->[0] =~ m/UNRELEASED/;
4178 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4182 sub pseudomerge_hash_commit ($$$$ $$) {
4183 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4184 $msg_cmd, $msg_msg) = @_;
4185 progress f_ "Declaring that HEAD includes all changes in %s...",
4188 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4189 my $authline = clogp_authline $clogp;
4193 !defined $overwrite_version ? ""
4194 : !length $overwrite_version ? " --overwrite"
4195 : " --overwrite=".$overwrite_version;
4197 # Contributing parent is the first parent - that makes
4198 # git rev-list --first-parent DTRT.
4199 my $pmf = dgit_privdir()."/pseudomerge";
4200 open MC, ">", $pmf or die "$pmf $!";
4201 print MC <<END or confess "$!";
4204 parent $archive_hash
4212 close MC or confess "$!";
4214 return hash_commit($pmf);
4217 sub splitbrain_pseudomerge ($$$$) {
4218 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4219 # => $merged_dgitview
4220 printdebug "splitbrain_pseudomerge...\n";
4222 # We: debian/PREVIOUS HEAD($maintview)
4223 # expect: o ----------------- o
4226 # a/d/PREVIOUS $dgitview
4229 # we do: `------------------ o
4233 return $dgitview unless defined $archive_hash;
4234 return $dgitview if deliberately_not_fast_forward();
4236 printdebug "splitbrain_pseudomerge...\n";
4238 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4240 if (!defined $overwrite_version) {
4241 progress __ "Checking that HEAD includes all changes in archive...";
4244 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4246 if (defined $overwrite_version) {
4248 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4249 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4250 __ "maintainer view tag");
4251 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4252 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4253 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4255 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4257 infopair_cond_equal($i_dgit, $i_archive);
4258 infopair_cond_ff($i_dep14, $i_dgit);
4259 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4262 $@ =~ s/^\n//; chomp $@;
4263 print STDERR <<END.(__ <<ENDT);
4266 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4271 my $arch_v = $i_arch_v->[0];
4272 my $r = pseudomerge_hash_commit
4273 $clogp, $dgitview, $archive_hash, $i_arch_v,
4274 "dgit --quilt=$quilt_mode",
4275 (defined $overwrite_version
4276 ? f_ "Declare fast forward from %s\n", $arch_v
4277 : f_ "Make fast forward from %s\n", $arch_v);
4279 maybe_split_brain_save $maintview, $r, "pseudomerge";
4281 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4285 sub plain_overwrite_pseudomerge ($$$) {
4286 my ($clogp, $head, $archive_hash) = @_;
4288 printdebug "plain_overwrite_pseudomerge...";
4290 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4292 return $head if is_fast_fwd $archive_hash, $head;
4294 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4296 my $r = pseudomerge_hash_commit
4297 $clogp, $head, $archive_hash, $i_arch_v,
4300 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4302 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4306 sub push_parse_changelog ($) {
4309 my $clogp = Dpkg::Control::Hash->new();
4310 $clogp->load($clogpfn) or die;
4312 my $clogpackage = getfield $clogp, 'Source';
4313 $package //= $clogpackage;
4314 fail f_ "-p specified %s but changelog specified %s",
4315 $package, $clogpackage
4316 unless $package eq $clogpackage;
4317 my $cversion = getfield $clogp, 'Version';
4319 if (!$we_are_initiator) {
4320 # rpush initiator can't do this because it doesn't have $isuite yet
4321 my $tag = debiantag_new($cversion, access_nomdistro);
4322 runcmd @git, qw(check-ref-format), $tag;
4325 my $dscfn = dscfn($cversion);
4327 return ($clogp, $cversion, $dscfn);
4330 sub push_parse_dsc ($$$) {
4331 my ($dscfn,$dscfnwhat, $cversion) = @_;
4332 $dsc = parsecontrol($dscfn,$dscfnwhat);
4333 my $dversion = getfield $dsc, 'Version';
4334 my $dscpackage = getfield $dsc, 'Source';
4335 ($dscpackage eq $package && $dversion eq $cversion) or
4336 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4337 $dscfn, $dscpackage, $dversion,
4338 $package, $cversion;
4341 sub push_tagwants ($$$$) {
4342 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4345 TagFn => \&debiantag_new,
4350 if (defined $maintviewhead) {
4352 TagFn => \&debiantag_maintview,
4353 Objid => $maintviewhead,
4354 TfSuffix => '-maintview',
4357 } elsif ($dodep14tag ne 'no') {
4359 TagFn => \&debiantag_maintview,
4361 TfSuffix => '-dgit',
4365 foreach my $tw (@tagwants) {
4366 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4367 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4369 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4373 sub push_mktags ($$ $$ $) {
4375 $changesfile,$changesfilewhat,
4378 die unless $tagwants->[0]{View} eq 'dgit';
4380 my $declaredistro = access_nomdistro();
4381 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4382 $dsc->{$ourdscfield[0]} = join " ",
4383 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4385 $dsc->save("$dscfn.tmp") or confess "$!";
4387 my $changes = parsecontrol($changesfile,$changesfilewhat);
4388 foreach my $field (qw(Source Distribution Version)) {
4389 $changes->{$field} eq $clogp->{$field} or
4390 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4391 $field, $changes->{$field}, $clogp->{$field};
4394 my $cversion = getfield $clogp, 'Version';
4395 my $clogsuite = getfield $clogp, 'Distribution';
4396 my $format = getfield $dsc, 'Format';
4398 # We make the git tag by hand because (a) that makes it easier
4399 # to control the "tagger" (b) we can do remote signing
4400 my $authline = clogp_authline $clogp;
4404 my $tfn = $tw->{Tfn};
4405 my $head = $tw->{Objid};
4406 my $tag = $tw->{Tag};
4408 open TO, '>', $tfn->('.tmp') or confess "$!";
4409 print TO <<END or confess "$!";
4417 my @dtxinfo = @deliberatelies;
4418 unshift @dtxinfo, "--quilt=$quilt_mode" if madformat($format);
4419 unshift @dtxinfo, do_split_brain() ? "split" : "no-split"
4420 # rpush protocol 5 and earlier don't tell us
4421 unless $we_are_initiator && $protovsn < 6;
4422 my $dtxinfo = join(" ", "",@dtxinfo);
4423 my $tag_metadata = <<END;
4424 [dgit distro=$declaredistro$dtxinfo]
4426 foreach my $ref (sort keys %previously) {
4427 $tag_metadata .= <<END or confess "$!";
4428 [dgit previously:$ref=$previously{$ref}]
4432 if ($tw->{View} eq 'dgit') {
4433 print TO sprintf <<ENDT, $package, $cversion, $clogsuite, $csuite
4434 %s release %s for %s (%s) [dgit]
4437 } elsif ($tw->{View} eq 'maint') {
4438 print TO sprintf <<END, $package, $cversion, $clogsuite, $csuite;
4439 %s release %s for %s (%s)
4443 (maintainer view tag generated by dgit --quilt=%s)
4448 confess Dumper($tw)."?";
4450 print TO "\n", $tag_metadata;
4452 close TO or confess "$!";
4454 my $tagobjfn = $tfn->('.tmp');
4456 if (!defined $keyid) {
4457 $keyid = access_cfg('keyid','RETURN-UNDEF');
4459 if (!defined $keyid) {
4460 $keyid = getfield $clogp, 'Maintainer';
4462 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4463 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4464 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4465 push @sign_cmd, $tfn->('.tmp');
4466 runcmd_ordryrun @sign_cmd;
4468 $tagobjfn = $tfn->('.signed.tmp');
4469 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4470 $tfn->('.tmp'), $tfn->('.tmp.asc');
4476 my @r = map { $mktag->($_); } @$tagwants;
4480 sub sign_changes ($) {
4481 my ($changesfile) = @_;
4483 my @debsign_cmd = @debsign;
4484 push @debsign_cmd, "-k$keyid" if defined $keyid;
4485 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4486 push @debsign_cmd, $changesfile;
4487 runcmd_ordryrun @debsign_cmd;
4492 printdebug "actually entering push\n";
4494 supplementary_message(__ <<'END');
4495 Push failed, while checking state of the archive.
4496 You can retry the push, after fixing the problem, if you like.
4498 if (check_for_git()) {
4501 my $archive_hash = fetch_from_archive();
4502 if (!$archive_hash) {
4504 fail __ "package appears to be new in this suite;".
4505 " if this is intentional, use --new";
4508 supplementary_message(__ <<'END');
4509 Push failed, while preparing your push.
4510 You can retry the push, after fixing the problem, if you like.
4515 access_giturl(); # check that success is vaguely likely
4516 rpush_handle_protovsn_bothends() if $we_are_initiator;
4518 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4519 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4521 responder_send_file('parsed-changelog', $clogpfn);
4523 my ($clogp, $cversion, $dscfn) =
4524 push_parse_changelog("$clogpfn");
4526 my $dscpath = "$buildproductsdir/$dscfn";
4527 stat_exists $dscpath or
4528 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4531 responder_send_file('dsc', $dscpath);
4533 push_parse_dsc($dscpath, $dscfn, $cversion);
4535 my $format = getfield $dsc, 'Format';
4537 my $symref = git_get_symref();
4538 my $actualhead = git_rev_parse('HEAD');
4540 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4541 if (quiltmode_splitting()) {
4542 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4543 fail f_ <<END, $ffq_prev, $quilt_mode;
4544 Branch is managed by git-debrebase (%s
4545 exists), but quilt mode (%s) implies a split view.
4546 Pass the right --quilt option or adjust your git config.
4547 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4550 runcmd_ordryrun_local @git_debrebase, 'stitch';
4551 $actualhead = git_rev_parse('HEAD');
4554 my $dgithead = $actualhead;
4555 my $maintviewhead = undef;
4557 my $upstreamversion = upstreamversion $clogp->{Version};
4559 if (madformat_wantfixup($format)) {
4560 # user might have not used dgit build, so maybe do this now:
4561 if (do_split_brain()) {
4562 changedir $playground;
4564 ($dgithead, $cachekey) =
4565 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4566 $dgithead or fail f_
4567 "--quilt=%s but no cached dgit view:
4568 perhaps HEAD changed since dgit build[-source] ?",
4571 if (!do_split_brain()) {
4572 # In split brain mode, do not attempt to incorporate dirty
4573 # stuff from the user's working tree. That would be mad.
4574 commit_quilty_patch();
4577 if (do_split_brain()) {
4578 $made_split_brain = 1;
4579 $dgithead = splitbrain_pseudomerge($clogp,
4580 $actualhead, $dgithead,
4582 $maintviewhead = $actualhead;
4584 prep_ud(); # so _only_subdir() works, below
4587 if (defined $overwrite_version && !defined $maintviewhead
4589 $dgithead = plain_overwrite_pseudomerge($clogp,
4597 if ($archive_hash) {
4598 if (is_fast_fwd($archive_hash, $dgithead)) {
4600 } elsif (deliberately_not_fast_forward) {
4603 fail __ "dgit push: HEAD is not a descendant".
4604 " of the archive's version.\n".
4605 "To overwrite the archive's contents,".
4606 " pass --overwrite[=VERSION].\n".
4607 "To rewrite history, if permitted by the archive,".
4608 " use --deliberately-not-fast-forward.";
4612 confess unless !!$made_split_brain == do_split_brain();
4614 my $tagname = debiantag_new $cversion, access_nomdistro();
4615 if (!(forceing[qw(reusing-version)]) && git_get_ref "refs/tags/$tagname") {
4616 supplementary_message '';
4617 print STDERR f_ <<END, $cversion;
4619 Version %s has already been tagged (pushed?)
4620 If this was a failed (or incomplete or rejected) upload by you, just
4621 add a new changelog stanza for a new version number and try again.
4623 fail f_ <<END, $tagname;
4624 Tag %s already exists.
4628 changedir $playground;
4629 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4630 runcmd qw(dpkg-source -x --),
4631 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4632 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4633 check_for_vendor_patches() if madformat($dsc->{format});
4635 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4636 debugcmd "+",@diffcmd;
4638 my $r = system @diffcmd;
4641 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4642 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4645 my $raw = cmdoutput @git,
4646 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4648 foreach (split /\0/, $raw) {
4649 if (defined $changed) {
4650 push @mode_changes, "$changed: $_\n" if $changed;
4653 } elsif (m/^:0+ 0+ /) {
4655 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4656 $changed = "Mode change from $1 to $2"
4661 if (@mode_changes) {
4662 fail +(f_ <<ENDT, $dscfn).<<END
4663 HEAD specifies a different tree to %s:
4667 .(join '', @mode_changes)
4668 .(f_ <<ENDT, $tree, $referent);
4669 There is a problem with your source tree (see dgit(7) for some hints).
4670 To see a full diff, run git diff %s %s
4674 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4675 HEAD specifies a different tree to %s:
4679 Perhaps you forgot to build. Or perhaps there is a problem with your
4680 source tree (see dgit(7) for some hints). To see a full diff, run
4687 if (!$changesfile) {
4688 my $pat = changespat $cversion;
4689 my @cs = glob "$buildproductsdir/$pat";
4690 fail f_ "failed to find unique changes file".
4691 " (looked for %s in %s);".
4692 " perhaps you need to use dgit -C",
4693 $pat, $buildproductsdir
4695 ($changesfile) = @cs;
4697 $changesfile = "$buildproductsdir/$changesfile";
4700 # Check that changes and .dsc agree enough
4701 $changesfile =~ m{[^/]*$};
4702 my $changes = parsecontrol($changesfile,$&);
4703 files_compare_inputs($dsc, $changes)
4704 unless forceing [qw(dsc-changes-mismatch)];
4706 # Check whether this is a source only upload
4707 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4708 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4709 if ($sourceonlypolicy eq 'ok') {
4710 } elsif ($sourceonlypolicy eq 'always') {
4711 forceable_fail [qw(uploading-binaries)],
4712 __ "uploading binaries, although distro policy is source only"
4714 } elsif ($sourceonlypolicy eq 'never') {
4715 forceable_fail [qw(uploading-source-only)],
4716 __ "source-only upload, although distro policy requires .debs"
4718 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4719 forceable_fail [qw(uploading-source-only)],
4720 f_ "source-only upload, even though package is entirely NEW\n".
4721 "(this is contrary to policy in %s)",
4725 && !(archive_query('package_not_wholly_new', $package) // 1);
4727 badcfg f_ "unknown source-only-uploads policy \`%s'",
4731 # Perhaps adjust .dsc to contain right set of origs
4732 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4734 unless forceing [qw(changes-origs-exactly)];
4736 # Checks complete, we're going to try and go ahead:
4738 responder_send_file('changes',$changesfile);
4739 responder_send_command("param head $dgithead");
4740 responder_send_command("param csuite $csuite");
4741 responder_send_command("param isuite $isuite");
4742 responder_send_command("param tagformat new"); # needed in $protovsn==4
4743 responder_send_command("param splitbrain $do_split_brain");
4744 if (defined $maintviewhead) {
4745 responder_send_command("param maint-view $maintviewhead");
4748 # Perhaps send buildinfo(s) for signing
4749 my $changes_files = getfield $changes, 'Files';
4750 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4751 foreach my $bi (@buildinfos) {
4752 responder_send_command("param buildinfo-filename $bi");
4753 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4756 if (deliberately_not_fast_forward) {
4757 git_for_each_ref(lrfetchrefs, sub {
4758 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4759 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4760 responder_send_command("previously $rrefname=$objid");
4761 $previously{$rrefname} = $objid;
4765 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4766 dgit_privdir()."/tag");
4769 supplementary_message(__ <<'END');
4770 Push failed, while signing the tag.
4771 You can retry the push, after fixing the problem, if you like.
4773 # If we manage to sign but fail to record it anywhere, it's fine.
4774 if ($we_are_responder) {
4775 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4776 responder_receive_files('signed-tag', @tagobjfns);
4778 @tagobjfns = push_mktags($clogp,$dscpath,
4779 $changesfile,$changesfile,
4782 supplementary_message(__ <<'END');
4783 Push failed, *after* signing the tag.
4784 If you want to try again, you should use a new version number.
4787 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4789 foreach my $tw (@tagwants) {
4790 my $tag = $tw->{Tag};
4791 my $tagobjfn = $tw->{TagObjFn};
4793 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4794 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4795 runcmd_ordryrun_local
4796 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4799 supplementary_message(__ <<'END');
4800 Push failed, while updating the remote git repository - see messages above.
4801 If you want to try again, you should use a new version number.
4803 if (!check_for_git()) {
4804 create_remote_git_repo();
4807 my @pushrefs = $forceflag.$dgithead.":".rrref();
4808 foreach my $tw (@tagwants) {
4809 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4812 runcmd_ordryrun @git,
4813 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4814 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4816 supplementary_message(__ <<'END');
4817 Push failed, while obtaining signatures on the .changes and .dsc.
4818 If it was just that the signature failed, you may try again by using
4819 debsign by hand to sign the changes file (see the command dgit tried,
4820 above), and then dput that changes file to complete the upload.
4821 If you need to change the package, you must use a new version number.
4823 if ($we_are_responder) {
4824 my $dryrunsuffix = act_local() ? "" : ".tmp";
4825 my @rfiles = ($dscpath, $changesfile);
4826 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4827 responder_receive_files('signed-dsc-changes',
4828 map { "$_$dryrunsuffix" } @rfiles);
4831 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4833 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4835 sign_changes $changesfile;
4838 supplementary_message(f_ <<END, $changesfile);
4839 Push failed, while uploading package(s) to the archive server.
4840 You can retry the upload of exactly these same files with dput of:
4842 If that .changes file is broken, you will need to use a new version
4843 number for your next attempt at the upload.
4845 my $host = access_cfg('upload-host','RETURN-UNDEF');
4846 my @hostarg = defined($host) ? ($host,) : ();
4847 runcmd_ordryrun @dput, @hostarg, $changesfile;
4848 printdone f_ "pushed and uploaded %s", $cversion;
4850 supplementary_message('');
4851 responder_send_command("complete");
4855 not_necessarily_a_tree();
4860 badusage __ "-p is not allowed with clone; specify as argument instead"
4861 if defined $package;
4864 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4865 ($package,$isuite) = @ARGV;
4866 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4867 ($package,$dstdir) = @ARGV;
4868 } elsif (@ARGV==3) {
4869 ($package,$isuite,$dstdir) = @ARGV;
4871 badusage __ "incorrect arguments to dgit clone";
4875 $dstdir ||= "$package";
4876 if (stat_exists $dstdir) {
4877 fail f_ "%s already exists", $dstdir;
4881 if ($rmonerror && !$dryrun_level) {
4882 $cwd_remove= getcwd();
4884 return unless defined $cwd_remove;
4885 if (!chdir "$cwd_remove") {
4886 return if $!==&ENOENT;
4887 confess "chdir $cwd_remove: $!";
4889 printdebug "clone rmonerror removing $dstdir\n";
4891 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4892 } elsif (grep { $! == $_ }
4893 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4895 print STDERR f_ "check whether to remove %s: %s\n",
4902 $cwd_remove = undef;
4905 sub branchsuite () {
4906 my $branch = git_get_symref();
4907 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4914 sub package_from_d_control () {
4915 if (!defined $package) {
4916 my $sourcep = parsecontrol('debian/control','debian/control');
4917 $package = getfield $sourcep, 'Source';
4921 sub fetchpullargs () {
4922 package_from_d_control();
4924 $isuite = branchsuite();
4926 my $clogp = parsechangelog();
4927 my $clogsuite = getfield $clogp, 'Distribution';
4928 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4930 } elsif (@ARGV==1) {
4933 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4947 determine_whether_split_brain get_source_format();
4948 if (do_split_brain()) {
4949 my ($format, $fopts) = get_source_format();
4950 madformat($format) and fail f_ <<END, $quilt_mode
4951 dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
4959 package_from_d_control();
4960 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4964 foreach my $canon (qw(0 1)) {
4969 canonicalise_suite();
4971 if (length git_get_ref lref()) {
4972 # local branch already exists, yay
4975 if (!length git_get_ref lrref()) {
4983 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4986 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4987 "dgit checkout $isuite";
4988 runcmd (@git, qw(checkout), lbranch());
4991 sub cmd_update_vcs_git () {
4993 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4994 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4996 ($specsuite) = (@ARGV);
5001 if ($ARGV[0] eq '-') {
5003 } elsif ($ARGV[0] eq '-') {
5008 package_from_d_control();
5010 if ($specsuite eq '.') {
5011 $ctrl = parsecontrol 'debian/control', 'debian/control';
5013 $isuite = $specsuite;
5017 my $url = vcs_git_url_of_ctrl $ctrl;
5018 fail 'no Vcs-Git header in control file' unless length $url;
5021 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
5022 if (!defined $orgurl) {
5023 print STDERR f_ "setting up vcs-git: %s\n", $url;
5024 @cmd = (@git, qw(remote add vcs-git), $url);
5025 } elsif ($orgurl eq $url) {
5026 print STDERR f_ "vcs git unchanged: %s\n", $url;
5028 print STDERR f_ "changing vcs-git url to: %s\n", $url;
5029 @cmd = (@git, qw(remote set-url vcs-git), $url);
5031 runcmd_ordryrun_local @cmd if @cmd;
5033 print f_ "fetching (%s)\n", "@ARGV";
5034 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
5040 build_or_push_prep_early();
5042 build_or_push_prep_modes();
5046 } elsif (@ARGV==1) {
5047 ($specsuite) = (@ARGV);
5049 badusage f_ "incorrect arguments to dgit %s", $subcommand;
5052 local ($package) = $existing_package; # this is a hack
5053 canonicalise_suite();
5055 canonicalise_suite();
5057 if (defined $specsuite &&
5058 $specsuite ne $isuite &&
5059 $specsuite ne $csuite) {
5060 fail f_ "dgit %s: changelog specifies %s (%s)".
5061 " but command line specifies %s",
5062 $subcommand, $isuite, $csuite, $specsuite;
5071 #---------- remote commands' implementation ----------
5073 sub pre_remote_push_build_host {
5074 my ($nrargs) = shift @ARGV;
5075 my (@rargs) = @ARGV[0..$nrargs-1];
5076 @ARGV = @ARGV[$nrargs..$#ARGV];
5078 my ($dir,$vsnwant) = @rargs;
5079 # vsnwant is a comma-separated list; we report which we have
5080 # chosen in our ready response (so other end can tell if they
5083 $we_are_responder = 1;
5084 $us .= " (build host)";
5086 open PI, "<&STDIN" or confess "$!";
5087 open STDIN, "/dev/null" or confess "$!";
5088 open PO, ">&STDOUT" or confess "$!";
5090 open STDOUT, ">&STDERR" or confess "$!";
5094 ($protovsn) = grep {
5095 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5096 } @rpushprotovsn_support;
5098 fail f_ "build host has dgit rpush protocol versions %s".
5099 " but invocation host has %s",
5100 (join ",", @rpushprotovsn_support), $vsnwant
5101 unless defined $protovsn;
5105 sub cmd_remote_push_build_host {
5106 responder_send_command("dgit-remote-push-ready $protovsn");
5110 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5111 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5112 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5113 # a good error message)
5115 sub rpush_handle_protovsn_bothends () {
5122 my $report = i_child_report();
5123 if (defined $report) {
5124 printdebug "($report)\n";
5125 } elsif ($i_child_pid) {
5126 printdebug "(killing build host child $i_child_pid)\n";
5127 kill 15, $i_child_pid;
5129 if (defined $i_tmp && !defined $initiator_tempdir) {
5131 eval { rmtree $i_tmp; };
5136 return unless forkcheck_mainprocess();
5141 my ($base,$selector,@args) = @_;
5142 $selector =~ s/\-/_/g;
5143 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5147 not_necessarily_a_tree();
5152 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5160 push @rargs, join ",", @rpushprotovsn_support;
5163 push @rdgit, @ropts;
5164 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5166 my @cmd = (@ssh, $host, shellquote @rdgit);
5169 $we_are_initiator=1;
5171 if (defined $initiator_tempdir) {
5172 rmtree $initiator_tempdir;
5173 mkdir $initiator_tempdir, 0700
5174 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5175 $i_tmp = $initiator_tempdir;
5179 $i_child_pid = open2(\*RO, \*RI, @cmd);
5181 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5182 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5185 my ($icmd,$iargs) = initiator_expect {
5186 m/^(\S+)(?: (.*))?$/;
5189 i_method "i_resp", $icmd, $iargs;
5193 sub i_resp_progress ($) {
5195 my $msg = protocol_read_bytes \*RO, $rhs;
5199 sub i_resp_supplementary_message ($) {
5201 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5204 sub i_resp_complete {
5205 my $pid = $i_child_pid;
5206 $i_child_pid = undef; # prevents killing some other process with same pid
5207 printdebug "waiting for build host child $pid...\n";
5208 my $got = waitpid $pid, 0;
5209 confess "$!" unless $got == $pid;
5210 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5213 printdebug __ "all done\n";
5217 sub i_resp_file ($) {
5219 my $localname = i_method "i_localname", $keyword;
5220 my $localpath = "$i_tmp/$localname";
5221 stat_exists $localpath and
5222 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5223 protocol_receive_file \*RO, $localpath;
5224 i_method "i_file", $keyword;
5229 sub i_resp_param ($) {
5230 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5234 sub i_resp_previously ($) {
5235 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5236 or badproto \*RO, __ "bad previously spec";
5237 my $r = system qw(git check-ref-format), $1;
5238 confess "bad previously ref spec ($r)" if $r;
5239 $previously{$1} = $2;
5243 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5245 sub i_resp_want ($) {
5247 die "$keyword ?" if $i_wanted{$keyword}++;
5249 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5250 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5251 die unless $isuite =~ m/^$suite_re$/;
5253 if (!defined $dsc) {
5255 rpush_handle_protovsn_bothends();
5256 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5257 if ($protovsn >= 6) {
5258 determine_whether_split_brain getfield $dsc, 'Format';
5259 $do_split_brain eq ($i_param{'splitbrain'} // '<unsent>')
5261 "split brain mismatch, $do_split_brain != $i_param{'split_brain'}";
5262 printdebug "rpush split brain $do_split_brain\n";
5266 my @localpaths = i_method "i_want", $keyword;
5267 printdebug "[[ $keyword @localpaths\n";
5268 foreach my $localpath (@localpaths) {
5269 protocol_send_file \*RI, $localpath;
5271 print RI "files-end\n" or confess "$!";
5274 sub i_localname_parsed_changelog {
5275 return "remote-changelog.822";
5277 sub i_file_parsed_changelog {
5278 ($i_clogp, $i_version, $i_dscfn) =
5279 push_parse_changelog "$i_tmp/remote-changelog.822";
5280 die if $i_dscfn =~ m#/|^\W#;
5283 sub i_localname_dsc {
5284 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5289 sub i_localname_buildinfo ($) {
5290 my $bi = $i_param{'buildinfo-filename'};
5291 defined $bi or badproto \*RO, "buildinfo before filename";
5292 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5293 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5294 or badproto \*RO, "improper buildinfo filename";
5297 sub i_file_buildinfo {
5298 my $bi = $i_param{'buildinfo-filename'};
5299 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5300 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5301 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5302 files_compare_inputs($bd, $ch);
5303 (getfield $bd, $_) eq (getfield $ch, $_) or
5304 fail f_ "buildinfo mismatch in field %s", $_
5305 foreach qw(Source Version);
5306 !defined $bd->{$_} or
5307 fail f_ "buildinfo contains forbidden field %s", $_
5308 foreach qw(Changes Changed-by Distribution);
5310 push @i_buildinfos, $bi;
5311 delete $i_param{'buildinfo-filename'};
5314 sub i_localname_changes {
5315 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5316 $i_changesfn = $i_dscfn;
5317 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5318 return $i_changesfn;
5320 sub i_file_changes { }
5322 sub i_want_signed_tag {
5323 printdebug Dumper(\%i_param, $i_dscfn);
5324 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5325 && defined $i_param{'csuite'}
5326 or badproto \*RO, "premature desire for signed-tag";
5327 my $head = $i_param{'head'};
5328 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5330 my $maintview = $i_param{'maint-view'};
5331 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5333 if ($protovsn == 4) {
5334 my $p = $i_param{'tagformat'} // '<undef>';
5336 or badproto \*RO, "tag format mismatch: $p vs. new";
5339 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5341 defined $dsc or badproto \*RO, "dsc (before parsed-changelog)";
5343 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5346 push_mktags $i_clogp, $i_dscfn,
5347 $i_changesfn, (__ 'remote changes file'),
5351 sub i_want_signed_dsc_changes {
5352 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5353 sign_changes $i_changesfn;
5354 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5357 #---------- building etc. ----------
5363 #----- `3.0 (quilt)' handling -----
5365 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5367 sub quiltify_dpkg_commit ($$$;$) {
5368 my ($patchname,$author,$msg, $xinfo) = @_;
5371 mkpath '.git/dgit'; # we are in playtree
5372 my $descfn = ".git/dgit/quilt-description.tmp";
5373 open O, '>', $descfn or confess "$descfn: $!";
5374 $msg =~ s/\n+/\n\n/;
5375 print O <<END or confess "$!";
5377 ${xinfo}Subject: $msg
5381 close O or confess "$!";
5384 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5385 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5386 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5387 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5391 sub quiltify_trees_differ ($$;$$$) {
5392 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5393 # returns true iff the two tree objects differ other than in debian/
5394 # with $finegrained,
5395 # returns bitmask 01 - differ in upstream files except .gitignore
5396 # 02 - differ in .gitignore
5397 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5398 # is set for each modified .gitignore filename $fn
5399 # if $unrepres is defined, array ref to which is appeneded
5400 # a list of unrepresentable changes (removals of upstream files
5403 my @cmd = (@git, qw(diff-tree -z --no-renames));
5404 push @cmd, qw(--name-only) unless $unrepres;
5405 push @cmd, qw(-r) if $finegrained || $unrepres;
5407 my $diffs= cmdoutput @cmd;
5410 foreach my $f (split /\0/, $diffs) {
5411 if ($unrepres && !@lmodes) {
5412 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5415 my ($oldmode,$newmode) = @lmodes;
5418 next if $f =~ m#^debian(?:/.*)?$#s;
5422 die __ "not a plain file or symlink\n"
5423 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5424 $oldmode =~ m/^(?:10|12)\d{4}$/;
5425 if ($oldmode =~ m/[^0]/ &&
5426 $newmode =~ m/[^0]/) {
5427 # both old and new files exist
5428 die __ "mode or type changed\n" if $oldmode ne $newmode;
5429 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5430 } elsif ($oldmode =~ m/[^0]/) {
5432 die __ "deletion of symlink\n"
5433 unless $oldmode =~ m/^10/;
5436 die __ "creation with non-default mode\n"
5437 unless $newmode =~ m/^100644$/ or
5438 $newmode =~ m/^120000$/;
5442 local $/="\n"; chomp $@;
5443 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5447 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5448 $r |= $isignore ? 02 : 01;
5449 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5451 printdebug "quiltify_trees_differ $x $y => $r\n";
5455 sub quiltify_tree_sentinelfiles ($) {
5456 # lists the `sentinel' files present in the tree
5458 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5459 qw(-- debian/rules debian/control);
5464 sub quiltify_splitting ($$$$$$$) {
5465 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5466 $editedignores, $cachekey) = @_;
5467 my $gitignore_special = 1;
5468 if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
5469 # treat .gitignore just like any other upstream file
5470 $diffbits = { %$diffbits };
5471 $_ = !!$_ foreach values %$diffbits;
5472 $gitignore_special = 0;
5474 # We would like any commits we generate to be reproducible
5475 my @authline = clogp_authline($clogp);
5476 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5477 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5478 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5479 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5480 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5481 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5483 confess unless do_split_brain();
5485 my $fulldiffhint = sub {
5487 my $cmd = "git diff $x $y -- :/ ':!debian'";
5488 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5489 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5493 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5494 ($diffbits->{O2H} & 01)) {
5496 "--quilt=%s specified, implying patches-unapplied git tree\n".
5497 " but git tree differs from orig in upstream files.",
5499 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5500 if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
5502 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5506 if ($quilt_mode =~ m/dpm/ &&
5507 ($diffbits->{H2A} & 01)) {
5508 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5509 --quilt=%s specified, implying patches-applied git tree
5510 but git tree differs from result of applying debian/patches to upstream
5513 if ($quilt_mode =~ m/baredebian/) {
5514 # We need to construct a merge which has upstream files from
5515 # upstream and debian/ files from HEAD.
5517 read_tree_upstream $quilt_upstream_commitish, 1, $headref;
5518 my $version = getfield $clogp, 'Version';
5519 my $upsversion = upstreamversion $version;
5520 my $merge = make_commit
5521 [ $headref, $quilt_upstream_commitish ],
5522 [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
5523 Combine debian/ with upstream source for %s
5525 [dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
5527 runcmd @git, qw(reset -q --hard), $merge;
5529 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5530 ($diffbits->{O2A} & 01)) { # some patches
5531 progress __ "dgit view: creating patches-applied version using gbp pq";
5532 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5533 # gbp pq import creates a fresh branch; push back to dgit-view
5534 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5535 runcmd @git, qw(checkout -q dgit-view);
5537 if ($quilt_mode =~ m/gbp|dpm/ &&
5538 ($diffbits->{O2A} & 02)) {
5539 fail f_ <<END, $quilt_mode;
5540 --quilt=%s specified, implying that HEAD is for use with a
5541 tool which does not create patches for changes to upstream
5542 .gitignores: but, such patches exist in debian/patches.
5545 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5546 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5548 "dgit view: creating patch to represent .gitignore changes";
5549 ensuredir "debian/patches";
5550 my $gipatch = "debian/patches/auto-gitignore";
5551 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5552 stat GIPATCH or confess "$gipatch: $!";
5553 fail f_ "%s already exists; but want to create it".
5554 " to record .gitignore changes",
5557 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5558 Subject: Update .gitignore from Debian packaging branch
5560 The Debian packaging git branch contains these updates to the upstream
5561 .gitignore file(s). This patch is autogenerated, to provide these
5562 updates to users of the official Debian archive view of the package.
5565 [dgit ($our_version) update-gitignore]
5568 close GIPATCH or die "$gipatch: $!";
5569 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5570 $unapplied, $headref, "--", sort keys %$editedignores;
5571 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5572 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5574 defined read SERIES, $newline, 1 or confess "$!";
5575 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5576 print SERIES "auto-gitignore\n" or confess "$!";
5577 close SERIES or die $!;
5578 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5579 commit_admin +(__ <<END).<<ENDU
5580 Commit patch to update .gitignore
5583 [dgit ($our_version) update-gitignore-quilt-fixup]
5588 sub quiltify ($$$$) {
5589 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5591 # Quilt patchification algorithm
5593 # We search backwards through the history of the main tree's HEAD
5594 # (T) looking for a start commit S whose tree object is identical
5595 # to to the patch tip tree (ie the tree corresponding to the
5596 # current dpkg-committed patch series). For these purposes
5597 # `identical' disregards anything in debian/ - this wrinkle is
5598 # necessary because dpkg-source treates debian/ specially.
5600 # We can only traverse edges where at most one of the ancestors'
5601 # trees differs (in changes outside in debian/). And we cannot
5602 # handle edges which change .pc/ or debian/patches. To avoid
5603 # going down a rathole we avoid traversing edges which introduce
5604 # debian/rules or debian/control. And we set a limit on the
5605 # number of edges we are willing to look at.
5607 # If we succeed, we walk forwards again. For each traversed edge
5608 # PC (with P parent, C child) (starting with P=S and ending with
5609 # C=T) to we do this:
5611 # - dpkg-source --commit with a patch name and message derived from C
5612 # After traversing PT, we git commit the changes which
5613 # should be contained within debian/patches.
5615 # The search for the path S..T is breadth-first. We maintain a
5616 # todo list containing search nodes. A search node identifies a
5617 # commit, and looks something like this:
5619 # Commit => $git_commit_id,
5620 # Child => $c, # or undef if P=T
5621 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5622 # Nontrivial => true iff $p..$c has relevant changes
5629 my %considered; # saves being exponential on some weird graphs
5631 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5634 my ($search,$whynot) = @_;
5635 printdebug " search NOT $search->{Commit} $whynot\n";
5636 $search->{Whynot} = $whynot;
5637 push @nots, $search;
5638 no warnings qw(exiting);
5647 my $c = shift @todo;
5648 next if $considered{$c->{Commit}}++;
5650 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5652 printdebug "quiltify investigate $c->{Commit}\n";
5655 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5656 printdebug " search finished hooray!\n";
5661 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5662 if ($quilt_mode eq 'smash') {
5663 printdebug " search quitting smash\n";
5667 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5668 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5669 if $c_sentinels ne $t_sentinels;
5671 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5672 $commitdata =~ m/\n\n/;
5674 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5675 @parents = map { { Commit => $_, Child => $c } } @parents;
5677 $not->($c, __ "root commit") if !@parents;
5679 foreach my $p (@parents) {
5680 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5682 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5683 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5686 foreach my $p (@parents) {
5687 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5689 my @cmd= (@git, qw(diff-tree -r --name-only),
5690 $p->{Commit},$c->{Commit},
5691 qw(-- debian/patches .pc debian/source/format));
5692 my $patchstackchange = cmdoutput @cmd;
5693 if (length $patchstackchange) {
5694 $patchstackchange =~ s/\n/,/g;
5695 $not->($p, f_ "changed %s", $patchstackchange);
5698 printdebug " search queue P=$p->{Commit} ",
5699 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5705 printdebug "quiltify want to smash\n";
5708 my $x = $_[0]{Commit};
5709 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5712 if ($quilt_mode eq 'linear') {
5714 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5716 my $all_gdr = !!@nots;
5717 foreach my $notp (@nots) {
5718 my $c = $notp->{Child};
5719 my $cprange = $abbrev->($notp);
5720 $cprange .= "..".$abbrev->($c) if $c;
5721 print STDERR f_ "%s: %s: %s\n",
5722 $us, $cprange, $notp->{Whynot};
5723 $all_gdr &&= $notp->{Child} &&
5724 (git_cat_file $notp->{Child}{Commit}, 'commit')
5725 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5729 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5731 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5733 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5734 } elsif ($quilt_mode eq 'smash') {
5735 } elsif ($quilt_mode eq 'auto') {
5736 progress __ "quilt fixup cannot be linear, smashing...";
5738 confess "$quilt_mode ?";
5741 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5742 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5744 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5746 quiltify_dpkg_commit "auto-$version-$target-$time",
5747 (getfield $clogp, 'Maintainer'),
5748 (f_ "Automatically generated patch (%s)\n".
5749 "Last (up to) %s git changes, FYI:\n\n",
5750 $clogp->{Version}, $ncommits).
5755 progress __ "quiltify linearisation planning successful, executing...";
5757 for (my $p = $sref_S;
5758 my $c = $p->{Child};
5760 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5761 next unless $p->{Nontrivial};
5763 my $cc = $c->{Commit};
5765 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5766 $commitdata =~ m/\n\n/ or die "$c ?";
5769 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5772 my $commitdate = cmdoutput
5773 @git, qw(log -n1 --pretty=format:%aD), $cc;
5775 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5777 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5784 my $gbp_check_suitable = sub {
5789 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5790 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5791 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5792 die __ "is series file\n" if m{$series_filename_re}o;
5793 die __ "too long\n" if length > 200;
5795 return $_ unless $@;
5797 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5802 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5804 (\S+) \s* \n //ixm) {
5805 $patchname = $gbp_check_suitable->($1, 'Name');
5807 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5809 (\S+) \s* \n //ixm) {
5810 $patchdir = $gbp_check_suitable->($1, 'Topic');
5815 if (!defined $patchname) {
5816 $patchname = $title;
5817 $patchname =~ s/[.:]$//;
5820 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5821 my $translitname = $converter->convert($patchname);
5822 die unless defined $translitname;
5823 $patchname = $translitname;
5826 +(f_ "dgit: patch title transliteration error: %s", $@)
5828 $patchname =~ y/ A-Z/-a-z/;
5829 $patchname =~ y/-a-z0-9_.+=~//cd;
5830 $patchname =~ s/^\W/x-$&/;
5831 $patchname = substr($patchname,0,40);
5832 $patchname .= ".patch";
5834 if (!defined $patchdir) {
5837 if (length $patchdir) {
5838 $patchname = "$patchdir/$patchname";
5840 if ($patchname =~ m{^(.*)/}) {
5841 mkpath "debian/patches/$1";
5846 stat "debian/patches/$patchname$index";
5848 $!==ENOENT or confess "$patchname$index $!";
5850 runcmd @git, qw(checkout -q), $cc;
5852 # We use the tip's changelog so that dpkg-source doesn't
5853 # produce complaining messages from dpkg-parsechangelog. None
5854 # of the information dpkg-source gets from the changelog is
5855 # actually relevant - it gets put into the original message
5856 # which dpkg-source provides our stunt editor, and then
5858 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5860 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5861 "Date: $commitdate\n".
5862 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5864 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5868 sub build_maybe_quilt_fixup () {
5869 my ($format,$fopts) = get_source_format;
5870 return unless madformat_wantfixup $format;
5873 check_for_vendor_patches();
5875 my $clogp = parsechangelog();
5876 my $headref = git_rev_parse('HEAD');
5877 my $symref = git_get_symref();
5878 my $upstreamversion = upstreamversion $version;
5881 changedir $playground;
5883 my $splitbrain_cachekey;
5885 if (do_split_brain()) {
5887 ($cachehit, $splitbrain_cachekey) =
5888 quilt_check_splitbrain_cache($headref, $upstreamversion);
5895 unpack_playtree_need_cd_work($headref);
5896 if (do_split_brain()) {
5897 runcmd @git, qw(checkout -q -b dgit-view);
5898 # so long as work is not deleted, its current branch will
5899 # remain dgit-view, rather than master, so subsequent calls to
5900 # unpack_playtree_need_cd_work
5901 # will DTRT, resetting dgit-view.
5902 confess if $made_split_brain;
5903 $made_split_brain = 1;
5907 if ($fopts->{'single-debian-patch'}) {
5909 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5911 if quiltmode_splitting();
5912 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5914 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5915 $splitbrain_cachekey);
5918 if (do_split_brain()) {
5919 my $dgitview = git_rev_parse 'HEAD';
5922 reflog_cache_insert "refs/$splitbraincache",
5923 $splitbrain_cachekey, $dgitview;
5925 changedir "$playground/work";
5927 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5928 progress f_ "dgit view: created (%s)", $saved;
5932 runcmd_ordryrun_local
5933 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5936 sub build_check_quilt_splitbrain () {
5937 build_maybe_quilt_fixup();
5940 sub unpack_playtree_need_cd_work ($) {
5943 # prep_ud() must have been called already.
5944 if (!chdir "work") {
5945 # Check in the filesystem because sometimes we run prep_ud
5946 # in between multiple calls to unpack_playtree_need_cd_work.
5947 confess "$!" unless $!==ENOENT;
5948 mkdir "work" or confess "$!";
5950 mktree_in_ud_here();
5952 runcmd @git, qw(reset -q --hard), $headref;
5955 sub unpack_playtree_linkorigs ($$) {
5956 my ($upstreamversion, $fn) = @_;
5957 # calls $fn->($leafname);
5959 my $bpd_abs = bpd_abs();
5961 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5963 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5964 while ($!=0, defined(my $leaf = readdir QFD)) {
5965 my $f = bpd_abs()."/".$leaf;
5967 local ($debuglevel) = $debuglevel-1;
5968 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5970 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5971 printdebug "QF linkorigs $leaf, $f Y\n";
5972 link_ltarget $f, $leaf or die "$leaf $!";
5975 die "$buildproductsdir: $!" if $!;
5979 sub quilt_fixup_delete_pc () {
5980 runcmd @git, qw(rm -rqf .pc);
5981 commit_admin +(__ <<END).<<ENDU
5982 Commit removal of .pc (quilt series tracking data)
5985 [dgit ($our_version) upgrade quilt-remove-pc]
5989 sub quilt_fixup_singlepatch ($$$) {
5990 my ($clogp, $headref, $upstreamversion) = @_;
5992 progress __ "starting quiltify (single-debian-patch)";
5994 # dpkg-source --commit generates new patches even if
5995 # single-debian-patch is in debian/source/options. In order to
5996 # get it to generate debian/patches/debian-changes, it is
5997 # necessary to build the source package.
5999 unpack_playtree_linkorigs($upstreamversion, sub { });
6000 unpack_playtree_need_cd_work($headref);
6002 rmtree("debian/patches");
6004 runcmd @dpkgsource, qw(-b .);
6006 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
6007 rename srcfn("$upstreamversion", "/debian/patches"),
6008 "work/debian/patches"
6010 or confess "install d/patches: $!";
6013 commit_quilty_patch();
6016 sub quilt_need_fake_dsc ($) {
6017 # cwd should be playground
6018 my ($upstreamversion) = @_;
6020 return if stat_exists "fake.dsc";
6021 # ^ OK to test this as a sentinel because if we created it
6022 # we must either have done the rest too, or crashed.
6024 my $fakeversion="$upstreamversion-~~DGITFAKE";
6026 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
6027 print $fakedsc <<END or confess "$!";
6030 Version: $fakeversion
6034 my $dscaddfile=sub {
6037 my $md = new Digest::MD5;
6039 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
6040 stat $fh or confess "$!";
6044 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
6047 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
6049 my @files=qw(debian/source/format debian/rules
6050 debian/control debian/changelog);
6051 foreach my $maybe (qw(debian/patches debian/source/options
6052 debian/tests/control)) {
6053 next unless stat_exists "$maindir/$maybe";
6054 push @files, $maybe;
6057 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
6058 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
6060 $dscaddfile->($debtar);
6061 close $fakedsc or confess "$!";
6064 sub quilt_fakedsc2unapplied ($$) {
6065 my ($headref, $upstreamversion) = @_;
6066 # must be run in the playground
6067 # quilt_need_fake_dsc must have been called
6069 quilt_need_fake_dsc($upstreamversion);
6071 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
6073 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
6074 rename $fakexdir, "fake" or die "$fakexdir $!";
6078 remove_stray_gits(__ "source package");
6079 mktree_in_ud_here();
6083 rmtree 'debian'; # git checkout commitish paths does not delete!
6084 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
6085 my $unapplied=git_add_write_tree();
6086 printdebug "fake orig tree object $unapplied\n";
6090 sub quilt_check_splitbrain_cache ($$) {
6091 my ($headref, $upstreamversion) = @_;
6092 # Called only if we are in (potentially) split brain mode.
6093 # Called in playground.
6094 # Computes the cache key and looks in the cache.
6095 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
6097 quilt_need_fake_dsc($upstreamversion);
6099 my $splitbrain_cachekey;
6102 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6104 # we look in the reflog of dgit-intern/quilt-cache
6105 # we look for an entry whose message is the key for the cache lookup
6106 my @cachekey = (qw(dgit), $our_version);
6107 push @cachekey, $upstreamversion;
6108 push @cachekey, $quilt_mode;
6109 push @cachekey, $headref;
6110 push @cachekey, $quilt_upstream_commitish // '-';
6112 push @cachekey, hashfile('fake.dsc');
6114 my $srcshash = Digest::SHA->new(256);
6115 my %sfs = ( %INC, '$0(dgit)' => $0 );
6116 foreach my $sfk (sort keys %sfs) {
6117 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6118 $srcshash->add($sfk," ");
6119 $srcshash->add(hashfile($sfs{$sfk}));
6120 $srcshash->add("\n");
6122 push @cachekey, $srcshash->hexdigest();
6123 $splitbrain_cachekey = "@cachekey";
6125 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6127 my $cachehit = reflog_cache_lookup
6128 "refs/$splitbraincache", $splitbrain_cachekey;
6131 unpack_playtree_need_cd_work($headref);
6132 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6133 if ($cachehit ne $headref) {
6134 progress f_ "dgit view: found cached (%s)", $saved;
6135 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6136 $made_split_brain = 1;
6137 return ($cachehit, $splitbrain_cachekey);
6139 progress __ "dgit view: found cached, no changes required";
6140 return ($headref, $splitbrain_cachekey);
6143 printdebug "splitbrain cache miss\n";
6144 return (undef, $splitbrain_cachekey);
6147 sub baredebian_origtarballs_scan ($$$) {
6148 my ($fakedfi, $upstreamversion, $dir) = @_;
6149 if (!opendir OD, $dir) {
6150 return if $! == ENOENT;
6151 fail "opendir $dir (origs): $!";
6154 while ($!=0, defined(my $leaf = readdir OD)) {
6156 local ($debuglevel) = $debuglevel-1;
6157 printdebug "BDOS $dir $leaf ?\n";
6159 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
6160 next if grep { $_->{Filename} eq $leaf } @$fakedfi;
6163 Path => "$dir/$leaf",
6167 die "$dir; $!" if $!;
6171 sub quilt_fixup_multipatch ($$$) {
6172 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6174 progress f_ "examining quilt state (multiple patches, %s mode)",
6178 # - honour any existing .pc in case it has any strangeness
6179 # - determine the git commit corresponding to the tip of
6180 # the patch stack (if there is one)
6181 # - if there is such a git commit, convert each subsequent
6182 # git commit into a quilt patch with dpkg-source --commit
6183 # - otherwise convert all the differences in the tree into
6184 # a single git commit
6188 # Our git tree doesn't necessarily contain .pc. (Some versions of
6189 # dgit would include the .pc in the git tree.) If there isn't
6190 # one, we need to generate one by unpacking the patches that we
6193 # We first look for a .pc in the git tree. If there is one, we
6194 # will use it. (This is not the normal case.)
6196 # Otherwise need to regenerate .pc so that dpkg-source --commit
6197 # can work. We do this as follows:
6198 # 1. Collect all relevant .orig from parent directory
6199 # 2. Generate a debian.tar.gz out of
6200 # debian/{patches,rules,source/format,source/options}
6201 # 3. Generate a fake .dsc containing just these fields:
6202 # Format Source Version Files
6203 # 4. Extract the fake .dsc
6204 # Now the fake .dsc has a .pc directory.
6205 # (In fact we do this in every case, because in future we will
6206 # want to search for a good base commit for generating patches.)
6208 # Then we can actually do the dpkg-source --commit
6209 # 1. Make a new working tree with the same object
6210 # store as our main tree and check out the main
6212 # 2. Copy .pc from the fake's extraction, if necessary
6213 # 3. Run dpkg-source --commit
6214 # 4. If the result has changes to debian/, then
6215 # - git add them them
6216 # - git add .pc if we had a .pc in-tree
6218 # 5. If we had a .pc in-tree, delete it, and git commit
6219 # 6. Back in the main tree, fast forward to the new HEAD
6221 # Another situation we may have to cope with is gbp-style
6222 # patches-unapplied trees.
6224 # We would want to detect these, so we know to escape into
6225 # quilt_fixup_gbp. However, this is in general not possible.
6226 # Consider a package with a one patch which the dgit user reverts
6227 # (with git revert or the moral equivalent).
6229 # That is indistinguishable in contents from a patches-unapplied
6230 # tree. And looking at the history to distinguish them is not
6231 # useful because the user might have made a confusing-looking git
6232 # history structure (which ought to produce an error if dgit can't
6233 # cope, not a silent reintroduction of an unwanted patch).
6235 # So gbp users will have to pass an option. But we can usually
6236 # detect their failure to do so: if the tree is not a clean
6237 # patches-applied tree, quilt linearisation fails, but the tree
6238 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6239 # they want --quilt=unapplied.
6241 # To help detect this, when we are extracting the fake dsc, we
6242 # first extract it with --skip-patches, and then apply the patches
6243 # afterwards with dpkg-source --before-build. That lets us save a
6244 # tree object corresponding to .origs.
6246 if ($quilt_mode eq 'linear'
6247 && branch_is_gdr($headref)) {
6248 # This is much faster. It also makes patches that gdr
6249 # likes better for future updates without laundering.
6251 # However, it can fail in some casses where we would
6252 # succeed: if there are existing patches, which correspond
6253 # to a prefix of the branch, but are not in gbp/gdr
6254 # format, gdr will fail (exiting status 7), but we might
6255 # be able to figure out where to start linearising. That
6256 # will be slower so hopefully there's not much to do.
6258 unpack_playtree_need_cd_work $headref;
6260 my @cmd = (@git_debrebase,
6261 qw(--noop-ok -funclean-mixed -funclean-ordering
6262 make-patches --quiet-would-amend));
6263 # We tolerate soe snags that gdr wouldn't, by default.
6269 and not ($? == 7*256 or
6270 $? == -1 && $!==ENOENT);
6274 $headref = git_rev_parse('HEAD');
6279 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6283 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6285 if (system @bbcmd) {
6286 failedcmd @bbcmd if $? < 0;
6288 failed to apply your git tree's patch stack (from debian/patches/) to
6289 the corresponding upstream tarball(s). Your source tree and .orig
6290 are probably too inconsistent. dgit can only fix up certain kinds of
6291 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6297 unpack_playtree_need_cd_work($headref);
6300 if (stat_exists ".pc") {
6302 progress __ "Tree already contains .pc - will use it then delete it.";
6305 rename '../fake/.pc','.pc' or confess "$!";
6308 changedir '../fake';
6310 my $oldtiptree=git_add_write_tree();
6311 printdebug "fake o+d/p tree object $unapplied\n";
6312 changedir '../work';
6315 # We calculate some guesswork now about what kind of tree this might
6316 # be. This is mostly for error reporting.
6318 my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
6319 my $onlydebian = $tentries eq "debian\0";
6321 my $uheadref = $headref;
6322 my $uhead_whatshort = 'HEAD';
6324 if ($quilt_mode =~ m/baredebian\+tarball/) {
6325 # We need to make a tarball import. Yuk.
6326 # We want to do this here so that we have a $uheadref value
6329 baredebian_origtarballs_scan \@fakedfi, $upstreamversion, bpd_abs();
6330 baredebian_origtarballs_scan \@fakedfi, $upstreamversion,
6331 "$maindir/.." unless $buildproductsdir eq '..';
6334 my @tartrees = import_tarball_tartrees $upstreamversion, \@fakedfi;
6336 fail __ "baredebian quilt fixup: could not find any origs"
6340 my ($authline, $r1authline, $clogp,) =
6341 import_tarball_commits \@tartrees, $upstreamversion;
6343 if (@tartrees == 1) {
6344 $uheadref = $tartrees[0]{Commit};
6345 # TRANSLATORS: this translation must fit in the ASCII art
6346 # quilt differences display. The untranslated display
6347 # says %9.9s, so with that display it must be at most 9
6349 $uhead_whatshort = __ 'tarball';
6351 # on .dsc import we do not make a separate commit, but
6352 # here we need to do so
6353 rm_subdir_cached '.';
6355 foreach my $ti (@tartrees) {
6356 my $c = $ti->{Commit};
6357 if ($ti->{OrigPart} eq 'orig') {
6358 runcmd qw(git read-tree), $c;
6359 } elsif ($ti->{OrigPart} =~ m/orig-/) {
6360 read_tree_subdir $', $c;
6362 confess "$ti->OrigPart} ?"
6364 $parents .= "parent $c\n";
6366 my $tree = git_write_tree();
6367 my $mbody = f_ 'Combine orig tarballs for %s %s',
6368 $package, $upstreamversion;
6369 $uheadref = hash_commit_text <<END;
6371 ${parents}author $r1authline
6372 committer $r1authline
6376 [dgit import tarballs combine $package $upstreamversion]
6378 # TRANSLATORS: this translation must fit in the ASCII art
6379 # quilt differences display. The untranslated display
6380 # says %9.9s, so with that display it must be at most 9
6381 # characters. This fragmentt is referring to multiple
6382 # orig tarballs in a source package.
6383 $uhead_whatshort = __ 'tarballs';
6385 runcmd @git, qw(reset -q);
6387 $quilt_upstream_commitish = $uheadref;
6388 $quilt_upstream_commitish_used = '*orig*';
6389 $quilt_upstream_commitish_message = '';
6391 if ($quilt_mode =~ m/baredebian$/) {
6392 $uheadref = $quilt_upstream_commitish;
6393 # TRANSLATORS: this translation must fit in the ASCII art
6394 # quilt differences display. The untranslated display
6395 # says %9.9s, so with that display it must be at most 9
6397 $uhead_whatshort = __ 'upstream';
6404 # O = orig, without patches applied
6405 # A = "applied", ie orig with H's debian/patches applied
6406 O2H => quiltify_trees_differ($unapplied,$uheadref, 1,
6407 \%editedignores, \@unrepres),
6408 H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
6409 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6413 foreach my $bits (qw(01 02)) {
6414 foreach my $v (qw(O2H O2A H2A)) {
6415 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6418 printdebug "differences \@dl @dl.\n";
6421 "%s: base trees orig=%.20s o+d/p=%.20s",
6422 $us, $unapplied, $oldtiptree;
6423 # TRANSLATORS: Try to keep this ascii-art layout right. The 0s in
6424 # %9.00009s will be ignored and are there to make the format the
6425 # same length (9 characters) as the output it generates. If you
6426 # change the value 9, your translations of "upstream" and
6427 # 'tarball' must fit into the new length, and you should change
6428 # the number of 0s. Do not reduce it below 4 as HEAD has to fit
6431 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6432 "%s: quilt differences: %9.00009s %s o+d/p %9.00009s %s o+d/p",
6433 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6434 $us, $uhead_whatshort, $dl[2], $uhead_whatshort, $dl[5];
6436 if (@unrepres && $quilt_mode !~ m/baredebian/) {
6437 # With baredebian, even if the upstream commitish has this
6438 # problem, we don't want to print this message, as nothing
6439 # is going to try to make a patch out of it anyway.
6440 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6443 forceable_fail [qw(unrepresentable)], __ <<END;
6444 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6450 push @failsuggestion, [ 'onlydebian', __
6451 "This has only a debian/ directory; you probably want --quilt=bare debian." ]
6452 unless $quilt_mode =~ m/baredebian/;
6453 } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
6454 push @failsuggestion, [ 'unapplied', __
6455 "This might be a patches-unapplied branch." ];
6456 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6457 push @failsuggestion, [ 'applied', __
6458 "This might be a patches-applied branch." ];
6460 push @failsuggestion, [ 'quilt-mode', __
6461 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6463 push @failsuggestion, [ 'gitattrs', __
6464 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6465 if stat_exists '.gitattributes';
6467 push @failsuggestion, [ 'origs', __
6468 "Maybe orig tarball(s) are not identical to git representation?" ]
6469 unless $onlydebian && $quilt_mode !~ m/baredebian/;
6470 # ^ in that case, we didn't really look properly
6472 if (quiltmode_splitting()) {
6473 quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6474 $diffbits, \%editedignores,
6475 $splitbrain_cachekey);
6479 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6480 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6481 runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6483 if (!open P, '>>', ".pc/applied-patches") {
6484 $!==&ENOENT or confess "$!";
6489 commit_quilty_patch();
6491 if ($mustdeletepc) {
6492 quilt_fixup_delete_pc();
6496 sub quilt_fixup_editor () {
6497 my $descfn = $ENV{$fakeeditorenv};
6498 my $editing = $ARGV[$#ARGV];
6499 open I1, '<', $descfn or confess "$descfn: $!";
6500 open I2, '<', $editing or confess "$editing: $!";
6501 unlink $editing or confess "$editing: $!";
6502 open O, '>', $editing or confess "$editing: $!";
6503 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6506 $copying ||= m/^\-\-\- /;
6507 next unless $copying;
6508 print O or confess "$!";
6510 I2->error and confess "$!";
6515 sub maybe_apply_patches_dirtily () {
6516 return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
6517 print STDERR __ <<END or confess "$!";
6519 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6520 dgit: Have to apply the patches - making the tree dirty.
6521 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6524 $patches_applied_dirtily = 01;
6525 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6526 runcmd qw(dpkg-source --before-build .);
6529 sub maybe_unapply_patches_again () {
6530 progress __ "dgit: Unapplying patches again to tidy up the tree."
6531 if $patches_applied_dirtily;
6532 runcmd qw(dpkg-source --after-build .)
6533 if $patches_applied_dirtily & 01;
6535 if $patches_applied_dirtily & 02;
6536 $patches_applied_dirtily = 0;
6539 #----- other building -----
6541 sub clean_tree_check_git ($$$) {
6542 my ($honour_ignores, $message, $ignmessage) = @_;
6543 my @cmd = (@git, qw(clean -dn));
6544 push @cmd, qw(-x) unless $honour_ignores;
6545 my $leftovers = cmdoutput @cmd;
6546 if (length $leftovers) {
6547 print STDERR $leftovers, "\n" or confess "$!";
6548 $message .= $ignmessage if $honour_ignores;
6553 sub clean_tree_check_git_wd ($) {
6555 return if $cleanmode =~ m{no-check};
6556 return if $patches_applied_dirtily; # yuk
6557 clean_tree_check_git +($cleanmode !~ m{all-check}),
6558 $message, "\n".__ <<END;
6559 If this is just missing .gitignore entries, use a different clean
6560 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6561 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6565 sub clean_tree_check () {
6566 # This function needs to not care about modified but tracked files.
6567 # That was done by check_not_dirty, and by now we may have run
6568 # the rules clean target which might modify tracked files (!)
6569 if ($cleanmode =~ m{^check}) {
6570 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6571 "tree contains uncommitted files and --clean=check specified", '';
6572 } elsif ($cleanmode =~ m{^dpkg-source}) {
6573 clean_tree_check_git_wd __
6574 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6575 } elsif ($cleanmode =~ m{^git}) {
6576 clean_tree_check_git 1, __
6577 "tree contains uncommited, untracked, unignored files\n".
6578 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6579 } elsif ($cleanmode eq 'none') {
6581 confess "$cleanmode ?";
6586 # We always clean the tree ourselves, rather than leave it to the
6587 # builder (dpkg-source, or soemthing which calls dpkg-source).
6588 if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
6589 fail f_ <<END, $quilt_mode, $cleanmode;
6590 quilt mode %s (generally needs untracked upstream files)
6591 contradicts clean mode %s (which would delete them)
6593 # This is not 100% true: dgit build-source and push-source
6594 # (for example) could operate just fine with no upstream
6595 # source in the working tree. But it doesn't seem likely that
6596 # the user wants dgit to proactively delete such things.
6597 # -wn, for example, would produce identical output without
6598 # deleting anything from the working tree.
6600 if ($cleanmode =~ m{^dpkg-source}) {
6601 my @cmd = @dpkgbuildpackage;
6602 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6603 push @cmd, qw(-T clean);
6604 maybe_apply_patches_dirtily();
6605 runcmd_ordryrun_local @cmd;
6606 clean_tree_check_git_wd __
6607 "tree contains uncommitted files (after running rules clean)";
6608 } elsif ($cleanmode =~ m{^git(?!-)}) {
6609 runcmd_ordryrun_local @git, qw(clean -xdf);
6610 } elsif ($cleanmode =~ m{^git-ff}) {
6611 runcmd_ordryrun_local @git, qw(clean -xdff);
6612 } elsif ($cleanmode =~ m{^check}) {
6614 } elsif ($cleanmode eq 'none') {
6616 confess "$cleanmode ?";
6621 badusage __ "clean takes no additional arguments" if @ARGV;
6624 maybe_unapply_patches_again();
6627 # return values from massage_dbp_args are one or both of these flags
6628 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6629 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6631 sub build_or_push_prep_early () {
6632 our $build_or_push_prep_early_done //= 0;
6633 return if $build_or_push_prep_early_done++;
6634 my $clogp = parsechangelog();
6635 $isuite = getfield $clogp, 'Distribution';
6636 my $gotpackage = getfield $clogp, 'Source';
6637 $version = getfield $clogp, 'Version';
6638 $package //= $gotpackage;
6639 if ($package ne $gotpackage) {
6640 fail f_ "-p specified package %s, but changelog says %s",
6641 $package, $gotpackage;
6643 $dscfn = dscfn($version);
6646 sub build_or_push_prep_modes () {
6647 my ($format) = get_source_format();
6648 determine_whether_split_brain($format);
6650 fail __ "dgit: --include-dirty is not supported with split view".
6651 " (including with view-splitting quilt modes)"
6652 if do_split_brain() && $includedirty;
6654 if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
6655 ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
6656 $quilt_upstream_commitish_message)
6657 = resolve_upstream_version
6658 $quilt_upstream_commitish, upstreamversion $version;
6659 progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
6660 $quilt_upstream_commitish_message;
6661 } elsif (defined $quilt_upstream_commitish) {
6663 "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
6667 sub build_prep_early () {
6668 build_or_push_prep_early();
6670 build_or_push_prep_modes();
6674 sub build_prep ($) {
6678 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6679 # Clean the tree because we're going to use the contents of
6680 # $maindir. (We trying to include dirty changes in the source
6681 # package, or we are running the builder in $maindir.)
6682 || $cleanmode =~ m{always}) {
6683 # Or because the user asked us to.
6686 # We don't actually need to do anything in $maindir, but we
6687 # should do some kind of cleanliness check because (i) the
6688 # user may have forgotten a `git add', and (ii) if the user
6689 # said -wc we should still do the check.
6692 build_check_quilt_splitbrain();
6694 my $pat = changespat $version;
6695 foreach my $f (glob "$buildproductsdir/$pat") {
6698 fail f_ "remove old changes file %s: %s", $f, $!;
6700 progress f_ "would remove %s", $f;
6706 sub maybe_warn_opt_confusion ($$$) {
6707 my ($subcommand, $willrun, $optsref) = @_;
6708 foreach (@$optsref) {
6709 if (m/^(?: --dry-run $
6711 | --clean= | -w[gcnd]
6712 | --(?:include|ignore)-dirty$
6713 | --quilt= | --gbp$ | --dpm$ | --baredebian
6715 | --build-products-dir=
6717 print STDERR f_ <<END, $&, $subcommand or die $!;
6718 warning: dgit option %s must be passed before %s on dgit command line
6724 print STDERR f_ <<END, $&, $subcommand, $willrun or die $!;
6725 warning: option %s should probably be passed to dgit before %s sub-command on the dgit command line, so that it is seen by dgit and not simply passed to %s
6731 sub changesopts_initial () {
6732 my @opts =@changesopts[1..$#changesopts];
6735 sub changesopts_version () {
6736 if (!defined $changes_since_version) {
6739 @vsns = archive_query('archive_query');
6740 my @quirk = access_quirk();
6741 if ($quirk[0] eq 'backports') {
6742 local $isuite = $quirk[2];
6744 canonicalise_suite();
6745 push @vsns, archive_query('archive_query');
6751 "archive query failed (queried because --since-version not specified)";
6754 @vsns = map { $_->[0] } @vsns;
6755 @vsns = sort { -version_compare($a, $b) } @vsns;
6756 $changes_since_version = $vsns[0];
6757 progress f_ "changelog will contain changes since %s", $vsns[0];
6759 $changes_since_version = '_';
6760 progress __ "package seems new, not specifying -v<version>";
6763 if ($changes_since_version ne '_') {
6764 return ("-v$changes_since_version");
6770 sub changesopts () {
6771 return (changesopts_initial(), changesopts_version());
6774 sub massage_dbp_args ($;$) {
6775 my ($cmd,$xargs) = @_;
6776 # Since we split the source build out so we can do strange things
6777 # to it, massage the arguments to dpkg-buildpackage so that the
6778 # main build doessn't build source (or add an argument to stop it
6779 # building source by default).
6780 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6781 # -nc has the side effect of specifying -b if nothing else specified
6782 # and some combinations of -S, -b, et al, are errors, rather than
6783 # later simply overriding earlie. So we need to:
6784 # - search the command line for these options
6785 # - pick the last one
6786 # - perhaps add our own as a default
6787 # - perhaps adjust it to the corresponding non-source-building version
6789 foreach my $l ($cmd, $xargs) {
6791 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6794 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6795 my $r = WANTSRC_BUILDER;
6796 printdebug "massage split $dmode.\n";
6797 if ($dmode =~ s/^--build=//) {
6799 my @d = split /,/, $dmode;
6800 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6801 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6802 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6803 fail __ "Wanted to build nothing!" unless $r;
6804 $dmode = '--build='. join ',', grep m/./, @d;
6807 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6808 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6809 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6812 printdebug "massage done $r $dmode.\n";
6814 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6820 my $wasdir = must_getcwd();
6821 changedir $buildproductsdir;
6826 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6827 sub postbuild_mergechanges ($) {
6828 my ($msg_if_onlyone) = @_;
6829 # If there is only one .changes file, fail with $msg_if_onlyone,
6830 # or if that is undef, be a no-op.
6831 # Returns the changes file to report to the user.
6832 my $pat = changespat $version;
6833 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6834 @changesfiles = sort {
6835 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6839 if (@changesfiles==1) {
6840 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6841 only one changes file from build (%s)
6843 if defined $msg_if_onlyone;
6844 $result = $changesfiles[0];
6845 } elsif (@changesfiles==2) {
6846 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6847 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6848 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6851 runcmd_ordryrun_local @mergechanges, @changesfiles;
6852 my $multichanges = changespat $version,'multi';
6854 stat_exists $multichanges or fail f_
6855 "%s unexpectedly not created by build", $multichanges;
6856 foreach my $cf (glob $pat) {
6857 next if $cf eq $multichanges;
6858 rename "$cf", "$cf.inmulti" or fail f_
6859 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6862 $result = $multichanges;
6864 fail f_ "wrong number of different changes files (%s)",
6867 printdone f_ "build successful, results in %s\n", $result
6871 sub midbuild_checkchanges () {
6872 my $pat = changespat $version;
6873 return if $rmchanges;
6874 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6876 $_ ne changespat $version,'source' and
6877 $_ ne changespat $version,'multi'
6879 fail +(f_ <<END, $pat, "@unwanted")
6880 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6881 Suggest you delete %s.
6886 sub midbuild_checkchanges_vanilla ($) {
6888 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6891 sub postbuild_mergechanges_vanilla ($) {
6893 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6895 postbuild_mergechanges(undef);
6898 printdone __ "build successful\n";
6904 maybe_warn_opt_confusion 'build', 'dpkg-buildpackage', \@ARGV;
6905 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6906 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6907 %s: warning: build-products-dir will be ignored; files will go to ..
6909 $buildproductsdir = '..';
6910 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6911 my $wantsrc = massage_dbp_args \@dbp;
6912 build_prep($wantsrc);
6913 if ($wantsrc & WANTSRC_SOURCE) {
6915 midbuild_checkchanges_vanilla $wantsrc;
6917 if ($wantsrc & WANTSRC_BUILDER) {
6918 push @dbp, changesopts_version();
6919 maybe_apply_patches_dirtily();
6920 runcmd_ordryrun_local @dbp;
6922 maybe_unapply_patches_again();
6923 postbuild_mergechanges_vanilla $wantsrc;
6927 $quilt_mode //= 'gbp';
6932 maybe_warn_opt_confusion 'gbp-build', 'gbp buildpackage', \@ARGV;
6934 # gbp can make .origs out of thin air. In my tests it does this
6935 # even for a 1.0 format package, with no origs present. So I
6936 # guess it keys off just the version number. We don't know
6937 # exactly what .origs ought to exist, but let's assume that we
6938 # should run gbp if: the version has an upstream part and the main
6940 my $upstreamversion = upstreamversion $version;
6941 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6942 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6944 if ($gbp_make_orig) {
6946 $cleanmode = 'none'; # don't do it again
6949 my @dbp = @dpkgbuildpackage;
6951 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6953 if (!length $gbp_build[0]) {
6954 if (length executable_on_path('git-buildpackage')) {
6955 $gbp_build[0] = qw(git-buildpackage);
6957 $gbp_build[0] = 'gbp buildpackage';
6960 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6962 push @cmd, (qw(-us -uc --git-no-sign-tags),
6963 "--git-builder=".(shellquote @dbp));
6965 if ($gbp_make_orig) {
6966 my $priv = dgit_privdir();
6967 my $ok = "$priv/origs-gen-ok";
6968 unlink $ok or $!==&ENOENT or confess "$!";
6969 my @origs_cmd = @cmd;
6970 push @origs_cmd, qw(--git-cleaner=true);
6971 push @origs_cmd, "--git-prebuild=".
6972 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6973 push @origs_cmd, @ARGV;
6975 debugcmd @origs_cmd;
6977 do { local $!; stat_exists $ok; }
6978 or failedcmd @origs_cmd;
6980 dryrun_report @origs_cmd;
6984 build_prep($wantsrc);
6985 if ($wantsrc & WANTSRC_SOURCE) {
6987 midbuild_checkchanges_vanilla $wantsrc;
6989 push @cmd, '--git-cleaner=true';
6991 maybe_unapply_patches_again();
6992 if ($wantsrc & WANTSRC_BUILDER) {
6993 push @cmd, changesopts();
6994 runcmd_ordryrun_local @cmd, @ARGV;
6996 postbuild_mergechanges_vanilla $wantsrc;
6998 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
7000 sub building_source_in_playtree {
7001 # If $includedirty, we have to build the source package from the
7002 # working tree, not a playtree, so that uncommitted changes are
7003 # included (copying or hardlinking them into the playtree could
7006 # Note that if we are building a source package in split brain
7007 # mode we do not support including uncommitted changes, because
7008 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
7009 # building a source package)) => !$includedirty
7010 return !$includedirty;
7014 $sourcechanges = changespat $version,'source';
7016 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
7017 or fail f_ "remove %s: %s", $sourcechanges, $!;
7019 # confess unless !!$made_split_brain == do_split_brain();
7021 my @cmd = (@dpkgsource, qw(-b --));
7023 if (building_source_in_playtree()) {
7025 my $headref = git_rev_parse('HEAD');
7026 # If we are in split brain, there is already a playtree with
7027 # the thing we should package into a .dsc (thanks to quilt
7028 # fixup). If not, make a playtree
7029 prep_ud() unless $made_split_brain;
7030 changedir $playground;
7031 unless ($made_split_brain) {
7032 my $upstreamversion = upstreamversion $version;
7033 unpack_playtree_linkorigs($upstreamversion, sub { });
7034 unpack_playtree_need_cd_work($headref);
7038 $leafdir = basename $maindir;
7040 if ($buildproductsdir ne '..') {
7041 # Well, we are going to run dpkg-source -b which consumes
7042 # origs from .. and generates output there. To make this
7043 # work when the bpd is not .. , we would have to (i) link
7044 # origs from bpd to .. , (ii) check for files that
7045 # dpkg-source -b would/might overwrite, and afterwards
7046 # (iii) move all the outputs back to the bpd (iv) except
7047 # for the origs which should be deleted from .. if they
7048 # weren't there beforehand. And if there is an error and
7049 # we don't run to completion we would necessarily leave a
7050 # mess. This is too much. The real way to fix this
7051 # is for dpkg-source to have bpd support.
7052 confess unless $includedirty;
7054 "--include-dirty not supported with --build-products-dir, sorry";
7059 runcmd_ordryrun_local @cmd, $leafdir;
7062 runcmd_ordryrun_local qw(sh -ec),
7063 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
7064 @dpkggenchanges, qw(-S), changesopts();
7067 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
7068 $dsc = parsecontrol($dscfn, "source package");
7072 printdebug " renaming ($why) $l\n";
7073 rename_link_xf 0, "$l", bpd_abs()."/$l"
7074 or fail f_ "put in place new built file (%s): %s", $l, $@;
7076 foreach my $l (split /\n/, getfield $dsc, 'Files') {
7077 $l =~ m/\S+$/ or next;
7080 $mv->('dsc', $dscfn);
7081 $mv->('changes', $sourcechanges);
7086 sub cmd_build_source {
7087 badusage __ "build-source takes no additional arguments" if @ARGV;
7088 build_prep(WANTSRC_SOURCE);
7090 maybe_unapply_patches_again();
7091 printdone f_ "source built, results in %s and %s",
7092 $dscfn, $sourcechanges;
7095 sub cmd_push_source {
7098 "dgit push-source: --include-dirty/--ignore-dirty does not make".
7099 "sense with push-source!"
7101 build_check_quilt_splitbrain();
7103 my $changes = parsecontrol("$buildproductsdir/$changesfile",
7104 __ "source changes file");
7105 unless (test_source_only_changes($changes)) {
7106 fail __ "user-specified changes file is not source-only";
7109 # Building a source package is very fast, so just do it
7111 confess "er, patches are applied dirtily but shouldn't be.."
7112 if $patches_applied_dirtily;
7113 $changesfile = $sourcechanges;
7118 sub binary_builder {
7119 my ($bbuilder, $pbmc_msg, @args) = @_;
7120 build_prep(WANTSRC_SOURCE);
7122 midbuild_checkchanges();
7125 stat_exists $dscfn or fail f_
7126 "%s (in build products dir): %s", $dscfn, $!;
7127 stat_exists $sourcechanges or fail f_
7128 "%s (in build products dir): %s", $sourcechanges, $!;
7130 runcmd_ordryrun_local @$bbuilder, @args;
7132 maybe_unapply_patches_again();
7134 postbuild_mergechanges($pbmc_msg);
7140 maybe_warn_opt_confusion 'sbuild', 'sbuild', \@ARGV;
7141 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
7142 perhaps you need to pass -A ? (sbuild's default is to build only
7143 arch-specific binaries; dgit 1.4 used to override that.)
7148 my ($pbuilder) = @_;
7150 maybe_warn_opt_confusion 'pbuilder', 'pbuilder', \@ARGV;
7151 # @ARGV is allowed to contain only things that should be passed to
7152 # pbuilder under debbuildopts; just massage those
7153 my $wantsrc = massage_dbp_args \@ARGV;
7155 "you asked for a builder but your debbuildopts didn't ask for".
7156 " any binaries -- is this really what you meant?"
7157 unless $wantsrc & WANTSRC_BUILDER;
7159 "we must build a .dsc to pass to the builder but your debbuiltopts".
7160 " forbids the building of a source package; cannot continue"
7161 unless $wantsrc & WANTSRC_SOURCE;
7162 # We do not want to include the verb "build" in @pbuilder because
7163 # the user can customise @pbuilder and they shouldn't be required
7164 # to include "build" in their customised value. However, if the
7165 # user passes any additional args to pbuilder using the dgit
7166 # option --pbuilder:foo, such args need to come after the "build"
7167 # verb. opts_opt_multi_cmd does all of that.
7168 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
7169 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
7174 pbuilder(\@pbuilder);
7177 sub cmd_cowbuilder {
7178 pbuilder(\@cowbuilder);
7181 sub cmd_quilt_fixup {
7182 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
7185 build_maybe_quilt_fixup();
7188 sub cmd_print_unapplied_treeish {
7189 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
7191 my $headref = git_rev_parse('HEAD');
7192 my $clogp = commit_getclogp $headref;
7193 $package = getfield $clogp, 'Source';
7194 $version = getfield $clogp, 'Version';
7195 $isuite = getfield $clogp, 'Distribution';
7196 $csuite = $isuite; # we want this to be offline!
7200 changedir $playground;
7201 my $uv = upstreamversion $version;
7202 my $u = quilt_fakedsc2unapplied($headref, $uv);
7203 print $u, "\n" or confess "$!";
7206 sub import_dsc_result {
7207 my ($dstref, $newhash, $what_log, $what_msg) = @_;
7208 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
7210 check_gitattrs($newhash, __ "source tree");
7212 progress f_ "dgit: import-dsc: %s", $what_msg;
7215 sub cmd_import_dsc {
7219 last unless $ARGV[0] =~ m/^-/;
7222 if (m/^--require-valid-signature$/) {
7225 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
7229 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
7231 my ($dscfn, $dstbranch) = @ARGV;
7233 badusage __ "dry run makes no sense with import-dsc"
7236 my $force = $dstbranch =~ s/^\+// ? +1 :
7237 $dstbranch =~ s/^\.\.// ? -1 :
7239 my $info = $force ? " $&" : '';
7240 $info = "$dscfn$info";
7242 my $specbranch = $dstbranch;
7243 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
7244 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
7246 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
7247 my $chead = cmdoutput_errok @symcmd;
7248 defined $chead or $?==256 or failedcmd @symcmd;
7250 fail f_ "%s is checked out - will not update it", $dstbranch
7251 if defined $chead and $chead eq $dstbranch;
7253 my $oldhash = git_get_ref $dstbranch;
7255 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
7256 $dscdata = do { local $/ = undef; <D>; };
7257 D->error and fail f_ "read %s: %s", $dscfn, $!;
7260 # we don't normally need this so import it here
7261 use Dpkg::Source::Package;
7262 my $dp = new Dpkg::Source::Package filename => $dscfn,
7263 require_valid_signature => $needsig;
7265 local $SIG{__WARN__} = sub {
7267 return unless $needsig;
7268 fail __ "import-dsc signature check failed";
7270 if (!$dp->is_signed()) {
7271 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
7273 my $r = $dp->check_signature();
7274 confess "->check_signature => $r" if $needsig && $r;
7280 $package = getfield $dsc, 'Source';
7282 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
7283 unless forceing [qw(import-dsc-with-dgit-field)];
7284 parse_dsc_field_def_dsc_distro();
7286 $isuite = 'DGIT-IMPORT-DSC';
7287 $idistro //= $dsc_distro;
7291 if (defined $dsc_hash) {
7293 "dgit: import-dsc of .dsc with Dgit field, using git hash";
7294 resolve_dsc_field_commit undef, undef;
7296 if (defined $dsc_hash) {
7297 my @cmd = (qw(sh -ec),
7298 "echo $dsc_hash | git cat-file --batch-check");
7299 my $objgot = cmdoutput @cmd;
7300 if ($objgot =~ m#^\w+ missing\b#) {
7301 fail f_ <<END, $dsc_hash
7302 .dsc contains Dgit field referring to object %s
7303 Your git tree does not have that object. Try `git fetch' from a
7304 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7307 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7309 progress __ "Not fast forward, forced update.";
7311 fail f_ "Not fast forward to %s", $dsc_hash;
7314 import_dsc_result $dstbranch, $dsc_hash,
7315 "dgit import-dsc (Dgit): $info",
7316 f_ "updated git ref %s", $dstbranch;
7320 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7321 Branch %s already exists
7322 Specify ..%s for a pseudo-merge, binding in existing history
7323 Specify +%s to overwrite, discarding existing history
7325 if $oldhash && !$force;
7327 my @dfi = dsc_files_info();
7328 foreach my $fi (@dfi) {
7329 my $f = $fi->{Filename};
7330 # We transfer all the pieces of the dsc to the bpd, not just
7331 # origs. This is by analogy with dgit fetch, which wants to
7332 # keep them somewhere to avoid downloading them again.
7333 # We make symlinks, though. If the user wants copies, then
7334 # they can copy the parts of the dsc to the bpd using dcmd,
7336 my $here = "$buildproductsdir/$f";
7341 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7343 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7344 printdebug "not in bpd, $f ...\n";
7345 # $f does not exist in bpd, we need to transfer it
7347 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7348 # $there is file we want, relative to user's cwd, or abs
7349 printdebug "not in bpd, $f, test $there ...\n";
7350 stat $there or fail f_
7351 "import %s requires %s, but: %s", $dscfn, $there, $!;
7352 if ($there =~ m#^(?:\./+)?\.\./+#) {
7353 # $there is relative to user's cwd
7354 my $there_from_parent = $';
7355 if ($buildproductsdir !~ m{^/}) {
7356 # abs2rel, despite its name, can take two relative paths
7357 $there = File::Spec->abs2rel($there,$buildproductsdir);
7358 # now $there is relative to bpd, great
7359 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7361 $there = (dirname $maindir)."/$there_from_parent";
7362 # now $there is absoute
7363 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7365 } elsif ($there =~ m#^/#) {
7366 # $there is absolute already
7367 printdebug "not in bpd, $f, abs, $there ...\n";
7370 "cannot import %s which seems to be inside working tree!",
7373 symlink $there, $here or fail f_
7374 "symlink %s to %s: %s", $there, $here, $!;
7375 progress f_ "made symlink %s -> %s", $here, $there;
7376 # print STDERR Dumper($fi);
7378 my @mergeinputs = generate_commits_from_dsc();
7379 die unless @mergeinputs == 1;
7381 my $newhash = $mergeinputs[0]{Commit};
7386 "Import, forced update - synthetic orphan git history.";
7387 } elsif ($force < 0) {
7388 progress __ "Import, merging.";
7389 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7390 my $version = getfield $dsc, 'Version';
7391 my $clogp = commit_getclogp $newhash;
7392 my $authline = clogp_authline $clogp;
7393 $newhash = hash_commit_text <<ENDU
7401 .(f_ <<END, $package, $version, $dstbranch);
7402 Merge %s (%s) import into %s
7405 die; # caught earlier
7409 import_dsc_result $dstbranch, $newhash,
7410 "dgit import-dsc: $info",
7411 f_ "results are in git ref %s", $dstbranch;
7414 sub pre_archive_api_query () {
7415 not_necessarily_a_tree();
7417 sub cmd_archive_api_query {
7418 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7419 my ($subpath) = @ARGV;
7420 local $isuite = 'DGIT-API-QUERY-CMD';
7421 my $json = api_query_raw $subpath;
7422 print $json or die "$!";
7425 sub repos_server_url () {
7426 $package = '_dgit-repos-server';
7427 local $access_forpush = 1;
7428 local $isuite = 'DGIT-REPOS-SERVER';
7429 my $url = access_giturl();
7432 sub pre_clone_dgit_repos_server () {
7433 not_necessarily_a_tree();
7435 sub cmd_clone_dgit_repos_server {
7436 badusage __ "need destination argument" unless @ARGV==1;
7437 my ($destdir) = @ARGV;
7438 my $url = repos_server_url();
7439 my @cmd = (@git, qw(clone), $url, $destdir);
7441 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7444 sub pre_print_dgit_repos_server_source_url () {
7445 not_necessarily_a_tree();
7447 sub cmd_print_dgit_repos_server_source_url {
7449 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7451 my $url = repos_server_url();
7452 print $url, "\n" or confess "$!";
7455 sub pre_print_dpkg_source_ignores {
7456 not_necessarily_a_tree();
7458 sub cmd_print_dpkg_source_ignores {
7460 "no arguments allowed to dgit print-dpkg-source-ignores"
7462 print "@dpkg_source_ignores\n" or confess "$!";
7465 sub cmd_setup_mergechangelogs {
7466 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7468 local $isuite = 'DGIT-SETUP-TREE';
7469 setup_mergechangelogs(1);
7472 sub cmd_setup_useremail {
7473 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7474 local $isuite = 'DGIT-SETUP-TREE';
7478 sub cmd_setup_gitattributes {
7479 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7480 local $isuite = 'DGIT-SETUP-TREE';
7484 sub cmd_setup_new_tree {
7485 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7486 local $isuite = 'DGIT-SETUP-TREE';
7490 #---------- argument parsing and main program ----------
7493 print "dgit version $our_version\n" or confess "$!";
7497 our (%valopts_long, %valopts_short);
7498 our (%funcopts_long);
7500 our (@modeopt_cfgs);
7502 sub defvalopt ($$$$) {
7503 my ($long,$short,$val_re,$how) = @_;
7504 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7505 $valopts_long{$long} = $oi;
7506 $valopts_short{$short} = $oi;
7507 # $how subref should:
7508 # do whatever assignemnt or thing it likes with $_[0]
7509 # if the option should not be passed on to remote, @rvalopts=()
7510 # or $how can be a scalar ref, meaning simply assign the value
7513 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7514 defvalopt '--distro', '-d', '.+', \$idistro;
7515 defvalopt '', '-k', '.+', \$keyid;
7516 defvalopt '--existing-package','', '.*', \$existing_package;
7517 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7518 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7519 defvalopt '--package', '-p', $package_re, \$package;
7520 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7522 defvalopt '', '-C', '.+', sub {
7523 ($changesfile) = (@_);
7524 if ($changesfile =~ s#^(.*)/##) {
7525 $buildproductsdir = $1;
7529 defvalopt '--initiator-tempdir','','.*', sub {
7530 ($initiator_tempdir) = (@_);
7531 $initiator_tempdir =~ m#^/# or
7532 badusage __ "--initiator-tempdir must be used specify an".
7533 " absolute, not relative, directory."
7536 sub defoptmodes ($@) {
7537 my ($varref, $cfgkey, $default, %optmap) = @_;
7539 while (my ($opt,$val) = each %optmap) {
7540 $funcopts_long{$opt} = sub { $$varref = $val; };
7541 $permit{$val} = $val;
7543 push @modeopt_cfgs, {
7546 Default => $default,
7551 defoptmodes \$dodep14tag, qw( dep14tag want
7554 --always-dep14tag always );
7559 if (defined $ENV{'DGIT_SSH'}) {
7560 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7561 } elsif (defined $ENV{'GIT_SSH'}) {
7562 @ssh = ($ENV{'GIT_SSH'});
7570 if (!defined $val) {
7571 badusage f_ "%s needs a value", $what unless @ARGV;
7573 push @rvalopts, $val;
7575 badusage f_ "bad value \`%s' for %s", $val, $what unless
7576 $val =~ m/^$oi->{Re}$(?!\n)/s;
7577 my $how = $oi->{How};
7578 if (ref($how) eq 'SCALAR') {
7583 push @ropts, @rvalopts;
7587 last unless $ARGV[0] =~ m/^-/;
7591 if (m/^--dry-run$/) {
7594 } elsif (m/^--damp-run$/) {
7597 } elsif (m/^--no-sign$/) {
7600 } elsif (m/^--help$/) {
7602 } elsif (m/^--version$/) {
7604 } elsif (m/^--new$/) {
7607 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7608 ($om = $opts_opt_map{$1}) &&
7612 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7613 !$opts_opt_cmdonly{$1} &&
7614 ($om = $opts_opt_map{$1})) {
7617 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7618 !$opts_opt_cmdonly{$1} &&
7619 ($om = $opts_opt_map{$1})) {
7621 my $cmd = shift @$om;
7622 @$om = ($cmd, grep { $_ ne $2 } @$om);
7623 } elsif (m/^--($quilt_options_re)$/s) {
7624 push @ropts, "--quilt=$1";
7626 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7629 } elsif (m/^--no-quilt-fixup$/s) {
7631 $quilt_mode = 'nocheck';
7632 } elsif (m/^--no-rm-on-error$/s) {
7635 } elsif (m/^--no-chase-dsc-distro$/s) {
7637 $chase_dsc_distro = 0;
7638 } elsif (m/^--overwrite$/s) {
7640 $overwrite_version = '';
7641 } elsif (m/^--split-(?:view|brain)$/s) {
7643 $splitview_mode = 'always';
7644 } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7646 $splitview_mode = $1;
7647 } elsif (m/^--overwrite=(.+)$/s) {
7649 $overwrite_version = $1;
7650 } elsif (m/^--delayed=(\d+)$/s) {
7653 } elsif (m/^--upstream-commitish=(.+)$/s) {
7655 $quilt_upstream_commitish = $1;
7656 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7657 m/^--(dgit-view)-save=(.+)$/s
7659 my ($k,$v) = ($1,$2);
7661 $v =~ s#^(?!refs/)#refs/heads/#;
7662 $internal_object_save{$k} = $v;
7663 } elsif (m/^--(no-)?rm-old-changes$/s) {
7666 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7668 push @deliberatelies, $&;
7669 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7673 } elsif (m/^--force-/) {
7675 f_ "%s: warning: ignoring unknown force option %s\n",
7678 } elsif (m/^--for-push$/s) {
7680 $access_forpush = 1;
7681 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7682 # undocumented, for testing
7684 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7685 # ^ it's supposed to be an array ref
7686 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7687 $val = $2 ? $' : undef; #';
7688 $valopt->($oi->{Long});
7689 } elsif ($funcopts_long{$_}) {
7691 $funcopts_long{$_}();
7693 badusage f_ "unknown long option \`%s'", $_;
7700 } elsif (s/^-L/-/) {
7703 } elsif (s/^-h/-/) {
7705 } elsif (s/^-D/-/) {
7709 } elsif (s/^-N/-/) {
7714 push @changesopts, $_;
7716 } elsif (s/^-wn$//s) {
7718 $cleanmode = 'none';
7719 } elsif (s/^-wg(f?)(a?)$//s) {
7722 $cleanmode .= '-ff' if $1;
7723 $cleanmode .= ',always' if $2;
7724 } elsif (s/^-wd(d?)([na]?)$//s) {
7726 $cleanmode = 'dpkg-source';
7727 $cleanmode .= '-d' if $1;
7728 $cleanmode .= ',no-check' if $2 eq 'n';
7729 $cleanmode .= ',all-check' if $2 eq 'a';
7730 } elsif (s/^-wc$//s) {
7732 $cleanmode = 'check';
7733 } elsif (s/^-wci$//s) {
7735 $cleanmode = 'check,ignores';
7736 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7737 push @git, '-c', $&;
7738 $gitcfgs{cmdline}{$1} = [ $2 ];
7739 } elsif (s/^-c([^=]+)$//s) {
7740 push @git, '-c', $&;
7741 $gitcfgs{cmdline}{$1} = [ 'true' ];
7742 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7744 $val = undef unless length $val;
7745 $valopt->($oi->{Short});
7748 badusage f_ "unknown short option \`%s'", $_;
7755 sub check_env_sanity () {
7756 my $blocked = new POSIX::SigSet;
7757 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7760 foreach my $name (qw(PIPE CHLD)) {
7761 my $signame = "SIG$name";
7762 my $signum = eval "POSIX::$signame" // die;
7763 die f_ "%s is set to something other than SIG_DFL\n",
7765 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7766 $blocked->ismember($signum) and
7767 die f_ "%s is blocked\n", $signame;
7773 On entry to dgit, %s
7774 This is a bug produced by something in your execution environment.
7780 sub parseopts_late_defaults () {
7781 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7782 if defined $idistro;
7783 $isuite //= cfg('dgit.default.default-suite');
7785 foreach my $k (keys %opts_opt_map) {
7786 my $om = $opts_opt_map{$k};
7788 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7790 badcfg f_ "cannot set command for %s", $k
7791 unless length $om->[0];
7795 foreach my $c (access_cfg_cfgs("opts-$k")) {
7797 map { $_ ? @$_ : () }
7798 map { $gitcfgs{$_}{$c} }
7799 reverse @gitcfgsources;
7800 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7801 "\n" if $debuglevel >= 4;
7803 badcfg f_ "cannot configure options for %s", $k
7804 if $opts_opt_cmdonly{$k};
7805 my $insertpos = $opts_cfg_insertpos{$k};
7806 @$om = ( @$om[0..$insertpos-1],
7808 @$om[$insertpos..$#$om] );
7812 if (!defined $rmchanges) {
7813 local $access_forpush;
7814 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7817 if (!defined $quilt_mode) {
7818 local $access_forpush;
7819 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7820 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7822 $quilt_mode =~ m/^($quilt_modes_re)$/
7823 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7826 $quilt_mode =~ s/^(baredebian)\+git$/$1/;
7828 foreach my $moc (@modeopt_cfgs) {
7829 local $access_forpush;
7830 my $vr = $moc->{Var};
7831 next if defined $$vr;
7832 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7833 my $v = $moc->{Vals}{$$vr};
7834 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7840 local $access_forpush;
7841 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7845 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7846 $buildproductsdir //= '..';
7847 $bpd_glob = $buildproductsdir;
7848 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7851 setlocale(LC_MESSAGES, "");
7854 if ($ENV{$fakeeditorenv}) {
7856 quilt_fixup_editor();
7862 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7863 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7864 if $dryrun_level == 1;
7866 print STDERR __ $helpmsg or confess "$!";
7869 $cmd = $subcommand = shift @ARGV;
7872 my $pre_fn = ${*::}{"pre_$cmd"};
7873 $pre_fn->() if $pre_fn;
7875 if ($invoked_in_git_tree) {
7876 changedir_git_toplevel();
7881 my $fn = ${*::}{"cmd_$cmd"};
7882 $fn or badusage f_ "unknown operation %s", $cmd;