3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2019 Ian Jackson
6 # Copyright (C)2017-2019 Sean Whitton
7 # Copyright (C)2019 Matthew Vernon / Sanger Institute
9 # This program is free software: you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation, either version 3 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program. If not, see <http://www.gnu.org/licenses/>.
22 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
23 use Debian::Dgit::ExitStatus;
24 use Debian::Dgit::I18n;
28 use Debian::Dgit qw(:DEFAULT :playground);
34 use Dpkg::Control::Hash;
37 use File::Temp qw(tempdir);
40 use Dpkg::Compression;
41 use Dpkg::Compression::Process;
47 use List::MoreUtils qw(pairwise);
48 use Text::Glob qw(match_glob);
49 use Fcntl qw(:DEFAULT :flock);
54 our $our_version = 'UNRELEASED'; ###substituted###
55 our $absurdity = undef; ###substituted###
57 our @rpushprotovsn_support = qw(6 5 4); # Reverse order!
68 our $dryrun_level = 0;
70 our $buildproductsdir;
73 our $includedirty = 0;
77 our $existing_package = 'dpkg';
79 our $changes_since_version;
81 our $overwrite_version; # undef: not specified; '': check changelog
83 our $quilt_upstream_commitish;
84 our $quilt_upstream_commitish_used;
85 our $quilt_upstream_commitish_message;
86 our $quilt_options_re = 'gbp|dpm|baredebian(?:\+tarball|\+git)?';
87 our $quilt_modes_re = "linear|smash|auto|nofix|nocheck|unapplied|$quilt_options_re";
89 our $splitview_modes_re = qr{auto|always|never};
91 our %internal_object_save;
92 our $we_are_responder;
93 our $we_are_initiator;
94 our $initiator_tempdir;
95 our $patches_applied_dirtily = 00;
96 our $chase_dsc_distro=1;
98 our %forceopts = map { $_=>0 }
99 qw(unrepresentable unsupported-source-format
100 dsc-changes-mismatch changes-origs-exactly
101 uploading-binaries uploading-source-only
102 import-gitapply-absurd
103 import-gitapply-no-absurd
104 import-dsc-with-dgit-field);
106 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
108 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
109 | (?: git | git-ff ) (?: ,always )?
110 | check (?: ,ignores )?
114 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
115 our $splitbraincache = 'dgit-intern/quilt-cache';
116 our $rewritemap = 'dgit-rewrite/map';
118 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
120 our (@git) = qw(git);
121 our (@dget) = qw(dget);
122 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
123 our (@dput) = qw(dput);
124 our (@debsign) = qw(debsign);
125 our (@gpg) = qw(gpg);
126 our (@sbuild) = (qw(sbuild --no-source));
128 our (@dgit) = qw(dgit);
129 our (@git_debrebase) = qw(git-debrebase);
130 our (@aptget) = qw(apt-get);
131 our (@aptcache) = qw(apt-cache);
132 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
133 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
134 our (@dpkggenchanges) = qw(dpkg-genchanges);
135 our (@mergechanges) = qw(mergechanges -f);
136 our (@gbp_build) = ('');
137 our (@gbp_pq) = ('gbp pq');
138 our (@changesopts) = ('');
139 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
140 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
142 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
145 'debsign' => \@debsign,
147 'sbuild' => \@sbuild,
151 'git-debrebase' => \@git_debrebase,
152 'apt-get' => \@aptget,
153 'apt-cache' => \@aptcache,
154 'dpkg-source' => \@dpkgsource,
155 'dpkg-buildpackage' => \@dpkgbuildpackage,
156 'dpkg-genchanges' => \@dpkggenchanges,
157 'gbp-build' => \@gbp_build,
158 'gbp-pq' => \@gbp_pq,
159 'ch' => \@changesopts,
160 'mergechanges' => \@mergechanges,
161 'pbuilder' => \@pbuilder,
162 'cowbuilder' => \@cowbuilder);
164 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
165 our %opts_cfg_insertpos = map {
167 scalar @{ $opts_opt_map{$_} }
168 } keys %opts_opt_map;
170 sub parseopts_late_defaults();
171 sub quiltify_trees_differ ($$;$$$);
172 sub setup_gitattrs(;$);
173 sub check_gitattrs($$);
180 our $supplementary_message = '';
181 our $made_split_brain = 0;
184 # Interactions between quilt mode and split brain
185 # (currently, split brain only implemented iff
186 # madformat_wantfixup && quiltmode_splitting)
188 # source format sane `3.0 (quilt)'
189 # madformat_wantfixup()
191 # quilt mode normal quiltmode
192 # (eg linear) _splitbrain
194 # ------------ ------------------------------------------------
196 # no split no q cache no q cache forbidden,
197 # brain PM on master q fixup on master prevented
198 # !do_split_brain() PM on master
200 # split brain no q cache q fixup cached, to dgit view
201 # PM in dgit view PM in dgit view
203 # PM = pseudomerge to make ff, due to overwrite (or split view)
204 # "no q cache" = do not record in cache on build, do not check cache
205 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
209 return unless forkcheck_mainprocess();
210 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
213 our $remotename = 'dgit';
214 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
218 if (!defined $absurdity) {
220 $absurdity =~ s{/[^/]+$}{/absurd} or die;
223 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
225 sub lbranch () { return "$branchprefix/$csuite"; }
226 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
227 sub lref () { return "refs/heads/".lbranch(); }
228 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
229 sub rrref () { return server_ref($csuite); }
232 my ($vsn, $sfx) = @_;
233 return &source_file_leafname($package, $vsn, $sfx);
235 sub is_orig_file_of_vsn ($$) {
236 my ($f, $upstreamvsn) = @_;
237 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
242 return srcfn($vsn,".dsc");
245 sub changespat ($;$) {
246 my ($vsn, $arch) = @_;
247 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
256 return unless forkcheck_mainprocess();
257 foreach my $f (@end) {
259 print STDERR "$us: cleanup: $@" if length $@;
264 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
268 sub forceable_fail ($$) {
269 my ($forceoptsl, $msg) = @_;
270 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
271 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
275 my ($forceoptsl) = @_;
276 my @got = grep { $forceopts{$_} } @$forceoptsl;
277 return 0 unless @got;
279 "warning: skipping checks or functionality due to --force-%s\n",
283 sub no_such_package () {
284 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
285 $us, $package, $isuite;
289 sub deliberately ($) {
291 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
294 sub deliberately_not_fast_forward () {
295 foreach (qw(not-fast-forward fresh-repo)) {
296 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
300 sub quiltmode_splitting () {
301 $quilt_mode =~ m/gbp|dpm|unapplied|baredebian/;
303 sub format_quiltmode_splitting ($) {
305 return madformat_wantfixup($format) && quiltmode_splitting();
308 sub do_split_brain () { !!($do_split_brain // confess) }
310 sub opts_opt_multi_cmd {
313 push @cmd, split /\s+/, shift @_;
320 return opts_opt_multi_cmd [], @gbp_pq;
323 sub dgit_privdir () {
324 our $dgit_privdir_made //= ensure_a_playground 'dgit';
328 my $r = $buildproductsdir;
329 $r = "$maindir/$r" unless $r =~ m{^/};
333 sub get_tree_of_commit ($) {
334 my ($commitish) = @_;
335 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
336 $cdata =~ m/\n\n/; $cdata = $`;
337 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
341 sub branch_gdr_info ($$) {
342 my ($symref, $head) = @_;
343 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
344 gdr_ffq_prev_branchinfo($symref);
345 return () unless $status eq 'branch';
346 $ffq_prev = git_get_ref $ffq_prev;
347 $gdrlast = git_get_ref $gdrlast;
348 $gdrlast &&= is_fast_fwd $gdrlast, $head;
349 return ($ffq_prev, $gdrlast);
352 sub branch_is_gdr_unstitched_ff ($$$) {
353 my ($symref, $head, $ancestor) = @_;
354 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
355 return 0 unless $ffq_prev;
356 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
360 sub branch_is_gdr ($) {
362 # This is quite like git-debrebase's keycommits.
363 # We have our own implementation because:
364 # - our algorighm can do fewer tests so is faster
365 # - it saves testing to see if gdr is installed
367 # NB we use this jsut for deciding whether to run gdr make-patches
368 # Before reusing this algorithm for somthing else, its
369 # suitability should be reconsidered.
372 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
373 printdebug "branch_is_gdr $head...\n";
374 my $get_patches = sub {
375 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
378 my $tip_patches = $get_patches->($head);
381 my $cdata = git_cat_file $walk, 'commit';
382 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
383 if ($msg =~ m{^\[git-debrebase\ (
384 anchor | changelog | make-patches |
385 merged-breakwater | pseudomerge
387 # no need to analyse this - it's sufficient
388 # (gdr classifications: Anchor, MergedBreakwaters)
389 # (made by gdr: Pseudomerge, Changelog)
390 printdebug "branch_is_gdr $walk gdr $1 YES\n";
393 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
395 my $walk_tree = get_tree_of_commit $walk;
396 foreach my $p (@parents) {
397 my $p_tree = get_tree_of_commit $p;
398 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
399 # (gdr classification: Pseudomerge; not made by gdr)
400 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
406 # some other non-gdr merge
407 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
408 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
412 # (gdr classification: ?)
413 printdebug "branch_is_gdr $walk ?-octopus NO\n";
417 printdebug "branch_is_gdr $walk origin\n";
420 if ($get_patches->($walk) ne $tip_patches) {
421 # Our parent added, removed, or edited patches, and wasn't
422 # a gdr make-patches commit. gdr make-patches probably
423 # won't do that well, then.
424 # (gdr classification of parent: AddPatches or ?)
425 printdebug "branch_is_gdr $walk ?-patches NO\n";
428 if ($tip_patches eq '' and
429 !defined git_cat_file "$walk~:debian" and
430 !quiltify_trees_differ "$walk~", $walk
432 # (gdr classification of parent: BreakwaterStart
433 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
436 # (gdr classification: Upstream Packaging Mixed Changelog)
437 printdebug "branch_is_gdr $walk plain\n"
443 #---------- remote protocol support, common ----------
445 # remote push initiator/responder protocol:
446 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
447 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
448 # < dgit-remote-push-ready <actual-proto-vsn>
455 # > supplementary-message NBYTES
460 # > file parsed-changelog
461 # [indicates that output of dpkg-parsechangelog follows]
462 # > data-block NBYTES
463 # > [NBYTES bytes of data (no newline)]
464 # [maybe some more blocks]
473 # > param head DGIT-VIEW-HEAD
474 # > param csuite SUITE
475 # > param tagformat new # $protovsn == 4
476 # > param splitbrain 0|1 # $protovsn >= 6
477 # > param maint-view MAINT-VIEW-HEAD
479 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
480 # > file buildinfo # for buildinfos to sign
482 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
483 # # goes into tag, for replay prevention
486 # [indicates that signed tag is wanted]
487 # < data-block NBYTES
488 # < [NBYTES bytes of data (no newline)]
489 # [maybe some more blocks]
493 # > want signed-dsc-changes
494 # < data-block NBYTES [transfer of signed dsc]
496 # < data-block NBYTES [transfer of signed changes]
498 # < data-block NBYTES [transfer of each signed buildinfo
499 # [etc] same number and order as "file buildinfo"]
507 sub i_child_report () {
508 # Sees if our child has died, and reap it if so. Returns a string
509 # describing how it died if it failed, or undef otherwise.
510 return undef unless $i_child_pid;
511 my $got = waitpid $i_child_pid, WNOHANG;
512 return undef if $got <= 0;
513 die unless $got == $i_child_pid;
514 $i_child_pid = undef;
515 return undef unless $?;
516 return f_ "build host child %s", waitstatusmsg();
521 fail f_ "connection lost: %s", $! if $fh->error;
522 fail f_ "protocol violation; %s not expected", $m;
525 sub badproto_badread ($$) {
527 fail f_ "connection lost: %s", $! if $!;
528 my $report = i_child_report();
529 fail $report if defined $report;
530 badproto $fh, f_ "eof (reading %s)", $wh;
533 sub protocol_expect (&$) {
534 my ($match, $fh) = @_;
537 defined && chomp or badproto_badread $fh, __ "protocol message";
545 badproto $fh, f_ "\`%s'", $_;
548 sub protocol_send_file ($$) {
549 my ($fh, $ourfn) = @_;
550 open PF, "<", $ourfn or die "$ourfn: $!";
553 my $got = read PF, $d, 65536;
554 die "$ourfn: $!" unless defined $got;
556 print $fh "data-block ".length($d)."\n" or confess "$!";
557 print $fh $d or confess "$!";
559 PF->error and die "$ourfn $!";
560 print $fh "data-end\n" or confess "$!";
564 sub protocol_read_bytes ($$) {
565 my ($fh, $nbytes) = @_;
566 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
568 my $got = read $fh, $d, $nbytes;
569 $got==$nbytes or badproto_badread $fh, __ "data block";
573 sub protocol_receive_file ($$) {
574 my ($fh, $ourfn) = @_;
575 printdebug "() $ourfn\n";
576 open PF, ">", $ourfn or die "$ourfn: $!";
578 my ($y,$l) = protocol_expect {
579 m/^data-block (.*)$/ ? (1,$1) :
580 m/^data-end$/ ? (0,) :
584 my $d = protocol_read_bytes $fh, $l;
585 print PF $d or confess "$!";
587 close PF or confess "$!";
590 #---------- remote protocol support, responder ----------
592 sub responder_send_command ($) {
594 return unless $we_are_responder;
595 # called even without $we_are_responder
596 printdebug ">> $command\n";
597 print PO $command, "\n" or confess "$!";
600 sub responder_send_file ($$) {
601 my ($keyword, $ourfn) = @_;
602 return unless $we_are_responder;
603 printdebug "]] $keyword $ourfn\n";
604 responder_send_command "file $keyword";
605 protocol_send_file \*PO, $ourfn;
608 sub responder_receive_files ($@) {
609 my ($keyword, @ourfns) = @_;
610 die unless $we_are_responder;
611 printdebug "[[ $keyword @ourfns\n";
612 responder_send_command "want $keyword";
613 foreach my $fn (@ourfns) {
614 protocol_receive_file \*PI, $fn;
617 protocol_expect { m/^files-end$/ } \*PI;
620 #---------- remote protocol support, initiator ----------
622 sub initiator_expect (&) {
624 protocol_expect { &$match } \*RO;
627 #---------- end remote code ----------
630 if ($we_are_responder) {
632 responder_send_command "progress ".length($m) or confess "$!";
633 print PO $m or confess "$!";
643 $ua = LWP::UserAgent->new();
647 progress "downloading $what...";
648 my $r = $ua->get(@_) or confess "$!";
649 return undef if $r->code == 404;
650 $r->is_success or fail f_ "failed to fetch %s: %s",
651 $what, $r->status_line;
652 return $r->decoded_content(charset => 'none');
655 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
657 sub act_local () { return $dryrun_level <= 1; }
658 sub act_scary () { return !$dryrun_level; }
661 if (!$dryrun_level) {
662 progress f_ "%s ok: %s", $us, "@_";
664 progress f_ "would be ok: %s (but dry run only)", "@_";
669 printcmd(\*STDERR,$debugprefix."#",@_);
672 sub runcmd_ordryrun {
680 sub runcmd_ordryrun_local {
688 our $helpmsg = i_ <<END;
690 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
691 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
692 dgit [dgit-opts] build [dpkg-buildpackage-opts]
693 dgit [dgit-opts] sbuild [sbuild-opts]
694 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
695 dgit [dgit-opts] push [dgit-opts] [suite]
696 dgit [dgit-opts] push-source [dgit-opts] [suite]
697 dgit [dgit-opts] rpush build-host:build-dir ...
698 important dgit options:
699 -k<keyid> sign tag and package with <keyid> instead of default
700 --dry-run -n do not change anything, but go through the motions
701 --damp-run -L like --dry-run but make local changes, without signing
702 --new -N allow introducing a new package
703 --debug -D increase debug level
704 -c<name>=<value> set git config option (used directly by dgit too)
707 our $later_warning_msg = i_ <<END;
708 Perhaps the upload is stuck in incoming. Using the version from git.
712 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
717 @ARGV or badusage __ "too few arguments";
718 return scalar shift @ARGV;
722 not_necessarily_a_tree();
725 print __ $helpmsg or confess "$!";
729 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
731 our %defcfg = ('dgit.default.distro' => 'debian',
732 'dgit.default.default-suite' => 'unstable',
733 'dgit.default.old-dsc-distro' => 'debian',
734 'dgit-suite.*-security.distro' => 'debian-security',
735 'dgit.default.username' => '',
736 'dgit.default.archive-query-default-component' => 'main',
737 'dgit.default.ssh' => 'ssh',
738 'dgit.default.archive-query' => 'madison:',
739 'dgit.default.sshpsql-dbname' => 'service=projectb',
740 'dgit.default.aptget-components' => 'main',
741 'dgit.default.source-only-uploads' => 'ok',
742 'dgit.dsc-url-proto-ok.http' => 'true',
743 'dgit.dsc-url-proto-ok.https' => 'true',
744 'dgit.dsc-url-proto-ok.git' => 'true',
745 'dgit.vcs-git.suites', => 'sid', # ;-separated
746 'dgit.default.dsc-url-proto-ok' => 'false',
747 # old means "repo server accepts pushes with old dgit tags"
748 # new means "repo server accepts pushes with new dgit tags"
749 # maint means "repo server accepts split brain pushes"
750 # hist means "repo server may have old pushes without new tag"
751 # ("hist" is implied by "old")
752 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
753 'dgit-distro.debian.git-check' => 'url',
754 'dgit-distro.debian.git-check-suffix' => '/info/refs',
755 'dgit-distro.debian.new-private-pushers' => 't',
756 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
757 'dgit-distro.debian/push.git-url' => '',
758 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
759 'dgit-distro.debian/push.git-user-force' => 'dgit',
760 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
761 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
762 'dgit-distro.debian/push.git-create' => 'true',
763 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
764 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
765 # 'dgit-distro.debian.archive-query-tls-key',
766 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
767 # ^ this does not work because curl is broken nowadays
768 # Fixing #790093 properly will involve providing providing the key
769 # in some pacagke and maybe updating these paths.
771 # 'dgit-distro.debian.archive-query-tls-curl-args',
772 # '--ca-path=/etc/ssl/ca-debian',
773 # ^ this is a workaround but works (only) on DSA-administered machines
774 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
775 'dgit-distro.debian.git-url-suffix' => '',
776 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
777 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
778 'dgit-distro.debian-security.archive-query' => 'aptget:',
779 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
780 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
781 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
782 'dgit-distro.debian-security.nominal-distro' => 'debian',
783 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
784 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
785 'dgit-distro.ubuntu.git-check' => 'false',
786 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
787 'dgit-distro.ubuntucloud.git-check' => 'false',
788 'dgit-distro.ubuntucloud.nominal-distro' => 'ubuntu',
789 'dgit-distro.ubuntucloud.archive-query' => 'aptget:',
790 'dgit-distro.ubuntucloud.mirror' => 'http://ubuntu-cloud.archive.canonical.com/ubuntu',
791 'dgit-distro.ubuntucloud.aptget-suite-map' => 's#^([^-]+):([^:]+)$#${1}-updates/$2#; s#^(.+)-(.+):(.+)#$1-$2/$3#;',
792 'dgit-distro.ubuntucloud.aptget-suite-rmap' => 's#/(.+)$#-$1#',
793 'dgit-distro.test-dummy.ssh' => "$td/ssh",
794 'dgit-distro.test-dummy.username' => "alice",
795 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
796 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
797 'dgit-distro.test-dummy.git-url' => "$td/git",
798 'dgit-distro.test-dummy.git-host' => "git",
799 'dgit-distro.test-dummy.git-path' => "$td/git",
800 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
801 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
802 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
803 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
807 our @gitcfgsources = qw(cmdline local global system);
808 our $invoked_in_git_tree = 1;
810 sub git_slurp_config () {
811 # This algoritm is a bit subtle, but this is needed so that for
812 # options which we want to be single-valued, we allow the
813 # different config sources to override properly. See #835858.
814 foreach my $src (@gitcfgsources) {
815 next if $src eq 'cmdline';
816 # we do this ourselves since git doesn't handle it
818 $gitcfgs{$src} = git_slurp_config_src $src;
822 sub git_get_config ($) {
824 foreach my $src (@gitcfgsources) {
825 my $l = $gitcfgs{$src}{$c};
826 confess "internal error ($l $c)" if $l && !ref $l;
827 printdebug"C $c ".(defined $l ?
828 join " ", map { messagequote "'$_'" } @$l :
833 f_ "multiple values for %s (in %s git config)", $c, $src
835 $l->[0] =~ m/\n/ and badcfg f_
836 "value for config option %s (in %s git config) contains newline(s)!",
845 return undef if $c =~ /RETURN-UNDEF/;
846 printdebug "C? $c\n" if $debuglevel >= 5;
847 my $v = git_get_config($c);
848 return $v if defined $v;
849 my $dv = $defcfg{$c};
851 printdebug "CD $c $dv\n" if $debuglevel >= 4;
856 "need value for one of: %s\n".
857 "%s: distro or suite appears not to be (properly) supported",
861 sub not_necessarily_a_tree () {
862 # needs to be called from pre_*
863 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
864 $invoked_in_git_tree = 0;
867 sub access_basedistro__noalias () {
868 if (defined $idistro) {
871 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
872 return $def if defined $def;
873 foreach my $src (@gitcfgsources, 'internal') {
874 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
876 foreach my $k (keys %$kl) {
877 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
879 next unless match_glob $dpat, $isuite;
883 return cfg("dgit.default.distro");
887 sub access_basedistro () {
888 my $noalias = access_basedistro__noalias();
889 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
890 return $canon // $noalias;
893 sub access_nomdistro () {
894 my $base = access_basedistro();
895 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
896 $r =~ m/^$distro_re$/ or badcfg
897 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
898 $r, "/^$distro_re$/";
902 sub access_quirk () {
903 # returns (quirk name, distro to use instead or undef, quirk-specific info)
904 my $basedistro = access_basedistro();
905 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
907 if (defined $backports_quirk) {
908 my $re = $backports_quirk;
909 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
911 $re =~ s/\%/([-0-9a-z_]+)/
912 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
913 if ($isuite =~ m/^$re$/) {
914 return ('backports',"$basedistro-backports",$1);
917 return ('none',undef);
922 sub parse_cfg_bool ($$$) {
923 my ($what,$def,$v) = @_;
926 $v =~ m/^[ty1]/ ? 1 :
927 $v =~ m/^[fn0]/ ? 0 :
928 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
932 sub access_forpush_config () {
933 my $d = access_basedistro();
937 parse_cfg_bool('new-private-pushers', 0,
938 cfg("dgit-distro.$d.new-private-pushers",
941 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
944 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
945 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
946 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
948 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
951 sub access_forpush () {
952 $access_forpush //= access_forpush_config();
953 return $access_forpush;
956 sub default_from_access_cfg ($$$;$) {
957 my ($var, $keybase, $defval, $permit_re) = @_;
958 return if defined $$var;
960 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
961 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
963 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
966 badcfg f_ "unknown %s \`%s'", $keybase, $$var
967 if defined $permit_re and $$var !~ m/$permit_re/;
971 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
972 defined $access_forpush and !$access_forpush;
973 badcfg __ "pushing but distro is configured readonly"
974 if access_forpush_config() eq '0';
976 $supplementary_message = __ <<'END' unless $we_are_responder;
977 Push failed, before we got started.
978 You can retry the push, after fixing the problem, if you like.
980 parseopts_late_defaults();
984 parseopts_late_defaults();
987 sub determine_whether_split_brain ($) {
990 local $access_forpush;
991 default_from_access_cfg(\$splitview_mode, 'split-view', 'auto',
992 $splitview_modes_re);
993 $do_split_brain = 1 if $splitview_mode eq 'always';
996 printdebug "format $format, quilt mode $quilt_mode\n";
998 if (format_quiltmode_splitting $format) {
999 $splitview_mode ne 'never' or
1000 fail f_ "dgit: quilt mode \`%s' (for format \`%s')".
1001 " implies split view, but split-view set to \`%s'",
1002 $quilt_mode, $format, $splitview_mode;
1003 $do_split_brain = 1;
1005 $do_split_brain //= 0;
1008 sub supplementary_message ($) {
1010 if (!$we_are_responder) {
1011 $supplementary_message = $msg;
1014 responder_send_command "supplementary-message ".length($msg)
1016 print PO $msg or confess "$!";
1020 sub access_distros () {
1021 # Returns list of distros to try, in order
1024 # 0. `instead of' distro name(s) we have been pointed to
1025 # 1. the access_quirk distro, if any
1026 # 2a. the user's specified distro, or failing that } basedistro
1027 # 2b. the distro calculated from the suite }
1028 my @l = access_basedistro();
1030 my (undef,$quirkdistro) = access_quirk();
1031 unshift @l, $quirkdistro;
1032 unshift @l, $instead_distro;
1033 @l = grep { defined } @l;
1035 push @l, access_nomdistro();
1037 if (access_forpush()) {
1038 @l = map { ("$_/push", $_) } @l;
1043 sub access_cfg_cfgs (@) {
1046 # The nesting of these loops determines the search order. We put
1047 # the key loop on the outside so that we search all the distros
1048 # for each key, before going on to the next key. That means that
1049 # if access_cfg is called with a more specific, and then a less
1050 # specific, key, an earlier distro can override the less specific
1051 # without necessarily overriding any more specific keys. (If the
1052 # distro wants to override the more specific keys it can simply do
1053 # so; whereas if we did the loop the other way around, it would be
1054 # impossible to for an earlier distro to override a less specific
1055 # key but not the more specific ones without restating the unknown
1056 # values of the more specific keys.
1059 # We have to deal with RETURN-UNDEF specially, so that we don't
1060 # terminate the search prematurely.
1062 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1065 foreach my $d (access_distros()) {
1066 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1068 push @cfgs, map { "dgit.default.$_" } @realkeys;
1069 push @cfgs, @rundef;
1073 sub access_cfg (@) {
1075 my (@cfgs) = access_cfg_cfgs(@keys);
1076 my $value = cfg(@cfgs);
1080 sub access_cfg_bool ($$) {
1081 my ($def, @keys) = @_;
1082 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1085 sub string_to_ssh ($) {
1087 if ($spec =~ m/\s/) {
1088 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1094 sub access_cfg_ssh () {
1095 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1096 if (!defined $gitssh) {
1099 return string_to_ssh $gitssh;
1103 sub access_runeinfo ($) {
1105 return ": dgit ".access_basedistro()." $info ;";
1108 sub access_someuserhost ($) {
1110 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1111 defined($user) && length($user) or
1112 $user = access_cfg("$some-user",'username');
1113 my $host = access_cfg("$some-host");
1114 return length($user) ? "$user\@$host" : $host;
1117 sub access_gituserhost () {
1118 return access_someuserhost('git');
1121 sub access_giturl (;$) {
1122 my ($optional) = @_;
1123 my $url = access_cfg('git-url','RETURN-UNDEF');
1126 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1127 return undef unless defined $proto;
1130 access_gituserhost().
1131 access_cfg('git-path');
1133 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1136 return "$url/$package$suffix";
1139 sub commit_getclogp ($) {
1140 # Returns the parsed changelog hashref for a particular commit
1142 our %commit_getclogp_memo;
1143 my $memo = $commit_getclogp_memo{$objid};
1144 return $memo if $memo;
1146 my $mclog = dgit_privdir()."clog";
1147 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1148 "$objid:debian/changelog";
1149 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1152 sub parse_dscdata () {
1153 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1154 printdebug Dumper($dscdata) if $debuglevel>1;
1155 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1156 printdebug Dumper($dsc) if $debuglevel>1;
1161 sub archive_query ($;@) {
1162 my ($method) = shift @_;
1163 fail __ "this operation does not support multiple comma-separated suites"
1165 my $query = access_cfg('archive-query','RETURN-UNDEF');
1166 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1169 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1172 sub archive_query_prepend_mirror {
1173 my $m = access_cfg('mirror');
1174 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1177 sub pool_dsc_subpath ($$) {
1178 my ($vsn,$component) = @_; # $package is implict arg
1179 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1180 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1183 sub cfg_apply_map ($$$) {
1184 my ($varref, $what, $mapspec) = @_;
1185 return unless $mapspec;
1187 printdebug "config $what EVAL{ $mapspec; }\n";
1189 eval "package Dgit::Config; $mapspec;";
1194 #---------- `ftpmasterapi' archive query method (nascent) ----------
1196 sub archive_api_query_cmd ($) {
1198 my @cmd = (@curl, qw(-sS));
1199 my $url = access_cfg('archive-query-url');
1200 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1202 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1203 foreach my $key (split /\:/, $keys) {
1204 $key =~ s/\%HOST\%/$host/g;
1206 fail "for $url: stat $key: $!" unless $!==ENOENT;
1209 fail f_ "config requested specific TLS key but do not know".
1210 " how to get curl to use exactly that EE key (%s)",
1212 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1213 # # Sadly the above line does not work because of changes
1214 # # to gnutls. The real fix for #790093 may involve
1215 # # new curl options.
1218 # Fixing #790093 properly will involve providing a value
1219 # for this on clients.
1220 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1221 push @cmd, split / /, $kargs if defined $kargs;
1223 push @cmd, $url.$subpath;
1227 sub api_query ($$;$) {
1229 my ($data, $subpath, $ok404) = @_;
1230 badcfg __ "ftpmasterapi archive query method takes no data part"
1232 my @cmd = archive_api_query_cmd($subpath);
1233 my $url = $cmd[$#cmd];
1234 push @cmd, qw(-w %{http_code});
1235 my $json = cmdoutput @cmd;
1236 unless ($json =~ s/\d+\d+\d$//) {
1237 failedcmd_report_cmd undef, @cmd;
1238 fail __ "curl failed to print 3-digit HTTP code";
1241 return undef if $code eq '404' && $ok404;
1242 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1243 unless $url =~ m#^file://# or $code =~ m/^2/;
1244 return decode_json($json);
1247 sub canonicalise_suite_ftpmasterapi {
1248 my ($proto,$data) = @_;
1249 my $suites = api_query($data, 'suites');
1251 foreach my $entry (@$suites) {
1253 my $v = $entry->{$_};
1254 defined $v && $v eq $isuite;
1255 } qw(codename name);
1256 push @matched, $entry;
1258 fail f_ "unknown suite %s, maybe -d would help", $isuite
1262 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1263 $cn = "$matched[0]{codename}";
1264 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1265 $cn =~ m/^$suite_re$/
1266 or die f_ "suite %s maps to bad codename\n", $isuite;
1268 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1273 sub archive_query_ftpmasterapi {
1274 my ($proto,$data) = @_;
1275 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1277 my $digester = Digest::SHA->new(256);
1278 foreach my $entry (@$info) {
1280 my $vsn = "$entry->{version}";
1281 my ($ok,$msg) = version_check $vsn;
1282 die f_ "bad version: %s\n", $msg unless $ok;
1283 my $component = "$entry->{component}";
1284 $component =~ m/^$component_re$/ or die __ "bad component";
1285 my $filename = "$entry->{filename}";
1286 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1287 or die __ "bad filename";
1288 my $sha256sum = "$entry->{sha256sum}";
1289 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1290 push @rows, [ $vsn, "/pool/$component/$filename",
1291 $digester, $sha256sum ];
1293 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1296 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1297 return archive_query_prepend_mirror @rows;
1300 sub file_in_archive_ftpmasterapi {
1301 my ($proto,$data,$filename) = @_;
1302 my $pat = $filename;
1305 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1306 my $info = api_query($data, "file_in_archive/$pat", 1);
1309 sub package_not_wholly_new_ftpmasterapi {
1310 my ($proto,$data,$pkg) = @_;
1311 my $info = api_query($data,"madison?package=${pkg}&f=json");
1315 #---------- `aptget' archive query method ----------
1318 our $aptget_releasefile;
1319 our $aptget_configpath;
1321 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1322 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1324 sub aptget_cache_clean {
1325 runcmd_ordryrun_local qw(sh -ec),
1326 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1330 sub aptget_lock_acquire () {
1331 my $lockfile = "$aptget_base/lock";
1332 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1333 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1336 sub aptget_prep ($) {
1338 return if defined $aptget_base;
1340 badcfg __ "aptget archive query method takes no data part"
1343 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1346 ensuredir "$cache/dgit";
1348 access_cfg('aptget-cachekey','RETURN-UNDEF')
1349 // access_nomdistro();
1351 $aptget_base = "$cache/dgit/aptget";
1352 ensuredir $aptget_base;
1354 my $quoted_base = $aptget_base;
1355 confess "$quoted_base contains bad chars, cannot continue"
1356 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1358 ensuredir $aptget_base;
1360 aptget_lock_acquire();
1362 aptget_cache_clean();
1364 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1365 my $sourceslist = "source.list#$cachekey";
1367 my $aptsuites = $isuite;
1368 cfg_apply_map(\$aptsuites, 'suite map',
1369 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1371 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1372 printf SRCS "deb-src %s %s %s\n",
1373 access_cfg('mirror'),
1375 access_cfg('aptget-components')
1378 ensuredir "$aptget_base/cache";
1379 ensuredir "$aptget_base/lists";
1381 open CONF, ">", $aptget_configpath or confess "$!";
1383 Debug::NoLocking "true";
1384 APT::Get::List-Cleanup "false";
1385 #clear APT::Update::Post-Invoke-Success;
1386 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1387 Dir::State::Lists "$quoted_base/lists";
1388 Dir::Etc::preferences "$quoted_base/preferences";
1389 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1390 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1393 foreach my $key (qw(
1396 Dir::Cache::Archives
1397 Dir::Etc::SourceParts
1398 Dir::Etc::preferencesparts
1400 ensuredir "$aptget_base/$key";
1401 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1404 my $oldatime = (time // confess "$!") - 1;
1405 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1406 next unless stat_exists $oldlist;
1407 my ($mtime) = (stat _)[9];
1408 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1411 runcmd_ordryrun_local aptget_aptget(), qw(update);
1414 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1415 next unless stat_exists $oldlist;
1416 my ($atime) = (stat _)[8];
1417 next if $atime == $oldatime;
1418 push @releasefiles, $oldlist;
1420 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1421 @releasefiles = @inreleasefiles if @inreleasefiles;
1422 if (!@releasefiles) {
1423 fail f_ <<END, $isuite, $cache;
1424 apt seemed to not to update dgit's cached Release files for %s.
1426 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1429 confess "apt updated too many Release files (@releasefiles), erk"
1430 unless @releasefiles == 1;
1432 ($aptget_releasefile) = @releasefiles;
1435 sub canonicalise_suite_aptget {
1436 my ($proto,$data) = @_;
1439 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1441 foreach my $name (qw(Codename Suite)) {
1442 my $val = $release->{$name};
1444 printdebug "release file $name: $val\n";
1445 cfg_apply_map(\$val, 'suite rmap',
1446 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1447 $val =~ m/^$suite_re$/o or fail f_
1448 "Release file (%s) specifies intolerable %s",
1449 $aptget_releasefile, $name;
1456 sub archive_query_aptget {
1457 my ($proto,$data) = @_;
1460 ensuredir "$aptget_base/source";
1461 foreach my $old (<$aptget_base/source/*.dsc>) {
1462 unlink $old or die "$old: $!";
1465 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1466 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1467 # avoids apt-get source failing with ambiguous error code
1469 runcmd_ordryrun_local
1470 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1471 aptget_aptget(), qw(--download-only --only-source source), $package;
1473 my @dscs = <$aptget_base/source/*.dsc>;
1474 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1475 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1478 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1481 my $uri = "file://". uri_escape $dscs[0];
1482 $uri =~ s{\%2f}{/}gi;
1483 return [ (getfield $pre_dsc, 'Version'), $uri ];
1486 sub file_in_archive_aptget () { return undef; }
1487 sub package_not_wholly_new_aptget () { return undef; }
1489 #---------- `dummyapicat' archive query method ----------
1490 # (untranslated, because this is for testing purposes etc.)
1492 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1493 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1495 sub dummycatapi_run_in_mirror ($@) {
1496 # runs $fn with FIA open onto rune
1497 my ($rune, $argl, $fn) = @_;
1499 my $mirror = access_cfg('mirror');
1500 $mirror =~ s#^file://#/# or die "$mirror ?";
1501 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1502 qw(x), $mirror, @$argl);
1503 debugcmd "-|", @cmd;
1504 open FIA, "-|", @cmd or confess "$!";
1506 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1510 sub file_in_archive_dummycatapi ($$$) {
1511 my ($proto,$data,$filename) = @_;
1513 dummycatapi_run_in_mirror '
1514 find -name "$1" -print0 |
1516 ', [$filename], sub {
1519 printdebug "| $_\n";
1520 m/^(\w+) (\S+)$/ or die "$_ ?";
1521 push @out, { sha256sum => $1, filename => $2 };
1527 sub package_not_wholly_new_dummycatapi {
1528 my ($proto,$data,$pkg) = @_;
1529 dummycatapi_run_in_mirror "
1530 find -name ${pkg}_*.dsc
1537 #---------- `madison' archive query method ----------
1539 sub archive_query_madison {
1540 return archive_query_prepend_mirror
1541 map { [ @$_[0..1] ] } madison_get_parse(@_);
1544 sub madison_get_parse {
1545 my ($proto,$data) = @_;
1546 die unless $proto eq 'madison';
1547 if (!length $data) {
1548 $data= access_cfg('madison-distro','RETURN-UNDEF');
1549 $data //= access_basedistro();
1551 $rmad{$proto,$data,$package} ||= cmdoutput
1552 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1553 my $rmad = $rmad{$proto,$data,$package};
1556 foreach my $l (split /\n/, $rmad) {
1557 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1558 \s*( [^ \t|]+ )\s* \|
1559 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1560 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1561 $1 eq $package or die "$rmad $package ?";
1568 $component = access_cfg('archive-query-default-component');
1570 $5 eq 'source' or die "$rmad ?";
1571 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1573 return sort { -version_compare($a->[0],$b->[0]); } @out;
1576 sub canonicalise_suite_madison {
1577 # madison canonicalises for us
1578 my @r = madison_get_parse(@_);
1580 "unable to canonicalise suite using package %s".
1581 " which does not appear to exist in suite %s;".
1582 " --existing-package may help",
1587 sub file_in_archive_madison { return undef; }
1588 sub package_not_wholly_new_madison { return undef; }
1590 #---------- `sshpsql' archive query method ----------
1591 # (untranslated, because this is obsolete)
1594 my ($data,$runeinfo,$sql) = @_;
1595 if (!length $data) {
1596 $data= access_someuserhost('sshpsql').':'.
1597 access_cfg('sshpsql-dbname');
1599 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1600 my ($userhost,$dbname) = ($`,$'); #';
1602 my @cmd = (access_cfg_ssh, $userhost,
1603 access_runeinfo("ssh-psql $runeinfo").
1604 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1605 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1607 open P, "-|", @cmd or confess "$!";
1610 printdebug(">|$_|\n");
1613 $!=0; $?=0; close P or failedcmd @cmd;
1615 my $nrows = pop @rows;
1616 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1617 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1618 @rows = map { [ split /\|/, $_ ] } @rows;
1619 my $ncols = scalar @{ shift @rows };
1620 die if grep { scalar @$_ != $ncols } @rows;
1624 sub sql_injection_check {
1625 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1628 sub archive_query_sshpsql ($$) {
1629 my ($proto,$data) = @_;
1630 sql_injection_check $isuite, $package;
1631 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1632 SELECT source.version, component.name, files.filename, files.sha256sum
1634 JOIN src_associations ON source.id = src_associations.source
1635 JOIN suite ON suite.id = src_associations.suite
1636 JOIN dsc_files ON dsc_files.source = source.id
1637 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1638 JOIN component ON component.id = files_archive_map.component_id
1639 JOIN files ON files.id = dsc_files.file
1640 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1641 AND source.source='$package'
1642 AND files.filename LIKE '%.dsc';
1644 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1645 my $digester = Digest::SHA->new(256);
1647 my ($vsn,$component,$filename,$sha256sum) = @$_;
1648 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1650 return archive_query_prepend_mirror @rows;
1653 sub canonicalise_suite_sshpsql ($$) {
1654 my ($proto,$data) = @_;
1655 sql_injection_check $isuite;
1656 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1657 SELECT suite.codename
1658 FROM suite where suite_name='$isuite' or codename='$isuite';
1660 @rows = map { $_->[0] } @rows;
1661 fail "unknown suite $isuite" unless @rows;
1662 die "ambiguous $isuite: @rows ?" if @rows>1;
1666 sub file_in_archive_sshpsql ($$$) { return undef; }
1667 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1669 #---------- `dummycat' archive query method ----------
1670 # (untranslated, because this is for testing purposes etc.)
1672 sub canonicalise_suite_dummycat ($$) {
1673 my ($proto,$data) = @_;
1674 my $dpath = "$data/suite.$isuite";
1675 if (!open C, "<", $dpath) {
1676 $!==ENOENT or die "$dpath: $!";
1677 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1681 chomp or die "$dpath: $!";
1683 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1687 sub archive_query_dummycat ($$) {
1688 my ($proto,$data) = @_;
1689 canonicalise_suite();
1690 my $dpath = "$data/package.$csuite.$package";
1691 if (!open C, "<", $dpath) {
1692 $!==ENOENT or die "$dpath: $!";
1693 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1701 printdebug "dummycat query $csuite $package $dpath | $_\n";
1702 my @row = split /\s+/, $_;
1703 @row==2 or die "$dpath: $_ ?";
1706 C->error and die "$dpath: $!";
1708 return archive_query_prepend_mirror
1709 sort { -version_compare($a->[0],$b->[0]); } @rows;
1712 sub file_in_archive_dummycat () { return undef; }
1713 sub package_not_wholly_new_dummycat () { return undef; }
1715 #---------- archive query entrypoints and rest of program ----------
1717 sub canonicalise_suite () {
1718 return if defined $csuite;
1719 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1720 $csuite = archive_query('canonicalise_suite');
1721 if ($isuite ne $csuite) {
1722 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1724 progress f_ "canonical suite name is %s", $csuite;
1728 sub get_archive_dsc () {
1729 canonicalise_suite();
1730 my @vsns = archive_query('archive_query');
1731 foreach my $vinfo (@vsns) {
1732 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1733 $dscurl = $vsn_dscurl;
1734 $dscdata = url_get($dscurl);
1736 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1741 $digester->add($dscdata);
1742 my $got = $digester->hexdigest();
1744 fail f_ "%s has hash %s but archive told us to expect %s",
1745 $dscurl, $got, $digest;
1748 my $fmt = getfield $dsc, 'Format';
1749 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1750 f_ "unsupported source format %s, sorry", $fmt;
1752 $dsc_checked = !!$digester;
1753 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1757 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1760 sub check_for_git ();
1761 sub check_for_git () {
1763 my $how = access_cfg('git-check');
1764 if ($how eq 'ssh-cmd') {
1766 (access_cfg_ssh, access_gituserhost(),
1767 access_runeinfo("git-check $package").
1768 " set -e; cd ".access_cfg('git-path').";".
1769 " if test -d $package.git; then echo 1; else echo 0; fi");
1770 my $r= cmdoutput @cmd;
1771 if (defined $r and $r =~ m/^divert (\w+)$/) {
1773 my ($usedistro,) = access_distros();
1774 # NB that if we are pushing, $usedistro will be $distro/push
1775 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1776 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1777 progress f_ "diverting to %s (using config for %s)",
1778 $divert, $instead_distro;
1779 return check_for_git();
1781 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1783 } elsif ($how eq 'url') {
1784 my $prefix = access_cfg('git-check-url','git-url');
1785 my $suffix = access_cfg('git-check-suffix','git-suffix',
1786 'RETURN-UNDEF') // '.git';
1787 my $url = "$prefix/$package$suffix";
1788 my @cmd = (@curl, qw(-sS -I), $url);
1789 my $result = cmdoutput @cmd;
1790 $result =~ s/^\S+ 200 .*\n\r?\n//;
1791 # curl -sS -I with https_proxy prints
1792 # HTTP/1.0 200 Connection established
1793 $result =~ m/^\S+ (404|200) /s or
1794 fail +(__ "unexpected results from git check query - ").
1795 Dumper($prefix, $result);
1797 if ($code eq '404') {
1799 } elsif ($code eq '200') {
1804 } elsif ($how eq 'true') {
1806 } elsif ($how eq 'false') {
1809 badcfg f_ "unknown git-check \`%s'", $how;
1813 sub create_remote_git_repo () {
1814 my $how = access_cfg('git-create');
1815 if ($how eq 'ssh-cmd') {
1817 (access_cfg_ssh, access_gituserhost(),
1818 access_runeinfo("git-create $package").
1819 "set -e; cd ".access_cfg('git-path').";".
1820 " cp -a _template $package.git");
1821 } elsif ($how eq 'true') {
1824 badcfg f_ "unknown git-create \`%s'", $how;
1828 our ($dsc_hash,$lastpush_mergeinput);
1829 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1833 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1834 $playground = fresh_playground 'dgit/unpack';
1837 sub mktree_in_ud_here () {
1838 playtree_setup $gitcfgs{local};
1841 sub git_write_tree () {
1842 my $tree = cmdoutput @git, qw(write-tree);
1843 $tree =~ m/^\w+$/ or die "$tree ?";
1847 sub git_add_write_tree () {
1848 runcmd @git, qw(add -Af .);
1849 return git_write_tree();
1852 sub remove_stray_gits ($) {
1854 my @gitscmd = qw(find -name .git -prune -print0);
1855 debugcmd "|",@gitscmd;
1856 open GITS, "-|", @gitscmd or confess "$!";
1861 print STDERR f_ "%s: warning: removing from %s: %s\n",
1862 $us, $what, (messagequote $_);
1866 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1869 sub mktree_in_ud_from_only_subdir ($;$) {
1870 my ($what,$raw) = @_;
1871 # changes into the subdir
1874 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1875 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1879 remove_stray_gits($what);
1880 mktree_in_ud_here();
1882 my ($format, $fopts) = get_source_format();
1883 if (madformat($format)) {
1888 my $tree=git_add_write_tree();
1889 return ($tree,$dir);
1892 our @files_csum_info_fields =
1893 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1894 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1895 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1897 sub dsc_files_info () {
1898 foreach my $csumi (@files_csum_info_fields) {
1899 my ($fname, $module, $method) = @$csumi;
1900 my $field = $dsc->{$fname};
1901 next unless defined $field;
1902 eval "use $module; 1;" or die $@;
1904 foreach (split /\n/, $field) {
1906 m/^(\w+) (\d+) (\S+)$/ or
1907 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1908 my $digester = eval "$module"."->$method;" or die $@;
1913 Digester => $digester,
1918 fail f_ "missing any supported Checksums-* or Files field in %s",
1919 $dsc->get_option('name');
1923 map { $_->{Filename} } dsc_files_info();
1926 sub files_compare_inputs (@) {
1931 my $showinputs = sub {
1932 return join "; ", map { $_->get_option('name') } @$inputs;
1935 foreach my $in (@$inputs) {
1937 my $in_name = $in->get_option('name');
1939 printdebug "files_compare_inputs $in_name\n";
1941 foreach my $csumi (@files_csum_info_fields) {
1942 my ($fname) = @$csumi;
1943 printdebug "files_compare_inputs $in_name $fname\n";
1945 my $field = $in->{$fname};
1946 next unless defined $field;
1949 foreach (split /\n/, $field) {
1952 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1953 fail "could not parse $in_name $fname line \`$_'";
1955 printdebug "files_compare_inputs $in_name $fname $f\n";
1959 my $re = \ $record{$f}{$fname};
1961 $fchecked{$f}{$in_name} = 1;
1964 "hash or size of %s varies in %s fields (between: %s)",
1965 $f, $fname, $showinputs->();
1970 @files = sort @files;
1971 $expected_files //= \@files;
1972 "@$expected_files" eq "@files" or
1973 fail f_ "file list in %s varies between hash fields!",
1977 fail f_ "%s has no files list field(s)", $in_name;
1979 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1982 grep { keys %$_ == @$inputs-1 } values %fchecked
1983 or fail f_ "no file appears in all file lists (looked in: %s)",
1987 sub is_orig_file_in_dsc ($$) {
1988 my ($f, $dsc_files_info) = @_;
1989 return 0 if @$dsc_files_info <= 1;
1990 # One file means no origs, and the filename doesn't have a "what
1991 # part of dsc" component. (Consider versions ending `.orig'.)
1992 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1996 # This function determines whether a .changes file is source-only from
1997 # the point of view of dak. Thus, it permits *_source.buildinfo
2000 # It does not, however, permit any other buildinfo files. After a
2001 # source-only upload, the buildds will try to upload files like
2002 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
2003 # named like this in their (otherwise) source-only upload, the uploads
2004 # of the buildd can be rejected by dak. Fixing the resultant
2005 # situation can require manual intervention. So we block such
2006 # .buildinfo files when the user tells us to perform a source-only
2007 # upload (such as when using the push-source subcommand with the -C
2008 # option, which calls this function).
2010 # Note, though, that when dgit is told to prepare a source-only
2011 # upload, such as when subcommands like build-source and push-source
2012 # without -C are used, dgit has a more restrictive notion of
2013 # source-only .changes than dak: such uploads will never include
2014 # *_source.buildinfo files. This is because there is no use for such
2015 # files when using a tool like dgit to produce the source package, as
2016 # dgit ensures the source is identical to git HEAD.
2017 sub test_source_only_changes ($) {
2019 foreach my $l (split /\n/, getfield $changes, 'Files') {
2020 $l =~ m/\S+$/ or next;
2021 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2022 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
2023 print f_ "purportedly source-only changes polluted by %s\n", $&;
2030 sub changes_update_origs_from_dsc ($$$$) {
2031 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2033 printdebug "checking origs needed ($upstreamvsn)...\n";
2034 $_ = getfield $changes, 'Files';
2035 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2036 fail __ "cannot find section/priority from .changes Files field";
2037 my $placementinfo = $1;
2039 printdebug "checking origs needed placement '$placementinfo'...\n";
2040 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2041 $l =~ m/\S+$/ or next;
2043 printdebug "origs $file | $l\n";
2044 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2045 printdebug "origs $file is_orig\n";
2046 my $have = archive_query('file_in_archive', $file);
2047 if (!defined $have) {
2048 print STDERR __ <<END;
2049 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2055 printdebug "origs $file \$#\$have=$#$have\n";
2056 foreach my $h (@$have) {
2059 foreach my $csumi (@files_csum_info_fields) {
2060 my ($fname, $module, $method, $archivefield) = @$csumi;
2061 next unless defined $h->{$archivefield};
2062 $_ = $dsc->{$fname};
2063 next unless defined;
2064 m/^(\w+) .* \Q$file\E$/m or
2065 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2066 if ($h->{$archivefield} eq $1) {
2070 "%s: %s (archive) != %s (local .dsc)",
2071 $archivefield, $h->{$archivefield}, $1;
2074 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2078 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2081 printdebug "origs $file f.same=$found_same".
2082 " #f._differ=$#found_differ\n";
2083 if (@found_differ && !$found_same) {
2085 (f_ "archive contains %s with different checksum", $file),
2088 # Now we edit the changes file to add or remove it
2089 foreach my $csumi (@files_csum_info_fields) {
2090 my ($fname, $module, $method, $archivefield) = @$csumi;
2091 next unless defined $changes->{$fname};
2093 # in archive, delete from .changes if it's there
2094 $changed{$file} = "removed" if
2095 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2096 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2097 # not in archive, but it's here in the .changes
2099 my $dsc_data = getfield $dsc, $fname;
2100 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2102 $extra =~ s/ \d+ /$&$placementinfo /
2103 or confess "$fname $extra >$dsc_data< ?"
2104 if $fname eq 'Files';
2105 $changes->{$fname} .= "\n". $extra;
2106 $changed{$file} = "added";
2111 foreach my $file (keys %changed) {
2113 "edited .changes for archive .orig contents: %s %s",
2114 $changed{$file}, $file;
2116 my $chtmp = "$changesfile.tmp";
2117 $changes->save($chtmp);
2119 rename $chtmp,$changesfile or die "$changesfile $!";
2121 progress f_ "[new .changes left in %s]", $changesfile;
2124 progress f_ "%s already has appropriate .orig(s) (if any)",
2129 sub clogp_authline ($) {
2131 my $author = getfield $clogp, 'Maintainer';
2132 if ($author =~ m/^[^"\@]+\,/) {
2133 # single entry Maintainer field with unquoted comma
2134 $author = ($& =~ y/,//rd).$'; # strip the comma
2136 # git wants a single author; any remaining commas in $author
2137 # are by now preceded by @ (or "). It seems safer to punt on
2138 # "..." for now rather than attempting to dequote or something.
2139 $author =~ s#,.*##ms unless $author =~ m/"/;
2140 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2141 my $authline = "$author $date";
2142 $authline =~ m/$git_authline_re/o or
2143 fail f_ "unexpected commit author line format \`%s'".
2144 " (was generated from changelog Maintainer field)",
2146 return ($1,$2,$3) if wantarray;
2150 sub vendor_patches_distro ($$) {
2151 my ($checkdistro, $what) = @_;
2152 return unless defined $checkdistro;
2154 my $series = "debian/patches/\L$checkdistro\E.series";
2155 printdebug "checking for vendor-specific $series ($what)\n";
2157 if (!open SERIES, "<", $series) {
2158 confess "$series $!" unless $!==ENOENT;
2165 print STDERR __ <<END;
2167 Unfortunately, this source package uses a feature of dpkg-source where
2168 the same source package unpacks to different source code on different
2169 distros. dgit cannot safely operate on such packages on affected
2170 distros, because the meaning of source packages is not stable.
2172 Please ask the distro/maintainer to remove the distro-specific series
2173 files and use a different technique (if necessary, uploading actually
2174 different packages, if different distros are supposed to have
2178 fail f_ "Found active distro-specific series file for".
2179 " %s (%s): %s, cannot continue",
2180 $checkdistro, $what, $series;
2182 die "$series $!" if SERIES->error;
2186 sub check_for_vendor_patches () {
2187 # This dpkg-source feature doesn't seem to be documented anywhere!
2188 # But it can be found in the changelog (reformatted):
2190 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2191 # Author: Raphael Hertzog <hertzog@debian.org>
2192 # Date: Sun Oct 3 09:36:48 2010 +0200
2194 # dpkg-source: correctly create .pc/.quilt_series with alternate
2197 # If you have debian/patches/ubuntu.series and you were
2198 # unpacking the source package on ubuntu, quilt was still
2199 # directed to debian/patches/series instead of
2200 # debian/patches/ubuntu.series.
2202 # debian/changelog | 3 +++
2203 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2204 # 2 files changed, 6 insertions(+), 1 deletion(-)
2207 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2208 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2209 __ "Dpkg::Vendor \`current vendor'");
2210 vendor_patches_distro(access_basedistro(),
2211 __ "(base) distro being accessed");
2212 vendor_patches_distro(access_nomdistro(),
2213 __ "(nominal) distro being accessed");
2216 sub check_bpd_exists () {
2217 stat $buildproductsdir
2218 or fail f_ "build-products-dir %s is not accessible: %s\n",
2219 $buildproductsdir, $!;
2222 sub dotdot_bpd_transfer_origs ($$$) {
2223 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2224 # checks is_orig_file_of_vsn and if
2225 # calls $wanted->{$leaf} and expects boolish
2227 return if $buildproductsdir eq '..';
2230 my $dotdot = $maindir;
2231 $dotdot =~ s{/[^/]+$}{};
2232 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2233 while ($!=0, defined(my $leaf = readdir DD)) {
2235 local ($debuglevel) = $debuglevel-1;
2236 printdebug "DD_BPD $leaf ?\n";
2238 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2239 next unless $wanted->($leaf);
2240 next if lstat "$bpd_abs/$leaf";
2243 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2246 $! == &ENOENT or fail f_
2247 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2248 lstat "$dotdot/$leaf" or fail f_
2249 "check orig file %s in ..: %s", $leaf, $!;
2251 stat "$dotdot/$leaf" or fail f_
2252 "check target of orig symlink %s in ..: %s", $leaf, $!;
2253 my $ltarget = readlink "$dotdot/$leaf" or
2254 die "readlink $dotdot/$leaf: $!";
2255 if ($ltarget !~ m{^/}) {
2256 $ltarget = "$dotdot/$ltarget";
2258 symlink $ltarget, "$bpd_abs/$leaf"
2259 or die "$ltarget $bpd_abs $leaf: $!";
2261 "%s: cloned orig symlink from ..: %s\n",
2263 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2265 "%s: hardlinked orig from ..: %s\n",
2267 } elsif ($! != EXDEV) {
2268 fail f_ "failed to make %s a hardlink to %s: %s",
2269 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2271 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2272 or die "$bpd_abs $dotdot $leaf $!";
2274 "%s: symmlinked orig from .. on other filesystem: %s\n",
2278 die "$dotdot; $!" if $!;
2282 sub import_tarball_tartrees ($$) {
2283 my ($upstreamv, $dfi) = @_;
2284 # cwd should be the playground
2286 # We unpack and record the orig tarballs first, so that we only
2287 # need disk space for one private copy of the unpacked source.
2288 # But we can't make them into commits until we have the metadata
2289 # from the debian/changelog, so we record the tree objects now and
2290 # make them into commits later.
2292 my $orig_f_base = srcfn $upstreamv, '';
2294 foreach my $fi (@$dfi) {
2295 # We actually import, and record as a commit, every tarball
2296 # (unless there is only one file, in which case there seems
2299 my $f = $fi->{Filename};
2300 printdebug "import considering $f ";
2301 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2302 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2306 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2308 printdebug "Y ", (join ' ', map { $_//"(none)" }
2309 $compr_ext, $orig_f_part
2312 my $path = $fi->{Path} // $f;
2313 my $input = new IO::File $f, '<' or die "$f $!";
2317 if (defined $compr_ext) {
2319 Dpkg::Compression::compression_guess_from_filename $f;
2320 fail "Dpkg::Compression cannot handle file $f in source package"
2321 if defined $compr_ext && !defined $cname;
2323 new Dpkg::Compression::Process compression => $cname;
2324 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2325 my $compr_fh = new IO::Handle;
2326 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2328 open STDIN, "<&", $input or confess "$!";
2330 die "dgit (child): exec $compr_cmd[0]: $!\n";
2335 rmtree "_unpack-tar";
2336 mkdir "_unpack-tar" or confess "$!";
2337 my @tarcmd = qw(tar -x -f -
2338 --no-same-owner --no-same-permissions
2339 --no-acls --no-xattrs --no-selinux);
2340 my $tar_pid = fork // confess "$!";
2342 chdir "_unpack-tar" or confess "$!";
2343 open STDIN, "<&", $input or confess "$!";
2345 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2347 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2348 !$? or failedcmd @tarcmd;
2351 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2353 # finally, we have the results in "tarball", but maybe
2354 # with the wrong permissions
2356 runcmd qw(chmod -R +rwX _unpack-tar);
2357 changedir "_unpack-tar";
2358 remove_stray_gits($f);
2359 mktree_in_ud_here();
2361 my ($tree) = git_add_write_tree();
2362 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2363 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2365 printdebug "one subtree $1\n";
2367 printdebug "multiple subtrees\n";
2370 rmtree "_unpack-tar";
2372 my $ent = [ $f, $tree ];
2374 Orig => !!$orig_f_part,
2375 Sort => (!$orig_f_part ? 2 :
2376 $orig_f_part =~ m/-/g ? 1 :
2378 OrigPart => $orig_f_part, # 'orig', 'orig-XXX', or undef
2385 # put any without "_" first (spec is not clear whether files
2386 # are always in the usual order). Tarballs without "_" are
2387 # the main orig or the debian tarball.
2388 $a->{Sort} <=> $b->{Sort} or
2395 sub import_tarball_commits ($$) {
2396 my ($tartrees, $upstreamv) = @_;
2397 # cwd should be a playtree which has a relevant debian/changelog
2398 # fills in $tt->{Commit} for each one
2400 my $any_orig = grep { $_->{Orig} } @$tartrees;
2402 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2406 printdebug "import clog search...\n";
2407 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2408 my ($thisstanza, $desc) = @_;
2409 no warnings qw(exiting);
2411 $clogp //= $thisstanza;
2413 printdebug "import clog $thisstanza->{version} $desc...\n";
2415 last if !$any_orig; # we don't need $r1clogp
2417 # We look for the first (most recent) changelog entry whose
2418 # version number is lower than the upstream version of this
2419 # package. Then the last (least recent) previous changelog
2420 # entry is treated as the one which introduced this upstream
2421 # version and used for the synthetic commits for the upstream
2424 # One might think that a more sophisticated algorithm would be
2425 # necessary. But: we do not want to scan the whole changelog
2426 # file. Stopping when we see an earlier version, which
2427 # necessarily then is an earlier upstream version, is the only
2428 # realistic way to do that. Then, either the earliest
2429 # changelog entry we have seen so far is indeed the earliest
2430 # upload of this upstream version; or there are only changelog
2431 # entries relating to later upstream versions (which is not
2432 # possible unless the changelog and .dsc disagree about the
2433 # version). Then it remains to choose between the physically
2434 # last entry in the file, and the one with the lowest version
2435 # number. If these are not the same, we guess that the
2436 # versions were created in a non-monotonic order rather than
2437 # that the changelog entries have been misordered.
2439 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2441 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2442 $r1clogp = $thisstanza;
2444 printdebug "import clog $r1clogp->{version} becomes r1\n";
2447 $clogp or fail __ "package changelog has no entries!";
2449 my $authline = clogp_authline $clogp;
2450 my $changes = getfield $clogp, 'Changes';
2451 $changes =~ s/^\n//; # Changes: \n
2452 my $cversion = getfield $clogp, 'Version';
2456 $r1clogp //= $clogp; # maybe there's only one entry;
2457 $r1authline = clogp_authline $r1clogp;
2458 # Strictly, r1authline might now be wrong if it's going to be
2459 # unused because !$any_orig. Whatever.
2461 printdebug "import tartrees authline $authline\n";
2462 printdebug "import tartrees r1authline $r1authline\n";
2464 foreach my $tt (@$tartrees) {
2465 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2467 # untranslated so that different people's imports are identical
2468 my $mbody = sprintf "Import %s", $tt->{F};
2469 $tt->{Commit} = hash_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2472 committer $r1authline
2476 [dgit import orig $tt->{F}]
2484 [dgit import tarball $package $cversion $tt->{F}]
2489 return ($authline, $r1authline, $clogp, $changes);
2492 sub generate_commits_from_dsc () {
2493 # See big comment in fetch_from_archive, below.
2494 # See also README.dsc-import.
2496 changedir $playground;
2498 my $bpd_abs = bpd_abs();
2499 my $upstreamv = upstreamversion $dsc->{version};
2500 my @dfi = dsc_files_info();
2502 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2503 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2505 foreach my $fi (@dfi) {
2506 my $f = $fi->{Filename};
2507 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2508 my $upper_f = "$bpd_abs/$f";
2510 printdebug "considering reusing $f: ";
2512 if (link_ltarget "$upper_f,fetch", $f) {
2513 printdebug "linked (using ...,fetch).\n";
2514 } elsif ((printdebug "($!) "),
2516 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2517 } elsif (link_ltarget $upper_f, $f) {
2518 printdebug "linked.\n";
2519 } elsif ((printdebug "($!) "),
2521 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2523 printdebug "absent.\n";
2527 complete_file_from_dsc('.', $fi, \$refetched)
2530 printdebug "considering saving $f: ";
2532 if (rename_link_xf 1, $f, $upper_f) {
2533 printdebug "linked.\n";
2534 } elsif ((printdebug "($@) "),
2536 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2537 } elsif (!$refetched) {
2538 printdebug "no need.\n";
2539 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2540 printdebug "linked (using ...,fetch).\n";
2541 } elsif ((printdebug "($@) "),
2543 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2545 printdebug "cannot.\n";
2550 @tartrees = import_tarball_tartrees($upstreamv, \@dfi)
2551 unless @dfi == 1; # only one file in .dsc
2553 my $dscfn = "$package.dsc";
2555 my $treeimporthow = 'package';
2557 open D, ">", $dscfn or die "$dscfn: $!";
2558 print D $dscdata or die "$dscfn: $!";
2559 close D or die "$dscfn: $!";
2560 my @cmd = qw(dpkg-source);
2561 push @cmd, '--no-check' if $dsc_checked;
2562 if (madformat $dsc->{format}) {
2563 push @cmd, '--skip-patches';
2564 $treeimporthow = 'unpatched';
2566 push @cmd, qw(-x --), $dscfn;
2569 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2570 if (madformat $dsc->{format}) {
2571 check_for_vendor_patches();
2575 if (madformat $dsc->{format}) {
2576 my @pcmd = qw(dpkg-source --before-build .);
2577 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2579 $dappliedtree = git_add_write_tree();
2582 my ($authline, $r1authline, $clogp, $changes) =
2583 import_tarball_commits(\@tartrees, $upstreamv);
2585 my $cversion = getfield $clogp, 'Version';
2587 printdebug "import main commit\n";
2589 open C, ">../commit.tmp" or confess "$!";
2590 print C <<END or confess "$!";
2593 print C <<END or confess "$!" foreach @tartrees;
2596 print C <<END or confess "$!";
2602 [dgit import $treeimporthow $package $cversion]
2605 close C or confess "$!";
2606 my $rawimport_hash = hash_commit qw(../commit.tmp);
2608 if (madformat $dsc->{format}) {
2609 printdebug "import apply patches...\n";
2611 # regularise the state of the working tree so that
2612 # the checkout of $rawimport_hash works nicely.
2613 my $dappliedcommit = hash_commit_text(<<END);
2620 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2622 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2624 # We need the answers to be reproducible
2625 my @authline = clogp_authline($clogp);
2626 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2627 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2628 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2629 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2630 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2631 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2633 my $path = $ENV{PATH} or die;
2635 # we use ../../gbp-pq-output, which (given that we are in
2636 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2639 foreach my $use_absurd (qw(0 1)) {
2640 runcmd @git, qw(checkout -q unpa);
2641 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2642 local $ENV{PATH} = $path;
2645 progress "warning: $@";
2646 $path = "$absurdity:$path";
2647 progress f_ "%s: trying slow absurd-git-apply...", $us;
2648 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2653 die "forbid absurd git-apply\n" if $use_absurd
2654 && forceing [qw(import-gitapply-no-absurd)];
2655 die "only absurd git-apply!\n" if !$use_absurd
2656 && forceing [qw(import-gitapply-absurd)];
2658 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2659 local $ENV{PATH} = $path if $use_absurd;
2661 my @showcmd = (gbp_pq, qw(import));
2662 my @realcmd = shell_cmd
2663 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2664 debugcmd "+",@realcmd;
2665 if (system @realcmd) {
2666 die f_ "%s failed: %s\n",
2667 +(shellquote @showcmd),
2668 failedcmd_waitstatus();
2671 my $gapplied = git_rev_parse('HEAD');
2672 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2673 $gappliedtree eq $dappliedtree or
2674 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2675 gbp-pq import and dpkg-source disagree!
2676 gbp-pq import gave commit %s
2677 gbp-pq import gave tree %s
2678 dpkg-source --before-build gave tree %s
2680 $rawimport_hash = $gapplied;
2685 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2690 progress f_ "synthesised git commit from .dsc %s", $cversion;
2692 my $rawimport_mergeinput = {
2693 Commit => $rawimport_hash,
2694 Info => __ "Import of source package",
2696 my @output = ($rawimport_mergeinput);
2698 if ($lastpush_mergeinput) {
2699 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2700 my $oversion = getfield $oldclogp, 'Version';
2702 version_compare($oversion, $cversion);
2704 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2705 { ReverseParents => 1,
2706 # untranslated so that different people's pseudomerges
2707 # are not needlessly different (although they will
2708 # still differ if the series of pulls is different)
2709 Message => (sprintf <<END, $package, $cversion, $csuite) });
2710 Record %s (%s) in archive suite %s
2712 } elsif ($vcmp > 0) {
2713 print STDERR f_ <<END, $cversion, $oversion,
2715 Version actually in archive: %s (older)
2716 Last version pushed with dgit: %s (newer or same)
2719 __ $later_warning_msg or confess "$!";
2720 @output = $lastpush_mergeinput;
2722 # Same version. Use what's in the server git branch,
2723 # discarding our own import. (This could happen if the
2724 # server automatically imports all packages into git.)
2725 @output = $lastpush_mergeinput;
2733 sub complete_file_from_dsc ($$;$) {
2734 our ($dstdir, $fi, $refetched) = @_;
2735 # Ensures that we have, in $dstdir, the file $fi, with the correct
2736 # contents. (Downloading it from alongside $dscurl if necessary.)
2737 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2738 # and will set $$refetched=1 if it did so (or tried to).
2740 my $f = $fi->{Filename};
2741 my $tf = "$dstdir/$f";
2745 my $checkhash = sub {
2746 open F, "<", "$tf" or die "$tf: $!";
2747 $fi->{Digester}->reset();
2748 $fi->{Digester}->addfile(*F);
2749 F->error and confess "$!";
2750 $got = $fi->{Digester}->hexdigest();
2751 return $got eq $fi->{Hash};
2754 if (stat_exists $tf) {
2755 if ($checkhash->()) {
2756 progress f_ "using existing %s", $f;
2760 fail f_ "file %s has hash %s but .dsc demands hash %s".
2761 " (perhaps you should delete this file?)",
2762 $f, $got, $fi->{Hash};
2764 progress f_ "need to fetch correct version of %s", $f;
2765 unlink $tf or die "$tf $!";
2768 printdebug "$tf does not exist, need to fetch\n";
2772 $furl =~ s{/[^/]+$}{};
2774 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2775 die "$f ?" if $f =~ m#/#;
2776 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2777 return 0 if !act_local();
2780 fail f_ "file %s has hash %s but .dsc demands hash %s".
2781 " (got wrong file from archive!)",
2782 $f, $got, $fi->{Hash};
2787 sub ensure_we_have_orig () {
2788 my @dfi = dsc_files_info();
2789 foreach my $fi (@dfi) {
2790 my $f = $fi->{Filename};
2791 next unless is_orig_file_in_dsc($f, \@dfi);
2792 complete_file_from_dsc($buildproductsdir, $fi)
2797 #---------- git fetch ----------
2799 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2800 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2802 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2803 # locally fetched refs because they have unhelpful names and clutter
2804 # up gitk etc. So we track whether we have "used up" head ref (ie,
2805 # whether we have made another local ref which refers to this object).
2807 # (If we deleted them unconditionally, then we might end up
2808 # re-fetching the same git objects each time dgit fetch was run.)
2810 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2811 # in git_fetch_us to fetch the refs in question, and possibly a call
2812 # to lrfetchref_used.
2814 our (%lrfetchrefs_f, %lrfetchrefs_d);
2815 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2817 sub lrfetchref_used ($) {
2818 my ($fullrefname) = @_;
2819 my $objid = $lrfetchrefs_f{$fullrefname};
2820 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2823 sub git_lrfetch_sane {
2824 my ($url, $supplementary, @specs) = @_;
2825 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2826 # at least as regards @specs. Also leave the results in
2827 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2828 # able to clean these up.
2830 # With $supplementary==1, @specs must not contain wildcards
2831 # and we add to our previous fetches (non-atomically).
2833 # This is rather miserable:
2834 # When git fetch --prune is passed a fetchspec ending with a *,
2835 # it does a plausible thing. If there is no * then:
2836 # - it matches subpaths too, even if the supplied refspec
2837 # starts refs, and behaves completely madly if the source
2838 # has refs/refs/something. (See, for example, Debian #NNNN.)
2839 # - if there is no matching remote ref, it bombs out the whole
2841 # We want to fetch a fixed ref, and we don't know in advance
2842 # if it exists, so this is not suitable.
2844 # Our workaround is to use git ls-remote. git ls-remote has its
2845 # own qairks. Notably, it has the absurd multi-tail-matching
2846 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2847 # refs/refs/foo etc.
2849 # Also, we want an idempotent snapshot, but we have to make two
2850 # calls to the remote: one to git ls-remote and to git fetch. The
2851 # solution is use git ls-remote to obtain a target state, and
2852 # git fetch to try to generate it. If we don't manage to generate
2853 # the target state, we try again.
2855 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2857 my $specre = join '|', map {
2860 my $wildcard = $x =~ s/\\\*$/.*/;
2861 die if $wildcard && $supplementary;
2864 printdebug "git_lrfetch_sane specre=$specre\n";
2865 my $wanted_rref = sub {
2867 return m/^(?:$specre)$/;
2870 my $fetch_iteration = 0;
2873 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2874 if (++$fetch_iteration > 10) {
2875 fail __ "too many iterations trying to get sane fetch!";
2878 my @look = map { "refs/$_" } @specs;
2879 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2883 open GITLS, "-|", @lcmd or confess "$!";
2885 printdebug "=> ", $_;
2886 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2887 my ($objid,$rrefname) = ($1,$2);
2888 if (!$wanted_rref->($rrefname)) {
2889 print STDERR f_ <<END, "@look", $rrefname;
2890 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2894 $wantr{$rrefname} = $objid;
2897 close GITLS or failedcmd @lcmd;
2899 # OK, now %want is exactly what we want for refs in @specs
2901 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2902 "+refs/$_:".lrfetchrefs."/$_";
2905 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2907 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2908 runcmd_ordryrun_local @fcmd if @fspecs;
2910 if (!$supplementary) {
2911 %lrfetchrefs_f = ();
2915 git_for_each_ref(lrfetchrefs, sub {
2916 my ($objid,$objtype,$lrefname,$reftail) = @_;
2917 $lrfetchrefs_f{$lrefname} = $objid;
2918 $objgot{$objid} = 1;
2921 if ($supplementary) {
2925 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2926 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2927 if (!exists $wantr{$rrefname}) {
2928 if ($wanted_rref->($rrefname)) {
2930 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2933 print STDERR f_ <<END, "@fspecs", $lrefname
2934 warning: git fetch %s created %s; this is silly, deleting it.
2937 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2938 delete $lrfetchrefs_f{$lrefname};
2942 foreach my $rrefname (sort keys %wantr) {
2943 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2944 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2945 my $want = $wantr{$rrefname};
2946 next if $got eq $want;
2947 if (!defined $objgot{$want}) {
2948 fail __ <<END unless act_local();
2949 --dry-run specified but we actually wanted the results of git fetch,
2950 so this is not going to work. Try running dgit fetch first,
2951 or using --damp-run instead of --dry-run.
2953 print STDERR f_ <<END, $lrefname, $want;
2954 warning: git ls-remote suggests we want %s
2955 warning: and it should refer to %s
2956 warning: but git fetch didn't fetch that object to any relevant ref.
2957 warning: This may be due to a race with someone updating the server.
2958 warning: Will try again...
2960 next FETCH_ITERATION;
2963 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2965 runcmd_ordryrun_local @git, qw(update-ref -m),
2966 "dgit fetch git fetch fixup", $lrefname, $want;
2967 $lrfetchrefs_f{$lrefname} = $want;
2972 if (defined $csuite) {
2973 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2974 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2975 my ($objid,$objtype,$lrefname,$reftail) = @_;
2976 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2977 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2981 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2982 Dumper(\%lrfetchrefs_f);
2985 sub git_fetch_us () {
2986 # Want to fetch only what we are going to use, unless
2987 # deliberately-not-ff, in which case we must fetch everything.
2989 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2990 map { "tags/$_" } debiantags('*',access_nomdistro);
2991 push @specs, server_branch($csuite);
2992 push @specs, $rewritemap;
2993 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2995 my $url = access_giturl();
2996 git_lrfetch_sane $url, 0, @specs;
2999 my @tagpats = debiantags('*',access_nomdistro);
3001 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
3002 my ($objid,$objtype,$fullrefname,$reftail) = @_;
3003 printdebug "currently $fullrefname=$objid\n";
3004 $here{$fullrefname} = $objid;
3006 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
3007 my ($objid,$objtype,$fullrefname,$reftail) = @_;
3008 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
3009 printdebug "offered $lref=$objid\n";
3010 if (!defined $here{$lref}) {
3011 my @upd = (@git, qw(update-ref), $lref, $objid, '');
3012 runcmd_ordryrun_local @upd;
3013 lrfetchref_used $fullrefname;
3014 } elsif ($here{$lref} eq $objid) {
3015 lrfetchref_used $fullrefname;
3017 print STDERR f_ "Not updating %s from %s to %s.\n",
3018 $lref, $here{$lref}, $objid;
3023 #---------- dsc and archive handling ----------
3025 sub mergeinfo_getclogp ($) {
3026 # Ensures thit $mi->{Clogp} exists and returns it
3028 $mi->{Clogp} = commit_getclogp($mi->{Commit});
3031 sub mergeinfo_version ($) {
3032 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
3035 sub fetch_from_archive_record_1 ($) {
3037 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
3038 cmdoutput @git, qw(log -n2), $hash;
3039 # ... gives git a chance to complain if our commit is malformed
3042 sub fetch_from_archive_record_2 ($) {
3044 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3048 dryrun_report @upd_cmd;
3052 sub parse_dsc_field_def_dsc_distro () {
3053 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3054 dgit.default.distro);
3057 sub parse_dsc_field ($$) {
3058 my ($dsc, $what) = @_;
3060 foreach my $field (@ourdscfield) {
3061 $f = $dsc->{$field};
3066 progress f_ "%s: NO git hash", $what;
3067 parse_dsc_field_def_dsc_distro();
3068 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3069 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3070 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3071 $dsc_hint_tag = [ $dsc_hint_tag ];
3072 } elsif ($f =~ m/^\w+\s*$/) {
3074 parse_dsc_field_def_dsc_distro();
3075 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3077 progress f_ "%s: specified git hash", $what;
3079 fail f_ "%s: invalid Dgit info", $what;
3083 sub resolve_dsc_field_commit ($$) {
3084 my ($already_distro, $already_mapref) = @_;
3086 return unless defined $dsc_hash;
3089 defined $already_mapref &&
3090 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3091 ? $already_mapref : undef;
3095 my ($what, @fetch) = @_;
3097 local $idistro = $dsc_distro;
3098 my $lrf = lrfetchrefs;
3100 if (!$chase_dsc_distro) {
3101 progress f_ "not chasing .dsc distro %s: not fetching %s",
3106 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3108 my $url = access_giturl();
3109 if (!defined $url) {
3110 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3111 .dsc Dgit metadata is in context of distro %s
3112 for which we have no configured url and .dsc provides no hint
3115 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3116 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3117 parse_cfg_bool "dsc-url-proto-ok", 'false',
3118 cfg("dgit.dsc-url-proto-ok.$proto",
3119 "dgit.default.dsc-url-proto-ok")
3120 or fail f_ <<END, $dsc_distro, $proto;
3121 .dsc Dgit metadata is in context of distro %s
3122 for which we have no configured url;
3123 .dsc provides hinted url with protocol %s which is unsafe.
3124 (can be overridden by config - consult documentation)
3126 $url = $dsc_hint_url;
3129 git_lrfetch_sane $url, 1, @fetch;
3134 my $rewrite_enable = do {
3135 local $idistro = $dsc_distro;
3136 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3139 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3140 if (!defined $mapref) {
3141 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3142 $mapref = $lrf.'/'.$rewritemap;
3144 my $rewritemapdata = git_cat_file $mapref.':map';
3145 if (defined $rewritemapdata
3146 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3148 "server's git history rewrite map contains a relevant entry!";
3151 if (defined $dsc_hash) {
3152 progress __ "using rewritten git hash in place of .dsc value";
3154 progress __ "server data says .dsc hash is to be disregarded";
3159 if (!defined git_cat_file $dsc_hash) {
3160 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3161 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3162 defined git_cat_file $dsc_hash
3163 or fail f_ <<END, $dsc_hash;
3164 .dsc Dgit metadata requires commit %s
3165 but we could not obtain that object anywhere.
3167 foreach my $t (@tags) {
3168 my $fullrefname = $lrf.'/'.$t;
3169 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3170 next unless $lrfetchrefs_f{$fullrefname};
3171 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3172 lrfetchref_used $fullrefname;
3177 sub fetch_from_archive () {
3179 ensure_setup_existing_tree();
3181 # Ensures that lrref() is what is actually in the archive, one way
3182 # or another, according to us - ie this client's
3183 # appropritaely-updated archive view. Also returns the commit id.
3184 # If there is nothing in the archive, leaves lrref alone and
3185 # returns undef. git_fetch_us must have already been called.
3189 parse_dsc_field($dsc, __ 'last upload to archive');
3190 resolve_dsc_field_commit access_basedistro,
3191 lrfetchrefs."/".$rewritemap
3193 progress __ "no version available from the archive";
3196 # If the archive's .dsc has a Dgit field, there are three
3197 # relevant git commitids we need to choose between and/or merge
3199 # 1. $dsc_hash: the Dgit field from the archive
3200 # 2. $lastpush_hash: the suite branch on the dgit git server
3201 # 3. $lastfetch_hash: our local tracking brach for the suite
3203 # These may all be distinct and need not be in any fast forward
3206 # If the dsc was pushed to this suite, then the server suite
3207 # branch will have been updated; but it might have been pushed to
3208 # a different suite and copied by the archive. Conversely a more
3209 # recent version may have been pushed with dgit but not appeared
3210 # in the archive (yet).
3212 # $lastfetch_hash may be awkward because archive imports
3213 # (particularly, imports of Dgit-less .dscs) are performed only as
3214 # needed on individual clients, so different clients may perform a
3215 # different subset of them - and these imports are only made
3216 # public during push. So $lastfetch_hash may represent a set of
3217 # imports different to a subsequent upload by a different dgit
3220 # Our approach is as follows:
3222 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3223 # descendant of $dsc_hash, then it was pushed by a dgit user who
3224 # had based their work on $dsc_hash, so we should prefer it.
3225 # Otherwise, $dsc_hash was installed into this suite in the
3226 # archive other than by a dgit push, and (necessarily) after the
3227 # last dgit push into that suite (since a dgit push would have
3228 # been descended from the dgit server git branch); thus, in that
3229 # case, we prefer the archive's version (and produce a
3230 # pseudo-merge to overwrite the dgit server git branch).
3232 # (If there is no Dgit field in the archive's .dsc then
3233 # generate_commit_from_dsc uses the version numbers to decide
3234 # whether the suite branch or the archive is newer. If the suite
3235 # branch is newer it ignores the archive's .dsc; otherwise it
3236 # generates an import of the .dsc, and produces a pseudo-merge to
3237 # overwrite the suite branch with the archive contents.)
3239 # The outcome of that part of the algorithm is the `public view',
3240 # and is same for all dgit clients: it does not depend on any
3241 # unpublished history in the local tracking branch.
3243 # As between the public view and the local tracking branch: The
3244 # local tracking branch is only updated by dgit fetch, and
3245 # whenever dgit fetch runs it includes the public view in the
3246 # local tracking branch. Therefore if the public view is not
3247 # descended from the local tracking branch, the local tracking
3248 # branch must contain history which was imported from the archive
3249 # but never pushed; and, its tip is now out of date. So, we make
3250 # a pseudo-merge to overwrite the old imports and stitch the old
3253 # Finally: we do not necessarily reify the public view (as
3254 # described above). This is so that we do not end up stacking two
3255 # pseudo-merges. So what we actually do is figure out the inputs
3256 # to any public view pseudo-merge and put them in @mergeinputs.
3259 # $mergeinputs[]{Commit}
3260 # $mergeinputs[]{Info}
3261 # $mergeinputs[0] is the one whose tree we use
3262 # @mergeinputs is in the order we use in the actual commit)
3265 # $mergeinputs[]{Message} is a commit message to use
3266 # $mergeinputs[]{ReverseParents} if def specifies that parent
3267 # list should be in opposite order
3268 # Such an entry has no Commit or Info. It applies only when found
3269 # in the last entry. (This ugliness is to support making
3270 # identical imports to previous dgit versions.)
3272 my $lastpush_hash = git_get_ref(lrfetchref());
3273 printdebug "previous reference hash=$lastpush_hash\n";
3274 $lastpush_mergeinput = $lastpush_hash && {
3275 Commit => $lastpush_hash,
3276 Info => (__ "dgit suite branch on dgit git server"),
3279 my $lastfetch_hash = git_get_ref(lrref());
3280 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3281 my $lastfetch_mergeinput = $lastfetch_hash && {
3282 Commit => $lastfetch_hash,
3283 Info => (__ "dgit client's archive history view"),
3286 my $dsc_mergeinput = $dsc_hash && {
3287 Commit => $dsc_hash,
3288 Info => (__ "Dgit field in .dsc from archive"),
3292 my $del_lrfetchrefs = sub {
3295 printdebug "del_lrfetchrefs...\n";
3296 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3297 my $objid = $lrfetchrefs_d{$fullrefname};
3298 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3300 $gur ||= new IO::Handle;
3301 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3303 printf $gur "delete %s %s\n", $fullrefname, $objid;
3306 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3310 if (defined $dsc_hash) {
3311 ensure_we_have_orig();
3312 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3313 @mergeinputs = $dsc_mergeinput
3314 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3315 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3317 Git commit in archive is behind the last version allegedly pushed/uploaded.
3318 Commit referred to by archive: %s
3319 Last version pushed with dgit: %s
3322 __ $later_warning_msg or confess "$!";
3323 @mergeinputs = ($lastpush_mergeinput);
3325 # Archive has .dsc which is not a descendant of the last dgit
3326 # push. This can happen if the archive moves .dscs about.
3327 # Just follow its lead.
3328 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3329 progress __ "archive .dsc names newer git commit";
3330 @mergeinputs = ($dsc_mergeinput);
3332 progress __ "archive .dsc names other git commit, fixing up";
3333 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3337 @mergeinputs = generate_commits_from_dsc();
3338 # We have just done an import. Now, our import algorithm might
3339 # have been improved. But even so we do not want to generate
3340 # a new different import of the same package. So if the
3341 # version numbers are the same, just use our existing version.
3342 # If the version numbers are different, the archive has changed
3343 # (perhaps, rewound).
3344 if ($lastfetch_mergeinput &&
3345 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3346 (mergeinfo_version $mergeinputs[0]) )) {
3347 @mergeinputs = ($lastfetch_mergeinput);
3349 } elsif ($lastpush_hash) {
3350 # only in git, not in the archive yet
3351 @mergeinputs = ($lastpush_mergeinput);
3352 print STDERR f_ <<END,
3354 Package not found in the archive, but has allegedly been pushed using dgit.
3357 __ $later_warning_msg or confess "$!";
3359 printdebug "nothing found!\n";
3360 if (defined $skew_warning_vsn) {
3361 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3363 Warning: relevant archive skew detected.
3364 Archive allegedly contains %s
3365 But we were not able to obtain any version from the archive or git.
3369 unshift @end, $del_lrfetchrefs;
3373 if ($lastfetch_hash &&
3375 my $h = $_->{Commit};
3376 $h and is_fast_fwd($lastfetch_hash, $h);
3377 # If true, one of the existing parents of this commit
3378 # is a descendant of the $lastfetch_hash, so we'll
3379 # be ff from that automatically.
3383 push @mergeinputs, $lastfetch_mergeinput;
3386 printdebug "fetch mergeinfos:\n";
3387 foreach my $mi (@mergeinputs) {
3389 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3391 printdebug sprintf " ReverseParents=%d Message=%s",
3392 $mi->{ReverseParents}, $mi->{Message};
3396 my $compat_info= pop @mergeinputs
3397 if $mergeinputs[$#mergeinputs]{Message};
3399 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3402 if (@mergeinputs > 1) {
3404 my $tree_commit = $mergeinputs[0]{Commit};
3406 my $tree = get_tree_of_commit $tree_commit;;
3408 # We use the changelog author of the package in question the
3409 # author of this pseudo-merge. This is (roughly) correct if
3410 # this commit is simply representing aa non-dgit upload.
3411 # (Roughly because it does not record sponsorship - but we
3412 # don't have sponsorship info because that's in the .changes,
3413 # which isn't in the archivw.)
3415 # But, it might be that we are representing archive history
3416 # updates (including in-archive copies). These are not really
3417 # the responsibility of the person who created the .dsc, but
3418 # there is no-one whose name we should better use. (The
3419 # author of the .dsc-named commit is clearly worse.)
3421 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3422 my $author = clogp_authline $useclogp;
3423 my $cversion = getfield $useclogp, 'Version';
3425 my $mcf = dgit_privdir()."/mergecommit";
3426 open MC, ">", $mcf or die "$mcf $!";
3427 print MC <<END or confess "$!";
3431 my @parents = grep { $_->{Commit} } @mergeinputs;
3432 @parents = reverse @parents if $compat_info->{ReverseParents};
3433 print MC <<END or confess "$!" foreach @parents;
3437 print MC <<END or confess "$!";
3443 if (defined $compat_info->{Message}) {
3444 print MC $compat_info->{Message} or confess "$!";
3446 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3447 Record %s (%s) in archive suite %s
3451 my $message_add_info = sub {
3453 my $mversion = mergeinfo_version $mi;
3454 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3458 $message_add_info->($mergeinputs[0]);
3459 print MC __ <<END or confess "$!";
3460 should be treated as descended from
3462 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3465 close MC or confess "$!";
3466 $hash = hash_commit $mcf;
3468 $hash = $mergeinputs[0]{Commit};
3470 printdebug "fetch hash=$hash\n";
3473 my ($lasth, $what) = @_;
3474 return unless $lasth;
3475 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3478 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3480 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3482 fetch_from_archive_record_1($hash);
3484 if (defined $skew_warning_vsn) {
3485 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3486 my $gotclogp = commit_getclogp($hash);
3487 my $got_vsn = getfield $gotclogp, 'Version';
3488 printdebug "SKEW CHECK GOT $got_vsn\n";
3489 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3490 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3492 Warning: archive skew detected. Using the available version:
3493 Archive allegedly contains %s
3494 We were able to obtain only %s
3500 if ($lastfetch_hash ne $hash) {
3501 fetch_from_archive_record_2($hash);
3504 lrfetchref_used lrfetchref();
3506 check_gitattrs($hash, __ "fetched source tree");
3508 unshift @end, $del_lrfetchrefs;
3512 sub set_local_git_config ($$) {
3514 runcmd @git, qw(config), $k, $v;
3517 sub setup_mergechangelogs (;$) {
3519 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3521 my $driver = 'dpkg-mergechangelogs';
3522 my $cb = "merge.$driver";
3523 confess unless defined $maindir;
3524 my $attrs = "$maindir_gitcommon/info/attributes";
3525 ensuredir "$maindir_gitcommon/info";
3527 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3528 if (!open ATTRS, "<", $attrs) {
3529 $!==ENOENT or die "$attrs: $!";
3533 next if m{^debian/changelog\s};
3534 print NATTRS $_, "\n" or confess "$!";
3536 ATTRS->error and confess "$!";
3539 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3542 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3543 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3545 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3548 sub setup_useremail (;$) {
3550 return unless $always || access_cfg_bool(1, 'setup-useremail');
3553 my ($k, $envvar) = @_;
3554 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3555 return unless defined $v;
3556 set_local_git_config "user.$k", $v;
3559 $setup->('email', 'DEBEMAIL');
3560 $setup->('name', 'DEBFULLNAME');
3563 sub ensure_setup_existing_tree () {
3564 my $k = "remote.$remotename.skipdefaultupdate";
3565 my $c = git_get_config $k;
3566 return if defined $c;
3567 set_local_git_config $k, 'true';
3570 sub open_main_gitattrs () {
3571 confess 'internal error no maindir' unless defined $maindir;
3572 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3574 or die "open $maindir_gitcommon/info/attributes: $!";
3578 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3580 sub is_gitattrs_setup () {
3583 # 1: gitattributes set up and should be left alone
3585 # 0: there is a dgit-defuse-attrs but it needs fixing
3586 # undef: there is none
3587 my $gai = open_main_gitattrs();
3588 return 0 unless $gai;
3590 next unless m{$gitattrs_ourmacro_re};
3591 return 1 if m{\s-working-tree-encoding\s};
3592 printdebug "is_gitattrs_setup: found old macro\n";
3595 $gai->error and confess "$!";
3596 printdebug "is_gitattrs_setup: found nothing\n";
3600 sub setup_gitattrs (;$) {
3602 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3604 my $already = is_gitattrs_setup();
3607 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3608 not doing further gitattributes setup
3612 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3613 my $af = "$maindir_gitcommon/info/attributes";
3614 ensuredir "$maindir_gitcommon/info";
3616 open GAO, "> $af.new" or confess "$!";
3617 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3621 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3623 my $gai = open_main_gitattrs();
3626 if (m{$gitattrs_ourmacro_re}) {
3627 die unless defined $already;
3631 print GAO $_, "\n" or confess "$!";
3633 $gai->error and confess "$!";
3635 close GAO or confess "$!";
3636 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3639 sub setup_new_tree () {
3640 setup_mergechangelogs();
3645 sub check_gitattrs ($$) {
3646 my ($treeish, $what) = @_;
3648 return if is_gitattrs_setup;
3651 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3653 my $gafl = new IO::File;
3654 open $gafl, "-|", @cmd or confess "$!";
3657 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3659 next unless m{(?:^|/)\.gitattributes$};
3661 # oh dear, found one
3662 print STDERR f_ <<END, $what;
3663 dgit: warning: %s contains .gitattributes
3664 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3669 # tree contains no .gitattributes files
3670 $?=0; $!=0; close $gafl or failedcmd @cmd;
3674 sub multisuite_suite_child ($$$) {
3675 my ($tsuite, $mergeinputs, $fn) = @_;
3676 # in child, sets things up, calls $fn->(), and returns undef
3677 # in parent, returns canonical suite name for $tsuite
3678 my $canonsuitefh = IO::File::new_tmpfile;
3679 my $pid = fork // confess "$!";
3683 $us .= " [$isuite]";
3684 $debugprefix .= " ";
3685 progress f_ "fetching %s...", $tsuite;
3686 canonicalise_suite();
3687 print $canonsuitefh $csuite, "\n" or confess "$!";
3688 close $canonsuitefh or confess "$!";
3692 waitpid $pid,0 == $pid or confess "$!";
3693 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3695 seek $canonsuitefh,0,0 or confess "$!";
3696 local $csuite = <$canonsuitefh>;
3697 confess "$!" unless defined $csuite && chomp $csuite;
3699 printdebug "multisuite $tsuite missing\n";
3702 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3703 push @$mergeinputs, {
3710 sub fork_for_multisuite ($) {
3711 my ($before_fetch_merge) = @_;
3712 # if nothing unusual, just returns ''
3715 # returns 0 to caller in child, to do first of the specified suites
3716 # in child, $csuite is not yet set
3718 # returns 1 to caller in parent, to finish up anything needed after
3719 # in parent, $csuite is set to canonicalised portmanteau
3721 my $org_isuite = $isuite;
3722 my @suites = split /\,/, $isuite;
3723 return '' unless @suites > 1;
3724 printdebug "fork_for_multisuite: @suites\n";
3728 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3730 return 0 unless defined $cbasesuite;
3732 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3733 unless @mergeinputs;
3735 my @csuites = ($cbasesuite);
3737 $before_fetch_merge->();
3739 foreach my $tsuite (@suites[1..$#suites]) {
3740 $tsuite =~ s/^-/$cbasesuite-/;
3741 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3748 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3749 push @csuites, $csubsuite;
3752 foreach my $mi (@mergeinputs) {
3753 my $ref = git_get_ref $mi->{Ref};
3754 die "$mi->{Ref} ?" unless length $ref;
3755 $mi->{Commit} = $ref;
3758 $csuite = join ",", @csuites;
3760 my $previous = git_get_ref lrref;
3762 unshift @mergeinputs, {
3763 Commit => $previous,
3764 Info => (__ "local combined tracking branch"),
3766 "archive seems to have rewound: local tracking branch is ahead!"),
3770 foreach my $ix (0..$#mergeinputs) {
3771 $mergeinputs[$ix]{Index} = $ix;
3774 @mergeinputs = sort {
3775 -version_compare(mergeinfo_version $a,
3776 mergeinfo_version $b) # highest version first
3778 $a->{Index} <=> $b->{Index}; # earliest in spec first
3784 foreach my $mi (@mergeinputs) {
3785 printdebug "multisuite merge check $mi->{Info}\n";
3786 foreach my $previous (@needed) {
3787 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3788 printdebug "multisuite merge un-needed $previous->{Info}\n";
3792 printdebug "multisuite merge this-needed\n";
3793 $mi->{Character} = '+';
3796 $needed[0]{Character} = '*';
3798 my $output = $needed[0]{Commit};
3801 printdebug "multisuite merge nontrivial\n";
3802 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3804 my $commit = "tree $tree\n";
3805 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3806 "Input branches:\n",
3809 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3810 printdebug "multisuite merge include $mi->{Info}\n";
3811 $mi->{Character} //= ' ';
3812 $commit .= "parent $mi->{Commit}\n";
3813 $msg .= sprintf " %s %-25s %s\n",
3815 (mergeinfo_version $mi),
3818 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3819 $msg .= __ "\nKey\n".
3820 " * marks the highest version branch, which choose to use\n".
3821 " + marks each branch which was not already an ancestor\n\n";
3823 "[dgit multi-suite $csuite]\n";
3825 "author $authline\n".
3826 "committer $authline\n\n";
3827 $output = hash_commit_text $commit.$msg;
3828 printdebug "multisuite merge generated $output\n";
3831 fetch_from_archive_record_1($output);
3832 fetch_from_archive_record_2($output);
3834 progress f_ "calculated combined tracking suite %s", $csuite;
3839 sub clone_set_head () {
3840 open H, "> .git/HEAD" or confess "$!";
3841 print H "ref: ".lref()."\n" or confess "$!";
3842 close H or confess "$!";
3844 sub clone_finish ($) {
3846 runcmd @git, qw(reset --hard), lrref();
3847 runcmd qw(bash -ec), <<'END';
3849 git ls-tree -r --name-only -z HEAD | \
3850 xargs -0r touch -h -r . --
3852 printdone f_ "ready for work in %s", $dstdir;
3856 # in multisuite, returns twice!
3857 # once in parent after first suite fetched,
3858 # and then again in child after everything is finished
3860 badusage __ "dry run makes no sense with clone" unless act_local();
3862 my $multi_fetched = fork_for_multisuite(sub {
3863 printdebug "multi clone before fetch merge\n";
3867 if ($multi_fetched) {
3868 printdebug "multi clone after fetch merge\n";
3870 clone_finish($dstdir);
3873 printdebug "clone main body\n";
3875 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3879 canonicalise_suite();
3880 my $hasgit = check_for_git();
3882 runcmd @git, qw(init -q);
3886 my $giturl = access_giturl(1);
3887 if (defined $giturl) {
3888 runcmd @git, qw(remote add), 'origin', $giturl;
3891 progress __ "fetching existing git history";
3893 runcmd_ordryrun_local @git, qw(fetch origin);
3895 progress __ "starting new git history";
3897 fetch_from_archive() or no_such_package;
3898 my $vcsgiturl = $dsc->{'Vcs-Git'};
3899 if (length $vcsgiturl) {
3900 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3901 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3903 clone_finish($dstdir);
3907 canonicalise_suite();
3908 if (check_for_git()) {
3911 fetch_from_archive() or no_such_package();
3913 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3914 if (length $vcsgiturl and
3915 (grep { $csuite eq $_ }
3917 cfg 'dgit.vcs-git.suites')) {
3918 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3919 if (defined $current && $current ne $vcsgiturl) {
3920 print STDERR f_ <<END, $csuite;
3921 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3922 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3926 printdone f_ "fetched into %s", lrref();
3930 my $multi_fetched = fork_for_multisuite(sub { });
3931 fetch_one() unless $multi_fetched; # parent
3932 finish 0 if $multi_fetched eq '0'; # child
3937 runcmd_ordryrun_local @git, qw(merge -m),
3938 (f_ "Merge from %s [dgit]", $csuite),
3940 printdone f_ "fetched to %s and merged into HEAD", lrref();
3943 sub check_not_dirty () {
3944 my @forbid = qw(local-options local-patch-header);
3945 @forbid = map { "debian/source/$_" } @forbid;
3946 foreach my $f (@forbid) {
3947 if (stat_exists $f) {
3948 fail f_ "git tree contains %s", $f;
3952 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3953 push @cmd, qw(debian/source/format debian/source/options);
3956 my $bad = cmdoutput @cmd;
3959 "you have uncommitted changes to critical files, cannot continue:\n").
3963 return if $includedirty;
3965 git_check_unmodified();
3968 sub commit_admin ($) {
3971 runcmd_ordryrun_local @git, qw(commit -m), $m;
3974 sub quiltify_nofix_bail ($$) {
3975 my ($headinfo, $xinfo) = @_;
3976 if ($quilt_mode eq 'nofix') {
3978 "quilt fixup required but quilt mode is \`nofix'\n".
3979 "HEAD commit%s differs from tree implied by debian/patches%s",
3984 sub commit_quilty_patch () {
3985 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3987 foreach my $l (split /\n/, $output) {
3988 next unless $l =~ m/\S/;
3989 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3993 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3995 progress __ "nothing quilty to commit, ok.";
3998 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3999 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
4000 runcmd_ordryrun_local @git, qw(add -f), @adds;
4001 commit_admin +(__ <<ENDT).<<END
4002 Commit Debian 3.0 (quilt) metadata
4005 [dgit ($our_version) quilt-fixup]
4009 sub get_source_format () {
4011 if (open F, "debian/source/options") {
4015 s/\s+$//; # ignore missing final newline
4017 my ($k, $v) = ($`, $'); #');
4018 $v =~ s/^"(.*)"$/$1/;
4024 F->error and confess "$!";
4027 confess "$!" unless $!==&ENOENT;
4030 if (!open F, "debian/source/format") {
4031 confess "$!" unless $!==&ENOENT;
4035 F->error and confess "$!";
4037 return ($_, \%options);
4040 sub madformat_wantfixup ($) {
4042 return 0 unless $format eq '3.0 (quilt)';
4043 our $quilt_mode_warned;
4044 if ($quilt_mode eq 'nocheck') {
4045 progress f_ "Not doing any fixup of \`%s'".
4046 " due to ----no-quilt-fixup or --quilt=nocheck", $format
4047 unless $quilt_mode_warned++;
4050 progress f_ "Format \`%s', need to check/update patch stack", $format
4051 unless $quilt_mode_warned++;
4055 sub maybe_split_brain_save ($$$) {
4056 my ($headref, $dgitview, $msg) = @_;
4057 # => message fragment "$saved" describing disposition of $dgitview
4058 # (used inside parens, in the English texts)
4059 my $save = $internal_object_save{'dgit-view'};
4060 return f_ "commit id %s", $dgitview unless defined $save;
4061 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4063 "dgit --dgit-view-save $msg HEAD=$headref",
4066 return f_ "and left in %s", $save;
4069 # An "infopair" is a tuple [ $thing, $what ]
4070 # (often $thing is a commit hash; $what is a description)
4072 sub infopair_cond_equal ($$) {
4074 $x->[0] eq $y->[0] or fail <<END;
4075 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4079 sub infopair_lrf_tag_lookup ($$) {
4080 my ($tagnames, $what) = @_;
4081 # $tagname may be an array ref
4082 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4083 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4084 foreach my $tagname (@tagnames) {
4085 my $lrefname = lrfetchrefs."/tags/$tagname";
4086 my $tagobj = $lrfetchrefs_f{$lrefname};
4087 next unless defined $tagobj;
4088 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4089 return [ git_rev_parse($tagobj), $what ];
4091 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4092 Wanted tag %s (%s) on dgit server, but not found
4094 : (f_ <<END, $what, "@tagnames");
4095 Wanted tag %s (one of: %s) on dgit server, but not found
4099 sub infopair_cond_ff ($$) {
4100 my ($anc,$desc) = @_;
4101 is_fast_fwd($anc->[0], $desc->[0]) or
4102 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4103 %s (%s) .. %s (%s) is not fast forward
4107 sub pseudomerge_version_check ($$) {
4108 my ($clogp, $archive_hash) = @_;
4110 my $arch_clogp = commit_getclogp $archive_hash;
4111 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4112 __ 'version currently in archive' ];
4113 if (defined $overwrite_version) {
4114 if (length $overwrite_version) {
4115 infopair_cond_equal([ $overwrite_version,
4116 '--overwrite= version' ],
4119 my $v = $i_arch_v->[0];
4121 "Checking package changelog for archive version %s ...", $v;
4124 my @xa = ("-f$v", "-t$v");
4125 my $vclogp = parsechangelog @xa;
4128 [ (getfield $vclogp, $fn),
4129 (f_ "%s field from dpkg-parsechangelog %s",
4132 my $cv = $gf->('Version');
4133 infopair_cond_equal($i_arch_v, $cv);
4134 $cd = $gf->('Distribution');
4138 $@ =~ s/^dgit: //gm;
4140 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4142 fail f_ <<END, $cd->[1], $cd->[0], $v
4144 Your tree seems to based on earlier (not uploaded) %s.
4146 if $cd->[0] =~ m/UNRELEASED/;
4150 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4154 sub pseudomerge_hash_commit ($$$$ $$) {
4155 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4156 $msg_cmd, $msg_msg) = @_;
4157 progress f_ "Declaring that HEAD includes all changes in %s...",
4160 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4161 my $authline = clogp_authline $clogp;
4165 !defined $overwrite_version ? ""
4166 : !length $overwrite_version ? " --overwrite"
4167 : " --overwrite=".$overwrite_version;
4169 # Contributing parent is the first parent - that makes
4170 # git rev-list --first-parent DTRT.
4171 my $pmf = dgit_privdir()."/pseudomerge";
4172 open MC, ">", $pmf or die "$pmf $!";
4173 print MC <<END or confess "$!";
4176 parent $archive_hash
4184 close MC or confess "$!";
4186 return hash_commit($pmf);
4189 sub splitbrain_pseudomerge ($$$$) {
4190 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4191 # => $merged_dgitview
4192 printdebug "splitbrain_pseudomerge...\n";
4194 # We: debian/PREVIOUS HEAD($maintview)
4195 # expect: o ----------------- o
4198 # a/d/PREVIOUS $dgitview
4201 # we do: `------------------ o
4205 return $dgitview unless defined $archive_hash;
4206 return $dgitview if deliberately_not_fast_forward();
4208 printdebug "splitbrain_pseudomerge...\n";
4210 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4212 if (!defined $overwrite_version) {
4213 progress __ "Checking that HEAD includes all changes in archive...";
4216 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4218 if (defined $overwrite_version) {
4220 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4221 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4222 __ "maintainer view tag");
4223 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4224 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4225 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4227 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4229 infopair_cond_equal($i_dgit, $i_archive);
4230 infopair_cond_ff($i_dep14, $i_dgit);
4231 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4234 $@ =~ s/^\n//; chomp $@;
4235 print STDERR <<END.(__ <<ENDT);
4238 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4243 my $arch_v = $i_arch_v->[0];
4244 my $r = pseudomerge_hash_commit
4245 $clogp, $dgitview, $archive_hash, $i_arch_v,
4246 "dgit --quilt=$quilt_mode",
4247 (defined $overwrite_version
4248 ? f_ "Declare fast forward from %s\n", $arch_v
4249 : f_ "Make fast forward from %s\n", $arch_v);
4251 maybe_split_brain_save $maintview, $r, "pseudomerge";
4253 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4257 sub plain_overwrite_pseudomerge ($$$) {
4258 my ($clogp, $head, $archive_hash) = @_;
4260 printdebug "plain_overwrite_pseudomerge...";
4262 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4264 return $head if is_fast_fwd $archive_hash, $head;
4266 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4268 my $r = pseudomerge_hash_commit
4269 $clogp, $head, $archive_hash, $i_arch_v,
4272 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4274 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4278 sub push_parse_changelog ($) {
4281 my $clogp = Dpkg::Control::Hash->new();
4282 $clogp->load($clogpfn) or die;
4284 my $clogpackage = getfield $clogp, 'Source';
4285 $package //= $clogpackage;
4286 fail f_ "-p specified %s but changelog specified %s",
4287 $package, $clogpackage
4288 unless $package eq $clogpackage;
4289 my $cversion = getfield $clogp, 'Version';
4291 if (!$we_are_initiator) {
4292 # rpush initiator can't do this because it doesn't have $isuite yet
4293 my $tag = debiantag_new($cversion, access_nomdistro);
4294 runcmd @git, qw(check-ref-format), $tag;
4297 my $dscfn = dscfn($cversion);
4299 return ($clogp, $cversion, $dscfn);
4302 sub push_parse_dsc ($$$) {
4303 my ($dscfn,$dscfnwhat, $cversion) = @_;
4304 $dsc = parsecontrol($dscfn,$dscfnwhat);
4305 my $dversion = getfield $dsc, 'Version';
4306 my $dscpackage = getfield $dsc, 'Source';
4307 ($dscpackage eq $package && $dversion eq $cversion) or
4308 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4309 $dscfn, $dscpackage, $dversion,
4310 $package, $cversion;
4313 sub push_tagwants ($$$$) {
4314 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4317 TagFn => \&debiantag_new,
4322 if (defined $maintviewhead) {
4324 TagFn => \&debiantag_maintview,
4325 Objid => $maintviewhead,
4326 TfSuffix => '-maintview',
4329 } elsif ($dodep14tag ne 'no') {
4331 TagFn => \&debiantag_maintview,
4333 TfSuffix => '-dgit',
4337 foreach my $tw (@tagwants) {
4338 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4339 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4341 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4345 sub push_mktags ($$ $$ $) {
4347 $changesfile,$changesfilewhat,
4350 die unless $tagwants->[0]{View} eq 'dgit';
4352 my $declaredistro = access_nomdistro();
4353 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4354 $dsc->{$ourdscfield[0]} = join " ",
4355 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4357 $dsc->save("$dscfn.tmp") or confess "$!";
4359 my $changes = parsecontrol($changesfile,$changesfilewhat);
4360 foreach my $field (qw(Source Distribution Version)) {
4361 $changes->{$field} eq $clogp->{$field} or
4362 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4363 $field, $changes->{$field}, $clogp->{$field};
4366 my $cversion = getfield $clogp, 'Version';
4367 my $clogsuite = getfield $clogp, 'Distribution';
4368 my $format = getfield $dsc, 'Format';
4370 # We make the git tag by hand because (a) that makes it easier
4371 # to control the "tagger" (b) we can do remote signing
4372 my $authline = clogp_authline $clogp;
4376 my $tfn = $tw->{Tfn};
4377 my $head = $tw->{Objid};
4378 my $tag = $tw->{Tag};
4380 open TO, '>', $tfn->('.tmp') or confess "$!";
4381 print TO <<END or confess "$!";
4389 my @dtxinfo = @deliberatelies;
4390 unshift @dtxinfo, "--quilt=$quilt_mode" if madformat($format);
4391 unshift @dtxinfo, do_split_brain() ? "split" : "no-split"
4392 # rpush protocol 5 and earlier don't tell us
4393 unless $we_are_initiator && $protovsn < 6;
4394 my $dtxinfo = join(" ", "",@dtxinfo);
4395 my $tag_metadata = <<END;
4396 [dgit distro=$declaredistro$dtxinfo]
4398 foreach my $ref (sort keys %previously) {
4399 $tag_metadata .= <<END or confess "$!";
4400 [dgit previously:$ref=$previously{$ref}]
4404 if ($tw->{View} eq 'dgit') {
4405 print TO sprintf <<ENDT, $package, $cversion, $clogsuite, $csuite
4406 %s release %s for %s (%s) [dgit]
4409 } elsif ($tw->{View} eq 'maint') {
4410 print TO sprintf <<END, $package, $cversion, $clogsuite, $csuite;
4411 %s release %s for %s (%s)
4415 (maintainer view tag generated by dgit --quilt=%s)
4420 confess Dumper($tw)."?";
4422 print TO "\n", $tag_metadata;
4424 close TO or confess "$!";
4426 my $tagobjfn = $tfn->('.tmp');
4428 if (!defined $keyid) {
4429 $keyid = access_cfg('keyid','RETURN-UNDEF');
4431 if (!defined $keyid) {
4432 $keyid = getfield $clogp, 'Maintainer';
4434 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4435 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4436 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4437 push @sign_cmd, $tfn->('.tmp');
4438 runcmd_ordryrun @sign_cmd;
4440 $tagobjfn = $tfn->('.signed.tmp');
4441 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4442 $tfn->('.tmp'), $tfn->('.tmp.asc');
4448 my @r = map { $mktag->($_); } @$tagwants;
4452 sub sign_changes ($) {
4453 my ($changesfile) = @_;
4455 my @debsign_cmd = @debsign;
4456 push @debsign_cmd, "-k$keyid" if defined $keyid;
4457 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4458 push @debsign_cmd, $changesfile;
4459 runcmd_ordryrun @debsign_cmd;
4464 printdebug "actually entering push\n";
4466 supplementary_message(__ <<'END');
4467 Push failed, while checking state of the archive.
4468 You can retry the push, after fixing the problem, if you like.
4470 if (check_for_git()) {
4473 my $archive_hash = fetch_from_archive();
4474 if (!$archive_hash) {
4476 fail __ "package appears to be new in this suite;".
4477 " if this is intentional, use --new";
4480 supplementary_message(__ <<'END');
4481 Push failed, while preparing your push.
4482 You can retry the push, after fixing the problem, if you like.
4487 access_giturl(); # check that success is vaguely likely
4488 rpush_handle_protovsn_bothends() if $we_are_initiator;
4490 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4491 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4493 responder_send_file('parsed-changelog', $clogpfn);
4495 my ($clogp, $cversion, $dscfn) =
4496 push_parse_changelog("$clogpfn");
4498 my $dscpath = "$buildproductsdir/$dscfn";
4499 stat_exists $dscpath or
4500 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4503 responder_send_file('dsc', $dscpath);
4505 push_parse_dsc($dscpath, $dscfn, $cversion);
4507 my $format = getfield $dsc, 'Format';
4509 my $symref = git_get_symref();
4510 my $actualhead = git_rev_parse('HEAD');
4512 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4513 if (quiltmode_splitting()) {
4514 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4515 fail f_ <<END, $ffq_prev, $quilt_mode;
4516 Branch is managed by git-debrebase (%s
4517 exists), but quilt mode (%s) implies a split view.
4518 Pass the right --quilt option or adjust your git config.
4519 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4522 runcmd_ordryrun_local @git_debrebase, 'stitch';
4523 $actualhead = git_rev_parse('HEAD');
4526 my $dgithead = $actualhead;
4527 my $maintviewhead = undef;
4529 my $upstreamversion = upstreamversion $clogp->{Version};
4531 if (madformat_wantfixup($format)) {
4532 # user might have not used dgit build, so maybe do this now:
4533 if (do_split_brain()) {
4534 changedir $playground;
4536 ($dgithead, $cachekey) =
4537 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4538 $dgithead or fail f_
4539 "--quilt=%s but no cached dgit view:
4540 perhaps HEAD changed since dgit build[-source] ?",
4543 if (!do_split_brain()) {
4544 # In split brain mode, do not attempt to incorporate dirty
4545 # stuff from the user's working tree. That would be mad.
4546 commit_quilty_patch();
4549 if (do_split_brain()) {
4550 $made_split_brain = 1;
4551 $dgithead = splitbrain_pseudomerge($clogp,
4552 $actualhead, $dgithead,
4554 $maintviewhead = $actualhead;
4556 prep_ud(); # so _only_subdir() works, below
4559 if (defined $overwrite_version && !defined $maintviewhead
4561 $dgithead = plain_overwrite_pseudomerge($clogp,
4569 if ($archive_hash) {
4570 if (is_fast_fwd($archive_hash, $dgithead)) {
4572 } elsif (deliberately_not_fast_forward) {
4575 fail __ "dgit push: HEAD is not a descendant".
4576 " of the archive's version.\n".
4577 "To overwrite the archive's contents,".
4578 " pass --overwrite[=VERSION].\n".
4579 "To rewind history, if permitted by the archive,".
4580 " use --deliberately-not-fast-forward.";
4584 confess unless !!$made_split_brain == do_split_brain();
4586 changedir $playground;
4587 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4588 runcmd qw(dpkg-source -x --),
4589 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4590 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4591 check_for_vendor_patches() if madformat($dsc->{format});
4593 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4594 debugcmd "+",@diffcmd;
4596 my $r = system @diffcmd;
4599 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4600 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4603 my $raw = cmdoutput @git,
4604 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4606 foreach (split /\0/, $raw) {
4607 if (defined $changed) {
4608 push @mode_changes, "$changed: $_\n" if $changed;
4611 } elsif (m/^:0+ 0+ /) {
4613 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4614 $changed = "Mode change from $1 to $2"
4619 if (@mode_changes) {
4620 fail +(f_ <<ENDT, $dscfn).<<END
4621 HEAD specifies a different tree to %s:
4625 .(join '', @mode_changes)
4626 .(f_ <<ENDT, $tree, $referent);
4627 There is a problem with your source tree (see dgit(7) for some hints).
4628 To see a full diff, run git diff %s %s
4632 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4633 HEAD specifies a different tree to %s:
4637 Perhaps you forgot to build. Or perhaps there is a problem with your
4638 source tree (see dgit(7) for some hints). To see a full diff, run
4645 if (!$changesfile) {
4646 my $pat = changespat $cversion;
4647 my @cs = glob "$buildproductsdir/$pat";
4648 fail f_ "failed to find unique changes file".
4649 " (looked for %s in %s);".
4650 " perhaps you need to use dgit -C",
4651 $pat, $buildproductsdir
4653 ($changesfile) = @cs;
4655 $changesfile = "$buildproductsdir/$changesfile";
4658 # Check that changes and .dsc agree enough
4659 $changesfile =~ m{[^/]*$};
4660 my $changes = parsecontrol($changesfile,$&);
4661 files_compare_inputs($dsc, $changes)
4662 unless forceing [qw(dsc-changes-mismatch)];
4664 # Check whether this is a source only upload
4665 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4666 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4667 if ($sourceonlypolicy eq 'ok') {
4668 } elsif ($sourceonlypolicy eq 'always') {
4669 forceable_fail [qw(uploading-binaries)],
4670 __ "uploading binaries, although distro policy is source only"
4672 } elsif ($sourceonlypolicy eq 'never') {
4673 forceable_fail [qw(uploading-source-only)],
4674 __ "source-only upload, although distro policy requires .debs"
4676 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4677 forceable_fail [qw(uploading-source-only)],
4678 f_ "source-only upload, even though package is entirely NEW\n".
4679 "(this is contrary to policy in %s)",
4683 && !(archive_query('package_not_wholly_new', $package) // 1);
4685 badcfg f_ "unknown source-only-uploads policy \`%s'",
4689 # Perhaps adjust .dsc to contain right set of origs
4690 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4692 unless forceing [qw(changes-origs-exactly)];
4694 # Checks complete, we're going to try and go ahead:
4696 responder_send_file('changes',$changesfile);
4697 responder_send_command("param head $dgithead");
4698 responder_send_command("param csuite $csuite");
4699 responder_send_command("param isuite $isuite");
4700 responder_send_command("param tagformat new"); # needed in $protovsn==4
4701 responder_send_command("param splitbrain $do_split_brain");
4702 if (defined $maintviewhead) {
4703 responder_send_command("param maint-view $maintviewhead");
4706 # Perhaps send buildinfo(s) for signing
4707 my $changes_files = getfield $changes, 'Files';
4708 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4709 foreach my $bi (@buildinfos) {
4710 responder_send_command("param buildinfo-filename $bi");
4711 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4714 if (deliberately_not_fast_forward) {
4715 git_for_each_ref(lrfetchrefs, sub {
4716 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4717 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4718 responder_send_command("previously $rrefname=$objid");
4719 $previously{$rrefname} = $objid;
4723 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4724 dgit_privdir()."/tag");
4727 supplementary_message(__ <<'END');
4728 Push failed, while signing the tag.
4729 You can retry the push, after fixing the problem, if you like.
4731 # If we manage to sign but fail to record it anywhere, it's fine.
4732 if ($we_are_responder) {
4733 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4734 responder_receive_files('signed-tag', @tagobjfns);
4736 @tagobjfns = push_mktags($clogp,$dscpath,
4737 $changesfile,$changesfile,
4740 supplementary_message(__ <<'END');
4741 Push failed, *after* signing the tag.
4742 If you want to try again, you should use a new version number.
4745 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4747 foreach my $tw (@tagwants) {
4748 my $tag = $tw->{Tag};
4749 my $tagobjfn = $tw->{TagObjFn};
4751 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4752 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4753 runcmd_ordryrun_local
4754 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4757 supplementary_message(__ <<'END');
4758 Push failed, while updating the remote git repository - see messages above.
4759 If you want to try again, you should use a new version number.
4761 if (!check_for_git()) {
4762 create_remote_git_repo();
4765 my @pushrefs = $forceflag.$dgithead.":".rrref();
4766 foreach my $tw (@tagwants) {
4767 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4770 runcmd_ordryrun @git,
4771 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4772 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4774 supplementary_message(__ <<'END');
4775 Push failed, while obtaining signatures on the .changes and .dsc.
4776 If it was just that the signature failed, you may try again by using
4777 debsign by hand to sign the changes file (see the command dgit tried,
4778 above), and then dput that changes file to complete the upload.
4779 If you need to change the package, you must use a new version number.
4781 if ($we_are_responder) {
4782 my $dryrunsuffix = act_local() ? "" : ".tmp";
4783 my @rfiles = ($dscpath, $changesfile);
4784 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4785 responder_receive_files('signed-dsc-changes',
4786 map { "$_$dryrunsuffix" } @rfiles);
4789 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4791 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4793 sign_changes $changesfile;
4796 supplementary_message(f_ <<END, $changesfile);
4797 Push failed, while uploading package(s) to the archive server.
4798 You can retry the upload of exactly these same files with dput of:
4800 If that .changes file is broken, you will need to use a new version
4801 number for your next attempt at the upload.
4803 my $host = access_cfg('upload-host','RETURN-UNDEF');
4804 my @hostarg = defined($host) ? ($host,) : ();
4805 runcmd_ordryrun @dput, @hostarg, $changesfile;
4806 printdone f_ "pushed and uploaded %s", $cversion;
4808 supplementary_message('');
4809 responder_send_command("complete");
4813 not_necessarily_a_tree();
4818 badusage __ "-p is not allowed with clone; specify as argument instead"
4819 if defined $package;
4822 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4823 ($package,$isuite) = @ARGV;
4824 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4825 ($package,$dstdir) = @ARGV;
4826 } elsif (@ARGV==3) {
4827 ($package,$isuite,$dstdir) = @ARGV;
4829 badusage __ "incorrect arguments to dgit clone";
4833 $dstdir ||= "$package";
4834 if (stat_exists $dstdir) {
4835 fail f_ "%s already exists", $dstdir;
4839 if ($rmonerror && !$dryrun_level) {
4840 $cwd_remove= getcwd();
4842 return unless defined $cwd_remove;
4843 if (!chdir "$cwd_remove") {
4844 return if $!==&ENOENT;
4845 confess "chdir $cwd_remove: $!";
4847 printdebug "clone rmonerror removing $dstdir\n";
4849 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4850 } elsif (grep { $! == $_ }
4851 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4853 print STDERR f_ "check whether to remove %s: %s\n",
4860 $cwd_remove = undef;
4863 sub branchsuite () {
4864 my $branch = git_get_symref();
4865 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4872 sub package_from_d_control () {
4873 if (!defined $package) {
4874 my $sourcep = parsecontrol('debian/control','debian/control');
4875 $package = getfield $sourcep, 'Source';
4879 sub fetchpullargs () {
4880 package_from_d_control();
4882 $isuite = branchsuite();
4884 my $clogp = parsechangelog();
4885 my $clogsuite = getfield $clogp, 'Distribution';
4886 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4888 } elsif (@ARGV==1) {
4891 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4905 determine_whether_split_brain get_source_format();
4906 if (do_split_brain()) {
4907 my ($format, $fopts) = get_source_format();
4908 madformat($format) and fail f_ <<END, $quilt_mode
4909 dgit pull not yet supported in split view mode (including with view-splitting quilt modes)
4917 package_from_d_control();
4918 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4922 foreach my $canon (qw(0 1)) {
4927 canonicalise_suite();
4929 if (length git_get_ref lref()) {
4930 # local branch already exists, yay
4933 if (!length git_get_ref lrref()) {
4941 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4944 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4945 "dgit checkout $isuite";
4946 runcmd (@git, qw(checkout), lbranch());
4949 sub cmd_update_vcs_git () {
4951 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4952 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4954 ($specsuite) = (@ARGV);
4959 if ($ARGV[0] eq '-') {
4961 } elsif ($ARGV[0] eq '-') {
4966 package_from_d_control();
4968 if ($specsuite eq '.') {
4969 $ctrl = parsecontrol 'debian/control', 'debian/control';
4971 $isuite = $specsuite;
4975 my $url = getfield $ctrl, 'Vcs-Git';
4978 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4979 if (!defined $orgurl) {
4980 print STDERR f_ "setting up vcs-git: %s\n", $url;
4981 @cmd = (@git, qw(remote add vcs-git), $url);
4982 } elsif ($orgurl eq $url) {
4983 print STDERR f_ "vcs git already configured: %s\n", $url;
4985 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4986 @cmd = (@git, qw(remote set-url vcs-git), $url);
4988 runcmd_ordryrun_local @cmd;
4990 print f_ "fetching (%s)\n", "@ARGV";
4991 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4997 build_or_push_prep_early();
4999 build_or_push_prep_modes();
5003 } elsif (@ARGV==1) {
5004 ($specsuite) = (@ARGV);
5006 badusage f_ "incorrect arguments to dgit %s", $subcommand;
5009 local ($package) = $existing_package; # this is a hack
5010 canonicalise_suite();
5012 canonicalise_suite();
5014 if (defined $specsuite &&
5015 $specsuite ne $isuite &&
5016 $specsuite ne $csuite) {
5017 fail f_ "dgit %s: changelog specifies %s (%s)".
5018 " but command line specifies %s",
5019 $subcommand, $isuite, $csuite, $specsuite;
5028 #---------- remote commands' implementation ----------
5030 sub pre_remote_push_build_host {
5031 my ($nrargs) = shift @ARGV;
5032 my (@rargs) = @ARGV[0..$nrargs-1];
5033 @ARGV = @ARGV[$nrargs..$#ARGV];
5035 my ($dir,$vsnwant) = @rargs;
5036 # vsnwant is a comma-separated list; we report which we have
5037 # chosen in our ready response (so other end can tell if they
5040 $we_are_responder = 1;
5041 $us .= " (build host)";
5043 open PI, "<&STDIN" or confess "$!";
5044 open STDIN, "/dev/null" or confess "$!";
5045 open PO, ">&STDOUT" or confess "$!";
5047 open STDOUT, ">&STDERR" or confess "$!";
5051 ($protovsn) = grep {
5052 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5053 } @rpushprotovsn_support;
5055 fail f_ "build host has dgit rpush protocol versions %s".
5056 " but invocation host has %s",
5057 (join ",", @rpushprotovsn_support), $vsnwant
5058 unless defined $protovsn;
5062 sub cmd_remote_push_build_host {
5063 responder_send_command("dgit-remote-push-ready $protovsn");
5067 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5068 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5069 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5070 # a good error message)
5072 sub rpush_handle_protovsn_bothends () {
5079 my $report = i_child_report();
5080 if (defined $report) {
5081 printdebug "($report)\n";
5082 } elsif ($i_child_pid) {
5083 printdebug "(killing build host child $i_child_pid)\n";
5084 kill 15, $i_child_pid;
5086 if (defined $i_tmp && !defined $initiator_tempdir) {
5088 eval { rmtree $i_tmp; };
5093 return unless forkcheck_mainprocess();
5098 my ($base,$selector,@args) = @_;
5099 $selector =~ s/\-/_/g;
5100 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5104 not_necessarily_a_tree();
5109 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5117 push @rargs, join ",", @rpushprotovsn_support;
5120 push @rdgit, @ropts;
5121 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5123 my @cmd = (@ssh, $host, shellquote @rdgit);
5126 $we_are_initiator=1;
5128 if (defined $initiator_tempdir) {
5129 rmtree $initiator_tempdir;
5130 mkdir $initiator_tempdir, 0700
5131 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5132 $i_tmp = $initiator_tempdir;
5136 $i_child_pid = open2(\*RO, \*RI, @cmd);
5138 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5139 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5142 my ($icmd,$iargs) = initiator_expect {
5143 m/^(\S+)(?: (.*))?$/;
5146 i_method "i_resp", $icmd, $iargs;
5150 sub i_resp_progress ($) {
5152 my $msg = protocol_read_bytes \*RO, $rhs;
5156 sub i_resp_supplementary_message ($) {
5158 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5161 sub i_resp_complete {
5162 my $pid = $i_child_pid;
5163 $i_child_pid = undef; # prevents killing some other process with same pid
5164 printdebug "waiting for build host child $pid...\n";
5165 my $got = waitpid $pid, 0;
5166 confess "$!" unless $got == $pid;
5167 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5170 printdebug __ "all done\n";
5174 sub i_resp_file ($) {
5176 my $localname = i_method "i_localname", $keyword;
5177 my $localpath = "$i_tmp/$localname";
5178 stat_exists $localpath and
5179 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5180 protocol_receive_file \*RO, $localpath;
5181 i_method "i_file", $keyword;
5186 sub i_resp_param ($) {
5187 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5191 sub i_resp_previously ($) {
5192 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5193 or badproto \*RO, __ "bad previously spec";
5194 my $r = system qw(git check-ref-format), $1;
5195 confess "bad previously ref spec ($r)" if $r;
5196 $previously{$1} = $2;
5200 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5202 sub i_resp_want ($) {
5204 die "$keyword ?" if $i_wanted{$keyword}++;
5206 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5207 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5208 die unless $isuite =~ m/^$suite_re$/;
5210 if (!defined $dsc) {
5212 rpush_handle_protovsn_bothends();
5213 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5214 if ($protovsn >= 6) {
5215 determine_whether_split_brain getfield $dsc, 'Format';
5216 $do_split_brain eq ($i_param{'splitbrain'} // '<unsent>')
5218 "split brain mismatch, $do_split_brain != $i_param{'split_brain'}";
5219 printdebug "rpush split brain $do_split_brain\n";
5223 my @localpaths = i_method "i_want", $keyword;
5224 printdebug "[[ $keyword @localpaths\n";
5225 foreach my $localpath (@localpaths) {
5226 protocol_send_file \*RI, $localpath;
5228 print RI "files-end\n" or confess "$!";
5231 sub i_localname_parsed_changelog {
5232 return "remote-changelog.822";
5234 sub i_file_parsed_changelog {
5235 ($i_clogp, $i_version, $i_dscfn) =
5236 push_parse_changelog "$i_tmp/remote-changelog.822";
5237 die if $i_dscfn =~ m#/|^\W#;
5240 sub i_localname_dsc {
5241 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5246 sub i_localname_buildinfo ($) {
5247 my $bi = $i_param{'buildinfo-filename'};
5248 defined $bi or badproto \*RO, "buildinfo before filename";
5249 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5250 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5251 or badproto \*RO, "improper buildinfo filename";
5254 sub i_file_buildinfo {
5255 my $bi = $i_param{'buildinfo-filename'};
5256 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5257 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5258 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5259 files_compare_inputs($bd, $ch);
5260 (getfield $bd, $_) eq (getfield $ch, $_) or
5261 fail f_ "buildinfo mismatch in field %s", $_
5262 foreach qw(Source Version);
5263 !defined $bd->{$_} or
5264 fail f_ "buildinfo contains forbidden field %s", $_
5265 foreach qw(Changes Changed-by Distribution);
5267 push @i_buildinfos, $bi;
5268 delete $i_param{'buildinfo-filename'};
5271 sub i_localname_changes {
5272 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5273 $i_changesfn = $i_dscfn;
5274 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5275 return $i_changesfn;
5277 sub i_file_changes { }
5279 sub i_want_signed_tag {
5280 printdebug Dumper(\%i_param, $i_dscfn);
5281 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5282 && defined $i_param{'csuite'}
5283 or badproto \*RO, "premature desire for signed-tag";
5284 my $head = $i_param{'head'};
5285 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5287 my $maintview = $i_param{'maint-view'};
5288 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5290 if ($protovsn == 4) {
5291 my $p = $i_param{'tagformat'} // '<undef>';
5293 or badproto \*RO, "tag format mismatch: $p vs. new";
5296 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5298 defined $dsc or badproto \*RO, "dsc (before parsed-changelog)";
5300 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5303 push_mktags $i_clogp, $i_dscfn,
5304 $i_changesfn, (__ 'remote changes file'),
5308 sub i_want_signed_dsc_changes {
5309 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5310 sign_changes $i_changesfn;
5311 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5314 #---------- building etc. ----------
5320 #----- `3.0 (quilt)' handling -----
5322 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5324 sub quiltify_dpkg_commit ($$$;$) {
5325 my ($patchname,$author,$msg, $xinfo) = @_;
5328 mkpath '.git/dgit'; # we are in playtree
5329 my $descfn = ".git/dgit/quilt-description.tmp";
5330 open O, '>', $descfn or confess "$descfn: $!";
5331 $msg =~ s/\n+/\n\n/;
5332 print O <<END or confess "$!";
5334 ${xinfo}Subject: $msg
5338 close O or confess "$!";
5341 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5342 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5343 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5344 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5348 sub quiltify_trees_differ ($$;$$$) {
5349 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5350 # returns true iff the two tree objects differ other than in debian/
5351 # with $finegrained,
5352 # returns bitmask 01 - differ in upstream files except .gitignore
5353 # 02 - differ in .gitignore
5354 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5355 # is set for each modified .gitignore filename $fn
5356 # if $unrepres is defined, array ref to which is appeneded
5357 # a list of unrepresentable changes (removals of upstream files
5360 my @cmd = (@git, qw(diff-tree -z --no-renames));
5361 push @cmd, qw(--name-only) unless $unrepres;
5362 push @cmd, qw(-r) if $finegrained || $unrepres;
5364 my $diffs= cmdoutput @cmd;
5367 foreach my $f (split /\0/, $diffs) {
5368 if ($unrepres && !@lmodes) {
5369 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5372 my ($oldmode,$newmode) = @lmodes;
5375 next if $f =~ m#^debian(?:/.*)?$#s;
5379 die __ "not a plain file or symlink\n"
5380 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5381 $oldmode =~ m/^(?:10|12)\d{4}$/;
5382 if ($oldmode =~ m/[^0]/ &&
5383 $newmode =~ m/[^0]/) {
5384 # both old and new files exist
5385 die __ "mode or type changed\n" if $oldmode ne $newmode;
5386 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5387 } elsif ($oldmode =~ m/[^0]/) {
5389 die __ "deletion of symlink\n"
5390 unless $oldmode =~ m/^10/;
5393 die __ "creation with non-default mode\n"
5394 unless $newmode =~ m/^100644$/ or
5395 $newmode =~ m/^120000$/;
5399 local $/="\n"; chomp $@;
5400 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5404 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5405 $r |= $isignore ? 02 : 01;
5406 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5408 printdebug "quiltify_trees_differ $x $y => $r\n";
5412 sub quiltify_tree_sentinelfiles ($) {
5413 # lists the `sentinel' files present in the tree
5415 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5416 qw(-- debian/rules debian/control);
5421 sub quiltify_splitting ($$$$$$$) {
5422 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5423 $editedignores, $cachekey) = @_;
5424 my $gitignore_special = 1;
5425 if ($quilt_mode !~ m/gbp|dpm|baredebian/) {
5426 # treat .gitignore just like any other upstream file
5427 $diffbits = { %$diffbits };
5428 $_ = !!$_ foreach values %$diffbits;
5429 $gitignore_special = 0;
5431 # We would like any commits we generate to be reproducible
5432 my @authline = clogp_authline($clogp);
5433 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5434 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5435 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5436 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5437 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5438 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5440 confess unless do_split_brain();
5442 my $fulldiffhint = sub {
5444 my $cmd = "git diff $x $y -- :/ ':!debian'";
5445 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5446 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5450 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5451 ($diffbits->{O2H} & 01)) {
5453 "--quilt=%s specified, implying patches-unapplied git tree\n".
5454 " but git tree differs from orig in upstream files.",
5456 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5457 if (!stat_exists "debian/patches" and $quilt_mode !~ m/baredebian/) {
5459 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5463 if ($quilt_mode =~ m/dpm/ &&
5464 ($diffbits->{H2A} & 01)) {
5465 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5466 --quilt=%s specified, implying patches-applied git tree
5467 but git tree differs from result of applying debian/patches to upstream
5470 if ($quilt_mode =~ m/baredebian/) {
5471 # We need to construct a merge which has upstream files from
5472 # upstream and debian/ files from HEAD.
5474 read_tree_upstream $quilt_upstream_commitish, 1, $headref;
5475 my $version = getfield $clogp, 'Version';
5476 my $upsversion = upstreamversion $version;
5477 my $merge = make_commit
5478 [ $headref, $quilt_upstream_commitish ],
5479 [ +(f_ <<ENDT, $upsversion), $quilt_upstream_commitish_message, <<ENDU ];
5480 Combine debian/ with upstream source for %s
5482 [dgit ($our_version) baredebian-merge $version $quilt_upstream_commitish_used]
5484 runcmd @git, qw(reset -q --hard), $merge;
5486 if ($quilt_mode =~ m/gbp|unapplied|baredebian/ &&
5487 ($diffbits->{O2A} & 01)) { # some patches
5488 progress __ "dgit view: creating patches-applied version using gbp pq";
5489 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5490 # gbp pq import creates a fresh branch; push back to dgit-view
5491 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5492 runcmd @git, qw(checkout -q dgit-view);
5494 if ($quilt_mode =~ m/gbp|dpm/ &&
5495 ($diffbits->{O2A} & 02)) {
5496 fail f_ <<END, $quilt_mode;
5497 --quilt=%s specified, implying that HEAD is for use with a
5498 tool which does not create patches for changes to upstream
5499 .gitignores: but, such patches exist in debian/patches.
5502 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5503 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5505 "dgit view: creating patch to represent .gitignore changes";
5506 ensuredir "debian/patches";
5507 my $gipatch = "debian/patches/auto-gitignore";
5508 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5509 stat GIPATCH or confess "$gipatch: $!";
5510 fail f_ "%s already exists; but want to create it".
5511 " to record .gitignore changes",
5514 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5515 Subject: Update .gitignore from Debian packaging branch
5517 The Debian packaging git branch contains these updates to the upstream
5518 .gitignore file(s). This patch is autogenerated, to provide these
5519 updates to users of the official Debian archive view of the package.
5522 [dgit ($our_version) update-gitignore]
5525 close GIPATCH or die "$gipatch: $!";
5526 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5527 $unapplied, $headref, "--", sort keys %$editedignores;
5528 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5529 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5531 defined read SERIES, $newline, 1 or confess "$!";
5532 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5533 print SERIES "auto-gitignore\n" or confess "$!";
5534 close SERIES or die $!;
5535 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5536 commit_admin +(__ <<END).<<ENDU
5537 Commit patch to update .gitignore
5540 [dgit ($our_version) update-gitignore-quilt-fixup]
5545 sub quiltify ($$$$) {
5546 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5548 # Quilt patchification algorithm
5550 # We search backwards through the history of the main tree's HEAD
5551 # (T) looking for a start commit S whose tree object is identical
5552 # to to the patch tip tree (ie the tree corresponding to the
5553 # current dpkg-committed patch series). For these purposes
5554 # `identical' disregards anything in debian/ - this wrinkle is
5555 # necessary because dpkg-source treates debian/ specially.
5557 # We can only traverse edges where at most one of the ancestors'
5558 # trees differs (in changes outside in debian/). And we cannot
5559 # handle edges which change .pc/ or debian/patches. To avoid
5560 # going down a rathole we avoid traversing edges which introduce
5561 # debian/rules or debian/control. And we set a limit on the
5562 # number of edges we are willing to look at.
5564 # If we succeed, we walk forwards again. For each traversed edge
5565 # PC (with P parent, C child) (starting with P=S and ending with
5566 # C=T) to we do this:
5568 # - dpkg-source --commit with a patch name and message derived from C
5569 # After traversing PT, we git commit the changes which
5570 # should be contained within debian/patches.
5572 # The search for the path S..T is breadth-first. We maintain a
5573 # todo list containing search nodes. A search node identifies a
5574 # commit, and looks something like this:
5576 # Commit => $git_commit_id,
5577 # Child => $c, # or undef if P=T
5578 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5579 # Nontrivial => true iff $p..$c has relevant changes
5586 my %considered; # saves being exponential on some weird graphs
5588 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5591 my ($search,$whynot) = @_;
5592 printdebug " search NOT $search->{Commit} $whynot\n";
5593 $search->{Whynot} = $whynot;
5594 push @nots, $search;
5595 no warnings qw(exiting);
5604 my $c = shift @todo;
5605 next if $considered{$c->{Commit}}++;
5607 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5609 printdebug "quiltify investigate $c->{Commit}\n";
5612 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5613 printdebug " search finished hooray!\n";
5618 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5619 if ($quilt_mode eq 'smash') {
5620 printdebug " search quitting smash\n";
5624 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5625 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5626 if $c_sentinels ne $t_sentinels;
5628 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5629 $commitdata =~ m/\n\n/;
5631 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5632 @parents = map { { Commit => $_, Child => $c } } @parents;
5634 $not->($c, __ "root commit") if !@parents;
5636 foreach my $p (@parents) {
5637 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5639 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5640 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5643 foreach my $p (@parents) {
5644 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5646 my @cmd= (@git, qw(diff-tree -r --name-only),
5647 $p->{Commit},$c->{Commit},
5648 qw(-- debian/patches .pc debian/source/format));
5649 my $patchstackchange = cmdoutput @cmd;
5650 if (length $patchstackchange) {
5651 $patchstackchange =~ s/\n/,/g;
5652 $not->($p, f_ "changed %s", $patchstackchange);
5655 printdebug " search queue P=$p->{Commit} ",
5656 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5662 printdebug "quiltify want to smash\n";
5665 my $x = $_[0]{Commit};
5666 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5669 if ($quilt_mode eq 'linear') {
5671 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5673 my $all_gdr = !!@nots;
5674 foreach my $notp (@nots) {
5675 my $c = $notp->{Child};
5676 my $cprange = $abbrev->($notp);
5677 $cprange .= "..".$abbrev->($c) if $c;
5678 print STDERR f_ "%s: %s: %s\n",
5679 $us, $cprange, $notp->{Whynot};
5680 $all_gdr &&= $notp->{Child} &&
5681 (git_cat_file $notp->{Child}{Commit}, 'commit')
5682 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5686 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5688 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5690 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5691 } elsif ($quilt_mode eq 'smash') {
5692 } elsif ($quilt_mode eq 'auto') {
5693 progress __ "quilt fixup cannot be linear, smashing...";
5695 confess "$quilt_mode ?";
5698 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5699 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5701 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5703 quiltify_dpkg_commit "auto-$version-$target-$time",
5704 (getfield $clogp, 'Maintainer'),
5705 (f_ "Automatically generated patch (%s)\n".
5706 "Last (up to) %s git changes, FYI:\n\n",
5707 $clogp->{Version}, $ncommits).
5712 progress __ "quiltify linearisation planning successful, executing...";
5714 for (my $p = $sref_S;
5715 my $c = $p->{Child};
5717 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5718 next unless $p->{Nontrivial};
5720 my $cc = $c->{Commit};
5722 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5723 $commitdata =~ m/\n\n/ or die "$c ?";
5726 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5729 my $commitdate = cmdoutput
5730 @git, qw(log -n1 --pretty=format:%aD), $cc;
5732 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5734 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5741 my $gbp_check_suitable = sub {
5746 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5747 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5748 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5749 die __ "is series file\n" if m{$series_filename_re}o;
5750 die __ "too long\n" if length > 200;
5752 return $_ unless $@;
5754 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5759 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5761 (\S+) \s* \n //ixm) {
5762 $patchname = $gbp_check_suitable->($1, 'Name');
5764 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5766 (\S+) \s* \n //ixm) {
5767 $patchdir = $gbp_check_suitable->($1, 'Topic');
5772 if (!defined $patchname) {
5773 $patchname = $title;
5774 $patchname =~ s/[.:]$//;
5777 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5778 my $translitname = $converter->convert($patchname);
5779 die unless defined $translitname;
5780 $patchname = $translitname;
5783 +(f_ "dgit: patch title transliteration error: %s", $@)
5785 $patchname =~ y/ A-Z/-a-z/;
5786 $patchname =~ y/-a-z0-9_.+=~//cd;
5787 $patchname =~ s/^\W/x-$&/;
5788 $patchname = substr($patchname,0,40);
5789 $patchname .= ".patch";
5791 if (!defined $patchdir) {
5794 if (length $patchdir) {
5795 $patchname = "$patchdir/$patchname";
5797 if ($patchname =~ m{^(.*)/}) {
5798 mkpath "debian/patches/$1";
5803 stat "debian/patches/$patchname$index";
5805 $!==ENOENT or confess "$patchname$index $!";
5807 runcmd @git, qw(checkout -q), $cc;
5809 # We use the tip's changelog so that dpkg-source doesn't
5810 # produce complaining messages from dpkg-parsechangelog. None
5811 # of the information dpkg-source gets from the changelog is
5812 # actually relevant - it gets put into the original message
5813 # which dpkg-source provides our stunt editor, and then
5815 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5817 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5818 "Date: $commitdate\n".
5819 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5821 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5825 sub build_maybe_quilt_fixup () {
5826 my ($format,$fopts) = get_source_format;
5827 return unless madformat_wantfixup $format;
5830 check_for_vendor_patches();
5832 my $clogp = parsechangelog();
5833 my $headref = git_rev_parse('HEAD');
5834 my $symref = git_get_symref();
5835 my $upstreamversion = upstreamversion $version;
5838 changedir $playground;
5840 my $splitbrain_cachekey;
5842 if (do_split_brain()) {
5844 ($cachehit, $splitbrain_cachekey) =
5845 quilt_check_splitbrain_cache($headref, $upstreamversion);
5852 unpack_playtree_need_cd_work($headref);
5853 if (do_split_brain()) {
5854 runcmd @git, qw(checkout -q -b dgit-view);
5855 # so long as work is not deleted, its current branch will
5856 # remain dgit-view, rather than master, so subsequent calls to
5857 # unpack_playtree_need_cd_work
5858 # will DTRT, resetting dgit-view.
5859 confess if $made_split_brain;
5860 $made_split_brain = 1;
5864 if ($fopts->{'single-debian-patch'}) {
5866 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5868 if quiltmode_splitting();
5869 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5871 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5872 $splitbrain_cachekey);
5875 if (do_split_brain()) {
5876 my $dgitview = git_rev_parse 'HEAD';
5879 reflog_cache_insert "refs/$splitbraincache",
5880 $splitbrain_cachekey, $dgitview;
5882 changedir "$playground/work";
5884 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5885 progress f_ "dgit view: created (%s)", $saved;
5889 runcmd_ordryrun_local
5890 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5893 sub build_check_quilt_splitbrain () {
5894 build_maybe_quilt_fixup();
5897 sub unpack_playtree_need_cd_work ($) {
5900 # prep_ud() must have been called already.
5901 if (!chdir "work") {
5902 # Check in the filesystem because sometimes we run prep_ud
5903 # in between multiple calls to unpack_playtree_need_cd_work.
5904 confess "$!" unless $!==ENOENT;
5905 mkdir "work" or confess "$!";
5907 mktree_in_ud_here();
5909 runcmd @git, qw(reset -q --hard), $headref;
5912 sub unpack_playtree_linkorigs ($$) {
5913 my ($upstreamversion, $fn) = @_;
5914 # calls $fn->($leafname);
5916 my $bpd_abs = bpd_abs();
5918 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5920 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5921 while ($!=0, defined(my $leaf = readdir QFD)) {
5922 my $f = bpd_abs()."/".$leaf;
5924 local ($debuglevel) = $debuglevel-1;
5925 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5927 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5928 printdebug "QF linkorigs $leaf, $f Y\n";
5929 link_ltarget $f, $leaf or die "$leaf $!";
5932 die "$buildproductsdir: $!" if $!;
5936 sub quilt_fixup_delete_pc () {
5937 runcmd @git, qw(rm -rqf .pc);
5938 commit_admin +(__ <<END).<<ENDU
5939 Commit removal of .pc (quilt series tracking data)
5942 [dgit ($our_version) upgrade quilt-remove-pc]
5946 sub quilt_fixup_singlepatch ($$$) {
5947 my ($clogp, $headref, $upstreamversion) = @_;
5949 progress __ "starting quiltify (single-debian-patch)";
5951 # dpkg-source --commit generates new patches even if
5952 # single-debian-patch is in debian/source/options. In order to
5953 # get it to generate debian/patches/debian-changes, it is
5954 # necessary to build the source package.
5956 unpack_playtree_linkorigs($upstreamversion, sub { });
5957 unpack_playtree_need_cd_work($headref);
5959 rmtree("debian/patches");
5961 runcmd @dpkgsource, qw(-b .);
5963 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5964 rename srcfn("$upstreamversion", "/debian/patches"),
5965 "work/debian/patches"
5967 or confess "install d/patches: $!";
5970 commit_quilty_patch();
5973 sub quilt_need_fake_dsc ($) {
5974 # cwd should be playground
5975 my ($upstreamversion) = @_;
5977 return if stat_exists "fake.dsc";
5978 # ^ OK to test this as a sentinel because if we created it
5979 # we must either have done the rest too, or crashed.
5981 my $fakeversion="$upstreamversion-~~DGITFAKE";
5983 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5984 print $fakedsc <<END or confess "$!";
5987 Version: $fakeversion
5991 my $dscaddfile=sub {
5994 my $md = new Digest::MD5;
5996 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5997 stat $fh or confess "$!";
6001 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
6004 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
6006 my @files=qw(debian/source/format debian/rules
6007 debian/control debian/changelog);
6008 foreach my $maybe (qw(debian/patches debian/source/options
6009 debian/tests/control)) {
6010 next unless stat_exists "$maindir/$maybe";
6011 push @files, $maybe;
6014 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
6015 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
6017 $dscaddfile->($debtar);
6018 close $fakedsc or confess "$!";
6021 sub quilt_fakedsc2unapplied ($$) {
6022 my ($headref, $upstreamversion) = @_;
6023 # must be run in the playground
6024 # quilt_need_fake_dsc must have been called
6026 quilt_need_fake_dsc($upstreamversion);
6028 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
6030 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
6031 rename $fakexdir, "fake" or die "$fakexdir $!";
6035 remove_stray_gits(__ "source package");
6036 mktree_in_ud_here();
6040 rmtree 'debian'; # git checkout commitish paths does not delete!
6041 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
6042 my $unapplied=git_add_write_tree();
6043 printdebug "fake orig tree object $unapplied\n";
6047 sub quilt_check_splitbrain_cache ($$) {
6048 my ($headref, $upstreamversion) = @_;
6049 # Called only if we are in (potentially) split brain mode.
6050 # Called in playground.
6051 # Computes the cache key and looks in the cache.
6052 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
6054 quilt_need_fake_dsc($upstreamversion);
6056 my $splitbrain_cachekey;
6059 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
6061 # we look in the reflog of dgit-intern/quilt-cache
6062 # we look for an entry whose message is the key for the cache lookup
6063 my @cachekey = (qw(dgit), $our_version);
6064 push @cachekey, $upstreamversion;
6065 push @cachekey, $quilt_mode;
6066 push @cachekey, $headref;
6067 push @cachekey, $quilt_upstream_commitish // '-';
6069 push @cachekey, hashfile('fake.dsc');
6071 my $srcshash = Digest::SHA->new(256);
6072 my %sfs = ( %INC, '$0(dgit)' => $0 );
6073 foreach my $sfk (sort keys %sfs) {
6074 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6075 $srcshash->add($sfk," ");
6076 $srcshash->add(hashfile($sfs{$sfk}));
6077 $srcshash->add("\n");
6079 push @cachekey, $srcshash->hexdigest();
6080 $splitbrain_cachekey = "@cachekey";
6082 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6084 my $cachehit = reflog_cache_lookup
6085 "refs/$splitbraincache", $splitbrain_cachekey;
6088 unpack_playtree_need_cd_work($headref);
6089 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6090 if ($cachehit ne $headref) {
6091 progress f_ "dgit view: found cached (%s)", $saved;
6092 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6093 $made_split_brain = 1;
6094 return ($cachehit, $splitbrain_cachekey);
6096 progress __ "dgit view: found cached, no changes required";
6097 return ($headref, $splitbrain_cachekey);
6100 printdebug "splitbrain cache miss\n";
6101 return (undef, $splitbrain_cachekey);
6104 sub baredebian_origtarballs_scan ($$$) {
6105 my ($fakedfi, $upstreamversion, $dir) = @_;
6106 if (!opendir OD, $dir) {
6107 return if $! == ENOENT;
6108 fail "opendir $dir (origs): $!";
6111 while ($!=0, defined(my $leaf = readdir OD)) {
6113 local ($debuglevel) = $debuglevel-1;
6114 printdebug "BDOS $dir $leaf ?\n";
6116 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
6117 next if grep { $_->{Filename} eq $leaf } @$fakedfi;
6120 Path => "$dir/$leaf",
6124 die "$dir; $!" if $!;
6128 sub quilt_fixup_multipatch ($$$) {
6129 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6131 progress f_ "examining quilt state (multiple patches, %s mode)",
6135 # - honour any existing .pc in case it has any strangeness
6136 # - determine the git commit corresponding to the tip of
6137 # the patch stack (if there is one)
6138 # - if there is such a git commit, convert each subsequent
6139 # git commit into a quilt patch with dpkg-source --commit
6140 # - otherwise convert all the differences in the tree into
6141 # a single git commit
6145 # Our git tree doesn't necessarily contain .pc. (Some versions of
6146 # dgit would include the .pc in the git tree.) If there isn't
6147 # one, we need to generate one by unpacking the patches that we
6150 # We first look for a .pc in the git tree. If there is one, we
6151 # will use it. (This is not the normal case.)
6153 # Otherwise need to regenerate .pc so that dpkg-source --commit
6154 # can work. We do this as follows:
6155 # 1. Collect all relevant .orig from parent directory
6156 # 2. Generate a debian.tar.gz out of
6157 # debian/{patches,rules,source/format,source/options}
6158 # 3. Generate a fake .dsc containing just these fields:
6159 # Format Source Version Files
6160 # 4. Extract the fake .dsc
6161 # Now the fake .dsc has a .pc directory.
6162 # (In fact we do this in every case, because in future we will
6163 # want to search for a good base commit for generating patches.)
6165 # Then we can actually do the dpkg-source --commit
6166 # 1. Make a new working tree with the same object
6167 # store as our main tree and check out the main
6169 # 2. Copy .pc from the fake's extraction, if necessary
6170 # 3. Run dpkg-source --commit
6171 # 4. If the result has changes to debian/, then
6172 # - git add them them
6173 # - git add .pc if we had a .pc in-tree
6175 # 5. If we had a .pc in-tree, delete it, and git commit
6176 # 6. Back in the main tree, fast forward to the new HEAD
6178 # Another situation we may have to cope with is gbp-style
6179 # patches-unapplied trees.
6181 # We would want to detect these, so we know to escape into
6182 # quilt_fixup_gbp. However, this is in general not possible.
6183 # Consider a package with a one patch which the dgit user reverts
6184 # (with git revert or the moral equivalent).
6186 # That is indistinguishable in contents from a patches-unapplied
6187 # tree. And looking at the history to distinguish them is not
6188 # useful because the user might have made a confusing-looking git
6189 # history structure (which ought to produce an error if dgit can't
6190 # cope, not a silent reintroduction of an unwanted patch).
6192 # So gbp users will have to pass an option. But we can usually
6193 # detect their failure to do so: if the tree is not a clean
6194 # patches-applied tree, quilt linearisation fails, but the tree
6195 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6196 # they want --quilt=unapplied.
6198 # To help detect this, when we are extracting the fake dsc, we
6199 # first extract it with --skip-patches, and then apply the patches
6200 # afterwards with dpkg-source --before-build. That lets us save a
6201 # tree object corresponding to .origs.
6203 if ($quilt_mode eq 'linear'
6204 && branch_is_gdr($headref)) {
6205 # This is much faster. It also makes patches that gdr
6206 # likes better for future updates without laundering.
6208 # However, it can fail in some casses where we would
6209 # succeed: if there are existing patches, which correspond
6210 # to a prefix of the branch, but are not in gbp/gdr
6211 # format, gdr will fail (exiting status 7), but we might
6212 # be able to figure out where to start linearising. That
6213 # will be slower so hopefully there's not much to do.
6215 unpack_playtree_need_cd_work $headref;
6217 my @cmd = (@git_debrebase,
6218 qw(--noop-ok -funclean-mixed -funclean-ordering
6219 make-patches --quiet-would-amend));
6220 # We tolerate soe snags that gdr wouldn't, by default.
6226 and not ($? == 7*256 or
6227 $? == -1 && $!==ENOENT);
6231 $headref = git_rev_parse('HEAD');
6236 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6240 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6242 if (system @bbcmd) {
6243 failedcmd @bbcmd if $? < 0;
6245 failed to apply your git tree's patch stack (from debian/patches/) to
6246 the corresponding upstream tarball(s). Your source tree and .orig
6247 are probably too inconsistent. dgit can only fix up certain kinds of
6248 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6254 unpack_playtree_need_cd_work($headref);
6257 if (stat_exists ".pc") {
6259 progress __ "Tree already contains .pc - will use it then delete it.";
6262 rename '../fake/.pc','.pc' or confess "$!";
6265 changedir '../fake';
6267 my $oldtiptree=git_add_write_tree();
6268 printdebug "fake o+d/p tree object $unapplied\n";
6269 changedir '../work';
6272 # We calculate some guesswork now about what kind of tree this might
6273 # be. This is mostly for error reporting.
6275 my $tentries = cmdoutput @git, qw(ls-tree --name-only -z), $headref;
6276 my $onlydebian = $tentries eq "debian\0";
6278 my $uheadref = $headref;
6279 my $uhead_whatshort = 'HEAD';
6281 if ($quilt_mode =~ m/baredebian\+tarball/) {
6282 # We need to make a tarball import. Yuk.
6283 # We want to do this here so that we have a $uheadref value
6286 baredebian_origtarballs_scan \@fakedfi, $upstreamversion, bpd_abs();
6287 baredebian_origtarballs_scan \@fakedfi, $upstreamversion,
6288 "$maindir/.." unless $buildproductsdir eq '..';
6291 my @tartrees = import_tarball_tartrees $upstreamversion, \@fakedfi;
6293 fail __ "baredebian quilt fixup: could not find any origs"
6297 my ($authline, $r1authline, $clogp,) =
6298 import_tarball_commits \@tartrees, $upstreamversion;
6300 if (@tartrees == 1) {
6301 $uheadref = $tartrees[0]{Commit};
6302 # TRANSLATORS: this translation must fit in the ASCII art
6303 # quilt differences display. The untranslated display
6304 # says %9.9s, so with that display it must be at most 9
6306 $uhead_whatshort = __ 'tarball';
6308 # on .dsc import we do not make a separate commit, but
6309 # here we need to do so
6310 rm_subdir_cached '.';
6312 foreach my $ti (@tartrees) {
6313 my $c = $ti->{Commit};
6314 if ($ti->{OrigPart} eq 'orig') {
6315 runcmd qw(git read-tree), $c;
6316 } elsif ($ti->{OrigPart} =~ m/orig-/) {
6317 read_tree_subdir $', $c;
6319 confess "$ti->OrigPart} ?"
6321 $parents .= "parent $c\n";
6323 my $tree = git_write_tree();
6324 my $mbody = f_ 'Combine orig tarballs for %s %s',
6325 $package, $upstreamversion;
6326 $uheadref = hash_commit_text <<END;
6328 ${parents}author $r1authline
6329 committer $r1authline
6333 [dgit import tarballs combine $package $upstreamversion]
6335 # TRANSLATORS: this translation must fit in the ASCII art
6336 # quilt differences display. The untranslated display
6337 # says %9.9s, so with that display it must be at most 9
6338 # characters. This fragmentt is referring to multiple
6339 # orig tarballs in a source package.
6340 $uhead_whatshort = __ 'tarballs';
6342 runcmd @git, qw(reset -q);
6344 $quilt_upstream_commitish = $uheadref;
6345 $quilt_upstream_commitish_used = '*orig*';
6346 $quilt_upstream_commitish_message = '';
6348 if ($quilt_mode =~ m/baredebian$/) {
6349 $uheadref = $quilt_upstream_commitish;
6350 # TRANSLATORS: this translation must fit in the ASCII art
6351 # quilt differences display. The untranslated display
6352 # says %9.9s, so with that display it must be at most 9
6354 $uhead_whatshort = __ 'upstream';
6361 # O = orig, without patches applied
6362 # A = "applied", ie orig with H's debian/patches applied
6363 O2H => quiltify_trees_differ($unapplied,$uheadref, 1,
6364 \%editedignores, \@unrepres),
6365 H2A => quiltify_trees_differ($uheadref, $oldtiptree,1),
6366 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6370 foreach my $bits (qw(01 02)) {
6371 foreach my $v (qw(O2H O2A H2A)) {
6372 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6375 printdebug "differences \@dl @dl.\n";
6378 "%s: base trees orig=%.20s o+d/p=%.20s",
6379 $us, $unapplied, $oldtiptree;
6380 # TRANSLATORS: Try to keep this ascii-art layout right. The 0s in
6381 # %9.00009s will be ignored and are there to make the format the
6382 # same length (9 characters) as the output it generates. If you
6383 # change the value 9, your translations of "upstream" and
6384 # 'tarball' must fit into the new length, and you should change
6385 # the number of 0s. Do not reduce it below 4 as HEAD has to fit
6388 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6389 "%s: quilt differences: %9.00009s %s o+d/p %9.00009s %s o+d/p",
6390 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6391 $us, $uhead_whatshort, $dl[2], $uhead_whatshort, $dl[5];
6393 if (@unrepres && $quilt_mode !~ m/baredebian/) {
6394 # With baredebian, even if the upstream commitish has this
6395 # problem, we don't want to print this message, as nothing
6396 # is going to try to make a patch out of it anyway.
6397 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6400 forceable_fail [qw(unrepresentable)], __ <<END;
6401 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6407 push @failsuggestion, [ 'onlydebian', __
6408 "This has only a debian/ directory; you probably want --quilt=bare debian." ]
6409 unless $quilt_mode =~ m/baredebian/;
6410 } elsif (!($diffbits->{O2H} & $diffbits->{O2A})) {
6411 push @failsuggestion, [ 'unapplied', __
6412 "This might be a patches-unapplied branch." ];
6413 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6414 push @failsuggestion, [ 'applied', __
6415 "This might be a patches-applied branch." ];
6417 push @failsuggestion, [ 'quilt-mode', __
6418 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6420 push @failsuggestion, [ 'gitattrs', __
6421 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6422 if stat_exists '.gitattributes';
6424 push @failsuggestion, [ 'origs', __
6425 "Maybe orig tarball(s) are not identical to git representation?" ]
6426 unless $onlydebian && $quilt_mode !~ m/baredebian/;
6427 # ^ in that case, we didn't really look properly
6429 if (quiltmode_splitting()) {
6430 quiltify_splitting($clogp, $unapplied, $headref, $oldtiptree,
6431 $diffbits, \%editedignores,
6432 $splitbrain_cachekey);
6436 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6437 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6438 runcmd @git, qw(checkout -q), (qw(master dgit-view)[do_split_brain()]);
6440 if (!open P, '>>', ".pc/applied-patches") {
6441 $!==&ENOENT or confess "$!";
6446 commit_quilty_patch();
6448 if ($mustdeletepc) {
6449 quilt_fixup_delete_pc();
6453 sub quilt_fixup_editor () {
6454 my $descfn = $ENV{$fakeeditorenv};
6455 my $editing = $ARGV[$#ARGV];
6456 open I1, '<', $descfn or confess "$descfn: $!";
6457 open I2, '<', $editing or confess "$editing: $!";
6458 unlink $editing or confess "$editing: $!";
6459 open O, '>', $editing or confess "$editing: $!";
6460 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6463 $copying ||= m/^\-\-\- /;
6464 next unless $copying;
6465 print O or confess "$!";
6467 I2->error and confess "$!";
6472 sub maybe_apply_patches_dirtily () {
6473 return unless $quilt_mode =~ m/gbp|unapplied|baredebian/;
6474 print STDERR __ <<END or confess "$!";
6476 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6477 dgit: Have to apply the patches - making the tree dirty.
6478 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6481 $patches_applied_dirtily = 01;
6482 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6483 runcmd qw(dpkg-source --before-build .);
6486 sub maybe_unapply_patches_again () {
6487 progress __ "dgit: Unapplying patches again to tidy up the tree."
6488 if $patches_applied_dirtily;
6489 runcmd qw(dpkg-source --after-build .)
6490 if $patches_applied_dirtily & 01;
6492 if $patches_applied_dirtily & 02;
6493 $patches_applied_dirtily = 0;
6496 #----- other building -----
6498 sub clean_tree_check_git ($$$) {
6499 my ($honour_ignores, $message, $ignmessage) = @_;
6500 my @cmd = (@git, qw(clean -dn));
6501 push @cmd, qw(-x) unless $honour_ignores;
6502 my $leftovers = cmdoutput @cmd;
6503 if (length $leftovers) {
6504 print STDERR $leftovers, "\n" or confess "$!";
6505 $message .= $ignmessage if $honour_ignores;
6510 sub clean_tree_check_git_wd ($) {
6512 return if $cleanmode =~ m{no-check};
6513 return if $patches_applied_dirtily; # yuk
6514 clean_tree_check_git +($cleanmode !~ m{all-check}),
6515 $message, "\n".__ <<END;
6516 If this is just missing .gitignore entries, use a different clean
6517 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6518 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6522 sub clean_tree_check () {
6523 # This function needs to not care about modified but tracked files.
6524 # That was done by check_not_dirty, and by now we may have run
6525 # the rules clean target which might modify tracked files (!)
6526 if ($cleanmode =~ m{^check}) {
6527 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6528 "tree contains uncommitted files and --clean=check specified", '';
6529 } elsif ($cleanmode =~ m{^dpkg-source}) {
6530 clean_tree_check_git_wd __
6531 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6532 } elsif ($cleanmode =~ m{^git}) {
6533 clean_tree_check_git 1, __
6534 "tree contains uncommited, untracked, unignored files\n".
6535 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6536 } elsif ($cleanmode eq 'none') {
6538 confess "$cleanmode ?";
6543 # We always clean the tree ourselves, rather than leave it to the
6544 # builder (dpkg-source, or soemthing which calls dpkg-source).
6545 if ($quilt_mode =~ m/baredebian/ and $cleanmode =~ m/git/) {
6546 fail f_ <<END, $quilt_mode, $cleanmode;
6547 quilt mode %s (generally needs untracked upstream files)
6548 contradicts clean mode %s (which would delete them)
6550 # This is not 100% true: dgit build-source and push-source
6551 # (for example) could operate just fine with no upstream
6552 # source in the working tree. But it doesn't seem likely that
6553 # the user wants dgit to proactively delete such things.
6554 # -wn, for example, would produce identical output without
6555 # deleting anything from the working tree.
6557 if ($cleanmode =~ m{^dpkg-source}) {
6558 my @cmd = @dpkgbuildpackage;
6559 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6560 push @cmd, qw(-T clean);
6561 maybe_apply_patches_dirtily();
6562 runcmd_ordryrun_local @cmd;
6563 clean_tree_check_git_wd __
6564 "tree contains uncommitted files (after running rules clean)";
6565 } elsif ($cleanmode =~ m{^git(?!-)}) {
6566 runcmd_ordryrun_local @git, qw(clean -xdf);
6567 } elsif ($cleanmode =~ m{^git-ff}) {
6568 runcmd_ordryrun_local @git, qw(clean -xdff);
6569 } elsif ($cleanmode =~ m{^check}) {
6571 } elsif ($cleanmode eq 'none') {
6573 confess "$cleanmode ?";
6578 badusage __ "clean takes no additional arguments" if @ARGV;
6581 maybe_unapply_patches_again();
6584 # return values from massage_dbp_args are one or both of these flags
6585 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6586 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6588 sub build_or_push_prep_early () {
6589 our $build_or_push_prep_early_done //= 0;
6590 return if $build_or_push_prep_early_done++;
6591 my $clogp = parsechangelog();
6592 $isuite = getfield $clogp, 'Distribution';
6593 my $gotpackage = getfield $clogp, 'Source';
6594 $version = getfield $clogp, 'Version';
6595 $package //= $gotpackage;
6596 if ($package ne $gotpackage) {
6597 fail f_ "-p specified package %s, but changelog says %s",
6598 $package, $gotpackage;
6600 $dscfn = dscfn($version);
6603 sub build_or_push_prep_modes () {
6604 my ($format) = get_source_format();
6605 determine_whether_split_brain($format);
6607 fail __ "dgit: --include-dirty is not supported with split view".
6608 " (including with view-splitting quilt modes)"
6609 if do_split_brain() && $includedirty;
6611 if (madformat_wantfixup $format and $quilt_mode =~ m/baredebian$/) {
6612 ($quilt_upstream_commitish, $quilt_upstream_commitish_used,
6613 $quilt_upstream_commitish_message)
6614 = resolve_upstream_version
6615 $quilt_upstream_commitish, upstreamversion $version;
6616 progress f_ "dgit: --quilt=%s, %s", $quilt_mode,
6617 $quilt_upstream_commitish_message;
6618 } elsif (defined $quilt_upstream_commitish) {
6620 "dgit: --upstream-commitish only makes sense with --quilt=baredebian"
6624 sub build_prep_early () {
6625 build_or_push_prep_early();
6627 build_or_push_prep_modes();
6631 sub build_prep ($) {
6635 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6636 # Clean the tree because we're going to use the contents of
6637 # $maindir. (We trying to include dirty changes in the source
6638 # package, or we are running the builder in $maindir.)
6639 || $cleanmode =~ m{always}) {
6640 # Or because the user asked us to.
6643 # We don't actually need to do anything in $maindir, but we
6644 # should do some kind of cleanliness check because (i) the
6645 # user may have forgotten a `git add', and (ii) if the user
6646 # said -wc we should still do the check.
6649 build_check_quilt_splitbrain();
6651 my $pat = changespat $version;
6652 foreach my $f (glob "$buildproductsdir/$pat") {
6655 fail f_ "remove old changes file %s: %s", $f, $!;
6657 progress f_ "would remove %s", $f;
6663 sub changesopts_initial () {
6664 my @opts =@changesopts[1..$#changesopts];
6667 sub changesopts_version () {
6668 if (!defined $changes_since_version) {
6671 @vsns = archive_query('archive_query');
6672 my @quirk = access_quirk();
6673 if ($quirk[0] eq 'backports') {
6674 local $isuite = $quirk[2];
6676 canonicalise_suite();
6677 push @vsns, archive_query('archive_query');
6683 "archive query failed (queried because --since-version not specified)";
6686 @vsns = map { $_->[0] } @vsns;
6687 @vsns = sort { -version_compare($a, $b) } @vsns;
6688 $changes_since_version = $vsns[0];
6689 progress f_ "changelog will contain changes since %s", $vsns[0];
6691 $changes_since_version = '_';
6692 progress __ "package seems new, not specifying -v<version>";
6695 if ($changes_since_version ne '_') {
6696 return ("-v$changes_since_version");
6702 sub changesopts () {
6703 return (changesopts_initial(), changesopts_version());
6706 sub massage_dbp_args ($;$) {
6707 my ($cmd,$xargs) = @_;
6708 # Since we split the source build out so we can do strange things
6709 # to it, massage the arguments to dpkg-buildpackage so that the
6710 # main build doessn't build source (or add an argument to stop it
6711 # building source by default).
6712 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6713 # -nc has the side effect of specifying -b if nothing else specified
6714 # and some combinations of -S, -b, et al, are errors, rather than
6715 # later simply overriding earlie. So we need to:
6716 # - search the command line for these options
6717 # - pick the last one
6718 # - perhaps add our own as a default
6719 # - perhaps adjust it to the corresponding non-source-building version
6721 foreach my $l ($cmd, $xargs) {
6723 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6726 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6727 my $r = WANTSRC_BUILDER;
6728 printdebug "massage split $dmode.\n";
6729 if ($dmode =~ s/^--build=//) {
6731 my @d = split /,/, $dmode;
6732 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6733 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6734 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6735 fail __ "Wanted to build nothing!" unless $r;
6736 $dmode = '--build='. join ',', grep m/./, @d;
6739 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6740 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6741 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6744 printdebug "massage done $r $dmode.\n";
6746 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6752 my $wasdir = must_getcwd();
6753 changedir $buildproductsdir;
6758 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6759 sub postbuild_mergechanges ($) {
6760 my ($msg_if_onlyone) = @_;
6761 # If there is only one .changes file, fail with $msg_if_onlyone,
6762 # or if that is undef, be a no-op.
6763 # Returns the changes file to report to the user.
6764 my $pat = changespat $version;
6765 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6766 @changesfiles = sort {
6767 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6771 if (@changesfiles==1) {
6772 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6773 only one changes file from build (%s)
6775 if defined $msg_if_onlyone;
6776 $result = $changesfiles[0];
6777 } elsif (@changesfiles==2) {
6778 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6779 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6780 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6783 runcmd_ordryrun_local @mergechanges, @changesfiles;
6784 my $multichanges = changespat $version,'multi';
6786 stat_exists $multichanges or fail f_
6787 "%s unexpectedly not created by build", $multichanges;
6788 foreach my $cf (glob $pat) {
6789 next if $cf eq $multichanges;
6790 rename "$cf", "$cf.inmulti" or fail f_
6791 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6794 $result = $multichanges;
6796 fail f_ "wrong number of different changes files (%s)",
6799 printdone f_ "build successful, results in %s\n", $result
6803 sub midbuild_checkchanges () {
6804 my $pat = changespat $version;
6805 return if $rmchanges;
6806 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6808 $_ ne changespat $version,'source' and
6809 $_ ne changespat $version,'multi'
6811 fail +(f_ <<END, $pat, "@unwanted")
6812 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6813 Suggest you delete %s.
6818 sub midbuild_checkchanges_vanilla ($) {
6820 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6823 sub postbuild_mergechanges_vanilla ($) {
6825 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6827 postbuild_mergechanges(undef);
6830 printdone __ "build successful\n";
6836 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6837 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6838 %s: warning: build-products-dir will be ignored; files will go to ..
6840 $buildproductsdir = '..';
6841 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6842 my $wantsrc = massage_dbp_args \@dbp;
6843 build_prep($wantsrc);
6844 if ($wantsrc & WANTSRC_SOURCE) {
6846 midbuild_checkchanges_vanilla $wantsrc;
6848 if ($wantsrc & WANTSRC_BUILDER) {
6849 push @dbp, changesopts_version();
6850 maybe_apply_patches_dirtily();
6851 runcmd_ordryrun_local @dbp;
6853 maybe_unapply_patches_again();
6854 postbuild_mergechanges_vanilla $wantsrc;
6858 $quilt_mode //= 'gbp';
6864 # gbp can make .origs out of thin air. In my tests it does this
6865 # even for a 1.0 format package, with no origs present. So I
6866 # guess it keys off just the version number. We don't know
6867 # exactly what .origs ought to exist, but let's assume that we
6868 # should run gbp if: the version has an upstream part and the main
6870 my $upstreamversion = upstreamversion $version;
6871 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6872 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6874 if ($gbp_make_orig) {
6876 $cleanmode = 'none'; # don't do it again
6879 my @dbp = @dpkgbuildpackage;
6881 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6883 if (!length $gbp_build[0]) {
6884 if (length executable_on_path('git-buildpackage')) {
6885 $gbp_build[0] = qw(git-buildpackage);
6887 $gbp_build[0] = 'gbp buildpackage';
6890 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6892 push @cmd, (qw(-us -uc --git-no-sign-tags),
6893 "--git-builder=".(shellquote @dbp));
6895 if ($gbp_make_orig) {
6896 my $priv = dgit_privdir();
6897 my $ok = "$priv/origs-gen-ok";
6898 unlink $ok or $!==&ENOENT or confess "$!";
6899 my @origs_cmd = @cmd;
6900 push @origs_cmd, qw(--git-cleaner=true);
6901 push @origs_cmd, "--git-prebuild=".
6902 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6903 push @origs_cmd, @ARGV;
6905 debugcmd @origs_cmd;
6907 do { local $!; stat_exists $ok; }
6908 or failedcmd @origs_cmd;
6910 dryrun_report @origs_cmd;
6914 build_prep($wantsrc);
6915 if ($wantsrc & WANTSRC_SOURCE) {
6917 midbuild_checkchanges_vanilla $wantsrc;
6919 push @cmd, '--git-cleaner=true';
6921 maybe_unapply_patches_again();
6922 if ($wantsrc & WANTSRC_BUILDER) {
6923 push @cmd, changesopts();
6924 runcmd_ordryrun_local @cmd, @ARGV;
6926 postbuild_mergechanges_vanilla $wantsrc;
6928 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6930 sub building_source_in_playtree {
6931 # If $includedirty, we have to build the source package from the
6932 # working tree, not a playtree, so that uncommitted changes are
6933 # included (copying or hardlinking them into the playtree could
6936 # Note that if we are building a source package in split brain
6937 # mode we do not support including uncommitted changes, because
6938 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6939 # building a source package)) => !$includedirty
6940 return !$includedirty;
6944 $sourcechanges = changespat $version,'source';
6946 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6947 or fail f_ "remove %s: %s", $sourcechanges, $!;
6949 # confess unless !!$made_split_brain == do_split_brain();
6951 my @cmd = (@dpkgsource, qw(-b --));
6953 if (building_source_in_playtree()) {
6955 my $headref = git_rev_parse('HEAD');
6956 # If we are in split brain, there is already a playtree with
6957 # the thing we should package into a .dsc (thanks to quilt
6958 # fixup). If not, make a playtree
6959 prep_ud() unless $made_split_brain;
6960 changedir $playground;
6961 unless ($made_split_brain) {
6962 my $upstreamversion = upstreamversion $version;
6963 unpack_playtree_linkorigs($upstreamversion, sub { });
6964 unpack_playtree_need_cd_work($headref);
6968 $leafdir = basename $maindir;
6970 if ($buildproductsdir ne '..') {
6971 # Well, we are going to run dpkg-source -b which consumes
6972 # origs from .. and generates output there. To make this
6973 # work when the bpd is not .. , we would have to (i) link
6974 # origs from bpd to .. , (ii) check for files that
6975 # dpkg-source -b would/might overwrite, and afterwards
6976 # (iii) move all the outputs back to the bpd (iv) except
6977 # for the origs which should be deleted from .. if they
6978 # weren't there beforehand. And if there is an error and
6979 # we don't run to completion we would necessarily leave a
6980 # mess. This is too much. The real way to fix this
6981 # is for dpkg-source to have bpd support.
6982 confess unless $includedirty;
6984 "--include-dirty not supported with --build-products-dir, sorry";
6989 runcmd_ordryrun_local @cmd, $leafdir;
6992 runcmd_ordryrun_local qw(sh -ec),
6993 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6994 @dpkggenchanges, qw(-S), changesopts();
6997 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6998 $dsc = parsecontrol($dscfn, "source package");
7002 printdebug " renaming ($why) $l\n";
7003 rename_link_xf 0, "$l", bpd_abs()."/$l"
7004 or fail f_ "put in place new built file (%s): %s", $l, $@;
7006 foreach my $l (split /\n/, getfield $dsc, 'Files') {
7007 $l =~ m/\S+$/ or next;
7010 $mv->('dsc', $dscfn);
7011 $mv->('changes', $sourcechanges);
7016 sub cmd_build_source {
7017 badusage __ "build-source takes no additional arguments" if @ARGV;
7018 build_prep(WANTSRC_SOURCE);
7020 maybe_unapply_patches_again();
7021 printdone f_ "source built, results in %s and %s",
7022 $dscfn, $sourcechanges;
7025 sub cmd_push_source {
7028 "dgit push-source: --include-dirty/--ignore-dirty does not make".
7029 "sense with push-source!"
7031 build_check_quilt_splitbrain();
7033 my $changes = parsecontrol("$buildproductsdir/$changesfile",
7034 __ "source changes file");
7035 unless (test_source_only_changes($changes)) {
7036 fail __ "user-specified changes file is not source-only";
7039 # Building a source package is very fast, so just do it
7041 confess "er, patches are applied dirtily but shouldn't be.."
7042 if $patches_applied_dirtily;
7043 $changesfile = $sourcechanges;
7048 sub binary_builder {
7049 my ($bbuilder, $pbmc_msg, @args) = @_;
7050 build_prep(WANTSRC_SOURCE);
7052 midbuild_checkchanges();
7055 stat_exists $dscfn or fail f_
7056 "%s (in build products dir): %s", $dscfn, $!;
7057 stat_exists $sourcechanges or fail f_
7058 "%s (in build products dir): %s", $sourcechanges, $!;
7060 runcmd_ordryrun_local @$bbuilder, @args;
7062 maybe_unapply_patches_again();
7064 postbuild_mergechanges($pbmc_msg);
7070 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
7071 perhaps you need to pass -A ? (sbuild's default is to build only
7072 arch-specific binaries; dgit 1.4 used to override that.)
7077 my ($pbuilder) = @_;
7079 # @ARGV is allowed to contain only things that should be passed to
7080 # pbuilder under debbuildopts; just massage those
7081 my $wantsrc = massage_dbp_args \@ARGV;
7083 "you asked for a builder but your debbuildopts didn't ask for".
7084 " any binaries -- is this really what you meant?"
7085 unless $wantsrc & WANTSRC_BUILDER;
7087 "we must build a .dsc to pass to the builder but your debbuiltopts".
7088 " forbids the building of a source package; cannot continue"
7089 unless $wantsrc & WANTSRC_SOURCE;
7090 # We do not want to include the verb "build" in @pbuilder because
7091 # the user can customise @pbuilder and they shouldn't be required
7092 # to include "build" in their customised value. However, if the
7093 # user passes any additional args to pbuilder using the dgit
7094 # option --pbuilder:foo, such args need to come after the "build"
7095 # verb. opts_opt_multi_cmd does all of that.
7096 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
7097 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
7102 pbuilder(\@pbuilder);
7105 sub cmd_cowbuilder {
7106 pbuilder(\@cowbuilder);
7109 sub cmd_quilt_fixup {
7110 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
7113 build_maybe_quilt_fixup();
7116 sub cmd_print_unapplied_treeish {
7117 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
7119 my $headref = git_rev_parse('HEAD');
7120 my $clogp = commit_getclogp $headref;
7121 $package = getfield $clogp, 'Source';
7122 $version = getfield $clogp, 'Version';
7123 $isuite = getfield $clogp, 'Distribution';
7124 $csuite = $isuite; # we want this to be offline!
7128 changedir $playground;
7129 my $uv = upstreamversion $version;
7130 my $u = quilt_fakedsc2unapplied($headref, $uv);
7131 print $u, "\n" or confess "$!";
7134 sub import_dsc_result {
7135 my ($dstref, $newhash, $what_log, $what_msg) = @_;
7136 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
7138 check_gitattrs($newhash, __ "source tree");
7140 progress f_ "dgit: import-dsc: %s", $what_msg;
7143 sub cmd_import_dsc {
7147 last unless $ARGV[0] =~ m/^-/;
7150 if (m/^--require-valid-signature$/) {
7153 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
7157 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
7159 my ($dscfn, $dstbranch) = @ARGV;
7161 badusage __ "dry run makes no sense with import-dsc"
7164 my $force = $dstbranch =~ s/^\+// ? +1 :
7165 $dstbranch =~ s/^\.\.// ? -1 :
7167 my $info = $force ? " $&" : '';
7168 $info = "$dscfn$info";
7170 my $specbranch = $dstbranch;
7171 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
7172 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
7174 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
7175 my $chead = cmdoutput_errok @symcmd;
7176 defined $chead or $?==256 or failedcmd @symcmd;
7178 fail f_ "%s is checked out - will not update it", $dstbranch
7179 if defined $chead and $chead eq $dstbranch;
7181 my $oldhash = git_get_ref $dstbranch;
7183 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
7184 $dscdata = do { local $/ = undef; <D>; };
7185 D->error and fail f_ "read %s: %s", $dscfn, $!;
7188 # we don't normally need this so import it here
7189 use Dpkg::Source::Package;
7190 my $dp = new Dpkg::Source::Package filename => $dscfn,
7191 require_valid_signature => $needsig;
7193 local $SIG{__WARN__} = sub {
7195 return unless $needsig;
7196 fail __ "import-dsc signature check failed";
7198 if (!$dp->is_signed()) {
7199 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
7201 my $r = $dp->check_signature();
7202 confess "->check_signature => $r" if $needsig && $r;
7208 $package = getfield $dsc, 'Source';
7210 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
7211 unless forceing [qw(import-dsc-with-dgit-field)];
7212 parse_dsc_field_def_dsc_distro();
7214 $isuite = 'DGIT-IMPORT-DSC';
7215 $idistro //= $dsc_distro;
7219 if (defined $dsc_hash) {
7221 "dgit: import-dsc of .dsc with Dgit field, using git hash";
7222 resolve_dsc_field_commit undef, undef;
7224 if (defined $dsc_hash) {
7225 my @cmd = (qw(sh -ec),
7226 "echo $dsc_hash | git cat-file --batch-check");
7227 my $objgot = cmdoutput @cmd;
7228 if ($objgot =~ m#^\w+ missing\b#) {
7229 fail f_ <<END, $dsc_hash
7230 .dsc contains Dgit field referring to object %s
7231 Your git tree does not have that object. Try `git fetch' from a
7232 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
7235 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
7237 progress __ "Not fast forward, forced update.";
7239 fail f_ "Not fast forward to %s", $dsc_hash;
7242 import_dsc_result $dstbranch, $dsc_hash,
7243 "dgit import-dsc (Dgit): $info",
7244 f_ "updated git ref %s", $dstbranch;
7248 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7249 Branch %s already exists
7250 Specify ..%s for a pseudo-merge, binding in existing history
7251 Specify +%s to overwrite, discarding existing history
7253 if $oldhash && !$force;
7255 my @dfi = dsc_files_info();
7256 foreach my $fi (@dfi) {
7257 my $f = $fi->{Filename};
7258 # We transfer all the pieces of the dsc to the bpd, not just
7259 # origs. This is by analogy with dgit fetch, which wants to
7260 # keep them somewhere to avoid downloading them again.
7261 # We make symlinks, though. If the user wants copies, then
7262 # they can copy the parts of the dsc to the bpd using dcmd,
7264 my $here = "$buildproductsdir/$f";
7269 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7271 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7272 printdebug "not in bpd, $f ...\n";
7273 # $f does not exist in bpd, we need to transfer it
7275 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7276 # $there is file we want, relative to user's cwd, or abs
7277 printdebug "not in bpd, $f, test $there ...\n";
7278 stat $there or fail f_
7279 "import %s requires %s, but: %s", $dscfn, $there, $!;
7280 if ($there =~ m#^(?:\./+)?\.\./+#) {
7281 # $there is relative to user's cwd
7282 my $there_from_parent = $';
7283 if ($buildproductsdir !~ m{^/}) {
7284 # abs2rel, despite its name, can take two relative paths
7285 $there = File::Spec->abs2rel($there,$buildproductsdir);
7286 # now $there is relative to bpd, great
7287 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7289 $there = (dirname $maindir)."/$there_from_parent";
7290 # now $there is absoute
7291 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7293 } elsif ($there =~ m#^/#) {
7294 # $there is absolute already
7295 printdebug "not in bpd, $f, abs, $there ...\n";
7298 "cannot import %s which seems to be inside working tree!",
7301 symlink $there, $here or fail f_
7302 "symlink %s to %s: %s", $there, $here, $!;
7303 progress f_ "made symlink %s -> %s", $here, $there;
7304 # print STDERR Dumper($fi);
7306 my @mergeinputs = generate_commits_from_dsc();
7307 die unless @mergeinputs == 1;
7309 my $newhash = $mergeinputs[0]{Commit};
7314 "Import, forced update - synthetic orphan git history.";
7315 } elsif ($force < 0) {
7316 progress __ "Import, merging.";
7317 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7318 my $version = getfield $dsc, 'Version';
7319 my $clogp = commit_getclogp $newhash;
7320 my $authline = clogp_authline $clogp;
7321 $newhash = hash_commit_text <<ENDU
7329 .(f_ <<END, $package, $version, $dstbranch);
7330 Merge %s (%s) import into %s
7333 die; # caught earlier
7337 import_dsc_result $dstbranch, $newhash,
7338 "dgit import-dsc: $info",
7339 f_ "results are in git ref %s", $dstbranch;
7342 sub pre_archive_api_query () {
7343 not_necessarily_a_tree();
7345 sub cmd_archive_api_query {
7346 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7347 my ($subpath) = @ARGV;
7348 local $isuite = 'DGIT-API-QUERY-CMD';
7349 my @cmd = archive_api_query_cmd($subpath);
7352 exec @cmd or fail f_ "exec curl: %s\n", $!;
7355 sub repos_server_url () {
7356 $package = '_dgit-repos-server';
7357 local $access_forpush = 1;
7358 local $isuite = 'DGIT-REPOS-SERVER';
7359 my $url = access_giturl();
7362 sub pre_clone_dgit_repos_server () {
7363 not_necessarily_a_tree();
7365 sub cmd_clone_dgit_repos_server {
7366 badusage __ "need destination argument" unless @ARGV==1;
7367 my ($destdir) = @ARGV;
7368 my $url = repos_server_url();
7369 my @cmd = (@git, qw(clone), $url, $destdir);
7371 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7374 sub pre_print_dgit_repos_server_source_url () {
7375 not_necessarily_a_tree();
7377 sub cmd_print_dgit_repos_server_source_url {
7379 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7381 my $url = repos_server_url();
7382 print $url, "\n" or confess "$!";
7385 sub pre_print_dpkg_source_ignores {
7386 not_necessarily_a_tree();
7388 sub cmd_print_dpkg_source_ignores {
7390 "no arguments allowed to dgit print-dpkg-source-ignores"
7392 print "@dpkg_source_ignores\n" or confess "$!";
7395 sub cmd_setup_mergechangelogs {
7396 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7398 local $isuite = 'DGIT-SETUP-TREE';
7399 setup_mergechangelogs(1);
7402 sub cmd_setup_useremail {
7403 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7404 local $isuite = 'DGIT-SETUP-TREE';
7408 sub cmd_setup_gitattributes {
7409 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7410 local $isuite = 'DGIT-SETUP-TREE';
7414 sub cmd_setup_new_tree {
7415 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7416 local $isuite = 'DGIT-SETUP-TREE';
7420 #---------- argument parsing and main program ----------
7423 print "dgit version $our_version\n" or confess "$!";
7427 our (%valopts_long, %valopts_short);
7428 our (%funcopts_long);
7430 our (@modeopt_cfgs);
7432 sub defvalopt ($$$$) {
7433 my ($long,$short,$val_re,$how) = @_;
7434 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7435 $valopts_long{$long} = $oi;
7436 $valopts_short{$short} = $oi;
7437 # $how subref should:
7438 # do whatever assignemnt or thing it likes with $_[0]
7439 # if the option should not be passed on to remote, @rvalopts=()
7440 # or $how can be a scalar ref, meaning simply assign the value
7443 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7444 defvalopt '--distro', '-d', '.+', \$idistro;
7445 defvalopt '', '-k', '.+', \$keyid;
7446 defvalopt '--existing-package','', '.*', \$existing_package;
7447 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7448 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7449 defvalopt '--package', '-p', $package_re, \$package;
7450 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7452 defvalopt '', '-C', '.+', sub {
7453 ($changesfile) = (@_);
7454 if ($changesfile =~ s#^(.*)/##) {
7455 $buildproductsdir = $1;
7459 defvalopt '--initiator-tempdir','','.*', sub {
7460 ($initiator_tempdir) = (@_);
7461 $initiator_tempdir =~ m#^/# or
7462 badusage __ "--initiator-tempdir must be used specify an".
7463 " absolute, not relative, directory."
7466 sub defoptmodes ($@) {
7467 my ($varref, $cfgkey, $default, %optmap) = @_;
7469 while (my ($opt,$val) = each %optmap) {
7470 $funcopts_long{$opt} = sub { $$varref = $val; };
7471 $permit{$val} = $val;
7473 push @modeopt_cfgs, {
7476 Default => $default,
7481 defoptmodes \$dodep14tag, qw( dep14tag want
7484 --always-dep14tag always );
7489 if (defined $ENV{'DGIT_SSH'}) {
7490 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7491 } elsif (defined $ENV{'GIT_SSH'}) {
7492 @ssh = ($ENV{'GIT_SSH'});
7500 if (!defined $val) {
7501 badusage f_ "%s needs a value", $what unless @ARGV;
7503 push @rvalopts, $val;
7505 badusage f_ "bad value \`%s' for %s", $val, $what unless
7506 $val =~ m/^$oi->{Re}$(?!\n)/s;
7507 my $how = $oi->{How};
7508 if (ref($how) eq 'SCALAR') {
7513 push @ropts, @rvalopts;
7517 last unless $ARGV[0] =~ m/^-/;
7521 if (m/^--dry-run$/) {
7524 } elsif (m/^--damp-run$/) {
7527 } elsif (m/^--no-sign$/) {
7530 } elsif (m/^--help$/) {
7532 } elsif (m/^--version$/) {
7534 } elsif (m/^--new$/) {
7537 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7538 ($om = $opts_opt_map{$1}) &&
7542 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7543 !$opts_opt_cmdonly{$1} &&
7544 ($om = $opts_opt_map{$1})) {
7547 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7548 !$opts_opt_cmdonly{$1} &&
7549 ($om = $opts_opt_map{$1})) {
7551 my $cmd = shift @$om;
7552 @$om = ($cmd, grep { $_ ne $2 } @$om);
7553 } elsif (m/^--($quilt_options_re)$/s) {
7554 push @ropts, "--quilt=$1";
7556 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7559 } elsif (m/^--no-quilt-fixup$/s) {
7561 $quilt_mode = 'nocheck';
7562 } elsif (m/^--no-rm-on-error$/s) {
7565 } elsif (m/^--no-chase-dsc-distro$/s) {
7567 $chase_dsc_distro = 0;
7568 } elsif (m/^--overwrite$/s) {
7570 $overwrite_version = '';
7571 } elsif (m/^--split-(?:view|brain)$/s) {
7573 $splitview_mode = 'always';
7574 } elsif (m/^--split-(?:view|brain)=($splitview_modes_re)$/s) {
7576 $splitview_mode = $1;
7577 } elsif (m/^--overwrite=(.+)$/s) {
7579 $overwrite_version = $1;
7580 } elsif (m/^--delayed=(\d+)$/s) {
7583 } elsif (m/^--upstream-commitish=(.+)$/s) {
7585 $quilt_upstream_commitish = $1;
7586 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7587 m/^--(dgit-view)-save=(.+)$/s
7589 my ($k,$v) = ($1,$2);
7591 $v =~ s#^(?!refs/)#refs/heads/#;
7592 $internal_object_save{$k} = $v;
7593 } elsif (m/^--(no-)?rm-old-changes$/s) {
7596 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7598 push @deliberatelies, $&;
7599 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7603 } elsif (m/^--force-/) {
7605 f_ "%s: warning: ignoring unknown force option %s\n",
7608 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7609 # undocumented, for testing
7611 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7612 # ^ it's supposed to be an array ref
7613 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7614 $val = $2 ? $' : undef; #';
7615 $valopt->($oi->{Long});
7616 } elsif ($funcopts_long{$_}) {
7618 $funcopts_long{$_}();
7620 badusage f_ "unknown long option \`%s'", $_;
7627 } elsif (s/^-L/-/) {
7630 } elsif (s/^-h/-/) {
7632 } elsif (s/^-D/-/) {
7636 } elsif (s/^-N/-/) {
7641 push @changesopts, $_;
7643 } elsif (s/^-wn$//s) {
7645 $cleanmode = 'none';
7646 } elsif (s/^-wg(f?)(a?)$//s) {
7649 $cleanmode .= '-ff' if $1;
7650 $cleanmode .= ',always' if $2;
7651 } elsif (s/^-wd(d?)([na]?)$//s) {
7653 $cleanmode = 'dpkg-source';
7654 $cleanmode .= '-d' if $1;
7655 $cleanmode .= ',no-check' if $2 eq 'n';
7656 $cleanmode .= ',all-check' if $2 eq 'a';
7657 } elsif (s/^-wc$//s) {
7659 $cleanmode = 'check';
7660 } elsif (s/^-wci$//s) {
7662 $cleanmode = 'check,ignores';
7663 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7664 push @git, '-c', $&;
7665 $gitcfgs{cmdline}{$1} = [ $2 ];
7666 } elsif (s/^-c([^=]+)$//s) {
7667 push @git, '-c', $&;
7668 $gitcfgs{cmdline}{$1} = [ 'true' ];
7669 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7671 $val = undef unless length $val;
7672 $valopt->($oi->{Short});
7675 badusage f_ "unknown short option \`%s'", $_;
7682 sub check_env_sanity () {
7683 my $blocked = new POSIX::SigSet;
7684 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7687 foreach my $name (qw(PIPE CHLD)) {
7688 my $signame = "SIG$name";
7689 my $signum = eval "POSIX::$signame" // die;
7690 die f_ "%s is set to something other than SIG_DFL\n",
7692 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7693 $blocked->ismember($signum) and
7694 die f_ "%s is blocked\n", $signame;
7700 On entry to dgit, %s
7701 This is a bug produced by something in your execution environment.
7707 sub parseopts_late_defaults () {
7708 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7709 if defined $idistro;
7710 $isuite //= cfg('dgit.default.default-suite');
7712 foreach my $k (keys %opts_opt_map) {
7713 my $om = $opts_opt_map{$k};
7715 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7717 badcfg f_ "cannot set command for %s", $k
7718 unless length $om->[0];
7722 foreach my $c (access_cfg_cfgs("opts-$k")) {
7724 map { $_ ? @$_ : () }
7725 map { $gitcfgs{$_}{$c} }
7726 reverse @gitcfgsources;
7727 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7728 "\n" if $debuglevel >= 4;
7730 badcfg f_ "cannot configure options for %s", $k
7731 if $opts_opt_cmdonly{$k};
7732 my $insertpos = $opts_cfg_insertpos{$k};
7733 @$om = ( @$om[0..$insertpos-1],
7735 @$om[$insertpos..$#$om] );
7739 if (!defined $rmchanges) {
7740 local $access_forpush;
7741 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7744 if (!defined $quilt_mode) {
7745 local $access_forpush;
7746 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7747 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7749 $quilt_mode =~ m/^($quilt_modes_re)$/
7750 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7753 $quilt_mode =~ s/^(baredebian)\+git$/$1/;
7755 foreach my $moc (@modeopt_cfgs) {
7756 local $access_forpush;
7757 my $vr = $moc->{Var};
7758 next if defined $$vr;
7759 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7760 my $v = $moc->{Vals}{$$vr};
7761 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7767 local $access_forpush;
7768 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7772 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7773 $buildproductsdir //= '..';
7774 $bpd_glob = $buildproductsdir;
7775 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7778 setlocale(LC_MESSAGES, "");
7781 if ($ENV{$fakeeditorenv}) {
7783 quilt_fixup_editor();
7789 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7790 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7791 if $dryrun_level == 1;
7793 print STDERR __ $helpmsg or confess "$!";
7796 $cmd = $subcommand = shift @ARGV;
7799 my $pre_fn = ${*::}{"pre_$cmd"};
7800 $pre_fn->() if $pre_fn;
7802 if ($invoked_in_git_tree) {
7803 changedir_git_toplevel();
7808 my $fn = ${*::}{"cmd_$cmd"};
7809 $fn or badusage f_ "unknown operation %s", $cmd;