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_splitbrain)
182 # source format sane `3.0 (quilt)'
183 # madformat_wantfixup()
185 # quilt mode normal quiltmode
186 # (eg linear) _splitbrain
188 # ------------ ------------------------------------------------
190 # no split no q cache no q cache forbidden,
191 # brain PM on master q fixup on master prevented
192 # !do_split_brain() PM on master
194 # split brain no q cache q fixup cached, to dgit view
195 # PM in dgit view PM in dgit view
197 # PM = pseudomerge to make ff, due to overwrite (or split view)
198 # "no q cache" = do not record in cache on build, do not check cache
199 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
203 return unless forkcheck_mainprocess();
204 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
207 our $remotename = 'dgit';
208 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
212 if (!defined $absurdity) {
214 $absurdity =~ s{/[^/]+$}{/absurd} or die;
217 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
219 sub lbranch () { return "$branchprefix/$csuite"; }
220 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
221 sub lref () { return "refs/heads/".lbranch(); }
222 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
223 sub rrref () { return server_ref($csuite); }
226 my ($vsn, $sfx) = @_;
227 return &source_file_leafname($package, $vsn, $sfx);
229 sub is_orig_file_of_vsn ($$) {
230 my ($f, $upstreamvsn) = @_;
231 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
236 return srcfn($vsn,".dsc");
239 sub changespat ($;$) {
240 my ($vsn, $arch) = @_;
241 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
250 return unless forkcheck_mainprocess();
251 foreach my $f (@end) {
253 print STDERR "$us: cleanup: $@" if length $@;
258 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
262 sub forceable_fail ($$) {
263 my ($forceoptsl, $msg) = @_;
264 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
265 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
269 my ($forceoptsl) = @_;
270 my @got = grep { $forceopts{$_} } @$forceoptsl;
271 return 0 unless @got;
273 "warning: skipping checks or functionality due to --force-%s\n",
277 sub no_such_package () {
278 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
279 $us, $package, $isuite;
283 sub deliberately ($) {
285 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
288 sub deliberately_not_fast_forward () {
289 foreach (qw(not-fast-forward fresh-repo)) {
290 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
294 sub quiltmode_splitbrain () {
295 $quilt_mode =~ m/gbp|dpm|unapplied/;
298 sub 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 supplementary_message ($) {
972 if (!$we_are_responder) {
973 $supplementary_message = $msg;
976 responder_send_command "supplementary-message ".length($msg)
978 print PO $msg or confess "$!";
982 sub access_distros () {
983 # Returns list of distros to try, in order
986 # 0. `instead of' distro name(s) we have been pointed to
987 # 1. the access_quirk distro, if any
988 # 2a. the user's specified distro, or failing that } basedistro
989 # 2b. the distro calculated from the suite }
990 my @l = access_basedistro();
992 my (undef,$quirkdistro) = access_quirk();
993 unshift @l, $quirkdistro;
994 unshift @l, $instead_distro;
995 @l = grep { defined } @l;
997 push @l, access_nomdistro();
999 if (access_forpush()) {
1000 @l = map { ("$_/push", $_) } @l;
1005 sub access_cfg_cfgs (@) {
1008 # The nesting of these loops determines the search order. We put
1009 # the key loop on the outside so that we search all the distros
1010 # for each key, before going on to the next key. That means that
1011 # if access_cfg is called with a more specific, and then a less
1012 # specific, key, an earlier distro can override the less specific
1013 # without necessarily overriding any more specific keys. (If the
1014 # distro wants to override the more specific keys it can simply do
1015 # so; whereas if we did the loop the other way around, it would be
1016 # impossible to for an earlier distro to override a less specific
1017 # key but not the more specific ones without restating the unknown
1018 # values of the more specific keys.
1021 # We have to deal with RETURN-UNDEF specially, so that we don't
1022 # terminate the search prematurely.
1024 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1027 foreach my $d (access_distros()) {
1028 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1030 push @cfgs, map { "dgit.default.$_" } @realkeys;
1031 push @cfgs, @rundef;
1035 sub access_cfg (@) {
1037 my (@cfgs) = access_cfg_cfgs(@keys);
1038 my $value = cfg(@cfgs);
1042 sub access_cfg_bool ($$) {
1043 my ($def, @keys) = @_;
1044 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1047 sub string_to_ssh ($) {
1049 if ($spec =~ m/\s/) {
1050 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1056 sub access_cfg_ssh () {
1057 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1058 if (!defined $gitssh) {
1061 return string_to_ssh $gitssh;
1065 sub access_runeinfo ($) {
1067 return ": dgit ".access_basedistro()." $info ;";
1070 sub access_someuserhost ($) {
1072 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1073 defined($user) && length($user) or
1074 $user = access_cfg("$some-user",'username');
1075 my $host = access_cfg("$some-host");
1076 return length($user) ? "$user\@$host" : $host;
1079 sub access_gituserhost () {
1080 return access_someuserhost('git');
1083 sub access_giturl (;$) {
1084 my ($optional) = @_;
1085 my $url = access_cfg('git-url','RETURN-UNDEF');
1088 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1089 return undef unless defined $proto;
1092 access_gituserhost().
1093 access_cfg('git-path');
1095 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1098 return "$url/$package$suffix";
1101 sub commit_getclogp ($) {
1102 # Returns the parsed changelog hashref for a particular commit
1104 our %commit_getclogp_memo;
1105 my $memo = $commit_getclogp_memo{$objid};
1106 return $memo if $memo;
1108 my $mclog = dgit_privdir()."clog";
1109 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1110 "$objid:debian/changelog";
1111 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1114 sub parse_dscdata () {
1115 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1116 printdebug Dumper($dscdata) if $debuglevel>1;
1117 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1118 printdebug Dumper($dsc) if $debuglevel>1;
1123 sub archive_query ($;@) {
1124 my ($method) = shift @_;
1125 fail __ "this operation does not support multiple comma-separated suites"
1127 my $query = access_cfg('archive-query','RETURN-UNDEF');
1128 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1131 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1134 sub archive_query_prepend_mirror {
1135 my $m = access_cfg('mirror');
1136 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1139 sub pool_dsc_subpath ($$) {
1140 my ($vsn,$component) = @_; # $package is implict arg
1141 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1142 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1145 sub cfg_apply_map ($$$) {
1146 my ($varref, $what, $mapspec) = @_;
1147 return unless $mapspec;
1149 printdebug "config $what EVAL{ $mapspec; }\n";
1151 eval "package Dgit::Config; $mapspec;";
1156 #---------- `ftpmasterapi' archive query method (nascent) ----------
1158 sub archive_api_query_cmd ($) {
1160 my @cmd = (@curl, qw(-sS));
1161 my $url = access_cfg('archive-query-url');
1162 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1164 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1165 foreach my $key (split /\:/, $keys) {
1166 $key =~ s/\%HOST\%/$host/g;
1168 fail "for $url: stat $key: $!" unless $!==ENOENT;
1171 fail f_ "config requested specific TLS key but do not know".
1172 " how to get curl to use exactly that EE key (%s)",
1174 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1175 # # Sadly the above line does not work because of changes
1176 # # to gnutls. The real fix for #790093 may involve
1177 # # new curl options.
1180 # Fixing #790093 properly will involve providing a value
1181 # for this on clients.
1182 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1183 push @cmd, split / /, $kargs if defined $kargs;
1185 push @cmd, $url.$subpath;
1189 sub api_query ($$;$) {
1191 my ($data, $subpath, $ok404) = @_;
1192 badcfg __ "ftpmasterapi archive query method takes no data part"
1194 my @cmd = archive_api_query_cmd($subpath);
1195 my $url = $cmd[$#cmd];
1196 push @cmd, qw(-w %{http_code});
1197 my $json = cmdoutput @cmd;
1198 unless ($json =~ s/\d+\d+\d$//) {
1199 failedcmd_report_cmd undef, @cmd;
1200 fail __ "curl failed to print 3-digit HTTP code";
1203 return undef if $code eq '404' && $ok404;
1204 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1205 unless $url =~ m#^file://# or $code =~ m/^2/;
1206 return decode_json($json);
1209 sub canonicalise_suite_ftpmasterapi {
1210 my ($proto,$data) = @_;
1211 my $suites = api_query($data, 'suites');
1213 foreach my $entry (@$suites) {
1215 my $v = $entry->{$_};
1216 defined $v && $v eq $isuite;
1217 } qw(codename name);
1218 push @matched, $entry;
1220 fail f_ "unknown suite %s, maybe -d would help", $isuite
1224 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1225 $cn = "$matched[0]{codename}";
1226 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1227 $cn =~ m/^$suite_re$/
1228 or die f_ "suite %s maps to bad codename\n", $isuite;
1230 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1235 sub archive_query_ftpmasterapi {
1236 my ($proto,$data) = @_;
1237 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1239 my $digester = Digest::SHA->new(256);
1240 foreach my $entry (@$info) {
1242 my $vsn = "$entry->{version}";
1243 my ($ok,$msg) = version_check $vsn;
1244 die f_ "bad version: %s\n", $msg unless $ok;
1245 my $component = "$entry->{component}";
1246 $component =~ m/^$component_re$/ or die __ "bad component";
1247 my $filename = "$entry->{filename}";
1248 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1249 or die __ "bad filename";
1250 my $sha256sum = "$entry->{sha256sum}";
1251 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1252 push @rows, [ $vsn, "/pool/$component/$filename",
1253 $digester, $sha256sum ];
1255 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1258 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1259 return archive_query_prepend_mirror @rows;
1262 sub file_in_archive_ftpmasterapi {
1263 my ($proto,$data,$filename) = @_;
1264 my $pat = $filename;
1267 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1268 my $info = api_query($data, "file_in_archive/$pat", 1);
1271 sub package_not_wholly_new_ftpmasterapi {
1272 my ($proto,$data,$pkg) = @_;
1273 my $info = api_query($data,"madison?package=${pkg}&f=json");
1277 #---------- `aptget' archive query method ----------
1280 our $aptget_releasefile;
1281 our $aptget_configpath;
1283 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1284 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1286 sub aptget_cache_clean {
1287 runcmd_ordryrun_local qw(sh -ec),
1288 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1292 sub aptget_lock_acquire () {
1293 my $lockfile = "$aptget_base/lock";
1294 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1295 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1298 sub aptget_prep ($) {
1300 return if defined $aptget_base;
1302 badcfg __ "aptget archive query method takes no data part"
1305 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1308 ensuredir "$cache/dgit";
1310 access_cfg('aptget-cachekey','RETURN-UNDEF')
1311 // access_nomdistro();
1313 $aptget_base = "$cache/dgit/aptget";
1314 ensuredir $aptget_base;
1316 my $quoted_base = $aptget_base;
1317 confess "$quoted_base contains bad chars, cannot continue"
1318 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1320 ensuredir $aptget_base;
1322 aptget_lock_acquire();
1324 aptget_cache_clean();
1326 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1327 my $sourceslist = "source.list#$cachekey";
1329 my $aptsuites = $isuite;
1330 cfg_apply_map(\$aptsuites, 'suite map',
1331 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1333 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1334 printf SRCS "deb-src %s %s %s\n",
1335 access_cfg('mirror'),
1337 access_cfg('aptget-components')
1340 ensuredir "$aptget_base/cache";
1341 ensuredir "$aptget_base/lists";
1343 open CONF, ">", $aptget_configpath or confess "$!";
1345 Debug::NoLocking "true";
1346 APT::Get::List-Cleanup "false";
1347 #clear APT::Update::Post-Invoke-Success;
1348 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1349 Dir::State::Lists "$quoted_base/lists";
1350 Dir::Etc::preferences "$quoted_base/preferences";
1351 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1352 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1355 foreach my $key (qw(
1358 Dir::Cache::Archives
1359 Dir::Etc::SourceParts
1360 Dir::Etc::preferencesparts
1362 ensuredir "$aptget_base/$key";
1363 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1366 my $oldatime = (time // confess "$!") - 1;
1367 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1368 next unless stat_exists $oldlist;
1369 my ($mtime) = (stat _)[9];
1370 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1373 runcmd_ordryrun_local aptget_aptget(), qw(update);
1376 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1377 next unless stat_exists $oldlist;
1378 my ($atime) = (stat _)[8];
1379 next if $atime == $oldatime;
1380 push @releasefiles, $oldlist;
1382 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1383 @releasefiles = @inreleasefiles if @inreleasefiles;
1384 if (!@releasefiles) {
1385 fail f_ <<END, $isuite, $cache;
1386 apt seemed to not to update dgit's cached Release files for %s.
1388 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1391 confess "apt updated too many Release files (@releasefiles), erk"
1392 unless @releasefiles == 1;
1394 ($aptget_releasefile) = @releasefiles;
1397 sub canonicalise_suite_aptget {
1398 my ($proto,$data) = @_;
1401 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1403 foreach my $name (qw(Codename Suite)) {
1404 my $val = $release->{$name};
1406 printdebug "release file $name: $val\n";
1407 $val =~ m/^$suite_re$/o or fail f_
1408 "Release file (%s) specifies intolerable %s",
1409 $aptget_releasefile, $name;
1410 cfg_apply_map(\$val, 'suite rmap',
1411 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1418 sub archive_query_aptget {
1419 my ($proto,$data) = @_;
1422 ensuredir "$aptget_base/source";
1423 foreach my $old (<$aptget_base/source/*.dsc>) {
1424 unlink $old or die "$old: $!";
1427 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1428 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1429 # avoids apt-get source failing with ambiguous error code
1431 runcmd_ordryrun_local
1432 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1433 aptget_aptget(), qw(--download-only --only-source source), $package;
1435 my @dscs = <$aptget_base/source/*.dsc>;
1436 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1437 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1440 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1443 my $uri = "file://". uri_escape $dscs[0];
1444 $uri =~ s{\%2f}{/}gi;
1445 return [ (getfield $pre_dsc, 'Version'), $uri ];
1448 sub file_in_archive_aptget () { return undef; }
1449 sub package_not_wholly_new_aptget () { return undef; }
1451 #---------- `dummyapicat' archive query method ----------
1452 # (untranslated, because this is for testing purposes etc.)
1454 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1455 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1457 sub dummycatapi_run_in_mirror ($@) {
1458 # runs $fn with FIA open onto rune
1459 my ($rune, $argl, $fn) = @_;
1461 my $mirror = access_cfg('mirror');
1462 $mirror =~ s#^file://#/# or die "$mirror ?";
1463 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1464 qw(x), $mirror, @$argl);
1465 debugcmd "-|", @cmd;
1466 open FIA, "-|", @cmd or confess "$!";
1468 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1472 sub file_in_archive_dummycatapi ($$$) {
1473 my ($proto,$data,$filename) = @_;
1475 dummycatapi_run_in_mirror '
1476 find -name "$1" -print0 |
1478 ', [$filename], sub {
1481 printdebug "| $_\n";
1482 m/^(\w+) (\S+)$/ or die "$_ ?";
1483 push @out, { sha256sum => $1, filename => $2 };
1489 sub package_not_wholly_new_dummycatapi {
1490 my ($proto,$data,$pkg) = @_;
1491 dummycatapi_run_in_mirror "
1492 find -name ${pkg}_*.dsc
1499 #---------- `madison' archive query method ----------
1501 sub archive_query_madison {
1502 return archive_query_prepend_mirror
1503 map { [ @$_[0..1] ] } madison_get_parse(@_);
1506 sub madison_get_parse {
1507 my ($proto,$data) = @_;
1508 die unless $proto eq 'madison';
1509 if (!length $data) {
1510 $data= access_cfg('madison-distro','RETURN-UNDEF');
1511 $data //= access_basedistro();
1513 $rmad{$proto,$data,$package} ||= cmdoutput
1514 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1515 my $rmad = $rmad{$proto,$data,$package};
1518 foreach my $l (split /\n/, $rmad) {
1519 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1520 \s*( [^ \t|]+ )\s* \|
1521 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1522 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1523 $1 eq $package or die "$rmad $package ?";
1530 $component = access_cfg('archive-query-default-component');
1532 $5 eq 'source' or die "$rmad ?";
1533 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1535 return sort { -version_compare($a->[0],$b->[0]); } @out;
1538 sub canonicalise_suite_madison {
1539 # madison canonicalises for us
1540 my @r = madison_get_parse(@_);
1542 "unable to canonicalise suite using package %s".
1543 " which does not appear to exist in suite %s;".
1544 " --existing-package may help",
1549 sub file_in_archive_madison { return undef; }
1550 sub package_not_wholly_new_madison { return undef; }
1552 #---------- `sshpsql' archive query method ----------
1553 # (untranslated, because this is obsolete)
1556 my ($data,$runeinfo,$sql) = @_;
1557 if (!length $data) {
1558 $data= access_someuserhost('sshpsql').':'.
1559 access_cfg('sshpsql-dbname');
1561 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1562 my ($userhost,$dbname) = ($`,$'); #';
1564 my @cmd = (access_cfg_ssh, $userhost,
1565 access_runeinfo("ssh-psql $runeinfo").
1566 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1567 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1569 open P, "-|", @cmd or confess "$!";
1572 printdebug(">|$_|\n");
1575 $!=0; $?=0; close P or failedcmd @cmd;
1577 my $nrows = pop @rows;
1578 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1579 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1580 @rows = map { [ split /\|/, $_ ] } @rows;
1581 my $ncols = scalar @{ shift @rows };
1582 die if grep { scalar @$_ != $ncols } @rows;
1586 sub sql_injection_check {
1587 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1590 sub archive_query_sshpsql ($$) {
1591 my ($proto,$data) = @_;
1592 sql_injection_check $isuite, $package;
1593 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1594 SELECT source.version, component.name, files.filename, files.sha256sum
1596 JOIN src_associations ON source.id = src_associations.source
1597 JOIN suite ON suite.id = src_associations.suite
1598 JOIN dsc_files ON dsc_files.source = source.id
1599 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1600 JOIN component ON component.id = files_archive_map.component_id
1601 JOIN files ON files.id = dsc_files.file
1602 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1603 AND source.source='$package'
1604 AND files.filename LIKE '%.dsc';
1606 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1607 my $digester = Digest::SHA->new(256);
1609 my ($vsn,$component,$filename,$sha256sum) = @$_;
1610 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1612 return archive_query_prepend_mirror @rows;
1615 sub canonicalise_suite_sshpsql ($$) {
1616 my ($proto,$data) = @_;
1617 sql_injection_check $isuite;
1618 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1619 SELECT suite.codename
1620 FROM suite where suite_name='$isuite' or codename='$isuite';
1622 @rows = map { $_->[0] } @rows;
1623 fail "unknown suite $isuite" unless @rows;
1624 die "ambiguous $isuite: @rows ?" if @rows>1;
1628 sub file_in_archive_sshpsql ($$$) { return undef; }
1629 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1631 #---------- `dummycat' archive query method ----------
1632 # (untranslated, because this is for testing purposes etc.)
1634 sub canonicalise_suite_dummycat ($$) {
1635 my ($proto,$data) = @_;
1636 my $dpath = "$data/suite.$isuite";
1637 if (!open C, "<", $dpath) {
1638 $!==ENOENT or die "$dpath: $!";
1639 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1643 chomp or die "$dpath: $!";
1645 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1649 sub archive_query_dummycat ($$) {
1650 my ($proto,$data) = @_;
1651 canonicalise_suite();
1652 my $dpath = "$data/package.$csuite.$package";
1653 if (!open C, "<", $dpath) {
1654 $!==ENOENT or die "$dpath: $!";
1655 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1663 printdebug "dummycat query $csuite $package $dpath | $_\n";
1664 my @row = split /\s+/, $_;
1665 @row==2 or die "$dpath: $_ ?";
1668 C->error and die "$dpath: $!";
1670 return archive_query_prepend_mirror
1671 sort { -version_compare($a->[0],$b->[0]); } @rows;
1674 sub file_in_archive_dummycat () { return undef; }
1675 sub package_not_wholly_new_dummycat () { return undef; }
1677 #---------- archive query entrypoints and rest of program ----------
1679 sub canonicalise_suite () {
1680 return if defined $csuite;
1681 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1682 $csuite = archive_query('canonicalise_suite');
1683 if ($isuite ne $csuite) {
1684 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1686 progress f_ "canonical suite name is %s", $csuite;
1690 sub get_archive_dsc () {
1691 canonicalise_suite();
1692 my @vsns = archive_query('archive_query');
1693 foreach my $vinfo (@vsns) {
1694 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1695 $dscurl = $vsn_dscurl;
1696 $dscdata = url_get($dscurl);
1698 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1703 $digester->add($dscdata);
1704 my $got = $digester->hexdigest();
1706 fail f_ "%s has hash %s but archive told us to expect %s",
1707 $dscurl, $got, $digest;
1710 my $fmt = getfield $dsc, 'Format';
1711 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1712 f_ "unsupported source format %s, sorry", $fmt;
1714 $dsc_checked = !!$digester;
1715 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1719 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1722 sub check_for_git ();
1723 sub check_for_git () {
1725 my $how = access_cfg('git-check');
1726 if ($how eq 'ssh-cmd') {
1728 (access_cfg_ssh, access_gituserhost(),
1729 access_runeinfo("git-check $package").
1730 " set -e; cd ".access_cfg('git-path').";".
1731 " if test -d $package.git; then echo 1; else echo 0; fi");
1732 my $r= cmdoutput @cmd;
1733 if (defined $r and $r =~ m/^divert (\w+)$/) {
1735 my ($usedistro,) = access_distros();
1736 # NB that if we are pushing, $usedistro will be $distro/push
1737 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1738 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1739 progress f_ "diverting to %s (using config for %s)",
1740 $divert, $instead_distro;
1741 return check_for_git();
1743 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1745 } elsif ($how eq 'url') {
1746 my $prefix = access_cfg('git-check-url','git-url');
1747 my $suffix = access_cfg('git-check-suffix','git-suffix',
1748 'RETURN-UNDEF') // '.git';
1749 my $url = "$prefix/$package$suffix";
1750 my @cmd = (@curl, qw(-sS -I), $url);
1751 my $result = cmdoutput @cmd;
1752 $result =~ s/^\S+ 200 .*\n\r?\n//;
1753 # curl -sS -I with https_proxy prints
1754 # HTTP/1.0 200 Connection established
1755 $result =~ m/^\S+ (404|200) /s or
1756 fail +(__ "unexpected results from git check query - ").
1757 Dumper($prefix, $result);
1759 if ($code eq '404') {
1761 } elsif ($code eq '200') {
1766 } elsif ($how eq 'true') {
1768 } elsif ($how eq 'false') {
1771 badcfg f_ "unknown git-check \`%s'", $how;
1775 sub create_remote_git_repo () {
1776 my $how = access_cfg('git-create');
1777 if ($how eq 'ssh-cmd') {
1779 (access_cfg_ssh, access_gituserhost(),
1780 access_runeinfo("git-create $package").
1781 "set -e; cd ".access_cfg('git-path').";".
1782 " cp -a _template $package.git");
1783 } elsif ($how eq 'true') {
1786 badcfg f_ "unknown git-create \`%s'", $how;
1790 our ($dsc_hash,$lastpush_mergeinput);
1791 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1795 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1796 $playground = fresh_playground 'dgit/unpack';
1799 sub mktree_in_ud_here () {
1800 playtree_setup $gitcfgs{local};
1803 sub git_write_tree () {
1804 my $tree = cmdoutput @git, qw(write-tree);
1805 $tree =~ m/^\w+$/ or die "$tree ?";
1809 sub git_add_write_tree () {
1810 runcmd @git, qw(add -Af .);
1811 return git_write_tree();
1814 sub remove_stray_gits ($) {
1816 my @gitscmd = qw(find -name .git -prune -print0);
1817 debugcmd "|",@gitscmd;
1818 open GITS, "-|", @gitscmd or confess "$!";
1823 print STDERR f_ "%s: warning: removing from %s: %s\n",
1824 $us, $what, (messagequote $_);
1828 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1831 sub mktree_in_ud_from_only_subdir ($;$) {
1832 my ($what,$raw) = @_;
1833 # changes into the subdir
1836 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1837 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1841 remove_stray_gits($what);
1842 mktree_in_ud_here();
1844 my ($format, $fopts) = get_source_format();
1845 if (madformat($format)) {
1850 my $tree=git_add_write_tree();
1851 return ($tree,$dir);
1854 our @files_csum_info_fields =
1855 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1856 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1857 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1859 sub dsc_files_info () {
1860 foreach my $csumi (@files_csum_info_fields) {
1861 my ($fname, $module, $method) = @$csumi;
1862 my $field = $dsc->{$fname};
1863 next unless defined $field;
1864 eval "use $module; 1;" or die $@;
1866 foreach (split /\n/, $field) {
1868 m/^(\w+) (\d+) (\S+)$/ or
1869 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1870 my $digester = eval "$module"."->$method;" or die $@;
1875 Digester => $digester,
1880 fail f_ "missing any supported Checksums-* or Files field in %s",
1881 $dsc->get_option('name');
1885 map { $_->{Filename} } dsc_files_info();
1888 sub files_compare_inputs (@) {
1893 my $showinputs = sub {
1894 return join "; ", map { $_->get_option('name') } @$inputs;
1897 foreach my $in (@$inputs) {
1899 my $in_name = $in->get_option('name');
1901 printdebug "files_compare_inputs $in_name\n";
1903 foreach my $csumi (@files_csum_info_fields) {
1904 my ($fname) = @$csumi;
1905 printdebug "files_compare_inputs $in_name $fname\n";
1907 my $field = $in->{$fname};
1908 next unless defined $field;
1911 foreach (split /\n/, $field) {
1914 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1915 fail "could not parse $in_name $fname line \`$_'";
1917 printdebug "files_compare_inputs $in_name $fname $f\n";
1921 my $re = \ $record{$f}{$fname};
1923 $fchecked{$f}{$in_name} = 1;
1926 "hash or size of %s varies in %s fields (between: %s)",
1927 $f, $fname, $showinputs->();
1932 @files = sort @files;
1933 $expected_files //= \@files;
1934 "@$expected_files" eq "@files" or
1935 fail f_ "file list in %s varies between hash fields!",
1939 fail f_ "%s has no files list field(s)", $in_name;
1941 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1944 grep { keys %$_ == @$inputs-1 } values %fchecked
1945 or fail f_ "no file appears in all file lists (looked in: %s)",
1949 sub is_orig_file_in_dsc ($$) {
1950 my ($f, $dsc_files_info) = @_;
1951 return 0 if @$dsc_files_info <= 1;
1952 # One file means no origs, and the filename doesn't have a "what
1953 # part of dsc" component. (Consider versions ending `.orig'.)
1954 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1958 # This function determines whether a .changes file is source-only from
1959 # the point of view of dak. Thus, it permits *_source.buildinfo
1962 # It does not, however, permit any other buildinfo files. After a
1963 # source-only upload, the buildds will try to upload files like
1964 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1965 # named like this in their (otherwise) source-only upload, the uploads
1966 # of the buildd can be rejected by dak. Fixing the resultant
1967 # situation can require manual intervention. So we block such
1968 # .buildinfo files when the user tells us to perform a source-only
1969 # upload (such as when using the push-source subcommand with the -C
1970 # option, which calls this function).
1972 # Note, though, that when dgit is told to prepare a source-only
1973 # upload, such as when subcommands like build-source and push-source
1974 # without -C are used, dgit has a more restrictive notion of
1975 # source-only .changes than dak: such uploads will never include
1976 # *_source.buildinfo files. This is because there is no use for such
1977 # files when using a tool like dgit to produce the source package, as
1978 # dgit ensures the source is identical to git HEAD.
1979 sub test_source_only_changes ($) {
1981 foreach my $l (split /\n/, getfield $changes, 'Files') {
1982 $l =~ m/\S+$/ or next;
1983 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1984 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1985 print f_ "purportedly source-only changes polluted by %s\n", $&;
1992 sub changes_update_origs_from_dsc ($$$$) {
1993 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1995 printdebug "checking origs needed ($upstreamvsn)...\n";
1996 $_ = getfield $changes, 'Files';
1997 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1998 fail __ "cannot find section/priority from .changes Files field";
1999 my $placementinfo = $1;
2001 printdebug "checking origs needed placement '$placementinfo'...\n";
2002 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2003 $l =~ m/\S+$/ or next;
2005 printdebug "origs $file | $l\n";
2006 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2007 printdebug "origs $file is_orig\n";
2008 my $have = archive_query('file_in_archive', $file);
2009 if (!defined $have) {
2010 print STDERR __ <<END;
2011 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2017 printdebug "origs $file \$#\$have=$#$have\n";
2018 foreach my $h (@$have) {
2021 foreach my $csumi (@files_csum_info_fields) {
2022 my ($fname, $module, $method, $archivefield) = @$csumi;
2023 next unless defined $h->{$archivefield};
2024 $_ = $dsc->{$fname};
2025 next unless defined;
2026 m/^(\w+) .* \Q$file\E$/m or
2027 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2028 if ($h->{$archivefield} eq $1) {
2032 "%s: %s (archive) != %s (local .dsc)",
2033 $archivefield, $h->{$archivefield}, $1;
2036 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2040 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2043 printdebug "origs $file f.same=$found_same".
2044 " #f._differ=$#found_differ\n";
2045 if (@found_differ && !$found_same) {
2047 (f_ "archive contains %s with different checksum", $file),
2050 # Now we edit the changes file to add or remove it
2051 foreach my $csumi (@files_csum_info_fields) {
2052 my ($fname, $module, $method, $archivefield) = @$csumi;
2053 next unless defined $changes->{$fname};
2055 # in archive, delete from .changes if it's there
2056 $changed{$file} = "removed" if
2057 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2058 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2059 # not in archive, but it's here in the .changes
2061 my $dsc_data = getfield $dsc, $fname;
2062 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2064 $extra =~ s/ \d+ /$&$placementinfo /
2065 or confess "$fname $extra >$dsc_data< ?"
2066 if $fname eq 'Files';
2067 $changes->{$fname} .= "\n". $extra;
2068 $changed{$file} = "added";
2073 foreach my $file (keys %changed) {
2075 "edited .changes for archive .orig contents: %s %s",
2076 $changed{$file}, $file;
2078 my $chtmp = "$changesfile.tmp";
2079 $changes->save($chtmp);
2081 rename $chtmp,$changesfile or die "$changesfile $!";
2083 progress f_ "[new .changes left in %s]", $changesfile;
2086 progress f_ "%s already has appropriate .orig(s) (if any)",
2091 sub make_commit ($) {
2093 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2096 sub clogp_authline ($) {
2098 my $author = getfield $clogp, 'Maintainer';
2099 if ($author =~ m/^[^"\@]+\,/) {
2100 # single entry Maintainer field with unquoted comma
2101 $author = ($& =~ y/,//rd).$'; # strip the comma
2103 # git wants a single author; any remaining commas in $author
2104 # are by now preceded by @ (or "). It seems safer to punt on
2105 # "..." for now rather than attempting to dequote or something.
2106 $author =~ s#,.*##ms unless $author =~ m/"/;
2107 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2108 my $authline = "$author $date";
2109 $authline =~ m/$git_authline_re/o or
2110 fail f_ "unexpected commit author line format \`%s'".
2111 " (was generated from changelog Maintainer field)",
2113 return ($1,$2,$3) if wantarray;
2117 sub vendor_patches_distro ($$) {
2118 my ($checkdistro, $what) = @_;
2119 return unless defined $checkdistro;
2121 my $series = "debian/patches/\L$checkdistro\E.series";
2122 printdebug "checking for vendor-specific $series ($what)\n";
2124 if (!open SERIES, "<", $series) {
2125 confess "$series $!" unless $!==ENOENT;
2132 print STDERR __ <<END;
2134 Unfortunately, this source package uses a feature of dpkg-source where
2135 the same source package unpacks to different source code on different
2136 distros. dgit cannot safely operate on such packages on affected
2137 distros, because the meaning of source packages is not stable.
2139 Please ask the distro/maintainer to remove the distro-specific series
2140 files and use a different technique (if necessary, uploading actually
2141 different packages, if different distros are supposed to have
2145 fail f_ "Found active distro-specific series file for".
2146 " %s (%s): %s, cannot continue",
2147 $checkdistro, $what, $series;
2149 die "$series $!" if SERIES->error;
2153 sub check_for_vendor_patches () {
2154 # This dpkg-source feature doesn't seem to be documented anywhere!
2155 # But it can be found in the changelog (reformatted):
2157 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2158 # Author: Raphael Hertzog <hertzog@debian.org>
2159 # Date: Sun Oct 3 09:36:48 2010 +0200
2161 # dpkg-source: correctly create .pc/.quilt_series with alternate
2164 # If you have debian/patches/ubuntu.series and you were
2165 # unpacking the source package on ubuntu, quilt was still
2166 # directed to debian/patches/series instead of
2167 # debian/patches/ubuntu.series.
2169 # debian/changelog | 3 +++
2170 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2171 # 2 files changed, 6 insertions(+), 1 deletion(-)
2174 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2175 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2176 __ "Dpkg::Vendor \`current vendor'");
2177 vendor_patches_distro(access_basedistro(),
2178 __ "(base) distro being accessed");
2179 vendor_patches_distro(access_nomdistro(),
2180 __ "(nominal) distro being accessed");
2183 sub check_bpd_exists () {
2184 stat $buildproductsdir
2185 or fail f_ "build-products-dir %s is not accessible: %s\n",
2186 $buildproductsdir, $!;
2189 sub dotdot_bpd_transfer_origs ($$$) {
2190 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2191 # checks is_orig_file_of_vsn and if
2192 # calls $wanted->{$leaf} and expects boolish
2194 return if $buildproductsdir eq '..';
2197 my $dotdot = $maindir;
2198 $dotdot =~ s{/[^/]+$}{};
2199 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2200 while ($!=0, defined(my $leaf = readdir DD)) {
2202 local ($debuglevel) = $debuglevel-1;
2203 printdebug "DD_BPD $leaf ?\n";
2205 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2206 next unless $wanted->($leaf);
2207 next if lstat "$bpd_abs/$leaf";
2210 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2213 $! == &ENOENT or fail f_
2214 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2215 lstat "$dotdot/$leaf" or fail f_
2216 "check orig file %s in ..: %s", $leaf, $!;
2218 stat "$dotdot/$leaf" or fail f_
2219 "check target of orig symlink %s in ..: %s", $leaf, $!;
2220 my $ltarget = readlink "$dotdot/$leaf" or
2221 die "readlink $dotdot/$leaf: $!";
2222 if ($ltarget !~ m{^/}) {
2223 $ltarget = "$dotdot/$ltarget";
2225 symlink $ltarget, "$bpd_abs/$leaf"
2226 or die "$ltarget $bpd_abs $leaf: $!";
2228 "%s: cloned orig symlink from ..: %s\n",
2230 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2232 "%s: hardlinked orig from ..: %s\n",
2234 } elsif ($! != EXDEV) {
2235 fail f_ "failed to make %s a hardlink to %s: %s",
2236 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2238 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2239 or die "$bpd_abs $dotdot $leaf $!";
2241 "%s: symmlinked orig from .. on other filesystem: %s\n",
2245 die "$dotdot; $!" if $!;
2249 sub generate_commits_from_dsc () {
2250 # See big comment in fetch_from_archive, below.
2251 # See also README.dsc-import.
2253 changedir $playground;
2255 my $bpd_abs = bpd_abs();
2256 my $upstreamv = upstreamversion $dsc->{version};
2257 my @dfi = dsc_files_info();
2259 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2260 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2262 foreach my $fi (@dfi) {
2263 my $f = $fi->{Filename};
2264 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2265 my $upper_f = "$bpd_abs/$f";
2267 printdebug "considering reusing $f: ";
2269 if (link_ltarget "$upper_f,fetch", $f) {
2270 printdebug "linked (using ...,fetch).\n";
2271 } elsif ((printdebug "($!) "),
2273 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2274 } elsif (link_ltarget $upper_f, $f) {
2275 printdebug "linked.\n";
2276 } elsif ((printdebug "($!) "),
2278 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2280 printdebug "absent.\n";
2284 complete_file_from_dsc('.', $fi, \$refetched)
2287 printdebug "considering saving $f: ";
2289 if (rename_link_xf 1, $f, $upper_f) {
2290 printdebug "linked.\n";
2291 } elsif ((printdebug "($@) "),
2293 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2294 } elsif (!$refetched) {
2295 printdebug "no need.\n";
2296 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2297 printdebug "linked (using ...,fetch).\n";
2298 } elsif ((printdebug "($@) "),
2300 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2302 printdebug "cannot.\n";
2306 # We unpack and record the orig tarballs first, so that we only
2307 # need disk space for one private copy of the unpacked source.
2308 # But we can't make them into commits until we have the metadata
2309 # from the debian/changelog, so we record the tree objects now and
2310 # make them into commits later.
2312 my $orig_f_base = srcfn $upstreamv, '';
2314 foreach my $fi (@dfi) {
2315 # We actually import, and record as a commit, every tarball
2316 # (unless there is only one file, in which case there seems
2319 my $f = $fi->{Filename};
2320 printdebug "import considering $f ";
2321 (printdebug "only one dfi\n"), next if @dfi == 1;
2322 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2323 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2327 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2329 printdebug "Y ", (join ' ', map { $_//"(none)" }
2330 $compr_ext, $orig_f_part
2333 my $input = new IO::File $f, '<' or die "$f $!";
2337 if (defined $compr_ext) {
2339 Dpkg::Compression::compression_guess_from_filename $f;
2340 fail "Dpkg::Compression cannot handle file $f in source package"
2341 if defined $compr_ext && !defined $cname;
2343 new Dpkg::Compression::Process compression => $cname;
2344 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2345 my $compr_fh = new IO::Handle;
2346 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2348 open STDIN, "<&", $input or confess "$!";
2350 die "dgit (child): exec $compr_cmd[0]: $!\n";
2355 rmtree "_unpack-tar";
2356 mkdir "_unpack-tar" or confess "$!";
2357 my @tarcmd = qw(tar -x -f -
2358 --no-same-owner --no-same-permissions
2359 --no-acls --no-xattrs --no-selinux);
2360 my $tar_pid = fork // confess "$!";
2362 chdir "_unpack-tar" or confess "$!";
2363 open STDIN, "<&", $input or confess "$!";
2365 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2367 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2368 !$? or failedcmd @tarcmd;
2371 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2373 # finally, we have the results in "tarball", but maybe
2374 # with the wrong permissions
2376 runcmd qw(chmod -R +rwX _unpack-tar);
2377 changedir "_unpack-tar";
2378 remove_stray_gits($f);
2379 mktree_in_ud_here();
2381 my ($tree) = git_add_write_tree();
2382 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2383 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2385 printdebug "one subtree $1\n";
2387 printdebug "multiple subtrees\n";
2390 rmtree "_unpack-tar";
2392 my $ent = [ $f, $tree ];
2394 Orig => !!$orig_f_part,
2395 Sort => (!$orig_f_part ? 2 :
2396 $orig_f_part =~ m/-/g ? 1 :
2404 # put any without "_" first (spec is not clear whether files
2405 # are always in the usual order). Tarballs without "_" are
2406 # the main orig or the debian tarball.
2407 $a->{Sort} <=> $b->{Sort} or
2411 my $any_orig = grep { $_->{Orig} } @tartrees;
2413 my $dscfn = "$package.dsc";
2415 my $treeimporthow = 'package';
2417 open D, ">", $dscfn or die "$dscfn: $!";
2418 print D $dscdata or die "$dscfn: $!";
2419 close D or die "$dscfn: $!";
2420 my @cmd = qw(dpkg-source);
2421 push @cmd, '--no-check' if $dsc_checked;
2422 if (madformat $dsc->{format}) {
2423 push @cmd, '--skip-patches';
2424 $treeimporthow = 'unpatched';
2426 push @cmd, qw(-x --), $dscfn;
2429 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2430 if (madformat $dsc->{format}) {
2431 check_for_vendor_patches();
2435 if (madformat $dsc->{format}) {
2436 my @pcmd = qw(dpkg-source --before-build .);
2437 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2439 $dappliedtree = git_add_write_tree();
2442 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2446 printdebug "import clog search...\n";
2447 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2448 my ($thisstanza, $desc) = @_;
2449 no warnings qw(exiting);
2451 $clogp //= $thisstanza;
2453 printdebug "import clog $thisstanza->{version} $desc...\n";
2455 last if !$any_orig; # we don't need $r1clogp
2457 # We look for the first (most recent) changelog entry whose
2458 # version number is lower than the upstream version of this
2459 # package. Then the last (least recent) previous changelog
2460 # entry is treated as the one which introduced this upstream
2461 # version and used for the synthetic commits for the upstream
2464 # One might think that a more sophisticated algorithm would be
2465 # necessary. But: we do not want to scan the whole changelog
2466 # file. Stopping when we see an earlier version, which
2467 # necessarily then is an earlier upstream version, is the only
2468 # realistic way to do that. Then, either the earliest
2469 # changelog entry we have seen so far is indeed the earliest
2470 # upload of this upstream version; or there are only changelog
2471 # entries relating to later upstream versions (which is not
2472 # possible unless the changelog and .dsc disagree about the
2473 # version). Then it remains to choose between the physically
2474 # last entry in the file, and the one with the lowest version
2475 # number. If these are not the same, we guess that the
2476 # versions were created in a non-monotonic order rather than
2477 # that the changelog entries have been misordered.
2479 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2481 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2482 $r1clogp = $thisstanza;
2484 printdebug "import clog $r1clogp->{version} becomes r1\n";
2487 $clogp or fail __ "package changelog has no entries!";
2489 my $authline = clogp_authline $clogp;
2490 my $changes = getfield $clogp, 'Changes';
2491 $changes =~ s/^\n//; # Changes: \n
2492 my $cversion = getfield $clogp, 'Version';
2495 $r1clogp //= $clogp; # maybe there's only one entry;
2496 my $r1authline = clogp_authline $r1clogp;
2497 # Strictly, r1authline might now be wrong if it's going to be
2498 # unused because !$any_orig. Whatever.
2500 printdebug "import tartrees authline $authline\n";
2501 printdebug "import tartrees r1authline $r1authline\n";
2503 foreach my $tt (@tartrees) {
2504 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2506 my $mbody = f_ "Import %s", $tt->{F};
2507 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2510 committer $r1authline
2514 [dgit import orig $tt->{F}]
2522 [dgit import tarball $package $cversion $tt->{F}]
2527 printdebug "import main commit\n";
2529 open C, ">../commit.tmp" or confess "$!";
2530 print C <<END or confess "$!";
2533 print C <<END or confess "$!" foreach @tartrees;
2536 print C <<END or confess "$!";
2542 [dgit import $treeimporthow $package $cversion]
2545 close C or confess "$!";
2546 my $rawimport_hash = make_commit qw(../commit.tmp);
2548 if (madformat $dsc->{format}) {
2549 printdebug "import apply patches...\n";
2551 # regularise the state of the working tree so that
2552 # the checkout of $rawimport_hash works nicely.
2553 my $dappliedcommit = make_commit_text(<<END);
2560 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2562 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2564 # We need the answers to be reproducible
2565 my @authline = clogp_authline($clogp);
2566 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2567 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2568 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2569 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2570 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2571 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2573 my $path = $ENV{PATH} or die;
2575 # we use ../../gbp-pq-output, which (given that we are in
2576 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2579 foreach my $use_absurd (qw(0 1)) {
2580 runcmd @git, qw(checkout -q unpa);
2581 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2582 local $ENV{PATH} = $path;
2585 progress "warning: $@";
2586 $path = "$absurdity:$path";
2587 progress f_ "%s: trying slow absurd-git-apply...", $us;
2588 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2593 die "forbid absurd git-apply\n" if $use_absurd
2594 && forceing [qw(import-gitapply-no-absurd)];
2595 die "only absurd git-apply!\n" if !$use_absurd
2596 && forceing [qw(import-gitapply-absurd)];
2598 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2599 local $ENV{PATH} = $path if $use_absurd;
2601 my @showcmd = (gbp_pq, qw(import));
2602 my @realcmd = shell_cmd
2603 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2604 debugcmd "+",@realcmd;
2605 if (system @realcmd) {
2606 die f_ "%s failed: %s\n",
2607 +(shellquote @showcmd),
2608 failedcmd_waitstatus();
2611 my $gapplied = git_rev_parse('HEAD');
2612 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2613 $gappliedtree eq $dappliedtree or
2614 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2615 gbp-pq import and dpkg-source disagree!
2616 gbp-pq import gave commit %s
2617 gbp-pq import gave tree %s
2618 dpkg-source --before-build gave tree %s
2620 $rawimport_hash = $gapplied;
2625 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2630 progress f_ "synthesised git commit from .dsc %s", $cversion;
2632 my $rawimport_mergeinput = {
2633 Commit => $rawimport_hash,
2634 Info => __ "Import of source package",
2636 my @output = ($rawimport_mergeinput);
2638 if ($lastpush_mergeinput) {
2639 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2640 my $oversion = getfield $oldclogp, 'Version';
2642 version_compare($oversion, $cversion);
2644 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2645 { ReverseParents => 1,
2646 Message => (f_ <<END, $package, $cversion, $csuite) });
2647 Record %s (%s) in archive suite %s
2649 } elsif ($vcmp > 0) {
2650 print STDERR f_ <<END, $cversion, $oversion,
2652 Version actually in archive: %s (older)
2653 Last version pushed with dgit: %s (newer or same)
2656 __ $later_warning_msg or confess "$!";
2657 @output = $lastpush_mergeinput;
2659 # Same version. Use what's in the server git branch,
2660 # discarding our own import. (This could happen if the
2661 # server automatically imports all packages into git.)
2662 @output = $lastpush_mergeinput;
2670 sub complete_file_from_dsc ($$;$) {
2671 our ($dstdir, $fi, $refetched) = @_;
2672 # Ensures that we have, in $dstdir, the file $fi, with the correct
2673 # contents. (Downloading it from alongside $dscurl if necessary.)
2674 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2675 # and will set $$refetched=1 if it did so (or tried to).
2677 my $f = $fi->{Filename};
2678 my $tf = "$dstdir/$f";
2682 my $checkhash = sub {
2683 open F, "<", "$tf" or die "$tf: $!";
2684 $fi->{Digester}->reset();
2685 $fi->{Digester}->addfile(*F);
2686 F->error and confess "$!";
2687 $got = $fi->{Digester}->hexdigest();
2688 return $got eq $fi->{Hash};
2691 if (stat_exists $tf) {
2692 if ($checkhash->()) {
2693 progress f_ "using existing %s", $f;
2697 fail f_ "file %s has hash %s but .dsc demands hash %s".
2698 " (perhaps you should delete this file?)",
2699 $f, $got, $fi->{Hash};
2701 progress f_ "need to fetch correct version of %s", $f;
2702 unlink $tf or die "$tf $!";
2705 printdebug "$tf does not exist, need to fetch\n";
2709 $furl =~ s{/[^/]+$}{};
2711 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2712 die "$f ?" if $f =~ m#/#;
2713 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2714 return 0 if !act_local();
2717 fail f_ "file %s has hash %s but .dsc demands hash %s".
2718 " (got wrong file from archive!)",
2719 $f, $got, $fi->{Hash};
2724 sub ensure_we_have_orig () {
2725 my @dfi = dsc_files_info();
2726 foreach my $fi (@dfi) {
2727 my $f = $fi->{Filename};
2728 next unless is_orig_file_in_dsc($f, \@dfi);
2729 complete_file_from_dsc($buildproductsdir, $fi)
2734 #---------- git fetch ----------
2736 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2737 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2739 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2740 # locally fetched refs because they have unhelpful names and clutter
2741 # up gitk etc. So we track whether we have "used up" head ref (ie,
2742 # whether we have made another local ref which refers to this object).
2744 # (If we deleted them unconditionally, then we might end up
2745 # re-fetching the same git objects each time dgit fetch was run.)
2747 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2748 # in git_fetch_us to fetch the refs in question, and possibly a call
2749 # to lrfetchref_used.
2751 our (%lrfetchrefs_f, %lrfetchrefs_d);
2752 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2754 sub lrfetchref_used ($) {
2755 my ($fullrefname) = @_;
2756 my $objid = $lrfetchrefs_f{$fullrefname};
2757 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2760 sub git_lrfetch_sane {
2761 my ($url, $supplementary, @specs) = @_;
2762 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2763 # at least as regards @specs. Also leave the results in
2764 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2765 # able to clean these up.
2767 # With $supplementary==1, @specs must not contain wildcards
2768 # and we add to our previous fetches (non-atomically).
2770 # This is rather miserable:
2771 # When git fetch --prune is passed a fetchspec ending with a *,
2772 # it does a plausible thing. If there is no * then:
2773 # - it matches subpaths too, even if the supplied refspec
2774 # starts refs, and behaves completely madly if the source
2775 # has refs/refs/something. (See, for example, Debian #NNNN.)
2776 # - if there is no matching remote ref, it bombs out the whole
2778 # We want to fetch a fixed ref, and we don't know in advance
2779 # if it exists, so this is not suitable.
2781 # Our workaround is to use git ls-remote. git ls-remote has its
2782 # own qairks. Notably, it has the absurd multi-tail-matching
2783 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2784 # refs/refs/foo etc.
2786 # Also, we want an idempotent snapshot, but we have to make two
2787 # calls to the remote: one to git ls-remote and to git fetch. The
2788 # solution is use git ls-remote to obtain a target state, and
2789 # git fetch to try to generate it. If we don't manage to generate
2790 # the target state, we try again.
2792 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2794 my $specre = join '|', map {
2797 my $wildcard = $x =~ s/\\\*$/.*/;
2798 die if $wildcard && $supplementary;
2801 printdebug "git_lrfetch_sane specre=$specre\n";
2802 my $wanted_rref = sub {
2804 return m/^(?:$specre)$/;
2807 my $fetch_iteration = 0;
2810 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2811 if (++$fetch_iteration > 10) {
2812 fail __ "too many iterations trying to get sane fetch!";
2815 my @look = map { "refs/$_" } @specs;
2816 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2820 open GITLS, "-|", @lcmd or confess "$!";
2822 printdebug "=> ", $_;
2823 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2824 my ($objid,$rrefname) = ($1,$2);
2825 if (!$wanted_rref->($rrefname)) {
2826 print STDERR f_ <<END, "@look", $rrefname;
2827 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2831 $wantr{$rrefname} = $objid;
2834 close GITLS or failedcmd @lcmd;
2836 # OK, now %want is exactly what we want for refs in @specs
2838 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2839 "+refs/$_:".lrfetchrefs."/$_";
2842 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2844 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2845 runcmd_ordryrun_local @fcmd if @fspecs;
2847 if (!$supplementary) {
2848 %lrfetchrefs_f = ();
2852 git_for_each_ref(lrfetchrefs, sub {
2853 my ($objid,$objtype,$lrefname,$reftail) = @_;
2854 $lrfetchrefs_f{$lrefname} = $objid;
2855 $objgot{$objid} = 1;
2858 if ($supplementary) {
2862 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2863 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2864 if (!exists $wantr{$rrefname}) {
2865 if ($wanted_rref->($rrefname)) {
2867 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2870 print STDERR f_ <<END, "@fspecs", $lrefname
2871 warning: git fetch %s created %s; this is silly, deleting it.
2874 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2875 delete $lrfetchrefs_f{$lrefname};
2879 foreach my $rrefname (sort keys %wantr) {
2880 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2881 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2882 my $want = $wantr{$rrefname};
2883 next if $got eq $want;
2884 if (!defined $objgot{$want}) {
2885 fail __ <<END unless act_local();
2886 --dry-run specified but we actually wanted the results of git fetch,
2887 so this is not going to work. Try running dgit fetch first,
2888 or using --damp-run instead of --dry-run.
2890 print STDERR f_ <<END, $lrefname, $want;
2891 warning: git ls-remote suggests we want %s
2892 warning: and it should refer to %s
2893 warning: but git fetch didn't fetch that object to any relevant ref.
2894 warning: This may be due to a race with someone updating the server.
2895 warning: Will try again...
2897 next FETCH_ITERATION;
2900 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2902 runcmd_ordryrun_local @git, qw(update-ref -m),
2903 "dgit fetch git fetch fixup", $lrefname, $want;
2904 $lrfetchrefs_f{$lrefname} = $want;
2909 if (defined $csuite) {
2910 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2911 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2912 my ($objid,$objtype,$lrefname,$reftail) = @_;
2913 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2914 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2918 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2919 Dumper(\%lrfetchrefs_f);
2922 sub git_fetch_us () {
2923 # Want to fetch only what we are going to use, unless
2924 # deliberately-not-ff, in which case we must fetch everything.
2926 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2927 map { "tags/$_" } debiantags('*',access_nomdistro);
2928 push @specs, server_branch($csuite);
2929 push @specs, $rewritemap;
2930 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2932 my $url = access_giturl();
2933 git_lrfetch_sane $url, 0, @specs;
2936 my @tagpats = debiantags('*',access_nomdistro);
2938 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2939 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2940 printdebug "currently $fullrefname=$objid\n";
2941 $here{$fullrefname} = $objid;
2943 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2944 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2945 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2946 printdebug "offered $lref=$objid\n";
2947 if (!defined $here{$lref}) {
2948 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2949 runcmd_ordryrun_local @upd;
2950 lrfetchref_used $fullrefname;
2951 } elsif ($here{$lref} eq $objid) {
2952 lrfetchref_used $fullrefname;
2954 print STDERR f_ "Not updating %s from %s to %s.\n",
2955 $lref, $here{$lref}, $objid;
2960 #---------- dsc and archive handling ----------
2962 sub mergeinfo_getclogp ($) {
2963 # Ensures thit $mi->{Clogp} exists and returns it
2965 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2968 sub mergeinfo_version ($) {
2969 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2972 sub fetch_from_archive_record_1 ($) {
2974 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2975 cmdoutput @git, qw(log -n2), $hash;
2976 # ... gives git a chance to complain if our commit is malformed
2979 sub fetch_from_archive_record_2 ($) {
2981 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2985 dryrun_report @upd_cmd;
2989 sub parse_dsc_field_def_dsc_distro () {
2990 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2991 dgit.default.distro);
2994 sub parse_dsc_field ($$) {
2995 my ($dsc, $what) = @_;
2997 foreach my $field (@ourdscfield) {
2998 $f = $dsc->{$field};
3003 progress f_ "%s: NO git hash", $what;
3004 parse_dsc_field_def_dsc_distro();
3005 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3006 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3007 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3008 $dsc_hint_tag = [ $dsc_hint_tag ];
3009 } elsif ($f =~ m/^\w+\s*$/) {
3011 parse_dsc_field_def_dsc_distro();
3012 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3014 progress f_ "%s: specified git hash", $what;
3016 fail f_ "%s: invalid Dgit info", $what;
3020 sub resolve_dsc_field_commit ($$) {
3021 my ($already_distro, $already_mapref) = @_;
3023 return unless defined $dsc_hash;
3026 defined $already_mapref &&
3027 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3028 ? $already_mapref : undef;
3032 my ($what, @fetch) = @_;
3034 local $idistro = $dsc_distro;
3035 my $lrf = lrfetchrefs;
3037 if (!$chase_dsc_distro) {
3038 progress f_ "not chasing .dsc distro %s: not fetching %s",
3043 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3045 my $url = access_giturl();
3046 if (!defined $url) {
3047 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3048 .dsc Dgit metadata is in context of distro %s
3049 for which we have no configured url and .dsc provides no hint
3052 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3053 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3054 parse_cfg_bool "dsc-url-proto-ok", 'false',
3055 cfg("dgit.dsc-url-proto-ok.$proto",
3056 "dgit.default.dsc-url-proto-ok")
3057 or fail f_ <<END, $dsc_distro, $proto;
3058 .dsc Dgit metadata is in context of distro %s
3059 for which we have no configured url;
3060 .dsc provides hinted url with protocol %s which is unsafe.
3061 (can be overridden by config - consult documentation)
3063 $url = $dsc_hint_url;
3066 git_lrfetch_sane $url, 1, @fetch;
3071 my $rewrite_enable = do {
3072 local $idistro = $dsc_distro;
3073 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3076 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3077 if (!defined $mapref) {
3078 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3079 $mapref = $lrf.'/'.$rewritemap;
3081 my $rewritemapdata = git_cat_file $mapref.':map';
3082 if (defined $rewritemapdata
3083 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3085 "server's git history rewrite map contains a relevant entry!";
3088 if (defined $dsc_hash) {
3089 progress __ "using rewritten git hash in place of .dsc value";
3091 progress __ "server data says .dsc hash is to be disregarded";
3096 if (!defined git_cat_file $dsc_hash) {
3097 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3098 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3099 defined git_cat_file $dsc_hash
3100 or fail f_ <<END, $dsc_hash;
3101 .dsc Dgit metadata requires commit %s
3102 but we could not obtain that object anywhere.
3104 foreach my $t (@tags) {
3105 my $fullrefname = $lrf.'/'.$t;
3106 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3107 next unless $lrfetchrefs_f{$fullrefname};
3108 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3109 lrfetchref_used $fullrefname;
3114 sub fetch_from_archive () {
3116 ensure_setup_existing_tree();
3118 # Ensures that lrref() is what is actually in the archive, one way
3119 # or another, according to us - ie this client's
3120 # appropritaely-updated archive view. Also returns the commit id.
3121 # If there is nothing in the archive, leaves lrref alone and
3122 # returns undef. git_fetch_us must have already been called.
3126 parse_dsc_field($dsc, __ 'last upload to archive');
3127 resolve_dsc_field_commit access_basedistro,
3128 lrfetchrefs."/".$rewritemap
3130 progress __ "no version available from the archive";
3133 # If the archive's .dsc has a Dgit field, there are three
3134 # relevant git commitids we need to choose between and/or merge
3136 # 1. $dsc_hash: the Dgit field from the archive
3137 # 2. $lastpush_hash: the suite branch on the dgit git server
3138 # 3. $lastfetch_hash: our local tracking brach for the suite
3140 # These may all be distinct and need not be in any fast forward
3143 # If the dsc was pushed to this suite, then the server suite
3144 # branch will have been updated; but it might have been pushed to
3145 # a different suite and copied by the archive. Conversely a more
3146 # recent version may have been pushed with dgit but not appeared
3147 # in the archive (yet).
3149 # $lastfetch_hash may be awkward because archive imports
3150 # (particularly, imports of Dgit-less .dscs) are performed only as
3151 # needed on individual clients, so different clients may perform a
3152 # different subset of them - and these imports are only made
3153 # public during push. So $lastfetch_hash may represent a set of
3154 # imports different to a subsequent upload by a different dgit
3157 # Our approach is as follows:
3159 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3160 # descendant of $dsc_hash, then it was pushed by a dgit user who
3161 # had based their work on $dsc_hash, so we should prefer it.
3162 # Otherwise, $dsc_hash was installed into this suite in the
3163 # archive other than by a dgit push, and (necessarily) after the
3164 # last dgit push into that suite (since a dgit push would have
3165 # been descended from the dgit server git branch); thus, in that
3166 # case, we prefer the archive's version (and produce a
3167 # pseudo-merge to overwrite the dgit server git branch).
3169 # (If there is no Dgit field in the archive's .dsc then
3170 # generate_commit_from_dsc uses the version numbers to decide
3171 # whether the suite branch or the archive is newer. If the suite
3172 # branch is newer it ignores the archive's .dsc; otherwise it
3173 # generates an import of the .dsc, and produces a pseudo-merge to
3174 # overwrite the suite branch with the archive contents.)
3176 # The outcome of that part of the algorithm is the `public view',
3177 # and is same for all dgit clients: it does not depend on any
3178 # unpublished history in the local tracking branch.
3180 # As between the public view and the local tracking branch: The
3181 # local tracking branch is only updated by dgit fetch, and
3182 # whenever dgit fetch runs it includes the public view in the
3183 # local tracking branch. Therefore if the public view is not
3184 # descended from the local tracking branch, the local tracking
3185 # branch must contain history which was imported from the archive
3186 # but never pushed; and, its tip is now out of date. So, we make
3187 # a pseudo-merge to overwrite the old imports and stitch the old
3190 # Finally: we do not necessarily reify the public view (as
3191 # described above). This is so that we do not end up stacking two
3192 # pseudo-merges. So what we actually do is figure out the inputs
3193 # to any public view pseudo-merge and put them in @mergeinputs.
3196 # $mergeinputs[]{Commit}
3197 # $mergeinputs[]{Info}
3198 # $mergeinputs[0] is the one whose tree we use
3199 # @mergeinputs is in the order we use in the actual commit)
3202 # $mergeinputs[]{Message} is a commit message to use
3203 # $mergeinputs[]{ReverseParents} if def specifies that parent
3204 # list should be in opposite order
3205 # Such an entry has no Commit or Info. It applies only when found
3206 # in the last entry. (This ugliness is to support making
3207 # identical imports to previous dgit versions.)
3209 my $lastpush_hash = git_get_ref(lrfetchref());
3210 printdebug "previous reference hash=$lastpush_hash\n";
3211 $lastpush_mergeinput = $lastpush_hash && {
3212 Commit => $lastpush_hash,
3213 Info => (__ "dgit suite branch on dgit git server"),
3216 my $lastfetch_hash = git_get_ref(lrref());
3217 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3218 my $lastfetch_mergeinput = $lastfetch_hash && {
3219 Commit => $lastfetch_hash,
3220 Info => (__ "dgit client's archive history view"),
3223 my $dsc_mergeinput = $dsc_hash && {
3224 Commit => $dsc_hash,
3225 Info => (__ "Dgit field in .dsc from archive"),
3229 my $del_lrfetchrefs = sub {
3232 printdebug "del_lrfetchrefs...\n";
3233 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3234 my $objid = $lrfetchrefs_d{$fullrefname};
3235 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3237 $gur ||= new IO::Handle;
3238 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3240 printf $gur "delete %s %s\n", $fullrefname, $objid;
3243 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3247 if (defined $dsc_hash) {
3248 ensure_we_have_orig();
3249 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3250 @mergeinputs = $dsc_mergeinput
3251 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3252 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3254 Git commit in archive is behind the last version allegedly pushed/uploaded.
3255 Commit referred to by archive: %s
3256 Last version pushed with dgit: %s
3259 __ $later_warning_msg or confess "$!";
3260 @mergeinputs = ($lastpush_mergeinput);
3262 # Archive has .dsc which is not a descendant of the last dgit
3263 # push. This can happen if the archive moves .dscs about.
3264 # Just follow its lead.
3265 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3266 progress __ "archive .dsc names newer git commit";
3267 @mergeinputs = ($dsc_mergeinput);
3269 progress __ "archive .dsc names other git commit, fixing up";
3270 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3274 @mergeinputs = generate_commits_from_dsc();
3275 # We have just done an import. Now, our import algorithm might
3276 # have been improved. But even so we do not want to generate
3277 # a new different import of the same package. So if the
3278 # version numbers are the same, just use our existing version.
3279 # If the version numbers are different, the archive has changed
3280 # (perhaps, rewound).
3281 if ($lastfetch_mergeinput &&
3282 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3283 (mergeinfo_version $mergeinputs[0]) )) {
3284 @mergeinputs = ($lastfetch_mergeinput);
3286 } elsif ($lastpush_hash) {
3287 # only in git, not in the archive yet
3288 @mergeinputs = ($lastpush_mergeinput);
3289 print STDERR f_ <<END,
3291 Package not found in the archive, but has allegedly been pushed using dgit.
3294 __ $later_warning_msg or confess "$!";
3296 printdebug "nothing found!\n";
3297 if (defined $skew_warning_vsn) {
3298 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3300 Warning: relevant archive skew detected.
3301 Archive allegedly contains %s
3302 But we were not able to obtain any version from the archive or git.
3306 unshift @end, $del_lrfetchrefs;
3310 if ($lastfetch_hash &&
3312 my $h = $_->{Commit};
3313 $h and is_fast_fwd($lastfetch_hash, $h);
3314 # If true, one of the existing parents of this commit
3315 # is a descendant of the $lastfetch_hash, so we'll
3316 # be ff from that automatically.
3320 push @mergeinputs, $lastfetch_mergeinput;
3323 printdebug "fetch mergeinfos:\n";
3324 foreach my $mi (@mergeinputs) {
3326 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3328 printdebug sprintf " ReverseParents=%d Message=%s",
3329 $mi->{ReverseParents}, $mi->{Message};
3333 my $compat_info= pop @mergeinputs
3334 if $mergeinputs[$#mergeinputs]{Message};
3336 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3339 if (@mergeinputs > 1) {
3341 my $tree_commit = $mergeinputs[0]{Commit};
3343 my $tree = get_tree_of_commit $tree_commit;;
3345 # We use the changelog author of the package in question the
3346 # author of this pseudo-merge. This is (roughly) correct if
3347 # this commit is simply representing aa non-dgit upload.
3348 # (Roughly because it does not record sponsorship - but we
3349 # don't have sponsorship info because that's in the .changes,
3350 # which isn't in the archivw.)
3352 # But, it might be that we are representing archive history
3353 # updates (including in-archive copies). These are not really
3354 # the responsibility of the person who created the .dsc, but
3355 # there is no-one whose name we should better use. (The
3356 # author of the .dsc-named commit is clearly worse.)
3358 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3359 my $author = clogp_authline $useclogp;
3360 my $cversion = getfield $useclogp, 'Version';
3362 my $mcf = dgit_privdir()."/mergecommit";
3363 open MC, ">", $mcf or die "$mcf $!";
3364 print MC <<END or confess "$!";
3368 my @parents = grep { $_->{Commit} } @mergeinputs;
3369 @parents = reverse @parents if $compat_info->{ReverseParents};
3370 print MC <<END or confess "$!" foreach @parents;
3374 print MC <<END or confess "$!";
3380 if (defined $compat_info->{Message}) {
3381 print MC $compat_info->{Message} or confess "$!";
3383 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3384 Record %s (%s) in archive suite %s
3388 my $message_add_info = sub {
3390 my $mversion = mergeinfo_version $mi;
3391 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3395 $message_add_info->($mergeinputs[0]);
3396 print MC __ <<END or confess "$!";
3397 should be treated as descended from
3399 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3402 close MC or confess "$!";
3403 $hash = make_commit $mcf;
3405 $hash = $mergeinputs[0]{Commit};
3407 printdebug "fetch hash=$hash\n";
3410 my ($lasth, $what) = @_;
3411 return unless $lasth;
3412 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3415 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3417 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3419 fetch_from_archive_record_1($hash);
3421 if (defined $skew_warning_vsn) {
3422 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3423 my $gotclogp = commit_getclogp($hash);
3424 my $got_vsn = getfield $gotclogp, 'Version';
3425 printdebug "SKEW CHECK GOT $got_vsn\n";
3426 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3427 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3429 Warning: archive skew detected. Using the available version:
3430 Archive allegedly contains %s
3431 We were able to obtain only %s
3437 if ($lastfetch_hash ne $hash) {
3438 fetch_from_archive_record_2($hash);
3441 lrfetchref_used lrfetchref();
3443 check_gitattrs($hash, __ "fetched source tree");
3445 unshift @end, $del_lrfetchrefs;
3449 sub set_local_git_config ($$) {
3451 runcmd @git, qw(config), $k, $v;
3454 sub setup_mergechangelogs (;$) {
3456 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3458 my $driver = 'dpkg-mergechangelogs';
3459 my $cb = "merge.$driver";
3460 confess unless defined $maindir;
3461 my $attrs = "$maindir_gitcommon/info/attributes";
3462 ensuredir "$maindir_gitcommon/info";
3464 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3465 if (!open ATTRS, "<", $attrs) {
3466 $!==ENOENT or die "$attrs: $!";
3470 next if m{^debian/changelog\s};
3471 print NATTRS $_, "\n" or confess "$!";
3473 ATTRS->error and confess "$!";
3476 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3479 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3480 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3482 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3485 sub setup_useremail (;$) {
3487 return unless $always || access_cfg_bool(1, 'setup-useremail');
3490 my ($k, $envvar) = @_;
3491 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3492 return unless defined $v;
3493 set_local_git_config "user.$k", $v;
3496 $setup->('email', 'DEBEMAIL');
3497 $setup->('name', 'DEBFULLNAME');
3500 sub ensure_setup_existing_tree () {
3501 my $k = "remote.$remotename.skipdefaultupdate";
3502 my $c = git_get_config $k;
3503 return if defined $c;
3504 set_local_git_config $k, 'true';
3507 sub open_main_gitattrs () {
3508 confess 'internal error no maindir' unless defined $maindir;
3509 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3511 or die "open $maindir_gitcommon/info/attributes: $!";
3515 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3517 sub is_gitattrs_setup () {
3520 # 1: gitattributes set up and should be left alone
3522 # 0: there is a dgit-defuse-attrs but it needs fixing
3523 # undef: there is none
3524 my $gai = open_main_gitattrs();
3525 return 0 unless $gai;
3527 next unless m{$gitattrs_ourmacro_re};
3528 return 1 if m{\s-working-tree-encoding\s};
3529 printdebug "is_gitattrs_setup: found old macro\n";
3532 $gai->error and confess "$!";
3533 printdebug "is_gitattrs_setup: found nothing\n";
3537 sub setup_gitattrs (;$) {
3539 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3541 my $already = is_gitattrs_setup();
3544 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3545 not doing further gitattributes setup
3549 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3550 my $af = "$maindir_gitcommon/info/attributes";
3551 ensuredir "$maindir_gitcommon/info";
3553 open GAO, "> $af.new" or confess "$!";
3554 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3558 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3560 my $gai = open_main_gitattrs();
3563 if (m{$gitattrs_ourmacro_re}) {
3564 die unless defined $already;
3568 print GAO $_, "\n" or confess "$!";
3570 $gai->error and confess "$!";
3572 close GAO or confess "$!";
3573 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3576 sub setup_new_tree () {
3577 setup_mergechangelogs();
3582 sub check_gitattrs ($$) {
3583 my ($treeish, $what) = @_;
3585 return if is_gitattrs_setup;
3588 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3590 my $gafl = new IO::File;
3591 open $gafl, "-|", @cmd or confess "$!";
3594 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3596 next unless m{(?:^|/)\.gitattributes$};
3598 # oh dear, found one
3599 print STDERR f_ <<END, $what;
3600 dgit: warning: %s contains .gitattributes
3601 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3606 # tree contains no .gitattributes files
3607 $?=0; $!=0; close $gafl or failedcmd @cmd;
3611 sub multisuite_suite_child ($$$) {
3612 my ($tsuite, $mergeinputs, $fn) = @_;
3613 # in child, sets things up, calls $fn->(), and returns undef
3614 # in parent, returns canonical suite name for $tsuite
3615 my $canonsuitefh = IO::File::new_tmpfile;
3616 my $pid = fork // confess "$!";
3620 $us .= " [$isuite]";
3621 $debugprefix .= " ";
3622 progress f_ "fetching %s...", $tsuite;
3623 canonicalise_suite();
3624 print $canonsuitefh $csuite, "\n" or confess "$!";
3625 close $canonsuitefh or confess "$!";
3629 waitpid $pid,0 == $pid or confess "$!";
3630 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3632 seek $canonsuitefh,0,0 or confess "$!";
3633 local $csuite = <$canonsuitefh>;
3634 confess "$!" unless defined $csuite && chomp $csuite;
3636 printdebug "multisuite $tsuite missing\n";
3639 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3640 push @$mergeinputs, {
3647 sub fork_for_multisuite ($) {
3648 my ($before_fetch_merge) = @_;
3649 # if nothing unusual, just returns ''
3652 # returns 0 to caller in child, to do first of the specified suites
3653 # in child, $csuite is not yet set
3655 # returns 1 to caller in parent, to finish up anything needed after
3656 # in parent, $csuite is set to canonicalised portmanteau
3658 my $org_isuite = $isuite;
3659 my @suites = split /\,/, $isuite;
3660 return '' unless @suites > 1;
3661 printdebug "fork_for_multisuite: @suites\n";
3665 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3667 return 0 unless defined $cbasesuite;
3669 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3670 unless @mergeinputs;
3672 my @csuites = ($cbasesuite);
3674 $before_fetch_merge->();
3676 foreach my $tsuite (@suites[1..$#suites]) {
3677 $tsuite =~ s/^-/$cbasesuite-/;
3678 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3685 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3686 push @csuites, $csubsuite;
3689 foreach my $mi (@mergeinputs) {
3690 my $ref = git_get_ref $mi->{Ref};
3691 die "$mi->{Ref} ?" unless length $ref;
3692 $mi->{Commit} = $ref;
3695 $csuite = join ",", @csuites;
3697 my $previous = git_get_ref lrref;
3699 unshift @mergeinputs, {
3700 Commit => $previous,
3701 Info => (__ "local combined tracking branch"),
3703 "archive seems to have rewound: local tracking branch is ahead!"),
3707 foreach my $ix (0..$#mergeinputs) {
3708 $mergeinputs[$ix]{Index} = $ix;
3711 @mergeinputs = sort {
3712 -version_compare(mergeinfo_version $a,
3713 mergeinfo_version $b) # highest version first
3715 $a->{Index} <=> $b->{Index}; # earliest in spec first
3721 foreach my $mi (@mergeinputs) {
3722 printdebug "multisuite merge check $mi->{Info}\n";
3723 foreach my $previous (@needed) {
3724 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3725 printdebug "multisuite merge un-needed $previous->{Info}\n";
3729 printdebug "multisuite merge this-needed\n";
3730 $mi->{Character} = '+';
3733 $needed[0]{Character} = '*';
3735 my $output = $needed[0]{Commit};
3738 printdebug "multisuite merge nontrivial\n";
3739 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3741 my $commit = "tree $tree\n";
3742 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3743 "Input branches:\n",
3746 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3747 printdebug "multisuite merge include $mi->{Info}\n";
3748 $mi->{Character} //= ' ';
3749 $commit .= "parent $mi->{Commit}\n";
3750 $msg .= sprintf " %s %-25s %s\n",
3752 (mergeinfo_version $mi),
3755 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3756 $msg .= __ "\nKey\n".
3757 " * marks the highest version branch, which choose to use\n".
3758 " + marks each branch which was not already an ancestor\n\n";
3760 "[dgit multi-suite $csuite]\n";
3762 "author $authline\n".
3763 "committer $authline\n\n";
3764 $output = make_commit_text $commit.$msg;
3765 printdebug "multisuite merge generated $output\n";
3768 fetch_from_archive_record_1($output);
3769 fetch_from_archive_record_2($output);
3771 progress f_ "calculated combined tracking suite %s", $csuite;
3776 sub clone_set_head () {
3777 open H, "> .git/HEAD" or confess "$!";
3778 print H "ref: ".lref()."\n" or confess "$!";
3779 close H or confess "$!";
3781 sub clone_finish ($) {
3783 runcmd @git, qw(reset --hard), lrref();
3784 runcmd qw(bash -ec), <<'END';
3786 git ls-tree -r --name-only -z HEAD | \
3787 xargs -0r touch -h -r . --
3789 printdone f_ "ready for work in %s", $dstdir;
3793 # in multisuite, returns twice!
3794 # once in parent after first suite fetched,
3795 # and then again in child after everything is finished
3797 badusage __ "dry run makes no sense with clone" unless act_local();
3799 my $multi_fetched = fork_for_multisuite(sub {
3800 printdebug "multi clone before fetch merge\n";
3804 if ($multi_fetched) {
3805 printdebug "multi clone after fetch merge\n";
3807 clone_finish($dstdir);
3810 printdebug "clone main body\n";
3812 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3816 canonicalise_suite();
3817 my $hasgit = check_for_git();
3819 runcmd @git, qw(init -q);
3823 my $giturl = access_giturl(1);
3824 if (defined $giturl) {
3825 runcmd @git, qw(remote add), 'origin', $giturl;
3828 progress __ "fetching existing git history";
3830 runcmd_ordryrun_local @git, qw(fetch origin);
3832 progress __ "starting new git history";
3834 fetch_from_archive() or no_such_package;
3835 my $vcsgiturl = $dsc->{'Vcs-Git'};
3836 if (length $vcsgiturl) {
3837 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3838 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3840 clone_finish($dstdir);
3844 canonicalise_suite();
3845 if (check_for_git()) {
3848 fetch_from_archive() or no_such_package();
3850 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3851 if (length $vcsgiturl and
3852 (grep { $csuite eq $_ }
3854 cfg 'dgit.vcs-git.suites')) {
3855 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3856 if (defined $current && $current ne $vcsgiturl) {
3857 print STDERR f_ <<END, $csuite;
3858 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3859 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3863 printdone f_ "fetched into %s", lrref();
3867 my $multi_fetched = fork_for_multisuite(sub { });
3868 fetch_one() unless $multi_fetched; # parent
3869 finish 0 if $multi_fetched eq '0'; # child
3874 runcmd_ordryrun_local @git, qw(merge -m),
3875 (f_ "Merge from %s [dgit]", $csuite),
3877 printdone f_ "fetched to %s and merged into HEAD", lrref();
3880 sub check_not_dirty () {
3881 my @forbid = qw(local-options local-patch-header);
3882 @forbid = map { "debian/source/$_" } @forbid;
3883 foreach my $f (@forbid) {
3884 if (stat_exists $f) {
3885 fail f_ "git tree contains %s", $f;
3889 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3890 push @cmd, qw(debian/source/format debian/source/options);
3893 my $bad = cmdoutput @cmd;
3896 "you have uncommitted changes to critical files, cannot continue:\n").
3900 return if $includedirty;
3902 git_check_unmodified();
3905 sub commit_admin ($) {
3908 runcmd_ordryrun_local @git, qw(commit -m), $m;
3911 sub quiltify_nofix_bail ($$) {
3912 my ($headinfo, $xinfo) = @_;
3913 if ($quilt_mode eq 'nofix') {
3915 "quilt fixup required but quilt mode is \`nofix'\n".
3916 "HEAD commit%s differs from tree implied by debian/patches%s",
3921 sub commit_quilty_patch () {
3922 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3924 foreach my $l (split /\n/, $output) {
3925 next unless $l =~ m/\S/;
3926 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3930 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3932 progress __ "nothing quilty to commit, ok.";
3935 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3936 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3937 runcmd_ordryrun_local @git, qw(add -f), @adds;
3938 commit_admin +(__ <<ENDT).<<END
3939 Commit Debian 3.0 (quilt) metadata
3942 [dgit ($our_version) quilt-fixup]
3946 sub get_source_format () {
3948 if (open F, "debian/source/options") {
3952 s/\s+$//; # ignore missing final newline
3954 my ($k, $v) = ($`, $'); #');
3955 $v =~ s/^"(.*)"$/$1/;
3961 F->error and confess "$!";
3964 confess "$!" unless $!==&ENOENT;
3967 if (!open F, "debian/source/format") {
3968 confess "$!" unless $!==&ENOENT;
3972 F->error and confess "$!";
3974 return ($_, \%options);
3977 sub madformat_wantfixup ($) {
3979 return 0 unless $format eq '3.0 (quilt)';
3980 our $quilt_mode_warned;
3981 if ($quilt_mode eq 'nocheck') {
3982 progress f_ "Not doing any fixup of \`%s'".
3983 " due to ----no-quilt-fixup or --quilt=nocheck", $format
3984 unless $quilt_mode_warned++;
3987 progress f_ "Format \`%s', need to check/update patch stack", $format
3988 unless $quilt_mode_warned++;
3992 sub maybe_split_brain_save ($$$) {
3993 my ($headref, $dgitview, $msg) = @_;
3994 # => message fragment "$saved" describing disposition of $dgitview
3995 # (used inside parens, in the English texts)
3996 my $save = $internal_object_save{'dgit-view'};
3997 return f_ "commit id %s", $dgitview unless defined $save;
3998 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4000 "dgit --dgit-view-save $msg HEAD=$headref",
4003 return f_ "and left in %s", $save;
4006 # An "infopair" is a tuple [ $thing, $what ]
4007 # (often $thing is a commit hash; $what is a description)
4009 sub infopair_cond_equal ($$) {
4011 $x->[0] eq $y->[0] or fail <<END;
4012 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4016 sub infopair_lrf_tag_lookup ($$) {
4017 my ($tagnames, $what) = @_;
4018 # $tagname may be an array ref
4019 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4020 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4021 foreach my $tagname (@tagnames) {
4022 my $lrefname = lrfetchrefs."/tags/$tagname";
4023 my $tagobj = $lrfetchrefs_f{$lrefname};
4024 next unless defined $tagobj;
4025 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4026 return [ git_rev_parse($tagobj), $what ];
4028 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4029 Wanted tag %s (%s) on dgit server, but not found
4031 : (f_ <<END, $what, "@tagnames");
4032 Wanted tag %s (one of: %s) on dgit server, but not found
4036 sub infopair_cond_ff ($$) {
4037 my ($anc,$desc) = @_;
4038 is_fast_fwd($anc->[0], $desc->[0]) or
4039 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4040 %s (%s) .. %s (%s) is not fast forward
4044 sub pseudomerge_version_check ($$) {
4045 my ($clogp, $archive_hash) = @_;
4047 my $arch_clogp = commit_getclogp $archive_hash;
4048 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4049 __ 'version currently in archive' ];
4050 if (defined $overwrite_version) {
4051 if (length $overwrite_version) {
4052 infopair_cond_equal([ $overwrite_version,
4053 '--overwrite= version' ],
4056 my $v = $i_arch_v->[0];
4058 "Checking package changelog for archive version %s ...", $v;
4061 my @xa = ("-f$v", "-t$v");
4062 my $vclogp = parsechangelog @xa;
4065 [ (getfield $vclogp, $fn),
4066 (f_ "%s field from dpkg-parsechangelog %s",
4069 my $cv = $gf->('Version');
4070 infopair_cond_equal($i_arch_v, $cv);
4071 $cd = $gf->('Distribution');
4075 $@ =~ s/^dgit: //gm;
4077 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4079 fail f_ <<END, $cd->[1], $cd->[0], $v
4081 Your tree seems to based on earlier (not uploaded) %s.
4083 if $cd->[0] =~ m/UNRELEASED/;
4087 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4091 sub pseudomerge_make_commit ($$$$ $$) {
4092 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4093 $msg_cmd, $msg_msg) = @_;
4094 progress f_ "Declaring that HEAD includes all changes in %s...",
4097 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4098 my $authline = clogp_authline $clogp;
4102 !defined $overwrite_version ? ""
4103 : !length $overwrite_version ? " --overwrite"
4104 : " --overwrite=".$overwrite_version;
4106 # Contributing parent is the first parent - that makes
4107 # git rev-list --first-parent DTRT.
4108 my $pmf = dgit_privdir()."/pseudomerge";
4109 open MC, ">", $pmf or die "$pmf $!";
4110 print MC <<END or confess "$!";
4113 parent $archive_hash
4121 close MC or confess "$!";
4123 return make_commit($pmf);
4126 sub splitbrain_pseudomerge ($$$$) {
4127 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4128 # => $merged_dgitview
4129 printdebug "splitbrain_pseudomerge...\n";
4131 # We: debian/PREVIOUS HEAD($maintview)
4132 # expect: o ----------------- o
4135 # a/d/PREVIOUS $dgitview
4138 # we do: `------------------ o
4142 return $dgitview unless defined $archive_hash;
4143 return $dgitview if deliberately_not_fast_forward();
4145 printdebug "splitbrain_pseudomerge...\n";
4147 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4149 if (!defined $overwrite_version) {
4150 progress __ "Checking that HEAD includes all changes in archive...";
4153 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4155 if (defined $overwrite_version) {
4157 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4158 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4159 __ "maintainer view tag");
4160 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4161 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4162 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4164 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4166 infopair_cond_equal($i_dgit, $i_archive);
4167 infopair_cond_ff($i_dep14, $i_dgit);
4168 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4171 $@ =~ s/^\n//; chomp $@;
4172 print STDERR <<END.(__ <<ENDT);
4175 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4180 my $arch_v = $i_arch_v->[0];
4181 my $r = pseudomerge_make_commit
4182 $clogp, $dgitview, $archive_hash, $i_arch_v,
4183 "dgit --quilt=$quilt_mode",
4184 (defined $overwrite_version
4185 ? f_ "Declare fast forward from %s\n", $arch_v
4186 : f_ "Make fast forward from %s\n", $arch_v);
4188 maybe_split_brain_save $maintview, $r, "pseudomerge";
4190 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4194 sub plain_overwrite_pseudomerge ($$$) {
4195 my ($clogp, $head, $archive_hash) = @_;
4197 printdebug "plain_overwrite_pseudomerge...";
4199 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4201 return $head if is_fast_fwd $archive_hash, $head;
4203 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4205 my $r = pseudomerge_make_commit
4206 $clogp, $head, $archive_hash, $i_arch_v,
4209 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4211 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4215 sub push_parse_changelog ($) {
4218 my $clogp = Dpkg::Control::Hash->new();
4219 $clogp->load($clogpfn) or die;
4221 my $clogpackage = getfield $clogp, 'Source';
4222 $package //= $clogpackage;
4223 fail f_ "-p specified %s but changelog specified %s",
4224 $package, $clogpackage
4225 unless $package eq $clogpackage;
4226 my $cversion = getfield $clogp, 'Version';
4228 if (!$we_are_initiator) {
4229 # rpush initiator can't do this because it doesn't have $isuite yet
4230 my $tag = debiantag_new($cversion, access_nomdistro);
4231 runcmd @git, qw(check-ref-format), $tag;
4234 my $dscfn = dscfn($cversion);
4236 return ($clogp, $cversion, $dscfn);
4239 sub push_parse_dsc ($$$) {
4240 my ($dscfn,$dscfnwhat, $cversion) = @_;
4241 $dsc = parsecontrol($dscfn,$dscfnwhat);
4242 my $dversion = getfield $dsc, 'Version';
4243 my $dscpackage = getfield $dsc, 'Source';
4244 ($dscpackage eq $package && $dversion eq $cversion) or
4245 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4246 $dscfn, $dscpackage, $dversion,
4247 $package, $cversion;
4250 sub push_tagwants ($$$$) {
4251 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4254 TagFn => \&debiantag_new,
4259 if (defined $maintviewhead) {
4261 TagFn => \&debiantag_maintview,
4262 Objid => $maintviewhead,
4263 TfSuffix => '-maintview',
4266 } elsif ($dodep14tag ne 'no') {
4268 TagFn => \&debiantag_maintview,
4270 TfSuffix => '-dgit',
4274 foreach my $tw (@tagwants) {
4275 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4276 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4278 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4282 sub push_mktags ($$ $$ $) {
4284 $changesfile,$changesfilewhat,
4287 die unless $tagwants->[0]{View} eq 'dgit';
4289 my $declaredistro = access_nomdistro();
4290 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4291 $dsc->{$ourdscfield[0]} = join " ",
4292 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4294 $dsc->save("$dscfn.tmp") or confess "$!";
4296 my $changes = parsecontrol($changesfile,$changesfilewhat);
4297 foreach my $field (qw(Source Distribution Version)) {
4298 $changes->{$field} eq $clogp->{$field} or
4299 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4300 $field, $changes->{$field}, $clogp->{$field};
4303 my $cversion = getfield $clogp, 'Version';
4304 my $clogsuite = getfield $clogp, 'Distribution';
4306 # We make the git tag by hand because (a) that makes it easier
4307 # to control the "tagger" (b) we can do remote signing
4308 my $authline = clogp_authline $clogp;
4309 my $delibs = join(" ", "",@deliberatelies);
4313 my $tfn = $tw->{Tfn};
4314 my $head = $tw->{Objid};
4315 my $tag = $tw->{Tag};
4317 open TO, '>', $tfn->('.tmp') or confess "$!";
4318 print TO <<END or confess "$!";
4325 if ($tw->{View} eq 'dgit') {
4326 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4327 %s release %s for %s (%s) [dgit]
4330 print TO <<END or confess "$!";
4331 [dgit distro=$declaredistro$delibs]
4333 foreach my $ref (sort keys %previously) {
4334 print TO <<END or confess "$!";
4335 [dgit previously:$ref=$previously{$ref}]
4338 } elsif ($tw->{View} eq 'maint') {
4339 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4340 %s release %s for %s (%s)
4341 (maintainer view tag generated by dgit --quilt=%s)
4346 confess Dumper($tw)."?";
4349 close TO or confess "$!";
4351 my $tagobjfn = $tfn->('.tmp');
4353 if (!defined $keyid) {
4354 $keyid = access_cfg('keyid','RETURN-UNDEF');
4356 if (!defined $keyid) {
4357 $keyid = getfield $clogp, 'Maintainer';
4359 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4360 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4361 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4362 push @sign_cmd, $tfn->('.tmp');
4363 runcmd_ordryrun @sign_cmd;
4365 $tagobjfn = $tfn->('.signed.tmp');
4366 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4367 $tfn->('.tmp'), $tfn->('.tmp.asc');
4373 my @r = map { $mktag->($_); } @$tagwants;
4377 sub sign_changes ($) {
4378 my ($changesfile) = @_;
4380 my @debsign_cmd = @debsign;
4381 push @debsign_cmd, "-k$keyid" if defined $keyid;
4382 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4383 push @debsign_cmd, $changesfile;
4384 runcmd_ordryrun @debsign_cmd;
4389 printdebug "actually entering push\n";
4391 supplementary_message(__ <<'END');
4392 Push failed, while checking state of the archive.
4393 You can retry the push, after fixing the problem, if you like.
4395 if (check_for_git()) {
4398 my $archive_hash = fetch_from_archive();
4399 if (!$archive_hash) {
4401 fail __ "package appears to be new in this suite;".
4402 " if this is intentional, use --new";
4405 supplementary_message(__ <<'END');
4406 Push failed, while preparing your push.
4407 You can retry the push, after fixing the problem, if you like.
4412 access_giturl(); # check that success is vaguely likely
4413 rpush_handle_protovsn_bothends() if $we_are_initiator;
4415 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4416 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4418 responder_send_file('parsed-changelog', $clogpfn);
4420 my ($clogp, $cversion, $dscfn) =
4421 push_parse_changelog("$clogpfn");
4423 my $dscpath = "$buildproductsdir/$dscfn";
4424 stat_exists $dscpath or
4425 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4428 responder_send_file('dsc', $dscpath);
4430 push_parse_dsc($dscpath, $dscfn, $cversion);
4432 my $format = getfield $dsc, 'Format';
4434 my $symref = git_get_symref();
4435 my $actualhead = git_rev_parse('HEAD');
4437 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4438 if (quiltmode_splitbrain()) {
4439 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4440 fail f_ <<END, $ffq_prev, $quilt_mode;
4441 Branch is managed by git-debrebase (%s
4442 exists), but quilt mode (%s) implies a split view.
4443 Pass the right --quilt option or adjust your git config.
4444 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4447 runcmd_ordryrun_local @git_debrebase, 'stitch';
4448 $actualhead = git_rev_parse('HEAD');
4451 my $dgithead = $actualhead;
4452 my $maintviewhead = undef;
4454 my $upstreamversion = upstreamversion $clogp->{Version};
4456 if (madformat_wantfixup($format)) {
4457 # user might have not used dgit build, so maybe do this now:
4458 if (do_split_brain()) {
4459 changedir $playground;
4461 ($dgithead, $cachekey) =
4462 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4463 $dgithead or fail f_
4464 "--quilt=%s but no cached dgit view:
4465 perhaps HEAD changed since dgit build[-source] ?",
4468 if (!do_split_brain()) {
4469 # In split brain mode, do not attempt to incorporate dirty
4470 # stuff from the user's working tree. That would be mad.
4471 commit_quilty_patch();
4474 if (do_split_brain()) {
4475 $made_split_brain = 1;
4476 $dgithead = splitbrain_pseudomerge($clogp,
4477 $actualhead, $dgithead,
4479 $maintviewhead = $actualhead;
4481 prep_ud(); # so _only_subdir() works, below
4484 if (defined $overwrite_version && !defined $maintviewhead
4486 $dgithead = plain_overwrite_pseudomerge($clogp,
4494 if ($archive_hash) {
4495 if (is_fast_fwd($archive_hash, $dgithead)) {
4497 } elsif (deliberately_not_fast_forward) {
4500 fail __ "dgit push: HEAD is not a descendant".
4501 " of the archive's version.\n".
4502 "To overwrite the archive's contents,".
4503 " pass --overwrite[=VERSION].\n".
4504 "To rewind history, if permitted by the archive,".
4505 " use --deliberately-not-fast-forward.";
4509 confess unless !!$made_split_brain == do_split_brain();
4511 changedir $playground;
4512 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4513 runcmd qw(dpkg-source -x --),
4514 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4515 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4516 check_for_vendor_patches() if madformat($dsc->{format});
4518 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4519 debugcmd "+",@diffcmd;
4521 my $r = system @diffcmd;
4524 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4525 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4528 my $raw = cmdoutput @git,
4529 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4531 foreach (split /\0/, $raw) {
4532 if (defined $changed) {
4533 push @mode_changes, "$changed: $_\n" if $changed;
4536 } elsif (m/^:0+ 0+ /) {
4538 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4539 $changed = "Mode change from $1 to $2"
4544 if (@mode_changes) {
4545 fail +(f_ <<ENDT, $dscfn).<<END
4546 HEAD specifies a different tree to %s:
4550 .(join '', @mode_changes)
4551 .(f_ <<ENDT, $tree, $referent);
4552 There is a problem with your source tree (see dgit(7) for some hints).
4553 To see a full diff, run git diff %s %s
4557 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4558 HEAD specifies a different tree to %s:
4562 Perhaps you forgot to build. Or perhaps there is a problem with your
4563 source tree (see dgit(7) for some hints). To see a full diff, run
4570 if (!$changesfile) {
4571 my $pat = changespat $cversion;
4572 my @cs = glob "$buildproductsdir/$pat";
4573 fail f_ "failed to find unique changes file".
4574 " (looked for %s in %s);".
4575 " perhaps you need to use dgit -C",
4576 $pat, $buildproductsdir
4578 ($changesfile) = @cs;
4580 $changesfile = "$buildproductsdir/$changesfile";
4583 # Check that changes and .dsc agree enough
4584 $changesfile =~ m{[^/]*$};
4585 my $changes = parsecontrol($changesfile,$&);
4586 files_compare_inputs($dsc, $changes)
4587 unless forceing [qw(dsc-changes-mismatch)];
4589 # Check whether this is a source only upload
4590 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4591 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4592 if ($sourceonlypolicy eq 'ok') {
4593 } elsif ($sourceonlypolicy eq 'always') {
4594 forceable_fail [qw(uploading-binaries)],
4595 __ "uploading binaries, although distro policy is source only"
4597 } elsif ($sourceonlypolicy eq 'never') {
4598 forceable_fail [qw(uploading-source-only)],
4599 __ "source-only upload, although distro policy requires .debs"
4601 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4602 forceable_fail [qw(uploading-source-only)],
4603 f_ "source-only upload, even though package is entirely NEW\n".
4604 "(this is contrary to policy in %s)",
4608 && !(archive_query('package_not_wholly_new', $package) // 1);
4610 badcfg f_ "unknown source-only-uploads policy \`%s'",
4614 # Perhaps adjust .dsc to contain right set of origs
4615 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4617 unless forceing [qw(changes-origs-exactly)];
4619 # Checks complete, we're going to try and go ahead:
4621 responder_send_file('changes',$changesfile);
4622 responder_send_command("param head $dgithead");
4623 responder_send_command("param csuite $csuite");
4624 responder_send_command("param isuite $isuite");
4625 responder_send_command("param tagformat new"); # needed in $protovsn==4
4626 if (defined $maintviewhead) {
4627 responder_send_command("param maint-view $maintviewhead");
4630 # Perhaps send buildinfo(s) for signing
4631 my $changes_files = getfield $changes, 'Files';
4632 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4633 foreach my $bi (@buildinfos) {
4634 responder_send_command("param buildinfo-filename $bi");
4635 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4638 if (deliberately_not_fast_forward) {
4639 git_for_each_ref(lrfetchrefs, sub {
4640 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4641 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4642 responder_send_command("previously $rrefname=$objid");
4643 $previously{$rrefname} = $objid;
4647 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4648 dgit_privdir()."/tag");
4651 supplementary_message(__ <<'END');
4652 Push failed, while signing the tag.
4653 You can retry the push, after fixing the problem, if you like.
4655 # If we manage to sign but fail to record it anywhere, it's fine.
4656 if ($we_are_responder) {
4657 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4658 responder_receive_files('signed-tag', @tagobjfns);
4660 @tagobjfns = push_mktags($clogp,$dscpath,
4661 $changesfile,$changesfile,
4664 supplementary_message(__ <<'END');
4665 Push failed, *after* signing the tag.
4666 If you want to try again, you should use a new version number.
4669 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4671 foreach my $tw (@tagwants) {
4672 my $tag = $tw->{Tag};
4673 my $tagobjfn = $tw->{TagObjFn};
4675 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4676 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4677 runcmd_ordryrun_local
4678 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4681 supplementary_message(__ <<'END');
4682 Push failed, while updating the remote git repository - see messages above.
4683 If you want to try again, you should use a new version number.
4685 if (!check_for_git()) {
4686 create_remote_git_repo();
4689 my @pushrefs = $forceflag.$dgithead.":".rrref();
4690 foreach my $tw (@tagwants) {
4691 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4694 runcmd_ordryrun @git,
4695 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4696 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4698 supplementary_message(__ <<'END');
4699 Push failed, while obtaining signatures on the .changes and .dsc.
4700 If it was just that the signature failed, you may try again by using
4701 debsign by hand to sign the changes file (see the command dgit tried,
4702 above), and then dput that changes file to complete the upload.
4703 If you need to change the package, you must use a new version number.
4705 if ($we_are_responder) {
4706 my $dryrunsuffix = act_local() ? "" : ".tmp";
4707 my @rfiles = ($dscpath, $changesfile);
4708 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4709 responder_receive_files('signed-dsc-changes',
4710 map { "$_$dryrunsuffix" } @rfiles);
4713 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4715 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4717 sign_changes $changesfile;
4720 supplementary_message(f_ <<END, $changesfile);
4721 Push failed, while uploading package(s) to the archive server.
4722 You can retry the upload of exactly these same files with dput of:
4724 If that .changes file is broken, you will need to use a new version
4725 number for your next attempt at the upload.
4727 my $host = access_cfg('upload-host','RETURN-UNDEF');
4728 my @hostarg = defined($host) ? ($host,) : ();
4729 runcmd_ordryrun @dput, @hostarg, $changesfile;
4730 printdone f_ "pushed and uploaded %s", $cversion;
4732 supplementary_message('');
4733 responder_send_command("complete");
4737 not_necessarily_a_tree();
4742 badusage __ "-p is not allowed with clone; specify as argument instead"
4743 if defined $package;
4746 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4747 ($package,$isuite) = @ARGV;
4748 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4749 ($package,$dstdir) = @ARGV;
4750 } elsif (@ARGV==3) {
4751 ($package,$isuite,$dstdir) = @ARGV;
4753 badusage __ "incorrect arguments to dgit clone";
4757 $dstdir ||= "$package";
4758 if (stat_exists $dstdir) {
4759 fail f_ "%s already exists", $dstdir;
4763 if ($rmonerror && !$dryrun_level) {
4764 $cwd_remove= getcwd();
4766 return unless defined $cwd_remove;
4767 if (!chdir "$cwd_remove") {
4768 return if $!==&ENOENT;
4769 confess "chdir $cwd_remove: $!";
4771 printdebug "clone rmonerror removing $dstdir\n";
4773 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4774 } elsif (grep { $! == $_ }
4775 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4777 print STDERR f_ "check whether to remove %s: %s\n",
4784 $cwd_remove = undef;
4787 sub branchsuite () {
4788 my $branch = git_get_symref();
4789 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4796 sub package_from_d_control () {
4797 if (!defined $package) {
4798 my $sourcep = parsecontrol('debian/control','debian/control');
4799 $package = getfield $sourcep, 'Source';
4803 sub fetchpullargs () {
4804 package_from_d_control();
4806 $isuite = branchsuite();
4808 my $clogp = parsechangelog();
4809 my $clogsuite = getfield $clogp, 'Distribution';
4810 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4812 } elsif (@ARGV==1) {
4815 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4829 if (quiltmode_splitbrain()) {
4830 my ($format, $fopts) = get_source_format();
4831 madformat($format) and fail f_ <<END, $quilt_mode
4832 dgit pull not yet supported in split view mode (--quilt=%s)
4840 package_from_d_control();
4841 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4845 foreach my $canon (qw(0 1)) {
4850 canonicalise_suite();
4852 if (length git_get_ref lref()) {
4853 # local branch already exists, yay
4856 if (!length git_get_ref lrref()) {
4864 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4867 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4868 "dgit checkout $isuite";
4869 runcmd (@git, qw(checkout), lbranch());
4872 sub cmd_update_vcs_git () {
4874 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4875 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4877 ($specsuite) = (@ARGV);
4882 if ($ARGV[0] eq '-') {
4884 } elsif ($ARGV[0] eq '-') {
4889 package_from_d_control();
4891 if ($specsuite eq '.') {
4892 $ctrl = parsecontrol 'debian/control', 'debian/control';
4894 $isuite = $specsuite;
4898 my $url = getfield $ctrl, 'Vcs-Git';
4901 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4902 if (!defined $orgurl) {
4903 print STDERR f_ "setting up vcs-git: %s\n", $url;
4904 @cmd = (@git, qw(remote add vcs-git), $url);
4905 } elsif ($orgurl eq $url) {
4906 print STDERR f_ "vcs git already configured: %s\n", $url;
4908 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4909 @cmd = (@git, qw(remote set-url vcs-git), $url);
4911 runcmd_ordryrun_local @cmd;
4913 print f_ "fetching (%s)\n", "@ARGV";
4914 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4920 build_or_push_prep_early();
4922 build_or_push_prep_modes();
4926 } elsif (@ARGV==1) {
4927 ($specsuite) = (@ARGV);
4929 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4932 local ($package) = $existing_package; # this is a hack
4933 canonicalise_suite();
4935 canonicalise_suite();
4937 if (defined $specsuite &&
4938 $specsuite ne $isuite &&
4939 $specsuite ne $csuite) {
4940 fail f_ "dgit %s: changelog specifies %s (%s)".
4941 " but command line specifies %s",
4942 $subcommand, $isuite, $csuite, $specsuite;
4951 #---------- remote commands' implementation ----------
4953 sub pre_remote_push_build_host {
4954 my ($nrargs) = shift @ARGV;
4955 my (@rargs) = @ARGV[0..$nrargs-1];
4956 @ARGV = @ARGV[$nrargs..$#ARGV];
4958 my ($dir,$vsnwant) = @rargs;
4959 # vsnwant is a comma-separated list; we report which we have
4960 # chosen in our ready response (so other end can tell if they
4963 $we_are_responder = 1;
4964 $us .= " (build host)";
4966 open PI, "<&STDIN" or confess "$!";
4967 open STDIN, "/dev/null" or confess "$!";
4968 open PO, ">&STDOUT" or confess "$!";
4970 open STDOUT, ">&STDERR" or confess "$!";
4974 ($protovsn) = grep {
4975 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4976 } @rpushprotovsn_support;
4978 fail f_ "build host has dgit rpush protocol versions %s".
4979 " but invocation host has %s",
4980 (join ",", @rpushprotovsn_support), $vsnwant
4981 unless defined $protovsn;
4985 sub cmd_remote_push_build_host {
4986 responder_send_command("dgit-remote-push-ready $protovsn");
4990 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4991 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4992 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4993 # a good error message)
4995 sub rpush_handle_protovsn_bothends () {
5002 my $report = i_child_report();
5003 if (defined $report) {
5004 printdebug "($report)\n";
5005 } elsif ($i_child_pid) {
5006 printdebug "(killing build host child $i_child_pid)\n";
5007 kill 15, $i_child_pid;
5009 if (defined $i_tmp && !defined $initiator_tempdir) {
5011 eval { rmtree $i_tmp; };
5016 return unless forkcheck_mainprocess();
5021 my ($base,$selector,@args) = @_;
5022 $selector =~ s/\-/_/g;
5023 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5027 not_necessarily_a_tree();
5032 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5040 push @rargs, join ",", @rpushprotovsn_support;
5043 push @rdgit, @ropts;
5044 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5046 my @cmd = (@ssh, $host, shellquote @rdgit);
5049 $we_are_initiator=1;
5051 if (defined $initiator_tempdir) {
5052 rmtree $initiator_tempdir;
5053 mkdir $initiator_tempdir, 0700
5054 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5055 $i_tmp = $initiator_tempdir;
5059 $i_child_pid = open2(\*RO, \*RI, @cmd);
5061 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5062 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5065 my ($icmd,$iargs) = initiator_expect {
5066 m/^(\S+)(?: (.*))?$/;
5069 i_method "i_resp", $icmd, $iargs;
5073 sub i_resp_progress ($) {
5075 my $msg = protocol_read_bytes \*RO, $rhs;
5079 sub i_resp_supplementary_message ($) {
5081 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5084 sub i_resp_complete {
5085 my $pid = $i_child_pid;
5086 $i_child_pid = undef; # prevents killing some other process with same pid
5087 printdebug "waiting for build host child $pid...\n";
5088 my $got = waitpid $pid, 0;
5089 confess "$!" unless $got == $pid;
5090 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5093 printdebug __ "all done\n";
5097 sub i_resp_file ($) {
5099 my $localname = i_method "i_localname", $keyword;
5100 my $localpath = "$i_tmp/$localname";
5101 stat_exists $localpath and
5102 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5103 protocol_receive_file \*RO, $localpath;
5104 i_method "i_file", $keyword;
5109 sub i_resp_param ($) {
5110 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5114 sub i_resp_previously ($) {
5115 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5116 or badproto \*RO, __ "bad previously spec";
5117 my $r = system qw(git check-ref-format), $1;
5118 confess "bad previously ref spec ($r)" if $r;
5119 $previously{$1} = $2;
5124 sub i_resp_want ($) {
5126 die "$keyword ?" if $i_wanted{$keyword}++;
5128 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5129 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5130 die unless $isuite =~ m/^$suite_re$/;
5133 rpush_handle_protovsn_bothends();
5135 my @localpaths = i_method "i_want", $keyword;
5136 printdebug "[[ $keyword @localpaths\n";
5137 foreach my $localpath (@localpaths) {
5138 protocol_send_file \*RI, $localpath;
5140 print RI "files-end\n" or confess "$!";
5143 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5145 sub i_localname_parsed_changelog {
5146 return "remote-changelog.822";
5148 sub i_file_parsed_changelog {
5149 ($i_clogp, $i_version, $i_dscfn) =
5150 push_parse_changelog "$i_tmp/remote-changelog.822";
5151 die if $i_dscfn =~ m#/|^\W#;
5154 sub i_localname_dsc {
5155 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5160 sub i_localname_buildinfo ($) {
5161 my $bi = $i_param{'buildinfo-filename'};
5162 defined $bi or badproto \*RO, "buildinfo before filename";
5163 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5164 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5165 or badproto \*RO, "improper buildinfo filename";
5168 sub i_file_buildinfo {
5169 my $bi = $i_param{'buildinfo-filename'};
5170 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5171 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5172 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5173 files_compare_inputs($bd, $ch);
5174 (getfield $bd, $_) eq (getfield $ch, $_) or
5175 fail f_ "buildinfo mismatch in field %s", $_
5176 foreach qw(Source Version);
5177 !defined $bd->{$_} or
5178 fail f_ "buildinfo contains forbidden field %s", $_
5179 foreach qw(Changes Changed-by Distribution);
5181 push @i_buildinfos, $bi;
5182 delete $i_param{'buildinfo-filename'};
5185 sub i_localname_changes {
5186 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5187 $i_changesfn = $i_dscfn;
5188 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5189 return $i_changesfn;
5191 sub i_file_changes { }
5193 sub i_want_signed_tag {
5194 printdebug Dumper(\%i_param, $i_dscfn);
5195 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5196 && defined $i_param{'csuite'}
5197 or badproto \*RO, "premature desire for signed-tag";
5198 my $head = $i_param{'head'};
5199 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5201 my $maintview = $i_param{'maint-view'};
5202 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5204 if ($protovsn == 4) {
5205 my $p = $i_param{'tagformat'} // '<undef>';
5207 or badproto \*RO, "tag format mismatch: $p vs. new";
5210 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5212 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5214 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5217 push_mktags $i_clogp, $i_dscfn,
5218 $i_changesfn, (__ 'remote changes file'),
5222 sub i_want_signed_dsc_changes {
5223 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5224 sign_changes $i_changesfn;
5225 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5228 #---------- building etc. ----------
5234 #----- `3.0 (quilt)' handling -----
5236 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5238 sub quiltify_dpkg_commit ($$$;$) {
5239 my ($patchname,$author,$msg, $xinfo) = @_;
5242 mkpath '.git/dgit'; # we are in playtree
5243 my $descfn = ".git/dgit/quilt-description.tmp";
5244 open O, '>', $descfn or confess "$descfn: $!";
5245 $msg =~ s/\n+/\n\n/;
5246 print O <<END or confess "$!";
5248 ${xinfo}Subject: $msg
5252 close O or confess "$!";
5255 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5256 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5257 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5258 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5262 sub quiltify_trees_differ ($$;$$$) {
5263 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5264 # returns true iff the two tree objects differ other than in debian/
5265 # with $finegrained,
5266 # returns bitmask 01 - differ in upstream files except .gitignore
5267 # 02 - differ in .gitignore
5268 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5269 # is set for each modified .gitignore filename $fn
5270 # if $unrepres is defined, array ref to which is appeneded
5271 # a list of unrepresentable changes (removals of upstream files
5274 my @cmd = (@git, qw(diff-tree -z --no-renames));
5275 push @cmd, qw(--name-only) unless $unrepres;
5276 push @cmd, qw(-r) if $finegrained || $unrepres;
5278 my $diffs= cmdoutput @cmd;
5281 foreach my $f (split /\0/, $diffs) {
5282 if ($unrepres && !@lmodes) {
5283 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5286 my ($oldmode,$newmode) = @lmodes;
5289 next if $f =~ m#^debian(?:/.*)?$#s;
5293 die __ "not a plain file or symlink\n"
5294 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5295 $oldmode =~ m/^(?:10|12)\d{4}$/;
5296 if ($oldmode =~ m/[^0]/ &&
5297 $newmode =~ m/[^0]/) {
5298 # both old and new files exist
5299 die __ "mode or type changed\n" if $oldmode ne $newmode;
5300 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5301 } elsif ($oldmode =~ m/[^0]/) {
5303 die __ "deletion of symlink\n"
5304 unless $oldmode =~ m/^10/;
5307 die __ "creation with non-default mode\n"
5308 unless $newmode =~ m/^100644$/ or
5309 $newmode =~ m/^120000$/;
5313 local $/="\n"; chomp $@;
5314 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5318 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5319 $r |= $isignore ? 02 : 01;
5320 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5322 printdebug "quiltify_trees_differ $x $y => $r\n";
5326 sub quiltify_tree_sentinelfiles ($) {
5327 # lists the `sentinel' files present in the tree
5329 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5330 qw(-- debian/rules debian/control);
5335 sub quiltify_splitbrain ($$$$$$$) {
5336 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5337 $editedignores, $cachekey) = @_;
5338 my $gitignore_special = 1;
5339 if ($quilt_mode !~ m/gbp|dpm/) {
5340 # treat .gitignore just like any other upstream file
5341 $diffbits = { %$diffbits };
5342 $_ = !!$_ foreach values %$diffbits;
5343 $gitignore_special = 0;
5345 # We would like any commits we generate to be reproducible
5346 my @authline = clogp_authline($clogp);
5347 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5348 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5349 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5350 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5351 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5352 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5354 confess unless do_split_brain();
5356 my $fulldiffhint = sub {
5358 my $cmd = "git diff $x $y -- :/ ':!debian'";
5359 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5360 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5364 if ($quilt_mode =~ m/gbp|unapplied/ &&
5365 ($diffbits->{O2H} & 01)) {
5367 "--quilt=%s specified, implying patches-unapplied git tree\n".
5368 " but git tree differs from orig in upstream files.",
5370 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5371 if (!stat_exists "debian/patches") {
5373 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5377 if ($quilt_mode =~ m/dpm/ &&
5378 ($diffbits->{H2A} & 01)) {
5379 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5380 --quilt=%s specified, implying patches-applied git tree
5381 but git tree differs from result of applying debian/patches to upstream
5384 if ($quilt_mode =~ m/gbp|unapplied/ &&
5385 ($diffbits->{O2A} & 01)) { # some patches
5386 progress __ "dgit view: creating patches-applied version using gbp pq";
5387 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5388 # gbp pq import creates a fresh branch; push back to dgit-view
5389 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5390 runcmd @git, qw(checkout -q dgit-view);
5392 if ($quilt_mode =~ m/gbp|dpm/ &&
5393 ($diffbits->{O2A} & 02)) {
5394 fail f_ <<END, $quilt_mode;
5395 --quilt=%s specified, implying that HEAD is for use with a
5396 tool which does not create patches for changes to upstream
5397 .gitignores: but, such patches exist in debian/patches.
5400 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5401 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5403 "dgit view: creating patch to represent .gitignore changes";
5404 ensuredir "debian/patches";
5405 my $gipatch = "debian/patches/auto-gitignore";
5406 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5407 stat GIPATCH or confess "$gipatch: $!";
5408 fail f_ "%s already exists; but want to create it".
5409 " to record .gitignore changes",
5412 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5413 Subject: Update .gitignore from Debian packaging branch
5415 The Debian packaging git branch contains these updates to the upstream
5416 .gitignore file(s). This patch is autogenerated, to provide these
5417 updates to users of the official Debian archive view of the package.
5420 [dgit ($our_version) update-gitignore]
5423 close GIPATCH or die "$gipatch: $!";
5424 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5425 $unapplied, $headref, "--", sort keys %$editedignores;
5426 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5427 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5429 defined read SERIES, $newline, 1 or confess "$!";
5430 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5431 print SERIES "auto-gitignore\n" or confess "$!";
5432 close SERIES or die $!;
5433 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5434 commit_admin +(__ <<END).<<ENDU
5435 Commit patch to update .gitignore
5438 [dgit ($our_version) update-gitignore-quilt-fixup]
5443 sub quiltify ($$$$) {
5444 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5446 # Quilt patchification algorithm
5448 # We search backwards through the history of the main tree's HEAD
5449 # (T) looking for a start commit S whose tree object is identical
5450 # to to the patch tip tree (ie the tree corresponding to the
5451 # current dpkg-committed patch series). For these purposes
5452 # `identical' disregards anything in debian/ - this wrinkle is
5453 # necessary because dpkg-source treates debian/ specially.
5455 # We can only traverse edges where at most one of the ancestors'
5456 # trees differs (in changes outside in debian/). And we cannot
5457 # handle edges which change .pc/ or debian/patches. To avoid
5458 # going down a rathole we avoid traversing edges which introduce
5459 # debian/rules or debian/control. And we set a limit on the
5460 # number of edges we are willing to look at.
5462 # If we succeed, we walk forwards again. For each traversed edge
5463 # PC (with P parent, C child) (starting with P=S and ending with
5464 # C=T) to we do this:
5466 # - dpkg-source --commit with a patch name and message derived from C
5467 # After traversing PT, we git commit the changes which
5468 # should be contained within debian/patches.
5470 # The search for the path S..T is breadth-first. We maintain a
5471 # todo list containing search nodes. A search node identifies a
5472 # commit, and looks something like this:
5474 # Commit => $git_commit_id,
5475 # Child => $c, # or undef if P=T
5476 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5477 # Nontrivial => true iff $p..$c has relevant changes
5484 my %considered; # saves being exponential on some weird graphs
5486 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5489 my ($search,$whynot) = @_;
5490 printdebug " search NOT $search->{Commit} $whynot\n";
5491 $search->{Whynot} = $whynot;
5492 push @nots, $search;
5493 no warnings qw(exiting);
5502 my $c = shift @todo;
5503 next if $considered{$c->{Commit}}++;
5505 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5507 printdebug "quiltify investigate $c->{Commit}\n";
5510 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5511 printdebug " search finished hooray!\n";
5516 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5517 if ($quilt_mode eq 'smash') {
5518 printdebug " search quitting smash\n";
5522 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5523 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5524 if $c_sentinels ne $t_sentinels;
5526 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5527 $commitdata =~ m/\n\n/;
5529 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5530 @parents = map { { Commit => $_, Child => $c } } @parents;
5532 $not->($c, __ "root commit") if !@parents;
5534 foreach my $p (@parents) {
5535 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5537 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5538 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5541 foreach my $p (@parents) {
5542 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5544 my @cmd= (@git, qw(diff-tree -r --name-only),
5545 $p->{Commit},$c->{Commit},
5546 qw(-- debian/patches .pc debian/source/format));
5547 my $patchstackchange = cmdoutput @cmd;
5548 if (length $patchstackchange) {
5549 $patchstackchange =~ s/\n/,/g;
5550 $not->($p, f_ "changed %s", $patchstackchange);
5553 printdebug " search queue P=$p->{Commit} ",
5554 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5560 printdebug "quiltify want to smash\n";
5563 my $x = $_[0]{Commit};
5564 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5567 if ($quilt_mode eq 'linear') {
5569 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5571 my $all_gdr = !!@nots;
5572 foreach my $notp (@nots) {
5573 my $c = $notp->{Child};
5574 my $cprange = $abbrev->($notp);
5575 $cprange .= "..".$abbrev->($c) if $c;
5576 print STDERR f_ "%s: %s: %s\n",
5577 $us, $cprange, $notp->{Whynot};
5578 $all_gdr &&= $notp->{Child} &&
5579 (git_cat_file $notp->{Child}{Commit}, 'commit')
5580 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5584 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5586 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5588 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5589 } elsif ($quilt_mode eq 'smash') {
5590 } elsif ($quilt_mode eq 'auto') {
5591 progress __ "quilt fixup cannot be linear, smashing...";
5593 confess "$quilt_mode ?";
5596 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5597 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5599 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5601 quiltify_dpkg_commit "auto-$version-$target-$time",
5602 (getfield $clogp, 'Maintainer'),
5603 (f_ "Automatically generated patch (%s)\n".
5604 "Last (up to) %s git changes, FYI:\n\n",
5605 $clogp->{Version}, $ncommits).
5610 progress __ "quiltify linearisation planning successful, executing...";
5612 for (my $p = $sref_S;
5613 my $c = $p->{Child};
5615 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5616 next unless $p->{Nontrivial};
5618 my $cc = $c->{Commit};
5620 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5621 $commitdata =~ m/\n\n/ or die "$c ?";
5624 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5627 my $commitdate = cmdoutput
5628 @git, qw(log -n1 --pretty=format:%aD), $cc;
5630 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5632 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5639 my $gbp_check_suitable = sub {
5644 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5645 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5646 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5647 die __ "is series file\n" if m{$series_filename_re}o;
5648 die __ "too long\n" if length > 200;
5650 return $_ unless $@;
5652 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5657 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5659 (\S+) \s* \n //ixm) {
5660 $patchname = $gbp_check_suitable->($1, 'Name');
5662 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5664 (\S+) \s* \n //ixm) {
5665 $patchdir = $gbp_check_suitable->($1, 'Topic');
5670 if (!defined $patchname) {
5671 $patchname = $title;
5672 $patchname =~ s/[.:]$//;
5675 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5676 my $translitname = $converter->convert($patchname);
5677 die unless defined $translitname;
5678 $patchname = $translitname;
5681 +(f_ "dgit: patch title transliteration error: %s", $@)
5683 $patchname =~ y/ A-Z/-a-z/;
5684 $patchname =~ y/-a-z0-9_.+=~//cd;
5685 $patchname =~ s/^\W/x-$&/;
5686 $patchname = substr($patchname,0,40);
5687 $patchname .= ".patch";
5689 if (!defined $patchdir) {
5692 if (length $patchdir) {
5693 $patchname = "$patchdir/$patchname";
5695 if ($patchname =~ m{^(.*)/}) {
5696 mkpath "debian/patches/$1";
5701 stat "debian/patches/$patchname$index";
5703 $!==ENOENT or confess "$patchname$index $!";
5705 runcmd @git, qw(checkout -q), $cc;
5707 # We use the tip's changelog so that dpkg-source doesn't
5708 # produce complaining messages from dpkg-parsechangelog. None
5709 # of the information dpkg-source gets from the changelog is
5710 # actually relevant - it gets put into the original message
5711 # which dpkg-source provides our stunt editor, and then
5713 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5715 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5716 "Date: $commitdate\n".
5717 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5719 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5723 sub build_maybe_quilt_fixup () {
5724 my ($format,$fopts) = get_source_format;
5725 return unless madformat_wantfixup $format;
5728 check_for_vendor_patches();
5730 my $clogp = parsechangelog();
5731 my $headref = git_rev_parse('HEAD');
5732 my $symref = git_get_symref();
5733 my $upstreamversion = upstreamversion $version;
5736 changedir $playground;
5738 my $splitbrain_cachekey;
5740 if (do_split_brain()) {
5742 ($cachehit, $splitbrain_cachekey) =
5743 quilt_check_splitbrain_cache($headref, $upstreamversion);
5750 unpack_playtree_need_cd_work($headref);
5751 if (do_split_brain()) {
5752 runcmd @git, qw(checkout -q -b dgit-view);
5753 # so long as work is not deleted, its current branch will
5754 # remain dgit-view, rather than master, so subsequent calls to
5755 # unpack_playtree_need_cd_work
5756 # will DTRT, resetting dgit-view.
5757 confess if $made_split_brain;
5758 $made_split_brain = 1;
5762 if ($fopts->{'single-debian-patch'}) {
5764 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5766 if quiltmode_splitbrain();
5767 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5769 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5770 $splitbrain_cachekey);
5773 if (do_split_brain()) {
5774 my $dgitview = git_rev_parse 'HEAD';
5777 reflog_cache_insert "refs/$splitbraincache",
5778 $splitbrain_cachekey, $dgitview;
5780 changedir "$playground/work";
5782 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5783 progress f_ "dgit view: created (%s)", $saved;
5787 runcmd_ordryrun_local
5788 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5791 sub build_check_quilt_splitbrain () {
5792 build_maybe_quilt_fixup();
5795 sub unpack_playtree_need_cd_work ($) {
5798 # prep_ud() must have been called already.
5799 if (!chdir "work") {
5800 # Check in the filesystem because sometimes we run prep_ud
5801 # in between multiple calls to unpack_playtree_need_cd_work.
5802 confess "$!" unless $!==ENOENT;
5803 mkdir "work" or confess "$!";
5805 mktree_in_ud_here();
5807 runcmd @git, qw(reset -q --hard), $headref;
5810 sub unpack_playtree_linkorigs ($$) {
5811 my ($upstreamversion, $fn) = @_;
5812 # calls $fn->($leafname);
5814 my $bpd_abs = bpd_abs();
5816 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5818 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5819 while ($!=0, defined(my $leaf = readdir QFD)) {
5820 my $f = bpd_abs()."/".$leaf;
5822 local ($debuglevel) = $debuglevel-1;
5823 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5825 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5826 printdebug "QF linkorigs $leaf, $f Y\n";
5827 link_ltarget $f, $leaf or die "$leaf $!";
5830 die "$buildproductsdir: $!" if $!;
5834 sub quilt_fixup_delete_pc () {
5835 runcmd @git, qw(rm -rqf .pc);
5836 commit_admin +(__ <<END).<<ENDU
5837 Commit removal of .pc (quilt series tracking data)
5840 [dgit ($our_version) upgrade quilt-remove-pc]
5844 sub quilt_fixup_singlepatch ($$$) {
5845 my ($clogp, $headref, $upstreamversion) = @_;
5847 progress __ "starting quiltify (single-debian-patch)";
5849 # dpkg-source --commit generates new patches even if
5850 # single-debian-patch is in debian/source/options. In order to
5851 # get it to generate debian/patches/debian-changes, it is
5852 # necessary to build the source package.
5854 unpack_playtree_linkorigs($upstreamversion, sub { });
5855 unpack_playtree_need_cd_work($headref);
5857 rmtree("debian/patches");
5859 runcmd @dpkgsource, qw(-b .);
5861 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5862 rename srcfn("$upstreamversion", "/debian/patches"),
5863 "work/debian/patches"
5865 or confess "install d/patches: $!";
5868 commit_quilty_patch();
5871 sub quilt_need_fake_dsc ($) {
5872 # cwd should be playground
5873 my ($upstreamversion) = @_;
5875 return if stat_exists "fake.dsc";
5876 # ^ OK to test this as a sentinel because if we created it
5877 # we must either have done the rest too, or crashed.
5879 my $fakeversion="$upstreamversion-~~DGITFAKE";
5881 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5882 print $fakedsc <<END or confess "$!";
5885 Version: $fakeversion
5889 my $dscaddfile=sub {
5892 my $md = new Digest::MD5;
5894 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5895 stat $fh or confess "$!";
5899 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5902 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5904 my @files=qw(debian/source/format debian/rules
5905 debian/control debian/changelog);
5906 foreach my $maybe (qw(debian/patches debian/source/options
5907 debian/tests/control)) {
5908 next unless stat_exists "$maindir/$maybe";
5909 push @files, $maybe;
5912 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5913 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5915 $dscaddfile->($debtar);
5916 close $fakedsc or confess "$!";
5919 sub quilt_fakedsc2unapplied ($$) {
5920 my ($headref, $upstreamversion) = @_;
5921 # must be run in the playground
5922 # quilt_need_fake_dsc must have been called
5924 quilt_need_fake_dsc($upstreamversion);
5926 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5928 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5929 rename $fakexdir, "fake" or die "$fakexdir $!";
5933 remove_stray_gits(__ "source package");
5934 mktree_in_ud_here();
5938 rmtree 'debian'; # git checkout commitish paths does not delete!
5939 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5940 my $unapplied=git_add_write_tree();
5941 printdebug "fake orig tree object $unapplied\n";
5945 sub quilt_check_splitbrain_cache ($$) {
5946 my ($headref, $upstreamversion) = @_;
5947 # Called only if we are in (potentially) split brain mode.
5948 # Called in playground.
5949 # Computes the cache key and looks in the cache.
5950 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5952 quilt_need_fake_dsc($upstreamversion);
5954 my $splitbrain_cachekey;
5957 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5959 # we look in the reflog of dgit-intern/quilt-cache
5960 # we look for an entry whose message is the key for the cache lookup
5961 my @cachekey = (qw(dgit), $our_version);
5962 push @cachekey, $upstreamversion;
5963 push @cachekey, $quilt_mode;
5964 push @cachekey, $headref;
5966 push @cachekey, hashfile('fake.dsc');
5968 my $srcshash = Digest::SHA->new(256);
5969 my %sfs = ( %INC, '$0(dgit)' => $0 );
5970 foreach my $sfk (sort keys %sfs) {
5971 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5972 $srcshash->add($sfk," ");
5973 $srcshash->add(hashfile($sfs{$sfk}));
5974 $srcshash->add("\n");
5976 push @cachekey, $srcshash->hexdigest();
5977 $splitbrain_cachekey = "@cachekey";
5979 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5981 my $cachehit = reflog_cache_lookup
5982 "refs/$splitbraincache", $splitbrain_cachekey;
5985 unpack_playtree_need_cd_work($headref);
5986 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5987 if ($cachehit ne $headref) {
5988 progress f_ "dgit view: found cached (%s)", $saved;
5989 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5990 $made_split_brain = 1;
5991 return ($cachehit, $splitbrain_cachekey);
5993 progress __ "dgit view: found cached, no changes required";
5994 return ($headref, $splitbrain_cachekey);
5997 printdebug "splitbrain cache miss\n";
5998 return (undef, $splitbrain_cachekey);
6001 sub quilt_fixup_multipatch ($$$) {
6002 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6004 progress f_ "examining quilt state (multiple patches, %s mode)",
6008 # - honour any existing .pc in case it has any strangeness
6009 # - determine the git commit corresponding to the tip of
6010 # the patch stack (if there is one)
6011 # - if there is such a git commit, convert each subsequent
6012 # git commit into a quilt patch with dpkg-source --commit
6013 # - otherwise convert all the differences in the tree into
6014 # a single git commit
6018 # Our git tree doesn't necessarily contain .pc. (Some versions of
6019 # dgit would include the .pc in the git tree.) If there isn't
6020 # one, we need to generate one by unpacking the patches that we
6023 # We first look for a .pc in the git tree. If there is one, we
6024 # will use it. (This is not the normal case.)
6026 # Otherwise need to regenerate .pc so that dpkg-source --commit
6027 # can work. We do this as follows:
6028 # 1. Collect all relevant .orig from parent directory
6029 # 2. Generate a debian.tar.gz out of
6030 # debian/{patches,rules,source/format,source/options}
6031 # 3. Generate a fake .dsc containing just these fields:
6032 # Format Source Version Files
6033 # 4. Extract the fake .dsc
6034 # Now the fake .dsc has a .pc directory.
6035 # (In fact we do this in every case, because in future we will
6036 # want to search for a good base commit for generating patches.)
6038 # Then we can actually do the dpkg-source --commit
6039 # 1. Make a new working tree with the same object
6040 # store as our main tree and check out the main
6042 # 2. Copy .pc from the fake's extraction, if necessary
6043 # 3. Run dpkg-source --commit
6044 # 4. If the result has changes to debian/, then
6045 # - git add them them
6046 # - git add .pc if we had a .pc in-tree
6048 # 5. If we had a .pc in-tree, delete it, and git commit
6049 # 6. Back in the main tree, fast forward to the new HEAD
6051 # Another situation we may have to cope with is gbp-style
6052 # patches-unapplied trees.
6054 # We would want to detect these, so we know to escape into
6055 # quilt_fixup_gbp. However, this is in general not possible.
6056 # Consider a package with a one patch which the dgit user reverts
6057 # (with git revert or the moral equivalent).
6059 # That is indistinguishable in contents from a patches-unapplied
6060 # tree. And looking at the history to distinguish them is not
6061 # useful because the user might have made a confusing-looking git
6062 # history structure (which ought to produce an error if dgit can't
6063 # cope, not a silent reintroduction of an unwanted patch).
6065 # So gbp users will have to pass an option. But we can usually
6066 # detect their failure to do so: if the tree is not a clean
6067 # patches-applied tree, quilt linearisation fails, but the tree
6068 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6069 # they want --quilt=unapplied.
6071 # To help detect this, when we are extracting the fake dsc, we
6072 # first extract it with --skip-patches, and then apply the patches
6073 # afterwards with dpkg-source --before-build. That lets us save a
6074 # tree object corresponding to .origs.
6076 if ($quilt_mode eq 'linear'
6077 && branch_is_gdr($headref)) {
6078 # This is much faster. It also makes patches that gdr
6079 # likes better for future updates without laundering.
6081 # However, it can fail in some casses where we would
6082 # succeed: if there are existing patches, which correspond
6083 # to a prefix of the branch, but are not in gbp/gdr
6084 # format, gdr will fail (exiting status 7), but we might
6085 # be able to figure out where to start linearising. That
6086 # will be slower so hopefully there's not much to do.
6088 unpack_playtree_need_cd_work $headref;
6090 my @cmd = (@git_debrebase,
6091 qw(--noop-ok -funclean-mixed -funclean-ordering
6092 make-patches --quiet-would-amend));
6093 # We tolerate soe snags that gdr wouldn't, by default.
6099 and not ($? == 7*256 or
6100 $? == -1 && $!==ENOENT);
6104 $headref = git_rev_parse('HEAD');
6109 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6113 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6115 if (system @bbcmd) {
6116 failedcmd @bbcmd if $? < 0;
6118 failed to apply your git tree's patch stack (from debian/patches/) to
6119 the corresponding upstream tarball(s). Your source tree and .orig
6120 are probably too inconsistent. dgit can only fix up certain kinds of
6121 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6127 unpack_playtree_need_cd_work($headref);
6130 if (stat_exists ".pc") {
6132 progress __ "Tree already contains .pc - will use it then delete it.";
6135 rename '../fake/.pc','.pc' or confess "$!";
6138 changedir '../fake';
6140 my $oldtiptree=git_add_write_tree();
6141 printdebug "fake o+d/p tree object $unapplied\n";
6142 changedir '../work';
6145 # We calculate some guesswork now about what kind of tree this might
6146 # be. This is mostly for error reporting.
6152 # O = orig, without patches applied
6153 # A = "applied", ie orig with H's debian/patches applied
6154 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6155 \%editedignores, \@unrepres),
6156 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6157 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6161 foreach my $bits (qw(01 02)) {
6162 foreach my $v (qw(O2H O2A H2A)) {
6163 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6166 printdebug "differences \@dl @dl.\n";
6169 "%s: base trees orig=%.20s o+d/p=%.20s",
6170 $us, $unapplied, $oldtiptree;
6172 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6173 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6174 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6175 $us, $dl[2], $dl[5];
6178 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6181 forceable_fail [qw(unrepresentable)], __ <<END;
6182 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6187 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6188 push @failsuggestion, [ 'unapplied', __
6189 "This might be a patches-unapplied branch." ];
6190 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6191 push @failsuggestion, [ 'applied', __
6192 "This might be a patches-applied branch." ];
6194 push @failsuggestion, [ 'quilt-mode', __
6195 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6197 push @failsuggestion, [ 'gitattrs', __
6198 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6199 if stat_exists '.gitattributes';
6201 push @failsuggestion, [ 'origs', __
6202 "Maybe orig tarball(s) are not identical to git representation?" ];
6204 if (quiltmode_splitbrain()) {
6205 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6206 $diffbits, \%editedignores,
6207 $splitbrain_cachekey);
6211 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6212 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6213 runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6215 if (!open P, '>>', ".pc/applied-patches") {
6216 $!==&ENOENT or confess "$!";
6221 commit_quilty_patch();
6223 if ($mustdeletepc) {
6224 quilt_fixup_delete_pc();
6228 sub quilt_fixup_editor () {
6229 my $descfn = $ENV{$fakeeditorenv};
6230 my $editing = $ARGV[$#ARGV];
6231 open I1, '<', $descfn or confess "$descfn: $!";
6232 open I2, '<', $editing or confess "$editing: $!";
6233 unlink $editing or confess "$editing: $!";
6234 open O, '>', $editing or confess "$editing: $!";
6235 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6238 $copying ||= m/^\-\-\- /;
6239 next unless $copying;
6240 print O or confess "$!";
6242 I2->error and confess "$!";
6247 sub maybe_apply_patches_dirtily () {
6248 return unless $quilt_mode =~ m/gbp|unapplied/;
6249 print STDERR __ <<END or confess "$!";
6251 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6252 dgit: Have to apply the patches - making the tree dirty.
6253 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6256 $patches_applied_dirtily = 01;
6257 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6258 runcmd qw(dpkg-source --before-build .);
6261 sub maybe_unapply_patches_again () {
6262 progress __ "dgit: Unapplying patches again to tidy up the tree."
6263 if $patches_applied_dirtily;
6264 runcmd qw(dpkg-source --after-build .)
6265 if $patches_applied_dirtily & 01;
6267 if $patches_applied_dirtily & 02;
6268 $patches_applied_dirtily = 0;
6271 #----- other building -----
6273 sub clean_tree_check_git ($$$) {
6274 my ($honour_ignores, $message, $ignmessage) = @_;
6275 my @cmd = (@git, qw(clean -dn));
6276 push @cmd, qw(-x) unless $honour_ignores;
6277 my $leftovers = cmdoutput @cmd;
6278 if (length $leftovers) {
6279 print STDERR $leftovers, "\n" or confess "$!";
6280 $message .= $ignmessage if $honour_ignores;
6285 sub clean_tree_check_git_wd ($) {
6287 return if $cleanmode =~ m{no-check};
6288 return if $patches_applied_dirtily; # yuk
6289 clean_tree_check_git +($cleanmode !~ m{all-check}),
6290 $message, "\n".__ <<END;
6291 If this is just missing .gitignore entries, use a different clean
6292 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6293 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6297 sub clean_tree_check () {
6298 # This function needs to not care about modified but tracked files.
6299 # That was done by check_not_dirty, and by now we may have run
6300 # the rules clean target which might modify tracked files (!)
6301 if ($cleanmode =~ m{^check}) {
6302 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6303 "tree contains uncommitted files and --clean=check specified", '';
6304 } elsif ($cleanmode =~ m{^dpkg-source}) {
6305 clean_tree_check_git_wd __
6306 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6307 } elsif ($cleanmode =~ m{^git}) {
6308 clean_tree_check_git 1, __
6309 "tree contains uncommited, untracked, unignored files\n".
6310 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6311 } elsif ($cleanmode eq 'none') {
6313 confess "$cleanmode ?";
6318 # We always clean the tree ourselves, rather than leave it to the
6319 # builder (dpkg-source, or soemthing which calls dpkg-source).
6320 if ($cleanmode =~ m{^dpkg-source}) {
6321 my @cmd = @dpkgbuildpackage;
6322 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6323 push @cmd, qw(-T clean);
6324 maybe_apply_patches_dirtily();
6325 runcmd_ordryrun_local @cmd;
6326 clean_tree_check_git_wd __
6327 "tree contains uncommitted files (after running rules clean)";
6328 } elsif ($cleanmode =~ m{^git(?!-)}) {
6329 runcmd_ordryrun_local @git, qw(clean -xdf);
6330 } elsif ($cleanmode =~ m{^git-ff}) {
6331 runcmd_ordryrun_local @git, qw(clean -xdff);
6332 } elsif ($cleanmode =~ m{^check}) {
6334 } elsif ($cleanmode eq 'none') {
6336 confess "$cleanmode ?";
6341 badusage __ "clean takes no additional arguments" if @ARGV;
6344 maybe_unapply_patches_again();
6347 # return values from massage_dbp_args are one or both of these flags
6348 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6349 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6351 sub build_or_push_prep_early () {
6352 our $build_or_push_prep_early_done //= 0;
6353 return if $build_or_push_prep_early_done++;
6354 badusage f_ "-p is not allowed with dgit %s", $subcommand
6355 if defined $package;
6356 my $clogp = parsechangelog();
6357 $isuite = getfield $clogp, 'Distribution';
6358 $package = getfield $clogp, 'Source';
6359 $version = getfield $clogp, 'Version';
6360 $dscfn = dscfn($version);
6363 sub build_or_push_prep_modes () {
6364 my ($format,) = get_source_format();
6365 printdebug "format $format, quilt mode $quilt_mode\n";
6366 if (madformat_wantfixup($format) && quiltmode_splitbrain()) {
6367 $do_split_brain = 1;
6369 $do_split_brain //= 0;
6370 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
6371 if do_split_brain() && $includedirty;
6374 sub build_prep_early () {
6375 build_or_push_prep_early();
6377 build_or_push_prep_modes();
6381 sub build_prep ($) {
6385 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6386 # Clean the tree because we're going to use the contents of
6387 # $maindir. (We trying to include dirty changes in the source
6388 # package, or we are running the builder in $maindir.)
6389 || $cleanmode =~ m{always}) {
6390 # Or because the user asked us to.
6393 # We don't actually need to do anything in $maindir, but we
6394 # should do some kind of cleanliness check because (i) the
6395 # user may have forgotten a `git add', and (ii) if the user
6396 # said -wc we should still do the check.
6399 build_check_quilt_splitbrain();
6401 my $pat = changespat $version;
6402 foreach my $f (glob "$buildproductsdir/$pat") {
6405 fail f_ "remove old changes file %s: %s", $f, $!;
6407 progress f_ "would remove %s", $f;
6413 sub changesopts_initial () {
6414 my @opts =@changesopts[1..$#changesopts];
6417 sub changesopts_version () {
6418 if (!defined $changes_since_version) {
6421 @vsns = archive_query('archive_query');
6422 my @quirk = access_quirk();
6423 if ($quirk[0] eq 'backports') {
6424 local $isuite = $quirk[2];
6426 canonicalise_suite();
6427 push @vsns, archive_query('archive_query');
6433 "archive query failed (queried because --since-version not specified)";
6436 @vsns = map { $_->[0] } @vsns;
6437 @vsns = sort { -version_compare($a, $b) } @vsns;
6438 $changes_since_version = $vsns[0];
6439 progress f_ "changelog will contain changes since %s", $vsns[0];
6441 $changes_since_version = '_';
6442 progress __ "package seems new, not specifying -v<version>";
6445 if ($changes_since_version ne '_') {
6446 return ("-v$changes_since_version");
6452 sub changesopts () {
6453 return (changesopts_initial(), changesopts_version());
6456 sub massage_dbp_args ($;$) {
6457 my ($cmd,$xargs) = @_;
6458 # Since we split the source build out so we can do strange things
6459 # to it, massage the arguments to dpkg-buildpackage so that the
6460 # main build doessn't build source (or add an argument to stop it
6461 # building source by default).
6462 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6463 # -nc has the side effect of specifying -b if nothing else specified
6464 # and some combinations of -S, -b, et al, are errors, rather than
6465 # later simply overriding earlie. So we need to:
6466 # - search the command line for these options
6467 # - pick the last one
6468 # - perhaps add our own as a default
6469 # - perhaps adjust it to the corresponding non-source-building version
6471 foreach my $l ($cmd, $xargs) {
6473 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6476 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6477 my $r = WANTSRC_BUILDER;
6478 printdebug "massage split $dmode.\n";
6479 if ($dmode =~ s/^--build=//) {
6481 my @d = split /,/, $dmode;
6482 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6483 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6484 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6485 fail __ "Wanted to build nothing!" unless $r;
6486 $dmode = '--build='. join ',', grep m/./, @d;
6489 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6490 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6491 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6494 printdebug "massage done $r $dmode.\n";
6496 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6502 my $wasdir = must_getcwd();
6503 changedir $buildproductsdir;
6508 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6509 sub postbuild_mergechanges ($) {
6510 my ($msg_if_onlyone) = @_;
6511 # If there is only one .changes file, fail with $msg_if_onlyone,
6512 # or if that is undef, be a no-op.
6513 # Returns the changes file to report to the user.
6514 my $pat = changespat $version;
6515 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6516 @changesfiles = sort {
6517 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6521 if (@changesfiles==1) {
6522 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6523 only one changes file from build (%s)
6525 if defined $msg_if_onlyone;
6526 $result = $changesfiles[0];
6527 } elsif (@changesfiles==2) {
6528 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6529 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6530 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6533 runcmd_ordryrun_local @mergechanges, @changesfiles;
6534 my $multichanges = changespat $version,'multi';
6536 stat_exists $multichanges or fail f_
6537 "%s unexpectedly not created by build", $multichanges;
6538 foreach my $cf (glob $pat) {
6539 next if $cf eq $multichanges;
6540 rename "$cf", "$cf.inmulti" or fail f_
6541 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6544 $result = $multichanges;
6546 fail f_ "wrong number of different changes files (%s)",
6549 printdone f_ "build successful, results in %s\n", $result
6553 sub midbuild_checkchanges () {
6554 my $pat = changespat $version;
6555 return if $rmchanges;
6556 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6558 $_ ne changespat $version,'source' and
6559 $_ ne changespat $version,'multi'
6561 fail +(f_ <<END, $pat, "@unwanted")
6562 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6563 Suggest you delete %s.
6568 sub midbuild_checkchanges_vanilla ($) {
6570 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6573 sub postbuild_mergechanges_vanilla ($) {
6575 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6577 postbuild_mergechanges(undef);
6580 printdone __ "build successful\n";
6586 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6587 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6588 %s: warning: build-products-dir will be ignored; files will go to ..
6590 $buildproductsdir = '..';
6591 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6592 my $wantsrc = massage_dbp_args \@dbp;
6593 build_prep($wantsrc);
6594 if ($wantsrc & WANTSRC_SOURCE) {
6596 midbuild_checkchanges_vanilla $wantsrc;
6598 if ($wantsrc & WANTSRC_BUILDER) {
6599 push @dbp, changesopts_version();
6600 maybe_apply_patches_dirtily();
6601 runcmd_ordryrun_local @dbp;
6603 maybe_unapply_patches_again();
6604 postbuild_mergechanges_vanilla $wantsrc;
6608 $quilt_mode //= 'gbp';
6614 # gbp can make .origs out of thin air. In my tests it does this
6615 # even for a 1.0 format package, with no origs present. So I
6616 # guess it keys off just the version number. We don't know
6617 # exactly what .origs ought to exist, but let's assume that we
6618 # should run gbp if: the version has an upstream part and the main
6620 my $upstreamversion = upstreamversion $version;
6621 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6622 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6624 if ($gbp_make_orig) {
6626 $cleanmode = 'none'; # don't do it again
6629 my @dbp = @dpkgbuildpackage;
6631 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6633 if (!length $gbp_build[0]) {
6634 if (length executable_on_path('git-buildpackage')) {
6635 $gbp_build[0] = qw(git-buildpackage);
6637 $gbp_build[0] = 'gbp buildpackage';
6640 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6642 push @cmd, (qw(-us -uc --git-no-sign-tags),
6643 "--git-builder=".(shellquote @dbp));
6645 if ($gbp_make_orig) {
6646 my $priv = dgit_privdir();
6647 my $ok = "$priv/origs-gen-ok";
6648 unlink $ok or $!==&ENOENT or confess "$!";
6649 my @origs_cmd = @cmd;
6650 push @origs_cmd, qw(--git-cleaner=true);
6651 push @origs_cmd, "--git-prebuild=".
6652 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6653 push @origs_cmd, @ARGV;
6655 debugcmd @origs_cmd;
6657 do { local $!; stat_exists $ok; }
6658 or failedcmd @origs_cmd;
6660 dryrun_report @origs_cmd;
6664 build_prep($wantsrc);
6665 if ($wantsrc & WANTSRC_SOURCE) {
6667 midbuild_checkchanges_vanilla $wantsrc;
6669 push @cmd, '--git-cleaner=true';
6671 maybe_unapply_patches_again();
6672 if ($wantsrc & WANTSRC_BUILDER) {
6673 push @cmd, changesopts();
6674 runcmd_ordryrun_local @cmd, @ARGV;
6676 postbuild_mergechanges_vanilla $wantsrc;
6678 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6680 sub building_source_in_playtree {
6681 # If $includedirty, we have to build the source package from the
6682 # working tree, not a playtree, so that uncommitted changes are
6683 # included (copying or hardlinking them into the playtree could
6686 # Note that if we are building a source package in split brain
6687 # mode we do not support including uncommitted changes, because
6688 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6689 # building a source package)) => !$includedirty
6690 return !$includedirty;
6694 $sourcechanges = changespat $version,'source';
6696 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6697 or fail f_ "remove %s: %s", $sourcechanges, $!;
6699 # confess unless !!$made_split_brain == do_split_brain();
6701 my @cmd = (@dpkgsource, qw(-b --));
6703 if (building_source_in_playtree()) {
6705 my $headref = git_rev_parse('HEAD');
6706 # If we are in split brain, there is already a playtree with
6707 # the thing we should package into a .dsc (thanks to quilt
6708 # fixup). If not, make a playtree
6709 prep_ud() unless $made_split_brain;
6710 changedir $playground;
6711 unless ($made_split_brain) {
6712 my $upstreamversion = upstreamversion $version;
6713 unpack_playtree_linkorigs($upstreamversion, sub { });
6714 unpack_playtree_need_cd_work($headref);
6718 $leafdir = basename $maindir;
6720 if ($buildproductsdir ne '..') {
6721 # Well, we are going to run dpkg-source -b which consumes
6722 # origs from .. and generates output there. To make this
6723 # work when the bpd is not .. , we would have to (i) link
6724 # origs from bpd to .. , (ii) check for files that
6725 # dpkg-source -b would/might overwrite, and afterwards
6726 # (iii) move all the outputs back to the bpd (iv) except
6727 # for the origs which should be deleted from .. if they
6728 # weren't there beforehand. And if there is an error and
6729 # we don't run to completion we would necessarily leave a
6730 # mess. This is too much. The real way to fix this
6731 # is for dpkg-source to have bpd support.
6732 confess unless $includedirty;
6734 "--include-dirty not supported with --build-products-dir, sorry";
6739 runcmd_ordryrun_local @cmd, $leafdir;
6742 runcmd_ordryrun_local qw(sh -ec),
6743 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6744 @dpkggenchanges, qw(-S), changesopts();
6747 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6748 $dsc = parsecontrol($dscfn, "source package");
6752 printdebug " renaming ($why) $l\n";
6753 rename_link_xf 0, "$l", bpd_abs()."/$l"
6754 or fail f_ "put in place new built file (%s): %s", $l, $@;
6756 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6757 $l =~ m/\S+$/ or next;
6760 $mv->('dsc', $dscfn);
6761 $mv->('changes', $sourcechanges);
6766 sub cmd_build_source {
6767 badusage __ "build-source takes no additional arguments" if @ARGV;
6768 build_prep(WANTSRC_SOURCE);
6770 maybe_unapply_patches_again();
6771 printdone f_ "source built, results in %s and %s",
6772 $dscfn, $sourcechanges;
6775 sub cmd_push_source {
6778 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6779 "sense with push-source!"
6781 build_check_quilt_splitbrain();
6783 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6784 __ "source changes file");
6785 unless (test_source_only_changes($changes)) {
6786 fail __ "user-specified changes file is not source-only";
6789 # Building a source package is very fast, so just do it
6791 confess "er, patches are applied dirtily but shouldn't be.."
6792 if $patches_applied_dirtily;
6793 $changesfile = $sourcechanges;
6798 sub binary_builder {
6799 my ($bbuilder, $pbmc_msg, @args) = @_;
6800 build_prep(WANTSRC_SOURCE);
6802 midbuild_checkchanges();
6805 stat_exists $dscfn or fail f_
6806 "%s (in build products dir): %s", $dscfn, $!;
6807 stat_exists $sourcechanges or fail f_
6808 "%s (in build products dir): %s", $sourcechanges, $!;
6810 runcmd_ordryrun_local @$bbuilder, @args;
6812 maybe_unapply_patches_again();
6814 postbuild_mergechanges($pbmc_msg);
6820 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6821 perhaps you need to pass -A ? (sbuild's default is to build only
6822 arch-specific binaries; dgit 1.4 used to override that.)
6827 my ($pbuilder) = @_;
6829 # @ARGV is allowed to contain only things that should be passed to
6830 # pbuilder under debbuildopts; just massage those
6831 my $wantsrc = massage_dbp_args \@ARGV;
6833 "you asked for a builder but your debbuildopts didn't ask for".
6834 " any binaries -- is this really what you meant?"
6835 unless $wantsrc & WANTSRC_BUILDER;
6837 "we must build a .dsc to pass to the builder but your debbuiltopts".
6838 " forbids the building of a source package; cannot continue"
6839 unless $wantsrc & WANTSRC_SOURCE;
6840 # We do not want to include the verb "build" in @pbuilder because
6841 # the user can customise @pbuilder and they shouldn't be required
6842 # to include "build" in their customised value. However, if the
6843 # user passes any additional args to pbuilder using the dgit
6844 # option --pbuilder:foo, such args need to come after the "build"
6845 # verb. opts_opt_multi_cmd does all of that.
6846 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6847 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6852 pbuilder(\@pbuilder);
6855 sub cmd_cowbuilder {
6856 pbuilder(\@cowbuilder);
6859 sub cmd_quilt_fixup {
6860 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6863 build_maybe_quilt_fixup();
6866 sub cmd_print_unapplied_treeish {
6867 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6869 my $headref = git_rev_parse('HEAD');
6870 my $clogp = commit_getclogp $headref;
6871 $package = getfield $clogp, 'Source';
6872 $version = getfield $clogp, 'Version';
6873 $isuite = getfield $clogp, 'Distribution';
6874 $csuite = $isuite; # we want this to be offline!
6878 changedir $playground;
6879 my $uv = upstreamversion $version;
6880 my $u = quilt_fakedsc2unapplied($headref, $uv);
6881 print $u, "\n" or confess "$!";
6884 sub import_dsc_result {
6885 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6886 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6888 check_gitattrs($newhash, __ "source tree");
6890 progress f_ "dgit: import-dsc: %s", $what_msg;
6893 sub cmd_import_dsc {
6897 last unless $ARGV[0] =~ m/^-/;
6900 if (m/^--require-valid-signature$/) {
6903 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6907 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6909 my ($dscfn, $dstbranch) = @ARGV;
6911 badusage __ "dry run makes no sense with import-dsc"
6914 my $force = $dstbranch =~ s/^\+// ? +1 :
6915 $dstbranch =~ s/^\.\.// ? -1 :
6917 my $info = $force ? " $&" : '';
6918 $info = "$dscfn$info";
6920 my $specbranch = $dstbranch;
6921 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6922 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6924 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6925 my $chead = cmdoutput_errok @symcmd;
6926 defined $chead or $?==256 or failedcmd @symcmd;
6928 fail f_ "%s is checked out - will not update it", $dstbranch
6929 if defined $chead and $chead eq $dstbranch;
6931 my $oldhash = git_get_ref $dstbranch;
6933 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6934 $dscdata = do { local $/ = undef; <D>; };
6935 D->error and fail f_ "read %s: %s", $dscfn, $!;
6938 # we don't normally need this so import it here
6939 use Dpkg::Source::Package;
6940 my $dp = new Dpkg::Source::Package filename => $dscfn,
6941 require_valid_signature => $needsig;
6943 local $SIG{__WARN__} = sub {
6945 return unless $needsig;
6946 fail __ "import-dsc signature check failed";
6948 if (!$dp->is_signed()) {
6949 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6951 my $r = $dp->check_signature();
6952 confess "->check_signature => $r" if $needsig && $r;
6958 $package = getfield $dsc, 'Source';
6960 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6961 unless forceing [qw(import-dsc-with-dgit-field)];
6962 parse_dsc_field_def_dsc_distro();
6964 $isuite = 'DGIT-IMPORT-DSC';
6965 $idistro //= $dsc_distro;
6969 if (defined $dsc_hash) {
6971 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6972 resolve_dsc_field_commit undef, undef;
6974 if (defined $dsc_hash) {
6975 my @cmd = (qw(sh -ec),
6976 "echo $dsc_hash | git cat-file --batch-check");
6977 my $objgot = cmdoutput @cmd;
6978 if ($objgot =~ m#^\w+ missing\b#) {
6979 fail f_ <<END, $dsc_hash
6980 .dsc contains Dgit field referring to object %s
6981 Your git tree does not have that object. Try `git fetch' from a
6982 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6985 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6987 progress __ "Not fast forward, forced update.";
6989 fail f_ "Not fast forward to %s", $dsc_hash;
6992 import_dsc_result $dstbranch, $dsc_hash,
6993 "dgit import-dsc (Dgit): $info",
6994 f_ "updated git ref %s", $dstbranch;
6998 fail f_ <<END, $dstbranch, $specbranch, $specbranch
6999 Branch %s already exists
7000 Specify ..%s for a pseudo-merge, binding in existing history
7001 Specify +%s to overwrite, discarding existing history
7003 if $oldhash && !$force;
7005 my @dfi = dsc_files_info();
7006 foreach my $fi (@dfi) {
7007 my $f = $fi->{Filename};
7008 # We transfer all the pieces of the dsc to the bpd, not just
7009 # origs. This is by analogy with dgit fetch, which wants to
7010 # keep them somewhere to avoid downloading them again.
7011 # We make symlinks, though. If the user wants copies, then
7012 # they can copy the parts of the dsc to the bpd using dcmd,
7014 my $here = "$buildproductsdir/$f";
7019 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7021 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7022 printdebug "not in bpd, $f ...\n";
7023 # $f does not exist in bpd, we need to transfer it
7025 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7026 # $there is file we want, relative to user's cwd, or abs
7027 printdebug "not in bpd, $f, test $there ...\n";
7028 stat $there or fail f_
7029 "import %s requires %s, but: %s", $dscfn, $there, $!;
7030 if ($there =~ m#^(?:\./+)?\.\./+#) {
7031 # $there is relative to user's cwd
7032 my $there_from_parent = $';
7033 if ($buildproductsdir !~ m{^/}) {
7034 # abs2rel, despite its name, can take two relative paths
7035 $there = File::Spec->abs2rel($there,$buildproductsdir);
7036 # now $there is relative to bpd, great
7037 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7039 $there = (dirname $maindir)."/$there_from_parent";
7040 # now $there is absoute
7041 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7043 } elsif ($there =~ m#^/#) {
7044 # $there is absolute already
7045 printdebug "not in bpd, $f, abs, $there ...\n";
7048 "cannot import %s which seems to be inside working tree!",
7051 symlink $there, $here or fail f_
7052 "symlink %s to %s: %s", $there, $here, $!;
7053 progress f_ "made symlink %s -> %s", $here, $there;
7054 # print STDERR Dumper($fi);
7056 my @mergeinputs = generate_commits_from_dsc();
7057 die unless @mergeinputs == 1;
7059 my $newhash = $mergeinputs[0]{Commit};
7064 "Import, forced update - synthetic orphan git history.";
7065 } elsif ($force < 0) {
7066 progress __ "Import, merging.";
7067 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7068 my $version = getfield $dsc, 'Version';
7069 my $clogp = commit_getclogp $newhash;
7070 my $authline = clogp_authline $clogp;
7071 $newhash = make_commit_text <<ENDU
7079 .(f_ <<END, $package, $version, $dstbranch);
7080 Merge %s (%s) import into %s
7083 die; # caught earlier
7087 import_dsc_result $dstbranch, $newhash,
7088 "dgit import-dsc: $info",
7089 f_ "results are in git ref %s", $dstbranch;
7092 sub pre_archive_api_query () {
7093 not_necessarily_a_tree();
7095 sub cmd_archive_api_query {
7096 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7097 my ($subpath) = @ARGV;
7098 local $isuite = 'DGIT-API-QUERY-CMD';
7099 my @cmd = archive_api_query_cmd($subpath);
7102 exec @cmd or fail f_ "exec curl: %s\n", $!;
7105 sub repos_server_url () {
7106 $package = '_dgit-repos-server';
7107 local $access_forpush = 1;
7108 local $isuite = 'DGIT-REPOS-SERVER';
7109 my $url = access_giturl();
7112 sub pre_clone_dgit_repos_server () {
7113 not_necessarily_a_tree();
7115 sub cmd_clone_dgit_repos_server {
7116 badusage __ "need destination argument" unless @ARGV==1;
7117 my ($destdir) = @ARGV;
7118 my $url = repos_server_url();
7119 my @cmd = (@git, qw(clone), $url, $destdir);
7121 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7124 sub pre_print_dgit_repos_server_source_url () {
7125 not_necessarily_a_tree();
7127 sub cmd_print_dgit_repos_server_source_url {
7129 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7131 my $url = repos_server_url();
7132 print $url, "\n" or confess "$!";
7135 sub pre_print_dpkg_source_ignores {
7136 not_necessarily_a_tree();
7138 sub cmd_print_dpkg_source_ignores {
7140 "no arguments allowed to dgit print-dpkg-source-ignores"
7142 print "@dpkg_source_ignores\n" or confess "$!";
7145 sub cmd_setup_mergechangelogs {
7146 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7148 local $isuite = 'DGIT-SETUP-TREE';
7149 setup_mergechangelogs(1);
7152 sub cmd_setup_useremail {
7153 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7154 local $isuite = 'DGIT-SETUP-TREE';
7158 sub cmd_setup_gitattributes {
7159 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7160 local $isuite = 'DGIT-SETUP-TREE';
7164 sub cmd_setup_new_tree {
7165 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7166 local $isuite = 'DGIT-SETUP-TREE';
7170 #---------- argument parsing and main program ----------
7173 print "dgit version $our_version\n" or confess "$!";
7177 our (%valopts_long, %valopts_short);
7178 our (%funcopts_long);
7180 our (@modeopt_cfgs);
7182 sub defvalopt ($$$$) {
7183 my ($long,$short,$val_re,$how) = @_;
7184 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7185 $valopts_long{$long} = $oi;
7186 $valopts_short{$short} = $oi;
7187 # $how subref should:
7188 # do whatever assignemnt or thing it likes with $_[0]
7189 # if the option should not be passed on to remote, @rvalopts=()
7190 # or $how can be a scalar ref, meaning simply assign the value
7193 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7194 defvalopt '--distro', '-d', '.+', \$idistro;
7195 defvalopt '', '-k', '.+', \$keyid;
7196 defvalopt '--existing-package','', '.*', \$existing_package;
7197 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7198 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7199 defvalopt '--package', '-p', $package_re, \$package;
7200 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7202 defvalopt '', '-C', '.+', sub {
7203 ($changesfile) = (@_);
7204 if ($changesfile =~ s#^(.*)/##) {
7205 $buildproductsdir = $1;
7209 defvalopt '--initiator-tempdir','','.*', sub {
7210 ($initiator_tempdir) = (@_);
7211 $initiator_tempdir =~ m#^/# or
7212 badusage __ "--initiator-tempdir must be used specify an".
7213 " absolute, not relative, directory."
7216 sub defoptmodes ($@) {
7217 my ($varref, $cfgkey, $default, %optmap) = @_;
7219 while (my ($opt,$val) = each %optmap) {
7220 $funcopts_long{$opt} = sub { $$varref = $val; };
7221 $permit{$val} = $val;
7223 push @modeopt_cfgs, {
7226 Default => $default,
7231 defoptmodes \$dodep14tag, qw( dep14tag want
7234 --always-dep14tag always );
7239 if (defined $ENV{'DGIT_SSH'}) {
7240 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7241 } elsif (defined $ENV{'GIT_SSH'}) {
7242 @ssh = ($ENV{'GIT_SSH'});
7250 if (!defined $val) {
7251 badusage f_ "%s needs a value", $what unless @ARGV;
7253 push @rvalopts, $val;
7255 badusage f_ "bad value \`%s' for %s", $val, $what unless
7256 $val =~ m/^$oi->{Re}$(?!\n)/s;
7257 my $how = $oi->{How};
7258 if (ref($how) eq 'SCALAR') {
7263 push @ropts, @rvalopts;
7267 last unless $ARGV[0] =~ m/^-/;
7271 if (m/^--dry-run$/) {
7274 } elsif (m/^--damp-run$/) {
7277 } elsif (m/^--no-sign$/) {
7280 } elsif (m/^--help$/) {
7282 } elsif (m/^--version$/) {
7284 } elsif (m/^--new$/) {
7287 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7288 ($om = $opts_opt_map{$1}) &&
7292 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7293 !$opts_opt_cmdonly{$1} &&
7294 ($om = $opts_opt_map{$1})) {
7297 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7298 !$opts_opt_cmdonly{$1} &&
7299 ($om = $opts_opt_map{$1})) {
7301 my $cmd = shift @$om;
7302 @$om = ($cmd, grep { $_ ne $2 } @$om);
7303 } elsif (m/^--(gbp|dpm)$/s) {
7304 push @ropts, "--quilt=$1";
7306 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7309 } elsif (m/^--no-quilt-fixup$/s) {
7311 $quilt_mode = 'nocheck';
7312 } elsif (m/^--no-rm-on-error$/s) {
7315 } elsif (m/^--no-chase-dsc-distro$/s) {
7317 $chase_dsc_distro = 0;
7318 } elsif (m/^--overwrite$/s) {
7320 $overwrite_version = '';
7321 } elsif (m/^--overwrite=(.+)$/s) {
7323 $overwrite_version = $1;
7324 } elsif (m/^--delayed=(\d+)$/s) {
7327 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7328 m/^--(dgit-view)-save=(.+)$/s
7330 my ($k,$v) = ($1,$2);
7332 $v =~ s#^(?!refs/)#refs/heads/#;
7333 $internal_object_save{$k} = $v;
7334 } elsif (m/^--(no-)?rm-old-changes$/s) {
7337 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7339 push @deliberatelies, $&;
7340 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7344 } elsif (m/^--force-/) {
7346 f_ "%s: warning: ignoring unknown force option %s\n",
7349 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7350 # undocumented, for testing
7352 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7353 # ^ it's supposed to be an array ref
7354 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7355 $val = $2 ? $' : undef; #';
7356 $valopt->($oi->{Long});
7357 } elsif ($funcopts_long{$_}) {
7359 $funcopts_long{$_}();
7361 badusage f_ "unknown long option \`%s'", $_;
7368 } elsif (s/^-L/-/) {
7371 } elsif (s/^-h/-/) {
7373 } elsif (s/^-D/-/) {
7377 } elsif (s/^-N/-/) {
7382 push @changesopts, $_;
7384 } elsif (s/^-wn$//s) {
7386 $cleanmode = 'none';
7387 } elsif (s/^-wg(f?)(a?)$//s) {
7390 $cleanmode .= '-ff' if $1;
7391 $cleanmode .= ',always' if $2;
7392 } elsif (s/^-wd(d?)([na]?)$//s) {
7394 $cleanmode = 'dpkg-source';
7395 $cleanmode .= '-d' if $1;
7396 $cleanmode .= ',no-check' if $2 eq 'n';
7397 $cleanmode .= ',all-check' if $2 eq 'a';
7398 } elsif (s/^-wc$//s) {
7400 $cleanmode = 'check';
7401 } elsif (s/^-wci$//s) {
7403 $cleanmode = 'check,ignores';
7404 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7405 push @git, '-c', $&;
7406 $gitcfgs{cmdline}{$1} = [ $2 ];
7407 } elsif (s/^-c([^=]+)$//s) {
7408 push @git, '-c', $&;
7409 $gitcfgs{cmdline}{$1} = [ 'true' ];
7410 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7412 $val = undef unless length $val;
7413 $valopt->($oi->{Short});
7416 badusage f_ "unknown short option \`%s'", $_;
7423 sub check_env_sanity () {
7424 my $blocked = new POSIX::SigSet;
7425 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7428 foreach my $name (qw(PIPE CHLD)) {
7429 my $signame = "SIG$name";
7430 my $signum = eval "POSIX::$signame" // die;
7431 die f_ "%s is set to something other than SIG_DFL\n",
7433 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7434 $blocked->ismember($signum) and
7435 die f_ "%s is blocked\n", $signame;
7441 On entry to dgit, %s
7442 This is a bug produced by something in your execution environment.
7448 sub parseopts_late_defaults () {
7449 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7450 if defined $idistro;
7451 $isuite //= cfg('dgit.default.default-suite');
7453 foreach my $k (keys %opts_opt_map) {
7454 my $om = $opts_opt_map{$k};
7456 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7458 badcfg f_ "cannot set command for %s", $k
7459 unless length $om->[0];
7463 foreach my $c (access_cfg_cfgs("opts-$k")) {
7465 map { $_ ? @$_ : () }
7466 map { $gitcfgs{$_}{$c} }
7467 reverse @gitcfgsources;
7468 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7469 "\n" if $debuglevel >= 4;
7471 badcfg f_ "cannot configure options for %s", $k
7472 if $opts_opt_cmdonly{$k};
7473 my $insertpos = $opts_cfg_insertpos{$k};
7474 @$om = ( @$om[0..$insertpos-1],
7476 @$om[$insertpos..$#$om] );
7480 if (!defined $rmchanges) {
7481 local $access_forpush;
7482 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7485 if (!defined $quilt_mode) {
7486 local $access_forpush;
7487 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7488 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7490 $quilt_mode =~ m/^($quilt_modes_re)$/
7491 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7495 foreach my $moc (@modeopt_cfgs) {
7496 local $access_forpush;
7497 my $vr = $moc->{Var};
7498 next if defined $$vr;
7499 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7500 my $v = $moc->{Vals}{$$vr};
7501 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7507 local $access_forpush;
7508 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7512 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7513 $buildproductsdir //= '..';
7514 $bpd_glob = $buildproductsdir;
7515 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7518 setlocale(LC_MESSAGES, "");
7521 if ($ENV{$fakeeditorenv}) {
7523 quilt_fixup_editor();
7529 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7530 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7531 if $dryrun_level == 1;
7533 print STDERR __ $helpmsg or confess "$!";
7536 $cmd = $subcommand = shift @ARGV;
7539 my $pre_fn = ${*::}{"pre_$cmd"};
7540 $pre_fn->() if $pre_fn;
7542 if ($invoked_in_git_tree) {
7543 changedir_git_toplevel();
7548 my $fn = ${*::}{"cmd_$cmd"};
7549 $fn or badusage f_ "unknown operation %s", $cmd;