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;
178 # Interactions between quilt mode and split brain
179 # (currently, split brain only implemented iff
180 # madformat_wantfixup && quiltmode_splitting)
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_splitting () {
295 $quilt_mode =~ m/gbp|dpm|unapplied/;
298 sub do_split_brain () { !!($do_split_brain // confess) }
300 sub opts_opt_multi_cmd {
303 push @cmd, split /\s+/, shift @_;
310 return opts_opt_multi_cmd [], @gbp_pq;
313 sub dgit_privdir () {
314 our $dgit_privdir_made //= ensure_a_playground 'dgit';
318 my $r = $buildproductsdir;
319 $r = "$maindir/$r" unless $r =~ m{^/};
323 sub get_tree_of_commit ($) {
324 my ($commitish) = @_;
325 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
326 $cdata =~ m/\n\n/; $cdata = $`;
327 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
331 sub branch_gdr_info ($$) {
332 my ($symref, $head) = @_;
333 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
334 gdr_ffq_prev_branchinfo($symref);
335 return () unless $status eq 'branch';
336 $ffq_prev = git_get_ref $ffq_prev;
337 $gdrlast = git_get_ref $gdrlast;
338 $gdrlast &&= is_fast_fwd $gdrlast, $head;
339 return ($ffq_prev, $gdrlast);
342 sub branch_is_gdr_unstitched_ff ($$$) {
343 my ($symref, $head, $ancestor) = @_;
344 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
345 return 0 unless $ffq_prev;
346 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
350 sub branch_is_gdr ($) {
352 # This is quite like git-debrebase's keycommits.
353 # We have our own implementation because:
354 # - our algorighm can do fewer tests so is faster
355 # - it saves testing to see if gdr is installed
357 # NB we use this jsut for deciding whether to run gdr make-patches
358 # Before reusing this algorithm for somthing else, its
359 # suitability should be reconsidered.
362 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
363 printdebug "branch_is_gdr $head...\n";
364 my $get_patches = sub {
365 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
368 my $tip_patches = $get_patches->($head);
371 my $cdata = git_cat_file $walk, 'commit';
372 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
373 if ($msg =~ m{^\[git-debrebase\ (
374 anchor | changelog | make-patches |
375 merged-breakwater | pseudomerge
377 # no need to analyse this - it's sufficient
378 # (gdr classifications: Anchor, MergedBreakwaters)
379 # (made by gdr: Pseudomerge, Changelog)
380 printdebug "branch_is_gdr $walk gdr $1 YES\n";
383 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
385 my $walk_tree = get_tree_of_commit $walk;
386 foreach my $p (@parents) {
387 my $p_tree = get_tree_of_commit $p;
388 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
389 # (gdr classification: Pseudomerge; not made by gdr)
390 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
396 # some other non-gdr merge
397 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
398 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
402 # (gdr classification: ?)
403 printdebug "branch_is_gdr $walk ?-octopus NO\n";
407 printdebug "branch_is_gdr $walk origin\n";
410 if ($get_patches->($walk) ne $tip_patches) {
411 # Our parent added, removed, or edited patches, and wasn't
412 # a gdr make-patches commit. gdr make-patches probably
413 # won't do that well, then.
414 # (gdr classification of parent: AddPatches or ?)
415 printdebug "branch_is_gdr $walk ?-patches NO\n";
418 if ($tip_patches eq '' and
419 !defined git_cat_file "$walk~:debian" and
420 !quiltify_trees_differ "$walk~", $walk
422 # (gdr classification of parent: BreakwaterStart
423 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
426 # (gdr classification: Upstream Packaging Mixed Changelog)
427 printdebug "branch_is_gdr $walk plain\n"
433 #---------- remote protocol support, common ----------
435 # remote push initiator/responder protocol:
436 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
437 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
438 # < dgit-remote-push-ready <actual-proto-vsn>
445 # > supplementary-message NBYTES
450 # > file parsed-changelog
451 # [indicates that output of dpkg-parsechangelog follows]
452 # > data-block NBYTES
453 # > [NBYTES bytes of data (no newline)]
454 # [maybe some more blocks]
463 # > param head DGIT-VIEW-HEAD
464 # > param csuite SUITE
465 # > param tagformat new # $protovsn == 4
466 # > param maint-view MAINT-VIEW-HEAD
468 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
469 # > file buildinfo # for buildinfos to sign
471 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
472 # # goes into tag, for replay prevention
475 # [indicates that signed tag is wanted]
476 # < data-block NBYTES
477 # < [NBYTES bytes of data (no newline)]
478 # [maybe some more blocks]
482 # > want signed-dsc-changes
483 # < data-block NBYTES [transfer of signed dsc]
485 # < data-block NBYTES [transfer of signed changes]
487 # < data-block NBYTES [transfer of each signed buildinfo
488 # [etc] same number and order as "file buildinfo"]
496 sub i_child_report () {
497 # Sees if our child has died, and reap it if so. Returns a string
498 # describing how it died if it failed, or undef otherwise.
499 return undef unless $i_child_pid;
500 my $got = waitpid $i_child_pid, WNOHANG;
501 return undef if $got <= 0;
502 die unless $got == $i_child_pid;
503 $i_child_pid = undef;
504 return undef unless $?;
505 return f_ "build host child %s", waitstatusmsg();
510 fail f_ "connection lost: %s", $! if $fh->error;
511 fail f_ "protocol violation; %s not expected", $m;
514 sub badproto_badread ($$) {
516 fail f_ "connection lost: %s", $! if $!;
517 my $report = i_child_report();
518 fail $report if defined $report;
519 badproto $fh, f_ "eof (reading %s)", $wh;
522 sub protocol_expect (&$) {
523 my ($match, $fh) = @_;
526 defined && chomp or badproto_badread $fh, __ "protocol message";
534 badproto $fh, f_ "\`%s'", $_;
537 sub protocol_send_file ($$) {
538 my ($fh, $ourfn) = @_;
539 open PF, "<", $ourfn or die "$ourfn: $!";
542 my $got = read PF, $d, 65536;
543 die "$ourfn: $!" unless defined $got;
545 print $fh "data-block ".length($d)."\n" or confess "$!";
546 print $fh $d or confess "$!";
548 PF->error and die "$ourfn $!";
549 print $fh "data-end\n" or confess "$!";
553 sub protocol_read_bytes ($$) {
554 my ($fh, $nbytes) = @_;
555 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
557 my $got = read $fh, $d, $nbytes;
558 $got==$nbytes or badproto_badread $fh, __ "data block";
562 sub protocol_receive_file ($$) {
563 my ($fh, $ourfn) = @_;
564 printdebug "() $ourfn\n";
565 open PF, ">", $ourfn or die "$ourfn: $!";
567 my ($y,$l) = protocol_expect {
568 m/^data-block (.*)$/ ? (1,$1) :
569 m/^data-end$/ ? (0,) :
573 my $d = protocol_read_bytes $fh, $l;
574 print PF $d or confess "$!";
576 close PF or confess "$!";
579 #---------- remote protocol support, responder ----------
581 sub responder_send_command ($) {
583 return unless $we_are_responder;
584 # called even without $we_are_responder
585 printdebug ">> $command\n";
586 print PO $command, "\n" or confess "$!";
589 sub responder_send_file ($$) {
590 my ($keyword, $ourfn) = @_;
591 return unless $we_are_responder;
592 printdebug "]] $keyword $ourfn\n";
593 responder_send_command "file $keyword";
594 protocol_send_file \*PO, $ourfn;
597 sub responder_receive_files ($@) {
598 my ($keyword, @ourfns) = @_;
599 die unless $we_are_responder;
600 printdebug "[[ $keyword @ourfns\n";
601 responder_send_command "want $keyword";
602 foreach my $fn (@ourfns) {
603 protocol_receive_file \*PI, $fn;
606 protocol_expect { m/^files-end$/ } \*PI;
609 #---------- remote protocol support, initiator ----------
611 sub initiator_expect (&) {
613 protocol_expect { &$match } \*RO;
616 #---------- end remote code ----------
619 if ($we_are_responder) {
621 responder_send_command "progress ".length($m) or confess "$!";
622 print PO $m or confess "$!";
632 $ua = LWP::UserAgent->new();
636 progress "downloading $what...";
637 my $r = $ua->get(@_) or confess "$!";
638 return undef if $r->code == 404;
639 $r->is_success or fail f_ "failed to fetch %s: %s",
640 $what, $r->status_line;
641 return $r->decoded_content(charset => 'none');
644 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
646 sub act_local () { return $dryrun_level <= 1; }
647 sub act_scary () { return !$dryrun_level; }
650 if (!$dryrun_level) {
651 progress f_ "%s ok: %s", $us, "@_";
653 progress f_ "would be ok: %s (but dry run only)", "@_";
658 printcmd(\*STDERR,$debugprefix."#",@_);
661 sub runcmd_ordryrun {
669 sub runcmd_ordryrun_local {
677 our $helpmsg = i_ <<END;
679 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
680 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
681 dgit [dgit-opts] build [dpkg-buildpackage-opts]
682 dgit [dgit-opts] sbuild [sbuild-opts]
683 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
684 dgit [dgit-opts] push [dgit-opts] [suite]
685 dgit [dgit-opts] push-source [dgit-opts] [suite]
686 dgit [dgit-opts] rpush build-host:build-dir ...
687 important dgit options:
688 -k<keyid> sign tag and package with <keyid> instead of default
689 --dry-run -n do not change anything, but go through the motions
690 --damp-run -L like --dry-run but make local changes, without signing
691 --new -N allow introducing a new package
692 --debug -D increase debug level
693 -c<name>=<value> set git config option (used directly by dgit too)
696 our $later_warning_msg = i_ <<END;
697 Perhaps the upload is stuck in incoming. Using the version from git.
701 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
706 @ARGV or badusage __ "too few arguments";
707 return scalar shift @ARGV;
711 not_necessarily_a_tree();
714 print __ $helpmsg or confess "$!";
718 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
720 our %defcfg = ('dgit.default.distro' => 'debian',
721 'dgit.default.default-suite' => 'unstable',
722 'dgit.default.old-dsc-distro' => 'debian',
723 'dgit-suite.*-security.distro' => 'debian-security',
724 'dgit.default.username' => '',
725 'dgit.default.archive-query-default-component' => 'main',
726 'dgit.default.ssh' => 'ssh',
727 'dgit.default.archive-query' => 'madison:',
728 'dgit.default.sshpsql-dbname' => 'service=projectb',
729 'dgit.default.aptget-components' => 'main',
730 'dgit.default.source-only-uploads' => 'ok',
731 'dgit.dsc-url-proto-ok.http' => 'true',
732 'dgit.dsc-url-proto-ok.https' => 'true',
733 'dgit.dsc-url-proto-ok.git' => 'true',
734 'dgit.vcs-git.suites', => 'sid', # ;-separated
735 'dgit.default.dsc-url-proto-ok' => 'false',
736 # old means "repo server accepts pushes with old dgit tags"
737 # new means "repo server accepts pushes with new dgit tags"
738 # maint means "repo server accepts split brain pushes"
739 # hist means "repo server may have old pushes without new tag"
740 # ("hist" is implied by "old")
741 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
742 'dgit-distro.debian.git-check' => 'url',
743 'dgit-distro.debian.git-check-suffix' => '/info/refs',
744 'dgit-distro.debian.new-private-pushers' => 't',
745 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
746 'dgit-distro.debian/push.git-url' => '',
747 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
748 'dgit-distro.debian/push.git-user-force' => 'dgit',
749 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
750 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
751 'dgit-distro.debian/push.git-create' => 'true',
752 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
753 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
754 # 'dgit-distro.debian.archive-query-tls-key',
755 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
756 # ^ this does not work because curl is broken nowadays
757 # Fixing #790093 properly will involve providing providing the key
758 # in some pacagke and maybe updating these paths.
760 # 'dgit-distro.debian.archive-query-tls-curl-args',
761 # '--ca-path=/etc/ssl/ca-debian',
762 # ^ this is a workaround but works (only) on DSA-administered machines
763 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
764 'dgit-distro.debian.git-url-suffix' => '',
765 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
766 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
767 'dgit-distro.debian-security.archive-query' => 'aptget:',
768 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
769 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
770 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
771 'dgit-distro.debian-security.nominal-distro' => 'debian',
772 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
773 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
774 'dgit-distro.ubuntu.git-check' => 'false',
775 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
776 'dgit-distro.test-dummy.ssh' => "$td/ssh",
777 'dgit-distro.test-dummy.username' => "alice",
778 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
779 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
780 'dgit-distro.test-dummy.git-url' => "$td/git",
781 'dgit-distro.test-dummy.git-host' => "git",
782 'dgit-distro.test-dummy.git-path' => "$td/git",
783 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
784 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
785 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
786 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
790 our @gitcfgsources = qw(cmdline local global system);
791 our $invoked_in_git_tree = 1;
793 sub git_slurp_config () {
794 # This algoritm is a bit subtle, but this is needed so that for
795 # options which we want to be single-valued, we allow the
796 # different config sources to override properly. See #835858.
797 foreach my $src (@gitcfgsources) {
798 next if $src eq 'cmdline';
799 # we do this ourselves since git doesn't handle it
801 $gitcfgs{$src} = git_slurp_config_src $src;
805 sub git_get_config ($) {
807 foreach my $src (@gitcfgsources) {
808 my $l = $gitcfgs{$src}{$c};
809 confess "internal error ($l $c)" if $l && !ref $l;
810 printdebug"C $c ".(defined $l ?
811 join " ", map { messagequote "'$_'" } @$l :
816 f_ "multiple values for %s (in %s git config)", $c, $src
818 $l->[0] =~ m/\n/ and badcfg f_
819 "value for config option %s (in %s git config) contains newline(s)!",
828 return undef if $c =~ /RETURN-UNDEF/;
829 printdebug "C? $c\n" if $debuglevel >= 5;
830 my $v = git_get_config($c);
831 return $v if defined $v;
832 my $dv = $defcfg{$c};
834 printdebug "CD $c $dv\n" if $debuglevel >= 4;
839 "need value for one of: %s\n".
840 "%s: distro or suite appears not to be (properly) supported",
844 sub not_necessarily_a_tree () {
845 # needs to be called from pre_*
846 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
847 $invoked_in_git_tree = 0;
850 sub access_basedistro__noalias () {
851 if (defined $idistro) {
854 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
855 return $def if defined $def;
856 foreach my $src (@gitcfgsources, 'internal') {
857 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
859 foreach my $k (keys %$kl) {
860 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
862 next unless match_glob $dpat, $isuite;
866 return cfg("dgit.default.distro");
870 sub access_basedistro () {
871 my $noalias = access_basedistro__noalias();
872 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
873 return $canon // $noalias;
876 sub access_nomdistro () {
877 my $base = access_basedistro();
878 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
879 $r =~ m/^$distro_re$/ or badcfg
880 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
881 $r, "/^$distro_re$/";
885 sub access_quirk () {
886 # returns (quirk name, distro to use instead or undef, quirk-specific info)
887 my $basedistro = access_basedistro();
888 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
890 if (defined $backports_quirk) {
891 my $re = $backports_quirk;
892 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
894 $re =~ s/\%/([-0-9a-z_]+)/
895 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
896 if ($isuite =~ m/^$re$/) {
897 return ('backports',"$basedistro-backports",$1);
900 return ('none',undef);
905 sub parse_cfg_bool ($$$) {
906 my ($what,$def,$v) = @_;
909 $v =~ m/^[ty1]/ ? 1 :
910 $v =~ m/^[fn0]/ ? 0 :
911 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
915 sub access_forpush_config () {
916 my $d = access_basedistro();
920 parse_cfg_bool('new-private-pushers', 0,
921 cfg("dgit-distro.$d.new-private-pushers",
924 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
927 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
928 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
929 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
931 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
934 sub access_forpush () {
935 $access_forpush //= access_forpush_config();
936 return $access_forpush;
939 sub default_from_access_cfg ($$$;$) {
940 my ($var, $keybase, $defval, $permit_re) = @_;
941 return if defined $$var;
943 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
944 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
946 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
949 badcfg f_ "unknown %s \`%s'", $keybase, $$var
950 if defined $permit_re and $$var !~ m/$permit_re/;
954 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
955 defined $access_forpush and !$access_forpush;
956 badcfg __ "pushing but distro is configured readonly"
957 if access_forpush_config() eq '0';
959 $supplementary_message = __ <<'END' unless $we_are_responder;
960 Push failed, before we got started.
961 You can retry the push, after fixing the problem, if you like.
963 parseopts_late_defaults();
967 parseopts_late_defaults();
970 sub determine_whether_split_brain () {
971 my ($format,) = get_source_format();
972 printdebug "format $format, quilt mode $quilt_mode\n";
973 if (madformat_wantfixup($format) && quiltmode_splitting()) {
976 $do_split_brain //= 0;
979 sub supplementary_message ($) {
981 if (!$we_are_responder) {
982 $supplementary_message = $msg;
985 responder_send_command "supplementary-message ".length($msg)
987 print PO $msg or confess "$!";
991 sub access_distros () {
992 # Returns list of distros to try, in order
995 # 0. `instead of' distro name(s) we have been pointed to
996 # 1. the access_quirk distro, if any
997 # 2a. the user's specified distro, or failing that } basedistro
998 # 2b. the distro calculated from the suite }
999 my @l = access_basedistro();
1001 my (undef,$quirkdistro) = access_quirk();
1002 unshift @l, $quirkdistro;
1003 unshift @l, $instead_distro;
1004 @l = grep { defined } @l;
1006 push @l, access_nomdistro();
1008 if (access_forpush()) {
1009 @l = map { ("$_/push", $_) } @l;
1014 sub access_cfg_cfgs (@) {
1017 # The nesting of these loops determines the search order. We put
1018 # the key loop on the outside so that we search all the distros
1019 # for each key, before going on to the next key. That means that
1020 # if access_cfg is called with a more specific, and then a less
1021 # specific, key, an earlier distro can override the less specific
1022 # without necessarily overriding any more specific keys. (If the
1023 # distro wants to override the more specific keys it can simply do
1024 # so; whereas if we did the loop the other way around, it would be
1025 # impossible to for an earlier distro to override a less specific
1026 # key but not the more specific ones without restating the unknown
1027 # values of the more specific keys.
1030 # We have to deal with RETURN-UNDEF specially, so that we don't
1031 # terminate the search prematurely.
1033 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1036 foreach my $d (access_distros()) {
1037 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1039 push @cfgs, map { "dgit.default.$_" } @realkeys;
1040 push @cfgs, @rundef;
1044 sub access_cfg (@) {
1046 my (@cfgs) = access_cfg_cfgs(@keys);
1047 my $value = cfg(@cfgs);
1051 sub access_cfg_bool ($$) {
1052 my ($def, @keys) = @_;
1053 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1056 sub string_to_ssh ($) {
1058 if ($spec =~ m/\s/) {
1059 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1065 sub access_cfg_ssh () {
1066 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1067 if (!defined $gitssh) {
1070 return string_to_ssh $gitssh;
1074 sub access_runeinfo ($) {
1076 return ": dgit ".access_basedistro()." $info ;";
1079 sub access_someuserhost ($) {
1081 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1082 defined($user) && length($user) or
1083 $user = access_cfg("$some-user",'username');
1084 my $host = access_cfg("$some-host");
1085 return length($user) ? "$user\@$host" : $host;
1088 sub access_gituserhost () {
1089 return access_someuserhost('git');
1092 sub access_giturl (;$) {
1093 my ($optional) = @_;
1094 my $url = access_cfg('git-url','RETURN-UNDEF');
1097 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1098 return undef unless defined $proto;
1101 access_gituserhost().
1102 access_cfg('git-path');
1104 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1107 return "$url/$package$suffix";
1110 sub commit_getclogp ($) {
1111 # Returns the parsed changelog hashref for a particular commit
1113 our %commit_getclogp_memo;
1114 my $memo = $commit_getclogp_memo{$objid};
1115 return $memo if $memo;
1117 my $mclog = dgit_privdir()."clog";
1118 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1119 "$objid:debian/changelog";
1120 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1123 sub parse_dscdata () {
1124 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1125 printdebug Dumper($dscdata) if $debuglevel>1;
1126 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1127 printdebug Dumper($dsc) if $debuglevel>1;
1132 sub archive_query ($;@) {
1133 my ($method) = shift @_;
1134 fail __ "this operation does not support multiple comma-separated suites"
1136 my $query = access_cfg('archive-query','RETURN-UNDEF');
1137 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1140 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1143 sub archive_query_prepend_mirror {
1144 my $m = access_cfg('mirror');
1145 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1148 sub pool_dsc_subpath ($$) {
1149 my ($vsn,$component) = @_; # $package is implict arg
1150 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1151 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1154 sub cfg_apply_map ($$$) {
1155 my ($varref, $what, $mapspec) = @_;
1156 return unless $mapspec;
1158 printdebug "config $what EVAL{ $mapspec; }\n";
1160 eval "package Dgit::Config; $mapspec;";
1165 #---------- `ftpmasterapi' archive query method (nascent) ----------
1167 sub archive_api_query_cmd ($) {
1169 my @cmd = (@curl, qw(-sS));
1170 my $url = access_cfg('archive-query-url');
1171 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1173 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1174 foreach my $key (split /\:/, $keys) {
1175 $key =~ s/\%HOST\%/$host/g;
1177 fail "for $url: stat $key: $!" unless $!==ENOENT;
1180 fail f_ "config requested specific TLS key but do not know".
1181 " how to get curl to use exactly that EE key (%s)",
1183 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1184 # # Sadly the above line does not work because of changes
1185 # # to gnutls. The real fix for #790093 may involve
1186 # # new curl options.
1189 # Fixing #790093 properly will involve providing a value
1190 # for this on clients.
1191 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1192 push @cmd, split / /, $kargs if defined $kargs;
1194 push @cmd, $url.$subpath;
1198 sub api_query ($$;$) {
1200 my ($data, $subpath, $ok404) = @_;
1201 badcfg __ "ftpmasterapi archive query method takes no data part"
1203 my @cmd = archive_api_query_cmd($subpath);
1204 my $url = $cmd[$#cmd];
1205 push @cmd, qw(-w %{http_code});
1206 my $json = cmdoutput @cmd;
1207 unless ($json =~ s/\d+\d+\d$//) {
1208 failedcmd_report_cmd undef, @cmd;
1209 fail __ "curl failed to print 3-digit HTTP code";
1212 return undef if $code eq '404' && $ok404;
1213 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1214 unless $url =~ m#^file://# or $code =~ m/^2/;
1215 return decode_json($json);
1218 sub canonicalise_suite_ftpmasterapi {
1219 my ($proto,$data) = @_;
1220 my $suites = api_query($data, 'suites');
1222 foreach my $entry (@$suites) {
1224 my $v = $entry->{$_};
1225 defined $v && $v eq $isuite;
1226 } qw(codename name);
1227 push @matched, $entry;
1229 fail f_ "unknown suite %s, maybe -d would help", $isuite
1233 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1234 $cn = "$matched[0]{codename}";
1235 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1236 $cn =~ m/^$suite_re$/
1237 or die f_ "suite %s maps to bad codename\n", $isuite;
1239 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1244 sub archive_query_ftpmasterapi {
1245 my ($proto,$data) = @_;
1246 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1248 my $digester = Digest::SHA->new(256);
1249 foreach my $entry (@$info) {
1251 my $vsn = "$entry->{version}";
1252 my ($ok,$msg) = version_check $vsn;
1253 die f_ "bad version: %s\n", $msg unless $ok;
1254 my $component = "$entry->{component}";
1255 $component =~ m/^$component_re$/ or die __ "bad component";
1256 my $filename = "$entry->{filename}";
1257 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1258 or die __ "bad filename";
1259 my $sha256sum = "$entry->{sha256sum}";
1260 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1261 push @rows, [ $vsn, "/pool/$component/$filename",
1262 $digester, $sha256sum ];
1264 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1267 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1268 return archive_query_prepend_mirror @rows;
1271 sub file_in_archive_ftpmasterapi {
1272 my ($proto,$data,$filename) = @_;
1273 my $pat = $filename;
1276 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1277 my $info = api_query($data, "file_in_archive/$pat", 1);
1280 sub package_not_wholly_new_ftpmasterapi {
1281 my ($proto,$data,$pkg) = @_;
1282 my $info = api_query($data,"madison?package=${pkg}&f=json");
1286 #---------- `aptget' archive query method ----------
1289 our $aptget_releasefile;
1290 our $aptget_configpath;
1292 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1293 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1295 sub aptget_cache_clean {
1296 runcmd_ordryrun_local qw(sh -ec),
1297 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1301 sub aptget_lock_acquire () {
1302 my $lockfile = "$aptget_base/lock";
1303 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1304 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1307 sub aptget_prep ($) {
1309 return if defined $aptget_base;
1311 badcfg __ "aptget archive query method takes no data part"
1314 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1317 ensuredir "$cache/dgit";
1319 access_cfg('aptget-cachekey','RETURN-UNDEF')
1320 // access_nomdistro();
1322 $aptget_base = "$cache/dgit/aptget";
1323 ensuredir $aptget_base;
1325 my $quoted_base = $aptget_base;
1326 confess "$quoted_base contains bad chars, cannot continue"
1327 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1329 ensuredir $aptget_base;
1331 aptget_lock_acquire();
1333 aptget_cache_clean();
1335 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1336 my $sourceslist = "source.list#$cachekey";
1338 my $aptsuites = $isuite;
1339 cfg_apply_map(\$aptsuites, 'suite map',
1340 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1342 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1343 printf SRCS "deb-src %s %s %s\n",
1344 access_cfg('mirror'),
1346 access_cfg('aptget-components')
1349 ensuredir "$aptget_base/cache";
1350 ensuredir "$aptget_base/lists";
1352 open CONF, ">", $aptget_configpath or confess "$!";
1354 Debug::NoLocking "true";
1355 APT::Get::List-Cleanup "false";
1356 #clear APT::Update::Post-Invoke-Success;
1357 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1358 Dir::State::Lists "$quoted_base/lists";
1359 Dir::Etc::preferences "$quoted_base/preferences";
1360 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1361 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1364 foreach my $key (qw(
1367 Dir::Cache::Archives
1368 Dir::Etc::SourceParts
1369 Dir::Etc::preferencesparts
1371 ensuredir "$aptget_base/$key";
1372 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1375 my $oldatime = (time // confess "$!") - 1;
1376 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1377 next unless stat_exists $oldlist;
1378 my ($mtime) = (stat _)[9];
1379 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1382 runcmd_ordryrun_local aptget_aptget(), qw(update);
1385 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1386 next unless stat_exists $oldlist;
1387 my ($atime) = (stat _)[8];
1388 next if $atime == $oldatime;
1389 push @releasefiles, $oldlist;
1391 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1392 @releasefiles = @inreleasefiles if @inreleasefiles;
1393 if (!@releasefiles) {
1394 fail f_ <<END, $isuite, $cache;
1395 apt seemed to not to update dgit's cached Release files for %s.
1397 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1400 confess "apt updated too many Release files (@releasefiles), erk"
1401 unless @releasefiles == 1;
1403 ($aptget_releasefile) = @releasefiles;
1406 sub canonicalise_suite_aptget {
1407 my ($proto,$data) = @_;
1410 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1412 foreach my $name (qw(Codename Suite)) {
1413 my $val = $release->{$name};
1415 printdebug "release file $name: $val\n";
1416 $val =~ m/^$suite_re$/o or fail f_
1417 "Release file (%s) specifies intolerable %s",
1418 $aptget_releasefile, $name;
1419 cfg_apply_map(\$val, 'suite rmap',
1420 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1427 sub archive_query_aptget {
1428 my ($proto,$data) = @_;
1431 ensuredir "$aptget_base/source";
1432 foreach my $old (<$aptget_base/source/*.dsc>) {
1433 unlink $old or die "$old: $!";
1436 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1437 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1438 # avoids apt-get source failing with ambiguous error code
1440 runcmd_ordryrun_local
1441 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1442 aptget_aptget(), qw(--download-only --only-source source), $package;
1444 my @dscs = <$aptget_base/source/*.dsc>;
1445 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1446 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1449 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1452 my $uri = "file://". uri_escape $dscs[0];
1453 $uri =~ s{\%2f}{/}gi;
1454 return [ (getfield $pre_dsc, 'Version'), $uri ];
1457 sub file_in_archive_aptget () { return undef; }
1458 sub package_not_wholly_new_aptget () { return undef; }
1460 #---------- `dummyapicat' archive query method ----------
1461 # (untranslated, because this is for testing purposes etc.)
1463 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1464 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1466 sub dummycatapi_run_in_mirror ($@) {
1467 # runs $fn with FIA open onto rune
1468 my ($rune, $argl, $fn) = @_;
1470 my $mirror = access_cfg('mirror');
1471 $mirror =~ s#^file://#/# or die "$mirror ?";
1472 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1473 qw(x), $mirror, @$argl);
1474 debugcmd "-|", @cmd;
1475 open FIA, "-|", @cmd or confess "$!";
1477 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1481 sub file_in_archive_dummycatapi ($$$) {
1482 my ($proto,$data,$filename) = @_;
1484 dummycatapi_run_in_mirror '
1485 find -name "$1" -print0 |
1487 ', [$filename], sub {
1490 printdebug "| $_\n";
1491 m/^(\w+) (\S+)$/ or die "$_ ?";
1492 push @out, { sha256sum => $1, filename => $2 };
1498 sub package_not_wholly_new_dummycatapi {
1499 my ($proto,$data,$pkg) = @_;
1500 dummycatapi_run_in_mirror "
1501 find -name ${pkg}_*.dsc
1508 #---------- `madison' archive query method ----------
1510 sub archive_query_madison {
1511 return archive_query_prepend_mirror
1512 map { [ @$_[0..1] ] } madison_get_parse(@_);
1515 sub madison_get_parse {
1516 my ($proto,$data) = @_;
1517 die unless $proto eq 'madison';
1518 if (!length $data) {
1519 $data= access_cfg('madison-distro','RETURN-UNDEF');
1520 $data //= access_basedistro();
1522 $rmad{$proto,$data,$package} ||= cmdoutput
1523 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1524 my $rmad = $rmad{$proto,$data,$package};
1527 foreach my $l (split /\n/, $rmad) {
1528 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1529 \s*( [^ \t|]+ )\s* \|
1530 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1531 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1532 $1 eq $package or die "$rmad $package ?";
1539 $component = access_cfg('archive-query-default-component');
1541 $5 eq 'source' or die "$rmad ?";
1542 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1544 return sort { -version_compare($a->[0],$b->[0]); } @out;
1547 sub canonicalise_suite_madison {
1548 # madison canonicalises for us
1549 my @r = madison_get_parse(@_);
1551 "unable to canonicalise suite using package %s".
1552 " which does not appear to exist in suite %s;".
1553 " --existing-package may help",
1558 sub file_in_archive_madison { return undef; }
1559 sub package_not_wholly_new_madison { return undef; }
1561 #---------- `sshpsql' archive query method ----------
1562 # (untranslated, because this is obsolete)
1565 my ($data,$runeinfo,$sql) = @_;
1566 if (!length $data) {
1567 $data= access_someuserhost('sshpsql').':'.
1568 access_cfg('sshpsql-dbname');
1570 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1571 my ($userhost,$dbname) = ($`,$'); #';
1573 my @cmd = (access_cfg_ssh, $userhost,
1574 access_runeinfo("ssh-psql $runeinfo").
1575 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1576 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1578 open P, "-|", @cmd or confess "$!";
1581 printdebug(">|$_|\n");
1584 $!=0; $?=0; close P or failedcmd @cmd;
1586 my $nrows = pop @rows;
1587 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1588 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1589 @rows = map { [ split /\|/, $_ ] } @rows;
1590 my $ncols = scalar @{ shift @rows };
1591 die if grep { scalar @$_ != $ncols } @rows;
1595 sub sql_injection_check {
1596 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1599 sub archive_query_sshpsql ($$) {
1600 my ($proto,$data) = @_;
1601 sql_injection_check $isuite, $package;
1602 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1603 SELECT source.version, component.name, files.filename, files.sha256sum
1605 JOIN src_associations ON source.id = src_associations.source
1606 JOIN suite ON suite.id = src_associations.suite
1607 JOIN dsc_files ON dsc_files.source = source.id
1608 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1609 JOIN component ON component.id = files_archive_map.component_id
1610 JOIN files ON files.id = dsc_files.file
1611 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1612 AND source.source='$package'
1613 AND files.filename LIKE '%.dsc';
1615 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1616 my $digester = Digest::SHA->new(256);
1618 my ($vsn,$component,$filename,$sha256sum) = @$_;
1619 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1621 return archive_query_prepend_mirror @rows;
1624 sub canonicalise_suite_sshpsql ($$) {
1625 my ($proto,$data) = @_;
1626 sql_injection_check $isuite;
1627 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1628 SELECT suite.codename
1629 FROM suite where suite_name='$isuite' or codename='$isuite';
1631 @rows = map { $_->[0] } @rows;
1632 fail "unknown suite $isuite" unless @rows;
1633 die "ambiguous $isuite: @rows ?" if @rows>1;
1637 sub file_in_archive_sshpsql ($$$) { return undef; }
1638 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1640 #---------- `dummycat' archive query method ----------
1641 # (untranslated, because this is for testing purposes etc.)
1643 sub canonicalise_suite_dummycat ($$) {
1644 my ($proto,$data) = @_;
1645 my $dpath = "$data/suite.$isuite";
1646 if (!open C, "<", $dpath) {
1647 $!==ENOENT or die "$dpath: $!";
1648 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1652 chomp or die "$dpath: $!";
1654 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1658 sub archive_query_dummycat ($$) {
1659 my ($proto,$data) = @_;
1660 canonicalise_suite();
1661 my $dpath = "$data/package.$csuite.$package";
1662 if (!open C, "<", $dpath) {
1663 $!==ENOENT or die "$dpath: $!";
1664 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1672 printdebug "dummycat query $csuite $package $dpath | $_\n";
1673 my @row = split /\s+/, $_;
1674 @row==2 or die "$dpath: $_ ?";
1677 C->error and die "$dpath: $!";
1679 return archive_query_prepend_mirror
1680 sort { -version_compare($a->[0],$b->[0]); } @rows;
1683 sub file_in_archive_dummycat () { return undef; }
1684 sub package_not_wholly_new_dummycat () { return undef; }
1686 #---------- archive query entrypoints and rest of program ----------
1688 sub canonicalise_suite () {
1689 return if defined $csuite;
1690 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1691 $csuite = archive_query('canonicalise_suite');
1692 if ($isuite ne $csuite) {
1693 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1695 progress f_ "canonical suite name is %s", $csuite;
1699 sub get_archive_dsc () {
1700 canonicalise_suite();
1701 my @vsns = archive_query('archive_query');
1702 foreach my $vinfo (@vsns) {
1703 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1704 $dscurl = $vsn_dscurl;
1705 $dscdata = url_get($dscurl);
1707 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1712 $digester->add($dscdata);
1713 my $got = $digester->hexdigest();
1715 fail f_ "%s has hash %s but archive told us to expect %s",
1716 $dscurl, $got, $digest;
1719 my $fmt = getfield $dsc, 'Format';
1720 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1721 f_ "unsupported source format %s, sorry", $fmt;
1723 $dsc_checked = !!$digester;
1724 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1728 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1731 sub check_for_git ();
1732 sub check_for_git () {
1734 my $how = access_cfg('git-check');
1735 if ($how eq 'ssh-cmd') {
1737 (access_cfg_ssh, access_gituserhost(),
1738 access_runeinfo("git-check $package").
1739 " set -e; cd ".access_cfg('git-path').";".
1740 " if test -d $package.git; then echo 1; else echo 0; fi");
1741 my $r= cmdoutput @cmd;
1742 if (defined $r and $r =~ m/^divert (\w+)$/) {
1744 my ($usedistro,) = access_distros();
1745 # NB that if we are pushing, $usedistro will be $distro/push
1746 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1747 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1748 progress f_ "diverting to %s (using config for %s)",
1749 $divert, $instead_distro;
1750 return check_for_git();
1752 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1754 } elsif ($how eq 'url') {
1755 my $prefix = access_cfg('git-check-url','git-url');
1756 my $suffix = access_cfg('git-check-suffix','git-suffix',
1757 'RETURN-UNDEF') // '.git';
1758 my $url = "$prefix/$package$suffix";
1759 my @cmd = (@curl, qw(-sS -I), $url);
1760 my $result = cmdoutput @cmd;
1761 $result =~ s/^\S+ 200 .*\n\r?\n//;
1762 # curl -sS -I with https_proxy prints
1763 # HTTP/1.0 200 Connection established
1764 $result =~ m/^\S+ (404|200) /s or
1765 fail +(__ "unexpected results from git check query - ").
1766 Dumper($prefix, $result);
1768 if ($code eq '404') {
1770 } elsif ($code eq '200') {
1775 } elsif ($how eq 'true') {
1777 } elsif ($how eq 'false') {
1780 badcfg f_ "unknown git-check \`%s'", $how;
1784 sub create_remote_git_repo () {
1785 my $how = access_cfg('git-create');
1786 if ($how eq 'ssh-cmd') {
1788 (access_cfg_ssh, access_gituserhost(),
1789 access_runeinfo("git-create $package").
1790 "set -e; cd ".access_cfg('git-path').";".
1791 " cp -a _template $package.git");
1792 } elsif ($how eq 'true') {
1795 badcfg f_ "unknown git-create \`%s'", $how;
1799 our ($dsc_hash,$lastpush_mergeinput);
1800 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1804 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1805 $playground = fresh_playground 'dgit/unpack';
1808 sub mktree_in_ud_here () {
1809 playtree_setup $gitcfgs{local};
1812 sub git_write_tree () {
1813 my $tree = cmdoutput @git, qw(write-tree);
1814 $tree =~ m/^\w+$/ or die "$tree ?";
1818 sub git_add_write_tree () {
1819 runcmd @git, qw(add -Af .);
1820 return git_write_tree();
1823 sub remove_stray_gits ($) {
1825 my @gitscmd = qw(find -name .git -prune -print0);
1826 debugcmd "|",@gitscmd;
1827 open GITS, "-|", @gitscmd or confess "$!";
1832 print STDERR f_ "%s: warning: removing from %s: %s\n",
1833 $us, $what, (messagequote $_);
1837 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1840 sub mktree_in_ud_from_only_subdir ($;$) {
1841 my ($what,$raw) = @_;
1842 # changes into the subdir
1845 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1846 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1850 remove_stray_gits($what);
1851 mktree_in_ud_here();
1853 my ($format, $fopts) = get_source_format();
1854 if (madformat($format)) {
1859 my $tree=git_add_write_tree();
1860 return ($tree,$dir);
1863 our @files_csum_info_fields =
1864 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1865 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1866 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1868 sub dsc_files_info () {
1869 foreach my $csumi (@files_csum_info_fields) {
1870 my ($fname, $module, $method) = @$csumi;
1871 my $field = $dsc->{$fname};
1872 next unless defined $field;
1873 eval "use $module; 1;" or die $@;
1875 foreach (split /\n/, $field) {
1877 m/^(\w+) (\d+) (\S+)$/ or
1878 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1879 my $digester = eval "$module"."->$method;" or die $@;
1884 Digester => $digester,
1889 fail f_ "missing any supported Checksums-* or Files field in %s",
1890 $dsc->get_option('name');
1894 map { $_->{Filename} } dsc_files_info();
1897 sub files_compare_inputs (@) {
1902 my $showinputs = sub {
1903 return join "; ", map { $_->get_option('name') } @$inputs;
1906 foreach my $in (@$inputs) {
1908 my $in_name = $in->get_option('name');
1910 printdebug "files_compare_inputs $in_name\n";
1912 foreach my $csumi (@files_csum_info_fields) {
1913 my ($fname) = @$csumi;
1914 printdebug "files_compare_inputs $in_name $fname\n";
1916 my $field = $in->{$fname};
1917 next unless defined $field;
1920 foreach (split /\n/, $field) {
1923 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1924 fail "could not parse $in_name $fname line \`$_'";
1926 printdebug "files_compare_inputs $in_name $fname $f\n";
1930 my $re = \ $record{$f}{$fname};
1932 $fchecked{$f}{$in_name} = 1;
1935 "hash or size of %s varies in %s fields (between: %s)",
1936 $f, $fname, $showinputs->();
1941 @files = sort @files;
1942 $expected_files //= \@files;
1943 "@$expected_files" eq "@files" or
1944 fail f_ "file list in %s varies between hash fields!",
1948 fail f_ "%s has no files list field(s)", $in_name;
1950 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1953 grep { keys %$_ == @$inputs-1 } values %fchecked
1954 or fail f_ "no file appears in all file lists (looked in: %s)",
1958 sub is_orig_file_in_dsc ($$) {
1959 my ($f, $dsc_files_info) = @_;
1960 return 0 if @$dsc_files_info <= 1;
1961 # One file means no origs, and the filename doesn't have a "what
1962 # part of dsc" component. (Consider versions ending `.orig'.)
1963 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1967 # This function determines whether a .changes file is source-only from
1968 # the point of view of dak. Thus, it permits *_source.buildinfo
1971 # It does not, however, permit any other buildinfo files. After a
1972 # source-only upload, the buildds will try to upload files like
1973 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1974 # named like this in their (otherwise) source-only upload, the uploads
1975 # of the buildd can be rejected by dak. Fixing the resultant
1976 # situation can require manual intervention. So we block such
1977 # .buildinfo files when the user tells us to perform a source-only
1978 # upload (such as when using the push-source subcommand with the -C
1979 # option, which calls this function).
1981 # Note, though, that when dgit is told to prepare a source-only
1982 # upload, such as when subcommands like build-source and push-source
1983 # without -C are used, dgit has a more restrictive notion of
1984 # source-only .changes than dak: such uploads will never include
1985 # *_source.buildinfo files. This is because there is no use for such
1986 # files when using a tool like dgit to produce the source package, as
1987 # dgit ensures the source is identical to git HEAD.
1988 sub test_source_only_changes ($) {
1990 foreach my $l (split /\n/, getfield $changes, 'Files') {
1991 $l =~ m/\S+$/ or next;
1992 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1993 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1994 print f_ "purportedly source-only changes polluted by %s\n", $&;
2001 sub changes_update_origs_from_dsc ($$$$) {
2002 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2004 printdebug "checking origs needed ($upstreamvsn)...\n";
2005 $_ = getfield $changes, 'Files';
2006 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2007 fail __ "cannot find section/priority from .changes Files field";
2008 my $placementinfo = $1;
2010 printdebug "checking origs needed placement '$placementinfo'...\n";
2011 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2012 $l =~ m/\S+$/ or next;
2014 printdebug "origs $file | $l\n";
2015 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2016 printdebug "origs $file is_orig\n";
2017 my $have = archive_query('file_in_archive', $file);
2018 if (!defined $have) {
2019 print STDERR __ <<END;
2020 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2026 printdebug "origs $file \$#\$have=$#$have\n";
2027 foreach my $h (@$have) {
2030 foreach my $csumi (@files_csum_info_fields) {
2031 my ($fname, $module, $method, $archivefield) = @$csumi;
2032 next unless defined $h->{$archivefield};
2033 $_ = $dsc->{$fname};
2034 next unless defined;
2035 m/^(\w+) .* \Q$file\E$/m or
2036 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2037 if ($h->{$archivefield} eq $1) {
2041 "%s: %s (archive) != %s (local .dsc)",
2042 $archivefield, $h->{$archivefield}, $1;
2045 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2049 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2052 printdebug "origs $file f.same=$found_same".
2053 " #f._differ=$#found_differ\n";
2054 if (@found_differ && !$found_same) {
2056 (f_ "archive contains %s with different checksum", $file),
2059 # Now we edit the changes file to add or remove it
2060 foreach my $csumi (@files_csum_info_fields) {
2061 my ($fname, $module, $method, $archivefield) = @$csumi;
2062 next unless defined $changes->{$fname};
2064 # in archive, delete from .changes if it's there
2065 $changed{$file} = "removed" if
2066 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2067 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2068 # not in archive, but it's here in the .changes
2070 my $dsc_data = getfield $dsc, $fname;
2071 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2073 $extra =~ s/ \d+ /$&$placementinfo /
2074 or confess "$fname $extra >$dsc_data< ?"
2075 if $fname eq 'Files';
2076 $changes->{$fname} .= "\n". $extra;
2077 $changed{$file} = "added";
2082 foreach my $file (keys %changed) {
2084 "edited .changes for archive .orig contents: %s %s",
2085 $changed{$file}, $file;
2087 my $chtmp = "$changesfile.tmp";
2088 $changes->save($chtmp);
2090 rename $chtmp,$changesfile or die "$changesfile $!";
2092 progress f_ "[new .changes left in %s]", $changesfile;
2095 progress f_ "%s already has appropriate .orig(s) (if any)",
2100 sub make_commit ($) {
2102 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2105 sub clogp_authline ($) {
2107 my $author = getfield $clogp, 'Maintainer';
2108 if ($author =~ m/^[^"\@]+\,/) {
2109 # single entry Maintainer field with unquoted comma
2110 $author = ($& =~ y/,//rd).$'; # strip the comma
2112 # git wants a single author; any remaining commas in $author
2113 # are by now preceded by @ (or "). It seems safer to punt on
2114 # "..." for now rather than attempting to dequote or something.
2115 $author =~ s#,.*##ms unless $author =~ m/"/;
2116 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2117 my $authline = "$author $date";
2118 $authline =~ m/$git_authline_re/o or
2119 fail f_ "unexpected commit author line format \`%s'".
2120 " (was generated from changelog Maintainer field)",
2122 return ($1,$2,$3) if wantarray;
2126 sub vendor_patches_distro ($$) {
2127 my ($checkdistro, $what) = @_;
2128 return unless defined $checkdistro;
2130 my $series = "debian/patches/\L$checkdistro\E.series";
2131 printdebug "checking for vendor-specific $series ($what)\n";
2133 if (!open SERIES, "<", $series) {
2134 confess "$series $!" unless $!==ENOENT;
2141 print STDERR __ <<END;
2143 Unfortunately, this source package uses a feature of dpkg-source where
2144 the same source package unpacks to different source code on different
2145 distros. dgit cannot safely operate on such packages on affected
2146 distros, because the meaning of source packages is not stable.
2148 Please ask the distro/maintainer to remove the distro-specific series
2149 files and use a different technique (if necessary, uploading actually
2150 different packages, if different distros are supposed to have
2154 fail f_ "Found active distro-specific series file for".
2155 " %s (%s): %s, cannot continue",
2156 $checkdistro, $what, $series;
2158 die "$series $!" if SERIES->error;
2162 sub check_for_vendor_patches () {
2163 # This dpkg-source feature doesn't seem to be documented anywhere!
2164 # But it can be found in the changelog (reformatted):
2166 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2167 # Author: Raphael Hertzog <hertzog@debian.org>
2168 # Date: Sun Oct 3 09:36:48 2010 +0200
2170 # dpkg-source: correctly create .pc/.quilt_series with alternate
2173 # If you have debian/patches/ubuntu.series and you were
2174 # unpacking the source package on ubuntu, quilt was still
2175 # directed to debian/patches/series instead of
2176 # debian/patches/ubuntu.series.
2178 # debian/changelog | 3 +++
2179 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2180 # 2 files changed, 6 insertions(+), 1 deletion(-)
2183 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2184 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2185 __ "Dpkg::Vendor \`current vendor'");
2186 vendor_patches_distro(access_basedistro(),
2187 __ "(base) distro being accessed");
2188 vendor_patches_distro(access_nomdistro(),
2189 __ "(nominal) distro being accessed");
2192 sub check_bpd_exists () {
2193 stat $buildproductsdir
2194 or fail f_ "build-products-dir %s is not accessible: %s\n",
2195 $buildproductsdir, $!;
2198 sub dotdot_bpd_transfer_origs ($$$) {
2199 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2200 # checks is_orig_file_of_vsn and if
2201 # calls $wanted->{$leaf} and expects boolish
2203 return if $buildproductsdir eq '..';
2206 my $dotdot = $maindir;
2207 $dotdot =~ s{/[^/]+$}{};
2208 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2209 while ($!=0, defined(my $leaf = readdir DD)) {
2211 local ($debuglevel) = $debuglevel-1;
2212 printdebug "DD_BPD $leaf ?\n";
2214 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2215 next unless $wanted->($leaf);
2216 next if lstat "$bpd_abs/$leaf";
2219 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2222 $! == &ENOENT or fail f_
2223 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2224 lstat "$dotdot/$leaf" or fail f_
2225 "check orig file %s in ..: %s", $leaf, $!;
2227 stat "$dotdot/$leaf" or fail f_
2228 "check target of orig symlink %s in ..: %s", $leaf, $!;
2229 my $ltarget = readlink "$dotdot/$leaf" or
2230 die "readlink $dotdot/$leaf: $!";
2231 if ($ltarget !~ m{^/}) {
2232 $ltarget = "$dotdot/$ltarget";
2234 symlink $ltarget, "$bpd_abs/$leaf"
2235 or die "$ltarget $bpd_abs $leaf: $!";
2237 "%s: cloned orig symlink from ..: %s\n",
2239 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2241 "%s: hardlinked orig from ..: %s\n",
2243 } elsif ($! != EXDEV) {
2244 fail f_ "failed to make %s a hardlink to %s: %s",
2245 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2247 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2248 or die "$bpd_abs $dotdot $leaf $!";
2250 "%s: symmlinked orig from .. on other filesystem: %s\n",
2254 die "$dotdot; $!" if $!;
2258 sub generate_commits_from_dsc () {
2259 # See big comment in fetch_from_archive, below.
2260 # See also README.dsc-import.
2262 changedir $playground;
2264 my $bpd_abs = bpd_abs();
2265 my $upstreamv = upstreamversion $dsc->{version};
2266 my @dfi = dsc_files_info();
2268 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2269 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2271 foreach my $fi (@dfi) {
2272 my $f = $fi->{Filename};
2273 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2274 my $upper_f = "$bpd_abs/$f";
2276 printdebug "considering reusing $f: ";
2278 if (link_ltarget "$upper_f,fetch", $f) {
2279 printdebug "linked (using ...,fetch).\n";
2280 } elsif ((printdebug "($!) "),
2282 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2283 } elsif (link_ltarget $upper_f, $f) {
2284 printdebug "linked.\n";
2285 } elsif ((printdebug "($!) "),
2287 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2289 printdebug "absent.\n";
2293 complete_file_from_dsc('.', $fi, \$refetched)
2296 printdebug "considering saving $f: ";
2298 if (rename_link_xf 1, $f, $upper_f) {
2299 printdebug "linked.\n";
2300 } elsif ((printdebug "($@) "),
2302 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2303 } elsif (!$refetched) {
2304 printdebug "no need.\n";
2305 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2306 printdebug "linked (using ...,fetch).\n";
2307 } elsif ((printdebug "($@) "),
2309 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2311 printdebug "cannot.\n";
2315 # We unpack and record the orig tarballs first, so that we only
2316 # need disk space for one private copy of the unpacked source.
2317 # But we can't make them into commits until we have the metadata
2318 # from the debian/changelog, so we record the tree objects now and
2319 # make them into commits later.
2321 my $orig_f_base = srcfn $upstreamv, '';
2323 foreach my $fi (@dfi) {
2324 # We actually import, and record as a commit, every tarball
2325 # (unless there is only one file, in which case there seems
2328 my $f = $fi->{Filename};
2329 printdebug "import considering $f ";
2330 (printdebug "only one dfi\n"), next if @dfi == 1;
2331 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2332 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2336 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2338 printdebug "Y ", (join ' ', map { $_//"(none)" }
2339 $compr_ext, $orig_f_part
2342 my $input = new IO::File $f, '<' or die "$f $!";
2346 if (defined $compr_ext) {
2348 Dpkg::Compression::compression_guess_from_filename $f;
2349 fail "Dpkg::Compression cannot handle file $f in source package"
2350 if defined $compr_ext && !defined $cname;
2352 new Dpkg::Compression::Process compression => $cname;
2353 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2354 my $compr_fh = new IO::Handle;
2355 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2357 open STDIN, "<&", $input or confess "$!";
2359 die "dgit (child): exec $compr_cmd[0]: $!\n";
2364 rmtree "_unpack-tar";
2365 mkdir "_unpack-tar" or confess "$!";
2366 my @tarcmd = qw(tar -x -f -
2367 --no-same-owner --no-same-permissions
2368 --no-acls --no-xattrs --no-selinux);
2369 my $tar_pid = fork // confess "$!";
2371 chdir "_unpack-tar" or confess "$!";
2372 open STDIN, "<&", $input or confess "$!";
2374 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2376 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2377 !$? or failedcmd @tarcmd;
2380 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2382 # finally, we have the results in "tarball", but maybe
2383 # with the wrong permissions
2385 runcmd qw(chmod -R +rwX _unpack-tar);
2386 changedir "_unpack-tar";
2387 remove_stray_gits($f);
2388 mktree_in_ud_here();
2390 my ($tree) = git_add_write_tree();
2391 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2392 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2394 printdebug "one subtree $1\n";
2396 printdebug "multiple subtrees\n";
2399 rmtree "_unpack-tar";
2401 my $ent = [ $f, $tree ];
2403 Orig => !!$orig_f_part,
2404 Sort => (!$orig_f_part ? 2 :
2405 $orig_f_part =~ m/-/g ? 1 :
2413 # put any without "_" first (spec is not clear whether files
2414 # are always in the usual order). Tarballs without "_" are
2415 # the main orig or the debian tarball.
2416 $a->{Sort} <=> $b->{Sort} or
2420 my $any_orig = grep { $_->{Orig} } @tartrees;
2422 my $dscfn = "$package.dsc";
2424 my $treeimporthow = 'package';
2426 open D, ">", $dscfn or die "$dscfn: $!";
2427 print D $dscdata or die "$dscfn: $!";
2428 close D or die "$dscfn: $!";
2429 my @cmd = qw(dpkg-source);
2430 push @cmd, '--no-check' if $dsc_checked;
2431 if (madformat $dsc->{format}) {
2432 push @cmd, '--skip-patches';
2433 $treeimporthow = 'unpatched';
2435 push @cmd, qw(-x --), $dscfn;
2438 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2439 if (madformat $dsc->{format}) {
2440 check_for_vendor_patches();
2444 if (madformat $dsc->{format}) {
2445 my @pcmd = qw(dpkg-source --before-build .);
2446 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2448 $dappliedtree = git_add_write_tree();
2451 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2455 printdebug "import clog search...\n";
2456 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2457 my ($thisstanza, $desc) = @_;
2458 no warnings qw(exiting);
2460 $clogp //= $thisstanza;
2462 printdebug "import clog $thisstanza->{version} $desc...\n";
2464 last if !$any_orig; # we don't need $r1clogp
2466 # We look for the first (most recent) changelog entry whose
2467 # version number is lower than the upstream version of this
2468 # package. Then the last (least recent) previous changelog
2469 # entry is treated as the one which introduced this upstream
2470 # version and used for the synthetic commits for the upstream
2473 # One might think that a more sophisticated algorithm would be
2474 # necessary. But: we do not want to scan the whole changelog
2475 # file. Stopping when we see an earlier version, which
2476 # necessarily then is an earlier upstream version, is the only
2477 # realistic way to do that. Then, either the earliest
2478 # changelog entry we have seen so far is indeed the earliest
2479 # upload of this upstream version; or there are only changelog
2480 # entries relating to later upstream versions (which is not
2481 # possible unless the changelog and .dsc disagree about the
2482 # version). Then it remains to choose between the physically
2483 # last entry in the file, and the one with the lowest version
2484 # number. If these are not the same, we guess that the
2485 # versions were created in a non-monotonic order rather than
2486 # that the changelog entries have been misordered.
2488 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2490 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2491 $r1clogp = $thisstanza;
2493 printdebug "import clog $r1clogp->{version} becomes r1\n";
2496 $clogp or fail __ "package changelog has no entries!";
2498 my $authline = clogp_authline $clogp;
2499 my $changes = getfield $clogp, 'Changes';
2500 $changes =~ s/^\n//; # Changes: \n
2501 my $cversion = getfield $clogp, 'Version';
2504 $r1clogp //= $clogp; # maybe there's only one entry;
2505 my $r1authline = clogp_authline $r1clogp;
2506 # Strictly, r1authline might now be wrong if it's going to be
2507 # unused because !$any_orig. Whatever.
2509 printdebug "import tartrees authline $authline\n";
2510 printdebug "import tartrees r1authline $r1authline\n";
2512 foreach my $tt (@tartrees) {
2513 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2515 my $mbody = f_ "Import %s", $tt->{F};
2516 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2519 committer $r1authline
2523 [dgit import orig $tt->{F}]
2531 [dgit import tarball $package $cversion $tt->{F}]
2536 printdebug "import main commit\n";
2538 open C, ">../commit.tmp" or confess "$!";
2539 print C <<END or confess "$!";
2542 print C <<END or confess "$!" foreach @tartrees;
2545 print C <<END or confess "$!";
2551 [dgit import $treeimporthow $package $cversion]
2554 close C or confess "$!";
2555 my $rawimport_hash = make_commit qw(../commit.tmp);
2557 if (madformat $dsc->{format}) {
2558 printdebug "import apply patches...\n";
2560 # regularise the state of the working tree so that
2561 # the checkout of $rawimport_hash works nicely.
2562 my $dappliedcommit = make_commit_text(<<END);
2569 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2571 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2573 # We need the answers to be reproducible
2574 my @authline = clogp_authline($clogp);
2575 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2576 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2577 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2578 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2579 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2580 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2582 my $path = $ENV{PATH} or die;
2584 # we use ../../gbp-pq-output, which (given that we are in
2585 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2588 foreach my $use_absurd (qw(0 1)) {
2589 runcmd @git, qw(checkout -q unpa);
2590 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2591 local $ENV{PATH} = $path;
2594 progress "warning: $@";
2595 $path = "$absurdity:$path";
2596 progress f_ "%s: trying slow absurd-git-apply...", $us;
2597 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2602 die "forbid absurd git-apply\n" if $use_absurd
2603 && forceing [qw(import-gitapply-no-absurd)];
2604 die "only absurd git-apply!\n" if !$use_absurd
2605 && forceing [qw(import-gitapply-absurd)];
2607 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2608 local $ENV{PATH} = $path if $use_absurd;
2610 my @showcmd = (gbp_pq, qw(import));
2611 my @realcmd = shell_cmd
2612 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2613 debugcmd "+",@realcmd;
2614 if (system @realcmd) {
2615 die f_ "%s failed: %s\n",
2616 +(shellquote @showcmd),
2617 failedcmd_waitstatus();
2620 my $gapplied = git_rev_parse('HEAD');
2621 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2622 $gappliedtree eq $dappliedtree or
2623 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2624 gbp-pq import and dpkg-source disagree!
2625 gbp-pq import gave commit %s
2626 gbp-pq import gave tree %s
2627 dpkg-source --before-build gave tree %s
2629 $rawimport_hash = $gapplied;
2634 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2639 progress f_ "synthesised git commit from .dsc %s", $cversion;
2641 my $rawimport_mergeinput = {
2642 Commit => $rawimport_hash,
2643 Info => __ "Import of source package",
2645 my @output = ($rawimport_mergeinput);
2647 if ($lastpush_mergeinput) {
2648 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2649 my $oversion = getfield $oldclogp, 'Version';
2651 version_compare($oversion, $cversion);
2653 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2654 { ReverseParents => 1,
2655 Message => (f_ <<END, $package, $cversion, $csuite) });
2656 Record %s (%s) in archive suite %s
2658 } elsif ($vcmp > 0) {
2659 print STDERR f_ <<END, $cversion, $oversion,
2661 Version actually in archive: %s (older)
2662 Last version pushed with dgit: %s (newer or same)
2665 __ $later_warning_msg or confess "$!";
2666 @output = $lastpush_mergeinput;
2668 # Same version. Use what's in the server git branch,
2669 # discarding our own import. (This could happen if the
2670 # server automatically imports all packages into git.)
2671 @output = $lastpush_mergeinput;
2679 sub complete_file_from_dsc ($$;$) {
2680 our ($dstdir, $fi, $refetched) = @_;
2681 # Ensures that we have, in $dstdir, the file $fi, with the correct
2682 # contents. (Downloading it from alongside $dscurl if necessary.)
2683 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2684 # and will set $$refetched=1 if it did so (or tried to).
2686 my $f = $fi->{Filename};
2687 my $tf = "$dstdir/$f";
2691 my $checkhash = sub {
2692 open F, "<", "$tf" or die "$tf: $!";
2693 $fi->{Digester}->reset();
2694 $fi->{Digester}->addfile(*F);
2695 F->error and confess "$!";
2696 $got = $fi->{Digester}->hexdigest();
2697 return $got eq $fi->{Hash};
2700 if (stat_exists $tf) {
2701 if ($checkhash->()) {
2702 progress f_ "using existing %s", $f;
2706 fail f_ "file %s has hash %s but .dsc demands hash %s".
2707 " (perhaps you should delete this file?)",
2708 $f, $got, $fi->{Hash};
2710 progress f_ "need to fetch correct version of %s", $f;
2711 unlink $tf or die "$tf $!";
2714 printdebug "$tf does not exist, need to fetch\n";
2718 $furl =~ s{/[^/]+$}{};
2720 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2721 die "$f ?" if $f =~ m#/#;
2722 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2723 return 0 if !act_local();
2726 fail f_ "file %s has hash %s but .dsc demands hash %s".
2727 " (got wrong file from archive!)",
2728 $f, $got, $fi->{Hash};
2733 sub ensure_we_have_orig () {
2734 my @dfi = dsc_files_info();
2735 foreach my $fi (@dfi) {
2736 my $f = $fi->{Filename};
2737 next unless is_orig_file_in_dsc($f, \@dfi);
2738 complete_file_from_dsc($buildproductsdir, $fi)
2743 #---------- git fetch ----------
2745 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2746 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2748 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2749 # locally fetched refs because they have unhelpful names and clutter
2750 # up gitk etc. So we track whether we have "used up" head ref (ie,
2751 # whether we have made another local ref which refers to this object).
2753 # (If we deleted them unconditionally, then we might end up
2754 # re-fetching the same git objects each time dgit fetch was run.)
2756 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2757 # in git_fetch_us to fetch the refs in question, and possibly a call
2758 # to lrfetchref_used.
2760 our (%lrfetchrefs_f, %lrfetchrefs_d);
2761 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2763 sub lrfetchref_used ($) {
2764 my ($fullrefname) = @_;
2765 my $objid = $lrfetchrefs_f{$fullrefname};
2766 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2769 sub git_lrfetch_sane {
2770 my ($url, $supplementary, @specs) = @_;
2771 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2772 # at least as regards @specs. Also leave the results in
2773 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2774 # able to clean these up.
2776 # With $supplementary==1, @specs must not contain wildcards
2777 # and we add to our previous fetches (non-atomically).
2779 # This is rather miserable:
2780 # When git fetch --prune is passed a fetchspec ending with a *,
2781 # it does a plausible thing. If there is no * then:
2782 # - it matches subpaths too, even if the supplied refspec
2783 # starts refs, and behaves completely madly if the source
2784 # has refs/refs/something. (See, for example, Debian #NNNN.)
2785 # - if there is no matching remote ref, it bombs out the whole
2787 # We want to fetch a fixed ref, and we don't know in advance
2788 # if it exists, so this is not suitable.
2790 # Our workaround is to use git ls-remote. git ls-remote has its
2791 # own qairks. Notably, it has the absurd multi-tail-matching
2792 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2793 # refs/refs/foo etc.
2795 # Also, we want an idempotent snapshot, but we have to make two
2796 # calls to the remote: one to git ls-remote and to git fetch. The
2797 # solution is use git ls-remote to obtain a target state, and
2798 # git fetch to try to generate it. If we don't manage to generate
2799 # the target state, we try again.
2801 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2803 my $specre = join '|', map {
2806 my $wildcard = $x =~ s/\\\*$/.*/;
2807 die if $wildcard && $supplementary;
2810 printdebug "git_lrfetch_sane specre=$specre\n";
2811 my $wanted_rref = sub {
2813 return m/^(?:$specre)$/;
2816 my $fetch_iteration = 0;
2819 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2820 if (++$fetch_iteration > 10) {
2821 fail __ "too many iterations trying to get sane fetch!";
2824 my @look = map { "refs/$_" } @specs;
2825 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2829 open GITLS, "-|", @lcmd or confess "$!";
2831 printdebug "=> ", $_;
2832 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2833 my ($objid,$rrefname) = ($1,$2);
2834 if (!$wanted_rref->($rrefname)) {
2835 print STDERR f_ <<END, "@look", $rrefname;
2836 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2840 $wantr{$rrefname} = $objid;
2843 close GITLS or failedcmd @lcmd;
2845 # OK, now %want is exactly what we want for refs in @specs
2847 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2848 "+refs/$_:".lrfetchrefs."/$_";
2851 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2853 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2854 runcmd_ordryrun_local @fcmd if @fspecs;
2856 if (!$supplementary) {
2857 %lrfetchrefs_f = ();
2861 git_for_each_ref(lrfetchrefs, sub {
2862 my ($objid,$objtype,$lrefname,$reftail) = @_;
2863 $lrfetchrefs_f{$lrefname} = $objid;
2864 $objgot{$objid} = 1;
2867 if ($supplementary) {
2871 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2872 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2873 if (!exists $wantr{$rrefname}) {
2874 if ($wanted_rref->($rrefname)) {
2876 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2879 print STDERR f_ <<END, "@fspecs", $lrefname
2880 warning: git fetch %s created %s; this is silly, deleting it.
2883 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2884 delete $lrfetchrefs_f{$lrefname};
2888 foreach my $rrefname (sort keys %wantr) {
2889 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2890 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2891 my $want = $wantr{$rrefname};
2892 next if $got eq $want;
2893 if (!defined $objgot{$want}) {
2894 fail __ <<END unless act_local();
2895 --dry-run specified but we actually wanted the results of git fetch,
2896 so this is not going to work. Try running dgit fetch first,
2897 or using --damp-run instead of --dry-run.
2899 print STDERR f_ <<END, $lrefname, $want;
2900 warning: git ls-remote suggests we want %s
2901 warning: and it should refer to %s
2902 warning: but git fetch didn't fetch that object to any relevant ref.
2903 warning: This may be due to a race with someone updating the server.
2904 warning: Will try again...
2906 next FETCH_ITERATION;
2909 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2911 runcmd_ordryrun_local @git, qw(update-ref -m),
2912 "dgit fetch git fetch fixup", $lrefname, $want;
2913 $lrfetchrefs_f{$lrefname} = $want;
2918 if (defined $csuite) {
2919 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2920 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2921 my ($objid,$objtype,$lrefname,$reftail) = @_;
2922 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2923 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2927 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2928 Dumper(\%lrfetchrefs_f);
2931 sub git_fetch_us () {
2932 # Want to fetch only what we are going to use, unless
2933 # deliberately-not-ff, in which case we must fetch everything.
2935 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2936 map { "tags/$_" } debiantags('*',access_nomdistro);
2937 push @specs, server_branch($csuite);
2938 push @specs, $rewritemap;
2939 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2941 my $url = access_giturl();
2942 git_lrfetch_sane $url, 0, @specs;
2945 my @tagpats = debiantags('*',access_nomdistro);
2947 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2948 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2949 printdebug "currently $fullrefname=$objid\n";
2950 $here{$fullrefname} = $objid;
2952 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2953 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2954 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2955 printdebug "offered $lref=$objid\n";
2956 if (!defined $here{$lref}) {
2957 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2958 runcmd_ordryrun_local @upd;
2959 lrfetchref_used $fullrefname;
2960 } elsif ($here{$lref} eq $objid) {
2961 lrfetchref_used $fullrefname;
2963 print STDERR f_ "Not updating %s from %s to %s.\n",
2964 $lref, $here{$lref}, $objid;
2969 #---------- dsc and archive handling ----------
2971 sub mergeinfo_getclogp ($) {
2972 # Ensures thit $mi->{Clogp} exists and returns it
2974 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2977 sub mergeinfo_version ($) {
2978 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2981 sub fetch_from_archive_record_1 ($) {
2983 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2984 cmdoutput @git, qw(log -n2), $hash;
2985 # ... gives git a chance to complain if our commit is malformed
2988 sub fetch_from_archive_record_2 ($) {
2990 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2994 dryrun_report @upd_cmd;
2998 sub parse_dsc_field_def_dsc_distro () {
2999 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3000 dgit.default.distro);
3003 sub parse_dsc_field ($$) {
3004 my ($dsc, $what) = @_;
3006 foreach my $field (@ourdscfield) {
3007 $f = $dsc->{$field};
3012 progress f_ "%s: NO git hash", $what;
3013 parse_dsc_field_def_dsc_distro();
3014 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3015 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3016 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3017 $dsc_hint_tag = [ $dsc_hint_tag ];
3018 } elsif ($f =~ m/^\w+\s*$/) {
3020 parse_dsc_field_def_dsc_distro();
3021 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3023 progress f_ "%s: specified git hash", $what;
3025 fail f_ "%s: invalid Dgit info", $what;
3029 sub resolve_dsc_field_commit ($$) {
3030 my ($already_distro, $already_mapref) = @_;
3032 return unless defined $dsc_hash;
3035 defined $already_mapref &&
3036 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3037 ? $already_mapref : undef;
3041 my ($what, @fetch) = @_;
3043 local $idistro = $dsc_distro;
3044 my $lrf = lrfetchrefs;
3046 if (!$chase_dsc_distro) {
3047 progress f_ "not chasing .dsc distro %s: not fetching %s",
3052 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3054 my $url = access_giturl();
3055 if (!defined $url) {
3056 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3057 .dsc Dgit metadata is in context of distro %s
3058 for which we have no configured url and .dsc provides no hint
3061 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3062 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3063 parse_cfg_bool "dsc-url-proto-ok", 'false',
3064 cfg("dgit.dsc-url-proto-ok.$proto",
3065 "dgit.default.dsc-url-proto-ok")
3066 or fail f_ <<END, $dsc_distro, $proto;
3067 .dsc Dgit metadata is in context of distro %s
3068 for which we have no configured url;
3069 .dsc provides hinted url with protocol %s which is unsafe.
3070 (can be overridden by config - consult documentation)
3072 $url = $dsc_hint_url;
3075 git_lrfetch_sane $url, 1, @fetch;
3080 my $rewrite_enable = do {
3081 local $idistro = $dsc_distro;
3082 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3085 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3086 if (!defined $mapref) {
3087 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3088 $mapref = $lrf.'/'.$rewritemap;
3090 my $rewritemapdata = git_cat_file $mapref.':map';
3091 if (defined $rewritemapdata
3092 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3094 "server's git history rewrite map contains a relevant entry!";
3097 if (defined $dsc_hash) {
3098 progress __ "using rewritten git hash in place of .dsc value";
3100 progress __ "server data says .dsc hash is to be disregarded";
3105 if (!defined git_cat_file $dsc_hash) {
3106 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3107 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3108 defined git_cat_file $dsc_hash
3109 or fail f_ <<END, $dsc_hash;
3110 .dsc Dgit metadata requires commit %s
3111 but we could not obtain that object anywhere.
3113 foreach my $t (@tags) {
3114 my $fullrefname = $lrf.'/'.$t;
3115 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3116 next unless $lrfetchrefs_f{$fullrefname};
3117 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3118 lrfetchref_used $fullrefname;
3123 sub fetch_from_archive () {
3125 ensure_setup_existing_tree();
3127 # Ensures that lrref() is what is actually in the archive, one way
3128 # or another, according to us - ie this client's
3129 # appropritaely-updated archive view. Also returns the commit id.
3130 # If there is nothing in the archive, leaves lrref alone and
3131 # returns undef. git_fetch_us must have already been called.
3135 parse_dsc_field($dsc, __ 'last upload to archive');
3136 resolve_dsc_field_commit access_basedistro,
3137 lrfetchrefs."/".$rewritemap
3139 progress __ "no version available from the archive";
3142 # If the archive's .dsc has a Dgit field, there are three
3143 # relevant git commitids we need to choose between and/or merge
3145 # 1. $dsc_hash: the Dgit field from the archive
3146 # 2. $lastpush_hash: the suite branch on the dgit git server
3147 # 3. $lastfetch_hash: our local tracking brach for the suite
3149 # These may all be distinct and need not be in any fast forward
3152 # If the dsc was pushed to this suite, then the server suite
3153 # branch will have been updated; but it might have been pushed to
3154 # a different suite and copied by the archive. Conversely a more
3155 # recent version may have been pushed with dgit but not appeared
3156 # in the archive (yet).
3158 # $lastfetch_hash may be awkward because archive imports
3159 # (particularly, imports of Dgit-less .dscs) are performed only as
3160 # needed on individual clients, so different clients may perform a
3161 # different subset of them - and these imports are only made
3162 # public during push. So $lastfetch_hash may represent a set of
3163 # imports different to a subsequent upload by a different dgit
3166 # Our approach is as follows:
3168 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3169 # descendant of $dsc_hash, then it was pushed by a dgit user who
3170 # had based their work on $dsc_hash, so we should prefer it.
3171 # Otherwise, $dsc_hash was installed into this suite in the
3172 # archive other than by a dgit push, and (necessarily) after the
3173 # last dgit push into that suite (since a dgit push would have
3174 # been descended from the dgit server git branch); thus, in that
3175 # case, we prefer the archive's version (and produce a
3176 # pseudo-merge to overwrite the dgit server git branch).
3178 # (If there is no Dgit field in the archive's .dsc then
3179 # generate_commit_from_dsc uses the version numbers to decide
3180 # whether the suite branch or the archive is newer. If the suite
3181 # branch is newer it ignores the archive's .dsc; otherwise it
3182 # generates an import of the .dsc, and produces a pseudo-merge to
3183 # overwrite the suite branch with the archive contents.)
3185 # The outcome of that part of the algorithm is the `public view',
3186 # and is same for all dgit clients: it does not depend on any
3187 # unpublished history in the local tracking branch.
3189 # As between the public view and the local tracking branch: The
3190 # local tracking branch is only updated by dgit fetch, and
3191 # whenever dgit fetch runs it includes the public view in the
3192 # local tracking branch. Therefore if the public view is not
3193 # descended from the local tracking branch, the local tracking
3194 # branch must contain history which was imported from the archive
3195 # but never pushed; and, its tip is now out of date. So, we make
3196 # a pseudo-merge to overwrite the old imports and stitch the old
3199 # Finally: we do not necessarily reify the public view (as
3200 # described above). This is so that we do not end up stacking two
3201 # pseudo-merges. So what we actually do is figure out the inputs
3202 # to any public view pseudo-merge and put them in @mergeinputs.
3205 # $mergeinputs[]{Commit}
3206 # $mergeinputs[]{Info}
3207 # $mergeinputs[0] is the one whose tree we use
3208 # @mergeinputs is in the order we use in the actual commit)
3211 # $mergeinputs[]{Message} is a commit message to use
3212 # $mergeinputs[]{ReverseParents} if def specifies that parent
3213 # list should be in opposite order
3214 # Such an entry has no Commit or Info. It applies only when found
3215 # in the last entry. (This ugliness is to support making
3216 # identical imports to previous dgit versions.)
3218 my $lastpush_hash = git_get_ref(lrfetchref());
3219 printdebug "previous reference hash=$lastpush_hash\n";
3220 $lastpush_mergeinput = $lastpush_hash && {
3221 Commit => $lastpush_hash,
3222 Info => (__ "dgit suite branch on dgit git server"),
3225 my $lastfetch_hash = git_get_ref(lrref());
3226 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3227 my $lastfetch_mergeinput = $lastfetch_hash && {
3228 Commit => $lastfetch_hash,
3229 Info => (__ "dgit client's archive history view"),
3232 my $dsc_mergeinput = $dsc_hash && {
3233 Commit => $dsc_hash,
3234 Info => (__ "Dgit field in .dsc from archive"),
3238 my $del_lrfetchrefs = sub {
3241 printdebug "del_lrfetchrefs...\n";
3242 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3243 my $objid = $lrfetchrefs_d{$fullrefname};
3244 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3246 $gur ||= new IO::Handle;
3247 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3249 printf $gur "delete %s %s\n", $fullrefname, $objid;
3252 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3256 if (defined $dsc_hash) {
3257 ensure_we_have_orig();
3258 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3259 @mergeinputs = $dsc_mergeinput
3260 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3261 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3263 Git commit in archive is behind the last version allegedly pushed/uploaded.
3264 Commit referred to by archive: %s
3265 Last version pushed with dgit: %s
3268 __ $later_warning_msg or confess "$!";
3269 @mergeinputs = ($lastpush_mergeinput);
3271 # Archive has .dsc which is not a descendant of the last dgit
3272 # push. This can happen if the archive moves .dscs about.
3273 # Just follow its lead.
3274 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3275 progress __ "archive .dsc names newer git commit";
3276 @mergeinputs = ($dsc_mergeinput);
3278 progress __ "archive .dsc names other git commit, fixing up";
3279 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3283 @mergeinputs = generate_commits_from_dsc();
3284 # We have just done an import. Now, our import algorithm might
3285 # have been improved. But even so we do not want to generate
3286 # a new different import of the same package. So if the
3287 # version numbers are the same, just use our existing version.
3288 # If the version numbers are different, the archive has changed
3289 # (perhaps, rewound).
3290 if ($lastfetch_mergeinput &&
3291 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3292 (mergeinfo_version $mergeinputs[0]) )) {
3293 @mergeinputs = ($lastfetch_mergeinput);
3295 } elsif ($lastpush_hash) {
3296 # only in git, not in the archive yet
3297 @mergeinputs = ($lastpush_mergeinput);
3298 print STDERR f_ <<END,
3300 Package not found in the archive, but has allegedly been pushed using dgit.
3303 __ $later_warning_msg or confess "$!";
3305 printdebug "nothing found!\n";
3306 if (defined $skew_warning_vsn) {
3307 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3309 Warning: relevant archive skew detected.
3310 Archive allegedly contains %s
3311 But we were not able to obtain any version from the archive or git.
3315 unshift @end, $del_lrfetchrefs;
3319 if ($lastfetch_hash &&
3321 my $h = $_->{Commit};
3322 $h and is_fast_fwd($lastfetch_hash, $h);
3323 # If true, one of the existing parents of this commit
3324 # is a descendant of the $lastfetch_hash, so we'll
3325 # be ff from that automatically.
3329 push @mergeinputs, $lastfetch_mergeinput;
3332 printdebug "fetch mergeinfos:\n";
3333 foreach my $mi (@mergeinputs) {
3335 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3337 printdebug sprintf " ReverseParents=%d Message=%s",
3338 $mi->{ReverseParents}, $mi->{Message};
3342 my $compat_info= pop @mergeinputs
3343 if $mergeinputs[$#mergeinputs]{Message};
3345 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3348 if (@mergeinputs > 1) {
3350 my $tree_commit = $mergeinputs[0]{Commit};
3352 my $tree = get_tree_of_commit $tree_commit;;
3354 # We use the changelog author of the package in question the
3355 # author of this pseudo-merge. This is (roughly) correct if
3356 # this commit is simply representing aa non-dgit upload.
3357 # (Roughly because it does not record sponsorship - but we
3358 # don't have sponsorship info because that's in the .changes,
3359 # which isn't in the archivw.)
3361 # But, it might be that we are representing archive history
3362 # updates (including in-archive copies). These are not really
3363 # the responsibility of the person who created the .dsc, but
3364 # there is no-one whose name we should better use. (The
3365 # author of the .dsc-named commit is clearly worse.)
3367 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3368 my $author = clogp_authline $useclogp;
3369 my $cversion = getfield $useclogp, 'Version';
3371 my $mcf = dgit_privdir()."/mergecommit";
3372 open MC, ">", $mcf or die "$mcf $!";
3373 print MC <<END or confess "$!";
3377 my @parents = grep { $_->{Commit} } @mergeinputs;
3378 @parents = reverse @parents if $compat_info->{ReverseParents};
3379 print MC <<END or confess "$!" foreach @parents;
3383 print MC <<END or confess "$!";
3389 if (defined $compat_info->{Message}) {
3390 print MC $compat_info->{Message} or confess "$!";
3392 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3393 Record %s (%s) in archive suite %s
3397 my $message_add_info = sub {
3399 my $mversion = mergeinfo_version $mi;
3400 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3404 $message_add_info->($mergeinputs[0]);
3405 print MC __ <<END or confess "$!";
3406 should be treated as descended from
3408 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3411 close MC or confess "$!";
3412 $hash = make_commit $mcf;
3414 $hash = $mergeinputs[0]{Commit};
3416 printdebug "fetch hash=$hash\n";
3419 my ($lasth, $what) = @_;
3420 return unless $lasth;
3421 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3424 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3426 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3428 fetch_from_archive_record_1($hash);
3430 if (defined $skew_warning_vsn) {
3431 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3432 my $gotclogp = commit_getclogp($hash);
3433 my $got_vsn = getfield $gotclogp, 'Version';
3434 printdebug "SKEW CHECK GOT $got_vsn\n";
3435 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3436 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3438 Warning: archive skew detected. Using the available version:
3439 Archive allegedly contains %s
3440 We were able to obtain only %s
3446 if ($lastfetch_hash ne $hash) {
3447 fetch_from_archive_record_2($hash);
3450 lrfetchref_used lrfetchref();
3452 check_gitattrs($hash, __ "fetched source tree");
3454 unshift @end, $del_lrfetchrefs;
3458 sub set_local_git_config ($$) {
3460 runcmd @git, qw(config), $k, $v;
3463 sub setup_mergechangelogs (;$) {
3465 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3467 my $driver = 'dpkg-mergechangelogs';
3468 my $cb = "merge.$driver";
3469 confess unless defined $maindir;
3470 my $attrs = "$maindir_gitcommon/info/attributes";
3471 ensuredir "$maindir_gitcommon/info";
3473 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3474 if (!open ATTRS, "<", $attrs) {
3475 $!==ENOENT or die "$attrs: $!";
3479 next if m{^debian/changelog\s};
3480 print NATTRS $_, "\n" or confess "$!";
3482 ATTRS->error and confess "$!";
3485 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3488 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3489 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3491 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3494 sub setup_useremail (;$) {
3496 return unless $always || access_cfg_bool(1, 'setup-useremail');
3499 my ($k, $envvar) = @_;
3500 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3501 return unless defined $v;
3502 set_local_git_config "user.$k", $v;
3505 $setup->('email', 'DEBEMAIL');
3506 $setup->('name', 'DEBFULLNAME');
3509 sub ensure_setup_existing_tree () {
3510 my $k = "remote.$remotename.skipdefaultupdate";
3511 my $c = git_get_config $k;
3512 return if defined $c;
3513 set_local_git_config $k, 'true';
3516 sub open_main_gitattrs () {
3517 confess 'internal error no maindir' unless defined $maindir;
3518 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3520 or die "open $maindir_gitcommon/info/attributes: $!";
3524 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3526 sub is_gitattrs_setup () {
3529 # 1: gitattributes set up and should be left alone
3531 # 0: there is a dgit-defuse-attrs but it needs fixing
3532 # undef: there is none
3533 my $gai = open_main_gitattrs();
3534 return 0 unless $gai;
3536 next unless m{$gitattrs_ourmacro_re};
3537 return 1 if m{\s-working-tree-encoding\s};
3538 printdebug "is_gitattrs_setup: found old macro\n";
3541 $gai->error and confess "$!";
3542 printdebug "is_gitattrs_setup: found nothing\n";
3546 sub setup_gitattrs (;$) {
3548 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3550 my $already = is_gitattrs_setup();
3553 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3554 not doing further gitattributes setup
3558 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3559 my $af = "$maindir_gitcommon/info/attributes";
3560 ensuredir "$maindir_gitcommon/info";
3562 open GAO, "> $af.new" or confess "$!";
3563 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3567 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3569 my $gai = open_main_gitattrs();
3572 if (m{$gitattrs_ourmacro_re}) {
3573 die unless defined $already;
3577 print GAO $_, "\n" or confess "$!";
3579 $gai->error and confess "$!";
3581 close GAO or confess "$!";
3582 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3585 sub setup_new_tree () {
3586 setup_mergechangelogs();
3591 sub check_gitattrs ($$) {
3592 my ($treeish, $what) = @_;
3594 return if is_gitattrs_setup;
3597 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3599 my $gafl = new IO::File;
3600 open $gafl, "-|", @cmd or confess "$!";
3603 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3605 next unless m{(?:^|/)\.gitattributes$};
3607 # oh dear, found one
3608 print STDERR f_ <<END, $what;
3609 dgit: warning: %s contains .gitattributes
3610 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3615 # tree contains no .gitattributes files
3616 $?=0; $!=0; close $gafl or failedcmd @cmd;
3620 sub multisuite_suite_child ($$$) {
3621 my ($tsuite, $mergeinputs, $fn) = @_;
3622 # in child, sets things up, calls $fn->(), and returns undef
3623 # in parent, returns canonical suite name for $tsuite
3624 my $canonsuitefh = IO::File::new_tmpfile;
3625 my $pid = fork // confess "$!";
3629 $us .= " [$isuite]";
3630 $debugprefix .= " ";
3631 progress f_ "fetching %s...", $tsuite;
3632 canonicalise_suite();
3633 print $canonsuitefh $csuite, "\n" or confess "$!";
3634 close $canonsuitefh or confess "$!";
3638 waitpid $pid,0 == $pid or confess "$!";
3639 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3641 seek $canonsuitefh,0,0 or confess "$!";
3642 local $csuite = <$canonsuitefh>;
3643 confess "$!" unless defined $csuite && chomp $csuite;
3645 printdebug "multisuite $tsuite missing\n";
3648 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3649 push @$mergeinputs, {
3656 sub fork_for_multisuite ($) {
3657 my ($before_fetch_merge) = @_;
3658 # if nothing unusual, just returns ''
3661 # returns 0 to caller in child, to do first of the specified suites
3662 # in child, $csuite is not yet set
3664 # returns 1 to caller in parent, to finish up anything needed after
3665 # in parent, $csuite is set to canonicalised portmanteau
3667 my $org_isuite = $isuite;
3668 my @suites = split /\,/, $isuite;
3669 return '' unless @suites > 1;
3670 printdebug "fork_for_multisuite: @suites\n";
3674 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3676 return 0 unless defined $cbasesuite;
3678 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3679 unless @mergeinputs;
3681 my @csuites = ($cbasesuite);
3683 $before_fetch_merge->();
3685 foreach my $tsuite (@suites[1..$#suites]) {
3686 $tsuite =~ s/^-/$cbasesuite-/;
3687 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3694 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3695 push @csuites, $csubsuite;
3698 foreach my $mi (@mergeinputs) {
3699 my $ref = git_get_ref $mi->{Ref};
3700 die "$mi->{Ref} ?" unless length $ref;
3701 $mi->{Commit} = $ref;
3704 $csuite = join ",", @csuites;
3706 my $previous = git_get_ref lrref;
3708 unshift @mergeinputs, {
3709 Commit => $previous,
3710 Info => (__ "local combined tracking branch"),
3712 "archive seems to have rewound: local tracking branch is ahead!"),
3716 foreach my $ix (0..$#mergeinputs) {
3717 $mergeinputs[$ix]{Index} = $ix;
3720 @mergeinputs = sort {
3721 -version_compare(mergeinfo_version $a,
3722 mergeinfo_version $b) # highest version first
3724 $a->{Index} <=> $b->{Index}; # earliest in spec first
3730 foreach my $mi (@mergeinputs) {
3731 printdebug "multisuite merge check $mi->{Info}\n";
3732 foreach my $previous (@needed) {
3733 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3734 printdebug "multisuite merge un-needed $previous->{Info}\n";
3738 printdebug "multisuite merge this-needed\n";
3739 $mi->{Character} = '+';
3742 $needed[0]{Character} = '*';
3744 my $output = $needed[0]{Commit};
3747 printdebug "multisuite merge nontrivial\n";
3748 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3750 my $commit = "tree $tree\n";
3751 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3752 "Input branches:\n",
3755 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3756 printdebug "multisuite merge include $mi->{Info}\n";
3757 $mi->{Character} //= ' ';
3758 $commit .= "parent $mi->{Commit}\n";
3759 $msg .= sprintf " %s %-25s %s\n",
3761 (mergeinfo_version $mi),
3764 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3765 $msg .= __ "\nKey\n".
3766 " * marks the highest version branch, which choose to use\n".
3767 " + marks each branch which was not already an ancestor\n\n";
3769 "[dgit multi-suite $csuite]\n";
3771 "author $authline\n".
3772 "committer $authline\n\n";
3773 $output = make_commit_text $commit.$msg;
3774 printdebug "multisuite merge generated $output\n";
3777 fetch_from_archive_record_1($output);
3778 fetch_from_archive_record_2($output);
3780 progress f_ "calculated combined tracking suite %s", $csuite;
3785 sub clone_set_head () {
3786 open H, "> .git/HEAD" or confess "$!";
3787 print H "ref: ".lref()."\n" or confess "$!";
3788 close H or confess "$!";
3790 sub clone_finish ($) {
3792 runcmd @git, qw(reset --hard), lrref();
3793 runcmd qw(bash -ec), <<'END';
3795 git ls-tree -r --name-only -z HEAD | \
3796 xargs -0r touch -h -r . --
3798 printdone f_ "ready for work in %s", $dstdir;
3802 # in multisuite, returns twice!
3803 # once in parent after first suite fetched,
3804 # and then again in child after everything is finished
3806 badusage __ "dry run makes no sense with clone" unless act_local();
3808 my $multi_fetched = fork_for_multisuite(sub {
3809 printdebug "multi clone before fetch merge\n";
3813 if ($multi_fetched) {
3814 printdebug "multi clone after fetch merge\n";
3816 clone_finish($dstdir);
3819 printdebug "clone main body\n";
3821 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3825 canonicalise_suite();
3826 my $hasgit = check_for_git();
3828 runcmd @git, qw(init -q);
3832 my $giturl = access_giturl(1);
3833 if (defined $giturl) {
3834 runcmd @git, qw(remote add), 'origin', $giturl;
3837 progress __ "fetching existing git history";
3839 runcmd_ordryrun_local @git, qw(fetch origin);
3841 progress __ "starting new git history";
3843 fetch_from_archive() or no_such_package;
3844 my $vcsgiturl = $dsc->{'Vcs-Git'};
3845 if (length $vcsgiturl) {
3846 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3847 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3849 clone_finish($dstdir);
3853 canonicalise_suite();
3854 if (check_for_git()) {
3857 fetch_from_archive() or no_such_package();
3859 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3860 if (length $vcsgiturl and
3861 (grep { $csuite eq $_ }
3863 cfg 'dgit.vcs-git.suites')) {
3864 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3865 if (defined $current && $current ne $vcsgiturl) {
3866 print STDERR f_ <<END, $csuite;
3867 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3868 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3872 printdone f_ "fetched into %s", lrref();
3876 my $multi_fetched = fork_for_multisuite(sub { });
3877 fetch_one() unless $multi_fetched; # parent
3878 finish 0 if $multi_fetched eq '0'; # child
3883 runcmd_ordryrun_local @git, qw(merge -m),
3884 (f_ "Merge from %s [dgit]", $csuite),
3886 printdone f_ "fetched to %s and merged into HEAD", lrref();
3889 sub check_not_dirty () {
3890 my @forbid = qw(local-options local-patch-header);
3891 @forbid = map { "debian/source/$_" } @forbid;
3892 foreach my $f (@forbid) {
3893 if (stat_exists $f) {
3894 fail f_ "git tree contains %s", $f;
3898 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3899 push @cmd, qw(debian/source/format debian/source/options);
3902 my $bad = cmdoutput @cmd;
3905 "you have uncommitted changes to critical files, cannot continue:\n").
3909 return if $includedirty;
3911 git_check_unmodified();
3914 sub commit_admin ($) {
3917 runcmd_ordryrun_local @git, qw(commit -m), $m;
3920 sub quiltify_nofix_bail ($$) {
3921 my ($headinfo, $xinfo) = @_;
3922 if ($quilt_mode eq 'nofix') {
3924 "quilt fixup required but quilt mode is \`nofix'\n".
3925 "HEAD commit%s differs from tree implied by debian/patches%s",
3930 sub commit_quilty_patch () {
3931 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3933 foreach my $l (split /\n/, $output) {
3934 next unless $l =~ m/\S/;
3935 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3939 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3941 progress __ "nothing quilty to commit, ok.";
3944 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3945 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3946 runcmd_ordryrun_local @git, qw(add -f), @adds;
3947 commit_admin +(__ <<ENDT).<<END
3948 Commit Debian 3.0 (quilt) metadata
3951 [dgit ($our_version) quilt-fixup]
3955 sub get_source_format () {
3957 if (open F, "debian/source/options") {
3961 s/\s+$//; # ignore missing final newline
3963 my ($k, $v) = ($`, $'); #');
3964 $v =~ s/^"(.*)"$/$1/;
3970 F->error and confess "$!";
3973 confess "$!" unless $!==&ENOENT;
3976 if (!open F, "debian/source/format") {
3977 confess "$!" unless $!==&ENOENT;
3981 F->error and confess "$!";
3983 return ($_, \%options);
3986 sub madformat_wantfixup ($) {
3988 return 0 unless $format eq '3.0 (quilt)';
3989 our $quilt_mode_warned;
3990 if ($quilt_mode eq 'nocheck') {
3991 progress f_ "Not doing any fixup of \`%s'".
3992 " due to ----no-quilt-fixup or --quilt=nocheck", $format
3993 unless $quilt_mode_warned++;
3996 progress f_ "Format \`%s', need to check/update patch stack", $format
3997 unless $quilt_mode_warned++;
4001 sub maybe_split_brain_save ($$$) {
4002 my ($headref, $dgitview, $msg) = @_;
4003 # => message fragment "$saved" describing disposition of $dgitview
4004 # (used inside parens, in the English texts)
4005 my $save = $internal_object_save{'dgit-view'};
4006 return f_ "commit id %s", $dgitview unless defined $save;
4007 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4009 "dgit --dgit-view-save $msg HEAD=$headref",
4012 return f_ "and left in %s", $save;
4015 # An "infopair" is a tuple [ $thing, $what ]
4016 # (often $thing is a commit hash; $what is a description)
4018 sub infopair_cond_equal ($$) {
4020 $x->[0] eq $y->[0] or fail <<END;
4021 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4025 sub infopair_lrf_tag_lookup ($$) {
4026 my ($tagnames, $what) = @_;
4027 # $tagname may be an array ref
4028 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4029 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4030 foreach my $tagname (@tagnames) {
4031 my $lrefname = lrfetchrefs."/tags/$tagname";
4032 my $tagobj = $lrfetchrefs_f{$lrefname};
4033 next unless defined $tagobj;
4034 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4035 return [ git_rev_parse($tagobj), $what ];
4037 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4038 Wanted tag %s (%s) on dgit server, but not found
4040 : (f_ <<END, $what, "@tagnames");
4041 Wanted tag %s (one of: %s) on dgit server, but not found
4045 sub infopair_cond_ff ($$) {
4046 my ($anc,$desc) = @_;
4047 is_fast_fwd($anc->[0], $desc->[0]) or
4048 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4049 %s (%s) .. %s (%s) is not fast forward
4053 sub pseudomerge_version_check ($$) {
4054 my ($clogp, $archive_hash) = @_;
4056 my $arch_clogp = commit_getclogp $archive_hash;
4057 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4058 __ 'version currently in archive' ];
4059 if (defined $overwrite_version) {
4060 if (length $overwrite_version) {
4061 infopair_cond_equal([ $overwrite_version,
4062 '--overwrite= version' ],
4065 my $v = $i_arch_v->[0];
4067 "Checking package changelog for archive version %s ...", $v;
4070 my @xa = ("-f$v", "-t$v");
4071 my $vclogp = parsechangelog @xa;
4074 [ (getfield $vclogp, $fn),
4075 (f_ "%s field from dpkg-parsechangelog %s",
4078 my $cv = $gf->('Version');
4079 infopair_cond_equal($i_arch_v, $cv);
4080 $cd = $gf->('Distribution');
4084 $@ =~ s/^dgit: //gm;
4086 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4088 fail f_ <<END, $cd->[1], $cd->[0], $v
4090 Your tree seems to based on earlier (not uploaded) %s.
4092 if $cd->[0] =~ m/UNRELEASED/;
4096 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4100 sub pseudomerge_make_commit ($$$$ $$) {
4101 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4102 $msg_cmd, $msg_msg) = @_;
4103 progress f_ "Declaring that HEAD includes all changes in %s...",
4106 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4107 my $authline = clogp_authline $clogp;
4111 !defined $overwrite_version ? ""
4112 : !length $overwrite_version ? " --overwrite"
4113 : " --overwrite=".$overwrite_version;
4115 # Contributing parent is the first parent - that makes
4116 # git rev-list --first-parent DTRT.
4117 my $pmf = dgit_privdir()."/pseudomerge";
4118 open MC, ">", $pmf or die "$pmf $!";
4119 print MC <<END or confess "$!";
4122 parent $archive_hash
4130 close MC or confess "$!";
4132 return make_commit($pmf);
4135 sub splitbrain_pseudomerge ($$$$) {
4136 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4137 # => $merged_dgitview
4138 printdebug "splitbrain_pseudomerge...\n";
4140 # We: debian/PREVIOUS HEAD($maintview)
4141 # expect: o ----------------- o
4144 # a/d/PREVIOUS $dgitview
4147 # we do: `------------------ o
4151 return $dgitview unless defined $archive_hash;
4152 return $dgitview if deliberately_not_fast_forward();
4154 printdebug "splitbrain_pseudomerge...\n";
4156 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4158 if (!defined $overwrite_version) {
4159 progress __ "Checking that HEAD includes all changes in archive...";
4162 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4164 if (defined $overwrite_version) {
4166 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4167 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4168 __ "maintainer view tag");
4169 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4170 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4171 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4173 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4175 infopair_cond_equal($i_dgit, $i_archive);
4176 infopair_cond_ff($i_dep14, $i_dgit);
4177 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4180 $@ =~ s/^\n//; chomp $@;
4181 print STDERR <<END.(__ <<ENDT);
4184 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4189 my $arch_v = $i_arch_v->[0];
4190 my $r = pseudomerge_make_commit
4191 $clogp, $dgitview, $archive_hash, $i_arch_v,
4192 "dgit --quilt=$quilt_mode",
4193 (defined $overwrite_version
4194 ? f_ "Declare fast forward from %s\n", $arch_v
4195 : f_ "Make fast forward from %s\n", $arch_v);
4197 maybe_split_brain_save $maintview, $r, "pseudomerge";
4199 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4203 sub plain_overwrite_pseudomerge ($$$) {
4204 my ($clogp, $head, $archive_hash) = @_;
4206 printdebug "plain_overwrite_pseudomerge...";
4208 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4210 return $head if is_fast_fwd $archive_hash, $head;
4212 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4214 my $r = pseudomerge_make_commit
4215 $clogp, $head, $archive_hash, $i_arch_v,
4218 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4220 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4224 sub push_parse_changelog ($) {
4227 my $clogp = Dpkg::Control::Hash->new();
4228 $clogp->load($clogpfn) or die;
4230 my $clogpackage = getfield $clogp, 'Source';
4231 $package //= $clogpackage;
4232 fail f_ "-p specified %s but changelog specified %s",
4233 $package, $clogpackage
4234 unless $package eq $clogpackage;
4235 my $cversion = getfield $clogp, 'Version';
4237 if (!$we_are_initiator) {
4238 # rpush initiator can't do this because it doesn't have $isuite yet
4239 my $tag = debiantag_new($cversion, access_nomdistro);
4240 runcmd @git, qw(check-ref-format), $tag;
4243 my $dscfn = dscfn($cversion);
4245 return ($clogp, $cversion, $dscfn);
4248 sub push_parse_dsc ($$$) {
4249 my ($dscfn,$dscfnwhat, $cversion) = @_;
4250 $dsc = parsecontrol($dscfn,$dscfnwhat);
4251 my $dversion = getfield $dsc, 'Version';
4252 my $dscpackage = getfield $dsc, 'Source';
4253 ($dscpackage eq $package && $dversion eq $cversion) or
4254 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4255 $dscfn, $dscpackage, $dversion,
4256 $package, $cversion;
4259 sub push_tagwants ($$$$) {
4260 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4263 TagFn => \&debiantag_new,
4268 if (defined $maintviewhead) {
4270 TagFn => \&debiantag_maintview,
4271 Objid => $maintviewhead,
4272 TfSuffix => '-maintview',
4275 } elsif ($dodep14tag ne 'no') {
4277 TagFn => \&debiantag_maintview,
4279 TfSuffix => '-dgit',
4283 foreach my $tw (@tagwants) {
4284 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4285 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4287 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4291 sub push_mktags ($$ $$ $) {
4293 $changesfile,$changesfilewhat,
4296 die unless $tagwants->[0]{View} eq 'dgit';
4298 my $declaredistro = access_nomdistro();
4299 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4300 $dsc->{$ourdscfield[0]} = join " ",
4301 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4303 $dsc->save("$dscfn.tmp") or confess "$!";
4305 my $changes = parsecontrol($changesfile,$changesfilewhat);
4306 foreach my $field (qw(Source Distribution Version)) {
4307 $changes->{$field} eq $clogp->{$field} or
4308 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4309 $field, $changes->{$field}, $clogp->{$field};
4312 my $cversion = getfield $clogp, 'Version';
4313 my $clogsuite = getfield $clogp, 'Distribution';
4315 # We make the git tag by hand because (a) that makes it easier
4316 # to control the "tagger" (b) we can do remote signing
4317 my $authline = clogp_authline $clogp;
4318 my $delibs = join(" ", "",@deliberatelies);
4322 my $tfn = $tw->{Tfn};
4323 my $head = $tw->{Objid};
4324 my $tag = $tw->{Tag};
4326 open TO, '>', $tfn->('.tmp') or confess "$!";
4327 print TO <<END or confess "$!";
4334 if ($tw->{View} eq 'dgit') {
4335 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4336 %s release %s for %s (%s) [dgit]
4339 print TO <<END or confess "$!";
4340 [dgit distro=$declaredistro$delibs]
4342 foreach my $ref (sort keys %previously) {
4343 print TO <<END or confess "$!";
4344 [dgit previously:$ref=$previously{$ref}]
4347 } elsif ($tw->{View} eq 'maint') {
4348 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4349 %s release %s for %s (%s)
4350 (maintainer view tag generated by dgit --quilt=%s)
4355 confess Dumper($tw)."?";
4358 close TO or confess "$!";
4360 my $tagobjfn = $tfn->('.tmp');
4362 if (!defined $keyid) {
4363 $keyid = access_cfg('keyid','RETURN-UNDEF');
4365 if (!defined $keyid) {
4366 $keyid = getfield $clogp, 'Maintainer';
4368 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4369 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4370 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4371 push @sign_cmd, $tfn->('.tmp');
4372 runcmd_ordryrun @sign_cmd;
4374 $tagobjfn = $tfn->('.signed.tmp');
4375 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4376 $tfn->('.tmp'), $tfn->('.tmp.asc');
4382 my @r = map { $mktag->($_); } @$tagwants;
4386 sub sign_changes ($) {
4387 my ($changesfile) = @_;
4389 my @debsign_cmd = @debsign;
4390 push @debsign_cmd, "-k$keyid" if defined $keyid;
4391 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4392 push @debsign_cmd, $changesfile;
4393 runcmd_ordryrun @debsign_cmd;
4398 printdebug "actually entering push\n";
4400 supplementary_message(__ <<'END');
4401 Push failed, while checking state of the archive.
4402 You can retry the push, after fixing the problem, if you like.
4404 if (check_for_git()) {
4407 my $archive_hash = fetch_from_archive();
4408 if (!$archive_hash) {
4410 fail __ "package appears to be new in this suite;".
4411 " if this is intentional, use --new";
4414 supplementary_message(__ <<'END');
4415 Push failed, while preparing your push.
4416 You can retry the push, after fixing the problem, if you like.
4421 access_giturl(); # check that success is vaguely likely
4422 rpush_handle_protovsn_bothends() if $we_are_initiator;
4424 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4425 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4427 responder_send_file('parsed-changelog', $clogpfn);
4429 my ($clogp, $cversion, $dscfn) =
4430 push_parse_changelog("$clogpfn");
4432 my $dscpath = "$buildproductsdir/$dscfn";
4433 stat_exists $dscpath or
4434 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4437 responder_send_file('dsc', $dscpath);
4439 push_parse_dsc($dscpath, $dscfn, $cversion);
4441 my $format = getfield $dsc, 'Format';
4443 my $symref = git_get_symref();
4444 my $actualhead = git_rev_parse('HEAD');
4446 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4447 if (quiltmode_splitting()) {
4448 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4449 fail f_ <<END, $ffq_prev, $quilt_mode;
4450 Branch is managed by git-debrebase (%s
4451 exists), but quilt mode (%s) implies a split view.
4452 Pass the right --quilt option or adjust your git config.
4453 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4456 runcmd_ordryrun_local @git_debrebase, 'stitch';
4457 $actualhead = git_rev_parse('HEAD');
4460 my $dgithead = $actualhead;
4461 my $maintviewhead = undef;
4463 my $upstreamversion = upstreamversion $clogp->{Version};
4465 if (madformat_wantfixup($format)) {
4466 # user might have not used dgit build, so maybe do this now:
4467 if (do_split_brain()) {
4468 changedir $playground;
4470 ($dgithead, $cachekey) =
4471 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4472 $dgithead or fail f_
4473 "--quilt=%s but no cached dgit view:
4474 perhaps HEAD changed since dgit build[-source] ?",
4477 if (!do_split_brain()) {
4478 # In split brain mode, do not attempt to incorporate dirty
4479 # stuff from the user's working tree. That would be mad.
4480 commit_quilty_patch();
4483 if (do_split_brain()) {
4484 $made_split_brain = 1;
4485 $dgithead = splitbrain_pseudomerge($clogp,
4486 $actualhead, $dgithead,
4488 $maintviewhead = $actualhead;
4490 prep_ud(); # so _only_subdir() works, below
4493 if (defined $overwrite_version && !defined $maintviewhead
4495 $dgithead = plain_overwrite_pseudomerge($clogp,
4503 if ($archive_hash) {
4504 if (is_fast_fwd($archive_hash, $dgithead)) {
4506 } elsif (deliberately_not_fast_forward) {
4509 fail __ "dgit push: HEAD is not a descendant".
4510 " of the archive's version.\n".
4511 "To overwrite the archive's contents,".
4512 " pass --overwrite[=VERSION].\n".
4513 "To rewind history, if permitted by the archive,".
4514 " use --deliberately-not-fast-forward.";
4518 confess unless !!$made_split_brain == do_split_brain();
4520 changedir $playground;
4521 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4522 runcmd qw(dpkg-source -x --),
4523 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4524 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4525 check_for_vendor_patches() if madformat($dsc->{format});
4527 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4528 debugcmd "+",@diffcmd;
4530 my $r = system @diffcmd;
4533 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4534 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4537 my $raw = cmdoutput @git,
4538 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4540 foreach (split /\0/, $raw) {
4541 if (defined $changed) {
4542 push @mode_changes, "$changed: $_\n" if $changed;
4545 } elsif (m/^:0+ 0+ /) {
4547 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4548 $changed = "Mode change from $1 to $2"
4553 if (@mode_changes) {
4554 fail +(f_ <<ENDT, $dscfn).<<END
4555 HEAD specifies a different tree to %s:
4559 .(join '', @mode_changes)
4560 .(f_ <<ENDT, $tree, $referent);
4561 There is a problem with your source tree (see dgit(7) for some hints).
4562 To see a full diff, run git diff %s %s
4566 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4567 HEAD specifies a different tree to %s:
4571 Perhaps you forgot to build. Or perhaps there is a problem with your
4572 source tree (see dgit(7) for some hints). To see a full diff, run
4579 if (!$changesfile) {
4580 my $pat = changespat $cversion;
4581 my @cs = glob "$buildproductsdir/$pat";
4582 fail f_ "failed to find unique changes file".
4583 " (looked for %s in %s);".
4584 " perhaps you need to use dgit -C",
4585 $pat, $buildproductsdir
4587 ($changesfile) = @cs;
4589 $changesfile = "$buildproductsdir/$changesfile";
4592 # Check that changes and .dsc agree enough
4593 $changesfile =~ m{[^/]*$};
4594 my $changes = parsecontrol($changesfile,$&);
4595 files_compare_inputs($dsc, $changes)
4596 unless forceing [qw(dsc-changes-mismatch)];
4598 # Check whether this is a source only upload
4599 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4600 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4601 if ($sourceonlypolicy eq 'ok') {
4602 } elsif ($sourceonlypolicy eq 'always') {
4603 forceable_fail [qw(uploading-binaries)],
4604 __ "uploading binaries, although distro policy is source only"
4606 } elsif ($sourceonlypolicy eq 'never') {
4607 forceable_fail [qw(uploading-source-only)],
4608 __ "source-only upload, although distro policy requires .debs"
4610 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4611 forceable_fail [qw(uploading-source-only)],
4612 f_ "source-only upload, even though package is entirely NEW\n".
4613 "(this is contrary to policy in %s)",
4617 && !(archive_query('package_not_wholly_new', $package) // 1);
4619 badcfg f_ "unknown source-only-uploads policy \`%s'",
4623 # Perhaps adjust .dsc to contain right set of origs
4624 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4626 unless forceing [qw(changes-origs-exactly)];
4628 # Checks complete, we're going to try and go ahead:
4630 responder_send_file('changes',$changesfile);
4631 responder_send_command("param head $dgithead");
4632 responder_send_command("param csuite $csuite");
4633 responder_send_command("param isuite $isuite");
4634 responder_send_command("param tagformat new"); # needed in $protovsn==4
4635 if (defined $maintviewhead) {
4636 responder_send_command("param maint-view $maintviewhead");
4639 # Perhaps send buildinfo(s) for signing
4640 my $changes_files = getfield $changes, 'Files';
4641 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4642 foreach my $bi (@buildinfos) {
4643 responder_send_command("param buildinfo-filename $bi");
4644 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4647 if (deliberately_not_fast_forward) {
4648 git_for_each_ref(lrfetchrefs, sub {
4649 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4650 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4651 responder_send_command("previously $rrefname=$objid");
4652 $previously{$rrefname} = $objid;
4656 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4657 dgit_privdir()."/tag");
4660 supplementary_message(__ <<'END');
4661 Push failed, while signing the tag.
4662 You can retry the push, after fixing the problem, if you like.
4664 # If we manage to sign but fail to record it anywhere, it's fine.
4665 if ($we_are_responder) {
4666 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4667 responder_receive_files('signed-tag', @tagobjfns);
4669 @tagobjfns = push_mktags($clogp,$dscpath,
4670 $changesfile,$changesfile,
4673 supplementary_message(__ <<'END');
4674 Push failed, *after* signing the tag.
4675 If you want to try again, you should use a new version number.
4678 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4680 foreach my $tw (@tagwants) {
4681 my $tag = $tw->{Tag};
4682 my $tagobjfn = $tw->{TagObjFn};
4684 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4685 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4686 runcmd_ordryrun_local
4687 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4690 supplementary_message(__ <<'END');
4691 Push failed, while updating the remote git repository - see messages above.
4692 If you want to try again, you should use a new version number.
4694 if (!check_for_git()) {
4695 create_remote_git_repo();
4698 my @pushrefs = $forceflag.$dgithead.":".rrref();
4699 foreach my $tw (@tagwants) {
4700 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4703 runcmd_ordryrun @git,
4704 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4705 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4707 supplementary_message(__ <<'END');
4708 Push failed, while obtaining signatures on the .changes and .dsc.
4709 If it was just that the signature failed, you may try again by using
4710 debsign by hand to sign the changes file (see the command dgit tried,
4711 above), and then dput that changes file to complete the upload.
4712 If you need to change the package, you must use a new version number.
4714 if ($we_are_responder) {
4715 my $dryrunsuffix = act_local() ? "" : ".tmp";
4716 my @rfiles = ($dscpath, $changesfile);
4717 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4718 responder_receive_files('signed-dsc-changes',
4719 map { "$_$dryrunsuffix" } @rfiles);
4722 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4724 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4726 sign_changes $changesfile;
4729 supplementary_message(f_ <<END, $changesfile);
4730 Push failed, while uploading package(s) to the archive server.
4731 You can retry the upload of exactly these same files with dput of:
4733 If that .changes file is broken, you will need to use a new version
4734 number for your next attempt at the upload.
4736 my $host = access_cfg('upload-host','RETURN-UNDEF');
4737 my @hostarg = defined($host) ? ($host,) : ();
4738 runcmd_ordryrun @dput, @hostarg, $changesfile;
4739 printdone f_ "pushed and uploaded %s", $cversion;
4741 supplementary_message('');
4742 responder_send_command("complete");
4746 not_necessarily_a_tree();
4751 badusage __ "-p is not allowed with clone; specify as argument instead"
4752 if defined $package;
4755 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4756 ($package,$isuite) = @ARGV;
4757 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4758 ($package,$dstdir) = @ARGV;
4759 } elsif (@ARGV==3) {
4760 ($package,$isuite,$dstdir) = @ARGV;
4762 badusage __ "incorrect arguments to dgit clone";
4766 $dstdir ||= "$package";
4767 if (stat_exists $dstdir) {
4768 fail f_ "%s already exists", $dstdir;
4772 if ($rmonerror && !$dryrun_level) {
4773 $cwd_remove= getcwd();
4775 return unless defined $cwd_remove;
4776 if (!chdir "$cwd_remove") {
4777 return if $!==&ENOENT;
4778 confess "chdir $cwd_remove: $!";
4780 printdebug "clone rmonerror removing $dstdir\n";
4782 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4783 } elsif (grep { $! == $_ }
4784 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4786 print STDERR f_ "check whether to remove %s: %s\n",
4793 $cwd_remove = undef;
4796 sub branchsuite () {
4797 my $branch = git_get_symref();
4798 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4805 sub package_from_d_control () {
4806 if (!defined $package) {
4807 my $sourcep = parsecontrol('debian/control','debian/control');
4808 $package = getfield $sourcep, 'Source';
4812 sub fetchpullargs () {
4813 package_from_d_control();
4815 $isuite = branchsuite();
4817 my $clogp = parsechangelog();
4818 my $clogsuite = getfield $clogp, 'Distribution';
4819 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4821 } elsif (@ARGV==1) {
4824 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4838 determine_whether_split_brain();
4839 if (do_split_brain()) {
4840 my ($format, $fopts) = get_source_format();
4841 madformat($format) and fail f_ <<END, $quilt_mode
4842 dgit pull not yet supported in split view mode (--quilt=%s)
4850 package_from_d_control();
4851 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4855 foreach my $canon (qw(0 1)) {
4860 canonicalise_suite();
4862 if (length git_get_ref lref()) {
4863 # local branch already exists, yay
4866 if (!length git_get_ref lrref()) {
4874 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4877 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4878 "dgit checkout $isuite";
4879 runcmd (@git, qw(checkout), lbranch());
4882 sub cmd_update_vcs_git () {
4884 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4885 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4887 ($specsuite) = (@ARGV);
4892 if ($ARGV[0] eq '-') {
4894 } elsif ($ARGV[0] eq '-') {
4899 package_from_d_control();
4901 if ($specsuite eq '.') {
4902 $ctrl = parsecontrol 'debian/control', 'debian/control';
4904 $isuite = $specsuite;
4908 my $url = getfield $ctrl, 'Vcs-Git';
4911 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4912 if (!defined $orgurl) {
4913 print STDERR f_ "setting up vcs-git: %s\n", $url;
4914 @cmd = (@git, qw(remote add vcs-git), $url);
4915 } elsif ($orgurl eq $url) {
4916 print STDERR f_ "vcs git already configured: %s\n", $url;
4918 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4919 @cmd = (@git, qw(remote set-url vcs-git), $url);
4921 runcmd_ordryrun_local @cmd;
4923 print f_ "fetching (%s)\n", "@ARGV";
4924 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4930 build_or_push_prep_early();
4932 build_or_push_prep_modes();
4936 } elsif (@ARGV==1) {
4937 ($specsuite) = (@ARGV);
4939 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4942 local ($package) = $existing_package; # this is a hack
4943 canonicalise_suite();
4945 canonicalise_suite();
4947 if (defined $specsuite &&
4948 $specsuite ne $isuite &&
4949 $specsuite ne $csuite) {
4950 fail f_ "dgit %s: changelog specifies %s (%s)".
4951 " but command line specifies %s",
4952 $subcommand, $isuite, $csuite, $specsuite;
4961 #---------- remote commands' implementation ----------
4963 sub pre_remote_push_build_host {
4964 my ($nrargs) = shift @ARGV;
4965 my (@rargs) = @ARGV[0..$nrargs-1];
4966 @ARGV = @ARGV[$nrargs..$#ARGV];
4968 my ($dir,$vsnwant) = @rargs;
4969 # vsnwant is a comma-separated list; we report which we have
4970 # chosen in our ready response (so other end can tell if they
4973 $we_are_responder = 1;
4974 $us .= " (build host)";
4976 open PI, "<&STDIN" or confess "$!";
4977 open STDIN, "/dev/null" or confess "$!";
4978 open PO, ">&STDOUT" or confess "$!";
4980 open STDOUT, ">&STDERR" or confess "$!";
4984 ($protovsn) = grep {
4985 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4986 } @rpushprotovsn_support;
4988 fail f_ "build host has dgit rpush protocol versions %s".
4989 " but invocation host has %s",
4990 (join ",", @rpushprotovsn_support), $vsnwant
4991 unless defined $protovsn;
4995 sub cmd_remote_push_build_host {
4996 responder_send_command("dgit-remote-push-ready $protovsn");
5000 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5001 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5002 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5003 # a good error message)
5005 sub rpush_handle_protovsn_bothends () {
5012 my $report = i_child_report();
5013 if (defined $report) {
5014 printdebug "($report)\n";
5015 } elsif ($i_child_pid) {
5016 printdebug "(killing build host child $i_child_pid)\n";
5017 kill 15, $i_child_pid;
5019 if (defined $i_tmp && !defined $initiator_tempdir) {
5021 eval { rmtree $i_tmp; };
5026 return unless forkcheck_mainprocess();
5031 my ($base,$selector,@args) = @_;
5032 $selector =~ s/\-/_/g;
5033 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5037 not_necessarily_a_tree();
5042 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5050 push @rargs, join ",", @rpushprotovsn_support;
5053 push @rdgit, @ropts;
5054 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5056 my @cmd = (@ssh, $host, shellquote @rdgit);
5059 $we_are_initiator=1;
5061 if (defined $initiator_tempdir) {
5062 rmtree $initiator_tempdir;
5063 mkdir $initiator_tempdir, 0700
5064 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5065 $i_tmp = $initiator_tempdir;
5069 $i_child_pid = open2(\*RO, \*RI, @cmd);
5071 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5072 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5075 my ($icmd,$iargs) = initiator_expect {
5076 m/^(\S+)(?: (.*))?$/;
5079 i_method "i_resp", $icmd, $iargs;
5083 sub i_resp_progress ($) {
5085 my $msg = protocol_read_bytes \*RO, $rhs;
5089 sub i_resp_supplementary_message ($) {
5091 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5094 sub i_resp_complete {
5095 my $pid = $i_child_pid;
5096 $i_child_pid = undef; # prevents killing some other process with same pid
5097 printdebug "waiting for build host child $pid...\n";
5098 my $got = waitpid $pid, 0;
5099 confess "$!" unless $got == $pid;
5100 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5103 printdebug __ "all done\n";
5107 sub i_resp_file ($) {
5109 my $localname = i_method "i_localname", $keyword;
5110 my $localpath = "$i_tmp/$localname";
5111 stat_exists $localpath and
5112 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5113 protocol_receive_file \*RO, $localpath;
5114 i_method "i_file", $keyword;
5119 sub i_resp_param ($) {
5120 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5124 sub i_resp_previously ($) {
5125 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5126 or badproto \*RO, __ "bad previously spec";
5127 my $r = system qw(git check-ref-format), $1;
5128 confess "bad previously ref spec ($r)" if $r;
5129 $previously{$1} = $2;
5134 sub i_resp_want ($) {
5136 die "$keyword ?" if $i_wanted{$keyword}++;
5138 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5139 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5140 die unless $isuite =~ m/^$suite_re$/;
5143 rpush_handle_protovsn_bothends();
5145 my @localpaths = i_method "i_want", $keyword;
5146 printdebug "[[ $keyword @localpaths\n";
5147 foreach my $localpath (@localpaths) {
5148 protocol_send_file \*RI, $localpath;
5150 print RI "files-end\n" or confess "$!";
5153 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5155 sub i_localname_parsed_changelog {
5156 return "remote-changelog.822";
5158 sub i_file_parsed_changelog {
5159 ($i_clogp, $i_version, $i_dscfn) =
5160 push_parse_changelog "$i_tmp/remote-changelog.822";
5161 die if $i_dscfn =~ m#/|^\W#;
5164 sub i_localname_dsc {
5165 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5170 sub i_localname_buildinfo ($) {
5171 my $bi = $i_param{'buildinfo-filename'};
5172 defined $bi or badproto \*RO, "buildinfo before filename";
5173 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5174 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5175 or badproto \*RO, "improper buildinfo filename";
5178 sub i_file_buildinfo {
5179 my $bi = $i_param{'buildinfo-filename'};
5180 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5181 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5182 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5183 files_compare_inputs($bd, $ch);
5184 (getfield $bd, $_) eq (getfield $ch, $_) or
5185 fail f_ "buildinfo mismatch in field %s", $_
5186 foreach qw(Source Version);
5187 !defined $bd->{$_} or
5188 fail f_ "buildinfo contains forbidden field %s", $_
5189 foreach qw(Changes Changed-by Distribution);
5191 push @i_buildinfos, $bi;
5192 delete $i_param{'buildinfo-filename'};
5195 sub i_localname_changes {
5196 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5197 $i_changesfn = $i_dscfn;
5198 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5199 return $i_changesfn;
5201 sub i_file_changes { }
5203 sub i_want_signed_tag {
5204 printdebug Dumper(\%i_param, $i_dscfn);
5205 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5206 && defined $i_param{'csuite'}
5207 or badproto \*RO, "premature desire for signed-tag";
5208 my $head = $i_param{'head'};
5209 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5211 my $maintview = $i_param{'maint-view'};
5212 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5214 if ($protovsn == 4) {
5215 my $p = $i_param{'tagformat'} // '<undef>';
5217 or badproto \*RO, "tag format mismatch: $p vs. new";
5220 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5222 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5224 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5227 push_mktags $i_clogp, $i_dscfn,
5228 $i_changesfn, (__ 'remote changes file'),
5232 sub i_want_signed_dsc_changes {
5233 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5234 sign_changes $i_changesfn;
5235 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5238 #---------- building etc. ----------
5244 #----- `3.0 (quilt)' handling -----
5246 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5248 sub quiltify_dpkg_commit ($$$;$) {
5249 my ($patchname,$author,$msg, $xinfo) = @_;
5252 mkpath '.git/dgit'; # we are in playtree
5253 my $descfn = ".git/dgit/quilt-description.tmp";
5254 open O, '>', $descfn or confess "$descfn: $!";
5255 $msg =~ s/\n+/\n\n/;
5256 print O <<END or confess "$!";
5258 ${xinfo}Subject: $msg
5262 close O or confess "$!";
5265 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5266 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5267 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5268 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5272 sub quiltify_trees_differ ($$;$$$) {
5273 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5274 # returns true iff the two tree objects differ other than in debian/
5275 # with $finegrained,
5276 # returns bitmask 01 - differ in upstream files except .gitignore
5277 # 02 - differ in .gitignore
5278 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5279 # is set for each modified .gitignore filename $fn
5280 # if $unrepres is defined, array ref to which is appeneded
5281 # a list of unrepresentable changes (removals of upstream files
5284 my @cmd = (@git, qw(diff-tree -z --no-renames));
5285 push @cmd, qw(--name-only) unless $unrepres;
5286 push @cmd, qw(-r) if $finegrained || $unrepres;
5288 my $diffs= cmdoutput @cmd;
5291 foreach my $f (split /\0/, $diffs) {
5292 if ($unrepres && !@lmodes) {
5293 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5296 my ($oldmode,$newmode) = @lmodes;
5299 next if $f =~ m#^debian(?:/.*)?$#s;
5303 die __ "not a plain file or symlink\n"
5304 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5305 $oldmode =~ m/^(?:10|12)\d{4}$/;
5306 if ($oldmode =~ m/[^0]/ &&
5307 $newmode =~ m/[^0]/) {
5308 # both old and new files exist
5309 die __ "mode or type changed\n" if $oldmode ne $newmode;
5310 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5311 } elsif ($oldmode =~ m/[^0]/) {
5313 die __ "deletion of symlink\n"
5314 unless $oldmode =~ m/^10/;
5317 die __ "creation with non-default mode\n"
5318 unless $newmode =~ m/^100644$/ or
5319 $newmode =~ m/^120000$/;
5323 local $/="\n"; chomp $@;
5324 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5328 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5329 $r |= $isignore ? 02 : 01;
5330 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5332 printdebug "quiltify_trees_differ $x $y => $r\n";
5336 sub quiltify_tree_sentinelfiles ($) {
5337 # lists the `sentinel' files present in the tree
5339 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5340 qw(-- debian/rules debian/control);
5345 sub quiltify_splitting ($$$$$$$) {
5346 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5347 $editedignores, $cachekey) = @_;
5348 my $gitignore_special = 1;
5349 if ($quilt_mode !~ m/gbp|dpm/) {
5350 # treat .gitignore just like any other upstream file
5351 $diffbits = { %$diffbits };
5352 $_ = !!$_ foreach values %$diffbits;
5353 $gitignore_special = 0;
5355 # We would like any commits we generate to be reproducible
5356 my @authline = clogp_authline($clogp);
5357 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5358 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5359 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5360 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5361 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5362 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5364 confess unless do_split_brain();
5366 my $fulldiffhint = sub {
5368 my $cmd = "git diff $x $y -- :/ ':!debian'";
5369 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5370 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5374 if ($quilt_mode =~ m/gbp|unapplied/ &&
5375 ($diffbits->{O2H} & 01)) {
5377 "--quilt=%s specified, implying patches-unapplied git tree\n".
5378 " but git tree differs from orig in upstream files.",
5380 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5381 if (!stat_exists "debian/patches") {
5383 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5387 if ($quilt_mode =~ m/dpm/ &&
5388 ($diffbits->{H2A} & 01)) {
5389 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5390 --quilt=%s specified, implying patches-applied git tree
5391 but git tree differs from result of applying debian/patches to upstream
5394 if ($quilt_mode =~ m/gbp|unapplied/ &&
5395 ($diffbits->{O2A} & 01)) { # some patches
5396 progress __ "dgit view: creating patches-applied version using gbp pq";
5397 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5398 # gbp pq import creates a fresh branch; push back to dgit-view
5399 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5400 runcmd @git, qw(checkout -q dgit-view);
5402 if ($quilt_mode =~ m/gbp|dpm/ &&
5403 ($diffbits->{O2A} & 02)) {
5404 fail f_ <<END, $quilt_mode;
5405 --quilt=%s specified, implying that HEAD is for use with a
5406 tool which does not create patches for changes to upstream
5407 .gitignores: but, such patches exist in debian/patches.
5410 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5411 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5413 "dgit view: creating patch to represent .gitignore changes";
5414 ensuredir "debian/patches";
5415 my $gipatch = "debian/patches/auto-gitignore";
5416 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5417 stat GIPATCH or confess "$gipatch: $!";
5418 fail f_ "%s already exists; but want to create it".
5419 " to record .gitignore changes",
5422 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5423 Subject: Update .gitignore from Debian packaging branch
5425 The Debian packaging git branch contains these updates to the upstream
5426 .gitignore file(s). This patch is autogenerated, to provide these
5427 updates to users of the official Debian archive view of the package.
5430 [dgit ($our_version) update-gitignore]
5433 close GIPATCH or die "$gipatch: $!";
5434 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5435 $unapplied, $headref, "--", sort keys %$editedignores;
5436 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5437 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5439 defined read SERIES, $newline, 1 or confess "$!";
5440 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5441 print SERIES "auto-gitignore\n" or confess "$!";
5442 close SERIES or die $!;
5443 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5444 commit_admin +(__ <<END).<<ENDU
5445 Commit patch to update .gitignore
5448 [dgit ($our_version) update-gitignore-quilt-fixup]
5453 sub quiltify ($$$$) {
5454 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5456 # Quilt patchification algorithm
5458 # We search backwards through the history of the main tree's HEAD
5459 # (T) looking for a start commit S whose tree object is identical
5460 # to to the patch tip tree (ie the tree corresponding to the
5461 # current dpkg-committed patch series). For these purposes
5462 # `identical' disregards anything in debian/ - this wrinkle is
5463 # necessary because dpkg-source treates debian/ specially.
5465 # We can only traverse edges where at most one of the ancestors'
5466 # trees differs (in changes outside in debian/). And we cannot
5467 # handle edges which change .pc/ or debian/patches. To avoid
5468 # going down a rathole we avoid traversing edges which introduce
5469 # debian/rules or debian/control. And we set a limit on the
5470 # number of edges we are willing to look at.
5472 # If we succeed, we walk forwards again. For each traversed edge
5473 # PC (with P parent, C child) (starting with P=S and ending with
5474 # C=T) to we do this:
5476 # - dpkg-source --commit with a patch name and message derived from C
5477 # After traversing PT, we git commit the changes which
5478 # should be contained within debian/patches.
5480 # The search for the path S..T is breadth-first. We maintain a
5481 # todo list containing search nodes. A search node identifies a
5482 # commit, and looks something like this:
5484 # Commit => $git_commit_id,
5485 # Child => $c, # or undef if P=T
5486 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5487 # Nontrivial => true iff $p..$c has relevant changes
5494 my %considered; # saves being exponential on some weird graphs
5496 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5499 my ($search,$whynot) = @_;
5500 printdebug " search NOT $search->{Commit} $whynot\n";
5501 $search->{Whynot} = $whynot;
5502 push @nots, $search;
5503 no warnings qw(exiting);
5512 my $c = shift @todo;
5513 next if $considered{$c->{Commit}}++;
5515 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5517 printdebug "quiltify investigate $c->{Commit}\n";
5520 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5521 printdebug " search finished hooray!\n";
5526 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5527 if ($quilt_mode eq 'smash') {
5528 printdebug " search quitting smash\n";
5532 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5533 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5534 if $c_sentinels ne $t_sentinels;
5536 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5537 $commitdata =~ m/\n\n/;
5539 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5540 @parents = map { { Commit => $_, Child => $c } } @parents;
5542 $not->($c, __ "root commit") if !@parents;
5544 foreach my $p (@parents) {
5545 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5547 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5548 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5551 foreach my $p (@parents) {
5552 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5554 my @cmd= (@git, qw(diff-tree -r --name-only),
5555 $p->{Commit},$c->{Commit},
5556 qw(-- debian/patches .pc debian/source/format));
5557 my $patchstackchange = cmdoutput @cmd;
5558 if (length $patchstackchange) {
5559 $patchstackchange =~ s/\n/,/g;
5560 $not->($p, f_ "changed %s", $patchstackchange);
5563 printdebug " search queue P=$p->{Commit} ",
5564 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5570 printdebug "quiltify want to smash\n";
5573 my $x = $_[0]{Commit};
5574 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5577 if ($quilt_mode eq 'linear') {
5579 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5581 my $all_gdr = !!@nots;
5582 foreach my $notp (@nots) {
5583 my $c = $notp->{Child};
5584 my $cprange = $abbrev->($notp);
5585 $cprange .= "..".$abbrev->($c) if $c;
5586 print STDERR f_ "%s: %s: %s\n",
5587 $us, $cprange, $notp->{Whynot};
5588 $all_gdr &&= $notp->{Child} &&
5589 (git_cat_file $notp->{Child}{Commit}, 'commit')
5590 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5594 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5596 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5598 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5599 } elsif ($quilt_mode eq 'smash') {
5600 } elsif ($quilt_mode eq 'auto') {
5601 progress __ "quilt fixup cannot be linear, smashing...";
5603 confess "$quilt_mode ?";
5606 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5607 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5609 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5611 quiltify_dpkg_commit "auto-$version-$target-$time",
5612 (getfield $clogp, 'Maintainer'),
5613 (f_ "Automatically generated patch (%s)\n".
5614 "Last (up to) %s git changes, FYI:\n\n",
5615 $clogp->{Version}, $ncommits).
5620 progress __ "quiltify linearisation planning successful, executing...";
5622 for (my $p = $sref_S;
5623 my $c = $p->{Child};
5625 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5626 next unless $p->{Nontrivial};
5628 my $cc = $c->{Commit};
5630 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5631 $commitdata =~ m/\n\n/ or die "$c ?";
5634 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5637 my $commitdate = cmdoutput
5638 @git, qw(log -n1 --pretty=format:%aD), $cc;
5640 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5642 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5649 my $gbp_check_suitable = sub {
5654 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5655 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5656 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5657 die __ "is series file\n" if m{$series_filename_re}o;
5658 die __ "too long\n" if length > 200;
5660 return $_ unless $@;
5662 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5667 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5669 (\S+) \s* \n //ixm) {
5670 $patchname = $gbp_check_suitable->($1, 'Name');
5672 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5674 (\S+) \s* \n //ixm) {
5675 $patchdir = $gbp_check_suitable->($1, 'Topic');
5680 if (!defined $patchname) {
5681 $patchname = $title;
5682 $patchname =~ s/[.:]$//;
5685 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5686 my $translitname = $converter->convert($patchname);
5687 die unless defined $translitname;
5688 $patchname = $translitname;
5691 +(f_ "dgit: patch title transliteration error: %s", $@)
5693 $patchname =~ y/ A-Z/-a-z/;
5694 $patchname =~ y/-a-z0-9_.+=~//cd;
5695 $patchname =~ s/^\W/x-$&/;
5696 $patchname = substr($patchname,0,40);
5697 $patchname .= ".patch";
5699 if (!defined $patchdir) {
5702 if (length $patchdir) {
5703 $patchname = "$patchdir/$patchname";
5705 if ($patchname =~ m{^(.*)/}) {
5706 mkpath "debian/patches/$1";
5711 stat "debian/patches/$patchname$index";
5713 $!==ENOENT or confess "$patchname$index $!";
5715 runcmd @git, qw(checkout -q), $cc;
5717 # We use the tip's changelog so that dpkg-source doesn't
5718 # produce complaining messages from dpkg-parsechangelog. None
5719 # of the information dpkg-source gets from the changelog is
5720 # actually relevant - it gets put into the original message
5721 # which dpkg-source provides our stunt editor, and then
5723 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5725 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5726 "Date: $commitdate\n".
5727 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5729 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5733 sub build_maybe_quilt_fixup () {
5734 my ($format,$fopts) = get_source_format;
5735 return unless madformat_wantfixup $format;
5738 check_for_vendor_patches();
5740 my $clogp = parsechangelog();
5741 my $headref = git_rev_parse('HEAD');
5742 my $symref = git_get_symref();
5743 my $upstreamversion = upstreamversion $version;
5746 changedir $playground;
5748 my $splitbrain_cachekey;
5750 if (do_split_brain()) {
5752 ($cachehit, $splitbrain_cachekey) =
5753 quilt_check_splitbrain_cache($headref, $upstreamversion);
5760 unpack_playtree_need_cd_work($headref);
5761 if (do_split_brain()) {
5762 runcmd @git, qw(checkout -q -b dgit-view);
5763 # so long as work is not deleted, its current branch will
5764 # remain dgit-view, rather than master, so subsequent calls to
5765 # unpack_playtree_need_cd_work
5766 # will DTRT, resetting dgit-view.
5767 confess if $made_split_brain;
5768 $made_split_brain = 1;
5772 if ($fopts->{'single-debian-patch'}) {
5774 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5776 if quiltmode_splitting();
5777 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5779 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5780 $splitbrain_cachekey);
5783 if (do_split_brain()) {
5784 my $dgitview = git_rev_parse 'HEAD';
5787 reflog_cache_insert "refs/$splitbraincache",
5788 $splitbrain_cachekey, $dgitview;
5790 changedir "$playground/work";
5792 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5793 progress f_ "dgit view: created (%s)", $saved;
5797 runcmd_ordryrun_local
5798 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5801 sub build_check_quilt_splitbrain () {
5802 build_maybe_quilt_fixup();
5805 sub unpack_playtree_need_cd_work ($) {
5808 # prep_ud() must have been called already.
5809 if (!chdir "work") {
5810 # Check in the filesystem because sometimes we run prep_ud
5811 # in between multiple calls to unpack_playtree_need_cd_work.
5812 confess "$!" unless $!==ENOENT;
5813 mkdir "work" or confess "$!";
5815 mktree_in_ud_here();
5817 runcmd @git, qw(reset -q --hard), $headref;
5820 sub unpack_playtree_linkorigs ($$) {
5821 my ($upstreamversion, $fn) = @_;
5822 # calls $fn->($leafname);
5824 my $bpd_abs = bpd_abs();
5826 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5828 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5829 while ($!=0, defined(my $leaf = readdir QFD)) {
5830 my $f = bpd_abs()."/".$leaf;
5832 local ($debuglevel) = $debuglevel-1;
5833 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5835 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5836 printdebug "QF linkorigs $leaf, $f Y\n";
5837 link_ltarget $f, $leaf or die "$leaf $!";
5840 die "$buildproductsdir: $!" if $!;
5844 sub quilt_fixup_delete_pc () {
5845 runcmd @git, qw(rm -rqf .pc);
5846 commit_admin +(__ <<END).<<ENDU
5847 Commit removal of .pc (quilt series tracking data)
5850 [dgit ($our_version) upgrade quilt-remove-pc]
5854 sub quilt_fixup_singlepatch ($$$) {
5855 my ($clogp, $headref, $upstreamversion) = @_;
5857 progress __ "starting quiltify (single-debian-patch)";
5859 # dpkg-source --commit generates new patches even if
5860 # single-debian-patch is in debian/source/options. In order to
5861 # get it to generate debian/patches/debian-changes, it is
5862 # necessary to build the source package.
5864 unpack_playtree_linkorigs($upstreamversion, sub { });
5865 unpack_playtree_need_cd_work($headref);
5867 rmtree("debian/patches");
5869 runcmd @dpkgsource, qw(-b .);
5871 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5872 rename srcfn("$upstreamversion", "/debian/patches"),
5873 "work/debian/patches"
5875 or confess "install d/patches: $!";
5878 commit_quilty_patch();
5881 sub quilt_need_fake_dsc ($) {
5882 # cwd should be playground
5883 my ($upstreamversion) = @_;
5885 return if stat_exists "fake.dsc";
5886 # ^ OK to test this as a sentinel because if we created it
5887 # we must either have done the rest too, or crashed.
5889 my $fakeversion="$upstreamversion-~~DGITFAKE";
5891 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5892 print $fakedsc <<END or confess "$!";
5895 Version: $fakeversion
5899 my $dscaddfile=sub {
5902 my $md = new Digest::MD5;
5904 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5905 stat $fh or confess "$!";
5909 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5912 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5914 my @files=qw(debian/source/format debian/rules
5915 debian/control debian/changelog);
5916 foreach my $maybe (qw(debian/patches debian/source/options
5917 debian/tests/control)) {
5918 next unless stat_exists "$maindir/$maybe";
5919 push @files, $maybe;
5922 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5923 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5925 $dscaddfile->($debtar);
5926 close $fakedsc or confess "$!";
5929 sub quilt_fakedsc2unapplied ($$) {
5930 my ($headref, $upstreamversion) = @_;
5931 # must be run in the playground
5932 # quilt_need_fake_dsc must have been called
5934 quilt_need_fake_dsc($upstreamversion);
5936 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5938 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5939 rename $fakexdir, "fake" or die "$fakexdir $!";
5943 remove_stray_gits(__ "source package");
5944 mktree_in_ud_here();
5948 rmtree 'debian'; # git checkout commitish paths does not delete!
5949 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5950 my $unapplied=git_add_write_tree();
5951 printdebug "fake orig tree object $unapplied\n";
5955 sub quilt_check_splitbrain_cache ($$) {
5956 my ($headref, $upstreamversion) = @_;
5957 # Called only if we are in (potentially) split brain mode.
5958 # Called in playground.
5959 # Computes the cache key and looks in the cache.
5960 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5962 quilt_need_fake_dsc($upstreamversion);
5964 my $splitbrain_cachekey;
5967 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5969 # we look in the reflog of dgit-intern/quilt-cache
5970 # we look for an entry whose message is the key for the cache lookup
5971 my @cachekey = (qw(dgit), $our_version);
5972 push @cachekey, $upstreamversion;
5973 push @cachekey, $quilt_mode;
5974 push @cachekey, $headref;
5976 push @cachekey, hashfile('fake.dsc');
5978 my $srcshash = Digest::SHA->new(256);
5979 my %sfs = ( %INC, '$0(dgit)' => $0 );
5980 foreach my $sfk (sort keys %sfs) {
5981 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5982 $srcshash->add($sfk," ");
5983 $srcshash->add(hashfile($sfs{$sfk}));
5984 $srcshash->add("\n");
5986 push @cachekey, $srcshash->hexdigest();
5987 $splitbrain_cachekey = "@cachekey";
5989 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5991 my $cachehit = reflog_cache_lookup
5992 "refs/$splitbraincache", $splitbrain_cachekey;
5995 unpack_playtree_need_cd_work($headref);
5996 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5997 if ($cachehit ne $headref) {
5998 progress f_ "dgit view: found cached (%s)", $saved;
5999 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6000 $made_split_brain = 1;
6001 return ($cachehit, $splitbrain_cachekey);
6003 progress __ "dgit view: found cached, no changes required";
6004 return ($headref, $splitbrain_cachekey);
6007 printdebug "splitbrain cache miss\n";
6008 return (undef, $splitbrain_cachekey);
6011 sub quilt_fixup_multipatch ($$$) {
6012 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6014 progress f_ "examining quilt state (multiple patches, %s mode)",
6018 # - honour any existing .pc in case it has any strangeness
6019 # - determine the git commit corresponding to the tip of
6020 # the patch stack (if there is one)
6021 # - if there is such a git commit, convert each subsequent
6022 # git commit into a quilt patch with dpkg-source --commit
6023 # - otherwise convert all the differences in the tree into
6024 # a single git commit
6028 # Our git tree doesn't necessarily contain .pc. (Some versions of
6029 # dgit would include the .pc in the git tree.) If there isn't
6030 # one, we need to generate one by unpacking the patches that we
6033 # We first look for a .pc in the git tree. If there is one, we
6034 # will use it. (This is not the normal case.)
6036 # Otherwise need to regenerate .pc so that dpkg-source --commit
6037 # can work. We do this as follows:
6038 # 1. Collect all relevant .orig from parent directory
6039 # 2. Generate a debian.tar.gz out of
6040 # debian/{patches,rules,source/format,source/options}
6041 # 3. Generate a fake .dsc containing just these fields:
6042 # Format Source Version Files
6043 # 4. Extract the fake .dsc
6044 # Now the fake .dsc has a .pc directory.
6045 # (In fact we do this in every case, because in future we will
6046 # want to search for a good base commit for generating patches.)
6048 # Then we can actually do the dpkg-source --commit
6049 # 1. Make a new working tree with the same object
6050 # store as our main tree and check out the main
6052 # 2. Copy .pc from the fake's extraction, if necessary
6053 # 3. Run dpkg-source --commit
6054 # 4. If the result has changes to debian/, then
6055 # - git add them them
6056 # - git add .pc if we had a .pc in-tree
6058 # 5. If we had a .pc in-tree, delete it, and git commit
6059 # 6. Back in the main tree, fast forward to the new HEAD
6061 # Another situation we may have to cope with is gbp-style
6062 # patches-unapplied trees.
6064 # We would want to detect these, so we know to escape into
6065 # quilt_fixup_gbp. However, this is in general not possible.
6066 # Consider a package with a one patch which the dgit user reverts
6067 # (with git revert or the moral equivalent).
6069 # That is indistinguishable in contents from a patches-unapplied
6070 # tree. And looking at the history to distinguish them is not
6071 # useful because the user might have made a confusing-looking git
6072 # history structure (which ought to produce an error if dgit can't
6073 # cope, not a silent reintroduction of an unwanted patch).
6075 # So gbp users will have to pass an option. But we can usually
6076 # detect their failure to do so: if the tree is not a clean
6077 # patches-applied tree, quilt linearisation fails, but the tree
6078 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6079 # they want --quilt=unapplied.
6081 # To help detect this, when we are extracting the fake dsc, we
6082 # first extract it with --skip-patches, and then apply the patches
6083 # afterwards with dpkg-source --before-build. That lets us save a
6084 # tree object corresponding to .origs.
6086 if ($quilt_mode eq 'linear'
6087 && branch_is_gdr($headref)) {
6088 # This is much faster. It also makes patches that gdr
6089 # likes better for future updates without laundering.
6091 # However, it can fail in some casses where we would
6092 # succeed: if there are existing patches, which correspond
6093 # to a prefix of the branch, but are not in gbp/gdr
6094 # format, gdr will fail (exiting status 7), but we might
6095 # be able to figure out where to start linearising. That
6096 # will be slower so hopefully there's not much to do.
6098 unpack_playtree_need_cd_work $headref;
6100 my @cmd = (@git_debrebase,
6101 qw(--noop-ok -funclean-mixed -funclean-ordering
6102 make-patches --quiet-would-amend));
6103 # We tolerate soe snags that gdr wouldn't, by default.
6109 and not ($? == 7*256 or
6110 $? == -1 && $!==ENOENT);
6114 $headref = git_rev_parse('HEAD');
6119 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6123 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6125 if (system @bbcmd) {
6126 failedcmd @bbcmd if $? < 0;
6128 failed to apply your git tree's patch stack (from debian/patches/) to
6129 the corresponding upstream tarball(s). Your source tree and .orig
6130 are probably too inconsistent. dgit can only fix up certain kinds of
6131 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6137 unpack_playtree_need_cd_work($headref);
6140 if (stat_exists ".pc") {
6142 progress __ "Tree already contains .pc - will use it then delete it.";
6145 rename '../fake/.pc','.pc' or confess "$!";
6148 changedir '../fake';
6150 my $oldtiptree=git_add_write_tree();
6151 printdebug "fake o+d/p tree object $unapplied\n";
6152 changedir '../work';
6155 # We calculate some guesswork now about what kind of tree this might
6156 # be. This is mostly for error reporting.
6162 # O = orig, without patches applied
6163 # A = "applied", ie orig with H's debian/patches applied
6164 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6165 \%editedignores, \@unrepres),
6166 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6167 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6171 foreach my $bits (qw(01 02)) {
6172 foreach my $v (qw(O2H O2A H2A)) {
6173 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6176 printdebug "differences \@dl @dl.\n";
6179 "%s: base trees orig=%.20s o+d/p=%.20s",
6180 $us, $unapplied, $oldtiptree;
6182 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6183 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6184 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6185 $us, $dl[2], $dl[5];
6188 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6191 forceable_fail [qw(unrepresentable)], __ <<END;
6192 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6197 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6198 push @failsuggestion, [ 'unapplied', __
6199 "This might be a patches-unapplied branch." ];
6200 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6201 push @failsuggestion, [ 'applied', __
6202 "This might be a patches-applied branch." ];
6204 push @failsuggestion, [ 'quilt-mode', __
6205 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6207 push @failsuggestion, [ 'gitattrs', __
6208 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6209 if stat_exists '.gitattributes';
6211 push @failsuggestion, [ 'origs', __
6212 "Maybe orig tarball(s) are not identical to git representation?" ];
6214 if (quiltmode_splitting()) {
6215 quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6216 $diffbits, \%editedignores,
6217 $splitbrain_cachekey);
6221 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6222 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6223 runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6225 if (!open P, '>>', ".pc/applied-patches") {
6226 $!==&ENOENT or confess "$!";
6231 commit_quilty_patch();
6233 if ($mustdeletepc) {
6234 quilt_fixup_delete_pc();
6238 sub quilt_fixup_editor () {
6239 my $descfn = $ENV{$fakeeditorenv};
6240 my $editing = $ARGV[$#ARGV];
6241 open I1, '<', $descfn or confess "$descfn: $!";
6242 open I2, '<', $editing or confess "$editing: $!";
6243 unlink $editing or confess "$editing: $!";
6244 open O, '>', $editing or confess "$editing: $!";
6245 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6248 $copying ||= m/^\-\-\- /;
6249 next unless $copying;
6250 print O or confess "$!";
6252 I2->error and confess "$!";
6257 sub maybe_apply_patches_dirtily () {
6258 return unless $quilt_mode =~ m/gbp|unapplied/;
6259 print STDERR __ <<END or confess "$!";
6261 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6262 dgit: Have to apply the patches - making the tree dirty.
6263 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6266 $patches_applied_dirtily = 01;
6267 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6268 runcmd qw(dpkg-source --before-build .);
6271 sub maybe_unapply_patches_again () {
6272 progress __ "dgit: Unapplying patches again to tidy up the tree."
6273 if $patches_applied_dirtily;
6274 runcmd qw(dpkg-source --after-build .)
6275 if $patches_applied_dirtily & 01;
6277 if $patches_applied_dirtily & 02;
6278 $patches_applied_dirtily = 0;
6281 #----- other building -----
6283 sub clean_tree_check_git ($$$) {
6284 my ($honour_ignores, $message, $ignmessage) = @_;
6285 my @cmd = (@git, qw(clean -dn));
6286 push @cmd, qw(-x) unless $honour_ignores;
6287 my $leftovers = cmdoutput @cmd;
6288 if (length $leftovers) {
6289 print STDERR $leftovers, "\n" or confess "$!";
6290 $message .= $ignmessage if $honour_ignores;
6295 sub clean_tree_check_git_wd ($) {
6297 return if $cleanmode =~ m{no-check};
6298 return if $patches_applied_dirtily; # yuk
6299 clean_tree_check_git +($cleanmode !~ m{all-check}),
6300 $message, "\n".__ <<END;
6301 If this is just missing .gitignore entries, use a different clean
6302 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6303 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6307 sub clean_tree_check () {
6308 # This function needs to not care about modified but tracked files.
6309 # That was done by check_not_dirty, and by now we may have run
6310 # the rules clean target which might modify tracked files (!)
6311 if ($cleanmode =~ m{^check}) {
6312 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6313 "tree contains uncommitted files and --clean=check specified", '';
6314 } elsif ($cleanmode =~ m{^dpkg-source}) {
6315 clean_tree_check_git_wd __
6316 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6317 } elsif ($cleanmode =~ m{^git}) {
6318 clean_tree_check_git 1, __
6319 "tree contains uncommited, untracked, unignored files\n".
6320 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6321 } elsif ($cleanmode eq 'none') {
6323 confess "$cleanmode ?";
6328 # We always clean the tree ourselves, rather than leave it to the
6329 # builder (dpkg-source, or soemthing which calls dpkg-source).
6330 if ($cleanmode =~ m{^dpkg-source}) {
6331 my @cmd = @dpkgbuildpackage;
6332 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6333 push @cmd, qw(-T clean);
6334 maybe_apply_patches_dirtily();
6335 runcmd_ordryrun_local @cmd;
6336 clean_tree_check_git_wd __
6337 "tree contains uncommitted files (after running rules clean)";
6338 } elsif ($cleanmode =~ m{^git(?!-)}) {
6339 runcmd_ordryrun_local @git, qw(clean -xdf);
6340 } elsif ($cleanmode =~ m{^git-ff}) {
6341 runcmd_ordryrun_local @git, qw(clean -xdff);
6342 } elsif ($cleanmode =~ m{^check}) {
6344 } elsif ($cleanmode eq 'none') {
6346 confess "$cleanmode ?";
6351 badusage __ "clean takes no additional arguments" if @ARGV;
6354 maybe_unapply_patches_again();
6357 # return values from massage_dbp_args are one or both of these flags
6358 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6359 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6361 sub build_or_push_prep_early () {
6362 our $build_or_push_prep_early_done //= 0;
6363 return if $build_or_push_prep_early_done++;
6364 badusage f_ "-p is not allowed with dgit %s", $subcommand
6365 if defined $package;
6366 my $clogp = parsechangelog();
6367 $isuite = getfield $clogp, 'Distribution';
6368 $package = getfield $clogp, 'Source';
6369 $version = getfield $clogp, 'Version';
6370 $dscfn = dscfn($version);
6373 sub build_or_push_prep_modes () {
6374 determine_whether_split_brain();
6376 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
6377 if do_split_brain() && $includedirty;
6380 sub build_prep_early () {
6381 build_or_push_prep_early();
6383 build_or_push_prep_modes();
6387 sub build_prep ($) {
6391 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6392 # Clean the tree because we're going to use the contents of
6393 # $maindir. (We trying to include dirty changes in the source
6394 # package, or we are running the builder in $maindir.)
6395 || $cleanmode =~ m{always}) {
6396 # Or because the user asked us to.
6399 # We don't actually need to do anything in $maindir, but we
6400 # should do some kind of cleanliness check because (i) the
6401 # user may have forgotten a `git add', and (ii) if the user
6402 # said -wc we should still do the check.
6405 build_check_quilt_splitbrain();
6407 my $pat = changespat $version;
6408 foreach my $f (glob "$buildproductsdir/$pat") {
6411 fail f_ "remove old changes file %s: %s", $f, $!;
6413 progress f_ "would remove %s", $f;
6419 sub changesopts_initial () {
6420 my @opts =@changesopts[1..$#changesopts];
6423 sub changesopts_version () {
6424 if (!defined $changes_since_version) {
6427 @vsns = archive_query('archive_query');
6428 my @quirk = access_quirk();
6429 if ($quirk[0] eq 'backports') {
6430 local $isuite = $quirk[2];
6432 canonicalise_suite();
6433 push @vsns, archive_query('archive_query');
6439 "archive query failed (queried because --since-version not specified)";
6442 @vsns = map { $_->[0] } @vsns;
6443 @vsns = sort { -version_compare($a, $b) } @vsns;
6444 $changes_since_version = $vsns[0];
6445 progress f_ "changelog will contain changes since %s", $vsns[0];
6447 $changes_since_version = '_';
6448 progress __ "package seems new, not specifying -v<version>";
6451 if ($changes_since_version ne '_') {
6452 return ("-v$changes_since_version");
6458 sub changesopts () {
6459 return (changesopts_initial(), changesopts_version());
6462 sub massage_dbp_args ($;$) {
6463 my ($cmd,$xargs) = @_;
6464 # Since we split the source build out so we can do strange things
6465 # to it, massage the arguments to dpkg-buildpackage so that the
6466 # main build doessn't build source (or add an argument to stop it
6467 # building source by default).
6468 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6469 # -nc has the side effect of specifying -b if nothing else specified
6470 # and some combinations of -S, -b, et al, are errors, rather than
6471 # later simply overriding earlie. So we need to:
6472 # - search the command line for these options
6473 # - pick the last one
6474 # - perhaps add our own as a default
6475 # - perhaps adjust it to the corresponding non-source-building version
6477 foreach my $l ($cmd, $xargs) {
6479 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6482 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6483 my $r = WANTSRC_BUILDER;
6484 printdebug "massage split $dmode.\n";
6485 if ($dmode =~ s/^--build=//) {
6487 my @d = split /,/, $dmode;
6488 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6489 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6490 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6491 fail __ "Wanted to build nothing!" unless $r;
6492 $dmode = '--build='. join ',', grep m/./, @d;
6495 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6496 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6497 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6500 printdebug "massage done $r $dmode.\n";
6502 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6508 my $wasdir = must_getcwd();
6509 changedir $buildproductsdir;
6514 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6515 sub postbuild_mergechanges ($) {
6516 my ($msg_if_onlyone) = @_;
6517 # If there is only one .changes file, fail with $msg_if_onlyone,
6518 # or if that is undef, be a no-op.
6519 # Returns the changes file to report to the user.
6520 my $pat = changespat $version;
6521 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6522 @changesfiles = sort {
6523 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6527 if (@changesfiles==1) {
6528 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6529 only one changes file from build (%s)
6531 if defined $msg_if_onlyone;
6532 $result = $changesfiles[0];
6533 } elsif (@changesfiles==2) {
6534 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6535 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6536 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6539 runcmd_ordryrun_local @mergechanges, @changesfiles;
6540 my $multichanges = changespat $version,'multi';
6542 stat_exists $multichanges or fail f_
6543 "%s unexpectedly not created by build", $multichanges;
6544 foreach my $cf (glob $pat) {
6545 next if $cf eq $multichanges;
6546 rename "$cf", "$cf.inmulti" or fail f_
6547 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6550 $result = $multichanges;
6552 fail f_ "wrong number of different changes files (%s)",
6555 printdone f_ "build successful, results in %s\n", $result
6559 sub midbuild_checkchanges () {
6560 my $pat = changespat $version;
6561 return if $rmchanges;
6562 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6564 $_ ne changespat $version,'source' and
6565 $_ ne changespat $version,'multi'
6567 fail +(f_ <<END, $pat, "@unwanted")
6568 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6569 Suggest you delete %s.
6574 sub midbuild_checkchanges_vanilla ($) {
6576 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6579 sub postbuild_mergechanges_vanilla ($) {
6581 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6583 postbuild_mergechanges(undef);
6586 printdone __ "build successful\n";
6592 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6593 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6594 %s: warning: build-products-dir will be ignored; files will go to ..
6596 $buildproductsdir = '..';
6597 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6598 my $wantsrc = massage_dbp_args \@dbp;
6599 build_prep($wantsrc);
6600 if ($wantsrc & WANTSRC_SOURCE) {
6602 midbuild_checkchanges_vanilla $wantsrc;
6604 if ($wantsrc & WANTSRC_BUILDER) {
6605 push @dbp, changesopts_version();
6606 maybe_apply_patches_dirtily();
6607 runcmd_ordryrun_local @dbp;
6609 maybe_unapply_patches_again();
6610 postbuild_mergechanges_vanilla $wantsrc;
6614 $quilt_mode //= 'gbp';
6620 # gbp can make .origs out of thin air. In my tests it does this
6621 # even for a 1.0 format package, with no origs present. So I
6622 # guess it keys off just the version number. We don't know
6623 # exactly what .origs ought to exist, but let's assume that we
6624 # should run gbp if: the version has an upstream part and the main
6626 my $upstreamversion = upstreamversion $version;
6627 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6628 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6630 if ($gbp_make_orig) {
6632 $cleanmode = 'none'; # don't do it again
6635 my @dbp = @dpkgbuildpackage;
6637 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6639 if (!length $gbp_build[0]) {
6640 if (length executable_on_path('git-buildpackage')) {
6641 $gbp_build[0] = qw(git-buildpackage);
6643 $gbp_build[0] = 'gbp buildpackage';
6646 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6648 push @cmd, (qw(-us -uc --git-no-sign-tags),
6649 "--git-builder=".(shellquote @dbp));
6651 if ($gbp_make_orig) {
6652 my $priv = dgit_privdir();
6653 my $ok = "$priv/origs-gen-ok";
6654 unlink $ok or $!==&ENOENT or confess "$!";
6655 my @origs_cmd = @cmd;
6656 push @origs_cmd, qw(--git-cleaner=true);
6657 push @origs_cmd, "--git-prebuild=".
6658 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6659 push @origs_cmd, @ARGV;
6661 debugcmd @origs_cmd;
6663 do { local $!; stat_exists $ok; }
6664 or failedcmd @origs_cmd;
6666 dryrun_report @origs_cmd;
6670 build_prep($wantsrc);
6671 if ($wantsrc & WANTSRC_SOURCE) {
6673 midbuild_checkchanges_vanilla $wantsrc;
6675 push @cmd, '--git-cleaner=true';
6677 maybe_unapply_patches_again();
6678 if ($wantsrc & WANTSRC_BUILDER) {
6679 push @cmd, changesopts();
6680 runcmd_ordryrun_local @cmd, @ARGV;
6682 postbuild_mergechanges_vanilla $wantsrc;
6684 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6686 sub building_source_in_playtree {
6687 # If $includedirty, we have to build the source package from the
6688 # working tree, not a playtree, so that uncommitted changes are
6689 # included (copying or hardlinking them into the playtree could
6692 # Note that if we are building a source package in split brain
6693 # mode we do not support including uncommitted changes, because
6694 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6695 # building a source package)) => !$includedirty
6696 return !$includedirty;
6700 $sourcechanges = changespat $version,'source';
6702 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6703 or fail f_ "remove %s: %s", $sourcechanges, $!;
6705 # confess unless !!$made_split_brain == do_split_brain();
6707 my @cmd = (@dpkgsource, qw(-b --));
6709 if (building_source_in_playtree()) {
6711 my $headref = git_rev_parse('HEAD');
6712 # If we are in split brain, there is already a playtree with
6713 # the thing we should package into a .dsc (thanks to quilt
6714 # fixup). If not, make a playtree
6715 prep_ud() unless $made_split_brain;
6716 changedir $playground;
6717 unless ($made_split_brain) {
6718 my $upstreamversion = upstreamversion $version;
6719 unpack_playtree_linkorigs($upstreamversion, sub { });
6720 unpack_playtree_need_cd_work($headref);
6724 $leafdir = basename $maindir;
6726 if ($buildproductsdir ne '..') {
6727 # Well, we are going to run dpkg-source -b which consumes
6728 # origs from .. and generates output there. To make this
6729 # work when the bpd is not .. , we would have to (i) link
6730 # origs from bpd to .. , (ii) check for files that
6731 # dpkg-source -b would/might overwrite, and afterwards
6732 # (iii) move all the outputs back to the bpd (iv) except
6733 # for the origs which should be deleted from .. if they
6734 # weren't there beforehand. And if there is an error and
6735 # we don't run to completion we would necessarily leave a
6736 # mess. This is too much. The real way to fix this
6737 # is for dpkg-source to have bpd support.
6738 confess unless $includedirty;
6740 "--include-dirty not supported with --build-products-dir, sorry";
6745 runcmd_ordryrun_local @cmd, $leafdir;
6748 runcmd_ordryrun_local qw(sh -ec),
6749 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6750 @dpkggenchanges, qw(-S), changesopts();
6753 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6754 $dsc = parsecontrol($dscfn, "source package");
6758 printdebug " renaming ($why) $l\n";
6759 rename_link_xf 0, "$l", bpd_abs()."/$l"
6760 or fail f_ "put in place new built file (%s): %s", $l, $@;
6762 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6763 $l =~ m/\S+$/ or next;
6766 $mv->('dsc', $dscfn);
6767 $mv->('changes', $sourcechanges);
6772 sub cmd_build_source {
6773 badusage __ "build-source takes no additional arguments" if @ARGV;
6774 build_prep(WANTSRC_SOURCE);
6776 maybe_unapply_patches_again();
6777 printdone f_ "source built, results in %s and %s",
6778 $dscfn, $sourcechanges;
6781 sub cmd_push_source {
6784 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6785 "sense with push-source!"
6787 build_check_quilt_splitbrain();
6789 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6790 __ "source changes file");
6791 unless (test_source_only_changes($changes)) {
6792 fail __ "user-specified changes file is not source-only";
6795 # Building a source package is very fast, so just do it
6797 confess "er, patches are applied dirtily but shouldn't be.."
6798 if $patches_applied_dirtily;
6799 $changesfile = $sourcechanges;
6804 sub binary_builder {
6805 my ($bbuilder, $pbmc_msg, @args) = @_;
6806 build_prep(WANTSRC_SOURCE);
6808 midbuild_checkchanges();
6811 stat_exists $dscfn or fail f_
6812 "%s (in build products dir): %s", $dscfn, $!;
6813 stat_exists $sourcechanges or fail f_
6814 "%s (in build products dir): %s", $sourcechanges, $!;
6816 runcmd_ordryrun_local @$bbuilder, @args;
6818 maybe_unapply_patches_again();
6820 postbuild_mergechanges($pbmc_msg);
6826 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6827 perhaps you need to pass -A ? (sbuild's default is to build only
6828 arch-specific binaries; dgit 1.4 used to override that.)
6833 my ($pbuilder) = @_;
6835 # @ARGV is allowed to contain only things that should be passed to
6836 # pbuilder under debbuildopts; just massage those
6837 my $wantsrc = massage_dbp_args \@ARGV;
6839 "you asked for a builder but your debbuildopts didn't ask for".
6840 " any binaries -- is this really what you meant?"
6841 unless $wantsrc & WANTSRC_BUILDER;
6843 "we must build a .dsc to pass to the builder but your debbuiltopts".
6844 " forbids the building of a source package; cannot continue"
6845 unless $wantsrc & WANTSRC_SOURCE;
6846 # We do not want to include the verb "build" in @pbuilder because
6847 # the user can customise @pbuilder and they shouldn't be required
6848 # to include "build" in their customised value. However, if the
6849 # user passes any additional args to pbuilder using the dgit
6850 # option --pbuilder:foo, such args need to come after the "build"
6851 # verb. opts_opt_multi_cmd does all of that.
6852 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6853 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6858 pbuilder(\@pbuilder);
6861 sub cmd_cowbuilder {
6862 pbuilder(\@cowbuilder);
6865 sub cmd_quilt_fixup {
6866 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6869 build_maybe_quilt_fixup();
6872 sub cmd_print_unapplied_treeish {
6873 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6875 my $headref = git_rev_parse('HEAD');
6876 my $clogp = commit_getclogp $headref;
6877 $package = getfield $clogp, 'Source';
6878 $version = getfield $clogp, 'Version';
6879 $isuite = getfield $clogp, 'Distribution';
6880 $csuite = $isuite; # we want this to be offline!
6884 changedir $playground;
6885 my $uv = upstreamversion $version;
6886 my $u = quilt_fakedsc2unapplied($headref, $uv);
6887 print $u, "\n" or confess "$!";
6890 sub import_dsc_result {
6891 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6892 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6894 check_gitattrs($newhash, __ "source tree");
6896 progress f_ "dgit: import-dsc: %s", $what_msg;
6899 sub cmd_import_dsc {
6903 last unless $ARGV[0] =~ m/^-/;
6906 if (m/^--require-valid-signature$/) {
6909 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6913 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6915 my ($dscfn, $dstbranch) = @ARGV;
6917 badusage __ "dry run makes no sense with import-dsc"
6920 my $force = $dstbranch =~ s/^\+// ? +1 :
6921 $dstbranch =~ s/^\.\.// ? -1 :
6923 my $info = $force ? " $&" : '';
6924 $info = "$dscfn$info";
6926 my $specbranch = $dstbranch;
6927 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6928 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6930 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6931 my $chead = cmdoutput_errok @symcmd;
6932 defined $chead or $?==256 or failedcmd @symcmd;
6934 fail f_ "%s is checked out - will not update it", $dstbranch
6935 if defined $chead and $chead eq $dstbranch;
6937 my $oldhash = git_get_ref $dstbranch;
6939 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6940 $dscdata = do { local $/ = undef; <D>; };
6941 D->error and fail f_ "read %s: %s", $dscfn, $!;
6944 # we don't normally need this so import it here
6945 use Dpkg::Source::Package;
6946 my $dp = new Dpkg::Source::Package filename => $dscfn,
6947 require_valid_signature => $needsig;
6949 local $SIG{__WARN__} = sub {
6951 return unless $needsig;
6952 fail __ "import-dsc signature check failed";
6954 if (!$dp->is_signed()) {
6955 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6957 my $r = $dp->check_signature();
6958 confess "->check_signature => $r" if $needsig && $r;
6964 $package = getfield $dsc, 'Source';
6966 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6967 unless forceing [qw(import-dsc-with-dgit-field)];
6968 parse_dsc_field_def_dsc_distro();
6970 $isuite = 'DGIT-IMPORT-DSC';
6971 $idistro //= $dsc_distro;
6975 if (defined $dsc_hash) {
6977 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6978 resolve_dsc_field_commit undef, undef;
6980 if (defined $dsc_hash) {
6981 my @cmd = (qw(sh -ec),
6982 "echo $dsc_hash | git cat-file --batch-check");
6983 my $objgot = cmdoutput @cmd;
6984 if ($objgot =~ m#^\w+ missing\b#) {
6985 fail f_ <<END, $dsc_hash
6986 .dsc contains Dgit field referring to object %s
6987 Your git tree does not have that object. Try `git fetch' from a
6988 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6991 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6993 progress __ "Not fast forward, forced update.";
6995 fail f_ "Not fast forward to %s", $dsc_hash;
6998 import_dsc_result $dstbranch, $dsc_hash,
6999 "dgit import-dsc (Dgit): $info",
7000 f_ "updated git ref %s", $dstbranch;
7004 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7005 Branch %s already exists
7006 Specify ..%s for a pseudo-merge, binding in existing history
7007 Specify +%s to overwrite, discarding existing history
7009 if $oldhash && !$force;
7011 my @dfi = dsc_files_info();
7012 foreach my $fi (@dfi) {
7013 my $f = $fi->{Filename};
7014 # We transfer all the pieces of the dsc to the bpd, not just
7015 # origs. This is by analogy with dgit fetch, which wants to
7016 # keep them somewhere to avoid downloading them again.
7017 # We make symlinks, though. If the user wants copies, then
7018 # they can copy the parts of the dsc to the bpd using dcmd,
7020 my $here = "$buildproductsdir/$f";
7025 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7027 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7028 printdebug "not in bpd, $f ...\n";
7029 # $f does not exist in bpd, we need to transfer it
7031 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7032 # $there is file we want, relative to user's cwd, or abs
7033 printdebug "not in bpd, $f, test $there ...\n";
7034 stat $there or fail f_
7035 "import %s requires %s, but: %s", $dscfn, $there, $!;
7036 if ($there =~ m#^(?:\./+)?\.\./+#) {
7037 # $there is relative to user's cwd
7038 my $there_from_parent = $';
7039 if ($buildproductsdir !~ m{^/}) {
7040 # abs2rel, despite its name, can take two relative paths
7041 $there = File::Spec->abs2rel($there,$buildproductsdir);
7042 # now $there is relative to bpd, great
7043 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7045 $there = (dirname $maindir)."/$there_from_parent";
7046 # now $there is absoute
7047 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7049 } elsif ($there =~ m#^/#) {
7050 # $there is absolute already
7051 printdebug "not in bpd, $f, abs, $there ...\n";
7054 "cannot import %s which seems to be inside working tree!",
7057 symlink $there, $here or fail f_
7058 "symlink %s to %s: %s", $there, $here, $!;
7059 progress f_ "made symlink %s -> %s", $here, $there;
7060 # print STDERR Dumper($fi);
7062 my @mergeinputs = generate_commits_from_dsc();
7063 die unless @mergeinputs == 1;
7065 my $newhash = $mergeinputs[0]{Commit};
7070 "Import, forced update - synthetic orphan git history.";
7071 } elsif ($force < 0) {
7072 progress __ "Import, merging.";
7073 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7074 my $version = getfield $dsc, 'Version';
7075 my $clogp = commit_getclogp $newhash;
7076 my $authline = clogp_authline $clogp;
7077 $newhash = make_commit_text <<ENDU
7085 .(f_ <<END, $package, $version, $dstbranch);
7086 Merge %s (%s) import into %s
7089 die; # caught earlier
7093 import_dsc_result $dstbranch, $newhash,
7094 "dgit import-dsc: $info",
7095 f_ "results are in git ref %s", $dstbranch;
7098 sub pre_archive_api_query () {
7099 not_necessarily_a_tree();
7101 sub cmd_archive_api_query {
7102 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7103 my ($subpath) = @ARGV;
7104 local $isuite = 'DGIT-API-QUERY-CMD';
7105 my @cmd = archive_api_query_cmd($subpath);
7108 exec @cmd or fail f_ "exec curl: %s\n", $!;
7111 sub repos_server_url () {
7112 $package = '_dgit-repos-server';
7113 local $access_forpush = 1;
7114 local $isuite = 'DGIT-REPOS-SERVER';
7115 my $url = access_giturl();
7118 sub pre_clone_dgit_repos_server () {
7119 not_necessarily_a_tree();
7121 sub cmd_clone_dgit_repos_server {
7122 badusage __ "need destination argument" unless @ARGV==1;
7123 my ($destdir) = @ARGV;
7124 my $url = repos_server_url();
7125 my @cmd = (@git, qw(clone), $url, $destdir);
7127 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7130 sub pre_print_dgit_repos_server_source_url () {
7131 not_necessarily_a_tree();
7133 sub cmd_print_dgit_repos_server_source_url {
7135 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7137 my $url = repos_server_url();
7138 print $url, "\n" or confess "$!";
7141 sub pre_print_dpkg_source_ignores {
7142 not_necessarily_a_tree();
7144 sub cmd_print_dpkg_source_ignores {
7146 "no arguments allowed to dgit print-dpkg-source-ignores"
7148 print "@dpkg_source_ignores\n" or confess "$!";
7151 sub cmd_setup_mergechangelogs {
7152 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7154 local $isuite = 'DGIT-SETUP-TREE';
7155 setup_mergechangelogs(1);
7158 sub cmd_setup_useremail {
7159 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7160 local $isuite = 'DGIT-SETUP-TREE';
7164 sub cmd_setup_gitattributes {
7165 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7166 local $isuite = 'DGIT-SETUP-TREE';
7170 sub cmd_setup_new_tree {
7171 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7172 local $isuite = 'DGIT-SETUP-TREE';
7176 #---------- argument parsing and main program ----------
7179 print "dgit version $our_version\n" or confess "$!";
7183 our (%valopts_long, %valopts_short);
7184 our (%funcopts_long);
7186 our (@modeopt_cfgs);
7188 sub defvalopt ($$$$) {
7189 my ($long,$short,$val_re,$how) = @_;
7190 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7191 $valopts_long{$long} = $oi;
7192 $valopts_short{$short} = $oi;
7193 # $how subref should:
7194 # do whatever assignemnt or thing it likes with $_[0]
7195 # if the option should not be passed on to remote, @rvalopts=()
7196 # or $how can be a scalar ref, meaning simply assign the value
7199 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7200 defvalopt '--distro', '-d', '.+', \$idistro;
7201 defvalopt '', '-k', '.+', \$keyid;
7202 defvalopt '--existing-package','', '.*', \$existing_package;
7203 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7204 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7205 defvalopt '--package', '-p', $package_re, \$package;
7206 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7208 defvalopt '', '-C', '.+', sub {
7209 ($changesfile) = (@_);
7210 if ($changesfile =~ s#^(.*)/##) {
7211 $buildproductsdir = $1;
7215 defvalopt '--initiator-tempdir','','.*', sub {
7216 ($initiator_tempdir) = (@_);
7217 $initiator_tempdir =~ m#^/# or
7218 badusage __ "--initiator-tempdir must be used specify an".
7219 " absolute, not relative, directory."
7222 sub defoptmodes ($@) {
7223 my ($varref, $cfgkey, $default, %optmap) = @_;
7225 while (my ($opt,$val) = each %optmap) {
7226 $funcopts_long{$opt} = sub { $$varref = $val; };
7227 $permit{$val} = $val;
7229 push @modeopt_cfgs, {
7232 Default => $default,
7237 defoptmodes \$dodep14tag, qw( dep14tag want
7240 --always-dep14tag always );
7245 if (defined $ENV{'DGIT_SSH'}) {
7246 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7247 } elsif (defined $ENV{'GIT_SSH'}) {
7248 @ssh = ($ENV{'GIT_SSH'});
7256 if (!defined $val) {
7257 badusage f_ "%s needs a value", $what unless @ARGV;
7259 push @rvalopts, $val;
7261 badusage f_ "bad value \`%s' for %s", $val, $what unless
7262 $val =~ m/^$oi->{Re}$(?!\n)/s;
7263 my $how = $oi->{How};
7264 if (ref($how) eq 'SCALAR') {
7269 push @ropts, @rvalopts;
7273 last unless $ARGV[0] =~ m/^-/;
7277 if (m/^--dry-run$/) {
7280 } elsif (m/^--damp-run$/) {
7283 } elsif (m/^--no-sign$/) {
7286 } elsif (m/^--help$/) {
7288 } elsif (m/^--version$/) {
7290 } elsif (m/^--new$/) {
7293 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7294 ($om = $opts_opt_map{$1}) &&
7298 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7299 !$opts_opt_cmdonly{$1} &&
7300 ($om = $opts_opt_map{$1})) {
7303 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7304 !$opts_opt_cmdonly{$1} &&
7305 ($om = $opts_opt_map{$1})) {
7307 my $cmd = shift @$om;
7308 @$om = ($cmd, grep { $_ ne $2 } @$om);
7309 } elsif (m/^--(gbp|dpm)$/s) {
7310 push @ropts, "--quilt=$1";
7312 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7315 } elsif (m/^--no-quilt-fixup$/s) {
7317 $quilt_mode = 'nocheck';
7318 } elsif (m/^--no-rm-on-error$/s) {
7321 } elsif (m/^--no-chase-dsc-distro$/s) {
7323 $chase_dsc_distro = 0;
7324 } elsif (m/^--overwrite$/s) {
7326 $overwrite_version = '';
7327 } elsif (m/^--overwrite=(.+)$/s) {
7329 $overwrite_version = $1;
7330 } elsif (m/^--delayed=(\d+)$/s) {
7333 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7334 m/^--(dgit-view)-save=(.+)$/s
7336 my ($k,$v) = ($1,$2);
7338 $v =~ s#^(?!refs/)#refs/heads/#;
7339 $internal_object_save{$k} = $v;
7340 } elsif (m/^--(no-)?rm-old-changes$/s) {
7343 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7345 push @deliberatelies, $&;
7346 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7350 } elsif (m/^--force-/) {
7352 f_ "%s: warning: ignoring unknown force option %s\n",
7355 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7356 # undocumented, for testing
7358 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7359 # ^ it's supposed to be an array ref
7360 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7361 $val = $2 ? $' : undef; #';
7362 $valopt->($oi->{Long});
7363 } elsif ($funcopts_long{$_}) {
7365 $funcopts_long{$_}();
7367 badusage f_ "unknown long option \`%s'", $_;
7374 } elsif (s/^-L/-/) {
7377 } elsif (s/^-h/-/) {
7379 } elsif (s/^-D/-/) {
7383 } elsif (s/^-N/-/) {
7388 push @changesopts, $_;
7390 } elsif (s/^-wn$//s) {
7392 $cleanmode = 'none';
7393 } elsif (s/^-wg(f?)(a?)$//s) {
7396 $cleanmode .= '-ff' if $1;
7397 $cleanmode .= ',always' if $2;
7398 } elsif (s/^-wd(d?)([na]?)$//s) {
7400 $cleanmode = 'dpkg-source';
7401 $cleanmode .= '-d' if $1;
7402 $cleanmode .= ',no-check' if $2 eq 'n';
7403 $cleanmode .= ',all-check' if $2 eq 'a';
7404 } elsif (s/^-wc$//s) {
7406 $cleanmode = 'check';
7407 } elsif (s/^-wci$//s) {
7409 $cleanmode = 'check,ignores';
7410 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7411 push @git, '-c', $&;
7412 $gitcfgs{cmdline}{$1} = [ $2 ];
7413 } elsif (s/^-c([^=]+)$//s) {
7414 push @git, '-c', $&;
7415 $gitcfgs{cmdline}{$1} = [ 'true' ];
7416 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7418 $val = undef unless length $val;
7419 $valopt->($oi->{Short});
7422 badusage f_ "unknown short option \`%s'", $_;
7429 sub check_env_sanity () {
7430 my $blocked = new POSIX::SigSet;
7431 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7434 foreach my $name (qw(PIPE CHLD)) {
7435 my $signame = "SIG$name";
7436 my $signum = eval "POSIX::$signame" // die;
7437 die f_ "%s is set to something other than SIG_DFL\n",
7439 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7440 $blocked->ismember($signum) and
7441 die f_ "%s is blocked\n", $signame;
7447 On entry to dgit, %s
7448 This is a bug produced by something in your execution environment.
7454 sub parseopts_late_defaults () {
7455 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7456 if defined $idistro;
7457 $isuite //= cfg('dgit.default.default-suite');
7459 foreach my $k (keys %opts_opt_map) {
7460 my $om = $opts_opt_map{$k};
7462 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7464 badcfg f_ "cannot set command for %s", $k
7465 unless length $om->[0];
7469 foreach my $c (access_cfg_cfgs("opts-$k")) {
7471 map { $_ ? @$_ : () }
7472 map { $gitcfgs{$_}{$c} }
7473 reverse @gitcfgsources;
7474 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7475 "\n" if $debuglevel >= 4;
7477 badcfg f_ "cannot configure options for %s", $k
7478 if $opts_opt_cmdonly{$k};
7479 my $insertpos = $opts_cfg_insertpos{$k};
7480 @$om = ( @$om[0..$insertpos-1],
7482 @$om[$insertpos..$#$om] );
7486 if (!defined $rmchanges) {
7487 local $access_forpush;
7488 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7491 if (!defined $quilt_mode) {
7492 local $access_forpush;
7493 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7494 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7496 $quilt_mode =~ m/^($quilt_modes_re)$/
7497 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7501 foreach my $moc (@modeopt_cfgs) {
7502 local $access_forpush;
7503 my $vr = $moc->{Var};
7504 next if defined $$vr;
7505 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7506 my $v = $moc->{Vals}{$$vr};
7507 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7513 local $access_forpush;
7514 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7518 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7519 $buildproductsdir //= '..';
7520 $bpd_glob = $buildproductsdir;
7521 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7524 setlocale(LC_MESSAGES, "");
7527 if ($ENV{$fakeeditorenv}) {
7529 quilt_fixup_editor();
7535 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7536 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7537 if $dryrun_level == 1;
7539 print STDERR __ $helpmsg or confess "$!";
7542 $cmd = $subcommand = shift @ARGV;
7545 my $pre_fn = ${*::}{"pre_$cmd"};
7546 $pre_fn->() if $pre_fn;
7548 if ($invoked_in_git_tree) {
7549 changedir_git_toplevel();
7554 my $fn = ${*::}{"cmd_$cmd"};
7555 $fn or badusage f_ "unknown operation %s", $cmd;