3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2018 Ian Jackson
6 # Copyright (C)2017-2018 Sean Whitton
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
22 use Debian::Dgit::ExitStatus;
23 use Debian::Dgit::I18n;
27 use Debian::Dgit qw(:DEFAULT :playground);
33 use Dpkg::Control::Hash;
36 use File::Temp qw(tempdir);
39 use Dpkg::Compression;
40 use Dpkg::Compression::Process;
46 use List::MoreUtils qw(pairwise);
47 use Text::Glob qw(match_glob);
48 use Fcntl qw(:DEFAULT :flock);
53 our $our_version = 'UNRELEASED'; ###substituted###
54 our $absurdity = undef; ###substituted###
56 our @rpushprotovsn_support = qw(4 5); # 5 drops tag format specification
67 our $dryrun_level = 0;
69 our $buildproductsdir;
72 our $includedirty = 0;
76 our $existing_package = 'dpkg';
78 our $changes_since_version;
80 our $overwrite_version; # undef: not specified; '': check changelog
82 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
84 our %internal_object_save;
85 our $we_are_responder;
86 our $we_are_initiator;
87 our $initiator_tempdir;
88 our $patches_applied_dirtily = 00;
89 our $chase_dsc_distro=1;
91 our %forceopts = map { $_=>0 }
92 qw(unrepresentable unsupported-source-format
93 dsc-changes-mismatch changes-origs-exactly
94 uploading-binaries uploading-source-only
95 import-gitapply-absurd
96 import-gitapply-no-absurd
97 import-dsc-with-dgit-field);
99 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
101 our $suite_re = '[-+.0-9a-z]+';
102 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
103 | (?: git | git-ff ) (?: ,always )?
104 | check (?: ,ignores )?
108 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
109 our $splitbraincache = 'dgit-intern/quilt-cache';
110 our $rewritemap = 'dgit-rewrite/map';
112 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
114 our (@git) = qw(git);
115 our (@dget) = qw(dget);
116 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
117 our (@dput) = qw(dput);
118 our (@debsign) = qw(debsign);
119 our (@gpg) = qw(gpg);
120 our (@sbuild) = (qw(sbuild --no-source));
122 our (@dgit) = qw(dgit);
123 our (@git_debrebase) = qw(git-debrebase);
124 our (@aptget) = qw(apt-get);
125 our (@aptcache) = qw(apt-cache);
126 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
127 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
128 our (@dpkggenchanges) = qw(dpkg-genchanges);
129 our (@mergechanges) = qw(mergechanges -f);
130 our (@gbp_build) = ('');
131 our (@gbp_pq) = ('gbp pq');
132 our (@changesopts) = ('');
133 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
134 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
136 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
139 'debsign' => \@debsign,
141 'sbuild' => \@sbuild,
145 'git-debrebase' => \@git_debrebase,
146 'apt-get' => \@aptget,
147 'apt-cache' => \@aptcache,
148 'dpkg-source' => \@dpkgsource,
149 'dpkg-buildpackage' => \@dpkgbuildpackage,
150 'dpkg-genchanges' => \@dpkggenchanges,
151 'gbp-build' => \@gbp_build,
152 'gbp-pq' => \@gbp_pq,
153 'ch' => \@changesopts,
154 'mergechanges' => \@mergechanges,
155 'pbuilder' => \@pbuilder,
156 'cowbuilder' => \@cowbuilder);
158 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
159 our %opts_cfg_insertpos = map {
161 scalar @{ $opts_opt_map{$_} }
162 } keys %opts_opt_map;
164 sub parseopts_late_defaults();
165 sub quiltify_trees_differ ($$;$$$);
166 sub setup_gitattrs(;$);
167 sub check_gitattrs($$);
174 our $supplementary_message = '';
175 our $made_split_brain = 0;
176 our $do_split_brain = 0;
178 # Interactions between quilt mode and split brain
179 # (currently, split brain only implemented iff
180 # madformat_wantfixup && quiltmode_splitbrain)
182 # source format sane `3.0 (quilt)'
183 # madformat_wantfixup()
185 # quilt mode normal quiltmode
186 # (eg linear) _splitbrain
188 # ------------ ------------------------------------------------
190 # no split no q cache no q cache forbidden,
191 # brain PM on master q fixup on master prevented
192 # !$do_split_brain PM on master
194 # split brain no q cache q fixup cached, to dgit view
195 # PM in dgit view PM in dgit view
197 # PM = pseudomerge to make ff, due to overwrite (or split view)
198 # "no q cache" = do not record in cache on build, do not check cache
199 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
203 return unless forkcheck_mainprocess();
204 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
207 our $remotename = 'dgit';
208 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
212 if (!defined $absurdity) {
214 $absurdity =~ s{/[^/]+$}{/absurd} or die;
217 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
219 sub lbranch () { return "$branchprefix/$csuite"; }
220 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
221 sub lref () { return "refs/heads/".lbranch(); }
222 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
223 sub rrref () { return server_ref($csuite); }
226 my ($vsn, $sfx) = @_;
227 return &source_file_leafname($package, $vsn, $sfx);
229 sub is_orig_file_of_vsn ($$) {
230 my ($f, $upstreamvsn) = @_;
231 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
236 return srcfn($vsn,".dsc");
239 sub changespat ($;$) {
240 my ($vsn, $arch) = @_;
241 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
250 return unless forkcheck_mainprocess();
251 foreach my $f (@end) {
253 print STDERR "$us: cleanup: $@" if length $@;
258 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
262 sub forceable_fail ($$) {
263 my ($forceoptsl, $msg) = @_;
264 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
265 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
269 my ($forceoptsl) = @_;
270 my @got = grep { $forceopts{$_} } @$forceoptsl;
271 return 0 unless @got;
273 "warning: skipping checks or functionality due to --force-%s\n",
277 sub no_such_package () {
278 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
279 $us, $package, $isuite;
283 sub deliberately ($) {
285 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
288 sub deliberately_not_fast_forward () {
289 foreach (qw(not-fast-forward fresh-repo)) {
290 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
294 sub quiltmode_splitbrain () {
295 $quilt_mode =~ m/gbp|dpm|unapplied/;
298 sub opts_opt_multi_cmd {
301 push @cmd, split /\s+/, shift @_;
308 return opts_opt_multi_cmd [], @gbp_pq;
311 sub dgit_privdir () {
312 our $dgit_privdir_made //= ensure_a_playground 'dgit';
316 my $r = $buildproductsdir;
317 $r = "$maindir/$r" unless $r =~ m{^/};
321 sub get_tree_of_commit ($) {
322 my ($commitish) = @_;
323 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
324 $cdata =~ m/\n\n/; $cdata = $`;
325 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
329 sub branch_gdr_info ($$) {
330 my ($symref, $head) = @_;
331 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
332 gdr_ffq_prev_branchinfo($symref);
333 return () unless $status eq 'branch';
334 $ffq_prev = git_get_ref $ffq_prev;
335 $gdrlast = git_get_ref $gdrlast;
336 $gdrlast &&= is_fast_fwd $gdrlast, $head;
337 return ($ffq_prev, $gdrlast);
340 sub branch_is_gdr_unstitched_ff ($$$) {
341 my ($symref, $head, $ancestor) = @_;
342 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
343 return 0 unless $ffq_prev;
344 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
348 sub branch_is_gdr ($) {
350 # This is quite like git-debrebase's keycommits.
351 # We have our own implementation because:
352 # - our algorighm can do fewer tests so is faster
353 # - it saves testing to see if gdr is installed
355 # NB we use this jsut for deciding whether to run gdr make-patches
356 # Before reusing this algorithm for somthing else, its
357 # suitability should be reconsidered.
360 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
361 printdebug "branch_is_gdr $head...\n";
362 my $get_patches = sub {
363 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
366 my $tip_patches = $get_patches->($head);
369 my $cdata = git_cat_file $walk, 'commit';
370 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
371 if ($msg =~ m{^\[git-debrebase\ (
372 anchor | changelog | make-patches |
373 merged-breakwater | pseudomerge
375 # no need to analyse this - it's sufficient
376 # (gdr classifications: Anchor, MergedBreakwaters)
377 # (made by gdr: Pseudomerge, Changelog)
378 printdebug "branch_is_gdr $walk gdr $1 YES\n";
381 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
383 my $walk_tree = get_tree_of_commit $walk;
384 foreach my $p (@parents) {
385 my $p_tree = get_tree_of_commit $p;
386 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
387 # (gdr classification: Pseudomerge; not made by gdr)
388 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
394 # some other non-gdr merge
395 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
396 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
400 # (gdr classification: ?)
401 printdebug "branch_is_gdr $walk ?-octopus NO\n";
405 printdebug "branch_is_gdr $walk origin\n";
408 if ($get_patches->($walk) ne $tip_patches) {
409 # Our parent added, removed, or edited patches, and wasn't
410 # a gdr make-patches commit. gdr make-patches probably
411 # won't do that well, then.
412 # (gdr classification of parent: AddPatches or ?)
413 printdebug "branch_is_gdr $walk ?-patches NO\n";
416 if ($tip_patches eq '' and
417 !defined git_cat_file "$walk~:debian" and
418 !quiltify_trees_differ "$walk~", $walk
420 # (gdr classification of parent: BreakwaterStart
421 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
424 # (gdr classification: Upstream Packaging Mixed Changelog)
425 printdebug "branch_is_gdr $walk plain\n"
431 #---------- remote protocol support, common ----------
433 # remote push initiator/responder protocol:
434 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
435 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
436 # < dgit-remote-push-ready <actual-proto-vsn>
443 # > supplementary-message NBYTES
448 # > file parsed-changelog
449 # [indicates that output of dpkg-parsechangelog follows]
450 # > data-block NBYTES
451 # > [NBYTES bytes of data (no newline)]
452 # [maybe some more blocks]
461 # > param head DGIT-VIEW-HEAD
462 # > param csuite SUITE
463 # > param tagformat new # $protovsn == 4
464 # > param maint-view MAINT-VIEW-HEAD
466 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
467 # > file buildinfo # for buildinfos to sign
469 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
470 # # goes into tag, for replay prevention
473 # [indicates that signed tag is wanted]
474 # < data-block NBYTES
475 # < [NBYTES bytes of data (no newline)]
476 # [maybe some more blocks]
480 # > want signed-dsc-changes
481 # < data-block NBYTES [transfer of signed dsc]
483 # < data-block NBYTES [transfer of signed changes]
485 # < data-block NBYTES [transfer of each signed buildinfo
486 # [etc] same number and order as "file buildinfo"]
494 sub i_child_report () {
495 # Sees if our child has died, and reap it if so. Returns a string
496 # describing how it died if it failed, or undef otherwise.
497 return undef unless $i_child_pid;
498 my $got = waitpid $i_child_pid, WNOHANG;
499 return undef if $got <= 0;
500 die unless $got == $i_child_pid;
501 $i_child_pid = undef;
502 return undef unless $?;
503 return f_ "build host child %s", waitstatusmsg();
508 fail f_ "connection lost: %s", $! if $fh->error;
509 fail f_ "protocol violation; %s not expected", $m;
512 sub badproto_badread ($$) {
514 fail f_ "connection lost: %s", $! if $!;
515 my $report = i_child_report();
516 fail $report if defined $report;
517 badproto $fh, f_ "eof (reading %s)", $wh;
520 sub protocol_expect (&$) {
521 my ($match, $fh) = @_;
524 defined && chomp or badproto_badread $fh, __ "protocol message";
532 badproto $fh, f_ "\`%s'", $_;
535 sub protocol_send_file ($$) {
536 my ($fh, $ourfn) = @_;
537 open PF, "<", $ourfn or die "$ourfn: $!";
540 my $got = read PF, $d, 65536;
541 die "$ourfn: $!" unless defined $got;
543 print $fh "data-block ".length($d)."\n" or confess "$!";
544 print $fh $d or confess "$!";
546 PF->error and die "$ourfn $!";
547 print $fh "data-end\n" or confess "$!";
551 sub protocol_read_bytes ($$) {
552 my ($fh, $nbytes) = @_;
553 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
555 my $got = read $fh, $d, $nbytes;
556 $got==$nbytes or badproto_badread $fh, __ "data block";
560 sub protocol_receive_file ($$) {
561 my ($fh, $ourfn) = @_;
562 printdebug "() $ourfn\n";
563 open PF, ">", $ourfn or die "$ourfn: $!";
565 my ($y,$l) = protocol_expect {
566 m/^data-block (.*)$/ ? (1,$1) :
567 m/^data-end$/ ? (0,) :
571 my $d = protocol_read_bytes $fh, $l;
572 print PF $d or confess "$!";
574 close PF or confess "$!";
577 #---------- remote protocol support, responder ----------
579 sub responder_send_command ($) {
581 return unless $we_are_responder;
582 # called even without $we_are_responder
583 printdebug ">> $command\n";
584 print PO $command, "\n" or confess "$!";
587 sub responder_send_file ($$) {
588 my ($keyword, $ourfn) = @_;
589 return unless $we_are_responder;
590 printdebug "]] $keyword $ourfn\n";
591 responder_send_command "file $keyword";
592 protocol_send_file \*PO, $ourfn;
595 sub responder_receive_files ($@) {
596 my ($keyword, @ourfns) = @_;
597 die unless $we_are_responder;
598 printdebug "[[ $keyword @ourfns\n";
599 responder_send_command "want $keyword";
600 foreach my $fn (@ourfns) {
601 protocol_receive_file \*PI, $fn;
604 protocol_expect { m/^files-end$/ } \*PI;
607 #---------- remote protocol support, initiator ----------
609 sub initiator_expect (&) {
611 protocol_expect { &$match } \*RO;
614 #---------- end remote code ----------
617 if ($we_are_responder) {
619 responder_send_command "progress ".length($m) or confess "$!";
620 print PO $m or confess "$!";
630 $ua = LWP::UserAgent->new();
634 progress "downloading $what...";
635 my $r = $ua->get(@_) or confess "$!";
636 return undef if $r->code == 404;
637 $r->is_success or fail f_ "failed to fetch %s: %s",
638 $what, $r->status_line;
639 return $r->decoded_content(charset => 'none');
642 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
644 sub act_local () { return $dryrun_level <= 1; }
645 sub act_scary () { return !$dryrun_level; }
648 if (!$dryrun_level) {
649 progress f_ "%s ok: %s", $us, "@_";
651 progress f_ "would be ok: %s (but dry run only)", "@_";
656 printcmd(\*STDERR,$debugprefix."#",@_);
659 sub runcmd_ordryrun {
667 sub runcmd_ordryrun_local {
675 our $helpmsg = i_ <<END;
677 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
678 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
679 dgit [dgit-opts] build [dpkg-buildpackage-opts]
680 dgit [dgit-opts] sbuild [sbuild-opts]
681 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
682 dgit [dgit-opts] push [dgit-opts] [suite]
683 dgit [dgit-opts] push-source [dgit-opts] [suite]
684 dgit [dgit-opts] rpush build-host:build-dir ...
685 important dgit options:
686 -k<keyid> sign tag and package with <keyid> instead of default
687 --dry-run -n do not change anything, but go through the motions
688 --damp-run -L like --dry-run but make local changes, without signing
689 --new -N allow introducing a new package
690 --debug -D increase debug level
691 -c<name>=<value> set git config option (used directly by dgit too)
694 our $later_warning_msg = i_ <<END;
695 Perhaps the upload is stuck in incoming. Using the version from git.
699 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
704 @ARGV or badusage __ "too few arguments";
705 return scalar shift @ARGV;
709 not_necessarily_a_tree();
712 print __ $helpmsg or confess "$!";
716 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
718 our %defcfg = ('dgit.default.distro' => 'debian',
719 'dgit.default.default-suite' => 'unstable',
720 'dgit.default.old-dsc-distro' => 'debian',
721 'dgit-suite.*-security.distro' => 'debian-security',
722 'dgit.default.username' => '',
723 'dgit.default.archive-query-default-component' => 'main',
724 'dgit.default.ssh' => 'ssh',
725 'dgit.default.archive-query' => 'madison:',
726 'dgit.default.sshpsql-dbname' => 'service=projectb',
727 'dgit.default.aptget-components' => 'main',
728 'dgit.default.source-only-uploads' => 'ok',
729 'dgit.dsc-url-proto-ok.http' => 'true',
730 'dgit.dsc-url-proto-ok.https' => 'true',
731 'dgit.dsc-url-proto-ok.git' => 'true',
732 'dgit.vcs-git.suites', => 'sid', # ;-separated
733 'dgit.default.dsc-url-proto-ok' => 'false',
734 # old means "repo server accepts pushes with old dgit tags"
735 # new means "repo server accepts pushes with new dgit tags"
736 # maint means "repo server accepts split brain pushes"
737 # hist means "repo server may have old pushes without new tag"
738 # ("hist" is implied by "old")
739 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
740 'dgit-distro.debian.git-check' => 'url',
741 'dgit-distro.debian.git-check-suffix' => '/info/refs',
742 'dgit-distro.debian.new-private-pushers' => 't',
743 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
744 'dgit-distro.debian/push.git-url' => '',
745 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
746 'dgit-distro.debian/push.git-user-force' => 'dgit',
747 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
748 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
749 'dgit-distro.debian/push.git-create' => 'true',
750 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
751 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
752 # 'dgit-distro.debian.archive-query-tls-key',
753 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
754 # ^ this does not work because curl is broken nowadays
755 # Fixing #790093 properly will involve providing providing the key
756 # in some pacagke and maybe updating these paths.
758 # 'dgit-distro.debian.archive-query-tls-curl-args',
759 # '--ca-path=/etc/ssl/ca-debian',
760 # ^ this is a workaround but works (only) on DSA-administered machines
761 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
762 'dgit-distro.debian.git-url-suffix' => '',
763 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
764 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
765 'dgit-distro.debian-security.archive-query' => 'aptget:',
766 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
767 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
768 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
769 'dgit-distro.debian-security.nominal-distro' => 'debian',
770 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
771 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
772 'dgit-distro.ubuntu.git-check' => 'false',
773 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
774 'dgit-distro.test-dummy.ssh' => "$td/ssh",
775 'dgit-distro.test-dummy.username' => "alice",
776 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
777 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
778 'dgit-distro.test-dummy.git-url' => "$td/git",
779 'dgit-distro.test-dummy.git-host' => "git",
780 'dgit-distro.test-dummy.git-path' => "$td/git",
781 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
782 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
783 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
784 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
788 our @gitcfgsources = qw(cmdline local global system);
789 our $invoked_in_git_tree = 1;
791 sub git_slurp_config () {
792 # This algoritm is a bit subtle, but this is needed so that for
793 # options which we want to be single-valued, we allow the
794 # different config sources to override properly. See #835858.
795 foreach my $src (@gitcfgsources) {
796 next if $src eq 'cmdline';
797 # we do this ourselves since git doesn't handle it
799 $gitcfgs{$src} = git_slurp_config_src $src;
803 sub git_get_config ($) {
805 foreach my $src (@gitcfgsources) {
806 my $l = $gitcfgs{$src}{$c};
807 confess "internal error ($l $c)" if $l && !ref $l;
808 printdebug"C $c ".(defined $l ?
809 join " ", map { messagequote "'$_'" } @$l :
814 f_ "multiple values for %s (in %s git config)", $c, $src
816 $l->[0] =~ m/\n/ and badcfg f_
817 "value for config option %s (in %s git config) contains newline(s)!",
826 return undef if $c =~ /RETURN-UNDEF/;
827 printdebug "C? $c\n" if $debuglevel >= 5;
828 my $v = git_get_config($c);
829 return $v if defined $v;
830 my $dv = $defcfg{$c};
832 printdebug "CD $c $dv\n" if $debuglevel >= 4;
837 "need value for one of: %s\n".
838 "%s: distro or suite appears not to be (properly) supported",
842 sub not_necessarily_a_tree () {
843 # needs to be called from pre_*
844 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
845 $invoked_in_git_tree = 0;
848 sub access_basedistro__noalias () {
849 if (defined $idistro) {
852 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
853 return $def if defined $def;
854 foreach my $src (@gitcfgsources, 'internal') {
855 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
857 foreach my $k (keys %$kl) {
858 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
860 next unless match_glob $dpat, $isuite;
864 return cfg("dgit.default.distro");
868 sub access_basedistro () {
869 my $noalias = access_basedistro__noalias();
870 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
871 return $canon // $noalias;
874 sub access_nomdistro () {
875 my $base = access_basedistro();
876 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
877 $r =~ m/^$distro_re$/ or badcfg
878 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
879 $r, "/^$distro_re$/";
883 sub access_quirk () {
884 # returns (quirk name, distro to use instead or undef, quirk-specific info)
885 my $basedistro = access_basedistro();
886 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
888 if (defined $backports_quirk) {
889 my $re = $backports_quirk;
890 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
892 $re =~ s/\%/([-0-9a-z_]+)/
893 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
894 if ($isuite =~ m/^$re$/) {
895 return ('backports',"$basedistro-backports",$1);
898 return ('none',undef);
903 sub parse_cfg_bool ($$$) {
904 my ($what,$def,$v) = @_;
907 $v =~ m/^[ty1]/ ? 1 :
908 $v =~ m/^[fn0]/ ? 0 :
909 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
913 sub access_forpush_config () {
914 my $d = access_basedistro();
918 parse_cfg_bool('new-private-pushers', 0,
919 cfg("dgit-distro.$d.new-private-pushers",
922 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
925 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
926 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
927 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
929 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
932 sub access_forpush () {
933 $access_forpush //= access_forpush_config();
934 return $access_forpush;
937 sub default_from_access_cfg ($$$;$) {
938 my ($var, $keybase, $defval, $permit_re) = @_;
939 return if defined $$var;
941 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
942 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
944 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
947 badcfg f_ "unknown %s \`%s'", $keybase, $$var
948 if defined $permit_re and $$var !~ m/$permit_re/;
952 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
953 defined $access_forpush and !$access_forpush;
954 badcfg __ "pushing but distro is configured readonly"
955 if access_forpush_config() eq '0';
957 $supplementary_message = __ <<'END' unless $we_are_responder;
958 Push failed, before we got started.
959 You can retry the push, after fixing the problem, if you like.
961 parseopts_late_defaults();
965 parseopts_late_defaults();
968 sub supplementary_message ($) {
970 if (!$we_are_responder) {
971 $supplementary_message = $msg;
974 responder_send_command "supplementary-message ".length($msg)
976 print PO $msg or confess "$!";
980 sub access_distros () {
981 # Returns list of distros to try, in order
984 # 0. `instead of' distro name(s) we have been pointed to
985 # 1. the access_quirk distro, if any
986 # 2a. the user's specified distro, or failing that } basedistro
987 # 2b. the distro calculated from the suite }
988 my @l = access_basedistro();
990 my (undef,$quirkdistro) = access_quirk();
991 unshift @l, $quirkdistro;
992 unshift @l, $instead_distro;
993 @l = grep { defined } @l;
995 push @l, access_nomdistro();
997 if (access_forpush()) {
998 @l = map { ("$_/push", $_) } @l;
1003 sub access_cfg_cfgs (@) {
1006 # The nesting of these loops determines the search order. We put
1007 # the key loop on the outside so that we search all the distros
1008 # for each key, before going on to the next key. That means that
1009 # if access_cfg is called with a more specific, and then a less
1010 # specific, key, an earlier distro can override the less specific
1011 # without necessarily overriding any more specific keys. (If the
1012 # distro wants to override the more specific keys it can simply do
1013 # so; whereas if we did the loop the other way around, it would be
1014 # impossible to for an earlier distro to override a less specific
1015 # key but not the more specific ones without restating the unknown
1016 # values of the more specific keys.
1019 # We have to deal with RETURN-UNDEF specially, so that we don't
1020 # terminate the search prematurely.
1022 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1025 foreach my $d (access_distros()) {
1026 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1028 push @cfgs, map { "dgit.default.$_" } @realkeys;
1029 push @cfgs, @rundef;
1033 sub access_cfg (@) {
1035 my (@cfgs) = access_cfg_cfgs(@keys);
1036 my $value = cfg(@cfgs);
1040 sub access_cfg_bool ($$) {
1041 my ($def, @keys) = @_;
1042 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1045 sub string_to_ssh ($) {
1047 if ($spec =~ m/\s/) {
1048 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1054 sub access_cfg_ssh () {
1055 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1056 if (!defined $gitssh) {
1059 return string_to_ssh $gitssh;
1063 sub access_runeinfo ($) {
1065 return ": dgit ".access_basedistro()." $info ;";
1068 sub access_someuserhost ($) {
1070 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1071 defined($user) && length($user) or
1072 $user = access_cfg("$some-user",'username');
1073 my $host = access_cfg("$some-host");
1074 return length($user) ? "$user\@$host" : $host;
1077 sub access_gituserhost () {
1078 return access_someuserhost('git');
1081 sub access_giturl (;$) {
1082 my ($optional) = @_;
1083 my $url = access_cfg('git-url','RETURN-UNDEF');
1086 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1087 return undef unless defined $proto;
1090 access_gituserhost().
1091 access_cfg('git-path');
1093 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1096 return "$url/$package$suffix";
1099 sub commit_getclogp ($) {
1100 # Returns the parsed changelog hashref for a particular commit
1102 our %commit_getclogp_memo;
1103 my $memo = $commit_getclogp_memo{$objid};
1104 return $memo if $memo;
1106 my $mclog = dgit_privdir()."clog";
1107 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1108 "$objid:debian/changelog";
1109 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1112 sub parse_dscdata () {
1113 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1114 printdebug Dumper($dscdata) if $debuglevel>1;
1115 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1116 printdebug Dumper($dsc) if $debuglevel>1;
1121 sub archive_query ($;@) {
1122 my ($method) = shift @_;
1123 fail __ "this operation does not support multiple comma-separated suites"
1125 my $query = access_cfg('archive-query','RETURN-UNDEF');
1126 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1129 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1132 sub archive_query_prepend_mirror {
1133 my $m = access_cfg('mirror');
1134 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1137 sub pool_dsc_subpath ($$) {
1138 my ($vsn,$component) = @_; # $package is implict arg
1139 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1140 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1143 sub cfg_apply_map ($$$) {
1144 my ($varref, $what, $mapspec) = @_;
1145 return unless $mapspec;
1147 printdebug "config $what EVAL{ $mapspec; }\n";
1149 eval "package Dgit::Config; $mapspec;";
1154 #---------- `ftpmasterapi' archive query method (nascent) ----------
1156 sub archive_api_query_cmd ($) {
1158 my @cmd = (@curl, qw(-sS));
1159 my $url = access_cfg('archive-query-url');
1160 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1162 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1163 foreach my $key (split /\:/, $keys) {
1164 $key =~ s/\%HOST\%/$host/g;
1166 fail "for $url: stat $key: $!" unless $!==ENOENT;
1169 fail f_ "config requested specific TLS key but do not know".
1170 " how to get curl to use exactly that EE key (%s)",
1172 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1173 # # Sadly the above line does not work because of changes
1174 # # to gnutls. The real fix for #790093 may involve
1175 # # new curl options.
1178 # Fixing #790093 properly will involve providing a value
1179 # for this on clients.
1180 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1181 push @cmd, split / /, $kargs if defined $kargs;
1183 push @cmd, $url.$subpath;
1187 sub api_query ($$;$) {
1189 my ($data, $subpath, $ok404) = @_;
1190 badcfg __ "ftpmasterapi archive query method takes no data part"
1192 my @cmd = archive_api_query_cmd($subpath);
1193 my $url = $cmd[$#cmd];
1194 push @cmd, qw(-w %{http_code});
1195 my $json = cmdoutput @cmd;
1196 unless ($json =~ s/\d+\d+\d$//) {
1197 failedcmd_report_cmd undef, @cmd;
1198 fail __ "curl failed to print 3-digit HTTP code";
1201 return undef if $code eq '404' && $ok404;
1202 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1203 unless $url =~ m#^file://# or $code =~ m/^2/;
1204 return decode_json($json);
1207 sub canonicalise_suite_ftpmasterapi {
1208 my ($proto,$data) = @_;
1209 my $suites = api_query($data, 'suites');
1211 foreach my $entry (@$suites) {
1213 my $v = $entry->{$_};
1214 defined $v && $v eq $isuite;
1215 } qw(codename name);
1216 push @matched, $entry;
1218 fail f_ "unknown suite %s, maybe -d would help", $isuite
1222 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1223 $cn = "$matched[0]{codename}";
1224 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1225 $cn =~ m/^$suite_re$/
1226 or die f_ "suite %s maps to bad codename\n", $isuite;
1228 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1233 sub archive_query_ftpmasterapi {
1234 my ($proto,$data) = @_;
1235 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1237 my $digester = Digest::SHA->new(256);
1238 foreach my $entry (@$info) {
1240 my $vsn = "$entry->{version}";
1241 my ($ok,$msg) = version_check $vsn;
1242 die f_ "bad version: %s\n", $msg unless $ok;
1243 my $component = "$entry->{component}";
1244 $component =~ m/^$component_re$/ or die __ "bad component";
1245 my $filename = "$entry->{filename}";
1246 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1247 or die __ "bad filename";
1248 my $sha256sum = "$entry->{sha256sum}";
1249 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1250 push @rows, [ $vsn, "/pool/$component/$filename",
1251 $digester, $sha256sum ];
1253 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1256 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1257 return archive_query_prepend_mirror @rows;
1260 sub file_in_archive_ftpmasterapi {
1261 my ($proto,$data,$filename) = @_;
1262 my $pat = $filename;
1265 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1266 my $info = api_query($data, "file_in_archive/$pat", 1);
1269 sub package_not_wholly_new_ftpmasterapi {
1270 my ($proto,$data,$pkg) = @_;
1271 my $info = api_query($data,"madison?package=${pkg}&f=json");
1275 #---------- `aptget' archive query method ----------
1278 our $aptget_releasefile;
1279 our $aptget_configpath;
1281 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1282 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1284 sub aptget_cache_clean {
1285 runcmd_ordryrun_local qw(sh -ec),
1286 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1290 sub aptget_lock_acquire () {
1291 my $lockfile = "$aptget_base/lock";
1292 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1293 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1296 sub aptget_prep ($) {
1298 return if defined $aptget_base;
1300 badcfg __ "aptget archive query method takes no data part"
1303 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1306 ensuredir "$cache/dgit";
1308 access_cfg('aptget-cachekey','RETURN-UNDEF')
1309 // access_nomdistro();
1311 $aptget_base = "$cache/dgit/aptget";
1312 ensuredir $aptget_base;
1314 my $quoted_base = $aptget_base;
1315 confess "$quoted_base contains bad chars, cannot continue"
1316 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1318 ensuredir $aptget_base;
1320 aptget_lock_acquire();
1322 aptget_cache_clean();
1324 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1325 my $sourceslist = "source.list#$cachekey";
1327 my $aptsuites = $isuite;
1328 cfg_apply_map(\$aptsuites, 'suite map',
1329 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1331 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1332 printf SRCS "deb-src %s %s %s\n",
1333 access_cfg('mirror'),
1335 access_cfg('aptget-components')
1338 ensuredir "$aptget_base/cache";
1339 ensuredir "$aptget_base/lists";
1341 open CONF, ">", $aptget_configpath or confess "$!";
1343 Debug::NoLocking "true";
1344 APT::Get::List-Cleanup "false";
1345 #clear APT::Update::Post-Invoke-Success;
1346 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1347 Dir::State::Lists "$quoted_base/lists";
1348 Dir::Etc::preferences "$quoted_base/preferences";
1349 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1350 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1353 foreach my $key (qw(
1356 Dir::Cache::Archives
1357 Dir::Etc::SourceParts
1358 Dir::Etc::preferencesparts
1360 ensuredir "$aptget_base/$key";
1361 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1364 my $oldatime = (time // confess "$!") - 1;
1365 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1366 next unless stat_exists $oldlist;
1367 my ($mtime) = (stat _)[9];
1368 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1371 runcmd_ordryrun_local aptget_aptget(), qw(update);
1374 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1375 next unless stat_exists $oldlist;
1376 my ($atime) = (stat _)[8];
1377 next if $atime == $oldatime;
1378 push @releasefiles, $oldlist;
1380 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1381 @releasefiles = @inreleasefiles if @inreleasefiles;
1382 if (!@releasefiles) {
1383 fail f_ <<END, $isuite, $cache;
1384 apt seemed to not to update dgit's cached Release files for %s.
1386 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1389 confess "apt updated too many Release files (@releasefiles), erk"
1390 unless @releasefiles == 1;
1392 ($aptget_releasefile) = @releasefiles;
1395 sub canonicalise_suite_aptget {
1396 my ($proto,$data) = @_;
1399 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1401 foreach my $name (qw(Codename Suite)) {
1402 my $val = $release->{$name};
1404 printdebug "release file $name: $val\n";
1405 $val =~ m/^$suite_re$/o or fail f_
1406 "Release file (%s) specifies intolerable %s",
1407 $aptget_releasefile, $name;
1408 cfg_apply_map(\$val, 'suite rmap',
1409 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1416 sub archive_query_aptget {
1417 my ($proto,$data) = @_;
1420 ensuredir "$aptget_base/source";
1421 foreach my $old (<$aptget_base/source/*.dsc>) {
1422 unlink $old or die "$old: $!";
1425 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1426 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1427 # avoids apt-get source failing with ambiguous error code
1429 runcmd_ordryrun_local
1430 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1431 aptget_aptget(), qw(--download-only --only-source source), $package;
1433 my @dscs = <$aptget_base/source/*.dsc>;
1434 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1435 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1438 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1441 my $uri = "file://". uri_escape $dscs[0];
1442 $uri =~ s{\%2f}{/}gi;
1443 return [ (getfield $pre_dsc, 'Version'), $uri ];
1446 sub file_in_archive_aptget () { return undef; }
1447 sub package_not_wholly_new_aptget () { return undef; }
1449 #---------- `dummyapicat' archive query method ----------
1450 # (untranslated, because this is for testing purposes etc.)
1452 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1453 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1455 sub dummycatapi_run_in_mirror ($@) {
1456 # runs $fn with FIA open onto rune
1457 my ($rune, $argl, $fn) = @_;
1459 my $mirror = access_cfg('mirror');
1460 $mirror =~ s#^file://#/# or die "$mirror ?";
1461 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1462 qw(x), $mirror, @$argl);
1463 debugcmd "-|", @cmd;
1464 open FIA, "-|", @cmd or confess "$!";
1466 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1470 sub file_in_archive_dummycatapi ($$$) {
1471 my ($proto,$data,$filename) = @_;
1473 dummycatapi_run_in_mirror '
1474 find -name "$1" -print0 |
1476 ', [$filename], sub {
1479 printdebug "| $_\n";
1480 m/^(\w+) (\S+)$/ or die "$_ ?";
1481 push @out, { sha256sum => $1, filename => $2 };
1487 sub package_not_wholly_new_dummycatapi {
1488 my ($proto,$data,$pkg) = @_;
1489 dummycatapi_run_in_mirror "
1490 find -name ${pkg}_*.dsc
1497 #---------- `madison' archive query method ----------
1499 sub archive_query_madison {
1500 return archive_query_prepend_mirror
1501 map { [ @$_[0..1] ] } madison_get_parse(@_);
1504 sub madison_get_parse {
1505 my ($proto,$data) = @_;
1506 die unless $proto eq 'madison';
1507 if (!length $data) {
1508 $data= access_cfg('madison-distro','RETURN-UNDEF');
1509 $data //= access_basedistro();
1511 $rmad{$proto,$data,$package} ||= cmdoutput
1512 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1513 my $rmad = $rmad{$proto,$data,$package};
1516 foreach my $l (split /\n/, $rmad) {
1517 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1518 \s*( [^ \t|]+ )\s* \|
1519 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1520 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1521 $1 eq $package or die "$rmad $package ?";
1528 $component = access_cfg('archive-query-default-component');
1530 $5 eq 'source' or die "$rmad ?";
1531 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1533 return sort { -version_compare($a->[0],$b->[0]); } @out;
1536 sub canonicalise_suite_madison {
1537 # madison canonicalises for us
1538 my @r = madison_get_parse(@_);
1540 "unable to canonicalise suite using package %s".
1541 " which does not appear to exist in suite %s;".
1542 " --existing-package may help",
1547 sub file_in_archive_madison { return undef; }
1548 sub package_not_wholly_new_madison { return undef; }
1550 #---------- `sshpsql' archive query method ----------
1551 # (untranslated, because this is obsolete)
1554 my ($data,$runeinfo,$sql) = @_;
1555 if (!length $data) {
1556 $data= access_someuserhost('sshpsql').':'.
1557 access_cfg('sshpsql-dbname');
1559 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1560 my ($userhost,$dbname) = ($`,$'); #';
1562 my @cmd = (access_cfg_ssh, $userhost,
1563 access_runeinfo("ssh-psql $runeinfo").
1564 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1565 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1567 open P, "-|", @cmd or confess "$!";
1570 printdebug(">|$_|\n");
1573 $!=0; $?=0; close P or failedcmd @cmd;
1575 my $nrows = pop @rows;
1576 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1577 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1578 @rows = map { [ split /\|/, $_ ] } @rows;
1579 my $ncols = scalar @{ shift @rows };
1580 die if grep { scalar @$_ != $ncols } @rows;
1584 sub sql_injection_check {
1585 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1588 sub archive_query_sshpsql ($$) {
1589 my ($proto,$data) = @_;
1590 sql_injection_check $isuite, $package;
1591 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1592 SELECT source.version, component.name, files.filename, files.sha256sum
1594 JOIN src_associations ON source.id = src_associations.source
1595 JOIN suite ON suite.id = src_associations.suite
1596 JOIN dsc_files ON dsc_files.source = source.id
1597 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1598 JOIN component ON component.id = files_archive_map.component_id
1599 JOIN files ON files.id = dsc_files.file
1600 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1601 AND source.source='$package'
1602 AND files.filename LIKE '%.dsc';
1604 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1605 my $digester = Digest::SHA->new(256);
1607 my ($vsn,$component,$filename,$sha256sum) = @$_;
1608 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1610 return archive_query_prepend_mirror @rows;
1613 sub canonicalise_suite_sshpsql ($$) {
1614 my ($proto,$data) = @_;
1615 sql_injection_check $isuite;
1616 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1617 SELECT suite.codename
1618 FROM suite where suite_name='$isuite' or codename='$isuite';
1620 @rows = map { $_->[0] } @rows;
1621 fail "unknown suite $isuite" unless @rows;
1622 die "ambiguous $isuite: @rows ?" if @rows>1;
1626 sub file_in_archive_sshpsql ($$$) { return undef; }
1627 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1629 #---------- `dummycat' archive query method ----------
1630 # (untranslated, because this is for testing purposes etc.)
1632 sub canonicalise_suite_dummycat ($$) {
1633 my ($proto,$data) = @_;
1634 my $dpath = "$data/suite.$isuite";
1635 if (!open C, "<", $dpath) {
1636 $!==ENOENT or die "$dpath: $!";
1637 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1641 chomp or die "$dpath: $!";
1643 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1647 sub archive_query_dummycat ($$) {
1648 my ($proto,$data) = @_;
1649 canonicalise_suite();
1650 my $dpath = "$data/package.$csuite.$package";
1651 if (!open C, "<", $dpath) {
1652 $!==ENOENT or die "$dpath: $!";
1653 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1661 printdebug "dummycat query $csuite $package $dpath | $_\n";
1662 my @row = split /\s+/, $_;
1663 @row==2 or die "$dpath: $_ ?";
1666 C->error and die "$dpath: $!";
1668 return archive_query_prepend_mirror
1669 sort { -version_compare($a->[0],$b->[0]); } @rows;
1672 sub file_in_archive_dummycat () { return undef; }
1673 sub package_not_wholly_new_dummycat () { return undef; }
1675 #---------- archive query entrypoints and rest of program ----------
1677 sub canonicalise_suite () {
1678 return if defined $csuite;
1679 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1680 $csuite = archive_query('canonicalise_suite');
1681 if ($isuite ne $csuite) {
1682 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1684 progress f_ "canonical suite name is %s", $csuite;
1688 sub get_archive_dsc () {
1689 canonicalise_suite();
1690 my @vsns = archive_query('archive_query');
1691 foreach my $vinfo (@vsns) {
1692 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1693 $dscurl = $vsn_dscurl;
1694 $dscdata = url_get($dscurl);
1696 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1701 $digester->add($dscdata);
1702 my $got = $digester->hexdigest();
1704 fail f_ "%s has hash %s but archive told us to expect %s",
1705 $dscurl, $got, $digest;
1708 my $fmt = getfield $dsc, 'Format';
1709 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1710 f_ "unsupported source format %s, sorry", $fmt;
1712 $dsc_checked = !!$digester;
1713 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1717 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1720 sub check_for_git ();
1721 sub check_for_git () {
1723 my $how = access_cfg('git-check');
1724 if ($how eq 'ssh-cmd') {
1726 (access_cfg_ssh, access_gituserhost(),
1727 access_runeinfo("git-check $package").
1728 " set -e; cd ".access_cfg('git-path').";".
1729 " if test -d $package.git; then echo 1; else echo 0; fi");
1730 my $r= cmdoutput @cmd;
1731 if (defined $r and $r =~ m/^divert (\w+)$/) {
1733 my ($usedistro,) = access_distros();
1734 # NB that if we are pushing, $usedistro will be $distro/push
1735 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1736 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1737 progress f_ "diverting to %s (using config for %s)",
1738 $divert, $instead_distro;
1739 return check_for_git();
1741 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1743 } elsif ($how eq 'url') {
1744 my $prefix = access_cfg('git-check-url','git-url');
1745 my $suffix = access_cfg('git-check-suffix','git-suffix',
1746 'RETURN-UNDEF') // '.git';
1747 my $url = "$prefix/$package$suffix";
1748 my @cmd = (@curl, qw(-sS -I), $url);
1749 my $result = cmdoutput @cmd;
1750 $result =~ s/^\S+ 200 .*\n\r?\n//;
1751 # curl -sS -I with https_proxy prints
1752 # HTTP/1.0 200 Connection established
1753 $result =~ m/^\S+ (404|200) /s or
1754 fail +(__ "unexpected results from git check query - ").
1755 Dumper($prefix, $result);
1757 if ($code eq '404') {
1759 } elsif ($code eq '200') {
1764 } elsif ($how eq 'true') {
1766 } elsif ($how eq 'false') {
1769 badcfg f_ "unknown git-check \`%s'", $how;
1773 sub create_remote_git_repo () {
1774 my $how = access_cfg('git-create');
1775 if ($how eq 'ssh-cmd') {
1777 (access_cfg_ssh, access_gituserhost(),
1778 access_runeinfo("git-create $package").
1779 "set -e; cd ".access_cfg('git-path').";".
1780 " cp -a _template $package.git");
1781 } elsif ($how eq 'true') {
1784 badcfg f_ "unknown git-create \`%s'", $how;
1788 our ($dsc_hash,$lastpush_mergeinput);
1789 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1793 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1794 $playground = fresh_playground 'dgit/unpack';
1797 sub mktree_in_ud_here () {
1798 playtree_setup $gitcfgs{local};
1801 sub git_write_tree () {
1802 my $tree = cmdoutput @git, qw(write-tree);
1803 $tree =~ m/^\w+$/ or die "$tree ?";
1807 sub git_add_write_tree () {
1808 runcmd @git, qw(add -Af .);
1809 return git_write_tree();
1812 sub remove_stray_gits ($) {
1814 my @gitscmd = qw(find -name .git -prune -print0);
1815 debugcmd "|",@gitscmd;
1816 open GITS, "-|", @gitscmd or confess "$!";
1821 print STDERR f_ "%s: warning: removing from %s: %s\n",
1822 $us, $what, (messagequote $_);
1826 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1829 sub mktree_in_ud_from_only_subdir ($;$) {
1830 my ($what,$raw) = @_;
1831 # changes into the subdir
1834 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1835 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1839 remove_stray_gits($what);
1840 mktree_in_ud_here();
1842 my ($format, $fopts) = get_source_format();
1843 if (madformat($format)) {
1848 my $tree=git_add_write_tree();
1849 return ($tree,$dir);
1852 our @files_csum_info_fields =
1853 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1854 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1855 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1857 sub dsc_files_info () {
1858 foreach my $csumi (@files_csum_info_fields) {
1859 my ($fname, $module, $method) = @$csumi;
1860 my $field = $dsc->{$fname};
1861 next unless defined $field;
1862 eval "use $module; 1;" or die $@;
1864 foreach (split /\n/, $field) {
1866 m/^(\w+) (\d+) (\S+)$/ or
1867 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1868 my $digester = eval "$module"."->$method;" or die $@;
1873 Digester => $digester,
1878 fail f_ "missing any supported Checksums-* or Files field in %s",
1879 $dsc->get_option('name');
1883 map { $_->{Filename} } dsc_files_info();
1886 sub files_compare_inputs (@) {
1891 my $showinputs = sub {
1892 return join "; ", map { $_->get_option('name') } @$inputs;
1895 foreach my $in (@$inputs) {
1897 my $in_name = $in->get_option('name');
1899 printdebug "files_compare_inputs $in_name\n";
1901 foreach my $csumi (@files_csum_info_fields) {
1902 my ($fname) = @$csumi;
1903 printdebug "files_compare_inputs $in_name $fname\n";
1905 my $field = $in->{$fname};
1906 next unless defined $field;
1909 foreach (split /\n/, $field) {
1912 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1913 fail "could not parse $in_name $fname line \`$_'";
1915 printdebug "files_compare_inputs $in_name $fname $f\n";
1919 my $re = \ $record{$f}{$fname};
1921 $fchecked{$f}{$in_name} = 1;
1924 "hash or size of %s varies in %s fields (between: %s)",
1925 $f, $fname, $showinputs->();
1930 @files = sort @files;
1931 $expected_files //= \@files;
1932 "@$expected_files" eq "@files" or
1933 fail f_ "file list in %s varies between hash fields!",
1937 fail f_ "%s has no files list field(s)", $in_name;
1939 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1942 grep { keys %$_ == @$inputs-1 } values %fchecked
1943 or fail f_ "no file appears in all file lists (looked in: %s)",
1947 sub is_orig_file_in_dsc ($$) {
1948 my ($f, $dsc_files_info) = @_;
1949 return 0 if @$dsc_files_info <= 1;
1950 # One file means no origs, and the filename doesn't have a "what
1951 # part of dsc" component. (Consider versions ending `.orig'.)
1952 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1956 # This function determines whether a .changes file is source-only from
1957 # the point of view of dak. Thus, it permits *_source.buildinfo
1960 # It does not, however, permit any other buildinfo files. After a
1961 # source-only upload, the buildds will try to upload files like
1962 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1963 # named like this in their (otherwise) source-only upload, the uploads
1964 # of the buildd can be rejected by dak. Fixing the resultant
1965 # situation can require manual intervention. So we block such
1966 # .buildinfo files when the user tells us to perform a source-only
1967 # upload (such as when using the push-source subcommand with the -C
1968 # option, which calls this function).
1970 # Note, though, that when dgit is told to prepare a source-only
1971 # upload, such as when subcommands like build-source and push-source
1972 # without -C are used, dgit has a more restrictive notion of
1973 # source-only .changes than dak: such uploads will never include
1974 # *_source.buildinfo files. This is because there is no use for such
1975 # files when using a tool like dgit to produce the source package, as
1976 # dgit ensures the source is identical to git HEAD.
1977 sub test_source_only_changes ($) {
1979 foreach my $l (split /\n/, getfield $changes, 'Files') {
1980 $l =~ m/\S+$/ or next;
1981 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1982 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1983 print f_ "purportedly source-only changes polluted by %s\n", $&;
1990 sub changes_update_origs_from_dsc ($$$$) {
1991 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1993 printdebug "checking origs needed ($upstreamvsn)...\n";
1994 $_ = getfield $changes, 'Files';
1995 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1996 fail __ "cannot find section/priority from .changes Files field";
1997 my $placementinfo = $1;
1999 printdebug "checking origs needed placement '$placementinfo'...\n";
2000 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2001 $l =~ m/\S+$/ or next;
2003 printdebug "origs $file | $l\n";
2004 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2005 printdebug "origs $file is_orig\n";
2006 my $have = archive_query('file_in_archive', $file);
2007 if (!defined $have) {
2008 print STDERR __ <<END;
2009 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2015 printdebug "origs $file \$#\$have=$#$have\n";
2016 foreach my $h (@$have) {
2019 foreach my $csumi (@files_csum_info_fields) {
2020 my ($fname, $module, $method, $archivefield) = @$csumi;
2021 next unless defined $h->{$archivefield};
2022 $_ = $dsc->{$fname};
2023 next unless defined;
2024 m/^(\w+) .* \Q$file\E$/m or
2025 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2026 if ($h->{$archivefield} eq $1) {
2030 "%s: %s (archive) != %s (local .dsc)",
2031 $archivefield, $h->{$archivefield}, $1;
2034 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2038 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2041 printdebug "origs $file f.same=$found_same".
2042 " #f._differ=$#found_differ\n";
2043 if (@found_differ && !$found_same) {
2045 (f_ "archive contains %s with different checksum", $file),
2048 # Now we edit the changes file to add or remove it
2049 foreach my $csumi (@files_csum_info_fields) {
2050 my ($fname, $module, $method, $archivefield) = @$csumi;
2051 next unless defined $changes->{$fname};
2053 # in archive, delete from .changes if it's there
2054 $changed{$file} = "removed" if
2055 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2056 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2057 # not in archive, but it's here in the .changes
2059 my $dsc_data = getfield $dsc, $fname;
2060 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2062 $extra =~ s/ \d+ /$&$placementinfo /
2063 or confess "$fname $extra >$dsc_data< ?"
2064 if $fname eq 'Files';
2065 $changes->{$fname} .= "\n". $extra;
2066 $changed{$file} = "added";
2071 foreach my $file (keys %changed) {
2073 "edited .changes for archive .orig contents: %s %s",
2074 $changed{$file}, $file;
2076 my $chtmp = "$changesfile.tmp";
2077 $changes->save($chtmp);
2079 rename $chtmp,$changesfile or die "$changesfile $!";
2081 progress f_ "[new .changes left in %s]", $changesfile;
2084 progress f_ "%s already has appropriate .orig(s) (if any)",
2089 sub make_commit ($) {
2091 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2094 sub clogp_authline ($) {
2096 my $author = getfield $clogp, 'Maintainer';
2097 if ($author =~ m/^[^"\@]+\,/) {
2098 # single entry Maintainer field with unquoted comma
2099 $author = ($& =~ y/,//rd).$'; # strip the comma
2101 # git wants a single author; any remaining commas in $author
2102 # are by now preceded by @ (or "). It seems safer to punt on
2103 # "..." for now rather than attempting to dequote or something.
2104 $author =~ s#,.*##ms unless $author =~ m/"/;
2105 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2106 my $authline = "$author $date";
2107 $authline =~ m/$git_authline_re/o or
2108 fail f_ "unexpected commit author line format \`%s'".
2109 " (was generated from changelog Maintainer field)",
2111 return ($1,$2,$3) if wantarray;
2115 sub vendor_patches_distro ($$) {
2116 my ($checkdistro, $what) = @_;
2117 return unless defined $checkdistro;
2119 my $series = "debian/patches/\L$checkdistro\E.series";
2120 printdebug "checking for vendor-specific $series ($what)\n";
2122 if (!open SERIES, "<", $series) {
2123 confess "$series $!" unless $!==ENOENT;
2130 print STDERR __ <<END;
2132 Unfortunately, this source package uses a feature of dpkg-source where
2133 the same source package unpacks to different source code on different
2134 distros. dgit cannot safely operate on such packages on affected
2135 distros, because the meaning of source packages is not stable.
2137 Please ask the distro/maintainer to remove the distro-specific series
2138 files and use a different technique (if necessary, uploading actually
2139 different packages, if different distros are supposed to have
2143 fail f_ "Found active distro-specific series file for".
2144 " %s (%s): %s, cannot continue",
2145 $checkdistro, $what, $series;
2147 die "$series $!" if SERIES->error;
2151 sub check_for_vendor_patches () {
2152 # This dpkg-source feature doesn't seem to be documented anywhere!
2153 # But it can be found in the changelog (reformatted):
2155 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2156 # Author: Raphael Hertzog <hertzog@debian.org>
2157 # Date: Sun Oct 3 09:36:48 2010 +0200
2159 # dpkg-source: correctly create .pc/.quilt_series with alternate
2162 # If you have debian/patches/ubuntu.series and you were
2163 # unpacking the source package on ubuntu, quilt was still
2164 # directed to debian/patches/series instead of
2165 # debian/patches/ubuntu.series.
2167 # debian/changelog | 3 +++
2168 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2169 # 2 files changed, 6 insertions(+), 1 deletion(-)
2172 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2173 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2174 __ "Dpkg::Vendor \`current vendor'");
2175 vendor_patches_distro(access_basedistro(),
2176 __ "(base) distro being accessed");
2177 vendor_patches_distro(access_nomdistro(),
2178 __ "(nominal) distro being accessed");
2181 sub check_bpd_exists () {
2182 stat $buildproductsdir
2183 or fail f_ "build-products-dir %s is not accessible: %s\n",
2184 $buildproductsdir, $!;
2187 sub dotdot_bpd_transfer_origs ($$$) {
2188 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2189 # checks is_orig_file_of_vsn and if
2190 # calls $wanted->{$leaf} and expects boolish
2192 return if $buildproductsdir eq '..';
2195 my $dotdot = $maindir;
2196 $dotdot =~ s{/[^/]+$}{};
2197 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2198 while ($!=0, defined(my $leaf = readdir DD)) {
2200 local ($debuglevel) = $debuglevel-1;
2201 printdebug "DD_BPD $leaf ?\n";
2203 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2204 next unless $wanted->($leaf);
2205 next if lstat "$bpd_abs/$leaf";
2208 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2211 $! == &ENOENT or fail f_
2212 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2213 lstat "$dotdot/$leaf" or fail f_
2214 "check orig file %s in ..: %s", $leaf, $!;
2216 stat "$dotdot/$leaf" or fail f_
2217 "check target of orig symlink %s in ..: %s", $leaf, $!;
2218 my $ltarget = readlink "$dotdot/$leaf" or
2219 die "readlink $dotdot/$leaf: $!";
2220 if ($ltarget !~ m{^/}) {
2221 $ltarget = "$dotdot/$ltarget";
2223 symlink $ltarget, "$bpd_abs/$leaf"
2224 or die "$ltarget $bpd_abs $leaf: $!";
2226 "%s: cloned orig symlink from ..: %s\n",
2228 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2230 "%s: hardlinked orig from ..: %s\n",
2232 } elsif ($! != EXDEV) {
2233 fail f_ "failed to make %s a hardlink to %s: %s",
2234 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2236 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2237 or die "$bpd_abs $dotdot $leaf $!";
2239 "%s: symmlinked orig from .. on other filesystem: %s\n",
2243 die "$dotdot; $!" if $!;
2247 sub generate_commits_from_dsc () {
2248 # See big comment in fetch_from_archive, below.
2249 # See also README.dsc-import.
2251 changedir $playground;
2253 my $bpd_abs = bpd_abs();
2254 my $upstreamv = upstreamversion $dsc->{version};
2255 my @dfi = dsc_files_info();
2257 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2258 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2260 foreach my $fi (@dfi) {
2261 my $f = $fi->{Filename};
2262 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2263 my $upper_f = "$bpd_abs/$f";
2265 printdebug "considering reusing $f: ";
2267 if (link_ltarget "$upper_f,fetch", $f) {
2268 printdebug "linked (using ...,fetch).\n";
2269 } elsif ((printdebug "($!) "),
2271 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2272 } elsif (link_ltarget $upper_f, $f) {
2273 printdebug "linked.\n";
2274 } elsif ((printdebug "($!) "),
2276 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2278 printdebug "absent.\n";
2282 complete_file_from_dsc('.', $fi, \$refetched)
2285 printdebug "considering saving $f: ";
2287 if (rename_link_xf 1, $f, $upper_f) {
2288 printdebug "linked.\n";
2289 } elsif ((printdebug "($@) "),
2291 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2292 } elsif (!$refetched) {
2293 printdebug "no need.\n";
2294 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2295 printdebug "linked (using ...,fetch).\n";
2296 } elsif ((printdebug "($@) "),
2298 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2300 printdebug "cannot.\n";
2304 # We unpack and record the orig tarballs first, so that we only
2305 # need disk space for one private copy of the unpacked source.
2306 # But we can't make them into commits until we have the metadata
2307 # from the debian/changelog, so we record the tree objects now and
2308 # make them into commits later.
2310 my $orig_f_base = srcfn $upstreamv, '';
2312 foreach my $fi (@dfi) {
2313 # We actually import, and record as a commit, every tarball
2314 # (unless there is only one file, in which case there seems
2317 my $f = $fi->{Filename};
2318 printdebug "import considering $f ";
2319 (printdebug "only one dfi\n"), next if @dfi == 1;
2320 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2321 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2325 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2327 printdebug "Y ", (join ' ', map { $_//"(none)" }
2328 $compr_ext, $orig_f_part
2331 my $input = new IO::File $f, '<' or die "$f $!";
2335 if (defined $compr_ext) {
2337 Dpkg::Compression::compression_guess_from_filename $f;
2338 fail "Dpkg::Compression cannot handle file $f in source package"
2339 if defined $compr_ext && !defined $cname;
2341 new Dpkg::Compression::Process compression => $cname;
2342 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2343 my $compr_fh = new IO::Handle;
2344 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2346 open STDIN, "<&", $input or confess "$!";
2348 die "dgit (child): exec $compr_cmd[0]: $!\n";
2353 rmtree "_unpack-tar";
2354 mkdir "_unpack-tar" or confess "$!";
2355 my @tarcmd = qw(tar -x -f -
2356 --no-same-owner --no-same-permissions
2357 --no-acls --no-xattrs --no-selinux);
2358 my $tar_pid = fork // confess "$!";
2360 chdir "_unpack-tar" or confess "$!";
2361 open STDIN, "<&", $input or confess "$!";
2363 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2365 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2366 !$? or failedcmd @tarcmd;
2369 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2371 # finally, we have the results in "tarball", but maybe
2372 # with the wrong permissions
2374 runcmd qw(chmod -R +rwX _unpack-tar);
2375 changedir "_unpack-tar";
2376 remove_stray_gits($f);
2377 mktree_in_ud_here();
2379 my ($tree) = git_add_write_tree();
2380 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2381 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2383 printdebug "one subtree $1\n";
2385 printdebug "multiple subtrees\n";
2388 rmtree "_unpack-tar";
2390 my $ent = [ $f, $tree ];
2392 Orig => !!$orig_f_part,
2393 Sort => (!$orig_f_part ? 2 :
2394 $orig_f_part =~ m/-/g ? 1 :
2402 # put any without "_" first (spec is not clear whether files
2403 # are always in the usual order). Tarballs without "_" are
2404 # the main orig or the debian tarball.
2405 $a->{Sort} <=> $b->{Sort} or
2409 my $any_orig = grep { $_->{Orig} } @tartrees;
2411 my $dscfn = "$package.dsc";
2413 my $treeimporthow = 'package';
2415 open D, ">", $dscfn or die "$dscfn: $!";
2416 print D $dscdata or die "$dscfn: $!";
2417 close D or die "$dscfn: $!";
2418 my @cmd = qw(dpkg-source);
2419 push @cmd, '--no-check' if $dsc_checked;
2420 if (madformat $dsc->{format}) {
2421 push @cmd, '--skip-patches';
2422 $treeimporthow = 'unpatched';
2424 push @cmd, qw(-x --), $dscfn;
2427 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2428 if (madformat $dsc->{format}) {
2429 check_for_vendor_patches();
2433 if (madformat $dsc->{format}) {
2434 my @pcmd = qw(dpkg-source --before-build .);
2435 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2437 $dappliedtree = git_add_write_tree();
2440 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2444 printdebug "import clog search...\n";
2445 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2446 my ($thisstanza, $desc) = @_;
2447 no warnings qw(exiting);
2449 $clogp //= $thisstanza;
2451 printdebug "import clog $thisstanza->{version} $desc...\n";
2453 last if !$any_orig; # we don't need $r1clogp
2455 # We look for the first (most recent) changelog entry whose
2456 # version number is lower than the upstream version of this
2457 # package. Then the last (least recent) previous changelog
2458 # entry is treated as the one which introduced this upstream
2459 # version and used for the synthetic commits for the upstream
2462 # One might think that a more sophisticated algorithm would be
2463 # necessary. But: we do not want to scan the whole changelog
2464 # file. Stopping when we see an earlier version, which
2465 # necessarily then is an earlier upstream version, is the only
2466 # realistic way to do that. Then, either the earliest
2467 # changelog entry we have seen so far is indeed the earliest
2468 # upload of this upstream version; or there are only changelog
2469 # entries relating to later upstream versions (which is not
2470 # possible unless the changelog and .dsc disagree about the
2471 # version). Then it remains to choose between the physically
2472 # last entry in the file, and the one with the lowest version
2473 # number. If these are not the same, we guess that the
2474 # versions were created in a non-monotonic order rather than
2475 # that the changelog entries have been misordered.
2477 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2479 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2480 $r1clogp = $thisstanza;
2482 printdebug "import clog $r1clogp->{version} becomes r1\n";
2485 $clogp or fail __ "package changelog has no entries!";
2487 my $authline = clogp_authline $clogp;
2488 my $changes = getfield $clogp, 'Changes';
2489 $changes =~ s/^\n//; # Changes: \n
2490 my $cversion = getfield $clogp, 'Version';
2493 $r1clogp //= $clogp; # maybe there's only one entry;
2494 my $r1authline = clogp_authline $r1clogp;
2495 # Strictly, r1authline might now be wrong if it's going to be
2496 # unused because !$any_orig. Whatever.
2498 printdebug "import tartrees authline $authline\n";
2499 printdebug "import tartrees r1authline $r1authline\n";
2501 foreach my $tt (@tartrees) {
2502 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2504 my $mbody = f_ "Import %s", $tt->{F};
2505 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2508 committer $r1authline
2512 [dgit import orig $tt->{F}]
2520 [dgit import tarball $package $cversion $tt->{F}]
2525 printdebug "import main commit\n";
2527 open C, ">../commit.tmp" or confess "$!";
2528 print C <<END or confess "$!";
2531 print C <<END or confess "$!" foreach @tartrees;
2534 print C <<END or confess "$!";
2540 [dgit import $treeimporthow $package $cversion]
2543 close C or confess "$!";
2544 my $rawimport_hash = make_commit qw(../commit.tmp);
2546 if (madformat $dsc->{format}) {
2547 printdebug "import apply patches...\n";
2549 # regularise the state of the working tree so that
2550 # the checkout of $rawimport_hash works nicely.
2551 my $dappliedcommit = make_commit_text(<<END);
2558 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2560 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2562 # We need the answers to be reproducible
2563 my @authline = clogp_authline($clogp);
2564 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2565 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2566 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2567 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2568 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2569 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2571 my $path = $ENV{PATH} or die;
2573 # we use ../../gbp-pq-output, which (given that we are in
2574 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2577 foreach my $use_absurd (qw(0 1)) {
2578 runcmd @git, qw(checkout -q unpa);
2579 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2580 local $ENV{PATH} = $path;
2583 progress "warning: $@";
2584 $path = "$absurdity:$path";
2585 progress f_ "%s: trying slow absurd-git-apply...", $us;
2586 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2591 die "forbid absurd git-apply\n" if $use_absurd
2592 && forceing [qw(import-gitapply-no-absurd)];
2593 die "only absurd git-apply!\n" if !$use_absurd
2594 && forceing [qw(import-gitapply-absurd)];
2596 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2597 local $ENV{PATH} = $path if $use_absurd;
2599 my @showcmd = (gbp_pq, qw(import));
2600 my @realcmd = shell_cmd
2601 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2602 debugcmd "+",@realcmd;
2603 if (system @realcmd) {
2604 die f_ "%s failed: %s\n",
2605 +(shellquote @showcmd),
2606 failedcmd_waitstatus();
2609 my $gapplied = git_rev_parse('HEAD');
2610 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2611 $gappliedtree eq $dappliedtree or
2612 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2613 gbp-pq import and dpkg-source disagree!
2614 gbp-pq import gave commit %s
2615 gbp-pq import gave tree %s
2616 dpkg-source --before-build gave tree %s
2618 $rawimport_hash = $gapplied;
2623 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2628 progress f_ "synthesised git commit from .dsc %s", $cversion;
2630 my $rawimport_mergeinput = {
2631 Commit => $rawimport_hash,
2632 Info => __ "Import of source package",
2634 my @output = ($rawimport_mergeinput);
2636 if ($lastpush_mergeinput) {
2637 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2638 my $oversion = getfield $oldclogp, 'Version';
2640 version_compare($oversion, $cversion);
2642 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2643 { ReverseParents => 1,
2644 Message => (f_ <<END, $package, $cversion, $csuite) });
2645 Record %s (%s) in archive suite %s
2647 } elsif ($vcmp > 0) {
2648 print STDERR f_ <<END, $cversion, $oversion,
2650 Version actually in archive: %s (older)
2651 Last version pushed with dgit: %s (newer or same)
2654 __ $later_warning_msg or confess "$!";
2655 @output = $lastpush_mergeinput;
2657 # Same version. Use what's in the server git branch,
2658 # discarding our own import. (This could happen if the
2659 # server automatically imports all packages into git.)
2660 @output = $lastpush_mergeinput;
2668 sub complete_file_from_dsc ($$;$) {
2669 our ($dstdir, $fi, $refetched) = @_;
2670 # Ensures that we have, in $dstdir, the file $fi, with the correct
2671 # contents. (Downloading it from alongside $dscurl if necessary.)
2672 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2673 # and will set $$refetched=1 if it did so (or tried to).
2675 my $f = $fi->{Filename};
2676 my $tf = "$dstdir/$f";
2680 my $checkhash = sub {
2681 open F, "<", "$tf" or die "$tf: $!";
2682 $fi->{Digester}->reset();
2683 $fi->{Digester}->addfile(*F);
2684 F->error and confess "$!";
2685 $got = $fi->{Digester}->hexdigest();
2686 return $got eq $fi->{Hash};
2689 if (stat_exists $tf) {
2690 if ($checkhash->()) {
2691 progress f_ "using existing %s", $f;
2695 fail f_ "file %s has hash %s but .dsc demands hash %s".
2696 " (perhaps you should delete this file?)",
2697 $f, $got, $fi->{Hash};
2699 progress f_ "need to fetch correct version of %s", $f;
2700 unlink $tf or die "$tf $!";
2703 printdebug "$tf does not exist, need to fetch\n";
2707 $furl =~ s{/[^/]+$}{};
2709 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2710 die "$f ?" if $f =~ m#/#;
2711 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2712 return 0 if !act_local();
2715 fail f_ "file %s has hash %s but .dsc demands hash %s".
2716 " (got wrong file from archive!)",
2717 $f, $got, $fi->{Hash};
2722 sub ensure_we_have_orig () {
2723 my @dfi = dsc_files_info();
2724 foreach my $fi (@dfi) {
2725 my $f = $fi->{Filename};
2726 next unless is_orig_file_in_dsc($f, \@dfi);
2727 complete_file_from_dsc($buildproductsdir, $fi)
2732 #---------- git fetch ----------
2734 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2735 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2737 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2738 # locally fetched refs because they have unhelpful names and clutter
2739 # up gitk etc. So we track whether we have "used up" head ref (ie,
2740 # whether we have made another local ref which refers to this object).
2742 # (If we deleted them unconditionally, then we might end up
2743 # re-fetching the same git objects each time dgit fetch was run.)
2745 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2746 # in git_fetch_us to fetch the refs in question, and possibly a call
2747 # to lrfetchref_used.
2749 our (%lrfetchrefs_f, %lrfetchrefs_d);
2750 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2752 sub lrfetchref_used ($) {
2753 my ($fullrefname) = @_;
2754 my $objid = $lrfetchrefs_f{$fullrefname};
2755 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2758 sub git_lrfetch_sane {
2759 my ($url, $supplementary, @specs) = @_;
2760 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2761 # at least as regards @specs. Also leave the results in
2762 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2763 # able to clean these up.
2765 # With $supplementary==1, @specs must not contain wildcards
2766 # and we add to our previous fetches (non-atomically).
2768 # This is rather miserable:
2769 # When git fetch --prune is passed a fetchspec ending with a *,
2770 # it does a plausible thing. If there is no * then:
2771 # - it matches subpaths too, even if the supplied refspec
2772 # starts refs, and behaves completely madly if the source
2773 # has refs/refs/something. (See, for example, Debian #NNNN.)
2774 # - if there is no matching remote ref, it bombs out the whole
2776 # We want to fetch a fixed ref, and we don't know in advance
2777 # if it exists, so this is not suitable.
2779 # Our workaround is to use git ls-remote. git ls-remote has its
2780 # own qairks. Notably, it has the absurd multi-tail-matching
2781 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2782 # refs/refs/foo etc.
2784 # Also, we want an idempotent snapshot, but we have to make two
2785 # calls to the remote: one to git ls-remote and to git fetch. The
2786 # solution is use git ls-remote to obtain a target state, and
2787 # git fetch to try to generate it. If we don't manage to generate
2788 # the target state, we try again.
2790 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2792 my $specre = join '|', map {
2795 my $wildcard = $x =~ s/\\\*$/.*/;
2796 die if $wildcard && $supplementary;
2799 printdebug "git_lrfetch_sane specre=$specre\n";
2800 my $wanted_rref = sub {
2802 return m/^(?:$specre)$/;
2805 my $fetch_iteration = 0;
2808 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2809 if (++$fetch_iteration > 10) {
2810 fail __ "too many iterations trying to get sane fetch!";
2813 my @look = map { "refs/$_" } @specs;
2814 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2818 open GITLS, "-|", @lcmd or confess "$!";
2820 printdebug "=> ", $_;
2821 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2822 my ($objid,$rrefname) = ($1,$2);
2823 if (!$wanted_rref->($rrefname)) {
2824 print STDERR f_ <<END, "@look", $rrefname;
2825 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2829 $wantr{$rrefname} = $objid;
2832 close GITLS or failedcmd @lcmd;
2834 # OK, now %want is exactly what we want for refs in @specs
2836 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2837 "+refs/$_:".lrfetchrefs."/$_";
2840 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2842 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2843 runcmd_ordryrun_local @fcmd if @fspecs;
2845 if (!$supplementary) {
2846 %lrfetchrefs_f = ();
2850 git_for_each_ref(lrfetchrefs, sub {
2851 my ($objid,$objtype,$lrefname,$reftail) = @_;
2852 $lrfetchrefs_f{$lrefname} = $objid;
2853 $objgot{$objid} = 1;
2856 if ($supplementary) {
2860 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2861 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2862 if (!exists $wantr{$rrefname}) {
2863 if ($wanted_rref->($rrefname)) {
2865 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2868 print STDERR f_ <<END, "@fspecs", $lrefname
2869 warning: git fetch %s created %s; this is silly, deleting it.
2872 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2873 delete $lrfetchrefs_f{$lrefname};
2877 foreach my $rrefname (sort keys %wantr) {
2878 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2879 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2880 my $want = $wantr{$rrefname};
2881 next if $got eq $want;
2882 if (!defined $objgot{$want}) {
2883 fail __ <<END unless act_local();
2884 --dry-run specified but we actually wanted the results of git fetch,
2885 so this is not going to work. Try running dgit fetch first,
2886 or using --damp-run instead of --dry-run.
2888 print STDERR f_ <<END, $lrefname, $want;
2889 warning: git ls-remote suggests we want %s
2890 warning: and it should refer to %s
2891 warning: but git fetch didn't fetch that object to any relevant ref.
2892 warning: This may be due to a race with someone updating the server.
2893 warning: Will try again...
2895 next FETCH_ITERATION;
2898 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2900 runcmd_ordryrun_local @git, qw(update-ref -m),
2901 "dgit fetch git fetch fixup", $lrefname, $want;
2902 $lrfetchrefs_f{$lrefname} = $want;
2907 if (defined $csuite) {
2908 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2909 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2910 my ($objid,$objtype,$lrefname,$reftail) = @_;
2911 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2912 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2916 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2917 Dumper(\%lrfetchrefs_f);
2920 sub git_fetch_us () {
2921 # Want to fetch only what we are going to use, unless
2922 # deliberately-not-ff, in which case we must fetch everything.
2924 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2925 map { "tags/$_" } debiantags('*',access_nomdistro);
2926 push @specs, server_branch($csuite);
2927 push @specs, $rewritemap;
2928 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2930 my $url = access_giturl();
2931 git_lrfetch_sane $url, 0, @specs;
2934 my @tagpats = debiantags('*',access_nomdistro);
2936 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2937 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2938 printdebug "currently $fullrefname=$objid\n";
2939 $here{$fullrefname} = $objid;
2941 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2942 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2943 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2944 printdebug "offered $lref=$objid\n";
2945 if (!defined $here{$lref}) {
2946 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2947 runcmd_ordryrun_local @upd;
2948 lrfetchref_used $fullrefname;
2949 } elsif ($here{$lref} eq $objid) {
2950 lrfetchref_used $fullrefname;
2952 print STDERR f_ "Not updating %s from %s to %s.\n",
2953 $lref, $here{$lref}, $objid;
2958 #---------- dsc and archive handling ----------
2960 sub mergeinfo_getclogp ($) {
2961 # Ensures thit $mi->{Clogp} exists and returns it
2963 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2966 sub mergeinfo_version ($) {
2967 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2970 sub fetch_from_archive_record_1 ($) {
2972 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2973 cmdoutput @git, qw(log -n2), $hash;
2974 # ... gives git a chance to complain if our commit is malformed
2977 sub fetch_from_archive_record_2 ($) {
2979 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2983 dryrun_report @upd_cmd;
2987 sub parse_dsc_field_def_dsc_distro () {
2988 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2989 dgit.default.distro);
2992 sub parse_dsc_field ($$) {
2993 my ($dsc, $what) = @_;
2995 foreach my $field (@ourdscfield) {
2996 $f = $dsc->{$field};
3001 progress f_ "%s: NO git hash", $what;
3002 parse_dsc_field_def_dsc_distro();
3003 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3004 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3005 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3006 $dsc_hint_tag = [ $dsc_hint_tag ];
3007 } elsif ($f =~ m/^\w+\s*$/) {
3009 parse_dsc_field_def_dsc_distro();
3010 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3012 progress f_ "%s: specified git hash", $what;
3014 fail f_ "%s: invalid Dgit info", $what;
3018 sub resolve_dsc_field_commit ($$) {
3019 my ($already_distro, $already_mapref) = @_;
3021 return unless defined $dsc_hash;
3024 defined $already_mapref &&
3025 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3026 ? $already_mapref : undef;
3030 my ($what, @fetch) = @_;
3032 local $idistro = $dsc_distro;
3033 my $lrf = lrfetchrefs;
3035 if (!$chase_dsc_distro) {
3036 progress f_ "not chasing .dsc distro %s: not fetching %s",
3041 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3043 my $url = access_giturl();
3044 if (!defined $url) {
3045 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3046 .dsc Dgit metadata is in context of distro %s
3047 for which we have no configured url and .dsc provides no hint
3050 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3051 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3052 parse_cfg_bool "dsc-url-proto-ok", 'false',
3053 cfg("dgit.dsc-url-proto-ok.$proto",
3054 "dgit.default.dsc-url-proto-ok")
3055 or fail f_ <<END, $dsc_distro, $proto;
3056 .dsc Dgit metadata is in context of distro %s
3057 for which we have no configured url;
3058 .dsc provides hinted url with protocol %s which is unsafe.
3059 (can be overridden by config - consult documentation)
3061 $url = $dsc_hint_url;
3064 git_lrfetch_sane $url, 1, @fetch;
3069 my $rewrite_enable = do {
3070 local $idistro = $dsc_distro;
3071 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3074 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3075 if (!defined $mapref) {
3076 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3077 $mapref = $lrf.'/'.$rewritemap;
3079 my $rewritemapdata = git_cat_file $mapref.':map';
3080 if (defined $rewritemapdata
3081 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3083 "server's git history rewrite map contains a relevant entry!";
3086 if (defined $dsc_hash) {
3087 progress __ "using rewritten git hash in place of .dsc value";
3089 progress __ "server data says .dsc hash is to be disregarded";
3094 if (!defined git_cat_file $dsc_hash) {
3095 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3096 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3097 defined git_cat_file $dsc_hash
3098 or fail f_ <<END, $dsc_hash;
3099 .dsc Dgit metadata requires commit %s
3100 but we could not obtain that object anywhere.
3102 foreach my $t (@tags) {
3103 my $fullrefname = $lrf.'/'.$t;
3104 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3105 next unless $lrfetchrefs_f{$fullrefname};
3106 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3107 lrfetchref_used $fullrefname;
3112 sub fetch_from_archive () {
3114 ensure_setup_existing_tree();
3116 # Ensures that lrref() is what is actually in the archive, one way
3117 # or another, according to us - ie this client's
3118 # appropritaely-updated archive view. Also returns the commit id.
3119 # If there is nothing in the archive, leaves lrref alone and
3120 # returns undef. git_fetch_us must have already been called.
3124 parse_dsc_field($dsc, __ 'last upload to archive');
3125 resolve_dsc_field_commit access_basedistro,
3126 lrfetchrefs."/".$rewritemap
3128 progress __ "no version available from the archive";
3131 # If the archive's .dsc has a Dgit field, there are three
3132 # relevant git commitids we need to choose between and/or merge
3134 # 1. $dsc_hash: the Dgit field from the archive
3135 # 2. $lastpush_hash: the suite branch on the dgit git server
3136 # 3. $lastfetch_hash: our local tracking brach for the suite
3138 # These may all be distinct and need not be in any fast forward
3141 # If the dsc was pushed to this suite, then the server suite
3142 # branch will have been updated; but it might have been pushed to
3143 # a different suite and copied by the archive. Conversely a more
3144 # recent version may have been pushed with dgit but not appeared
3145 # in the archive (yet).
3147 # $lastfetch_hash may be awkward because archive imports
3148 # (particularly, imports of Dgit-less .dscs) are performed only as
3149 # needed on individual clients, so different clients may perform a
3150 # different subset of them - and these imports are only made
3151 # public during push. So $lastfetch_hash may represent a set of
3152 # imports different to a subsequent upload by a different dgit
3155 # Our approach is as follows:
3157 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3158 # descendant of $dsc_hash, then it was pushed by a dgit user who
3159 # had based their work on $dsc_hash, so we should prefer it.
3160 # Otherwise, $dsc_hash was installed into this suite in the
3161 # archive other than by a dgit push, and (necessarily) after the
3162 # last dgit push into that suite (since a dgit push would have
3163 # been descended from the dgit server git branch); thus, in that
3164 # case, we prefer the archive's version (and produce a
3165 # pseudo-merge to overwrite the dgit server git branch).
3167 # (If there is no Dgit field in the archive's .dsc then
3168 # generate_commit_from_dsc uses the version numbers to decide
3169 # whether the suite branch or the archive is newer. If the suite
3170 # branch is newer it ignores the archive's .dsc; otherwise it
3171 # generates an import of the .dsc, and produces a pseudo-merge to
3172 # overwrite the suite branch with the archive contents.)
3174 # The outcome of that part of the algorithm is the `public view',
3175 # and is same for all dgit clients: it does not depend on any
3176 # unpublished history in the local tracking branch.
3178 # As between the public view and the local tracking branch: The
3179 # local tracking branch is only updated by dgit fetch, and
3180 # whenever dgit fetch runs it includes the public view in the
3181 # local tracking branch. Therefore if the public view is not
3182 # descended from the local tracking branch, the local tracking
3183 # branch must contain history which was imported from the archive
3184 # but never pushed; and, its tip is now out of date. So, we make
3185 # a pseudo-merge to overwrite the old imports and stitch the old
3188 # Finally: we do not necessarily reify the public view (as
3189 # described above). This is so that we do not end up stacking two
3190 # pseudo-merges. So what we actually do is figure out the inputs
3191 # to any public view pseudo-merge and put them in @mergeinputs.
3194 # $mergeinputs[]{Commit}
3195 # $mergeinputs[]{Info}
3196 # $mergeinputs[0] is the one whose tree we use
3197 # @mergeinputs is in the order we use in the actual commit)
3200 # $mergeinputs[]{Message} is a commit message to use
3201 # $mergeinputs[]{ReverseParents} if def specifies that parent
3202 # list should be in opposite order
3203 # Such an entry has no Commit or Info. It applies only when found
3204 # in the last entry. (This ugliness is to support making
3205 # identical imports to previous dgit versions.)
3207 my $lastpush_hash = git_get_ref(lrfetchref());
3208 printdebug "previous reference hash=$lastpush_hash\n";
3209 $lastpush_mergeinput = $lastpush_hash && {
3210 Commit => $lastpush_hash,
3211 Info => (__ "dgit suite branch on dgit git server"),
3214 my $lastfetch_hash = git_get_ref(lrref());
3215 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3216 my $lastfetch_mergeinput = $lastfetch_hash && {
3217 Commit => $lastfetch_hash,
3218 Info => (__ "dgit client's archive history view"),
3221 my $dsc_mergeinput = $dsc_hash && {
3222 Commit => $dsc_hash,
3223 Info => (__ "Dgit field in .dsc from archive"),
3227 my $del_lrfetchrefs = sub {
3230 printdebug "del_lrfetchrefs...\n";
3231 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3232 my $objid = $lrfetchrefs_d{$fullrefname};
3233 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3235 $gur ||= new IO::Handle;
3236 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3238 printf $gur "delete %s %s\n", $fullrefname, $objid;
3241 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3245 if (defined $dsc_hash) {
3246 ensure_we_have_orig();
3247 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3248 @mergeinputs = $dsc_mergeinput
3249 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3250 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3252 Git commit in archive is behind the last version allegedly pushed/uploaded.
3253 Commit referred to by archive: %s
3254 Last version pushed with dgit: %s
3257 __ $later_warning_msg or confess "$!";
3258 @mergeinputs = ($lastpush_mergeinput);
3260 # Archive has .dsc which is not a descendant of the last dgit
3261 # push. This can happen if the archive moves .dscs about.
3262 # Just follow its lead.
3263 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3264 progress __ "archive .dsc names newer git commit";
3265 @mergeinputs = ($dsc_mergeinput);
3267 progress __ "archive .dsc names other git commit, fixing up";
3268 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3272 @mergeinputs = generate_commits_from_dsc();
3273 # We have just done an import. Now, our import algorithm might
3274 # have been improved. But even so we do not want to generate
3275 # a new different import of the same package. So if the
3276 # version numbers are the same, just use our existing version.
3277 # If the version numbers are different, the archive has changed
3278 # (perhaps, rewound).
3279 if ($lastfetch_mergeinput &&
3280 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3281 (mergeinfo_version $mergeinputs[0]) )) {
3282 @mergeinputs = ($lastfetch_mergeinput);
3284 } elsif ($lastpush_hash) {
3285 # only in git, not in the archive yet
3286 @mergeinputs = ($lastpush_mergeinput);
3287 print STDERR f_ <<END,
3289 Package not found in the archive, but has allegedly been pushed using dgit.
3292 __ $later_warning_msg or confess "$!";
3294 printdebug "nothing found!\n";
3295 if (defined $skew_warning_vsn) {
3296 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3298 Warning: relevant archive skew detected.
3299 Archive allegedly contains %s
3300 But we were not able to obtain any version from the archive or git.
3304 unshift @end, $del_lrfetchrefs;
3308 if ($lastfetch_hash &&
3310 my $h = $_->{Commit};
3311 $h and is_fast_fwd($lastfetch_hash, $h);
3312 # If true, one of the existing parents of this commit
3313 # is a descendant of the $lastfetch_hash, so we'll
3314 # be ff from that automatically.
3318 push @mergeinputs, $lastfetch_mergeinput;
3321 printdebug "fetch mergeinfos:\n";
3322 foreach my $mi (@mergeinputs) {
3324 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3326 printdebug sprintf " ReverseParents=%d Message=%s",
3327 $mi->{ReverseParents}, $mi->{Message};
3331 my $compat_info= pop @mergeinputs
3332 if $mergeinputs[$#mergeinputs]{Message};
3334 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3337 if (@mergeinputs > 1) {
3339 my $tree_commit = $mergeinputs[0]{Commit};
3341 my $tree = get_tree_of_commit $tree_commit;;
3343 # We use the changelog author of the package in question the
3344 # author of this pseudo-merge. This is (roughly) correct if
3345 # this commit is simply representing aa non-dgit upload.
3346 # (Roughly because it does not record sponsorship - but we
3347 # don't have sponsorship info because that's in the .changes,
3348 # which isn't in the archivw.)
3350 # But, it might be that we are representing archive history
3351 # updates (including in-archive copies). These are not really
3352 # the responsibility of the person who created the .dsc, but
3353 # there is no-one whose name we should better use. (The
3354 # author of the .dsc-named commit is clearly worse.)
3356 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3357 my $author = clogp_authline $useclogp;
3358 my $cversion = getfield $useclogp, 'Version';
3360 my $mcf = dgit_privdir()."/mergecommit";
3361 open MC, ">", $mcf or die "$mcf $!";
3362 print MC <<END or confess "$!";
3366 my @parents = grep { $_->{Commit} } @mergeinputs;
3367 @parents = reverse @parents if $compat_info->{ReverseParents};
3368 print MC <<END or confess "$!" foreach @parents;
3372 print MC <<END or confess "$!";
3378 if (defined $compat_info->{Message}) {
3379 print MC $compat_info->{Message} or confess "$!";
3381 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3382 Record %s (%s) in archive suite %s
3386 my $message_add_info = sub {
3388 my $mversion = mergeinfo_version $mi;
3389 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3393 $message_add_info->($mergeinputs[0]);
3394 print MC __ <<END or confess "$!";
3395 should be treated as descended from
3397 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3400 close MC or confess "$!";
3401 $hash = make_commit $mcf;
3403 $hash = $mergeinputs[0]{Commit};
3405 printdebug "fetch hash=$hash\n";
3408 my ($lasth, $what) = @_;
3409 return unless $lasth;
3410 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3413 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3415 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3417 fetch_from_archive_record_1($hash);
3419 if (defined $skew_warning_vsn) {
3420 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3421 my $gotclogp = commit_getclogp($hash);
3422 my $got_vsn = getfield $gotclogp, 'Version';
3423 printdebug "SKEW CHECK GOT $got_vsn\n";
3424 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3425 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3427 Warning: archive skew detected. Using the available version:
3428 Archive allegedly contains %s
3429 We were able to obtain only %s
3435 if ($lastfetch_hash ne $hash) {
3436 fetch_from_archive_record_2($hash);
3439 lrfetchref_used lrfetchref();
3441 check_gitattrs($hash, __ "fetched source tree");
3443 unshift @end, $del_lrfetchrefs;
3447 sub set_local_git_config ($$) {
3449 runcmd @git, qw(config), $k, $v;
3452 sub setup_mergechangelogs (;$) {
3454 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3456 my $driver = 'dpkg-mergechangelogs';
3457 my $cb = "merge.$driver";
3458 confess unless defined $maindir;
3459 my $attrs = "$maindir_gitcommon/info/attributes";
3460 ensuredir "$maindir_gitcommon/info";
3462 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3463 if (!open ATTRS, "<", $attrs) {
3464 $!==ENOENT or die "$attrs: $!";
3468 next if m{^debian/changelog\s};
3469 print NATTRS $_, "\n" or confess "$!";
3471 ATTRS->error and confess "$!";
3474 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3477 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3478 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3480 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3483 sub setup_useremail (;$) {
3485 return unless $always || access_cfg_bool(1, 'setup-useremail');
3488 my ($k, $envvar) = @_;
3489 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3490 return unless defined $v;
3491 set_local_git_config "user.$k", $v;
3494 $setup->('email', 'DEBEMAIL');
3495 $setup->('name', 'DEBFULLNAME');
3498 sub ensure_setup_existing_tree () {
3499 my $k = "remote.$remotename.skipdefaultupdate";
3500 my $c = git_get_config $k;
3501 return if defined $c;
3502 set_local_git_config $k, 'true';
3505 sub open_main_gitattrs () {
3506 confess 'internal error no maindir' unless defined $maindir;
3507 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3509 or die "open $maindir_gitcommon/info/attributes: $!";
3513 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3515 sub is_gitattrs_setup () {
3518 # 1: gitattributes set up and should be left alone
3520 # 0: there is a dgit-defuse-attrs but it needs fixing
3521 # undef: there is none
3522 my $gai = open_main_gitattrs();
3523 return 0 unless $gai;
3525 next unless m{$gitattrs_ourmacro_re};
3526 return 1 if m{\s-working-tree-encoding\s};
3527 printdebug "is_gitattrs_setup: found old macro\n";
3530 $gai->error and confess "$!";
3531 printdebug "is_gitattrs_setup: found nothing\n";
3535 sub setup_gitattrs (;$) {
3537 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3539 my $already = is_gitattrs_setup();
3542 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3543 not doing further gitattributes setup
3547 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3548 my $af = "$maindir_gitcommon/info/attributes";
3549 ensuredir "$maindir_gitcommon/info";
3551 open GAO, "> $af.new" or confess "$!";
3552 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3556 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3558 my $gai = open_main_gitattrs();
3561 if (m{$gitattrs_ourmacro_re}) {
3562 die unless defined $already;
3566 print GAO $_, "\n" or confess "$!";
3568 $gai->error and confess "$!";
3570 close GAO or confess "$!";
3571 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3574 sub setup_new_tree () {
3575 setup_mergechangelogs();
3580 sub check_gitattrs ($$) {
3581 my ($treeish, $what) = @_;
3583 return if is_gitattrs_setup;
3586 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3588 my $gafl = new IO::File;
3589 open $gafl, "-|", @cmd or confess "$!";
3592 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3594 next unless m{(?:^|/)\.gitattributes$};
3596 # oh dear, found one
3597 print STDERR f_ <<END, $what;
3598 dgit: warning: %s contains .gitattributes
3599 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3604 # tree contains no .gitattributes files
3605 $?=0; $!=0; close $gafl or failedcmd @cmd;
3609 sub multisuite_suite_child ($$$) {
3610 my ($tsuite, $mergeinputs, $fn) = @_;
3611 # in child, sets things up, calls $fn->(), and returns undef
3612 # in parent, returns canonical suite name for $tsuite
3613 my $canonsuitefh = IO::File::new_tmpfile;
3614 my $pid = fork // confess "$!";
3618 $us .= " [$isuite]";
3619 $debugprefix .= " ";
3620 progress f_ "fetching %s...", $tsuite;
3621 canonicalise_suite();
3622 print $canonsuitefh $csuite, "\n" or confess "$!";
3623 close $canonsuitefh or confess "$!";
3627 waitpid $pid,0 == $pid or confess "$!";
3628 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3630 seek $canonsuitefh,0,0 or confess "$!";
3631 local $csuite = <$canonsuitefh>;
3632 confess "$!" unless defined $csuite && chomp $csuite;
3634 printdebug "multisuite $tsuite missing\n";
3637 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3638 push @$mergeinputs, {
3645 sub fork_for_multisuite ($) {
3646 my ($before_fetch_merge) = @_;
3647 # if nothing unusual, just returns ''
3650 # returns 0 to caller in child, to do first of the specified suites
3651 # in child, $csuite is not yet set
3653 # returns 1 to caller in parent, to finish up anything needed after
3654 # in parent, $csuite is set to canonicalised portmanteau
3656 my $org_isuite = $isuite;
3657 my @suites = split /\,/, $isuite;
3658 return '' unless @suites > 1;
3659 printdebug "fork_for_multisuite: @suites\n";
3663 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3665 return 0 unless defined $cbasesuite;
3667 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3668 unless @mergeinputs;
3670 my @csuites = ($cbasesuite);
3672 $before_fetch_merge->();
3674 foreach my $tsuite (@suites[1..$#suites]) {
3675 $tsuite =~ s/^-/$cbasesuite-/;
3676 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3683 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3684 push @csuites, $csubsuite;
3687 foreach my $mi (@mergeinputs) {
3688 my $ref = git_get_ref $mi->{Ref};
3689 die "$mi->{Ref} ?" unless length $ref;
3690 $mi->{Commit} = $ref;
3693 $csuite = join ",", @csuites;
3695 my $previous = git_get_ref lrref;
3697 unshift @mergeinputs, {
3698 Commit => $previous,
3699 Info => (__ "local combined tracking branch"),
3701 "archive seems to have rewound: local tracking branch is ahead!"),
3705 foreach my $ix (0..$#mergeinputs) {
3706 $mergeinputs[$ix]{Index} = $ix;
3709 @mergeinputs = sort {
3710 -version_compare(mergeinfo_version $a,
3711 mergeinfo_version $b) # highest version first
3713 $a->{Index} <=> $b->{Index}; # earliest in spec first
3719 foreach my $mi (@mergeinputs) {
3720 printdebug "multisuite merge check $mi->{Info}\n";
3721 foreach my $previous (@needed) {
3722 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3723 printdebug "multisuite merge un-needed $previous->{Info}\n";
3727 printdebug "multisuite merge this-needed\n";
3728 $mi->{Character} = '+';
3731 $needed[0]{Character} = '*';
3733 my $output = $needed[0]{Commit};
3736 printdebug "multisuite merge nontrivial\n";
3737 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3739 my $commit = "tree $tree\n";
3740 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3741 "Input branches:\n",
3744 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3745 printdebug "multisuite merge include $mi->{Info}\n";
3746 $mi->{Character} //= ' ';
3747 $commit .= "parent $mi->{Commit}\n";
3748 $msg .= sprintf " %s %-25s %s\n",
3750 (mergeinfo_version $mi),
3753 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3754 $msg .= __ "\nKey\n".
3755 " * marks the highest version branch, which choose to use\n".
3756 " + marks each branch which was not already an ancestor\n\n";
3758 "[dgit multi-suite $csuite]\n";
3760 "author $authline\n".
3761 "committer $authline\n\n";
3762 $output = make_commit_text $commit.$msg;
3763 printdebug "multisuite merge generated $output\n";
3766 fetch_from_archive_record_1($output);
3767 fetch_from_archive_record_2($output);
3769 progress f_ "calculated combined tracking suite %s", $csuite;
3774 sub clone_set_head () {
3775 open H, "> .git/HEAD" or confess "$!";
3776 print H "ref: ".lref()."\n" or confess "$!";
3777 close H or confess "$!";
3779 sub clone_finish ($) {
3781 runcmd @git, qw(reset --hard), lrref();
3782 runcmd qw(bash -ec), <<'END';
3784 git ls-tree -r --name-only -z HEAD | \
3785 xargs -0r touch -h -r . --
3787 printdone f_ "ready for work in %s", $dstdir;
3791 # in multisuite, returns twice!
3792 # once in parent after first suite fetched,
3793 # and then again in child after everything is finished
3795 badusage __ "dry run makes no sense with clone" unless act_local();
3797 my $multi_fetched = fork_for_multisuite(sub {
3798 printdebug "multi clone before fetch merge\n";
3802 if ($multi_fetched) {
3803 printdebug "multi clone after fetch merge\n";
3805 clone_finish($dstdir);
3808 printdebug "clone main body\n";
3810 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3814 canonicalise_suite();
3815 my $hasgit = check_for_git();
3817 runcmd @git, qw(init -q);
3821 my $giturl = access_giturl(1);
3822 if (defined $giturl) {
3823 runcmd @git, qw(remote add), 'origin', $giturl;
3826 progress __ "fetching existing git history";
3828 runcmd_ordryrun_local @git, qw(fetch origin);
3830 progress __ "starting new git history";
3832 fetch_from_archive() or no_such_package;
3833 my $vcsgiturl = $dsc->{'Vcs-Git'};
3834 if (length $vcsgiturl) {
3835 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3836 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3838 clone_finish($dstdir);
3842 canonicalise_suite();
3843 if (check_for_git()) {
3846 fetch_from_archive() or no_such_package();
3848 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3849 if (length $vcsgiturl and
3850 (grep { $csuite eq $_ }
3852 cfg 'dgit.vcs-git.suites')) {
3853 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3854 if (defined $current && $current ne $vcsgiturl) {
3855 print STDERR f_ <<END, $csuite;
3856 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3857 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3861 printdone f_ "fetched into %s", lrref();
3865 my $multi_fetched = fork_for_multisuite(sub { });
3866 fetch_one() unless $multi_fetched; # parent
3867 finish 0 if $multi_fetched eq '0'; # child
3872 runcmd_ordryrun_local @git, qw(merge -m),
3873 (f_ "Merge from %s [dgit]", $csuite),
3875 printdone f_ "fetched to %s and merged into HEAD", lrref();
3878 sub check_not_dirty () {
3879 my @forbid = qw(local-options local-patch-header);
3880 @forbid = map { "debian/source/$_" } @forbid;
3881 foreach my $f (@forbid) {
3882 if (stat_exists $f) {
3883 fail f_ "git tree contains %s", $f;
3887 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3888 push @cmd, qw(debian/source/format debian/source/options);
3891 my $bad = cmdoutput @cmd;
3894 "you have uncommitted changes to critical files, cannot continue:\n").
3898 return if $includedirty;
3900 git_check_unmodified();
3903 sub commit_admin ($) {
3906 runcmd_ordryrun_local @git, qw(commit -m), $m;
3909 sub quiltify_nofix_bail ($$) {
3910 my ($headinfo, $xinfo) = @_;
3911 if ($quilt_mode eq 'nofix') {
3913 "quilt fixup required but quilt mode is \`nofix'\n".
3914 "HEAD commit%s differs from tree implied by debian/patches%s",
3919 sub commit_quilty_patch () {
3920 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3922 foreach my $l (split /\n/, $output) {
3923 next unless $l =~ m/\S/;
3924 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3928 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3930 progress __ "nothing quilty to commit, ok.";
3933 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3934 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3935 runcmd_ordryrun_local @git, qw(add -f), @adds;
3936 commit_admin +(__ <<ENDT).<<END
3937 Commit Debian 3.0 (quilt) metadata
3940 [dgit ($our_version) quilt-fixup]
3944 sub get_source_format () {
3946 if (open F, "debian/source/options") {
3950 s/\s+$//; # ignore missing final newline
3952 my ($k, $v) = ($`, $'); #');
3953 $v =~ s/^"(.*)"$/$1/;
3959 F->error and confess "$!";
3962 confess "$!" unless $!==&ENOENT;
3965 if (!open F, "debian/source/format") {
3966 confess "$!" unless $!==&ENOENT;
3970 F->error and confess "$!";
3972 return ($_, \%options);
3975 sub madformat_wantfixup ($) {
3977 return 0 unless $format eq '3.0 (quilt)';
3978 our $quilt_mode_warned;
3979 if ($quilt_mode eq 'nocheck') {
3980 progress f_ "Not doing any fixup of \`%s'".
3981 " due to ----no-quilt-fixup or --quilt=nocheck", $format
3982 unless $quilt_mode_warned++;
3985 progress f_ "Format \`%s', need to check/update patch stack", $format
3986 unless $quilt_mode_warned++;
3990 sub maybe_split_brain_save ($$$) {
3991 my ($headref, $dgitview, $msg) = @_;
3992 # => message fragment "$saved" describing disposition of $dgitview
3993 # (used inside parens, in the English texts)
3994 my $save = $internal_object_save{'dgit-view'};
3995 return f_ "commit id %s", $dgitview unless defined $save;
3996 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3998 "dgit --dgit-view-save $msg HEAD=$headref",
4001 return f_ "and left in %s", $save;
4004 # An "infopair" is a tuple [ $thing, $what ]
4005 # (often $thing is a commit hash; $what is a description)
4007 sub infopair_cond_equal ($$) {
4009 $x->[0] eq $y->[0] or fail <<END;
4010 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4014 sub infopair_lrf_tag_lookup ($$) {
4015 my ($tagnames, $what) = @_;
4016 # $tagname may be an array ref
4017 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4018 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4019 foreach my $tagname (@tagnames) {
4020 my $lrefname = lrfetchrefs."/tags/$tagname";
4021 my $tagobj = $lrfetchrefs_f{$lrefname};
4022 next unless defined $tagobj;
4023 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4024 return [ git_rev_parse($tagobj), $what ];
4026 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4027 Wanted tag %s (%s) on dgit server, but not found
4029 : (f_ <<END, $what, "@tagnames");
4030 Wanted tag %s (one of: %s) on dgit server, but not found
4034 sub infopair_cond_ff ($$) {
4035 my ($anc,$desc) = @_;
4036 is_fast_fwd($anc->[0], $desc->[0]) or
4037 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4038 %s (%s) .. %s (%s) is not fast forward
4042 sub pseudomerge_version_check ($$) {
4043 my ($clogp, $archive_hash) = @_;
4045 my $arch_clogp = commit_getclogp $archive_hash;
4046 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4047 __ 'version currently in archive' ];
4048 if (defined $overwrite_version) {
4049 if (length $overwrite_version) {
4050 infopair_cond_equal([ $overwrite_version,
4051 '--overwrite= version' ],
4054 my $v = $i_arch_v->[0];
4056 "Checking package changelog for archive version %s ...", $v;
4059 my @xa = ("-f$v", "-t$v");
4060 my $vclogp = parsechangelog @xa;
4063 [ (getfield $vclogp, $fn),
4064 (f_ "%s field from dpkg-parsechangelog %s",
4067 my $cv = $gf->('Version');
4068 infopair_cond_equal($i_arch_v, $cv);
4069 $cd = $gf->('Distribution');
4073 $@ =~ s/^dgit: //gm;
4075 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4077 fail f_ <<END, $cd->[1], $cd->[0], $v
4079 Your tree seems to based on earlier (not uploaded) %s.
4081 if $cd->[0] =~ m/UNRELEASED/;
4085 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4089 sub pseudomerge_make_commit ($$$$ $$) {
4090 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4091 $msg_cmd, $msg_msg) = @_;
4092 progress f_ "Declaring that HEAD includes all changes in %s...",
4095 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4096 my $authline = clogp_authline $clogp;
4100 !defined $overwrite_version ? ""
4101 : !length $overwrite_version ? " --overwrite"
4102 : " --overwrite=".$overwrite_version;
4104 # Contributing parent is the first parent - that makes
4105 # git rev-list --first-parent DTRT.
4106 my $pmf = dgit_privdir()."/pseudomerge";
4107 open MC, ">", $pmf or die "$pmf $!";
4108 print MC <<END or confess "$!";
4111 parent $archive_hash
4119 close MC or confess "$!";
4121 return make_commit($pmf);
4124 sub splitbrain_pseudomerge ($$$$) {
4125 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4126 # => $merged_dgitview
4127 printdebug "splitbrain_pseudomerge...\n";
4129 # We: debian/PREVIOUS HEAD($maintview)
4130 # expect: o ----------------- o
4133 # a/d/PREVIOUS $dgitview
4136 # we do: `------------------ o
4140 return $dgitview unless defined $archive_hash;
4141 return $dgitview if deliberately_not_fast_forward();
4143 printdebug "splitbrain_pseudomerge...\n";
4145 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4147 if (!defined $overwrite_version) {
4148 progress __ "Checking that HEAD includes all changes in archive...";
4151 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4153 if (defined $overwrite_version) {
4155 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4156 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4157 __ "maintainer view tag");
4158 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4159 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4160 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4162 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4164 infopair_cond_equal($i_dgit, $i_archive);
4165 infopair_cond_ff($i_dep14, $i_dgit);
4166 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4169 $@ =~ s/^\n//; chomp $@;
4170 print STDERR <<END.(__ <<ENDT);
4173 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4178 my $arch_v = $i_arch_v->[0];
4179 my $r = pseudomerge_make_commit
4180 $clogp, $dgitview, $archive_hash, $i_arch_v,
4181 "dgit --quilt=$quilt_mode",
4182 (defined $overwrite_version
4183 ? f_ "Declare fast forward from %s\n", $arch_v
4184 : f_ "Make fast forward from %s\n", $arch_v);
4186 maybe_split_brain_save $maintview, $r, "pseudomerge";
4188 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4192 sub plain_overwrite_pseudomerge ($$$) {
4193 my ($clogp, $head, $archive_hash) = @_;
4195 printdebug "plain_overwrite_pseudomerge...";
4197 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4199 return $head if is_fast_fwd $archive_hash, $head;
4201 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4203 my $r = pseudomerge_make_commit
4204 $clogp, $head, $archive_hash, $i_arch_v,
4207 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4209 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4213 sub push_parse_changelog ($) {
4216 my $clogp = Dpkg::Control::Hash->new();
4217 $clogp->load($clogpfn) or die;
4219 my $clogpackage = getfield $clogp, 'Source';
4220 $package //= $clogpackage;
4221 fail f_ "-p specified %s but changelog specified %s",
4222 $package, $clogpackage
4223 unless $package eq $clogpackage;
4224 my $cversion = getfield $clogp, 'Version';
4226 if (!$we_are_initiator) {
4227 # rpush initiator can't do this because it doesn't have $isuite yet
4228 my $tag = debiantag_new($cversion, access_nomdistro);
4229 runcmd @git, qw(check-ref-format), $tag;
4232 my $dscfn = dscfn($cversion);
4234 return ($clogp, $cversion, $dscfn);
4237 sub push_parse_dsc ($$$) {
4238 my ($dscfn,$dscfnwhat, $cversion) = @_;
4239 $dsc = parsecontrol($dscfn,$dscfnwhat);
4240 my $dversion = getfield $dsc, 'Version';
4241 my $dscpackage = getfield $dsc, 'Source';
4242 ($dscpackage eq $package && $dversion eq $cversion) or
4243 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4244 $dscfn, $dscpackage, $dversion,
4245 $package, $cversion;
4248 sub push_tagwants ($$$$) {
4249 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4252 TagFn => \&debiantag_new,
4257 if (defined $maintviewhead) {
4259 TagFn => \&debiantag_maintview,
4260 Objid => $maintviewhead,
4261 TfSuffix => '-maintview',
4264 } elsif ($dodep14tag ne 'no') {
4266 TagFn => \&debiantag_maintview,
4268 TfSuffix => '-dgit',
4272 foreach my $tw (@tagwants) {
4273 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4274 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4276 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4280 sub push_mktags ($$ $$ $) {
4282 $changesfile,$changesfilewhat,
4285 die unless $tagwants->[0]{View} eq 'dgit';
4287 my $declaredistro = access_nomdistro();
4288 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4289 $dsc->{$ourdscfield[0]} = join " ",
4290 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4292 $dsc->save("$dscfn.tmp") or confess "$!";
4294 my $changes = parsecontrol($changesfile,$changesfilewhat);
4295 foreach my $field (qw(Source Distribution Version)) {
4296 $changes->{$field} eq $clogp->{$field} or
4297 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4298 $field, $changes->{$field}, $clogp->{$field};
4301 my $cversion = getfield $clogp, 'Version';
4302 my $clogsuite = getfield $clogp, 'Distribution';
4304 # We make the git tag by hand because (a) that makes it easier
4305 # to control the "tagger" (b) we can do remote signing
4306 my $authline = clogp_authline $clogp;
4307 my $delibs = join(" ", "",@deliberatelies);
4311 my $tfn = $tw->{Tfn};
4312 my $head = $tw->{Objid};
4313 my $tag = $tw->{Tag};
4315 open TO, '>', $tfn->('.tmp') or confess "$!";
4316 print TO <<END or confess "$!";
4323 if ($tw->{View} eq 'dgit') {
4324 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4325 %s release %s for %s (%s) [dgit]
4328 print TO <<END or confess "$!";
4329 [dgit distro=$declaredistro$delibs]
4331 foreach my $ref (sort keys %previously) {
4332 print TO <<END or confess "$!";
4333 [dgit previously:$ref=$previously{$ref}]
4336 } elsif ($tw->{View} eq 'maint') {
4337 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4338 %s release %s for %s (%s)
4339 (maintainer view tag generated by dgit --quilt=%s)
4344 confess Dumper($tw)."?";
4347 close TO or confess "$!";
4349 my $tagobjfn = $tfn->('.tmp');
4351 if (!defined $keyid) {
4352 $keyid = access_cfg('keyid','RETURN-UNDEF');
4354 if (!defined $keyid) {
4355 $keyid = getfield $clogp, 'Maintainer';
4357 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4358 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4359 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4360 push @sign_cmd, $tfn->('.tmp');
4361 runcmd_ordryrun @sign_cmd;
4363 $tagobjfn = $tfn->('.signed.tmp');
4364 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4365 $tfn->('.tmp'), $tfn->('.tmp.asc');
4371 my @r = map { $mktag->($_); } @$tagwants;
4375 sub sign_changes ($) {
4376 my ($changesfile) = @_;
4378 my @debsign_cmd = @debsign;
4379 push @debsign_cmd, "-k$keyid" if defined $keyid;
4380 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4381 push @debsign_cmd, $changesfile;
4382 runcmd_ordryrun @debsign_cmd;
4387 printdebug "actually entering push\n";
4389 supplementary_message(__ <<'END');
4390 Push failed, while checking state of the archive.
4391 You can retry the push, after fixing the problem, if you like.
4393 if (check_for_git()) {
4396 my $archive_hash = fetch_from_archive();
4397 if (!$archive_hash) {
4399 fail __ "package appears to be new in this suite;".
4400 " if this is intentional, use --new";
4403 supplementary_message(__ <<'END');
4404 Push failed, while preparing your push.
4405 You can retry the push, after fixing the problem, if you like.
4410 access_giturl(); # check that success is vaguely likely
4411 rpush_handle_protovsn_bothends() if $we_are_initiator;
4413 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4414 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4416 responder_send_file('parsed-changelog', $clogpfn);
4418 my ($clogp, $cversion, $dscfn) =
4419 push_parse_changelog("$clogpfn");
4421 my $dscpath = "$buildproductsdir/$dscfn";
4422 stat_exists $dscpath or
4423 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4426 responder_send_file('dsc', $dscpath);
4428 push_parse_dsc($dscpath, $dscfn, $cversion);
4430 my $format = getfield $dsc, 'Format';
4432 my $symref = git_get_symref();
4433 my $actualhead = git_rev_parse('HEAD');
4435 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4436 if (quiltmode_splitbrain()) {
4437 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4438 fail f_ <<END, $ffq_prev, $quilt_mode;
4439 Branch is managed by git-debrebase (%s
4440 exists), but quilt mode (%s) implies a split view.
4441 Pass the right --quilt option or adjust your git config.
4442 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4445 runcmd_ordryrun_local @git_debrebase, 'stitch';
4446 $actualhead = git_rev_parse('HEAD');
4449 my $dgithead = $actualhead;
4450 my $maintviewhead = undef;
4452 my $upstreamversion = upstreamversion $clogp->{Version};
4454 if (madformat_wantfixup($format)) {
4455 # user might have not used dgit build, so maybe do this now:
4456 if ($do_split_brain) {
4457 changedir $playground;
4459 ($dgithead, $cachekey) =
4460 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4461 $dgithead or fail f_
4462 "--quilt=%s but no cached dgit view:
4463 perhaps HEAD changed since dgit build[-source] ?",
4466 if (!$do_split_brain) {
4467 # In split brain mode, do not attempt to incorporate dirty
4468 # stuff from the user's working tree. That would be mad.
4469 commit_quilty_patch();
4472 if ($do_split_brain) {
4473 $made_split_brain = 1;
4474 $dgithead = splitbrain_pseudomerge($clogp,
4475 $actualhead, $dgithead,
4477 $maintviewhead = $actualhead;
4479 prep_ud(); # so _only_subdir() works, below
4482 if (defined $overwrite_version && !defined $maintviewhead
4484 $dgithead = plain_overwrite_pseudomerge($clogp,
4492 if ($archive_hash) {
4493 if (is_fast_fwd($archive_hash, $dgithead)) {
4495 } elsif (deliberately_not_fast_forward) {
4498 fail __ "dgit push: HEAD is not a descendant".
4499 " of the archive's version.\n".
4500 "To overwrite the archive's contents,".
4501 " pass --overwrite[=VERSION].\n".
4502 "To rewind history, if permitted by the archive,".
4503 " use --deliberately-not-fast-forward.";
4507 confess unless !!$made_split_brain == !!$do_split_brain;
4509 changedir $playground;
4510 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4511 runcmd qw(dpkg-source -x --),
4512 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4513 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4514 check_for_vendor_patches() if madformat($dsc->{format});
4516 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4517 debugcmd "+",@diffcmd;
4519 my $r = system @diffcmd;
4522 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4523 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4526 my $raw = cmdoutput @git,
4527 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4529 foreach (split /\0/, $raw) {
4530 if (defined $changed) {
4531 push @mode_changes, "$changed: $_\n" if $changed;
4534 } elsif (m/^:0+ 0+ /) {
4536 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4537 $changed = "Mode change from $1 to $2"
4542 if (@mode_changes) {
4543 fail +(f_ <<ENDT, $dscfn).<<END
4544 HEAD specifies a different tree to %s:
4548 .(join '', @mode_changes)
4549 .(f_ <<ENDT, $tree, $referent);
4550 There is a problem with your source tree (see dgit(7) for some hints).
4551 To see a full diff, run git diff %s %s
4555 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4556 HEAD specifies a different tree to %s:
4560 Perhaps you forgot to build. Or perhaps there is a problem with your
4561 source tree (see dgit(7) for some hints). To see a full diff, run
4568 if (!$changesfile) {
4569 my $pat = changespat $cversion;
4570 my @cs = glob "$buildproductsdir/$pat";
4571 fail f_ "failed to find unique changes file".
4572 " (looked for %s in %s);".
4573 " perhaps you need to use dgit -C",
4574 $pat, $buildproductsdir
4576 ($changesfile) = @cs;
4578 $changesfile = "$buildproductsdir/$changesfile";
4581 # Check that changes and .dsc agree enough
4582 $changesfile =~ m{[^/]*$};
4583 my $changes = parsecontrol($changesfile,$&);
4584 files_compare_inputs($dsc, $changes)
4585 unless forceing [qw(dsc-changes-mismatch)];
4587 # Check whether this is a source only upload
4588 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4589 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4590 if ($sourceonlypolicy eq 'ok') {
4591 } elsif ($sourceonlypolicy eq 'always') {
4592 forceable_fail [qw(uploading-binaries)],
4593 __ "uploading binaries, although distro policy is source only"
4595 } elsif ($sourceonlypolicy eq 'never') {
4596 forceable_fail [qw(uploading-source-only)],
4597 __ "source-only upload, although distro policy requires .debs"
4599 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4600 forceable_fail [qw(uploading-source-only)],
4601 f_ "source-only upload, even though package is entirely NEW\n".
4602 "(this is contrary to policy in %s)",
4606 && !(archive_query('package_not_wholly_new', $package) // 1);
4608 badcfg f_ "unknown source-only-uploads policy \`%s'",
4612 # Perhaps adjust .dsc to contain right set of origs
4613 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4615 unless forceing [qw(changes-origs-exactly)];
4617 # Checks complete, we're going to try and go ahead:
4619 responder_send_file('changes',$changesfile);
4620 responder_send_command("param head $dgithead");
4621 responder_send_command("param csuite $csuite");
4622 responder_send_command("param isuite $isuite");
4623 responder_send_command("param tagformat new"); # needed in $protovsn==4
4624 if (defined $maintviewhead) {
4625 responder_send_command("param maint-view $maintviewhead");
4628 # Perhaps send buildinfo(s) for signing
4629 my $changes_files = getfield $changes, 'Files';
4630 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4631 foreach my $bi (@buildinfos) {
4632 responder_send_command("param buildinfo-filename $bi");
4633 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4636 if (deliberately_not_fast_forward) {
4637 git_for_each_ref(lrfetchrefs, sub {
4638 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4639 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4640 responder_send_command("previously $rrefname=$objid");
4641 $previously{$rrefname} = $objid;
4645 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4646 dgit_privdir()."/tag");
4649 supplementary_message(__ <<'END');
4650 Push failed, while signing the tag.
4651 You can retry the push, after fixing the problem, if you like.
4653 # If we manage to sign but fail to record it anywhere, it's fine.
4654 if ($we_are_responder) {
4655 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4656 responder_receive_files('signed-tag', @tagobjfns);
4658 @tagobjfns = push_mktags($clogp,$dscpath,
4659 $changesfile,$changesfile,
4662 supplementary_message(__ <<'END');
4663 Push failed, *after* signing the tag.
4664 If you want to try again, you should use a new version number.
4667 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4669 foreach my $tw (@tagwants) {
4670 my $tag = $tw->{Tag};
4671 my $tagobjfn = $tw->{TagObjFn};
4673 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4674 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4675 runcmd_ordryrun_local
4676 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4679 supplementary_message(__ <<'END');
4680 Push failed, while updating the remote git repository - see messages above.
4681 If you want to try again, you should use a new version number.
4683 if (!check_for_git()) {
4684 create_remote_git_repo();
4687 my @pushrefs = $forceflag.$dgithead.":".rrref();
4688 foreach my $tw (@tagwants) {
4689 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4692 runcmd_ordryrun @git,
4693 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4694 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4696 supplementary_message(__ <<'END');
4697 Push failed, while obtaining signatures on the .changes and .dsc.
4698 If it was just that the signature failed, you may try again by using
4699 debsign by hand to sign the changes file (see the command dgit tried,
4700 above), and then dput that changes file to complete the upload.
4701 If you need to change the package, you must use a new version number.
4703 if ($we_are_responder) {
4704 my $dryrunsuffix = act_local() ? "" : ".tmp";
4705 my @rfiles = ($dscpath, $changesfile);
4706 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4707 responder_receive_files('signed-dsc-changes',
4708 map { "$_$dryrunsuffix" } @rfiles);
4711 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4713 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4715 sign_changes $changesfile;
4718 supplementary_message(f_ <<END, $changesfile);
4719 Push failed, while uploading package(s) to the archive server.
4720 You can retry the upload of exactly these same files with dput of:
4722 If that .changes file is broken, you will need to use a new version
4723 number for your next attempt at the upload.
4725 my $host = access_cfg('upload-host','RETURN-UNDEF');
4726 my @hostarg = defined($host) ? ($host,) : ();
4727 runcmd_ordryrun @dput, @hostarg, $changesfile;
4728 printdone f_ "pushed and uploaded %s", $cversion;
4730 supplementary_message('');
4731 responder_send_command("complete");
4735 not_necessarily_a_tree();
4740 badusage __ "-p is not allowed with clone; specify as argument instead"
4741 if defined $package;
4744 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4745 ($package,$isuite) = @ARGV;
4746 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4747 ($package,$dstdir) = @ARGV;
4748 } elsif (@ARGV==3) {
4749 ($package,$isuite,$dstdir) = @ARGV;
4751 badusage __ "incorrect arguments to dgit clone";
4755 $dstdir ||= "$package";
4756 if (stat_exists $dstdir) {
4757 fail f_ "%s already exists", $dstdir;
4761 if ($rmonerror && !$dryrun_level) {
4762 $cwd_remove= getcwd();
4764 return unless defined $cwd_remove;
4765 if (!chdir "$cwd_remove") {
4766 return if $!==&ENOENT;
4767 confess "chdir $cwd_remove: $!";
4769 printdebug "clone rmonerror removing $dstdir\n";
4771 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4772 } elsif (grep { $! == $_ }
4773 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4775 print STDERR f_ "check whether to remove %s: %s\n",
4782 $cwd_remove = undef;
4785 sub branchsuite () {
4786 my $branch = git_get_symref();
4787 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4794 sub package_from_d_control () {
4795 if (!defined $package) {
4796 my $sourcep = parsecontrol('debian/control','debian/control');
4797 $package = getfield $sourcep, 'Source';
4801 sub fetchpullargs () {
4802 package_from_d_control();
4804 $isuite = branchsuite();
4806 my $clogp = parsechangelog();
4807 my $clogsuite = getfield $clogp, 'Distribution';
4808 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4810 } elsif (@ARGV==1) {
4813 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4827 if (quiltmode_splitbrain()) {
4828 my ($format, $fopts) = get_source_format();
4829 madformat($format) and fail f_ <<END, $quilt_mode
4830 dgit pull not yet supported in split view mode (--quilt=%s)
4838 package_from_d_control();
4839 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4843 foreach my $canon (qw(0 1)) {
4848 canonicalise_suite();
4850 if (length git_get_ref lref()) {
4851 # local branch already exists, yay
4854 if (!length git_get_ref lrref()) {
4862 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4865 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4866 "dgit checkout $isuite";
4867 runcmd (@git, qw(checkout), lbranch());
4870 sub cmd_update_vcs_git () {
4872 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4873 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4875 ($specsuite) = (@ARGV);
4880 if ($ARGV[0] eq '-') {
4882 } elsif ($ARGV[0] eq '-') {
4887 package_from_d_control();
4889 if ($specsuite eq '.') {
4890 $ctrl = parsecontrol 'debian/control', 'debian/control';
4892 $isuite = $specsuite;
4896 my $url = getfield $ctrl, 'Vcs-Git';
4899 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4900 if (!defined $orgurl) {
4901 print STDERR f_ "setting up vcs-git: %s\n", $url;
4902 @cmd = (@git, qw(remote add vcs-git), $url);
4903 } elsif ($orgurl eq $url) {
4904 print STDERR f_ "vcs git already configured: %s\n", $url;
4906 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4907 @cmd = (@git, qw(remote set-url vcs-git), $url);
4909 runcmd_ordryrun_local @cmd;
4911 print f_ "fetching (%s)\n", "@ARGV";
4912 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4918 build_or_push_prep_early();
4920 build_or_push_prep_modes();
4924 } elsif (@ARGV==1) {
4925 ($specsuite) = (@ARGV);
4927 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4930 local ($package) = $existing_package; # this is a hack
4931 canonicalise_suite();
4933 canonicalise_suite();
4935 if (defined $specsuite &&
4936 $specsuite ne $isuite &&
4937 $specsuite ne $csuite) {
4938 fail f_ "dgit %s: changelog specifies %s (%s)".
4939 " but command line specifies %s",
4940 $subcommand, $isuite, $csuite, $specsuite;
4949 #---------- remote commands' implementation ----------
4951 sub pre_remote_push_build_host {
4952 my ($nrargs) = shift @ARGV;
4953 my (@rargs) = @ARGV[0..$nrargs-1];
4954 @ARGV = @ARGV[$nrargs..$#ARGV];
4956 my ($dir,$vsnwant) = @rargs;
4957 # vsnwant is a comma-separated list; we report which we have
4958 # chosen in our ready response (so other end can tell if they
4961 $we_are_responder = 1;
4962 $us .= " (build host)";
4964 open PI, "<&STDIN" or confess "$!";
4965 open STDIN, "/dev/null" or confess "$!";
4966 open PO, ">&STDOUT" or confess "$!";
4968 open STDOUT, ">&STDERR" or confess "$!";
4972 ($protovsn) = grep {
4973 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4974 } @rpushprotovsn_support;
4976 fail f_ "build host has dgit rpush protocol versions %s".
4977 " but invocation host has %s",
4978 (join ",", @rpushprotovsn_support), $vsnwant
4979 unless defined $protovsn;
4983 sub cmd_remote_push_build_host {
4984 responder_send_command("dgit-remote-push-ready $protovsn");
4988 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4989 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4990 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4991 # a good error message)
4993 sub rpush_handle_protovsn_bothends () {
5000 my $report = i_child_report();
5001 if (defined $report) {
5002 printdebug "($report)\n";
5003 } elsif ($i_child_pid) {
5004 printdebug "(killing build host child $i_child_pid)\n";
5005 kill 15, $i_child_pid;
5007 if (defined $i_tmp && !defined $initiator_tempdir) {
5009 eval { rmtree $i_tmp; };
5014 return unless forkcheck_mainprocess();
5019 my ($base,$selector,@args) = @_;
5020 $selector =~ s/\-/_/g;
5021 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5025 not_necessarily_a_tree();
5030 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5038 push @rargs, join ",", @rpushprotovsn_support;
5041 push @rdgit, @ropts;
5042 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5044 my @cmd = (@ssh, $host, shellquote @rdgit);
5047 $we_are_initiator=1;
5049 if (defined $initiator_tempdir) {
5050 rmtree $initiator_tempdir;
5051 mkdir $initiator_tempdir, 0700
5052 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5053 $i_tmp = $initiator_tempdir;
5057 $i_child_pid = open2(\*RO, \*RI, @cmd);
5059 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5060 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5063 my ($icmd,$iargs) = initiator_expect {
5064 m/^(\S+)(?: (.*))?$/;
5067 i_method "i_resp", $icmd, $iargs;
5071 sub i_resp_progress ($) {
5073 my $msg = protocol_read_bytes \*RO, $rhs;
5077 sub i_resp_supplementary_message ($) {
5079 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5082 sub i_resp_complete {
5083 my $pid = $i_child_pid;
5084 $i_child_pid = undef; # prevents killing some other process with same pid
5085 printdebug "waiting for build host child $pid...\n";
5086 my $got = waitpid $pid, 0;
5087 confess "$!" unless $got == $pid;
5088 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5091 printdebug __ "all done\n";
5095 sub i_resp_file ($) {
5097 my $localname = i_method "i_localname", $keyword;
5098 my $localpath = "$i_tmp/$localname";
5099 stat_exists $localpath and
5100 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5101 protocol_receive_file \*RO, $localpath;
5102 i_method "i_file", $keyword;
5107 sub i_resp_param ($) {
5108 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5112 sub i_resp_previously ($) {
5113 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5114 or badproto \*RO, __ "bad previously spec";
5115 my $r = system qw(git check-ref-format), $1;
5116 confess "bad previously ref spec ($r)" if $r;
5117 $previously{$1} = $2;
5122 sub i_resp_want ($) {
5124 die "$keyword ?" if $i_wanted{$keyword}++;
5126 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5127 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5128 die unless $isuite =~ m/^$suite_re$/;
5131 rpush_handle_protovsn_bothends();
5133 my @localpaths = i_method "i_want", $keyword;
5134 printdebug "[[ $keyword @localpaths\n";
5135 foreach my $localpath (@localpaths) {
5136 protocol_send_file \*RI, $localpath;
5138 print RI "files-end\n" or confess "$!";
5141 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5143 sub i_localname_parsed_changelog {
5144 return "remote-changelog.822";
5146 sub i_file_parsed_changelog {
5147 ($i_clogp, $i_version, $i_dscfn) =
5148 push_parse_changelog "$i_tmp/remote-changelog.822";
5149 die if $i_dscfn =~ m#/|^\W#;
5152 sub i_localname_dsc {
5153 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5158 sub i_localname_buildinfo ($) {
5159 my $bi = $i_param{'buildinfo-filename'};
5160 defined $bi or badproto \*RO, "buildinfo before filename";
5161 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5162 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5163 or badproto \*RO, "improper buildinfo filename";
5166 sub i_file_buildinfo {
5167 my $bi = $i_param{'buildinfo-filename'};
5168 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5169 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5170 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5171 files_compare_inputs($bd, $ch);
5172 (getfield $bd, $_) eq (getfield $ch, $_) or
5173 fail f_ "buildinfo mismatch in field %s", $_
5174 foreach qw(Source Version);
5175 !defined $bd->{$_} or
5176 fail f_ "buildinfo contains forbidden field %s", $_
5177 foreach qw(Changes Changed-by Distribution);
5179 push @i_buildinfos, $bi;
5180 delete $i_param{'buildinfo-filename'};
5183 sub i_localname_changes {
5184 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5185 $i_changesfn = $i_dscfn;
5186 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5187 return $i_changesfn;
5189 sub i_file_changes { }
5191 sub i_want_signed_tag {
5192 printdebug Dumper(\%i_param, $i_dscfn);
5193 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5194 && defined $i_param{'csuite'}
5195 or badproto \*RO, "premature desire for signed-tag";
5196 my $head = $i_param{'head'};
5197 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5199 my $maintview = $i_param{'maint-view'};
5200 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5202 if ($protovsn == 4) {
5203 my $p = $i_param{'tagformat'} // '<undef>';
5205 or badproto \*RO, "tag format mismatch: $p vs. new";
5208 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5210 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5212 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5215 push_mktags $i_clogp, $i_dscfn,
5216 $i_changesfn, (__ 'remote changes file'),
5220 sub i_want_signed_dsc_changes {
5221 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5222 sign_changes $i_changesfn;
5223 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5226 #---------- building etc. ----------
5232 #----- `3.0 (quilt)' handling -----
5234 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5236 sub quiltify_dpkg_commit ($$$;$) {
5237 my ($patchname,$author,$msg, $xinfo) = @_;
5240 mkpath '.git/dgit'; # we are in playtree
5241 my $descfn = ".git/dgit/quilt-description.tmp";
5242 open O, '>', $descfn or confess "$descfn: $!";
5243 $msg =~ s/\n+/\n\n/;
5244 print O <<END or confess "$!";
5246 ${xinfo}Subject: $msg
5250 close O or confess "$!";
5253 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5254 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5255 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5256 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5260 sub quiltify_trees_differ ($$;$$$) {
5261 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5262 # returns true iff the two tree objects differ other than in debian/
5263 # with $finegrained,
5264 # returns bitmask 01 - differ in upstream files except .gitignore
5265 # 02 - differ in .gitignore
5266 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5267 # is set for each modified .gitignore filename $fn
5268 # if $unrepres is defined, array ref to which is appeneded
5269 # a list of unrepresentable changes (removals of upstream files
5272 my @cmd = (@git, qw(diff-tree -z --no-renames));
5273 push @cmd, qw(--name-only) unless $unrepres;
5274 push @cmd, qw(-r) if $finegrained || $unrepres;
5276 my $diffs= cmdoutput @cmd;
5279 foreach my $f (split /\0/, $diffs) {
5280 if ($unrepres && !@lmodes) {
5281 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5284 my ($oldmode,$newmode) = @lmodes;
5287 next if $f =~ m#^debian(?:/.*)?$#s;
5291 die __ "not a plain file or symlink\n"
5292 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5293 $oldmode =~ m/^(?:10|12)\d{4}$/;
5294 if ($oldmode =~ m/[^0]/ &&
5295 $newmode =~ m/[^0]/) {
5296 # both old and new files exist
5297 die __ "mode or type changed\n" if $oldmode ne $newmode;
5298 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5299 } elsif ($oldmode =~ m/[^0]/) {
5301 die __ "deletion of symlink\n"
5302 unless $oldmode =~ m/^10/;
5305 die __ "creation with non-default mode\n"
5306 unless $newmode =~ m/^100644$/ or
5307 $newmode =~ m/^120000$/;
5311 local $/="\n"; chomp $@;
5312 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5316 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5317 $r |= $isignore ? 02 : 01;
5318 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5320 printdebug "quiltify_trees_differ $x $y => $r\n";
5324 sub quiltify_tree_sentinelfiles ($) {
5325 # lists the `sentinel' files present in the tree
5327 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5328 qw(-- debian/rules debian/control);
5333 sub quiltify_splitbrain ($$$$$$$) {
5334 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5335 $editedignores, $cachekey) = @_;
5336 my $gitignore_special = 1;
5337 if ($quilt_mode !~ m/gbp|dpm/) {
5338 # treat .gitignore just like any other upstream file
5339 $diffbits = { %$diffbits };
5340 $_ = !!$_ foreach values %$diffbits;
5341 $gitignore_special = 0;
5343 # We would like any commits we generate to be reproducible
5344 my @authline = clogp_authline($clogp);
5345 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5346 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5347 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5348 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5349 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5350 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5352 confess unless $do_split_brain;
5354 my $fulldiffhint = sub {
5356 my $cmd = "git diff $x $y -- :/ ':!debian'";
5357 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5358 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5362 if ($quilt_mode =~ m/gbp|unapplied/ &&
5363 ($diffbits->{O2H} & 01)) {
5365 "--quilt=%s specified, implying patches-unapplied git tree\n".
5366 " but git tree differs from orig in upstream files.",
5368 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5369 if (!stat_exists "debian/patches") {
5371 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5375 if ($quilt_mode =~ m/dpm/ &&
5376 ($diffbits->{H2A} & 01)) {
5377 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5378 --quilt=%s specified, implying patches-applied git tree
5379 but git tree differs from result of applying debian/patches to upstream
5382 if ($quilt_mode =~ m/gbp|unapplied/ &&
5383 ($diffbits->{O2A} & 01)) { # some patches
5384 progress __ "dgit view: creating patches-applied version using gbp pq";
5385 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5386 # gbp pq import creates a fresh branch; push back to dgit-view
5387 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5388 runcmd @git, qw(checkout -q dgit-view);
5390 if ($quilt_mode =~ m/gbp|dpm/ &&
5391 ($diffbits->{O2A} & 02)) {
5392 fail f_ <<END, $quilt_mode;
5393 --quilt=%s specified, implying that HEAD is for use with a
5394 tool which does not create patches for changes to upstream
5395 .gitignores: but, such patches exist in debian/patches.
5398 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5399 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5401 "dgit view: creating patch to represent .gitignore changes";
5402 ensuredir "debian/patches";
5403 my $gipatch = "debian/patches/auto-gitignore";
5404 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5405 stat GIPATCH or confess "$gipatch: $!";
5406 fail f_ "%s already exists; but want to create it".
5407 " to record .gitignore changes",
5410 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5411 Subject: Update .gitignore from Debian packaging branch
5413 The Debian packaging git branch contains these updates to the upstream
5414 .gitignore file(s). This patch is autogenerated, to provide these
5415 updates to users of the official Debian archive view of the package.
5418 [dgit ($our_version) update-gitignore]
5421 close GIPATCH or die "$gipatch: $!";
5422 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5423 $unapplied, $headref, "--", sort keys %$editedignores;
5424 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5425 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5427 defined read SERIES, $newline, 1 or confess "$!";
5428 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5429 print SERIES "auto-gitignore\n" or confess "$!";
5430 close SERIES or die $!;
5431 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5432 commit_admin +(__ <<END).<<ENDU
5433 Commit patch to update .gitignore
5436 [dgit ($our_version) update-gitignore-quilt-fixup]
5441 sub quiltify ($$$$) {
5442 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5444 # Quilt patchification algorithm
5446 # We search backwards through the history of the main tree's HEAD
5447 # (T) looking for a start commit S whose tree object is identical
5448 # to to the patch tip tree (ie the tree corresponding to the
5449 # current dpkg-committed patch series). For these purposes
5450 # `identical' disregards anything in debian/ - this wrinkle is
5451 # necessary because dpkg-source treates debian/ specially.
5453 # We can only traverse edges where at most one of the ancestors'
5454 # trees differs (in changes outside in debian/). And we cannot
5455 # handle edges which change .pc/ or debian/patches. To avoid
5456 # going down a rathole we avoid traversing edges which introduce
5457 # debian/rules or debian/control. And we set a limit on the
5458 # number of edges we are willing to look at.
5460 # If we succeed, we walk forwards again. For each traversed edge
5461 # PC (with P parent, C child) (starting with P=S and ending with
5462 # C=T) to we do this:
5464 # - dpkg-source --commit with a patch name and message derived from C
5465 # After traversing PT, we git commit the changes which
5466 # should be contained within debian/patches.
5468 # The search for the path S..T is breadth-first. We maintain a
5469 # todo list containing search nodes. A search node identifies a
5470 # commit, and looks something like this:
5472 # Commit => $git_commit_id,
5473 # Child => $c, # or undef if P=T
5474 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5475 # Nontrivial => true iff $p..$c has relevant changes
5482 my %considered; # saves being exponential on some weird graphs
5484 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5487 my ($search,$whynot) = @_;
5488 printdebug " search NOT $search->{Commit} $whynot\n";
5489 $search->{Whynot} = $whynot;
5490 push @nots, $search;
5491 no warnings qw(exiting);
5500 my $c = shift @todo;
5501 next if $considered{$c->{Commit}}++;
5503 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5505 printdebug "quiltify investigate $c->{Commit}\n";
5508 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5509 printdebug " search finished hooray!\n";
5514 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5515 if ($quilt_mode eq 'smash') {
5516 printdebug " search quitting smash\n";
5520 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5521 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5522 if $c_sentinels ne $t_sentinels;
5524 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5525 $commitdata =~ m/\n\n/;
5527 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5528 @parents = map { { Commit => $_, Child => $c } } @parents;
5530 $not->($c, __ "root commit") if !@parents;
5532 foreach my $p (@parents) {
5533 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5535 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5536 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5539 foreach my $p (@parents) {
5540 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5542 my @cmd= (@git, qw(diff-tree -r --name-only),
5543 $p->{Commit},$c->{Commit},
5544 qw(-- debian/patches .pc debian/source/format));
5545 my $patchstackchange = cmdoutput @cmd;
5546 if (length $patchstackchange) {
5547 $patchstackchange =~ s/\n/,/g;
5548 $not->($p, f_ "changed %s", $patchstackchange);
5551 printdebug " search queue P=$p->{Commit} ",
5552 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5558 printdebug "quiltify want to smash\n";
5561 my $x = $_[0]{Commit};
5562 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5565 if ($quilt_mode eq 'linear') {
5567 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5569 my $all_gdr = !!@nots;
5570 foreach my $notp (@nots) {
5571 my $c = $notp->{Child};
5572 my $cprange = $abbrev->($notp);
5573 $cprange .= "..".$abbrev->($c) if $c;
5574 print STDERR f_ "%s: %s: %s\n",
5575 $us, $cprange, $notp->{Whynot};
5576 $all_gdr &&= $notp->{Child} &&
5577 (git_cat_file $notp->{Child}{Commit}, 'commit')
5578 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5582 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5584 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5586 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5587 } elsif ($quilt_mode eq 'smash') {
5588 } elsif ($quilt_mode eq 'auto') {
5589 progress __ "quilt fixup cannot be linear, smashing...";
5591 confess "$quilt_mode ?";
5594 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5595 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5597 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5599 quiltify_dpkg_commit "auto-$version-$target-$time",
5600 (getfield $clogp, 'Maintainer'),
5601 (f_ "Automatically generated patch (%s)\n".
5602 "Last (up to) %s git changes, FYI:\n\n",
5603 $clogp->{Version}, $ncommits).
5608 progress __ "quiltify linearisation planning successful, executing...";
5610 for (my $p = $sref_S;
5611 my $c = $p->{Child};
5613 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5614 next unless $p->{Nontrivial};
5616 my $cc = $c->{Commit};
5618 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5619 $commitdata =~ m/\n\n/ or die "$c ?";
5622 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5625 my $commitdate = cmdoutput
5626 @git, qw(log -n1 --pretty=format:%aD), $cc;
5628 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5630 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5637 my $gbp_check_suitable = sub {
5642 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5643 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5644 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5645 die __ "is series file\n" if m{$series_filename_re}o;
5646 die __ "too long\n" if length > 200;
5648 return $_ unless $@;
5650 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5655 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5657 (\S+) \s* \n //ixm) {
5658 $patchname = $gbp_check_suitable->($1, 'Name');
5660 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5662 (\S+) \s* \n //ixm) {
5663 $patchdir = $gbp_check_suitable->($1, 'Topic');
5668 if (!defined $patchname) {
5669 $patchname = $title;
5670 $patchname =~ s/[.:]$//;
5673 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5674 my $translitname = $converter->convert($patchname);
5675 die unless defined $translitname;
5676 $patchname = $translitname;
5679 +(f_ "dgit: patch title transliteration error: %s", $@)
5681 $patchname =~ y/ A-Z/-a-z/;
5682 $patchname =~ y/-a-z0-9_.+=~//cd;
5683 $patchname =~ s/^\W/x-$&/;
5684 $patchname = substr($patchname,0,40);
5685 $patchname .= ".patch";
5687 if (!defined $patchdir) {
5690 if (length $patchdir) {
5691 $patchname = "$patchdir/$patchname";
5693 if ($patchname =~ m{^(.*)/}) {
5694 mkpath "debian/patches/$1";
5699 stat "debian/patches/$patchname$index";
5701 $!==ENOENT or confess "$patchname$index $!";
5703 runcmd @git, qw(checkout -q), $cc;
5705 # We use the tip's changelog so that dpkg-source doesn't
5706 # produce complaining messages from dpkg-parsechangelog. None
5707 # of the information dpkg-source gets from the changelog is
5708 # actually relevant - it gets put into the original message
5709 # which dpkg-source provides our stunt editor, and then
5711 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5713 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5714 "Date: $commitdate\n".
5715 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5717 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5721 sub build_maybe_quilt_fixup () {
5722 my ($format,$fopts) = get_source_format;
5723 return unless madformat_wantfixup $format;
5726 check_for_vendor_patches();
5728 my $clogp = parsechangelog();
5729 my $headref = git_rev_parse('HEAD');
5730 my $symref = git_get_symref();
5731 my $upstreamversion = upstreamversion $version;
5734 changedir $playground;
5736 my $splitbrain_cachekey;
5738 if ($do_split_brain) {
5740 ($cachehit, $splitbrain_cachekey) =
5741 quilt_check_splitbrain_cache($headref, $upstreamversion);
5748 unpack_playtree_need_cd_work($headref);
5749 if ($do_split_brain) {
5750 runcmd @git, qw(checkout -q -b dgit-view);
5751 # so long as work is not deleted, its current branch will
5752 # remain dgit-view, rather than master, so subsequent calls to
5753 # unpack_playtree_need_cd_work
5754 # will DTRT, resetting dgit-view.
5755 confess if $made_split_brain;
5756 $made_split_brain = 1;
5760 if ($fopts->{'single-debian-patch'}) {
5762 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5764 if quiltmode_splitbrain();
5765 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5767 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5768 $splitbrain_cachekey);
5771 if ($do_split_brain) {
5772 my $dgitview = git_rev_parse 'HEAD';
5775 reflog_cache_insert "refs/$splitbraincache",
5776 $splitbrain_cachekey, $dgitview;
5778 changedir "$playground/work";
5780 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5781 progress f_ "dgit view: created (%s)", $saved;
5785 runcmd_ordryrun_local
5786 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5789 sub build_check_quilt_splitbrain () {
5790 build_maybe_quilt_fixup();
5793 sub unpack_playtree_need_cd_work ($) {
5796 # prep_ud() must have been called already.
5797 if (!chdir "work") {
5798 # Check in the filesystem because sometimes we run prep_ud
5799 # in between multiple calls to unpack_playtree_need_cd_work.
5800 confess "$!" unless $!==ENOENT;
5801 mkdir "work" or confess "$!";
5803 mktree_in_ud_here();
5805 runcmd @git, qw(reset -q --hard), $headref;
5808 sub unpack_playtree_linkorigs ($$) {
5809 my ($upstreamversion, $fn) = @_;
5810 # calls $fn->($leafname);
5812 my $bpd_abs = bpd_abs();
5814 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5816 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5817 while ($!=0, defined(my $leaf = readdir QFD)) {
5818 my $f = bpd_abs()."/".$leaf;
5820 local ($debuglevel) = $debuglevel-1;
5821 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5823 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5824 printdebug "QF linkorigs $leaf, $f Y\n";
5825 link_ltarget $f, $leaf or die "$leaf $!";
5828 die "$buildproductsdir: $!" if $!;
5832 sub quilt_fixup_delete_pc () {
5833 runcmd @git, qw(rm -rqf .pc);
5834 commit_admin +(__ <<END).<<ENDU
5835 Commit removal of .pc (quilt series tracking data)
5838 [dgit ($our_version) upgrade quilt-remove-pc]
5842 sub quilt_fixup_singlepatch ($$$) {
5843 my ($clogp, $headref, $upstreamversion) = @_;
5845 progress __ "starting quiltify (single-debian-patch)";
5847 # dpkg-source --commit generates new patches even if
5848 # single-debian-patch is in debian/source/options. In order to
5849 # get it to generate debian/patches/debian-changes, it is
5850 # necessary to build the source package.
5852 unpack_playtree_linkorigs($upstreamversion, sub { });
5853 unpack_playtree_need_cd_work($headref);
5855 rmtree("debian/patches");
5857 runcmd @dpkgsource, qw(-b .);
5859 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5860 rename srcfn("$upstreamversion", "/debian/patches"),
5861 "work/debian/patches"
5863 or confess "install d/patches: $!";
5866 commit_quilty_patch();
5869 sub quilt_need_fake_dsc ($) {
5870 # cwd should be playground
5871 my ($upstreamversion) = @_;
5873 return if stat_exists "fake.dsc";
5874 # ^ OK to test this as a sentinel because if we created it
5875 # we must either have done the rest too, or crashed.
5877 my $fakeversion="$upstreamversion-~~DGITFAKE";
5879 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5880 print $fakedsc <<END or confess "$!";
5883 Version: $fakeversion
5887 my $dscaddfile=sub {
5890 my $md = new Digest::MD5;
5892 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5893 stat $fh or confess "$!";
5897 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5900 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5902 my @files=qw(debian/source/format debian/rules
5903 debian/control debian/changelog);
5904 foreach my $maybe (qw(debian/patches debian/source/options
5905 debian/tests/control)) {
5906 next unless stat_exists "$maindir/$maybe";
5907 push @files, $maybe;
5910 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5911 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5913 $dscaddfile->($debtar);
5914 close $fakedsc or confess "$!";
5917 sub quilt_fakedsc2unapplied ($$) {
5918 my ($headref, $upstreamversion) = @_;
5919 # must be run in the playground
5920 # quilt_need_fake_dsc must have been called
5922 quilt_need_fake_dsc($upstreamversion);
5924 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5926 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5927 rename $fakexdir, "fake" or die "$fakexdir $!";
5931 remove_stray_gits(__ "source package");
5932 mktree_in_ud_here();
5936 rmtree 'debian'; # git checkout commitish paths does not delete!
5937 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5938 my $unapplied=git_add_write_tree();
5939 printdebug "fake orig tree object $unapplied\n";
5943 sub quilt_check_splitbrain_cache ($$) {
5944 my ($headref, $upstreamversion) = @_;
5945 # Called only if we are in (potentially) split brain mode.
5946 # Called in playground.
5947 # Computes the cache key and looks in the cache.
5948 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5950 quilt_need_fake_dsc($upstreamversion);
5952 my $splitbrain_cachekey;
5955 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5957 # we look in the reflog of dgit-intern/quilt-cache
5958 # we look for an entry whose message is the key for the cache lookup
5959 my @cachekey = (qw(dgit), $our_version);
5960 push @cachekey, $upstreamversion;
5961 push @cachekey, $quilt_mode;
5962 push @cachekey, $headref;
5964 push @cachekey, hashfile('fake.dsc');
5966 my $srcshash = Digest::SHA->new(256);
5967 my %sfs = ( %INC, '$0(dgit)' => $0 );
5968 foreach my $sfk (sort keys %sfs) {
5969 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5970 $srcshash->add($sfk," ");
5971 $srcshash->add(hashfile($sfs{$sfk}));
5972 $srcshash->add("\n");
5974 push @cachekey, $srcshash->hexdigest();
5975 $splitbrain_cachekey = "@cachekey";
5977 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5979 my $cachehit = reflog_cache_lookup
5980 "refs/$splitbraincache", $splitbrain_cachekey;
5983 unpack_playtree_need_cd_work($headref);
5984 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5985 if ($cachehit ne $headref) {
5986 progress f_ "dgit view: found cached (%s)", $saved;
5987 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5988 $made_split_brain = 1;
5989 return ($cachehit, $splitbrain_cachekey);
5991 progress __ "dgit view: found cached, no changes required";
5992 return ($headref, $splitbrain_cachekey);
5995 printdebug "splitbrain cache miss\n";
5996 return (undef, $splitbrain_cachekey);
5999 sub quilt_fixup_multipatch ($$$) {
6000 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6002 progress f_ "examining quilt state (multiple patches, %s mode)",
6006 # - honour any existing .pc in case it has any strangeness
6007 # - determine the git commit corresponding to the tip of
6008 # the patch stack (if there is one)
6009 # - if there is such a git commit, convert each subsequent
6010 # git commit into a quilt patch with dpkg-source --commit
6011 # - otherwise convert all the differences in the tree into
6012 # a single git commit
6016 # Our git tree doesn't necessarily contain .pc. (Some versions of
6017 # dgit would include the .pc in the git tree.) If there isn't
6018 # one, we need to generate one by unpacking the patches that we
6021 # We first look for a .pc in the git tree. If there is one, we
6022 # will use it. (This is not the normal case.)
6024 # Otherwise need to regenerate .pc so that dpkg-source --commit
6025 # can work. We do this as follows:
6026 # 1. Collect all relevant .orig from parent directory
6027 # 2. Generate a debian.tar.gz out of
6028 # debian/{patches,rules,source/format,source/options}
6029 # 3. Generate a fake .dsc containing just these fields:
6030 # Format Source Version Files
6031 # 4. Extract the fake .dsc
6032 # Now the fake .dsc has a .pc directory.
6033 # (In fact we do this in every case, because in future we will
6034 # want to search for a good base commit for generating patches.)
6036 # Then we can actually do the dpkg-source --commit
6037 # 1. Make a new working tree with the same object
6038 # store as our main tree and check out the main
6040 # 2. Copy .pc from the fake's extraction, if necessary
6041 # 3. Run dpkg-source --commit
6042 # 4. If the result has changes to debian/, then
6043 # - git add them them
6044 # - git add .pc if we had a .pc in-tree
6046 # 5. If we had a .pc in-tree, delete it, and git commit
6047 # 6. Back in the main tree, fast forward to the new HEAD
6049 # Another situation we may have to cope with is gbp-style
6050 # patches-unapplied trees.
6052 # We would want to detect these, so we know to escape into
6053 # quilt_fixup_gbp. However, this is in general not possible.
6054 # Consider a package with a one patch which the dgit user reverts
6055 # (with git revert or the moral equivalent).
6057 # That is indistinguishable in contents from a patches-unapplied
6058 # tree. And looking at the history to distinguish them is not
6059 # useful because the user might have made a confusing-looking git
6060 # history structure (which ought to produce an error if dgit can't
6061 # cope, not a silent reintroduction of an unwanted patch).
6063 # So gbp users will have to pass an option. But we can usually
6064 # detect their failure to do so: if the tree is not a clean
6065 # patches-applied tree, quilt linearisation fails, but the tree
6066 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6067 # they want --quilt=unapplied.
6069 # To help detect this, when we are extracting the fake dsc, we
6070 # first extract it with --skip-patches, and then apply the patches
6071 # afterwards with dpkg-source --before-build. That lets us save a
6072 # tree object corresponding to .origs.
6074 if ($quilt_mode eq 'linear'
6075 && branch_is_gdr($headref)) {
6076 # This is much faster. It also makes patches that gdr
6077 # likes better for future updates without laundering.
6079 # However, it can fail in some casses where we would
6080 # succeed: if there are existing patches, which correspond
6081 # to a prefix of the branch, but are not in gbp/gdr
6082 # format, gdr will fail (exiting status 7), but we might
6083 # be able to figure out where to start linearising. That
6084 # will be slower so hopefully there's not much to do.
6086 unpack_playtree_need_cd_work $headref;
6088 my @cmd = (@git_debrebase,
6089 qw(--noop-ok -funclean-mixed -funclean-ordering
6090 make-patches --quiet-would-amend));
6091 # We tolerate soe snags that gdr wouldn't, by default.
6097 and not ($? == 7*256 or
6098 $? == -1 && $!==ENOENT);
6102 $headref = git_rev_parse('HEAD');
6107 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6111 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6113 if (system @bbcmd) {
6114 failedcmd @bbcmd if $? < 0;
6116 failed to apply your git tree's patch stack (from debian/patches/) to
6117 the corresponding upstream tarball(s). Your source tree and .orig
6118 are probably too inconsistent. dgit can only fix up certain kinds of
6119 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6125 unpack_playtree_need_cd_work($headref);
6128 if (stat_exists ".pc") {
6130 progress __ "Tree already contains .pc - will use it then delete it.";
6133 rename '../fake/.pc','.pc' or confess "$!";
6136 changedir '../fake';
6138 my $oldtiptree=git_add_write_tree();
6139 printdebug "fake o+d/p tree object $unapplied\n";
6140 changedir '../work';
6143 # We calculate some guesswork now about what kind of tree this might
6144 # be. This is mostly for error reporting.
6150 # O = orig, without patches applied
6151 # A = "applied", ie orig with H's debian/patches applied
6152 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6153 \%editedignores, \@unrepres),
6154 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6155 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6159 foreach my $bits (qw(01 02)) {
6160 foreach my $v (qw(O2H O2A H2A)) {
6161 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6164 printdebug "differences \@dl @dl.\n";
6167 "%s: base trees orig=%.20s o+d/p=%.20s",
6168 $us, $unapplied, $oldtiptree;
6170 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6171 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6172 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6173 $us, $dl[2], $dl[5];
6176 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6179 forceable_fail [qw(unrepresentable)], __ <<END;
6180 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6185 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6186 push @failsuggestion, [ 'unapplied', __
6187 "This might be a patches-unapplied branch." ];
6188 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6189 push @failsuggestion, [ 'applied', __
6190 "This might be a patches-applied branch." ];
6192 push @failsuggestion, [ 'quilt-mode', __
6193 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6195 push @failsuggestion, [ 'gitattrs', __
6196 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6197 if stat_exists '.gitattributes';
6199 push @failsuggestion, [ 'origs', __
6200 "Maybe orig tarball(s) are not identical to git representation?" ];
6202 if (quiltmode_splitbrain()) {
6203 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6204 $diffbits, \%editedignores,
6205 $splitbrain_cachekey);
6209 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6210 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6211 runcmd @git, qw(checkout -q), (qw(master dgit-view)[!!$do_split_brain]);
6213 if (!open P, '>>', ".pc/applied-patches") {
6214 $!==&ENOENT or confess "$!";
6219 commit_quilty_patch();
6221 if ($mustdeletepc) {
6222 quilt_fixup_delete_pc();
6226 sub quilt_fixup_editor () {
6227 my $descfn = $ENV{$fakeeditorenv};
6228 my $editing = $ARGV[$#ARGV];
6229 open I1, '<', $descfn or confess "$descfn: $!";
6230 open I2, '<', $editing or confess "$editing: $!";
6231 unlink $editing or confess "$editing: $!";
6232 open O, '>', $editing or confess "$editing: $!";
6233 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6236 $copying ||= m/^\-\-\- /;
6237 next unless $copying;
6238 print O or confess "$!";
6240 I2->error and confess "$!";
6245 sub maybe_apply_patches_dirtily () {
6246 return unless $quilt_mode =~ m/gbp|unapplied/;
6247 print STDERR __ <<END or confess "$!";
6249 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6250 dgit: Have to apply the patches - making the tree dirty.
6251 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6254 $patches_applied_dirtily = 01;
6255 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6256 runcmd qw(dpkg-source --before-build .);
6259 sub maybe_unapply_patches_again () {
6260 progress __ "dgit: Unapplying patches again to tidy up the tree."
6261 if $patches_applied_dirtily;
6262 runcmd qw(dpkg-source --after-build .)
6263 if $patches_applied_dirtily & 01;
6265 if $patches_applied_dirtily & 02;
6266 $patches_applied_dirtily = 0;
6269 #----- other building -----
6271 sub clean_tree_check_git ($$$) {
6272 my ($honour_ignores, $message, $ignmessage) = @_;
6273 my @cmd = (@git, qw(clean -dn));
6274 push @cmd, qw(-x) unless $honour_ignores;
6275 my $leftovers = cmdoutput @cmd;
6276 if (length $leftovers) {
6277 print STDERR $leftovers, "\n" or confess "$!";
6278 $message .= $ignmessage if $honour_ignores;
6283 sub clean_tree_check_git_wd ($) {
6285 return if $cleanmode =~ m{no-check};
6286 return if $patches_applied_dirtily; # yuk
6287 clean_tree_check_git +($cleanmode !~ m{all-check}),
6288 $message, "\n".__ <<END;
6289 If this is just missing .gitignore entries, use a different clean
6290 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6291 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6295 sub clean_tree_check () {
6296 # This function needs to not care about modified but tracked files.
6297 # That was done by check_not_dirty, and by now we may have run
6298 # the rules clean target which might modify tracked files (!)
6299 if ($cleanmode =~ m{^check}) {
6300 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6301 "tree contains uncommitted files and --clean=check specified", '';
6302 } elsif ($cleanmode =~ m{^dpkg-source}) {
6303 clean_tree_check_git_wd __
6304 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6305 } elsif ($cleanmode =~ m{^git}) {
6306 clean_tree_check_git 1, __
6307 "tree contains uncommited, untracked, unignored files\n".
6308 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6309 } elsif ($cleanmode eq 'none') {
6311 confess "$cleanmode ?";
6316 # We always clean the tree ourselves, rather than leave it to the
6317 # builder (dpkg-source, or soemthing which calls dpkg-source).
6318 if ($cleanmode =~ m{^dpkg-source}) {
6319 my @cmd = @dpkgbuildpackage;
6320 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6321 push @cmd, qw(-T clean);
6322 maybe_apply_patches_dirtily();
6323 runcmd_ordryrun_local @cmd;
6324 clean_tree_check_git_wd __
6325 "tree contains uncommitted files (after running rules clean)";
6326 } elsif ($cleanmode =~ m{^git(?!-)}) {
6327 runcmd_ordryrun_local @git, qw(clean -xdf);
6328 } elsif ($cleanmode =~ m{^git-ff}) {
6329 runcmd_ordryrun_local @git, qw(clean -xdff);
6330 } elsif ($cleanmode =~ m{^check}) {
6332 } elsif ($cleanmode eq 'none') {
6334 confess "$cleanmode ?";
6339 badusage __ "clean takes no additional arguments" if @ARGV;
6342 maybe_unapply_patches_again();
6345 # return values from massage_dbp_args are one or both of these flags
6346 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6347 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6349 sub build_or_push_prep_early () {
6350 our $build_or_push_prep_early_done //= 0;
6351 return if $build_or_push_prep_early_done++;
6352 badusage f_ "-p is not allowed with dgit %s", $subcommand
6353 if defined $package;
6354 my $clogp = parsechangelog();
6355 $isuite = getfield $clogp, 'Distribution';
6356 $package = getfield $clogp, 'Source';
6357 $version = getfield $clogp, 'Version';
6358 $dscfn = dscfn($version);
6361 sub build_or_push_prep_modes () {
6362 my ($format,) = get_source_format();
6363 printdebug "format $format, quilt mode $quilt_mode\n";
6364 if (madformat_wantfixup($format) && quiltmode_splitbrain()) {
6365 $do_split_brain = 1;
6367 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
6368 if $do_split_brain && $includedirty;
6371 sub build_prep_early () {
6372 build_or_push_prep_early();
6374 build_or_push_prep_modes();
6378 sub build_prep ($) {
6382 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6383 # Clean the tree because we're going to use the contents of
6384 # $maindir. (We trying to include dirty changes in the source
6385 # package, or we are running the builder in $maindir.)
6386 || $cleanmode =~ m{always}) {
6387 # Or because the user asked us to.
6390 # We don't actually need to do anything in $maindir, but we
6391 # should do some kind of cleanliness check because (i) the
6392 # user may have forgotten a `git add', and (ii) if the user
6393 # said -wc we should still do the check.
6396 build_check_quilt_splitbrain();
6398 my $pat = changespat $version;
6399 foreach my $f (glob "$buildproductsdir/$pat") {
6402 fail f_ "remove old changes file %s: %s", $f, $!;
6404 progress f_ "would remove %s", $f;
6410 sub changesopts_initial () {
6411 my @opts =@changesopts[1..$#changesopts];
6414 sub changesopts_version () {
6415 if (!defined $changes_since_version) {
6418 @vsns = archive_query('archive_query');
6419 my @quirk = access_quirk();
6420 if ($quirk[0] eq 'backports') {
6421 local $isuite = $quirk[2];
6423 canonicalise_suite();
6424 push @vsns, archive_query('archive_query');
6430 "archive query failed (queried because --since-version not specified)";
6433 @vsns = map { $_->[0] } @vsns;
6434 @vsns = sort { -version_compare($a, $b) } @vsns;
6435 $changes_since_version = $vsns[0];
6436 progress f_ "changelog will contain changes since %s", $vsns[0];
6438 $changes_since_version = '_';
6439 progress __ "package seems new, not specifying -v<version>";
6442 if ($changes_since_version ne '_') {
6443 return ("-v$changes_since_version");
6449 sub changesopts () {
6450 return (changesopts_initial(), changesopts_version());
6453 sub massage_dbp_args ($;$) {
6454 my ($cmd,$xargs) = @_;
6455 # Since we split the source build out so we can do strange things
6456 # to it, massage the arguments to dpkg-buildpackage so that the
6457 # main build doessn't build source (or add an argument to stop it
6458 # building source by default).
6459 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6460 # -nc has the side effect of specifying -b if nothing else specified
6461 # and some combinations of -S, -b, et al, are errors, rather than
6462 # later simply overriding earlie. So we need to:
6463 # - search the command line for these options
6464 # - pick the last one
6465 # - perhaps add our own as a default
6466 # - perhaps adjust it to the corresponding non-source-building version
6468 foreach my $l ($cmd, $xargs) {
6470 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6473 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6474 my $r = WANTSRC_BUILDER;
6475 printdebug "massage split $dmode.\n";
6476 if ($dmode =~ s/^--build=//) {
6478 my @d = split /,/, $dmode;
6479 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6480 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6481 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6482 fail __ "Wanted to build nothing!" unless $r;
6483 $dmode = '--build='. join ',', grep m/./, @d;
6486 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6487 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6488 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6491 printdebug "massage done $r $dmode.\n";
6493 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6499 my $wasdir = must_getcwd();
6500 changedir $buildproductsdir;
6505 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6506 sub postbuild_mergechanges ($) {
6507 my ($msg_if_onlyone) = @_;
6508 # If there is only one .changes file, fail with $msg_if_onlyone,
6509 # or if that is undef, be a no-op.
6510 # Returns the changes file to report to the user.
6511 my $pat = changespat $version;
6512 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6513 @changesfiles = sort {
6514 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6518 if (@changesfiles==1) {
6519 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6520 only one changes file from build (%s)
6522 if defined $msg_if_onlyone;
6523 $result = $changesfiles[0];
6524 } elsif (@changesfiles==2) {
6525 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6526 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6527 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6530 runcmd_ordryrun_local @mergechanges, @changesfiles;
6531 my $multichanges = changespat $version,'multi';
6533 stat_exists $multichanges or fail f_
6534 "%s unexpectedly not created by build", $multichanges;
6535 foreach my $cf (glob $pat) {
6536 next if $cf eq $multichanges;
6537 rename "$cf", "$cf.inmulti" or fail f_
6538 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6541 $result = $multichanges;
6543 fail f_ "wrong number of different changes files (%s)",
6546 printdone f_ "build successful, results in %s\n", $result
6550 sub midbuild_checkchanges () {
6551 my $pat = changespat $version;
6552 return if $rmchanges;
6553 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6555 $_ ne changespat $version,'source' and
6556 $_ ne changespat $version,'multi'
6558 fail +(f_ <<END, $pat, "@unwanted")
6559 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6560 Suggest you delete %s.
6565 sub midbuild_checkchanges_vanilla ($) {
6567 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6570 sub postbuild_mergechanges_vanilla ($) {
6572 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6574 postbuild_mergechanges(undef);
6577 printdone __ "build successful\n";
6583 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6584 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6585 %s: warning: build-products-dir will be ignored; files will go to ..
6587 $buildproductsdir = '..';
6588 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6589 my $wantsrc = massage_dbp_args \@dbp;
6590 build_prep($wantsrc);
6591 if ($wantsrc & WANTSRC_SOURCE) {
6593 midbuild_checkchanges_vanilla $wantsrc;
6595 if ($wantsrc & WANTSRC_BUILDER) {
6596 push @dbp, changesopts_version();
6597 maybe_apply_patches_dirtily();
6598 runcmd_ordryrun_local @dbp;
6600 maybe_unapply_patches_again();
6601 postbuild_mergechanges_vanilla $wantsrc;
6605 $quilt_mode //= 'gbp';
6611 # gbp can make .origs out of thin air. In my tests it does this
6612 # even for a 1.0 format package, with no origs present. So I
6613 # guess it keys off just the version number. We don't know
6614 # exactly what .origs ought to exist, but let's assume that we
6615 # should run gbp if: the version has an upstream part and the main
6617 my $upstreamversion = upstreamversion $version;
6618 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6619 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6621 if ($gbp_make_orig) {
6623 $cleanmode = 'none'; # don't do it again
6626 my @dbp = @dpkgbuildpackage;
6628 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6630 if (!length $gbp_build[0]) {
6631 if (length executable_on_path('git-buildpackage')) {
6632 $gbp_build[0] = qw(git-buildpackage);
6634 $gbp_build[0] = 'gbp buildpackage';
6637 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6639 push @cmd, (qw(-us -uc --git-no-sign-tags),
6640 "--git-builder=".(shellquote @dbp));
6642 if ($gbp_make_orig) {
6643 my $priv = dgit_privdir();
6644 my $ok = "$priv/origs-gen-ok";
6645 unlink $ok or $!==&ENOENT or confess "$!";
6646 my @origs_cmd = @cmd;
6647 push @origs_cmd, qw(--git-cleaner=true);
6648 push @origs_cmd, "--git-prebuild=".
6649 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6650 push @origs_cmd, @ARGV;
6652 debugcmd @origs_cmd;
6654 do { local $!; stat_exists $ok; }
6655 or failedcmd @origs_cmd;
6657 dryrun_report @origs_cmd;
6661 build_prep($wantsrc);
6662 if ($wantsrc & WANTSRC_SOURCE) {
6664 midbuild_checkchanges_vanilla $wantsrc;
6666 push @cmd, '--git-cleaner=true';
6668 maybe_unapply_patches_again();
6669 if ($wantsrc & WANTSRC_BUILDER) {
6670 push @cmd, changesopts();
6671 runcmd_ordryrun_local @cmd, @ARGV;
6673 postbuild_mergechanges_vanilla $wantsrc;
6675 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6677 sub building_source_in_playtree {
6678 # If $includedirty, we have to build the source package from the
6679 # working tree, not a playtree, so that uncommitted changes are
6680 # included (copying or hardlinking them into the playtree could
6683 # Note that if we are building a source package in split brain
6684 # mode we do not support including uncommitted changes, because
6685 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6686 # building a source package)) => !$includedirty
6687 return !$includedirty;
6691 $sourcechanges = changespat $version,'source';
6693 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6694 or fail f_ "remove %s: %s", $sourcechanges, $!;
6696 # confess unless !!$made_split_brain == !!$do_split_brain;
6698 my @cmd = (@dpkgsource, qw(-b --));
6700 if (building_source_in_playtree()) {
6702 my $headref = git_rev_parse('HEAD');
6703 # If we are in split brain, there is already a playtree with
6704 # the thing we should package into a .dsc (thanks to quilt
6705 # fixup). If not, make a playtree
6706 prep_ud() unless $made_split_brain;
6707 changedir $playground;
6708 unless ($made_split_brain) {
6709 my $upstreamversion = upstreamversion $version;
6710 unpack_playtree_linkorigs($upstreamversion, sub { });
6711 unpack_playtree_need_cd_work($headref);
6715 $leafdir = basename $maindir;
6717 if ($buildproductsdir ne '..') {
6718 # Well, we are going to run dpkg-source -b which consumes
6719 # origs from .. and generates output there. To make this
6720 # work when the bpd is not .. , we would have to (i) link
6721 # origs from bpd to .. , (ii) check for files that
6722 # dpkg-source -b would/might overwrite, and afterwards
6723 # (iii) move all the outputs back to the bpd (iv) except
6724 # for the origs which should be deleted from .. if they
6725 # weren't there beforehand. And if there is an error and
6726 # we don't run to completion we would necessarily leave a
6727 # mess. This is too much. The real way to fix this
6728 # is for dpkg-source to have bpd support.
6729 confess unless $includedirty;
6731 "--include-dirty not supported with --build-products-dir, sorry";
6736 runcmd_ordryrun_local @cmd, $leafdir;
6739 runcmd_ordryrun_local qw(sh -ec),
6740 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6741 @dpkggenchanges, qw(-S), changesopts();
6744 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6745 $dsc = parsecontrol($dscfn, "source package");
6749 printdebug " renaming ($why) $l\n";
6750 rename_link_xf 0, "$l", bpd_abs()."/$l"
6751 or fail f_ "put in place new built file (%s): %s", $l, $@;
6753 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6754 $l =~ m/\S+$/ or next;
6757 $mv->('dsc', $dscfn);
6758 $mv->('changes', $sourcechanges);
6763 sub cmd_build_source {
6764 badusage __ "build-source takes no additional arguments" if @ARGV;
6765 build_prep(WANTSRC_SOURCE);
6767 maybe_unapply_patches_again();
6768 printdone f_ "source built, results in %s and %s",
6769 $dscfn, $sourcechanges;
6772 sub cmd_push_source {
6775 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6776 "sense with push-source!"
6778 build_check_quilt_splitbrain();
6780 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6781 __ "source changes file");
6782 unless (test_source_only_changes($changes)) {
6783 fail __ "user-specified changes file is not source-only";
6786 # Building a source package is very fast, so just do it
6788 confess "er, patches are applied dirtily but shouldn't be.."
6789 if $patches_applied_dirtily;
6790 $changesfile = $sourcechanges;
6795 sub binary_builder {
6796 my ($bbuilder, $pbmc_msg, @args) = @_;
6797 build_prep(WANTSRC_SOURCE);
6799 midbuild_checkchanges();
6802 stat_exists $dscfn or fail f_
6803 "%s (in build products dir): %s", $dscfn, $!;
6804 stat_exists $sourcechanges or fail f_
6805 "%s (in build products dir): %s", $sourcechanges, $!;
6807 runcmd_ordryrun_local @$bbuilder, @args;
6809 maybe_unapply_patches_again();
6811 postbuild_mergechanges($pbmc_msg);
6817 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6818 perhaps you need to pass -A ? (sbuild's default is to build only
6819 arch-specific binaries; dgit 1.4 used to override that.)
6824 my ($pbuilder) = @_;
6826 # @ARGV is allowed to contain only things that should be passed to
6827 # pbuilder under debbuildopts; just massage those
6828 my $wantsrc = massage_dbp_args \@ARGV;
6830 "you asked for a builder but your debbuildopts didn't ask for".
6831 " any binaries -- is this really what you meant?"
6832 unless $wantsrc & WANTSRC_BUILDER;
6834 "we must build a .dsc to pass to the builder but your debbuiltopts".
6835 " forbids the building of a source package; cannot continue"
6836 unless $wantsrc & WANTSRC_SOURCE;
6837 # We do not want to include the verb "build" in @pbuilder because
6838 # the user can customise @pbuilder and they shouldn't be required
6839 # to include "build" in their customised value. However, if the
6840 # user passes any additional args to pbuilder using the dgit
6841 # option --pbuilder:foo, such args need to come after the "build"
6842 # verb. opts_opt_multi_cmd does all of that.
6843 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6844 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6849 pbuilder(\@pbuilder);
6852 sub cmd_cowbuilder {
6853 pbuilder(\@cowbuilder);
6856 sub cmd_quilt_fixup {
6857 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6860 build_maybe_quilt_fixup();
6863 sub cmd_print_unapplied_treeish {
6864 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6866 my $headref = git_rev_parse('HEAD');
6867 my $clogp = commit_getclogp $headref;
6868 $package = getfield $clogp, 'Source';
6869 $version = getfield $clogp, 'Version';
6870 $isuite = getfield $clogp, 'Distribution';
6871 $csuite = $isuite; # we want this to be offline!
6875 changedir $playground;
6876 my $uv = upstreamversion $version;
6877 my $u = quilt_fakedsc2unapplied($headref, $uv);
6878 print $u, "\n" or confess "$!";
6881 sub import_dsc_result {
6882 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6883 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6885 check_gitattrs($newhash, __ "source tree");
6887 progress f_ "dgit: import-dsc: %s", $what_msg;
6890 sub cmd_import_dsc {
6894 last unless $ARGV[0] =~ m/^-/;
6897 if (m/^--require-valid-signature$/) {
6900 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6904 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6906 my ($dscfn, $dstbranch) = @ARGV;
6908 badusage __ "dry run makes no sense with import-dsc"
6911 my $force = $dstbranch =~ s/^\+// ? +1 :
6912 $dstbranch =~ s/^\.\.// ? -1 :
6914 my $info = $force ? " $&" : '';
6915 $info = "$dscfn$info";
6917 my $specbranch = $dstbranch;
6918 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6919 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6921 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6922 my $chead = cmdoutput_errok @symcmd;
6923 defined $chead or $?==256 or failedcmd @symcmd;
6925 fail f_ "%s is checked out - will not update it", $dstbranch
6926 if defined $chead and $chead eq $dstbranch;
6928 my $oldhash = git_get_ref $dstbranch;
6930 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6931 $dscdata = do { local $/ = undef; <D>; };
6932 D->error and fail f_ "read %s: %s", $dscfn, $!;
6935 # we don't normally need this so import it here
6936 use Dpkg::Source::Package;
6937 my $dp = new Dpkg::Source::Package filename => $dscfn,
6938 require_valid_signature => $needsig;
6940 local $SIG{__WARN__} = sub {
6942 return unless $needsig;
6943 fail __ "import-dsc signature check failed";
6945 if (!$dp->is_signed()) {
6946 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6948 my $r = $dp->check_signature();
6949 confess "->check_signature => $r" if $needsig && $r;
6955 $package = getfield $dsc, 'Source';
6957 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6958 unless forceing [qw(import-dsc-with-dgit-field)];
6959 parse_dsc_field_def_dsc_distro();
6961 $isuite = 'DGIT-IMPORT-DSC';
6962 $idistro //= $dsc_distro;
6966 if (defined $dsc_hash) {
6968 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6969 resolve_dsc_field_commit undef, undef;
6971 if (defined $dsc_hash) {
6972 my @cmd = (qw(sh -ec),
6973 "echo $dsc_hash | git cat-file --batch-check");
6974 my $objgot = cmdoutput @cmd;
6975 if ($objgot =~ m#^\w+ missing\b#) {
6976 fail f_ <<END, $dsc_hash
6977 .dsc contains Dgit field referring to object %s
6978 Your git tree does not have that object. Try `git fetch' from a
6979 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6982 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6984 progress __ "Not fast forward, forced update.";
6986 fail f_ "Not fast forward to %s", $dsc_hash;
6989 import_dsc_result $dstbranch, $dsc_hash,
6990 "dgit import-dsc (Dgit): $info",
6991 f_ "updated git ref %s", $dstbranch;
6995 fail f_ <<END, $dstbranch, $specbranch, $specbranch
6996 Branch %s already exists
6997 Specify ..%s for a pseudo-merge, binding in existing history
6998 Specify +%s to overwrite, discarding existing history
7000 if $oldhash && !$force;
7002 my @dfi = dsc_files_info();
7003 foreach my $fi (@dfi) {
7004 my $f = $fi->{Filename};
7005 # We transfer all the pieces of the dsc to the bpd, not just
7006 # origs. This is by analogy with dgit fetch, which wants to
7007 # keep them somewhere to avoid downloading them again.
7008 # We make symlinks, though. If the user wants copies, then
7009 # they can copy the parts of the dsc to the bpd using dcmd,
7011 my $here = "$buildproductsdir/$f";
7016 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7018 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7019 printdebug "not in bpd, $f ...\n";
7020 # $f does not exist in bpd, we need to transfer it
7022 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7023 # $there is file we want, relative to user's cwd, or abs
7024 printdebug "not in bpd, $f, test $there ...\n";
7025 stat $there or fail f_
7026 "import %s requires %s, but: %s", $dscfn, $there, $!;
7027 if ($there =~ m#^(?:\./+)?\.\./+#) {
7028 # $there is relative to user's cwd
7029 my $there_from_parent = $';
7030 if ($buildproductsdir !~ m{^/}) {
7031 # abs2rel, despite its name, can take two relative paths
7032 $there = File::Spec->abs2rel($there,$buildproductsdir);
7033 # now $there is relative to bpd, great
7034 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7036 $there = (dirname $maindir)."/$there_from_parent";
7037 # now $there is absoute
7038 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7040 } elsif ($there =~ m#^/#) {
7041 # $there is absolute already
7042 printdebug "not in bpd, $f, abs, $there ...\n";
7045 "cannot import %s which seems to be inside working tree!",
7048 symlink $there, $here or fail f_
7049 "symlink %s to %s: %s", $there, $here, $!;
7050 progress f_ "made symlink %s -> %s", $here, $there;
7051 # print STDERR Dumper($fi);
7053 my @mergeinputs = generate_commits_from_dsc();
7054 die unless @mergeinputs == 1;
7056 my $newhash = $mergeinputs[0]{Commit};
7061 "Import, forced update - synthetic orphan git history.";
7062 } elsif ($force < 0) {
7063 progress __ "Import, merging.";
7064 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7065 my $version = getfield $dsc, 'Version';
7066 my $clogp = commit_getclogp $newhash;
7067 my $authline = clogp_authline $clogp;
7068 $newhash = make_commit_text <<ENDU
7076 .(f_ <<END, $package, $version, $dstbranch);
7077 Merge %s (%s) import into %s
7080 die; # caught earlier
7084 import_dsc_result $dstbranch, $newhash,
7085 "dgit import-dsc: $info",
7086 f_ "results are in git ref %s", $dstbranch;
7089 sub pre_archive_api_query () {
7090 not_necessarily_a_tree();
7092 sub cmd_archive_api_query {
7093 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7094 my ($subpath) = @ARGV;
7095 local $isuite = 'DGIT-API-QUERY-CMD';
7096 my @cmd = archive_api_query_cmd($subpath);
7099 exec @cmd or fail f_ "exec curl: %s\n", $!;
7102 sub repos_server_url () {
7103 $package = '_dgit-repos-server';
7104 local $access_forpush = 1;
7105 local $isuite = 'DGIT-REPOS-SERVER';
7106 my $url = access_giturl();
7109 sub pre_clone_dgit_repos_server () {
7110 not_necessarily_a_tree();
7112 sub cmd_clone_dgit_repos_server {
7113 badusage __ "need destination argument" unless @ARGV==1;
7114 my ($destdir) = @ARGV;
7115 my $url = repos_server_url();
7116 my @cmd = (@git, qw(clone), $url, $destdir);
7118 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7121 sub pre_print_dgit_repos_server_source_url () {
7122 not_necessarily_a_tree();
7124 sub cmd_print_dgit_repos_server_source_url {
7126 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7128 my $url = repos_server_url();
7129 print $url, "\n" or confess "$!";
7132 sub pre_print_dpkg_source_ignores {
7133 not_necessarily_a_tree();
7135 sub cmd_print_dpkg_source_ignores {
7137 "no arguments allowed to dgit print-dpkg-source-ignores"
7139 print "@dpkg_source_ignores\n" or confess "$!";
7142 sub cmd_setup_mergechangelogs {
7143 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7145 local $isuite = 'DGIT-SETUP-TREE';
7146 setup_mergechangelogs(1);
7149 sub cmd_setup_useremail {
7150 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7151 local $isuite = 'DGIT-SETUP-TREE';
7155 sub cmd_setup_gitattributes {
7156 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7157 local $isuite = 'DGIT-SETUP-TREE';
7161 sub cmd_setup_new_tree {
7162 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7163 local $isuite = 'DGIT-SETUP-TREE';
7167 #---------- argument parsing and main program ----------
7170 print "dgit version $our_version\n" or confess "$!";
7174 our (%valopts_long, %valopts_short);
7175 our (%funcopts_long);
7177 our (@modeopt_cfgs);
7179 sub defvalopt ($$$$) {
7180 my ($long,$short,$val_re,$how) = @_;
7181 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7182 $valopts_long{$long} = $oi;
7183 $valopts_short{$short} = $oi;
7184 # $how subref should:
7185 # do whatever assignemnt or thing it likes with $_[0]
7186 # if the option should not be passed on to remote, @rvalopts=()
7187 # or $how can be a scalar ref, meaning simply assign the value
7190 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7191 defvalopt '--distro', '-d', '.+', \$idistro;
7192 defvalopt '', '-k', '.+', \$keyid;
7193 defvalopt '--existing-package','', '.*', \$existing_package;
7194 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7195 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7196 defvalopt '--package', '-p', $package_re, \$package;
7197 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7199 defvalopt '', '-C', '.+', sub {
7200 ($changesfile) = (@_);
7201 if ($changesfile =~ s#^(.*)/##) {
7202 $buildproductsdir = $1;
7206 defvalopt '--initiator-tempdir','','.*', sub {
7207 ($initiator_tempdir) = (@_);
7208 $initiator_tempdir =~ m#^/# or
7209 badusage __ "--initiator-tempdir must be used specify an".
7210 " absolute, not relative, directory."
7213 sub defoptmodes ($@) {
7214 my ($varref, $cfgkey, $default, %optmap) = @_;
7216 while (my ($opt,$val) = each %optmap) {
7217 $funcopts_long{$opt} = sub { $$varref = $val; };
7218 $permit{$val} = $val;
7220 push @modeopt_cfgs, {
7223 Default => $default,
7228 defoptmodes \$dodep14tag, qw( dep14tag want
7231 --always-dep14tag always );
7236 if (defined $ENV{'DGIT_SSH'}) {
7237 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7238 } elsif (defined $ENV{'GIT_SSH'}) {
7239 @ssh = ($ENV{'GIT_SSH'});
7247 if (!defined $val) {
7248 badusage f_ "%s needs a value", $what unless @ARGV;
7250 push @rvalopts, $val;
7252 badusage f_ "bad value \`%s' for %s", $val, $what unless
7253 $val =~ m/^$oi->{Re}$(?!\n)/s;
7254 my $how = $oi->{How};
7255 if (ref($how) eq 'SCALAR') {
7260 push @ropts, @rvalopts;
7264 last unless $ARGV[0] =~ m/^-/;
7268 if (m/^--dry-run$/) {
7271 } elsif (m/^--damp-run$/) {
7274 } elsif (m/^--no-sign$/) {
7277 } elsif (m/^--help$/) {
7279 } elsif (m/^--version$/) {
7281 } elsif (m/^--new$/) {
7284 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7285 ($om = $opts_opt_map{$1}) &&
7289 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7290 !$opts_opt_cmdonly{$1} &&
7291 ($om = $opts_opt_map{$1})) {
7294 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7295 !$opts_opt_cmdonly{$1} &&
7296 ($om = $opts_opt_map{$1})) {
7298 my $cmd = shift @$om;
7299 @$om = ($cmd, grep { $_ ne $2 } @$om);
7300 } elsif (m/^--(gbp|dpm)$/s) {
7301 push @ropts, "--quilt=$1";
7303 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7306 } elsif (m/^--no-quilt-fixup$/s) {
7308 $quilt_mode = 'nocheck';
7309 } elsif (m/^--no-rm-on-error$/s) {
7312 } elsif (m/^--no-chase-dsc-distro$/s) {
7314 $chase_dsc_distro = 0;
7315 } elsif (m/^--overwrite$/s) {
7317 $overwrite_version = '';
7318 } elsif (m/^--overwrite=(.+)$/s) {
7320 $overwrite_version = $1;
7321 } elsif (m/^--delayed=(\d+)$/s) {
7324 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7325 m/^--(dgit-view)-save=(.+)$/s
7327 my ($k,$v) = ($1,$2);
7329 $v =~ s#^(?!refs/)#refs/heads/#;
7330 $internal_object_save{$k} = $v;
7331 } elsif (m/^--(no-)?rm-old-changes$/s) {
7334 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7336 push @deliberatelies, $&;
7337 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7341 } elsif (m/^--force-/) {
7343 f_ "%s: warning: ignoring unknown force option %s\n",
7346 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7347 # undocumented, for testing
7349 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7350 # ^ it's supposed to be an array ref
7351 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7352 $val = $2 ? $' : undef; #';
7353 $valopt->($oi->{Long});
7354 } elsif ($funcopts_long{$_}) {
7356 $funcopts_long{$_}();
7358 badusage f_ "unknown long option \`%s'", $_;
7365 } elsif (s/^-L/-/) {
7368 } elsif (s/^-h/-/) {
7370 } elsif (s/^-D/-/) {
7374 } elsif (s/^-N/-/) {
7379 push @changesopts, $_;
7381 } elsif (s/^-wn$//s) {
7383 $cleanmode = 'none';
7384 } elsif (s/^-wg(f?)(a?)$//s) {
7387 $cleanmode .= '-ff' if $1;
7388 $cleanmode .= ',always' if $2;
7389 } elsif (s/^-wd(d?)([na]?)$//s) {
7391 $cleanmode = 'dpkg-source';
7392 $cleanmode .= '-d' if $1;
7393 $cleanmode .= ',no-check' if $2 eq 'n';
7394 $cleanmode .= ',all-check' if $2 eq 'a';
7395 } elsif (s/^-wc$//s) {
7397 $cleanmode = 'check';
7398 } elsif (s/^-wci$//s) {
7400 $cleanmode = 'check,ignores';
7401 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7402 push @git, '-c', $&;
7403 $gitcfgs{cmdline}{$1} = [ $2 ];
7404 } elsif (s/^-c([^=]+)$//s) {
7405 push @git, '-c', $&;
7406 $gitcfgs{cmdline}{$1} = [ 'true' ];
7407 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7409 $val = undef unless length $val;
7410 $valopt->($oi->{Short});
7413 badusage f_ "unknown short option \`%s'", $_;
7420 sub check_env_sanity () {
7421 my $blocked = new POSIX::SigSet;
7422 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7425 foreach my $name (qw(PIPE CHLD)) {
7426 my $signame = "SIG$name";
7427 my $signum = eval "POSIX::$signame" // die;
7428 die f_ "%s is set to something other than SIG_DFL\n",
7430 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7431 $blocked->ismember($signum) and
7432 die f_ "%s is blocked\n", $signame;
7438 On entry to dgit, %s
7439 This is a bug produced by something in your execution environment.
7445 sub parseopts_late_defaults () {
7446 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7447 if defined $idistro;
7448 $isuite //= cfg('dgit.default.default-suite');
7450 foreach my $k (keys %opts_opt_map) {
7451 my $om = $opts_opt_map{$k};
7453 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7455 badcfg f_ "cannot set command for %s", $k
7456 unless length $om->[0];
7460 foreach my $c (access_cfg_cfgs("opts-$k")) {
7462 map { $_ ? @$_ : () }
7463 map { $gitcfgs{$_}{$c} }
7464 reverse @gitcfgsources;
7465 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7466 "\n" if $debuglevel >= 4;
7468 badcfg f_ "cannot configure options for %s", $k
7469 if $opts_opt_cmdonly{$k};
7470 my $insertpos = $opts_cfg_insertpos{$k};
7471 @$om = ( @$om[0..$insertpos-1],
7473 @$om[$insertpos..$#$om] );
7477 if (!defined $rmchanges) {
7478 local $access_forpush;
7479 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7482 if (!defined $quilt_mode) {
7483 local $access_forpush;
7484 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7485 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7487 $quilt_mode =~ m/^($quilt_modes_re)$/
7488 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7492 foreach my $moc (@modeopt_cfgs) {
7493 local $access_forpush;
7494 my $vr = $moc->{Var};
7495 next if defined $$vr;
7496 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7497 my $v = $moc->{Vals}{$$vr};
7498 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7504 local $access_forpush;
7505 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7509 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7510 $buildproductsdir //= '..';
7511 $bpd_glob = $buildproductsdir;
7512 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7515 setlocale(LC_MESSAGES, "");
7518 if ($ENV{$fakeeditorenv}) {
7520 quilt_fixup_editor();
7526 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7527 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7528 if $dryrun_level == 1;
7530 print STDERR __ $helpmsg or confess "$!";
7533 $cmd = $subcommand = shift @ARGV;
7536 my $pre_fn = ${*::}{"pre_$cmd"};
7537 $pre_fn->() if $pre_fn;
7539 if ($invoked_in_git_tree) {
7540 changedir_git_toplevel();
7545 my $fn = ${*::}{"cmd_$cmd"};
7546 $fn or badusage f_ "unknown operation %s", $cmd;