3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2018 Ian Jackson
6 # Copyright (C)2017-2018 Sean Whitton
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
22 use Debian::Dgit::ExitStatus;
23 use Debian::Dgit::I18n;
27 use Debian::Dgit qw(:DEFAULT :playground);
33 use Dpkg::Control::Hash;
36 use File::Temp qw(tempdir);
39 use Dpkg::Compression;
40 use Dpkg::Compression::Process;
46 use List::MoreUtils qw(pairwise);
47 use Text::Glob qw(match_glob);
48 use Fcntl qw(:DEFAULT :flock);
53 our $our_version = 'UNRELEASED'; ###substituted###
54 our $absurdity = undef; ###substituted###
56 our @rpushprotovsn_support = qw(4 5); # 5 drops tag format specification
67 our $dryrun_level = 0;
69 our $buildproductsdir;
72 our $includedirty = 0;
76 our $existing_package = 'dpkg';
78 our $changes_since_version;
80 our $overwrite_version; # undef: not specified; '': check changelog
82 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
84 our %internal_object_save;
85 our $we_are_responder;
86 our $we_are_initiator;
87 our $initiator_tempdir;
88 our $patches_applied_dirtily = 00;
89 our $chase_dsc_distro=1;
91 our %forceopts = map { $_=>0 }
92 qw(unrepresentable unsupported-source-format
93 dsc-changes-mismatch changes-origs-exactly
94 uploading-binaries uploading-source-only
95 import-gitapply-absurd
96 import-gitapply-no-absurd
97 import-dsc-with-dgit-field);
99 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
101 our $suite_re = '[-+.0-9a-z]+';
102 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
103 | (?: git | git-ff ) (?: ,always )?
104 | check (?: ,ignores )?
108 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
109 our $splitbraincache = 'dgit-intern/quilt-cache';
110 our $rewritemap = 'dgit-rewrite/map';
112 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
114 our (@git) = qw(git);
115 our (@dget) = qw(dget);
116 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
117 our (@dput) = qw(dput);
118 our (@debsign) = qw(debsign);
119 our (@gpg) = qw(gpg);
120 our (@sbuild) = (qw(sbuild --no-source));
122 our (@dgit) = qw(dgit);
123 our (@git_debrebase) = qw(git-debrebase);
124 our (@aptget) = qw(apt-get);
125 our (@aptcache) = qw(apt-cache);
126 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
127 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
128 our (@dpkggenchanges) = qw(dpkg-genchanges);
129 our (@mergechanges) = qw(mergechanges -f);
130 our (@gbp_build) = ('');
131 our (@gbp_pq) = ('gbp pq');
132 our (@changesopts) = ('');
133 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
134 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
136 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
139 'debsign' => \@debsign,
141 'sbuild' => \@sbuild,
145 'git-debrebase' => \@git_debrebase,
146 'apt-get' => \@aptget,
147 'apt-cache' => \@aptcache,
148 'dpkg-source' => \@dpkgsource,
149 'dpkg-buildpackage' => \@dpkgbuildpackage,
150 'dpkg-genchanges' => \@dpkggenchanges,
151 'gbp-build' => \@gbp_build,
152 'gbp-pq' => \@gbp_pq,
153 'ch' => \@changesopts,
154 'mergechanges' => \@mergechanges,
155 'pbuilder' => \@pbuilder,
156 'cowbuilder' => \@cowbuilder);
158 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
159 our %opts_cfg_insertpos = map {
161 scalar @{ $opts_opt_map{$_} }
162 } keys %opts_opt_map;
164 sub parseopts_late_defaults();
165 sub quiltify_trees_differ ($$;$$$);
166 sub setup_gitattrs(;$);
167 sub check_gitattrs($$);
174 our $supplementary_message = '';
175 our $made_split_brain = 0;
176 our $do_split_brain = 0;
178 # Interactions between quilt mode and split brain
179 # (currently, split brain only implemented iff
180 # madformat_wantfixup && quiltmode_splitbrain)
182 # source format sane `3.0 (quilt)'
183 # madformat_wantfixup()
185 # quilt mode normal quiltmode
186 # (eg linear) _splitbrain
188 # ------------ ------------------------------------------------
190 # no split no q cache no q cache forbidden,
191 # brain PM on master q fixup on master prevented
192 # !$do_split_brain PM on master
194 # split brain no q cache q fixup cached, to dgit view
195 # PM in dgit view PM in dgit view
197 # PM = pseudomerge to make ff, due to overwrite (or split view)
198 # "no q cache" = do not record in cache on build, do not check cache
199 # `3.0 (quilt)' with --quilt=nocheck is treated as sane format
203 return unless forkcheck_mainprocess();
204 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
207 our $remotename = 'dgit';
208 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
212 if (!defined $absurdity) {
214 $absurdity =~ s{/[^/]+$}{/absurd} or die;
217 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
219 sub lbranch () { return "$branchprefix/$csuite"; }
220 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
221 sub lref () { return "refs/heads/".lbranch(); }
222 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
223 sub rrref () { return server_ref($csuite); }
226 my ($vsn, $sfx) = @_;
227 return &source_file_leafname($package, $vsn, $sfx);
229 sub is_orig_file_of_vsn ($$) {
230 my ($f, $upstreamvsn) = @_;
231 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
236 return srcfn($vsn,".dsc");
239 sub changespat ($;$) {
240 my ($vsn, $arch) = @_;
241 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
250 return unless forkcheck_mainprocess();
251 foreach my $f (@end) {
253 print STDERR "$us: cleanup: $@" if length $@;
258 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
262 sub forceable_fail ($$) {
263 my ($forceoptsl, $msg) = @_;
264 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
265 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
269 my ($forceoptsl) = @_;
270 my @got = grep { $forceopts{$_} } @$forceoptsl;
271 return 0 unless @got;
273 "warning: skipping checks or functionality due to --force-%s\n",
277 sub no_such_package () {
278 print STDERR f_ "%s: source package %s does not exist in suite %s\n",
279 $us, $package, $isuite;
283 sub deliberately ($) {
285 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
288 sub deliberately_not_fast_forward () {
289 foreach (qw(not-fast-forward fresh-repo)) {
290 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
294 sub quiltmode_splitbrain () {
295 $quilt_mode =~ m/gbp|dpm|unapplied/;
298 sub opts_opt_multi_cmd {
301 push @cmd, split /\s+/, shift @_;
308 return opts_opt_multi_cmd [], @gbp_pq;
311 sub dgit_privdir () {
312 our $dgit_privdir_made //= ensure_a_playground 'dgit';
316 my $r = $buildproductsdir;
317 $r = "$maindir/$r" unless $r =~ m{^/};
321 sub get_tree_of_commit ($) {
322 my ($commitish) = @_;
323 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
324 $cdata =~ m/\n\n/; $cdata = $`;
325 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
329 sub branch_gdr_info ($$) {
330 my ($symref, $head) = @_;
331 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
332 gdr_ffq_prev_branchinfo($symref);
333 return () unless $status eq 'branch';
334 $ffq_prev = git_get_ref $ffq_prev;
335 $gdrlast = git_get_ref $gdrlast;
336 $gdrlast &&= is_fast_fwd $gdrlast, $head;
337 return ($ffq_prev, $gdrlast);
340 sub branch_is_gdr_unstitched_ff ($$$) {
341 my ($symref, $head, $ancestor) = @_;
342 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
343 return 0 unless $ffq_prev;
344 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
348 sub branch_is_gdr ($) {
350 # This is quite like git-debrebase's keycommits.
351 # We have our own implementation because:
352 # - our algorighm can do fewer tests so is faster
353 # - it saves testing to see if gdr is installed
355 # NB we use this jsut for deciding whether to run gdr make-patches
356 # Before reusing this algorithm for somthing else, its
357 # suitability should be reconsidered.
360 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
361 printdebug "branch_is_gdr $head...\n";
362 my $get_patches = sub {
363 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
366 my $tip_patches = $get_patches->($head);
369 my $cdata = git_cat_file $walk, 'commit';
370 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
371 if ($msg =~ m{^\[git-debrebase\ (
372 anchor | changelog | make-patches |
373 merged-breakwater | pseudomerge
375 # no need to analyse this - it's sufficient
376 # (gdr classifications: Anchor, MergedBreakwaters)
377 # (made by gdr: Pseudomerge, Changelog)
378 printdebug "branch_is_gdr $walk gdr $1 YES\n";
381 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
383 my $walk_tree = get_tree_of_commit $walk;
384 foreach my $p (@parents) {
385 my $p_tree = get_tree_of_commit $p;
386 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
387 # (gdr classification: Pseudomerge; not made by gdr)
388 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
394 # some other non-gdr merge
395 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
396 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
400 # (gdr classification: ?)
401 printdebug "branch_is_gdr $walk ?-octopus NO\n";
405 printdebug "branch_is_gdr $walk origin\n";
408 if ($get_patches->($walk) ne $tip_patches) {
409 # Our parent added, removed, or edited patches, and wasn't
410 # a gdr make-patches commit. gdr make-patches probably
411 # won't do that well, then.
412 # (gdr classification of parent: AddPatches or ?)
413 printdebug "branch_is_gdr $walk ?-patches NO\n";
416 if ($tip_patches eq '' and
417 !defined git_cat_file "$walk~:debian" and
418 !quiltify_trees_differ "$walk~", $walk
420 # (gdr classification of parent: BreakwaterStart
421 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
424 # (gdr classification: Upstream Packaging Mixed Changelog)
425 printdebug "branch_is_gdr $walk plain\n"
431 #---------- remote protocol support, common ----------
433 # remote push initiator/responder protocol:
434 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
435 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
436 # < dgit-remote-push-ready <actual-proto-vsn>
443 # > supplementary-message NBYTES
448 # > file parsed-changelog
449 # [indicates that output of dpkg-parsechangelog follows]
450 # > data-block NBYTES
451 # > [NBYTES bytes of data (no newline)]
452 # [maybe some more blocks]
461 # > param head DGIT-VIEW-HEAD
462 # > param csuite SUITE
463 # > param tagformat new # $protovsn == 4
464 # > param maint-view MAINT-VIEW-HEAD
466 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
467 # > file buildinfo # for buildinfos to sign
469 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
470 # # goes into tag, for replay prevention
473 # [indicates that signed tag is wanted]
474 # < data-block NBYTES
475 # < [NBYTES bytes of data (no newline)]
476 # [maybe some more blocks]
480 # > want signed-dsc-changes
481 # < data-block NBYTES [transfer of signed dsc]
483 # < data-block NBYTES [transfer of signed changes]
485 # < data-block NBYTES [transfer of each signed buildinfo
486 # [etc] same number and order as "file buildinfo"]
494 sub i_child_report () {
495 # Sees if our child has died, and reap it if so. Returns a string
496 # describing how it died if it failed, or undef otherwise.
497 return undef unless $i_child_pid;
498 my $got = waitpid $i_child_pid, WNOHANG;
499 return undef if $got <= 0;
500 die unless $got == $i_child_pid;
501 $i_child_pid = undef;
502 return undef unless $?;
503 return f_ "build host child %s", waitstatusmsg();
508 fail f_ "connection lost: %s", $! if $fh->error;
509 fail f_ "protocol violation; %s not expected", $m;
512 sub badproto_badread ($$) {
514 fail f_ "connection lost: %s", $! if $!;
515 my $report = i_child_report();
516 fail $report if defined $report;
517 badproto $fh, f_ "eof (reading %s)", $wh;
520 sub protocol_expect (&$) {
521 my ($match, $fh) = @_;
524 defined && chomp or badproto_badread $fh, __ "protocol message";
532 badproto $fh, f_ "\`%s'", $_;
535 sub protocol_send_file ($$) {
536 my ($fh, $ourfn) = @_;
537 open PF, "<", $ourfn or die "$ourfn: $!";
540 my $got = read PF, $d, 65536;
541 die "$ourfn: $!" unless defined $got;
543 print $fh "data-block ".length($d)."\n" or confess "$!";
544 print $fh $d or confess "$!";
546 PF->error and die "$ourfn $!";
547 print $fh "data-end\n" or confess "$!";
551 sub protocol_read_bytes ($$) {
552 my ($fh, $nbytes) = @_;
553 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
555 my $got = read $fh, $d, $nbytes;
556 $got==$nbytes or badproto_badread $fh, __ "data block";
560 sub protocol_receive_file ($$) {
561 my ($fh, $ourfn) = @_;
562 printdebug "() $ourfn\n";
563 open PF, ">", $ourfn or die "$ourfn: $!";
565 my ($y,$l) = protocol_expect {
566 m/^data-block (.*)$/ ? (1,$1) :
567 m/^data-end$/ ? (0,) :
571 my $d = protocol_read_bytes $fh, $l;
572 print PF $d or confess "$!";
574 close PF or confess "$!";
577 #---------- remote protocol support, responder ----------
579 sub responder_send_command ($) {
581 return unless $we_are_responder;
582 # called even without $we_are_responder
583 printdebug ">> $command\n";
584 print PO $command, "\n" or confess "$!";
587 sub responder_send_file ($$) {
588 my ($keyword, $ourfn) = @_;
589 return unless $we_are_responder;
590 printdebug "]] $keyword $ourfn\n";
591 responder_send_command "file $keyword";
592 protocol_send_file \*PO, $ourfn;
595 sub responder_receive_files ($@) {
596 my ($keyword, @ourfns) = @_;
597 die unless $we_are_responder;
598 printdebug "[[ $keyword @ourfns\n";
599 responder_send_command "want $keyword";
600 foreach my $fn (@ourfns) {
601 protocol_receive_file \*PI, $fn;
604 protocol_expect { m/^files-end$/ } \*PI;
607 #---------- remote protocol support, initiator ----------
609 sub initiator_expect (&) {
611 protocol_expect { &$match } \*RO;
614 #---------- end remote code ----------
617 if ($we_are_responder) {
619 responder_send_command "progress ".length($m) or confess "$!";
620 print PO $m or confess "$!";
630 $ua = LWP::UserAgent->new();
634 progress "downloading $what...";
635 my $r = $ua->get(@_) or confess "$!";
636 return undef if $r->code == 404;
637 $r->is_success or fail f_ "failed to fetch %s: %s",
638 $what, $r->status_line;
639 return $r->decoded_content(charset => 'none');
642 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
644 sub act_local () { return $dryrun_level <= 1; }
645 sub act_scary () { return !$dryrun_level; }
648 if (!$dryrun_level) {
649 progress f_ "%s ok: %s", $us, "@_";
651 progress f_ "would be ok: %s (but dry run only)", "@_";
656 printcmd(\*STDERR,$debugprefix."#",@_);
659 sub runcmd_ordryrun {
667 sub runcmd_ordryrun_local {
675 our $helpmsg = i_ <<END;
677 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
678 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
679 dgit [dgit-opts] build [dpkg-buildpackage-opts]
680 dgit [dgit-opts] sbuild [sbuild-opts]
681 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
682 dgit [dgit-opts] push [dgit-opts] [suite]
683 dgit [dgit-opts] push-source [dgit-opts] [suite]
684 dgit [dgit-opts] rpush build-host:build-dir ...
685 important dgit options:
686 -k<keyid> sign tag and package with <keyid> instead of default
687 --dry-run -n do not change anything, but go through the motions
688 --damp-run -L like --dry-run but make local changes, without signing
689 --new -N allow introducing a new package
690 --debug -D increase debug level
691 -c<name>=<value> set git config option (used directly by dgit too)
694 our $later_warning_msg = i_ <<END;
695 Perhaps the upload is stuck in incoming. Using the version from git.
699 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess "$!";
704 @ARGV or badusage __ "too few arguments";
705 return scalar shift @ARGV;
709 not_necessarily_a_tree();
712 print __ $helpmsg or confess "$!";
716 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
718 our %defcfg = ('dgit.default.distro' => 'debian',
719 'dgit.default.default-suite' => 'unstable',
720 'dgit.default.old-dsc-distro' => 'debian',
721 'dgit-suite.*-security.distro' => 'debian-security',
722 'dgit.default.username' => '',
723 'dgit.default.archive-query-default-component' => 'main',
724 'dgit.default.ssh' => 'ssh',
725 'dgit.default.archive-query' => 'madison:',
726 'dgit.default.sshpsql-dbname' => 'service=projectb',
727 'dgit.default.aptget-components' => 'main',
728 'dgit.default.source-only-uploads' => 'ok',
729 'dgit.dsc-url-proto-ok.http' => 'true',
730 'dgit.dsc-url-proto-ok.https' => 'true',
731 'dgit.dsc-url-proto-ok.git' => 'true',
732 'dgit.vcs-git.suites', => 'sid', # ;-separated
733 'dgit.default.dsc-url-proto-ok' => 'false',
734 # old means "repo server accepts pushes with old dgit tags"
735 # new means "repo server accepts pushes with new dgit tags"
736 # maint means "repo server accepts split brain pushes"
737 # hist means "repo server may have old pushes without new tag"
738 # ("hist" is implied by "old")
739 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
740 'dgit-distro.debian.git-check' => 'url',
741 'dgit-distro.debian.git-check-suffix' => '/info/refs',
742 'dgit-distro.debian.new-private-pushers' => 't',
743 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
744 'dgit-distro.debian/push.git-url' => '',
745 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
746 'dgit-distro.debian/push.git-user-force' => 'dgit',
747 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
748 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
749 'dgit-distro.debian/push.git-create' => 'true',
750 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
751 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
752 # 'dgit-distro.debian.archive-query-tls-key',
753 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
754 # ^ this does not work because curl is broken nowadays
755 # Fixing #790093 properly will involve providing providing the key
756 # in some pacagke and maybe updating these paths.
758 # 'dgit-distro.debian.archive-query-tls-curl-args',
759 # '--ca-path=/etc/ssl/ca-debian',
760 # ^ this is a workaround but works (only) on DSA-administered machines
761 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
762 'dgit-distro.debian.git-url-suffix' => '',
763 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
764 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
765 'dgit-distro.debian-security.archive-query' => 'aptget:',
766 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
767 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
768 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
769 'dgit-distro.debian-security.nominal-distro' => 'debian',
770 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
771 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
772 'dgit-distro.ubuntu.git-check' => 'false',
773 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
774 'dgit-distro.test-dummy.ssh' => "$td/ssh",
775 'dgit-distro.test-dummy.username' => "alice",
776 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
777 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
778 'dgit-distro.test-dummy.git-url' => "$td/git",
779 'dgit-distro.test-dummy.git-host' => "git",
780 'dgit-distro.test-dummy.git-path' => "$td/git",
781 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
782 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
783 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
784 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
788 our @gitcfgsources = qw(cmdline local global system);
789 our $invoked_in_git_tree = 1;
791 sub git_slurp_config () {
792 # This algoritm is a bit subtle, but this is needed so that for
793 # options which we want to be single-valued, we allow the
794 # different config sources to override properly. See #835858.
795 foreach my $src (@gitcfgsources) {
796 next if $src eq 'cmdline';
797 # we do this ourselves since git doesn't handle it
799 $gitcfgs{$src} = git_slurp_config_src $src;
803 sub git_get_config ($) {
805 foreach my $src (@gitcfgsources) {
806 my $l = $gitcfgs{$src}{$c};
807 confess "internal error ($l $c)" if $l && !ref $l;
808 printdebug"C $c ".(defined $l ?
809 join " ", map { messagequote "'$_'" } @$l :
814 f_ "multiple values for %s (in %s git config)", $c, $src
816 $l->[0] =~ m/\n/ and badcfg f_
817 "value for config option %s (in %s git config) contains newline(s)!",
826 return undef if $c =~ /RETURN-UNDEF/;
827 printdebug "C? $c\n" if $debuglevel >= 5;
828 my $v = git_get_config($c);
829 return $v if defined $v;
830 my $dv = $defcfg{$c};
832 printdebug "CD $c $dv\n" if $debuglevel >= 4;
837 "need value for one of: %s\n".
838 "%s: distro or suite appears not to be (properly) supported",
842 sub not_necessarily_a_tree () {
843 # needs to be called from pre_*
844 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
845 $invoked_in_git_tree = 0;
848 sub access_basedistro__noalias () {
849 if (defined $idistro) {
852 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
853 return $def if defined $def;
854 foreach my $src (@gitcfgsources, 'internal') {
855 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
857 foreach my $k (keys %$kl) {
858 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
860 next unless match_glob $dpat, $isuite;
864 return cfg("dgit.default.distro");
868 sub access_basedistro () {
869 my $noalias = access_basedistro__noalias();
870 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
871 return $canon // $noalias;
874 sub access_nomdistro () {
875 my $base = access_basedistro();
876 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
877 $r =~ m/^$distro_re$/ or badcfg
878 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
879 $r, "/^$distro_re$/";
883 sub access_quirk () {
884 # returns (quirk name, distro to use instead or undef, quirk-specific info)
885 my $basedistro = access_basedistro();
886 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
888 if (defined $backports_quirk) {
889 my $re = $backports_quirk;
890 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
892 $re =~ s/\%/([-0-9a-z_]+)/
893 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
894 if ($isuite =~ m/^$re$/) {
895 return ('backports',"$basedistro-backports",$1);
898 return ('none',undef);
903 sub parse_cfg_bool ($$$) {
904 my ($what,$def,$v) = @_;
907 $v =~ m/^[ty1]/ ? 1 :
908 $v =~ m/^[fn0]/ ? 0 :
909 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
913 sub access_forpush_config () {
914 my $d = access_basedistro();
918 parse_cfg_bool('new-private-pushers', 0,
919 cfg("dgit-distro.$d.new-private-pushers",
922 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
925 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
926 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
927 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
929 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
932 sub access_forpush () {
933 $access_forpush //= access_forpush_config();
934 return $access_forpush;
937 sub default_from_access_cfg ($$$;$) {
938 my ($var, $keybase, $defval, $permit_re) = @_;
939 return if defined $$var;
941 $$var = access_cfg("$keybase-newer", 'RETURN-UNDEF');
942 $$var = undef if $$var && $$var !~ m/^$permit_re$/;
944 $$var //= access_cfg($keybase, 'RETURN-UNDEF');
947 badcfg f_ "unknown %s \`%s'", $keybase, $$var
948 if defined $permit_re and $$var !~ m/$permit_re/;
952 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
953 defined $access_forpush and !$access_forpush;
954 badcfg __ "pushing but distro is configured readonly"
955 if access_forpush_config() eq '0';
957 $supplementary_message = __ <<'END' unless $we_are_responder;
958 Push failed, before we got started.
959 You can retry the push, after fixing the problem, if you like.
961 parseopts_late_defaults();
965 parseopts_late_defaults();
968 sub supplementary_message ($) {
970 if (!$we_are_responder) {
971 $supplementary_message = $msg;
974 responder_send_command "supplementary-message ".length($msg)
976 print PO $msg or confess "$!";
980 sub access_distros () {
981 # Returns list of distros to try, in order
984 # 0. `instead of' distro name(s) we have been pointed to
985 # 1. the access_quirk distro, if any
986 # 2a. the user's specified distro, or failing that } basedistro
987 # 2b. the distro calculated from the suite }
988 my @l = access_basedistro();
990 my (undef,$quirkdistro) = access_quirk();
991 unshift @l, $quirkdistro;
992 unshift @l, $instead_distro;
993 @l = grep { defined } @l;
995 push @l, access_nomdistro();
997 if (access_forpush()) {
998 @l = map { ("$_/push", $_) } @l;
1003 sub access_cfg_cfgs (@) {
1006 # The nesting of these loops determines the search order. We put
1007 # the key loop on the outside so that we search all the distros
1008 # for each key, before going on to the next key. That means that
1009 # if access_cfg is called with a more specific, and then a less
1010 # specific, key, an earlier distro can override the less specific
1011 # without necessarily overriding any more specific keys. (If the
1012 # distro wants to override the more specific keys it can simply do
1013 # so; whereas if we did the loop the other way around, it would be
1014 # impossible to for an earlier distro to override a less specific
1015 # key but not the more specific ones without restating the unknown
1016 # values of the more specific keys.
1019 # We have to deal with RETURN-UNDEF specially, so that we don't
1020 # terminate the search prematurely.
1022 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
1025 foreach my $d (access_distros()) {
1026 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
1028 push @cfgs, map { "dgit.default.$_" } @realkeys;
1029 push @cfgs, @rundef;
1033 sub access_cfg (@) {
1035 my (@cfgs) = access_cfg_cfgs(@keys);
1036 my $value = cfg(@cfgs);
1040 sub access_cfg_bool ($$) {
1041 my ($def, @keys) = @_;
1042 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1045 sub string_to_ssh ($) {
1047 if ($spec =~ m/\s/) {
1048 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1054 sub access_cfg_ssh () {
1055 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1056 if (!defined $gitssh) {
1059 return string_to_ssh $gitssh;
1063 sub access_runeinfo ($) {
1065 return ": dgit ".access_basedistro()." $info ;";
1068 sub access_someuserhost ($) {
1070 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1071 defined($user) && length($user) or
1072 $user = access_cfg("$some-user",'username');
1073 my $host = access_cfg("$some-host");
1074 return length($user) ? "$user\@$host" : $host;
1077 sub access_gituserhost () {
1078 return access_someuserhost('git');
1081 sub access_giturl (;$) {
1082 my ($optional) = @_;
1083 my $url = access_cfg('git-url','RETURN-UNDEF');
1086 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1087 return undef unless defined $proto;
1090 access_gituserhost().
1091 access_cfg('git-path');
1093 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1096 return "$url/$package$suffix";
1099 sub commit_getclogp ($) {
1100 # Returns the parsed changelog hashref for a particular commit
1102 our %commit_getclogp_memo;
1103 my $memo = $commit_getclogp_memo{$objid};
1104 return $memo if $memo;
1106 my $mclog = dgit_privdir()."clog";
1107 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1108 "$objid:debian/changelog";
1109 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1112 sub parse_dscdata () {
1113 my $dscfh = new IO::File \$dscdata, '<' or confess "$!";
1114 printdebug Dumper($dscdata) if $debuglevel>1;
1115 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1116 printdebug Dumper($dsc) if $debuglevel>1;
1121 sub archive_query ($;@) {
1122 my ($method) = shift @_;
1123 fail __ "this operation does not support multiple comma-separated suites"
1125 my $query = access_cfg('archive-query','RETURN-UNDEF');
1126 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1129 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1132 sub archive_query_prepend_mirror {
1133 my $m = access_cfg('mirror');
1134 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1137 sub pool_dsc_subpath ($$) {
1138 my ($vsn,$component) = @_; # $package is implict arg
1139 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1140 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1143 sub cfg_apply_map ($$$) {
1144 my ($varref, $what, $mapspec) = @_;
1145 return unless $mapspec;
1147 printdebug "config $what EVAL{ $mapspec; }\n";
1149 eval "package Dgit::Config; $mapspec;";
1154 #---------- `ftpmasterapi' archive query method (nascent) ----------
1156 sub archive_api_query_cmd ($) {
1158 my @cmd = (@curl, qw(-sS));
1159 my $url = access_cfg('archive-query-url');
1160 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1162 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1163 foreach my $key (split /\:/, $keys) {
1164 $key =~ s/\%HOST\%/$host/g;
1166 fail "for $url: stat $key: $!" unless $!==ENOENT;
1169 fail f_ "config requested specific TLS key but do not know".
1170 " how to get curl to use exactly that EE key (%s)",
1172 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1173 # # Sadly the above line does not work because of changes
1174 # # to gnutls. The real fix for #790093 may involve
1175 # # new curl options.
1178 # Fixing #790093 properly will involve providing a value
1179 # for this on clients.
1180 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1181 push @cmd, split / /, $kargs if defined $kargs;
1183 push @cmd, $url.$subpath;
1187 sub api_query ($$;$) {
1189 my ($data, $subpath, $ok404) = @_;
1190 badcfg __ "ftpmasterapi archive query method takes no data part"
1192 my @cmd = archive_api_query_cmd($subpath);
1193 my $url = $cmd[$#cmd];
1194 push @cmd, qw(-w %{http_code});
1195 my $json = cmdoutput @cmd;
1196 unless ($json =~ s/\d+\d+\d$//) {
1197 failedcmd_report_cmd undef, @cmd;
1198 fail __ "curl failed to print 3-digit HTTP code";
1201 return undef if $code eq '404' && $ok404;
1202 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1203 unless $url =~ m#^file://# or $code =~ m/^2/;
1204 return decode_json($json);
1207 sub canonicalise_suite_ftpmasterapi {
1208 my ($proto,$data) = @_;
1209 my $suites = api_query($data, 'suites');
1211 foreach my $entry (@$suites) {
1213 my $v = $entry->{$_};
1214 defined $v && $v eq $isuite;
1215 } qw(codename name);
1216 push @matched, $entry;
1218 fail f_ "unknown suite %s, maybe -d would help", $isuite
1222 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1223 $cn = "$matched[0]{codename}";
1224 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1225 $cn =~ m/^$suite_re$/
1226 or die f_ "suite %s maps to bad codename\n", $isuite;
1228 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1233 sub archive_query_ftpmasterapi {
1234 my ($proto,$data) = @_;
1235 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1237 my $digester = Digest::SHA->new(256);
1238 foreach my $entry (@$info) {
1240 my $vsn = "$entry->{version}";
1241 my ($ok,$msg) = version_check $vsn;
1242 die f_ "bad version: %s\n", $msg unless $ok;
1243 my $component = "$entry->{component}";
1244 $component =~ m/^$component_re$/ or die __ "bad component";
1245 my $filename = "$entry->{filename}";
1246 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1247 or die __ "bad filename";
1248 my $sha256sum = "$entry->{sha256sum}";
1249 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1250 push @rows, [ $vsn, "/pool/$component/$filename",
1251 $digester, $sha256sum ];
1253 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1256 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1257 return archive_query_prepend_mirror @rows;
1260 sub file_in_archive_ftpmasterapi {
1261 my ($proto,$data,$filename) = @_;
1262 my $pat = $filename;
1265 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1266 my $info = api_query($data, "file_in_archive/$pat", 1);
1269 sub package_not_wholly_new_ftpmasterapi {
1270 my ($proto,$data,$pkg) = @_;
1271 my $info = api_query($data,"madison?package=${pkg}&f=json");
1275 #---------- `aptget' archive query method ----------
1278 our $aptget_releasefile;
1279 our $aptget_configpath;
1281 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1282 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1284 sub aptget_cache_clean {
1285 runcmd_ordryrun_local qw(sh -ec),
1286 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1290 sub aptget_lock_acquire () {
1291 my $lockfile = "$aptget_base/lock";
1292 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1293 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1296 sub aptget_prep ($) {
1298 return if defined $aptget_base;
1300 badcfg __ "aptget archive query method takes no data part"
1303 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1306 ensuredir "$cache/dgit";
1308 access_cfg('aptget-cachekey','RETURN-UNDEF')
1309 // access_nomdistro();
1311 $aptget_base = "$cache/dgit/aptget";
1312 ensuredir $aptget_base;
1314 my $quoted_base = $aptget_base;
1315 confess "$quoted_base contains bad chars, cannot continue"
1316 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1318 ensuredir $aptget_base;
1320 aptget_lock_acquire();
1322 aptget_cache_clean();
1324 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1325 my $sourceslist = "source.list#$cachekey";
1327 my $aptsuites = $isuite;
1328 cfg_apply_map(\$aptsuites, 'suite map',
1329 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1331 open SRCS, ">", "$aptget_base/$sourceslist" or confess "$!";
1332 printf SRCS "deb-src %s %s %s\n",
1333 access_cfg('mirror'),
1335 access_cfg('aptget-components')
1338 ensuredir "$aptget_base/cache";
1339 ensuredir "$aptget_base/lists";
1341 open CONF, ">", $aptget_configpath or confess "$!";
1343 Debug::NoLocking "true";
1344 APT::Get::List-Cleanup "false";
1345 #clear APT::Update::Post-Invoke-Success;
1346 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1347 Dir::State::Lists "$quoted_base/lists";
1348 Dir::Etc::preferences "$quoted_base/preferences";
1349 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1350 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1353 foreach my $key (qw(
1356 Dir::Cache::Archives
1357 Dir::Etc::SourceParts
1358 Dir::Etc::preferencesparts
1360 ensuredir "$aptget_base/$key";
1361 print CONF "$key \"$quoted_base/$key\";\n" or confess "$!";
1364 my $oldatime = (time // confess "$!") - 1;
1365 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1366 next unless stat_exists $oldlist;
1367 my ($mtime) = (stat _)[9];
1368 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1371 runcmd_ordryrun_local aptget_aptget(), qw(update);
1374 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1375 next unless stat_exists $oldlist;
1376 my ($atime) = (stat _)[8];
1377 next if $atime == $oldatime;
1378 push @releasefiles, $oldlist;
1380 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1381 @releasefiles = @inreleasefiles if @inreleasefiles;
1382 if (!@releasefiles) {
1383 fail f_ <<END, $isuite, $cache;
1384 apt seemed to not to update dgit's cached Release files for %s.
1386 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1389 confess "apt updated too many Release files (@releasefiles), erk"
1390 unless @releasefiles == 1;
1392 ($aptget_releasefile) = @releasefiles;
1395 sub canonicalise_suite_aptget {
1396 my ($proto,$data) = @_;
1399 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1401 foreach my $name (qw(Codename Suite)) {
1402 my $val = $release->{$name};
1404 printdebug "release file $name: $val\n";
1405 $val =~ m/^$suite_re$/o or fail f_
1406 "Release file (%s) specifies intolerable %s",
1407 $aptget_releasefile, $name;
1408 cfg_apply_map(\$val, 'suite rmap',
1409 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1416 sub archive_query_aptget {
1417 my ($proto,$data) = @_;
1420 ensuredir "$aptget_base/source";
1421 foreach my $old (<$aptget_base/source/*.dsc>) {
1422 unlink $old or die "$old: $!";
1425 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1426 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1427 # avoids apt-get source failing with ambiguous error code
1429 runcmd_ordryrun_local
1430 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1431 aptget_aptget(), qw(--download-only --only-source source), $package;
1433 my @dscs = <$aptget_base/source/*.dsc>;
1434 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1435 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1438 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1441 my $uri = "file://". uri_escape $dscs[0];
1442 $uri =~ s{\%2f}{/}gi;
1443 return [ (getfield $pre_dsc, 'Version'), $uri ];
1446 sub file_in_archive_aptget () { return undef; }
1447 sub package_not_wholly_new_aptget () { return undef; }
1449 #---------- `dummyapicat' archive query method ----------
1450 # (untranslated, because this is for testing purposes etc.)
1452 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1453 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1455 sub dummycatapi_run_in_mirror ($@) {
1456 # runs $fn with FIA open onto rune
1457 my ($rune, $argl, $fn) = @_;
1459 my $mirror = access_cfg('mirror');
1460 $mirror =~ s#^file://#/# or die "$mirror ?";
1461 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1462 qw(x), $mirror, @$argl);
1463 debugcmd "-|", @cmd;
1464 open FIA, "-|", @cmd or confess "$!";
1466 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1470 sub file_in_archive_dummycatapi ($$$) {
1471 my ($proto,$data,$filename) = @_;
1473 dummycatapi_run_in_mirror '
1474 find -name "$1" -print0 |
1476 ', [$filename], sub {
1479 printdebug "| $_\n";
1480 m/^(\w+) (\S+)$/ or die "$_ ?";
1481 push @out, { sha256sum => $1, filename => $2 };
1487 sub package_not_wholly_new_dummycatapi {
1488 my ($proto,$data,$pkg) = @_;
1489 dummycatapi_run_in_mirror "
1490 find -name ${pkg}_*.dsc
1497 #---------- `madison' archive query method ----------
1499 sub archive_query_madison {
1500 return archive_query_prepend_mirror
1501 map { [ @$_[0..1] ] } madison_get_parse(@_);
1504 sub madison_get_parse {
1505 my ($proto,$data) = @_;
1506 die unless $proto eq 'madison';
1507 if (!length $data) {
1508 $data= access_cfg('madison-distro','RETURN-UNDEF');
1509 $data //= access_basedistro();
1511 $rmad{$proto,$data,$package} ||= cmdoutput
1512 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1513 my $rmad = $rmad{$proto,$data,$package};
1516 foreach my $l (split /\n/, $rmad) {
1517 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1518 \s*( [^ \t|]+ )\s* \|
1519 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1520 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1521 $1 eq $package or die "$rmad $package ?";
1528 $component = access_cfg('archive-query-default-component');
1530 $5 eq 'source' or die "$rmad ?";
1531 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1533 return sort { -version_compare($a->[0],$b->[0]); } @out;
1536 sub canonicalise_suite_madison {
1537 # madison canonicalises for us
1538 my @r = madison_get_parse(@_);
1540 "unable to canonicalise suite using package %s".
1541 " which does not appear to exist in suite %s;".
1542 " --existing-package may help",
1547 sub file_in_archive_madison { return undef; }
1548 sub package_not_wholly_new_madison { return undef; }
1550 #---------- `sshpsql' archive query method ----------
1551 # (untranslated, because this is obsolete)
1554 my ($data,$runeinfo,$sql) = @_;
1555 if (!length $data) {
1556 $data= access_someuserhost('sshpsql').':'.
1557 access_cfg('sshpsql-dbname');
1559 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1560 my ($userhost,$dbname) = ($`,$'); #';
1562 my @cmd = (access_cfg_ssh, $userhost,
1563 access_runeinfo("ssh-psql $runeinfo").
1564 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1565 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1567 open P, "-|", @cmd or confess "$!";
1570 printdebug(">|$_|\n");
1573 $!=0; $?=0; close P or failedcmd @cmd;
1575 my $nrows = pop @rows;
1576 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1577 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1578 @rows = map { [ split /\|/, $_ ] } @rows;
1579 my $ncols = scalar @{ shift @rows };
1580 die if grep { scalar @$_ != $ncols } @rows;
1584 sub sql_injection_check {
1585 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1588 sub archive_query_sshpsql ($$) {
1589 my ($proto,$data) = @_;
1590 sql_injection_check $isuite, $package;
1591 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1592 SELECT source.version, component.name, files.filename, files.sha256sum
1594 JOIN src_associations ON source.id = src_associations.source
1595 JOIN suite ON suite.id = src_associations.suite
1596 JOIN dsc_files ON dsc_files.source = source.id
1597 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1598 JOIN component ON component.id = files_archive_map.component_id
1599 JOIN files ON files.id = dsc_files.file
1600 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1601 AND source.source='$package'
1602 AND files.filename LIKE '%.dsc';
1604 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1605 my $digester = Digest::SHA->new(256);
1607 my ($vsn,$component,$filename,$sha256sum) = @$_;
1608 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1610 return archive_query_prepend_mirror @rows;
1613 sub canonicalise_suite_sshpsql ($$) {
1614 my ($proto,$data) = @_;
1615 sql_injection_check $isuite;
1616 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1617 SELECT suite.codename
1618 FROM suite where suite_name='$isuite' or codename='$isuite';
1620 @rows = map { $_->[0] } @rows;
1621 fail "unknown suite $isuite" unless @rows;
1622 die "ambiguous $isuite: @rows ?" if @rows>1;
1626 sub file_in_archive_sshpsql ($$$) { return undef; }
1627 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1629 #---------- `dummycat' archive query method ----------
1630 # (untranslated, because this is for testing purposes etc.)
1632 sub canonicalise_suite_dummycat ($$) {
1633 my ($proto,$data) = @_;
1634 my $dpath = "$data/suite.$isuite";
1635 if (!open C, "<", $dpath) {
1636 $!==ENOENT or die "$dpath: $!";
1637 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1641 chomp or die "$dpath: $!";
1643 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1647 sub archive_query_dummycat ($$) {
1648 my ($proto,$data) = @_;
1649 canonicalise_suite();
1650 my $dpath = "$data/package.$csuite.$package";
1651 if (!open C, "<", $dpath) {
1652 $!==ENOENT or die "$dpath: $!";
1653 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1661 printdebug "dummycat query $csuite $package $dpath | $_\n";
1662 my @row = split /\s+/, $_;
1663 @row==2 or die "$dpath: $_ ?";
1666 C->error and die "$dpath: $!";
1668 return archive_query_prepend_mirror
1669 sort { -version_compare($a->[0],$b->[0]); } @rows;
1672 sub file_in_archive_dummycat () { return undef; }
1673 sub package_not_wholly_new_dummycat () { return undef; }
1675 #---------- archive query entrypoints and rest of program ----------
1677 sub canonicalise_suite () {
1678 return if defined $csuite;
1679 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1680 $csuite = archive_query('canonicalise_suite');
1681 if ($isuite ne $csuite) {
1682 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1684 progress f_ "canonical suite name is %s", $csuite;
1688 sub get_archive_dsc () {
1689 canonicalise_suite();
1690 my @vsns = archive_query('archive_query');
1691 foreach my $vinfo (@vsns) {
1692 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1693 $dscurl = $vsn_dscurl;
1694 $dscdata = url_get($dscurl);
1696 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1701 $digester->add($dscdata);
1702 my $got = $digester->hexdigest();
1704 fail f_ "%s has hash %s but archive told us to expect %s",
1705 $dscurl, $got, $digest;
1708 my $fmt = getfield $dsc, 'Format';
1709 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1710 f_ "unsupported source format %s, sorry", $fmt;
1712 $dsc_checked = !!$digester;
1713 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1717 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1720 sub check_for_git ();
1721 sub check_for_git () {
1723 my $how = access_cfg('git-check');
1724 if ($how eq 'ssh-cmd') {
1726 (access_cfg_ssh, access_gituserhost(),
1727 access_runeinfo("git-check $package").
1728 " set -e; cd ".access_cfg('git-path').";".
1729 " if test -d $package.git; then echo 1; else echo 0; fi");
1730 my $r= cmdoutput @cmd;
1731 if (defined $r and $r =~ m/^divert (\w+)$/) {
1733 my ($usedistro,) = access_distros();
1734 # NB that if we are pushing, $usedistro will be $distro/push
1735 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1736 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1737 progress f_ "diverting to %s (using config for %s)",
1738 $divert, $instead_distro;
1739 return check_for_git();
1741 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1743 } elsif ($how eq 'url') {
1744 my $prefix = access_cfg('git-check-url','git-url');
1745 my $suffix = access_cfg('git-check-suffix','git-suffix',
1746 'RETURN-UNDEF') // '.git';
1747 my $url = "$prefix/$package$suffix";
1748 my @cmd = (@curl, qw(-sS -I), $url);
1749 my $result = cmdoutput @cmd;
1750 $result =~ s/^\S+ 200 .*\n\r?\n//;
1751 # curl -sS -I with https_proxy prints
1752 # HTTP/1.0 200 Connection established
1753 $result =~ m/^\S+ (404|200) /s or
1754 fail +(__ "unexpected results from git check query - ").
1755 Dumper($prefix, $result);
1757 if ($code eq '404') {
1759 } elsif ($code eq '200') {
1764 } elsif ($how eq 'true') {
1766 } elsif ($how eq 'false') {
1769 badcfg f_ "unknown git-check \`%s'", $how;
1773 sub create_remote_git_repo () {
1774 my $how = access_cfg('git-create');
1775 if ($how eq 'ssh-cmd') {
1777 (access_cfg_ssh, access_gituserhost(),
1778 access_runeinfo("git-create $package").
1779 "set -e; cd ".access_cfg('git-path').";".
1780 " cp -a _template $package.git");
1781 } elsif ($how eq 'true') {
1784 badcfg f_ "unknown git-create \`%s'", $how;
1788 our ($dsc_hash,$lastpush_mergeinput);
1789 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1793 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1794 $playground = fresh_playground 'dgit/unpack';
1797 sub mktree_in_ud_here () {
1798 playtree_setup $gitcfgs{local};
1801 sub git_write_tree () {
1802 my $tree = cmdoutput @git, qw(write-tree);
1803 $tree =~ m/^\w+$/ or die "$tree ?";
1807 sub git_add_write_tree () {
1808 runcmd @git, qw(add -Af .);
1809 return git_write_tree();
1812 sub remove_stray_gits ($) {
1814 my @gitscmd = qw(find -name .git -prune -print0);
1815 debugcmd "|",@gitscmd;
1816 open GITS, "-|", @gitscmd or confess "$!";
1821 print STDERR f_ "%s: warning: removing from %s: %s\n",
1822 $us, $what, (messagequote $_);
1826 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1829 sub mktree_in_ud_from_only_subdir ($;$) {
1830 my ($what,$raw) = @_;
1831 # changes into the subdir
1834 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1835 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1839 remove_stray_gits($what);
1840 mktree_in_ud_here();
1842 my ($format, $fopts) = get_source_format();
1843 if (madformat($format)) {
1848 my $tree=git_add_write_tree();
1849 return ($tree,$dir);
1852 our @files_csum_info_fields =
1853 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1854 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1855 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1857 sub dsc_files_info () {
1858 foreach my $csumi (@files_csum_info_fields) {
1859 my ($fname, $module, $method) = @$csumi;
1860 my $field = $dsc->{$fname};
1861 next unless defined $field;
1862 eval "use $module; 1;" or die $@;
1864 foreach (split /\n/, $field) {
1866 m/^(\w+) (\d+) (\S+)$/ or
1867 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1868 my $digester = eval "$module"."->$method;" or die $@;
1873 Digester => $digester,
1878 fail f_ "missing any supported Checksums-* or Files field in %s",
1879 $dsc->get_option('name');
1883 map { $_->{Filename} } dsc_files_info();
1886 sub files_compare_inputs (@) {
1891 my $showinputs = sub {
1892 return join "; ", map { $_->get_option('name') } @$inputs;
1895 foreach my $in (@$inputs) {
1897 my $in_name = $in->get_option('name');
1899 printdebug "files_compare_inputs $in_name\n";
1901 foreach my $csumi (@files_csum_info_fields) {
1902 my ($fname) = @$csumi;
1903 printdebug "files_compare_inputs $in_name $fname\n";
1905 my $field = $in->{$fname};
1906 next unless defined $field;
1909 foreach (split /\n/, $field) {
1912 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1913 fail "could not parse $in_name $fname line \`$_'";
1915 printdebug "files_compare_inputs $in_name $fname $f\n";
1919 my $re = \ $record{$f}{$fname};
1921 $fchecked{$f}{$in_name} = 1;
1924 "hash or size of %s varies in %s fields (between: %s)",
1925 $f, $fname, $showinputs->();
1930 @files = sort @files;
1931 $expected_files //= \@files;
1932 "@$expected_files" eq "@files" or
1933 fail f_ "file list in %s varies between hash fields!",
1937 fail f_ "%s has no files list field(s)", $in_name;
1939 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1942 grep { keys %$_ == @$inputs-1 } values %fchecked
1943 or fail f_ "no file appears in all file lists (looked in: %s)",
1947 sub is_orig_file_in_dsc ($$) {
1948 my ($f, $dsc_files_info) = @_;
1949 return 0 if @$dsc_files_info <= 1;
1950 # One file means no origs, and the filename doesn't have a "what
1951 # part of dsc" component. (Consider versions ending `.orig'.)
1952 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1956 # This function determines whether a .changes file is source-only from
1957 # the point of view of dak. Thus, it permits *_source.buildinfo
1960 # It does not, however, permit any other buildinfo files. After a
1961 # source-only upload, the buildds will try to upload files like
1962 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1963 # named like this in their (otherwise) source-only upload, the uploads
1964 # of the buildd can be rejected by dak. Fixing the resultant
1965 # situation can require manual intervention. So we block such
1966 # .buildinfo files when the user tells us to perform a source-only
1967 # upload (such as when using the push-source subcommand with the -C
1968 # option, which calls this function).
1970 # Note, though, that when dgit is told to prepare a source-only
1971 # upload, such as when subcommands like build-source and push-source
1972 # without -C are used, dgit has a more restrictive notion of
1973 # source-only .changes than dak: such uploads will never include
1974 # *_source.buildinfo files. This is because there is no use for such
1975 # files when using a tool like dgit to produce the source package, as
1976 # dgit ensures the source is identical to git HEAD.
1977 sub test_source_only_changes ($) {
1979 foreach my $l (split /\n/, getfield $changes, 'Files') {
1980 $l =~ m/\S+$/ or next;
1981 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1982 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1983 print f_ "purportedly source-only changes polluted by %s\n", $&;
1990 sub changes_update_origs_from_dsc ($$$$) {
1991 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1993 printdebug "checking origs needed ($upstreamvsn)...\n";
1994 $_ = getfield $changes, 'Files';
1995 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1996 fail __ "cannot find section/priority from .changes Files field";
1997 my $placementinfo = $1;
1999 printdebug "checking origs needed placement '$placementinfo'...\n";
2000 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2001 $l =~ m/\S+$/ or next;
2003 printdebug "origs $file | $l\n";
2004 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2005 printdebug "origs $file is_orig\n";
2006 my $have = archive_query('file_in_archive', $file);
2007 if (!defined $have) {
2008 print STDERR __ <<END;
2009 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2015 printdebug "origs $file \$#\$have=$#$have\n";
2016 foreach my $h (@$have) {
2019 foreach my $csumi (@files_csum_info_fields) {
2020 my ($fname, $module, $method, $archivefield) = @$csumi;
2021 next unless defined $h->{$archivefield};
2022 $_ = $dsc->{$fname};
2023 next unless defined;
2024 m/^(\w+) .* \Q$file\E$/m or
2025 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2026 if ($h->{$archivefield} eq $1) {
2030 "%s: %s (archive) != %s (local .dsc)",
2031 $archivefield, $h->{$archivefield}, $1;
2034 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2038 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2041 printdebug "origs $file f.same=$found_same".
2042 " #f._differ=$#found_differ\n";
2043 if (@found_differ && !$found_same) {
2045 (f_ "archive contains %s with different checksum", $file),
2048 # Now we edit the changes file to add or remove it
2049 foreach my $csumi (@files_csum_info_fields) {
2050 my ($fname, $module, $method, $archivefield) = @$csumi;
2051 next unless defined $changes->{$fname};
2053 # in archive, delete from .changes if it's there
2054 $changed{$file} = "removed" if
2055 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2056 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2057 # not in archive, but it's here in the .changes
2059 my $dsc_data = getfield $dsc, $fname;
2060 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2062 $extra =~ s/ \d+ /$&$placementinfo /
2063 or confess "$fname $extra >$dsc_data< ?"
2064 if $fname eq 'Files';
2065 $changes->{$fname} .= "\n". $extra;
2066 $changed{$file} = "added";
2071 foreach my $file (keys %changed) {
2073 "edited .changes for archive .orig contents: %s %s",
2074 $changed{$file}, $file;
2076 my $chtmp = "$changesfile.tmp";
2077 $changes->save($chtmp);
2079 rename $chtmp,$changesfile or die "$changesfile $!";
2081 progress f_ "[new .changes left in %s]", $changesfile;
2084 progress f_ "%s already has appropriate .orig(s) (if any)",
2089 sub make_commit ($) {
2091 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2094 sub clogp_authline ($) {
2096 my $author = getfield $clogp, 'Maintainer';
2097 if ($author =~ m/^[^"\@]+\,/) {
2098 # single entry Maintainer field with unquoted comma
2099 $author = ($& =~ y/,//rd).$'; # strip the comma
2101 # git wants a single author; any remaining commas in $author
2102 # are by now preceded by @ (or "). It seems safer to punt on
2103 # "..." for now rather than attempting to dequote or something.
2104 $author =~ s#,.*##ms unless $author =~ m/"/;
2105 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2106 my $authline = "$author $date";
2107 $authline =~ m/$git_authline_re/o or
2108 fail f_ "unexpected commit author line format \`%s'".
2109 " (was generated from changelog Maintainer field)",
2111 return ($1,$2,$3) if wantarray;
2115 sub vendor_patches_distro ($$) {
2116 my ($checkdistro, $what) = @_;
2117 return unless defined $checkdistro;
2119 my $series = "debian/patches/\L$checkdistro\E.series";
2120 printdebug "checking for vendor-specific $series ($what)\n";
2122 if (!open SERIES, "<", $series) {
2123 confess "$series $!" unless $!==ENOENT;
2130 print STDERR __ <<END;
2132 Unfortunately, this source package uses a feature of dpkg-source where
2133 the same source package unpacks to different source code on different
2134 distros. dgit cannot safely operate on such packages on affected
2135 distros, because the meaning of source packages is not stable.
2137 Please ask the distro/maintainer to remove the distro-specific series
2138 files and use a different technique (if necessary, uploading actually
2139 different packages, if different distros are supposed to have
2143 fail f_ "Found active distro-specific series file for".
2144 " %s (%s): %s, cannot continue",
2145 $checkdistro, $what, $series;
2147 die "$series $!" if SERIES->error;
2151 sub check_for_vendor_patches () {
2152 # This dpkg-source feature doesn't seem to be documented anywhere!
2153 # But it can be found in the changelog (reformatted):
2155 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2156 # Author: Raphael Hertzog <hertzog@debian.org>
2157 # Date: Sun Oct 3 09:36:48 2010 +0200
2159 # dpkg-source: correctly create .pc/.quilt_series with alternate
2162 # If you have debian/patches/ubuntu.series and you were
2163 # unpacking the source package on ubuntu, quilt was still
2164 # directed to debian/patches/series instead of
2165 # debian/patches/ubuntu.series.
2167 # debian/changelog | 3 +++
2168 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2169 # 2 files changed, 6 insertions(+), 1 deletion(-)
2172 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2173 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2174 __ "Dpkg::Vendor \`current vendor'");
2175 vendor_patches_distro(access_basedistro(),
2176 __ "(base) distro being accessed");
2177 vendor_patches_distro(access_nomdistro(),
2178 __ "(nominal) distro being accessed");
2181 sub check_bpd_exists () {
2182 stat $buildproductsdir
2183 or fail f_ "build-products-dir %s is not accessible: %s\n",
2184 $buildproductsdir, $!;
2187 sub dotdot_bpd_transfer_origs ($$$) {
2188 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2189 # checks is_orig_file_of_vsn and if
2190 # calls $wanted->{$leaf} and expects boolish
2192 return if $buildproductsdir eq '..';
2195 my $dotdot = $maindir;
2196 $dotdot =~ s{/[^/]+$}{};
2197 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2198 while ($!=0, defined(my $leaf = readdir DD)) {
2200 local ($debuglevel) = $debuglevel-1;
2201 printdebug "DD_BPD $leaf ?\n";
2203 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2204 next unless $wanted->($leaf);
2205 next if lstat "$bpd_abs/$leaf";
2208 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2211 $! == &ENOENT or fail f_
2212 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2213 lstat "$dotdot/$leaf" or fail f_
2214 "check orig file %s in ..: %s", $leaf, $!;
2216 stat "$dotdot/$leaf" or fail f_
2217 "check target of orig symlink %s in ..: %s", $leaf, $!;
2218 my $ltarget = readlink "$dotdot/$leaf" or
2219 die "readlink $dotdot/$leaf: $!";
2220 if ($ltarget !~ m{^/}) {
2221 $ltarget = "$dotdot/$ltarget";
2223 symlink $ltarget, "$bpd_abs/$leaf"
2224 or die "$ltarget $bpd_abs $leaf: $!";
2226 "%s: cloned orig symlink from ..: %s\n",
2228 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2230 "%s: hardlinked orig from ..: %s\n",
2232 } elsif ($! != EXDEV) {
2233 fail f_ "failed to make %s a hardlink to %s: %s",
2234 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2236 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2237 or die "$bpd_abs $dotdot $leaf $!";
2239 "%s: symmlinked orig from .. on other filesystem: %s\n",
2243 die "$dotdot; $!" if $!;
2247 sub generate_commits_from_dsc () {
2248 # See big comment in fetch_from_archive, below.
2249 # See also README.dsc-import.
2251 changedir $playground;
2253 my $bpd_abs = bpd_abs();
2254 my $upstreamv = upstreamversion $dsc->{version};
2255 my @dfi = dsc_files_info();
2257 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2258 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2260 foreach my $fi (@dfi) {
2261 my $f = $fi->{Filename};
2262 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2263 my $upper_f = "$bpd_abs/$f";
2265 printdebug "considering reusing $f: ";
2267 if (link_ltarget "$upper_f,fetch", $f) {
2268 printdebug "linked (using ...,fetch).\n";
2269 } elsif ((printdebug "($!) "),
2271 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2272 } elsif (link_ltarget $upper_f, $f) {
2273 printdebug "linked.\n";
2274 } elsif ((printdebug "($!) "),
2276 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2278 printdebug "absent.\n";
2282 complete_file_from_dsc('.', $fi, \$refetched)
2285 printdebug "considering saving $f: ";
2287 if (rename_link_xf 1, $f, $upper_f) {
2288 printdebug "linked.\n";
2289 } elsif ((printdebug "($@) "),
2291 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2292 } elsif (!$refetched) {
2293 printdebug "no need.\n";
2294 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2295 printdebug "linked (using ...,fetch).\n";
2296 } elsif ((printdebug "($@) "),
2298 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2300 printdebug "cannot.\n";
2304 # We unpack and record the orig tarballs first, so that we only
2305 # need disk space for one private copy of the unpacked source.
2306 # But we can't make them into commits until we have the metadata
2307 # from the debian/changelog, so we record the tree objects now and
2308 # make them into commits later.
2310 my $orig_f_base = srcfn $upstreamv, '';
2312 foreach my $fi (@dfi) {
2313 # We actually import, and record as a commit, every tarball
2314 # (unless there is only one file, in which case there seems
2317 my $f = $fi->{Filename};
2318 printdebug "import considering $f ";
2319 (printdebug "only one dfi\n"), next if @dfi == 1;
2320 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2321 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2325 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2327 printdebug "Y ", (join ' ', map { $_//"(none)" }
2328 $compr_ext, $orig_f_part
2331 my $input = new IO::File $f, '<' or die "$f $!";
2335 if (defined $compr_ext) {
2337 Dpkg::Compression::compression_guess_from_filename $f;
2338 fail "Dpkg::Compression cannot handle file $f in source package"
2339 if defined $compr_ext && !defined $cname;
2341 new Dpkg::Compression::Process compression => $cname;
2342 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2343 my $compr_fh = new IO::Handle;
2344 my $compr_pid = open $compr_fh, "-|" // confess "$!";
2346 open STDIN, "<&", $input or confess "$!";
2348 die "dgit (child): exec $compr_cmd[0]: $!\n";
2353 rmtree "_unpack-tar";
2354 mkdir "_unpack-tar" or confess "$!";
2355 my @tarcmd = qw(tar -x -f -
2356 --no-same-owner --no-same-permissions
2357 --no-acls --no-xattrs --no-selinux);
2358 my $tar_pid = fork // confess "$!";
2360 chdir "_unpack-tar" or confess "$!";
2361 open STDIN, "<&", $input or confess "$!";
2363 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2365 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess "$!";
2366 !$? or failedcmd @tarcmd;
2369 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2371 # finally, we have the results in "tarball", but maybe
2372 # with the wrong permissions
2374 runcmd qw(chmod -R +rwX _unpack-tar);
2375 changedir "_unpack-tar";
2376 remove_stray_gits($f);
2377 mktree_in_ud_here();
2379 my ($tree) = git_add_write_tree();
2380 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2381 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2383 printdebug "one subtree $1\n";
2385 printdebug "multiple subtrees\n";
2388 rmtree "_unpack-tar";
2390 my $ent = [ $f, $tree ];
2392 Orig => !!$orig_f_part,
2393 Sort => (!$orig_f_part ? 2 :
2394 $orig_f_part =~ m/-/g ? 1 :
2402 # put any without "_" first (spec is not clear whether files
2403 # are always in the usual order). Tarballs without "_" are
2404 # the main orig or the debian tarball.
2405 $a->{Sort} <=> $b->{Sort} or
2409 my $any_orig = grep { $_->{Orig} } @tartrees;
2411 my $dscfn = "$package.dsc";
2413 my $treeimporthow = 'package';
2415 open D, ">", $dscfn or die "$dscfn: $!";
2416 print D $dscdata or die "$dscfn: $!";
2417 close D or die "$dscfn: $!";
2418 my @cmd = qw(dpkg-source);
2419 push @cmd, '--no-check' if $dsc_checked;
2420 if (madformat $dsc->{format}) {
2421 push @cmd, '--skip-patches';
2422 $treeimporthow = 'unpatched';
2424 push @cmd, qw(-x --), $dscfn;
2427 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2428 if (madformat $dsc->{format}) {
2429 check_for_vendor_patches();
2433 if (madformat $dsc->{format}) {
2434 my @pcmd = qw(dpkg-source --before-build .);
2435 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2437 $dappliedtree = git_add_write_tree();
2440 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2444 printdebug "import clog search...\n";
2445 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2446 my ($thisstanza, $desc) = @_;
2447 no warnings qw(exiting);
2449 $clogp //= $thisstanza;
2451 printdebug "import clog $thisstanza->{version} $desc...\n";
2453 last if !$any_orig; # we don't need $r1clogp
2455 # We look for the first (most recent) changelog entry whose
2456 # version number is lower than the upstream version of this
2457 # package. Then the last (least recent) previous changelog
2458 # entry is treated as the one which introduced this upstream
2459 # version and used for the synthetic commits for the upstream
2462 # One might think that a more sophisticated algorithm would be
2463 # necessary. But: we do not want to scan the whole changelog
2464 # file. Stopping when we see an earlier version, which
2465 # necessarily then is an earlier upstream version, is the only
2466 # realistic way to do that. Then, either the earliest
2467 # changelog entry we have seen so far is indeed the earliest
2468 # upload of this upstream version; or there are only changelog
2469 # entries relating to later upstream versions (which is not
2470 # possible unless the changelog and .dsc disagree about the
2471 # version). Then it remains to choose between the physically
2472 # last entry in the file, and the one with the lowest version
2473 # number. If these are not the same, we guess that the
2474 # versions were created in a non-monotonic order rather than
2475 # that the changelog entries have been misordered.
2477 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2479 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2480 $r1clogp = $thisstanza;
2482 printdebug "import clog $r1clogp->{version} becomes r1\n";
2485 $clogp or fail __ "package changelog has no entries!";
2487 my $authline = clogp_authline $clogp;
2488 my $changes = getfield $clogp, 'Changes';
2489 $changes =~ s/^\n//; # Changes: \n
2490 my $cversion = getfield $clogp, 'Version';
2493 $r1clogp //= $clogp; # maybe there's only one entry;
2494 my $r1authline = clogp_authline $r1clogp;
2495 # Strictly, r1authline might now be wrong if it's going to be
2496 # unused because !$any_orig. Whatever.
2498 printdebug "import tartrees authline $authline\n";
2499 printdebug "import tartrees r1authline $r1authline\n";
2501 foreach my $tt (@tartrees) {
2502 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2504 my $mbody = f_ "Import %s", $tt->{F};
2505 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2508 committer $r1authline
2512 [dgit import orig $tt->{F}]
2520 [dgit import tarball $package $cversion $tt->{F}]
2525 printdebug "import main commit\n";
2527 open C, ">../commit.tmp" or confess "$!";
2528 print C <<END or confess "$!";
2531 print C <<END or confess "$!" foreach @tartrees;
2534 print C <<END or confess "$!";
2540 [dgit import $treeimporthow $package $cversion]
2543 close C or confess "$!";
2544 my $rawimport_hash = make_commit qw(../commit.tmp);
2546 if (madformat $dsc->{format}) {
2547 printdebug "import apply patches...\n";
2549 # regularise the state of the working tree so that
2550 # the checkout of $rawimport_hash works nicely.
2551 my $dappliedcommit = make_commit_text(<<END);
2558 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2560 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2562 # We need the answers to be reproducible
2563 my @authline = clogp_authline($clogp);
2564 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2565 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2566 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2567 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2568 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2569 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2571 my $path = $ENV{PATH} or die;
2573 # we use ../../gbp-pq-output, which (given that we are in
2574 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2577 foreach my $use_absurd (qw(0 1)) {
2578 runcmd @git, qw(checkout -q unpa);
2579 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2580 local $ENV{PATH} = $path;
2583 progress "warning: $@";
2584 $path = "$absurdity:$path";
2585 progress f_ "%s: trying slow absurd-git-apply...", $us;
2586 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2591 die "forbid absurd git-apply\n" if $use_absurd
2592 && forceing [qw(import-gitapply-no-absurd)];
2593 die "only absurd git-apply!\n" if !$use_absurd
2594 && forceing [qw(import-gitapply-absurd)];
2596 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2597 local $ENV{PATH} = $path if $use_absurd;
2599 my @showcmd = (gbp_pq, qw(import));
2600 my @realcmd = shell_cmd
2601 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2602 debugcmd "+",@realcmd;
2603 if (system @realcmd) {
2604 die f_ "%s failed: %s\n",
2605 +(shellquote @showcmd),
2606 failedcmd_waitstatus();
2609 my $gapplied = git_rev_parse('HEAD');
2610 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2611 $gappliedtree eq $dappliedtree or
2612 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2613 gbp-pq import and dpkg-source disagree!
2614 gbp-pq import gave commit %s
2615 gbp-pq import gave tree %s
2616 dpkg-source --before-build gave tree %s
2618 $rawimport_hash = $gapplied;
2623 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2628 progress f_ "synthesised git commit from .dsc %s", $cversion;
2630 my $rawimport_mergeinput = {
2631 Commit => $rawimport_hash,
2632 Info => __ "Import of source package",
2634 my @output = ($rawimport_mergeinput);
2636 if ($lastpush_mergeinput) {
2637 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2638 my $oversion = getfield $oldclogp, 'Version';
2640 version_compare($oversion, $cversion);
2642 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2643 { ReverseParents => 1,
2644 Message => (f_ <<END, $package, $cversion, $csuite) });
2645 Record %s (%s) in archive suite %s
2647 } elsif ($vcmp > 0) {
2648 print STDERR f_ <<END, $cversion, $oversion,
2650 Version actually in archive: %s (older)
2651 Last version pushed with dgit: %s (newer or same)
2654 __ $later_warning_msg or confess "$!";
2655 @output = $lastpush_mergeinput;
2657 # Same version. Use what's in the server git branch,
2658 # discarding our own import. (This could happen if the
2659 # server automatically imports all packages into git.)
2660 @output = $lastpush_mergeinput;
2668 sub complete_file_from_dsc ($$;$) {
2669 our ($dstdir, $fi, $refetched) = @_;
2670 # Ensures that we have, in $dstdir, the file $fi, with the correct
2671 # contents. (Downloading it from alongside $dscurl if necessary.)
2672 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2673 # and will set $$refetched=1 if it did so (or tried to).
2675 my $f = $fi->{Filename};
2676 my $tf = "$dstdir/$f";
2680 my $checkhash = sub {
2681 open F, "<", "$tf" or die "$tf: $!";
2682 $fi->{Digester}->reset();
2683 $fi->{Digester}->addfile(*F);
2684 F->error and confess "$!";
2685 $got = $fi->{Digester}->hexdigest();
2686 return $got eq $fi->{Hash};
2689 if (stat_exists $tf) {
2690 if ($checkhash->()) {
2691 progress f_ "using existing %s", $f;
2695 fail f_ "file %s has hash %s but .dsc demands hash %s".
2696 " (perhaps you should delete this file?)",
2697 $f, $got, $fi->{Hash};
2699 progress f_ "need to fetch correct version of %s", $f;
2700 unlink $tf or die "$tf $!";
2703 printdebug "$tf does not exist, need to fetch\n";
2707 $furl =~ s{/[^/]+$}{};
2709 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2710 die "$f ?" if $f =~ m#/#;
2711 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2712 return 0 if !act_local();
2715 fail f_ "file %s has hash %s but .dsc demands hash %s".
2716 " (got wrong file from archive!)",
2717 $f, $got, $fi->{Hash};
2722 sub ensure_we_have_orig () {
2723 my @dfi = dsc_files_info();
2724 foreach my $fi (@dfi) {
2725 my $f = $fi->{Filename};
2726 next unless is_orig_file_in_dsc($f, \@dfi);
2727 complete_file_from_dsc($buildproductsdir, $fi)
2732 #---------- git fetch ----------
2734 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2735 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2737 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2738 # locally fetched refs because they have unhelpful names and clutter
2739 # up gitk etc. So we track whether we have "used up" head ref (ie,
2740 # whether we have made another local ref which refers to this object).
2742 # (If we deleted them unconditionally, then we might end up
2743 # re-fetching the same git objects each time dgit fetch was run.)
2745 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2746 # in git_fetch_us to fetch the refs in question, and possibly a call
2747 # to lrfetchref_used.
2749 our (%lrfetchrefs_f, %lrfetchrefs_d);
2750 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2752 sub lrfetchref_used ($) {
2753 my ($fullrefname) = @_;
2754 my $objid = $lrfetchrefs_f{$fullrefname};
2755 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2758 sub git_lrfetch_sane {
2759 my ($url, $supplementary, @specs) = @_;
2760 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2761 # at least as regards @specs. Also leave the results in
2762 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2763 # able to clean these up.
2765 # With $supplementary==1, @specs must not contain wildcards
2766 # and we add to our previous fetches (non-atomically).
2768 # This is rather miserable:
2769 # When git fetch --prune is passed a fetchspec ending with a *,
2770 # it does a plausible thing. If there is no * then:
2771 # - it matches subpaths too, even if the supplied refspec
2772 # starts refs, and behaves completely madly if the source
2773 # has refs/refs/something. (See, for example, Debian #NNNN.)
2774 # - if there is no matching remote ref, it bombs out the whole
2776 # We want to fetch a fixed ref, and we don't know in advance
2777 # if it exists, so this is not suitable.
2779 # Our workaround is to use git ls-remote. git ls-remote has its
2780 # own qairks. Notably, it has the absurd multi-tail-matching
2781 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2782 # refs/refs/foo etc.
2784 # Also, we want an idempotent snapshot, but we have to make two
2785 # calls to the remote: one to git ls-remote and to git fetch. The
2786 # solution is use git ls-remote to obtain a target state, and
2787 # git fetch to try to generate it. If we don't manage to generate
2788 # the target state, we try again.
2790 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2792 my $specre = join '|', map {
2795 my $wildcard = $x =~ s/\\\*$/.*/;
2796 die if $wildcard && $supplementary;
2799 printdebug "git_lrfetch_sane specre=$specre\n";
2800 my $wanted_rref = sub {
2802 return m/^(?:$specre)$/;
2805 my $fetch_iteration = 0;
2808 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2809 if (++$fetch_iteration > 10) {
2810 fail __ "too many iterations trying to get sane fetch!";
2813 my @look = map { "refs/$_" } @specs;
2814 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2818 open GITLS, "-|", @lcmd or confess "$!";
2820 printdebug "=> ", $_;
2821 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2822 my ($objid,$rrefname) = ($1,$2);
2823 if (!$wanted_rref->($rrefname)) {
2824 print STDERR f_ <<END, "@look", $rrefname;
2825 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2829 $wantr{$rrefname} = $objid;
2832 close GITLS or failedcmd @lcmd;
2834 # OK, now %want is exactly what we want for refs in @specs
2836 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2837 "+refs/$_:".lrfetchrefs."/$_";
2840 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2842 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2843 runcmd_ordryrun_local @fcmd if @fspecs;
2845 if (!$supplementary) {
2846 %lrfetchrefs_f = ();
2850 git_for_each_ref(lrfetchrefs, sub {
2851 my ($objid,$objtype,$lrefname,$reftail) = @_;
2852 $lrfetchrefs_f{$lrefname} = $objid;
2853 $objgot{$objid} = 1;
2856 if ($supplementary) {
2860 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2861 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2862 if (!exists $wantr{$rrefname}) {
2863 if ($wanted_rref->($rrefname)) {
2865 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2868 print STDERR f_ <<END, "@fspecs", $lrefname
2869 warning: git fetch %s created %s; this is silly, deleting it.
2872 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2873 delete $lrfetchrefs_f{$lrefname};
2877 foreach my $rrefname (sort keys %wantr) {
2878 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2879 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2880 my $want = $wantr{$rrefname};
2881 next if $got eq $want;
2882 if (!defined $objgot{$want}) {
2883 fail __ <<END unless act_local();
2884 --dry-run specified but we actually wanted the results of git fetch,
2885 so this is not going to work. Try running dgit fetch first,
2886 or using --damp-run instead of --dry-run.
2888 print STDERR f_ <<END, $lrefname, $want;
2889 warning: git ls-remote suggests we want %s
2890 warning: and it should refer to %s
2891 warning: but git fetch didn't fetch that object to any relevant ref.
2892 warning: This may be due to a race with someone updating the server.
2893 warning: Will try again...
2895 next FETCH_ITERATION;
2898 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2900 runcmd_ordryrun_local @git, qw(update-ref -m),
2901 "dgit fetch git fetch fixup", $lrefname, $want;
2902 $lrfetchrefs_f{$lrefname} = $want;
2907 if (defined $csuite) {
2908 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2909 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2910 my ($objid,$objtype,$lrefname,$reftail) = @_;
2911 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2912 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2916 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2917 Dumper(\%lrfetchrefs_f);
2920 sub git_fetch_us () {
2921 # Want to fetch only what we are going to use, unless
2922 # deliberately-not-ff, in which case we must fetch everything.
2924 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2926 (quiltmode_splitbrain
2927 ? (map { $_->('*',access_nomdistro) }
2928 \&debiantag_new, \&debiantag_maintview)
2929 : debiantags('*',access_nomdistro));
2930 push @specs, server_branch($csuite);
2931 push @specs, $rewritemap;
2932 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2934 my $url = access_giturl();
2935 git_lrfetch_sane $url, 0, @specs;
2938 my @tagpats = debiantags('*',access_nomdistro);
2940 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2941 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2942 printdebug "currently $fullrefname=$objid\n";
2943 $here{$fullrefname} = $objid;
2945 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2946 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2947 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2948 printdebug "offered $lref=$objid\n";
2949 if (!defined $here{$lref}) {
2950 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2951 runcmd_ordryrun_local @upd;
2952 lrfetchref_used $fullrefname;
2953 } elsif ($here{$lref} eq $objid) {
2954 lrfetchref_used $fullrefname;
2956 print STDERR f_ "Not updating %s from %s to %s.\n",
2957 $lref, $here{$lref}, $objid;
2962 #---------- dsc and archive handling ----------
2964 sub mergeinfo_getclogp ($) {
2965 # Ensures thit $mi->{Clogp} exists and returns it
2967 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2970 sub mergeinfo_version ($) {
2971 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2974 sub fetch_from_archive_record_1 ($) {
2976 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2977 cmdoutput @git, qw(log -n2), $hash;
2978 # ... gives git a chance to complain if our commit is malformed
2981 sub fetch_from_archive_record_2 ($) {
2983 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2987 dryrun_report @upd_cmd;
2991 sub parse_dsc_field_def_dsc_distro () {
2992 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2993 dgit.default.distro);
2996 sub parse_dsc_field ($$) {
2997 my ($dsc, $what) = @_;
2999 foreach my $field (@ourdscfield) {
3000 $f = $dsc->{$field};
3005 progress f_ "%s: NO git hash", $what;
3006 parse_dsc_field_def_dsc_distro();
3007 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3008 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3009 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3010 $dsc_hint_tag = [ $dsc_hint_tag ];
3011 } elsif ($f =~ m/^\w+\s*$/) {
3013 parse_dsc_field_def_dsc_distro();
3014 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3016 progress f_ "%s: specified git hash", $what;
3018 fail f_ "%s: invalid Dgit info", $what;
3022 sub resolve_dsc_field_commit ($$) {
3023 my ($already_distro, $already_mapref) = @_;
3025 return unless defined $dsc_hash;
3028 defined $already_mapref &&
3029 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3030 ? $already_mapref : undef;
3034 my ($what, @fetch) = @_;
3036 local $idistro = $dsc_distro;
3037 my $lrf = lrfetchrefs;
3039 if (!$chase_dsc_distro) {
3040 progress f_ "not chasing .dsc distro %s: not fetching %s",
3045 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3047 my $url = access_giturl();
3048 if (!defined $url) {
3049 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3050 .dsc Dgit metadata is in context of distro %s
3051 for which we have no configured url and .dsc provides no hint
3054 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3055 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3056 parse_cfg_bool "dsc-url-proto-ok", 'false',
3057 cfg("dgit.dsc-url-proto-ok.$proto",
3058 "dgit.default.dsc-url-proto-ok")
3059 or fail f_ <<END, $dsc_distro, $proto;
3060 .dsc Dgit metadata is in context of distro %s
3061 for which we have no configured url;
3062 .dsc provides hinted url with protocol %s which is unsafe.
3063 (can be overridden by config - consult documentation)
3065 $url = $dsc_hint_url;
3068 git_lrfetch_sane $url, 1, @fetch;
3073 my $rewrite_enable = do {
3074 local $idistro = $dsc_distro;
3075 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3078 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3079 if (!defined $mapref) {
3080 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3081 $mapref = $lrf.'/'.$rewritemap;
3083 my $rewritemapdata = git_cat_file $mapref.':map';
3084 if (defined $rewritemapdata
3085 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3087 "server's git history rewrite map contains a relevant entry!";
3090 if (defined $dsc_hash) {
3091 progress __ "using rewritten git hash in place of .dsc value";
3093 progress __ "server data says .dsc hash is to be disregarded";
3098 if (!defined git_cat_file $dsc_hash) {
3099 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3100 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3101 defined git_cat_file $dsc_hash
3102 or fail f_ <<END, $dsc_hash;
3103 .dsc Dgit metadata requires commit %s
3104 but we could not obtain that object anywhere.
3106 foreach my $t (@tags) {
3107 my $fullrefname = $lrf.'/'.$t;
3108 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3109 next unless $lrfetchrefs_f{$fullrefname};
3110 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3111 lrfetchref_used $fullrefname;
3116 sub fetch_from_archive () {
3118 ensure_setup_existing_tree();
3120 # Ensures that lrref() is what is actually in the archive, one way
3121 # or another, according to us - ie this client's
3122 # appropritaely-updated archive view. Also returns the commit id.
3123 # If there is nothing in the archive, leaves lrref alone and
3124 # returns undef. git_fetch_us must have already been called.
3128 parse_dsc_field($dsc, __ 'last upload to archive');
3129 resolve_dsc_field_commit access_basedistro,
3130 lrfetchrefs."/".$rewritemap
3132 progress __ "no version available from the archive";
3135 # If the archive's .dsc has a Dgit field, there are three
3136 # relevant git commitids we need to choose between and/or merge
3138 # 1. $dsc_hash: the Dgit field from the archive
3139 # 2. $lastpush_hash: the suite branch on the dgit git server
3140 # 3. $lastfetch_hash: our local tracking brach for the suite
3142 # These may all be distinct and need not be in any fast forward
3145 # If the dsc was pushed to this suite, then the server suite
3146 # branch will have been updated; but it might have been pushed to
3147 # a different suite and copied by the archive. Conversely a more
3148 # recent version may have been pushed with dgit but not appeared
3149 # in the archive (yet).
3151 # $lastfetch_hash may be awkward because archive imports
3152 # (particularly, imports of Dgit-less .dscs) are performed only as
3153 # needed on individual clients, so different clients may perform a
3154 # different subset of them - and these imports are only made
3155 # public during push. So $lastfetch_hash may represent a set of
3156 # imports different to a subsequent upload by a different dgit
3159 # Our approach is as follows:
3161 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3162 # descendant of $dsc_hash, then it was pushed by a dgit user who
3163 # had based their work on $dsc_hash, so we should prefer it.
3164 # Otherwise, $dsc_hash was installed into this suite in the
3165 # archive other than by a dgit push, and (necessarily) after the
3166 # last dgit push into that suite (since a dgit push would have
3167 # been descended from the dgit server git branch); thus, in that
3168 # case, we prefer the archive's version (and produce a
3169 # pseudo-merge to overwrite the dgit server git branch).
3171 # (If there is no Dgit field in the archive's .dsc then
3172 # generate_commit_from_dsc uses the version numbers to decide
3173 # whether the suite branch or the archive is newer. If the suite
3174 # branch is newer it ignores the archive's .dsc; otherwise it
3175 # generates an import of the .dsc, and produces a pseudo-merge to
3176 # overwrite the suite branch with the archive contents.)
3178 # The outcome of that part of the algorithm is the `public view',
3179 # and is same for all dgit clients: it does not depend on any
3180 # unpublished history in the local tracking branch.
3182 # As between the public view and the local tracking branch: The
3183 # local tracking branch is only updated by dgit fetch, and
3184 # whenever dgit fetch runs it includes the public view in the
3185 # local tracking branch. Therefore if the public view is not
3186 # descended from the local tracking branch, the local tracking
3187 # branch must contain history which was imported from the archive
3188 # but never pushed; and, its tip is now out of date. So, we make
3189 # a pseudo-merge to overwrite the old imports and stitch the old
3192 # Finally: we do not necessarily reify the public view (as
3193 # described above). This is so that we do not end up stacking two
3194 # pseudo-merges. So what we actually do is figure out the inputs
3195 # to any public view pseudo-merge and put them in @mergeinputs.
3198 # $mergeinputs[]{Commit}
3199 # $mergeinputs[]{Info}
3200 # $mergeinputs[0] is the one whose tree we use
3201 # @mergeinputs is in the order we use in the actual commit)
3204 # $mergeinputs[]{Message} is a commit message to use
3205 # $mergeinputs[]{ReverseParents} if def specifies that parent
3206 # list should be in opposite order
3207 # Such an entry has no Commit or Info. It applies only when found
3208 # in the last entry. (This ugliness is to support making
3209 # identical imports to previous dgit versions.)
3211 my $lastpush_hash = git_get_ref(lrfetchref());
3212 printdebug "previous reference hash=$lastpush_hash\n";
3213 $lastpush_mergeinput = $lastpush_hash && {
3214 Commit => $lastpush_hash,
3215 Info => (__ "dgit suite branch on dgit git server"),
3218 my $lastfetch_hash = git_get_ref(lrref());
3219 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3220 my $lastfetch_mergeinput = $lastfetch_hash && {
3221 Commit => $lastfetch_hash,
3222 Info => (__ "dgit client's archive history view"),
3225 my $dsc_mergeinput = $dsc_hash && {
3226 Commit => $dsc_hash,
3227 Info => (__ "Dgit field in .dsc from archive"),
3231 my $del_lrfetchrefs = sub {
3234 printdebug "del_lrfetchrefs...\n";
3235 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3236 my $objid = $lrfetchrefs_d{$fullrefname};
3237 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3239 $gur ||= new IO::Handle;
3240 open $gur, "|-", qw(git update-ref --stdin) or confess "$!";
3242 printf $gur "delete %s %s\n", $fullrefname, $objid;
3245 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3249 if (defined $dsc_hash) {
3250 ensure_we_have_orig();
3251 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3252 @mergeinputs = $dsc_mergeinput
3253 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3254 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3256 Git commit in archive is behind the last version allegedly pushed/uploaded.
3257 Commit referred to by archive: %s
3258 Last version pushed with dgit: %s
3261 __ $later_warning_msg or confess "$!";
3262 @mergeinputs = ($lastpush_mergeinput);
3264 # Archive has .dsc which is not a descendant of the last dgit
3265 # push. This can happen if the archive moves .dscs about.
3266 # Just follow its lead.
3267 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3268 progress __ "archive .dsc names newer git commit";
3269 @mergeinputs = ($dsc_mergeinput);
3271 progress __ "archive .dsc names other git commit, fixing up";
3272 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3276 @mergeinputs = generate_commits_from_dsc();
3277 # We have just done an import. Now, our import algorithm might
3278 # have been improved. But even so we do not want to generate
3279 # a new different import of the same package. So if the
3280 # version numbers are the same, just use our existing version.
3281 # If the version numbers are different, the archive has changed
3282 # (perhaps, rewound).
3283 if ($lastfetch_mergeinput &&
3284 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3285 (mergeinfo_version $mergeinputs[0]) )) {
3286 @mergeinputs = ($lastfetch_mergeinput);
3288 } elsif ($lastpush_hash) {
3289 # only in git, not in the archive yet
3290 @mergeinputs = ($lastpush_mergeinput);
3291 print STDERR f_ <<END,
3293 Package not found in the archive, but has allegedly been pushed using dgit.
3296 __ $later_warning_msg or confess "$!";
3298 printdebug "nothing found!\n";
3299 if (defined $skew_warning_vsn) {
3300 print STDERR f_ <<END, $skew_warning_vsn or confess "$!";
3302 Warning: relevant archive skew detected.
3303 Archive allegedly contains %s
3304 But we were not able to obtain any version from the archive or git.
3308 unshift @end, $del_lrfetchrefs;
3312 if ($lastfetch_hash &&
3314 my $h = $_->{Commit};
3315 $h and is_fast_fwd($lastfetch_hash, $h);
3316 # If true, one of the existing parents of this commit
3317 # is a descendant of the $lastfetch_hash, so we'll
3318 # be ff from that automatically.
3322 push @mergeinputs, $lastfetch_mergeinput;
3325 printdebug "fetch mergeinfos:\n";
3326 foreach my $mi (@mergeinputs) {
3328 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3330 printdebug sprintf " ReverseParents=%d Message=%s",
3331 $mi->{ReverseParents}, $mi->{Message};
3335 my $compat_info= pop @mergeinputs
3336 if $mergeinputs[$#mergeinputs]{Message};
3338 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3341 if (@mergeinputs > 1) {
3343 my $tree_commit = $mergeinputs[0]{Commit};
3345 my $tree = get_tree_of_commit $tree_commit;;
3347 # We use the changelog author of the package in question the
3348 # author of this pseudo-merge. This is (roughly) correct if
3349 # this commit is simply representing aa non-dgit upload.
3350 # (Roughly because it does not record sponsorship - but we
3351 # don't have sponsorship info because that's in the .changes,
3352 # which isn't in the archivw.)
3354 # But, it might be that we are representing archive history
3355 # updates (including in-archive copies). These are not really
3356 # the responsibility of the person who created the .dsc, but
3357 # there is no-one whose name we should better use. (The
3358 # author of the .dsc-named commit is clearly worse.)
3360 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3361 my $author = clogp_authline $useclogp;
3362 my $cversion = getfield $useclogp, 'Version';
3364 my $mcf = dgit_privdir()."/mergecommit";
3365 open MC, ">", $mcf or die "$mcf $!";
3366 print MC <<END or confess "$!";
3370 my @parents = grep { $_->{Commit} } @mergeinputs;
3371 @parents = reverse @parents if $compat_info->{ReverseParents};
3372 print MC <<END or confess "$!" foreach @parents;
3376 print MC <<END or confess "$!";
3382 if (defined $compat_info->{Message}) {
3383 print MC $compat_info->{Message} or confess "$!";
3385 print MC f_ <<END, $package, $cversion, $csuite or confess "$!";
3386 Record %s (%s) in archive suite %s
3390 my $message_add_info = sub {
3392 my $mversion = mergeinfo_version $mi;
3393 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3397 $message_add_info->($mergeinputs[0]);
3398 print MC __ <<END or confess "$!";
3399 should be treated as descended from
3401 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3404 close MC or confess "$!";
3405 $hash = make_commit $mcf;
3407 $hash = $mergeinputs[0]{Commit};
3409 printdebug "fetch hash=$hash\n";
3412 my ($lasth, $what) = @_;
3413 return unless $lasth;
3414 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3417 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3419 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3421 fetch_from_archive_record_1($hash);
3423 if (defined $skew_warning_vsn) {
3424 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3425 my $gotclogp = commit_getclogp($hash);
3426 my $got_vsn = getfield $gotclogp, 'Version';
3427 printdebug "SKEW CHECK GOT $got_vsn\n";
3428 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3429 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess "$!";
3431 Warning: archive skew detected. Using the available version:
3432 Archive allegedly contains %s
3433 We were able to obtain only %s
3439 if ($lastfetch_hash ne $hash) {
3440 fetch_from_archive_record_2($hash);
3443 lrfetchref_used lrfetchref();
3445 check_gitattrs($hash, __ "fetched source tree");
3447 unshift @end, $del_lrfetchrefs;
3451 sub set_local_git_config ($$) {
3453 runcmd @git, qw(config), $k, $v;
3456 sub setup_mergechangelogs (;$) {
3458 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3460 my $driver = 'dpkg-mergechangelogs';
3461 my $cb = "merge.$driver";
3462 confess unless defined $maindir;
3463 my $attrs = "$maindir_gitcommon/info/attributes";
3464 ensuredir "$maindir_gitcommon/info";
3466 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3467 if (!open ATTRS, "<", $attrs) {
3468 $!==ENOENT or die "$attrs: $!";
3472 next if m{^debian/changelog\s};
3473 print NATTRS $_, "\n" or confess "$!";
3475 ATTRS->error and confess "$!";
3478 print NATTRS "debian/changelog merge=$driver\n" or confess "$!";
3481 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3482 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3484 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3487 sub setup_useremail (;$) {
3489 return unless $always || access_cfg_bool(1, 'setup-useremail');
3492 my ($k, $envvar) = @_;
3493 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3494 return unless defined $v;
3495 set_local_git_config "user.$k", $v;
3498 $setup->('email', 'DEBEMAIL');
3499 $setup->('name', 'DEBFULLNAME');
3502 sub ensure_setup_existing_tree () {
3503 my $k = "remote.$remotename.skipdefaultupdate";
3504 my $c = git_get_config $k;
3505 return if defined $c;
3506 set_local_git_config $k, 'true';
3509 sub open_main_gitattrs () {
3510 confess 'internal error no maindir' unless defined $maindir;
3511 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3513 or die "open $maindir_gitcommon/info/attributes: $!";
3517 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3519 sub is_gitattrs_setup () {
3522 # 1: gitattributes set up and should be left alone
3524 # 0: there is a dgit-defuse-attrs but it needs fixing
3525 # undef: there is none
3526 my $gai = open_main_gitattrs();
3527 return 0 unless $gai;
3529 next unless m{$gitattrs_ourmacro_re};
3530 return 1 if m{\s-working-tree-encoding\s};
3531 printdebug "is_gitattrs_setup: found old macro\n";
3534 $gai->error and confess "$!";
3535 printdebug "is_gitattrs_setup: found nothing\n";
3539 sub setup_gitattrs (;$) {
3541 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3543 my $already = is_gitattrs_setup();
3546 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3547 not doing further gitattributes setup
3551 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3552 my $af = "$maindir_gitcommon/info/attributes";
3553 ensuredir "$maindir_gitcommon/info";
3555 open GAO, "> $af.new" or confess "$!";
3556 print GAO <<END, __ <<ENDT or confess "$!" unless defined $already;
3560 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3562 my $gai = open_main_gitattrs();
3565 if (m{$gitattrs_ourmacro_re}) {
3566 die unless defined $already;
3570 print GAO $_, "\n" or confess "$!";
3572 $gai->error and confess "$!";
3574 close GAO or confess "$!";
3575 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3578 sub setup_new_tree () {
3579 setup_mergechangelogs();
3584 sub check_gitattrs ($$) {
3585 my ($treeish, $what) = @_;
3587 return if is_gitattrs_setup;
3590 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3592 my $gafl = new IO::File;
3593 open $gafl, "-|", @cmd or confess "$!";
3596 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3598 next unless m{(?:^|/)\.gitattributes$};
3600 # oh dear, found one
3601 print STDERR f_ <<END, $what;
3602 dgit: warning: %s contains .gitattributes
3603 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3608 # tree contains no .gitattributes files
3609 $?=0; $!=0; close $gafl or failedcmd @cmd;
3613 sub multisuite_suite_child ($$$) {
3614 my ($tsuite, $mergeinputs, $fn) = @_;
3615 # in child, sets things up, calls $fn->(), and returns undef
3616 # in parent, returns canonical suite name for $tsuite
3617 my $canonsuitefh = IO::File::new_tmpfile;
3618 my $pid = fork // confess "$!";
3622 $us .= " [$isuite]";
3623 $debugprefix .= " ";
3624 progress f_ "fetching %s...", $tsuite;
3625 canonicalise_suite();
3626 print $canonsuitefh $csuite, "\n" or confess "$!";
3627 close $canonsuitefh or confess "$!";
3631 waitpid $pid,0 == $pid or confess "$!";
3632 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3634 seek $canonsuitefh,0,0 or confess "$!";
3635 local $csuite = <$canonsuitefh>;
3636 confess "$!" unless defined $csuite && chomp $csuite;
3638 printdebug "multisuite $tsuite missing\n";
3641 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3642 push @$mergeinputs, {
3649 sub fork_for_multisuite ($) {
3650 my ($before_fetch_merge) = @_;
3651 # if nothing unusual, just returns ''
3654 # returns 0 to caller in child, to do first of the specified suites
3655 # in child, $csuite is not yet set
3657 # returns 1 to caller in parent, to finish up anything needed after
3658 # in parent, $csuite is set to canonicalised portmanteau
3660 my $org_isuite = $isuite;
3661 my @suites = split /\,/, $isuite;
3662 return '' unless @suites > 1;
3663 printdebug "fork_for_multisuite: @suites\n";
3667 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3669 return 0 unless defined $cbasesuite;
3671 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3672 unless @mergeinputs;
3674 my @csuites = ($cbasesuite);
3676 $before_fetch_merge->();
3678 foreach my $tsuite (@suites[1..$#suites]) {
3679 $tsuite =~ s/^-/$cbasesuite-/;
3680 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3687 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3688 push @csuites, $csubsuite;
3691 foreach my $mi (@mergeinputs) {
3692 my $ref = git_get_ref $mi->{Ref};
3693 die "$mi->{Ref} ?" unless length $ref;
3694 $mi->{Commit} = $ref;
3697 $csuite = join ",", @csuites;
3699 my $previous = git_get_ref lrref;
3701 unshift @mergeinputs, {
3702 Commit => $previous,
3703 Info => (__ "local combined tracking branch"),
3705 "archive seems to have rewound: local tracking branch is ahead!"),
3709 foreach my $ix (0..$#mergeinputs) {
3710 $mergeinputs[$ix]{Index} = $ix;
3713 @mergeinputs = sort {
3714 -version_compare(mergeinfo_version $a,
3715 mergeinfo_version $b) # highest version first
3717 $a->{Index} <=> $b->{Index}; # earliest in spec first
3723 foreach my $mi (@mergeinputs) {
3724 printdebug "multisuite merge check $mi->{Info}\n";
3725 foreach my $previous (@needed) {
3726 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3727 printdebug "multisuite merge un-needed $previous->{Info}\n";
3731 printdebug "multisuite merge this-needed\n";
3732 $mi->{Character} = '+';
3735 $needed[0]{Character} = '*';
3737 my $output = $needed[0]{Commit};
3740 printdebug "multisuite merge nontrivial\n";
3741 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3743 my $commit = "tree $tree\n";
3744 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3745 "Input branches:\n",
3748 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3749 printdebug "multisuite merge include $mi->{Info}\n";
3750 $mi->{Character} //= ' ';
3751 $commit .= "parent $mi->{Commit}\n";
3752 $msg .= sprintf " %s %-25s %s\n",
3754 (mergeinfo_version $mi),
3757 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3758 $msg .= __ "\nKey\n".
3759 " * marks the highest version branch, which choose to use\n".
3760 " + marks each branch which was not already an ancestor\n\n";
3762 "[dgit multi-suite $csuite]\n";
3764 "author $authline\n".
3765 "committer $authline\n\n";
3766 $output = make_commit_text $commit.$msg;
3767 printdebug "multisuite merge generated $output\n";
3770 fetch_from_archive_record_1($output);
3771 fetch_from_archive_record_2($output);
3773 progress f_ "calculated combined tracking suite %s", $csuite;
3778 sub clone_set_head () {
3779 open H, "> .git/HEAD" or confess "$!";
3780 print H "ref: ".lref()."\n" or confess "$!";
3781 close H or confess "$!";
3783 sub clone_finish ($) {
3785 runcmd @git, qw(reset --hard), lrref();
3786 runcmd qw(bash -ec), <<'END';
3788 git ls-tree -r --name-only -z HEAD | \
3789 xargs -0r touch -h -r . --
3791 printdone f_ "ready for work in %s", $dstdir;
3795 # in multisuite, returns twice!
3796 # once in parent after first suite fetched,
3797 # and then again in child after everything is finished
3799 badusage __ "dry run makes no sense with clone" unless act_local();
3801 my $multi_fetched = fork_for_multisuite(sub {
3802 printdebug "multi clone before fetch merge\n";
3806 if ($multi_fetched) {
3807 printdebug "multi clone after fetch merge\n";
3809 clone_finish($dstdir);
3812 printdebug "clone main body\n";
3814 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3818 canonicalise_suite();
3819 my $hasgit = check_for_git();
3821 runcmd @git, qw(init -q);
3825 my $giturl = access_giturl(1);
3826 if (defined $giturl) {
3827 runcmd @git, qw(remote add), 'origin', $giturl;
3830 progress __ "fetching existing git history";
3832 runcmd_ordryrun_local @git, qw(fetch origin);
3834 progress __ "starting new git history";
3836 fetch_from_archive() or no_such_package;
3837 my $vcsgiturl = $dsc->{'Vcs-Git'};
3838 if (length $vcsgiturl) {
3839 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3840 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3842 clone_finish($dstdir);
3846 canonicalise_suite();
3847 if (check_for_git()) {
3850 fetch_from_archive() or no_such_package();
3852 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3853 if (length $vcsgiturl and
3854 (grep { $csuite eq $_ }
3856 cfg 'dgit.vcs-git.suites')) {
3857 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3858 if (defined $current && $current ne $vcsgiturl) {
3859 print STDERR f_ <<END, $csuite;
3860 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3861 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3865 printdone f_ "fetched into %s", lrref();
3869 my $multi_fetched = fork_for_multisuite(sub { });
3870 fetch_one() unless $multi_fetched; # parent
3871 finish 0 if $multi_fetched eq '0'; # child
3876 runcmd_ordryrun_local @git, qw(merge -m),
3877 (f_ "Merge from %s [dgit]", $csuite),
3879 printdone f_ "fetched to %s and merged into HEAD", lrref();
3882 sub check_not_dirty () {
3883 my @forbid = qw(local-options local-patch-header);
3884 @forbid = map { "debian/source/$_" } @forbid;
3885 foreach my $f (@forbid) {
3886 if (stat_exists $f) {
3887 fail f_ "git tree contains %s", $f;
3891 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3892 push @cmd, qw(debian/source/format debian/source/options);
3895 my $bad = cmdoutput @cmd;
3898 "you have uncommitted changes to critical files, cannot continue:\n").
3902 return if $includedirty;
3904 git_check_unmodified();
3907 sub commit_admin ($) {
3910 runcmd_ordryrun_local @git, qw(commit -m), $m;
3913 sub quiltify_nofix_bail ($$) {
3914 my ($headinfo, $xinfo) = @_;
3915 if ($quilt_mode eq 'nofix') {
3917 "quilt fixup required but quilt mode is \`nofix'\n".
3918 "HEAD commit%s differs from tree implied by debian/patches%s",
3923 sub commit_quilty_patch () {
3924 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3926 foreach my $l (split /\n/, $output) {
3927 next unless $l =~ m/\S/;
3928 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3932 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3934 progress __ "nothing quilty to commit, ok.";
3937 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3938 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3939 runcmd_ordryrun_local @git, qw(add -f), @adds;
3940 commit_admin +(__ <<ENDT).<<END
3941 Commit Debian 3.0 (quilt) metadata
3944 [dgit ($our_version) quilt-fixup]
3948 sub get_source_format () {
3950 if (open F, "debian/source/options") {
3954 s/\s+$//; # ignore missing final newline
3956 my ($k, $v) = ($`, $'); #');
3957 $v =~ s/^"(.*)"$/$1/;
3963 F->error and confess "$!";
3966 confess "$!" unless $!==&ENOENT;
3969 if (!open F, "debian/source/format") {
3970 confess "$!" unless $!==&ENOENT;
3974 F->error and confess "$!";
3976 return ($_, \%options);
3979 sub madformat_wantfixup ($) {
3981 return 0 unless $format eq '3.0 (quilt)';
3982 our $quilt_mode_warned;
3983 if ($quilt_mode eq 'nocheck') {
3984 progress f_ "Not doing any fixup of \`%s'".
3985 " due to ----no-quilt-fixup or --quilt=nocheck", $format
3986 unless $quilt_mode_warned++;
3989 progress f_ "Format \`%s', need to check/update patch stack", $format
3990 unless $quilt_mode_warned++;
3994 sub maybe_split_brain_save ($$$) {
3995 my ($headref, $dgitview, $msg) = @_;
3996 # => message fragment "$saved" describing disposition of $dgitview
3997 # (used inside parens, in the English texts)
3998 my $save = $internal_object_save{'dgit-view'};
3999 return f_ "commit id %s", $dgitview unless defined $save;
4000 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4002 "dgit --dgit-view-save $msg HEAD=$headref",
4005 return f_ "and left in %s", $save;
4008 # An "infopair" is a tuple [ $thing, $what ]
4009 # (often $thing is a commit hash; $what is a description)
4011 sub infopair_cond_equal ($$) {
4013 $x->[0] eq $y->[0] or fail <<END;
4014 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4018 sub infopair_lrf_tag_lookup ($$) {
4019 my ($tagnames, $what) = @_;
4020 # $tagname may be an array ref
4021 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4022 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4023 foreach my $tagname (@tagnames) {
4024 my $lrefname = lrfetchrefs."/tags/$tagname";
4025 my $tagobj = $lrfetchrefs_f{$lrefname};
4026 next unless defined $tagobj;
4027 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4028 return [ git_rev_parse($tagobj), $what ];
4030 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4031 Wanted tag %s (%s) on dgit server, but not found
4033 : (f_ <<END, $what, "@tagnames");
4034 Wanted tag %s (one of: %s) on dgit server, but not found
4038 sub infopair_cond_ff ($$) {
4039 my ($anc,$desc) = @_;
4040 is_fast_fwd($anc->[0], $desc->[0]) or
4041 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4042 %s (%s) .. %s (%s) is not fast forward
4046 sub pseudomerge_version_check ($$) {
4047 my ($clogp, $archive_hash) = @_;
4049 my $arch_clogp = commit_getclogp $archive_hash;
4050 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4051 __ 'version currently in archive' ];
4052 if (defined $overwrite_version) {
4053 if (length $overwrite_version) {
4054 infopair_cond_equal([ $overwrite_version,
4055 '--overwrite= version' ],
4058 my $v = $i_arch_v->[0];
4060 "Checking package changelog for archive version %s ...", $v;
4063 my @xa = ("-f$v", "-t$v");
4064 my $vclogp = parsechangelog @xa;
4067 [ (getfield $vclogp, $fn),
4068 (f_ "%s field from dpkg-parsechangelog %s",
4071 my $cv = $gf->('Version');
4072 infopair_cond_equal($i_arch_v, $cv);
4073 $cd = $gf->('Distribution');
4077 $@ =~ s/^dgit: //gm;
4079 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4081 fail f_ <<END, $cd->[1], $cd->[0], $v
4083 Your tree seems to based on earlier (not uploaded) %s.
4085 if $cd->[0] =~ m/UNRELEASED/;
4089 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4093 sub pseudomerge_make_commit ($$$$ $$) {
4094 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4095 $msg_cmd, $msg_msg) = @_;
4096 progress f_ "Declaring that HEAD includes all changes in %s...",
4099 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4100 my $authline = clogp_authline $clogp;
4104 !defined $overwrite_version ? ""
4105 : !length $overwrite_version ? " --overwrite"
4106 : " --overwrite=".$overwrite_version;
4108 # Contributing parent is the first parent - that makes
4109 # git rev-list --first-parent DTRT.
4110 my $pmf = dgit_privdir()."/pseudomerge";
4111 open MC, ">", $pmf or die "$pmf $!";
4112 print MC <<END or confess "$!";
4115 parent $archive_hash
4123 close MC or confess "$!";
4125 return make_commit($pmf);
4128 sub splitbrain_pseudomerge ($$$$) {
4129 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4130 # => $merged_dgitview
4131 printdebug "splitbrain_pseudomerge...\n";
4133 # We: debian/PREVIOUS HEAD($maintview)
4134 # expect: o ----------------- o
4137 # a/d/PREVIOUS $dgitview
4140 # we do: `------------------ o
4144 return $dgitview unless defined $archive_hash;
4145 return $dgitview if deliberately_not_fast_forward();
4147 printdebug "splitbrain_pseudomerge...\n";
4149 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4151 if (!defined $overwrite_version) {
4152 progress __ "Checking that HEAD includes all changes in archive...";
4155 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4157 if (defined $overwrite_version) {
4159 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4160 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4161 __ "maintainer view tag");
4162 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4163 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4164 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4166 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4168 infopair_cond_equal($i_dgit, $i_archive);
4169 infopair_cond_ff($i_dep14, $i_dgit);
4170 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4173 $@ =~ s/^\n//; chomp $@;
4174 print STDERR <<END.(__ <<ENDT);
4177 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4182 my $arch_v = $i_arch_v->[0];
4183 my $r = pseudomerge_make_commit
4184 $clogp, $dgitview, $archive_hash, $i_arch_v,
4185 "dgit --quilt=$quilt_mode",
4186 (defined $overwrite_version
4187 ? f_ "Declare fast forward from %s\n", $arch_v
4188 : f_ "Make fast forward from %s\n", $arch_v);
4190 maybe_split_brain_save $maintview, $r, "pseudomerge";
4192 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4196 sub plain_overwrite_pseudomerge ($$$) {
4197 my ($clogp, $head, $archive_hash) = @_;
4199 printdebug "plain_overwrite_pseudomerge...";
4201 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4203 return $head if is_fast_fwd $archive_hash, $head;
4205 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4207 my $r = pseudomerge_make_commit
4208 $clogp, $head, $archive_hash, $i_arch_v,
4211 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4213 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4217 sub push_parse_changelog ($) {
4220 my $clogp = Dpkg::Control::Hash->new();
4221 $clogp->load($clogpfn) or die;
4223 my $clogpackage = getfield $clogp, 'Source';
4224 $package //= $clogpackage;
4225 fail f_ "-p specified %s but changelog specified %s",
4226 $package, $clogpackage
4227 unless $package eq $clogpackage;
4228 my $cversion = getfield $clogp, 'Version';
4230 if (!$we_are_initiator) {
4231 # rpush initiator can't do this because it doesn't have $isuite yet
4232 my $tag = debiantag_new($cversion, access_nomdistro);
4233 runcmd @git, qw(check-ref-format), $tag;
4236 my $dscfn = dscfn($cversion);
4238 return ($clogp, $cversion, $dscfn);
4241 sub push_parse_dsc ($$$) {
4242 my ($dscfn,$dscfnwhat, $cversion) = @_;
4243 $dsc = parsecontrol($dscfn,$dscfnwhat);
4244 my $dversion = getfield $dsc, 'Version';
4245 my $dscpackage = getfield $dsc, 'Source';
4246 ($dscpackage eq $package && $dversion eq $cversion) or
4247 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4248 $dscfn, $dscpackage, $dversion,
4249 $package, $cversion;
4252 sub push_tagwants ($$$$) {
4253 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4256 TagFn => \&debiantag_new,
4261 if (defined $maintviewhead) {
4263 TagFn => \&debiantag_maintview,
4264 Objid => $maintviewhead,
4265 TfSuffix => '-maintview',
4268 } elsif ($dodep14tag ne 'no') {
4270 TagFn => \&debiantag_maintview,
4272 TfSuffix => '-dgit',
4276 foreach my $tw (@tagwants) {
4277 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4278 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4280 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4284 sub push_mktags ($$ $$ $) {
4286 $changesfile,$changesfilewhat,
4289 die unless $tagwants->[0]{View} eq 'dgit';
4291 my $declaredistro = access_nomdistro();
4292 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4293 $dsc->{$ourdscfield[0]} = join " ",
4294 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4296 $dsc->save("$dscfn.tmp") or confess "$!";
4298 my $changes = parsecontrol($changesfile,$changesfilewhat);
4299 foreach my $field (qw(Source Distribution Version)) {
4300 $changes->{$field} eq $clogp->{$field} or
4301 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4302 $field, $changes->{$field}, $clogp->{$field};
4305 my $cversion = getfield $clogp, 'Version';
4306 my $clogsuite = getfield $clogp, 'Distribution';
4308 # We make the git tag by hand because (a) that makes it easier
4309 # to control the "tagger" (b) we can do remote signing
4310 my $authline = clogp_authline $clogp;
4311 my $delibs = join(" ", "",@deliberatelies);
4315 my $tfn = $tw->{Tfn};
4316 my $head = $tw->{Objid};
4317 my $tag = $tw->{Tag};
4319 open TO, '>', $tfn->('.tmp') or confess "$!";
4320 print TO <<END or confess "$!";
4327 if ($tw->{View} eq 'dgit') {
4328 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4329 %s release %s for %s (%s) [dgit]
4332 print TO <<END or confess "$!";
4333 [dgit distro=$declaredistro$delibs]
4335 foreach my $ref (sort keys %previously) {
4336 print TO <<END or confess "$!";
4337 [dgit previously:$ref=$previously{$ref}]
4340 } elsif ($tw->{View} eq 'maint') {
4341 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4342 %s release %s for %s (%s)
4343 (maintainer view tag generated by dgit --quilt=%s)
4348 confess Dumper($tw)."?";
4351 close TO or confess "$!";
4353 my $tagobjfn = $tfn->('.tmp');
4355 if (!defined $keyid) {
4356 $keyid = access_cfg('keyid','RETURN-UNDEF');
4358 if (!defined $keyid) {
4359 $keyid = getfield $clogp, 'Maintainer';
4361 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess "$!";
4362 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4363 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4364 push @sign_cmd, $tfn->('.tmp');
4365 runcmd_ordryrun @sign_cmd;
4367 $tagobjfn = $tfn->('.signed.tmp');
4368 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4369 $tfn->('.tmp'), $tfn->('.tmp.asc');
4375 my @r = map { $mktag->($_); } @$tagwants;
4379 sub sign_changes ($) {
4380 my ($changesfile) = @_;
4382 my @debsign_cmd = @debsign;
4383 push @debsign_cmd, "-k$keyid" if defined $keyid;
4384 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4385 push @debsign_cmd, $changesfile;
4386 runcmd_ordryrun @debsign_cmd;
4391 printdebug "actually entering push\n";
4393 supplementary_message(__ <<'END');
4394 Push failed, while checking state of the archive.
4395 You can retry the push, after fixing the problem, if you like.
4397 if (check_for_git()) {
4400 my $archive_hash = fetch_from_archive();
4401 if (!$archive_hash) {
4403 fail __ "package appears to be new in this suite;".
4404 " if this is intentional, use --new";
4407 supplementary_message(__ <<'END');
4408 Push failed, while preparing your push.
4409 You can retry the push, after fixing the problem, if you like.
4414 access_giturl(); # check that success is vaguely likely
4415 rpush_handle_protovsn_bothends() if $we_are_initiator;
4417 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4418 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4420 responder_send_file('parsed-changelog', $clogpfn);
4422 my ($clogp, $cversion, $dscfn) =
4423 push_parse_changelog("$clogpfn");
4425 my $dscpath = "$buildproductsdir/$dscfn";
4426 stat_exists $dscpath or
4427 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4430 responder_send_file('dsc', $dscpath);
4432 push_parse_dsc($dscpath, $dscfn, $cversion);
4434 my $format = getfield $dsc, 'Format';
4436 my $symref = git_get_symref();
4437 my $actualhead = git_rev_parse('HEAD');
4439 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4440 if (quiltmode_splitbrain()) {
4441 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4442 fail f_ <<END, $ffq_prev, $quilt_mode;
4443 Branch is managed by git-debrebase (%s
4444 exists), but quilt mode (%s) implies a split view.
4445 Pass the right --quilt option or adjust your git config.
4446 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4449 runcmd_ordryrun_local @git_debrebase, 'stitch';
4450 $actualhead = git_rev_parse('HEAD');
4453 my $dgithead = $actualhead;
4454 my $maintviewhead = undef;
4456 my $upstreamversion = upstreamversion $clogp->{Version};
4458 if (madformat_wantfixup($format)) {
4459 # user might have not used dgit build, so maybe do this now:
4460 if ($do_split_brain) {
4461 changedir $playground;
4463 ($dgithead, $cachekey) =
4464 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4465 $dgithead or fail f_
4466 "--quilt=%s but no cached dgit view:
4467 perhaps HEAD changed since dgit build[-source] ?",
4470 if (!$do_split_brain) {
4471 # In split brain mode, do not attempt to incorporate dirty
4472 # stuff from the user's working tree. That would be mad.
4473 commit_quilty_patch();
4476 if ($do_split_brain) {
4477 $made_split_brain = 1;
4478 $dgithead = splitbrain_pseudomerge($clogp,
4479 $actualhead, $dgithead,
4481 $maintviewhead = $actualhead;
4483 prep_ud(); # so _only_subdir() works, below
4486 if (defined $overwrite_version && !defined $maintviewhead
4488 $dgithead = plain_overwrite_pseudomerge($clogp,
4496 if ($archive_hash) {
4497 if (is_fast_fwd($archive_hash, $dgithead)) {
4499 } elsif (deliberately_not_fast_forward) {
4502 fail __ "dgit push: HEAD is not a descendant".
4503 " of the archive's version.\n".
4504 "To overwrite the archive's contents,".
4505 " pass --overwrite[=VERSION].\n".
4506 "To rewind history, if permitted by the archive,".
4507 " use --deliberately-not-fast-forward.";
4511 confess unless !!$made_split_brain == !!$do_split_brain;
4513 changedir $playground;
4514 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4515 runcmd qw(dpkg-source -x --),
4516 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4517 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4518 check_for_vendor_patches() if madformat($dsc->{format});
4520 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4521 debugcmd "+",@diffcmd;
4523 my $r = system @diffcmd;
4526 my $referent = $made_split_brain ? $dgithead : 'HEAD';
4527 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4530 my $raw = cmdoutput @git,
4531 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4533 foreach (split /\0/, $raw) {
4534 if (defined $changed) {
4535 push @mode_changes, "$changed: $_\n" if $changed;
4538 } elsif (m/^:0+ 0+ /) {
4540 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4541 $changed = "Mode change from $1 to $2"
4546 if (@mode_changes) {
4547 fail +(f_ <<ENDT, $dscfn).<<END
4548 HEAD specifies a different tree to %s:
4552 .(join '', @mode_changes)
4553 .(f_ <<ENDT, $tree, $referent);
4554 There is a problem with your source tree (see dgit(7) for some hints).
4555 To see a full diff, run git diff %s %s
4559 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4560 HEAD specifies a different tree to %s:
4564 Perhaps you forgot to build. Or perhaps there is a problem with your
4565 source tree (see dgit(7) for some hints). To see a full diff, run
4572 if (!$changesfile) {
4573 my $pat = changespat $cversion;
4574 my @cs = glob "$buildproductsdir/$pat";
4575 fail f_ "failed to find unique changes file".
4576 " (looked for %s in %s);".
4577 " perhaps you need to use dgit -C",
4578 $pat, $buildproductsdir
4580 ($changesfile) = @cs;
4582 $changesfile = "$buildproductsdir/$changesfile";
4585 # Check that changes and .dsc agree enough
4586 $changesfile =~ m{[^/]*$};
4587 my $changes = parsecontrol($changesfile,$&);
4588 files_compare_inputs($dsc, $changes)
4589 unless forceing [qw(dsc-changes-mismatch)];
4591 # Check whether this is a source only upload
4592 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4593 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4594 if ($sourceonlypolicy eq 'ok') {
4595 } elsif ($sourceonlypolicy eq 'always') {
4596 forceable_fail [qw(uploading-binaries)],
4597 __ "uploading binaries, although distro policy is source only"
4599 } elsif ($sourceonlypolicy eq 'never') {
4600 forceable_fail [qw(uploading-source-only)],
4601 __ "source-only upload, although distro policy requires .debs"
4603 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4604 forceable_fail [qw(uploading-source-only)],
4605 f_ "source-only upload, even though package is entirely NEW\n".
4606 "(this is contrary to policy in %s)",
4610 && !(archive_query('package_not_wholly_new', $package) // 1);
4612 badcfg f_ "unknown source-only-uploads policy \`%s'",
4616 # Perhaps adjust .dsc to contain right set of origs
4617 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4619 unless forceing [qw(changes-origs-exactly)];
4621 # Checks complete, we're going to try and go ahead:
4623 responder_send_file('changes',$changesfile);
4624 responder_send_command("param head $dgithead");
4625 responder_send_command("param csuite $csuite");
4626 responder_send_command("param isuite $isuite");
4627 responder_send_command("param tagformat new"); # needed in $protovsn==4
4628 if (defined $maintviewhead) {
4629 responder_send_command("param maint-view $maintviewhead");
4632 # Perhaps send buildinfo(s) for signing
4633 my $changes_files = getfield $changes, 'Files';
4634 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4635 foreach my $bi (@buildinfos) {
4636 responder_send_command("param buildinfo-filename $bi");
4637 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4640 if (deliberately_not_fast_forward) {
4641 git_for_each_ref(lrfetchrefs, sub {
4642 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4643 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4644 responder_send_command("previously $rrefname=$objid");
4645 $previously{$rrefname} = $objid;
4649 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4650 dgit_privdir()."/tag");
4653 supplementary_message(__ <<'END');
4654 Push failed, while signing the tag.
4655 You can retry the push, after fixing the problem, if you like.
4657 # If we manage to sign but fail to record it anywhere, it's fine.
4658 if ($we_are_responder) {
4659 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4660 responder_receive_files('signed-tag', @tagobjfns);
4662 @tagobjfns = push_mktags($clogp,$dscpath,
4663 $changesfile,$changesfile,
4666 supplementary_message(__ <<'END');
4667 Push failed, *after* signing the tag.
4668 If you want to try again, you should use a new version number.
4671 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4673 foreach my $tw (@tagwants) {
4674 my $tag = $tw->{Tag};
4675 my $tagobjfn = $tw->{TagObjFn};
4677 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4678 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4679 runcmd_ordryrun_local
4680 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4683 supplementary_message(__ <<'END');
4684 Push failed, while updating the remote git repository - see messages above.
4685 If you want to try again, you should use a new version number.
4687 if (!check_for_git()) {
4688 create_remote_git_repo();
4691 my @pushrefs = $forceflag.$dgithead.":".rrref();
4692 foreach my $tw (@tagwants) {
4693 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4696 runcmd_ordryrun @git,
4697 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4698 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4700 supplementary_message(__ <<'END');
4701 Push failed, while obtaining signatures on the .changes and .dsc.
4702 If it was just that the signature failed, you may try again by using
4703 debsign by hand to sign the changes file (see the command dgit tried,
4704 above), and then dput that changes file to complete the upload.
4705 If you need to change the package, you must use a new version number.
4707 if ($we_are_responder) {
4708 my $dryrunsuffix = act_local() ? "" : ".tmp";
4709 my @rfiles = ($dscpath, $changesfile);
4710 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4711 responder_receive_files('signed-dsc-changes',
4712 map { "$_$dryrunsuffix" } @rfiles);
4715 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4717 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4719 sign_changes $changesfile;
4722 supplementary_message(f_ <<END, $changesfile);
4723 Push failed, while uploading package(s) to the archive server.
4724 You can retry the upload of exactly these same files with dput of:
4726 If that .changes file is broken, you will need to use a new version
4727 number for your next attempt at the upload.
4729 my $host = access_cfg('upload-host','RETURN-UNDEF');
4730 my @hostarg = defined($host) ? ($host,) : ();
4731 runcmd_ordryrun @dput, @hostarg, $changesfile;
4732 printdone f_ "pushed and uploaded %s", $cversion;
4734 supplementary_message('');
4735 responder_send_command("complete");
4739 not_necessarily_a_tree();
4744 badusage __ "-p is not allowed with clone; specify as argument instead"
4745 if defined $package;
4748 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4749 ($package,$isuite) = @ARGV;
4750 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4751 ($package,$dstdir) = @ARGV;
4752 } elsif (@ARGV==3) {
4753 ($package,$isuite,$dstdir) = @ARGV;
4755 badusage __ "incorrect arguments to dgit clone";
4759 $dstdir ||= "$package";
4760 if (stat_exists $dstdir) {
4761 fail f_ "%s already exists", $dstdir;
4765 if ($rmonerror && !$dryrun_level) {
4766 $cwd_remove= getcwd();
4768 return unless defined $cwd_remove;
4769 if (!chdir "$cwd_remove") {
4770 return if $!==&ENOENT;
4771 confess "chdir $cwd_remove: $!";
4773 printdebug "clone rmonerror removing $dstdir\n";
4775 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4776 } elsif (grep { $! == $_ }
4777 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4779 print STDERR f_ "check whether to remove %s: %s\n",
4786 $cwd_remove = undef;
4789 sub branchsuite () {
4790 my $branch = git_get_symref();
4791 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4798 sub package_from_d_control () {
4799 if (!defined $package) {
4800 my $sourcep = parsecontrol('debian/control','debian/control');
4801 $package = getfield $sourcep, 'Source';
4805 sub fetchpullargs () {
4806 package_from_d_control();
4808 $isuite = branchsuite();
4810 my $clogp = parsechangelog();
4811 my $clogsuite = getfield $clogp, 'Distribution';
4812 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4814 } elsif (@ARGV==1) {
4817 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4831 if (quiltmode_splitbrain()) {
4832 my ($format, $fopts) = get_source_format();
4833 madformat($format) and fail f_ <<END, $quilt_mode
4834 dgit pull not yet supported in split view mode (--quilt=%s)
4842 package_from_d_control();
4843 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4847 foreach my $canon (qw(0 1)) {
4852 canonicalise_suite();
4854 if (length git_get_ref lref()) {
4855 # local branch already exists, yay
4858 if (!length git_get_ref lrref()) {
4866 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4869 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4870 "dgit checkout $isuite";
4871 runcmd (@git, qw(checkout), lbranch());
4874 sub cmd_update_vcs_git () {
4876 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4877 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4879 ($specsuite) = (@ARGV);
4884 if ($ARGV[0] eq '-') {
4886 } elsif ($ARGV[0] eq '-') {
4891 package_from_d_control();
4893 if ($specsuite eq '.') {
4894 $ctrl = parsecontrol 'debian/control', 'debian/control';
4896 $isuite = $specsuite;
4900 my $url = getfield $ctrl, 'Vcs-Git';
4903 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4904 if (!defined $orgurl) {
4905 print STDERR f_ "setting up vcs-git: %s\n", $url;
4906 @cmd = (@git, qw(remote add vcs-git), $url);
4907 } elsif ($orgurl eq $url) {
4908 print STDERR f_ "vcs git already configured: %s\n", $url;
4910 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4911 @cmd = (@git, qw(remote set-url vcs-git), $url);
4913 runcmd_ordryrun_local @cmd;
4915 print f_ "fetching (%s)\n", "@ARGV";
4916 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4922 build_or_push_prep_early();
4924 build_or_push_prep_modes();
4928 } elsif (@ARGV==1) {
4929 ($specsuite) = (@ARGV);
4931 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4934 local ($package) = $existing_package; # this is a hack
4935 canonicalise_suite();
4937 canonicalise_suite();
4939 if (defined $specsuite &&
4940 $specsuite ne $isuite &&
4941 $specsuite ne $csuite) {
4942 fail f_ "dgit %s: changelog specifies %s (%s)".
4943 " but command line specifies %s",
4944 $subcommand, $isuite, $csuite, $specsuite;
4953 #---------- remote commands' implementation ----------
4955 sub pre_remote_push_build_host {
4956 my ($nrargs) = shift @ARGV;
4957 my (@rargs) = @ARGV[0..$nrargs-1];
4958 @ARGV = @ARGV[$nrargs..$#ARGV];
4960 my ($dir,$vsnwant) = @rargs;
4961 # vsnwant is a comma-separated list; we report which we have
4962 # chosen in our ready response (so other end can tell if they
4965 $we_are_responder = 1;
4966 $us .= " (build host)";
4968 open PI, "<&STDIN" or confess "$!";
4969 open STDIN, "/dev/null" or confess "$!";
4970 open PO, ">&STDOUT" or confess "$!";
4972 open STDOUT, ">&STDERR" or confess "$!";
4976 ($protovsn) = grep {
4977 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4978 } @rpushprotovsn_support;
4980 fail f_ "build host has dgit rpush protocol versions %s".
4981 " but invocation host has %s",
4982 (join ",", @rpushprotovsn_support), $vsnwant
4983 unless defined $protovsn;
4987 sub cmd_remote_push_build_host {
4988 responder_send_command("dgit-remote-push-ready $protovsn");
4992 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4993 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4994 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4995 # a good error message)
4997 sub rpush_handle_protovsn_bothends () {
5004 my $report = i_child_report();
5005 if (defined $report) {
5006 printdebug "($report)\n";
5007 } elsif ($i_child_pid) {
5008 printdebug "(killing build host child $i_child_pid)\n";
5009 kill 15, $i_child_pid;
5011 if (defined $i_tmp && !defined $initiator_tempdir) {
5013 eval { rmtree $i_tmp; };
5018 return unless forkcheck_mainprocess();
5023 my ($base,$selector,@args) = @_;
5024 $selector =~ s/\-/_/g;
5025 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5029 not_necessarily_a_tree();
5034 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5042 push @rargs, join ",", @rpushprotovsn_support;
5045 push @rdgit, @ropts;
5046 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5048 my @cmd = (@ssh, $host, shellquote @rdgit);
5051 $we_are_initiator=1;
5053 if (defined $initiator_tempdir) {
5054 rmtree $initiator_tempdir;
5055 mkdir $initiator_tempdir, 0700
5056 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5057 $i_tmp = $initiator_tempdir;
5061 $i_child_pid = open2(\*RO, \*RI, @cmd);
5063 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5064 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5067 my ($icmd,$iargs) = initiator_expect {
5068 m/^(\S+)(?: (.*))?$/;
5071 i_method "i_resp", $icmd, $iargs;
5075 sub i_resp_progress ($) {
5077 my $msg = protocol_read_bytes \*RO, $rhs;
5081 sub i_resp_supplementary_message ($) {
5083 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5086 sub i_resp_complete {
5087 my $pid = $i_child_pid;
5088 $i_child_pid = undef; # prevents killing some other process with same pid
5089 printdebug "waiting for build host child $pid...\n";
5090 my $got = waitpid $pid, 0;
5091 confess "$!" unless $got == $pid;
5092 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5095 printdebug __ "all done\n";
5099 sub i_resp_file ($) {
5101 my $localname = i_method "i_localname", $keyword;
5102 my $localpath = "$i_tmp/$localname";
5103 stat_exists $localpath and
5104 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5105 protocol_receive_file \*RO, $localpath;
5106 i_method "i_file", $keyword;
5111 sub i_resp_param ($) {
5112 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5116 sub i_resp_previously ($) {
5117 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5118 or badproto \*RO, __ "bad previously spec";
5119 my $r = system qw(git check-ref-format), $1;
5120 confess "bad previously ref spec ($r)" if $r;
5121 $previously{$1} = $2;
5126 sub i_resp_want ($) {
5128 die "$keyword ?" if $i_wanted{$keyword}++;
5130 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5131 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5132 die unless $isuite =~ m/^$suite_re$/;
5135 rpush_handle_protovsn_bothends();
5137 my @localpaths = i_method "i_want", $keyword;
5138 printdebug "[[ $keyword @localpaths\n";
5139 foreach my $localpath (@localpaths) {
5140 protocol_send_file \*RI, $localpath;
5142 print RI "files-end\n" or confess "$!";
5145 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5147 sub i_localname_parsed_changelog {
5148 return "remote-changelog.822";
5150 sub i_file_parsed_changelog {
5151 ($i_clogp, $i_version, $i_dscfn) =
5152 push_parse_changelog "$i_tmp/remote-changelog.822";
5153 die if $i_dscfn =~ m#/|^\W#;
5156 sub i_localname_dsc {
5157 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5162 sub i_localname_buildinfo ($) {
5163 my $bi = $i_param{'buildinfo-filename'};
5164 defined $bi or badproto \*RO, "buildinfo before filename";
5165 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5166 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5167 or badproto \*RO, "improper buildinfo filename";
5170 sub i_file_buildinfo {
5171 my $bi = $i_param{'buildinfo-filename'};
5172 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5173 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5174 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5175 files_compare_inputs($bd, $ch);
5176 (getfield $bd, $_) eq (getfield $ch, $_) or
5177 fail f_ "buildinfo mismatch in field %s", $_
5178 foreach qw(Source Version);
5179 !defined $bd->{$_} or
5180 fail f_ "buildinfo contains forbidden field %s", $_
5181 foreach qw(Changes Changed-by Distribution);
5183 push @i_buildinfos, $bi;
5184 delete $i_param{'buildinfo-filename'};
5187 sub i_localname_changes {
5188 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5189 $i_changesfn = $i_dscfn;
5190 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5191 return $i_changesfn;
5193 sub i_file_changes { }
5195 sub i_want_signed_tag {
5196 printdebug Dumper(\%i_param, $i_dscfn);
5197 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5198 && defined $i_param{'csuite'}
5199 or badproto \*RO, "premature desire for signed-tag";
5200 my $head = $i_param{'head'};
5201 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5203 my $maintview = $i_param{'maint-view'};
5204 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5206 if ($protovsn == 4) {
5207 my $p = $i_param{'tagformat'} // '<undef>';
5209 or badproto \*RO, "tag format mismatch: $p vs. new";
5212 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5214 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5216 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5219 push_mktags $i_clogp, $i_dscfn,
5220 $i_changesfn, (__ 'remote changes file'),
5224 sub i_want_signed_dsc_changes {
5225 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5226 sign_changes $i_changesfn;
5227 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5230 #---------- building etc. ----------
5236 #----- `3.0 (quilt)' handling -----
5238 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5240 sub quiltify_dpkg_commit ($$$;$) {
5241 my ($patchname,$author,$msg, $xinfo) = @_;
5244 mkpath '.git/dgit'; # we are in playtree
5245 my $descfn = ".git/dgit/quilt-description.tmp";
5246 open O, '>', $descfn or confess "$descfn: $!";
5247 $msg =~ s/\n+/\n\n/;
5248 print O <<END or confess "$!";
5250 ${xinfo}Subject: $msg
5254 close O or confess "$!";
5257 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5258 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5259 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5260 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5264 sub quiltify_trees_differ ($$;$$$) {
5265 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5266 # returns true iff the two tree objects differ other than in debian/
5267 # with $finegrained,
5268 # returns bitmask 01 - differ in upstream files except .gitignore
5269 # 02 - differ in .gitignore
5270 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5271 # is set for each modified .gitignore filename $fn
5272 # if $unrepres is defined, array ref to which is appeneded
5273 # a list of unrepresentable changes (removals of upstream files
5276 my @cmd = (@git, qw(diff-tree -z --no-renames));
5277 push @cmd, qw(--name-only) unless $unrepres;
5278 push @cmd, qw(-r) if $finegrained || $unrepres;
5280 my $diffs= cmdoutput @cmd;
5283 foreach my $f (split /\0/, $diffs) {
5284 if ($unrepres && !@lmodes) {
5285 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5288 my ($oldmode,$newmode) = @lmodes;
5291 next if $f =~ m#^debian(?:/.*)?$#s;
5295 die __ "not a plain file or symlink\n"
5296 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5297 $oldmode =~ m/^(?:10|12)\d{4}$/;
5298 if ($oldmode =~ m/[^0]/ &&
5299 $newmode =~ m/[^0]/) {
5300 # both old and new files exist
5301 die __ "mode or type changed\n" if $oldmode ne $newmode;
5302 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5303 } elsif ($oldmode =~ m/[^0]/) {
5305 die __ "deletion of symlink\n"
5306 unless $oldmode =~ m/^10/;
5309 die __ "creation with non-default mode\n"
5310 unless $newmode =~ m/^100644$/ or
5311 $newmode =~ m/^120000$/;
5315 local $/="\n"; chomp $@;
5316 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5320 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5321 $r |= $isignore ? 02 : 01;
5322 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5324 printdebug "quiltify_trees_differ $x $y => $r\n";
5328 sub quiltify_tree_sentinelfiles ($) {
5329 # lists the `sentinel' files present in the tree
5331 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5332 qw(-- debian/rules debian/control);
5337 sub quiltify_splitbrain ($$$$$$$) {
5338 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5339 $editedignores, $cachekey) = @_;
5340 my $gitignore_special = 1;
5341 if ($quilt_mode !~ m/gbp|dpm/) {
5342 # treat .gitignore just like any other upstream file
5343 $diffbits = { %$diffbits };
5344 $_ = !!$_ foreach values %$diffbits;
5345 $gitignore_special = 0;
5347 # We would like any commits we generate to be reproducible
5348 my @authline = clogp_authline($clogp);
5349 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5350 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5351 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5352 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5353 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5354 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5356 confess unless $do_split_brain;
5358 my $fulldiffhint = sub {
5360 my $cmd = "git diff $x $y -- :/ ':!debian'";
5361 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5362 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5366 if ($quilt_mode =~ m/gbp|unapplied/ &&
5367 ($diffbits->{O2H} & 01)) {
5369 "--quilt=%s specified, implying patches-unapplied git tree\n".
5370 " but git tree differs from orig in upstream files.",
5372 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5373 if (!stat_exists "debian/patches") {
5375 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5379 if ($quilt_mode =~ m/dpm/ &&
5380 ($diffbits->{H2A} & 01)) {
5381 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5382 --quilt=%s specified, implying patches-applied git tree
5383 but git tree differs from result of applying debian/patches to upstream
5386 if ($quilt_mode =~ m/gbp|unapplied/ &&
5387 ($diffbits->{O2A} & 01)) { # some patches
5388 progress __ "dgit view: creating patches-applied version using gbp pq";
5389 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5390 # gbp pq import creates a fresh branch; push back to dgit-view
5391 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5392 runcmd @git, qw(checkout -q dgit-view);
5394 if ($quilt_mode =~ m/gbp|dpm/ &&
5395 ($diffbits->{O2A} & 02)) {
5396 fail f_ <<END, $quilt_mode;
5397 --quilt=%s specified, implying that HEAD is for use with a
5398 tool which does not create patches for changes to upstream
5399 .gitignores: but, such patches exist in debian/patches.
5402 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5403 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5405 "dgit view: creating patch to represent .gitignore changes";
5406 ensuredir "debian/patches";
5407 my $gipatch = "debian/patches/auto-gitignore";
5408 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5409 stat GIPATCH or confess "$gipatch: $!";
5410 fail f_ "%s already exists; but want to create it".
5411 " to record .gitignore changes",
5414 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5415 Subject: Update .gitignore from Debian packaging branch
5417 The Debian packaging git branch contains these updates to the upstream
5418 .gitignore file(s). This patch is autogenerated, to provide these
5419 updates to users of the official Debian archive view of the package.
5422 [dgit ($our_version) update-gitignore]
5425 close GIPATCH or die "$gipatch: $!";
5426 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5427 $unapplied, $headref, "--", sort keys %$editedignores;
5428 open SERIES, "+>>", "debian/patches/series" or confess "$!";
5429 defined seek SERIES, -1, 2 or $!==EINVAL or confess "$!";
5431 defined read SERIES, $newline, 1 or confess "$!";
5432 print SERIES "\n" or confess "$!" unless $newline eq "\n";
5433 print SERIES "auto-gitignore\n" or confess "$!";
5434 close SERIES or die $!;
5435 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5436 commit_admin +(__ <<END).<<ENDU
5437 Commit patch to update .gitignore
5440 [dgit ($our_version) update-gitignore-quilt-fixup]
5445 sub quiltify ($$$$) {
5446 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5448 # Quilt patchification algorithm
5450 # We search backwards through the history of the main tree's HEAD
5451 # (T) looking for a start commit S whose tree object is identical
5452 # to to the patch tip tree (ie the tree corresponding to the
5453 # current dpkg-committed patch series). For these purposes
5454 # `identical' disregards anything in debian/ - this wrinkle is
5455 # necessary because dpkg-source treates debian/ specially.
5457 # We can only traverse edges where at most one of the ancestors'
5458 # trees differs (in changes outside in debian/). And we cannot
5459 # handle edges which change .pc/ or debian/patches. To avoid
5460 # going down a rathole we avoid traversing edges which introduce
5461 # debian/rules or debian/control. And we set a limit on the
5462 # number of edges we are willing to look at.
5464 # If we succeed, we walk forwards again. For each traversed edge
5465 # PC (with P parent, C child) (starting with P=S and ending with
5466 # C=T) to we do this:
5468 # - dpkg-source --commit with a patch name and message derived from C
5469 # After traversing PT, we git commit the changes which
5470 # should be contained within debian/patches.
5472 # The search for the path S..T is breadth-first. We maintain a
5473 # todo list containing search nodes. A search node identifies a
5474 # commit, and looks something like this:
5476 # Commit => $git_commit_id,
5477 # Child => $c, # or undef if P=T
5478 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5479 # Nontrivial => true iff $p..$c has relevant changes
5486 my %considered; # saves being exponential on some weird graphs
5488 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5491 my ($search,$whynot) = @_;
5492 printdebug " search NOT $search->{Commit} $whynot\n";
5493 $search->{Whynot} = $whynot;
5494 push @nots, $search;
5495 no warnings qw(exiting);
5504 my $c = shift @todo;
5505 next if $considered{$c->{Commit}}++;
5507 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5509 printdebug "quiltify investigate $c->{Commit}\n";
5512 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5513 printdebug " search finished hooray!\n";
5518 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5519 if ($quilt_mode eq 'smash') {
5520 printdebug " search quitting smash\n";
5524 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5525 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5526 if $c_sentinels ne $t_sentinels;
5528 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5529 $commitdata =~ m/\n\n/;
5531 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5532 @parents = map { { Commit => $_, Child => $c } } @parents;
5534 $not->($c, __ "root commit") if !@parents;
5536 foreach my $p (@parents) {
5537 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5539 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5540 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5543 foreach my $p (@parents) {
5544 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5546 my @cmd= (@git, qw(diff-tree -r --name-only),
5547 $p->{Commit},$c->{Commit},
5548 qw(-- debian/patches .pc debian/source/format));
5549 my $patchstackchange = cmdoutput @cmd;
5550 if (length $patchstackchange) {
5551 $patchstackchange =~ s/\n/,/g;
5552 $not->($p, f_ "changed %s", $patchstackchange);
5555 printdebug " search queue P=$p->{Commit} ",
5556 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5562 printdebug "quiltify want to smash\n";
5565 my $x = $_[0]{Commit};
5566 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5569 if ($quilt_mode eq 'linear') {
5571 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5573 my $all_gdr = !!@nots;
5574 foreach my $notp (@nots) {
5575 my $c = $notp->{Child};
5576 my $cprange = $abbrev->($notp);
5577 $cprange .= "..".$abbrev->($c) if $c;
5578 print STDERR f_ "%s: %s: %s\n",
5579 $us, $cprange, $notp->{Whynot};
5580 $all_gdr &&= $notp->{Child} &&
5581 (git_cat_file $notp->{Child}{Commit}, 'commit')
5582 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5586 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5588 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5590 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5591 } elsif ($quilt_mode eq 'smash') {
5592 } elsif ($quilt_mode eq 'auto') {
5593 progress __ "quilt fixup cannot be linear, smashing...";
5595 confess "$quilt_mode ?";
5598 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5599 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5601 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5603 quiltify_dpkg_commit "auto-$version-$target-$time",
5604 (getfield $clogp, 'Maintainer'),
5605 (f_ "Automatically generated patch (%s)\n".
5606 "Last (up to) %s git changes, FYI:\n\n",
5607 $clogp->{Version}, $ncommits).
5612 progress __ "quiltify linearisation planning successful, executing...";
5614 for (my $p = $sref_S;
5615 my $c = $p->{Child};
5617 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5618 next unless $p->{Nontrivial};
5620 my $cc = $c->{Commit};
5622 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5623 $commitdata =~ m/\n\n/ or die "$c ?";
5626 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5629 my $commitdate = cmdoutput
5630 @git, qw(log -n1 --pretty=format:%aD), $cc;
5632 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5634 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5641 my $gbp_check_suitable = sub {
5646 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5647 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5648 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5649 die __ "is series file\n" if m{$series_filename_re}o;
5650 die __ "too long\n" if length > 200;
5652 return $_ unless $@;
5654 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5659 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5661 (\S+) \s* \n //ixm) {
5662 $patchname = $gbp_check_suitable->($1, 'Name');
5664 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5666 (\S+) \s* \n //ixm) {
5667 $patchdir = $gbp_check_suitable->($1, 'Topic');
5672 if (!defined $patchname) {
5673 $patchname = $title;
5674 $patchname =~ s/[.:]$//;
5677 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5678 my $translitname = $converter->convert($patchname);
5679 die unless defined $translitname;
5680 $patchname = $translitname;
5683 +(f_ "dgit: patch title transliteration error: %s", $@)
5685 $patchname =~ y/ A-Z/-a-z/;
5686 $patchname =~ y/-a-z0-9_.+=~//cd;
5687 $patchname =~ s/^\W/x-$&/;
5688 $patchname = substr($patchname,0,40);
5689 $patchname .= ".patch";
5691 if (!defined $patchdir) {
5694 if (length $patchdir) {
5695 $patchname = "$patchdir/$patchname";
5697 if ($patchname =~ m{^(.*)/}) {
5698 mkpath "debian/patches/$1";
5703 stat "debian/patches/$patchname$index";
5705 $!==ENOENT or confess "$patchname$index $!";
5707 runcmd @git, qw(checkout -q), $cc;
5709 # We use the tip's changelog so that dpkg-source doesn't
5710 # produce complaining messages from dpkg-parsechangelog. None
5711 # of the information dpkg-source gets from the changelog is
5712 # actually relevant - it gets put into the original message
5713 # which dpkg-source provides our stunt editor, and then
5715 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5717 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5718 "Date: $commitdate\n".
5719 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5721 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5725 sub build_maybe_quilt_fixup () {
5726 my ($format,$fopts) = get_source_format;
5727 return unless madformat_wantfixup $format;
5730 check_for_vendor_patches();
5732 my $clogp = parsechangelog();
5733 my $headref = git_rev_parse('HEAD');
5734 my $symref = git_get_symref();
5735 my $upstreamversion = upstreamversion $version;
5738 changedir $playground;
5740 my $splitbrain_cachekey;
5742 if ($do_split_brain) {
5744 ($cachehit, $splitbrain_cachekey) =
5745 quilt_check_splitbrain_cache($headref, $upstreamversion);
5752 unpack_playtree_need_cd_work($headref);
5753 if ($do_split_brain) {
5754 runcmd @git, qw(checkout -q -b dgit-view);
5755 # so long as work is not deleted, its current branch will
5756 # remain dgit-view, rather than master, so subsequent calls to
5757 # unpack_playtree_need_cd_work
5758 # will DTRT, resetting dgit-view.
5759 confess if $made_split_brain;
5760 $made_split_brain = 1;
5764 if ($fopts->{'single-debian-patch'}) {
5766 "quilt mode %s does not make sense (or is not supported) with single-debian-patch",
5768 if quiltmode_splitbrain();
5769 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5771 quilt_fixup_multipatch($clogp, $headref, $upstreamversion,
5772 $splitbrain_cachekey);
5775 if ($do_split_brain) {
5776 my $dgitview = git_rev_parse 'HEAD';
5779 reflog_cache_insert "refs/$splitbraincache",
5780 $splitbrain_cachekey, $dgitview;
5782 changedir "$playground/work";
5784 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5785 progress f_ "dgit view: created (%s)", $saved;
5789 runcmd_ordryrun_local
5790 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5793 sub build_check_quilt_splitbrain () {
5794 build_maybe_quilt_fixup();
5797 sub unpack_playtree_need_cd_work ($) {
5800 # prep_ud() must have been called already.
5801 if (!chdir "work") {
5802 # Check in the filesystem because sometimes we run prep_ud
5803 # in between multiple calls to unpack_playtree_need_cd_work.
5804 confess "$!" unless $!==ENOENT;
5805 mkdir "work" or confess "$!";
5807 mktree_in_ud_here();
5809 runcmd @git, qw(reset -q --hard), $headref;
5812 sub unpack_playtree_linkorigs ($$) {
5813 my ($upstreamversion, $fn) = @_;
5814 # calls $fn->($leafname);
5816 my $bpd_abs = bpd_abs();
5818 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5820 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5821 while ($!=0, defined(my $leaf = readdir QFD)) {
5822 my $f = bpd_abs()."/".$leaf;
5824 local ($debuglevel) = $debuglevel-1;
5825 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5827 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5828 printdebug "QF linkorigs $leaf, $f Y\n";
5829 link_ltarget $f, $leaf or die "$leaf $!";
5832 die "$buildproductsdir: $!" if $!;
5836 sub quilt_fixup_delete_pc () {
5837 runcmd @git, qw(rm -rqf .pc);
5838 commit_admin +(__ <<END).<<ENDU
5839 Commit removal of .pc (quilt series tracking data)
5842 [dgit ($our_version) upgrade quilt-remove-pc]
5846 sub quilt_fixup_singlepatch ($$$) {
5847 my ($clogp, $headref, $upstreamversion) = @_;
5849 progress __ "starting quiltify (single-debian-patch)";
5851 # dpkg-source --commit generates new patches even if
5852 # single-debian-patch is in debian/source/options. In order to
5853 # get it to generate debian/patches/debian-changes, it is
5854 # necessary to build the source package.
5856 unpack_playtree_linkorigs($upstreamversion, sub { });
5857 unpack_playtree_need_cd_work($headref);
5859 rmtree("debian/patches");
5861 runcmd @dpkgsource, qw(-b .);
5863 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5864 rename srcfn("$upstreamversion", "/debian/patches"),
5865 "work/debian/patches"
5867 or confess "install d/patches: $!";
5870 commit_quilty_patch();
5873 sub quilt_need_fake_dsc ($) {
5874 # cwd should be playground
5875 my ($upstreamversion) = @_;
5877 return if stat_exists "fake.dsc";
5878 # ^ OK to test this as a sentinel because if we created it
5879 # we must either have done the rest too, or crashed.
5881 my $fakeversion="$upstreamversion-~~DGITFAKE";
5883 my $fakedsc=new IO::File 'fake.dsc', '>' or confess "$!";
5884 print $fakedsc <<END or confess "$!";
5887 Version: $fakeversion
5891 my $dscaddfile=sub {
5894 my $md = new Digest::MD5;
5896 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5897 stat $fh or confess "$!";
5901 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess "$!";
5904 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5906 my @files=qw(debian/source/format debian/rules
5907 debian/control debian/changelog);
5908 foreach my $maybe (qw(debian/patches debian/source/options
5909 debian/tests/control)) {
5910 next unless stat_exists "$maindir/$maybe";
5911 push @files, $maybe;
5914 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5915 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5917 $dscaddfile->($debtar);
5918 close $fakedsc or confess "$!";
5921 sub quilt_fakedsc2unapplied ($$) {
5922 my ($headref, $upstreamversion) = @_;
5923 # must be run in the playground
5924 # quilt_need_fake_dsc must have been called
5926 quilt_need_fake_dsc($upstreamversion);
5928 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5930 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5931 rename $fakexdir, "fake" or die "$fakexdir $!";
5935 remove_stray_gits(__ "source package");
5936 mktree_in_ud_here();
5940 rmtree 'debian'; # git checkout commitish paths does not delete!
5941 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5942 my $unapplied=git_add_write_tree();
5943 printdebug "fake orig tree object $unapplied\n";
5947 sub quilt_check_splitbrain_cache ($$) {
5948 my ($headref, $upstreamversion) = @_;
5949 # Called only if we are in (potentially) split brain mode.
5950 # Called in playground.
5951 # Computes the cache key and looks in the cache.
5952 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5954 quilt_need_fake_dsc($upstreamversion);
5956 my $splitbrain_cachekey;
5959 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5961 # we look in the reflog of dgit-intern/quilt-cache
5962 # we look for an entry whose message is the key for the cache lookup
5963 my @cachekey = (qw(dgit), $our_version);
5964 push @cachekey, $upstreamversion;
5965 push @cachekey, $quilt_mode;
5966 push @cachekey, $headref;
5968 push @cachekey, hashfile('fake.dsc');
5970 my $srcshash = Digest::SHA->new(256);
5971 my %sfs = ( %INC, '$0(dgit)' => $0 );
5972 foreach my $sfk (sort keys %sfs) {
5973 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5974 $srcshash->add($sfk," ");
5975 $srcshash->add(hashfile($sfs{$sfk}));
5976 $srcshash->add("\n");
5978 push @cachekey, $srcshash->hexdigest();
5979 $splitbrain_cachekey = "@cachekey";
5981 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5983 my $cachehit = reflog_cache_lookup
5984 "refs/$splitbraincache", $splitbrain_cachekey;
5987 unpack_playtree_need_cd_work($headref);
5988 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5989 if ($cachehit ne $headref) {
5990 progress f_ "dgit view: found cached (%s)", $saved;
5991 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5992 $made_split_brain = 1;
5993 return ($cachehit, $splitbrain_cachekey);
5995 progress __ "dgit view: found cached, no changes required";
5996 return ($headref, $splitbrain_cachekey);
5999 printdebug "splitbrain cache miss\n";
6000 return (undef, $splitbrain_cachekey);
6003 sub quilt_fixup_multipatch ($$$) {
6004 my ($clogp, $headref, $upstreamversion, $splitbrain_cachekey) = @_;
6006 progress f_ "examining quilt state (multiple patches, %s mode)",
6010 # - honour any existing .pc in case it has any strangeness
6011 # - determine the git commit corresponding to the tip of
6012 # the patch stack (if there is one)
6013 # - if there is such a git commit, convert each subsequent
6014 # git commit into a quilt patch with dpkg-source --commit
6015 # - otherwise convert all the differences in the tree into
6016 # a single git commit
6020 # Our git tree doesn't necessarily contain .pc. (Some versions of
6021 # dgit would include the .pc in the git tree.) If there isn't
6022 # one, we need to generate one by unpacking the patches that we
6025 # We first look for a .pc in the git tree. If there is one, we
6026 # will use it. (This is not the normal case.)
6028 # Otherwise need to regenerate .pc so that dpkg-source --commit
6029 # can work. We do this as follows:
6030 # 1. Collect all relevant .orig from parent directory
6031 # 2. Generate a debian.tar.gz out of
6032 # debian/{patches,rules,source/format,source/options}
6033 # 3. Generate a fake .dsc containing just these fields:
6034 # Format Source Version Files
6035 # 4. Extract the fake .dsc
6036 # Now the fake .dsc has a .pc directory.
6037 # (In fact we do this in every case, because in future we will
6038 # want to search for a good base commit for generating patches.)
6040 # Then we can actually do the dpkg-source --commit
6041 # 1. Make a new working tree with the same object
6042 # store as our main tree and check out the main
6044 # 2. Copy .pc from the fake's extraction, if necessary
6045 # 3. Run dpkg-source --commit
6046 # 4. If the result has changes to debian/, then
6047 # - git add them them
6048 # - git add .pc if we had a .pc in-tree
6050 # 5. If we had a .pc in-tree, delete it, and git commit
6051 # 6. Back in the main tree, fast forward to the new HEAD
6053 # Another situation we may have to cope with is gbp-style
6054 # patches-unapplied trees.
6056 # We would want to detect these, so we know to escape into
6057 # quilt_fixup_gbp. However, this is in general not possible.
6058 # Consider a package with a one patch which the dgit user reverts
6059 # (with git revert or the moral equivalent).
6061 # That is indistinguishable in contents from a patches-unapplied
6062 # tree. And looking at the history to distinguish them is not
6063 # useful because the user might have made a confusing-looking git
6064 # history structure (which ought to produce an error if dgit can't
6065 # cope, not a silent reintroduction of an unwanted patch).
6067 # So gbp users will have to pass an option. But we can usually
6068 # detect their failure to do so: if the tree is not a clean
6069 # patches-applied tree, quilt linearisation fails, but the tree
6070 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6071 # they want --quilt=unapplied.
6073 # To help detect this, when we are extracting the fake dsc, we
6074 # first extract it with --skip-patches, and then apply the patches
6075 # afterwards with dpkg-source --before-build. That lets us save a
6076 # tree object corresponding to .origs.
6078 if ($quilt_mode eq 'linear'
6079 && branch_is_gdr($headref)) {
6080 # This is much faster. It also makes patches that gdr
6081 # likes better for future updates without laundering.
6083 # However, it can fail in some casses where we would
6084 # succeed: if there are existing patches, which correspond
6085 # to a prefix of the branch, but are not in gbp/gdr
6086 # format, gdr will fail (exiting status 7), but we might
6087 # be able to figure out where to start linearising. That
6088 # will be slower so hopefully there's not much to do.
6090 unpack_playtree_need_cd_work $headref;
6092 my @cmd = (@git_debrebase,
6093 qw(--noop-ok -funclean-mixed -funclean-ordering
6094 make-patches --quiet-would-amend));
6095 # We tolerate soe snags that gdr wouldn't, by default.
6101 and not ($? == 7*256 or
6102 $? == -1 && $!==ENOENT);
6106 $headref = git_rev_parse('HEAD');
6111 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6115 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6117 if (system @bbcmd) {
6118 failedcmd @bbcmd if $? < 0;
6120 failed to apply your git tree's patch stack (from debian/patches/) to
6121 the corresponding upstream tarball(s). Your source tree and .orig
6122 are probably too inconsistent. dgit can only fix up certain kinds of
6123 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6129 unpack_playtree_need_cd_work($headref);
6132 if (stat_exists ".pc") {
6134 progress __ "Tree already contains .pc - will use it then delete it.";
6137 rename '../fake/.pc','.pc' or confess "$!";
6140 changedir '../fake';
6142 my $oldtiptree=git_add_write_tree();
6143 printdebug "fake o+d/p tree object $unapplied\n";
6144 changedir '../work';
6147 # We calculate some guesswork now about what kind of tree this might
6148 # be. This is mostly for error reporting.
6154 # O = orig, without patches applied
6155 # A = "applied", ie orig with H's debian/patches applied
6156 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6157 \%editedignores, \@unrepres),
6158 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6159 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6163 foreach my $bits (qw(01 02)) {
6164 foreach my $v (qw(O2H O2A H2A)) {
6165 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6168 printdebug "differences \@dl @dl.\n";
6171 "%s: base trees orig=%.20s o+d/p=%.20s",
6172 $us, $unapplied, $oldtiptree;
6174 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6175 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6176 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6177 $us, $dl[2], $dl[5];
6180 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6183 forceable_fail [qw(unrepresentable)], __ <<END;
6184 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6189 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6190 push @failsuggestion, [ 'unapplied', __
6191 "This might be a patches-unapplied branch." ];
6192 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6193 push @failsuggestion, [ 'applied', __
6194 "This might be a patches-applied branch." ];
6196 push @failsuggestion, [ 'quilt-mode', __
6197 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6199 push @failsuggestion, [ 'gitattrs', __
6200 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6201 if stat_exists '.gitattributes';
6203 push @failsuggestion, [ 'origs', __
6204 "Maybe orig tarball(s) are not identical to git representation?" ];
6206 if (quiltmode_splitbrain()) {
6207 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6208 $diffbits, \%editedignores,
6209 $splitbrain_cachekey);
6213 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6214 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6215 runcmd @git, qw(checkout -q), (qw(master dgit-view)[!!$do_split_brain]);
6217 if (!open P, '>>', ".pc/applied-patches") {
6218 $!==&ENOENT or confess "$!";
6223 commit_quilty_patch();
6225 if ($mustdeletepc) {
6226 quilt_fixup_delete_pc();
6230 sub quilt_fixup_editor () {
6231 my $descfn = $ENV{$fakeeditorenv};
6232 my $editing = $ARGV[$#ARGV];
6233 open I1, '<', $descfn or confess "$descfn: $!";
6234 open I2, '<', $editing or confess "$editing: $!";
6235 unlink $editing or confess "$editing: $!";
6236 open O, '>', $editing or confess "$editing: $!";
6237 while (<I1>) { print O or confess "$!"; } I1->error and confess "$!";
6240 $copying ||= m/^\-\-\- /;
6241 next unless $copying;
6242 print O or confess "$!";
6244 I2->error and confess "$!";
6249 sub maybe_apply_patches_dirtily () {
6250 return unless $quilt_mode =~ m/gbp|unapplied/;
6251 print STDERR __ <<END or confess "$!";
6253 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6254 dgit: Have to apply the patches - making the tree dirty.
6255 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6258 $patches_applied_dirtily = 01;
6259 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6260 runcmd qw(dpkg-source --before-build .);
6263 sub maybe_unapply_patches_again () {
6264 progress __ "dgit: Unapplying patches again to tidy up the tree."
6265 if $patches_applied_dirtily;
6266 runcmd qw(dpkg-source --after-build .)
6267 if $patches_applied_dirtily & 01;
6269 if $patches_applied_dirtily & 02;
6270 $patches_applied_dirtily = 0;
6273 #----- other building -----
6275 sub clean_tree_check_git ($$$) {
6276 my ($honour_ignores, $message, $ignmessage) = @_;
6277 my @cmd = (@git, qw(clean -dn));
6278 push @cmd, qw(-x) unless $honour_ignores;
6279 my $leftovers = cmdoutput @cmd;
6280 if (length $leftovers) {
6281 print STDERR $leftovers, "\n" or confess "$!";
6282 $message .= $ignmessage if $honour_ignores;
6287 sub clean_tree_check_git_wd ($) {
6289 return if $cleanmode =~ m{no-check};
6290 return if $patches_applied_dirtily; # yuk
6291 clean_tree_check_git +($cleanmode !~ m{all-check}),
6292 $message, "\n".__ <<END;
6293 If this is just missing .gitignore entries, use a different clean
6294 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6295 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6299 sub clean_tree_check () {
6300 # This function needs to not care about modified but tracked files.
6301 # That was done by check_not_dirty, and by now we may have run
6302 # the rules clean target which might modify tracked files (!)
6303 if ($cleanmode =~ m{^check}) {
6304 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6305 "tree contains uncommitted files and --clean=check specified", '';
6306 } elsif ($cleanmode =~ m{^dpkg-source}) {
6307 clean_tree_check_git_wd __
6308 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6309 } elsif ($cleanmode =~ m{^git}) {
6310 clean_tree_check_git 1, __
6311 "tree contains uncommited, untracked, unignored files\n".
6312 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6313 } elsif ($cleanmode eq 'none') {
6315 confess "$cleanmode ?";
6320 # We always clean the tree ourselves, rather than leave it to the
6321 # builder (dpkg-source, or soemthing which calls dpkg-source).
6322 if ($cleanmode =~ m{^dpkg-source}) {
6323 my @cmd = @dpkgbuildpackage;
6324 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6325 push @cmd, qw(-T clean);
6326 maybe_apply_patches_dirtily();
6327 runcmd_ordryrun_local @cmd;
6328 clean_tree_check_git_wd __
6329 "tree contains uncommitted files (after running rules clean)";
6330 } elsif ($cleanmode =~ m{^git(?!-)}) {
6331 runcmd_ordryrun_local @git, qw(clean -xdf);
6332 } elsif ($cleanmode =~ m{^git-ff}) {
6333 runcmd_ordryrun_local @git, qw(clean -xdff);
6334 } elsif ($cleanmode =~ m{^check}) {
6336 } elsif ($cleanmode eq 'none') {
6338 confess "$cleanmode ?";
6343 badusage __ "clean takes no additional arguments" if @ARGV;
6346 maybe_unapply_patches_again();
6349 # return values from massage_dbp_args are one or both of these flags
6350 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6351 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6353 sub build_or_push_prep_early () {
6354 our $build_or_push_prep_early_done //= 0;
6355 return if $build_or_push_prep_early_done++;
6356 badusage f_ "-p is not allowed with dgit %s", $subcommand
6357 if defined $package;
6358 my $clogp = parsechangelog();
6359 $isuite = getfield $clogp, 'Distribution';
6360 $package = getfield $clogp, 'Source';
6361 $version = getfield $clogp, 'Version';
6362 $dscfn = dscfn($version);
6365 sub build_or_push_prep_modes () {
6366 my ($format,) = get_source_format();
6367 printdebug "format $format, quilt mode $quilt_mode\n";
6368 if (madformat_wantfixup($format) && quiltmode_splitbrain()) {
6369 $do_split_brain = 1;
6371 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
6372 if $do_split_brain && $includedirty;
6375 sub build_prep_early () {
6376 build_or_push_prep_early();
6378 build_or_push_prep_modes();
6382 sub build_prep ($) {
6386 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6387 # Clean the tree because we're going to use the contents of
6388 # $maindir. (We trying to include dirty changes in the source
6389 # package, or we are running the builder in $maindir.)
6390 || $cleanmode =~ m{always}) {
6391 # Or because the user asked us to.
6394 # We don't actually need to do anything in $maindir, but we
6395 # should do some kind of cleanliness check because (i) the
6396 # user may have forgotten a `git add', and (ii) if the user
6397 # said -wc we should still do the check.
6400 build_check_quilt_splitbrain();
6402 my $pat = changespat $version;
6403 foreach my $f (glob "$buildproductsdir/$pat") {
6406 fail f_ "remove old changes file %s: %s", $f, $!;
6408 progress f_ "would remove %s", $f;
6414 sub changesopts_initial () {
6415 my @opts =@changesopts[1..$#changesopts];
6418 sub changesopts_version () {
6419 if (!defined $changes_since_version) {
6422 @vsns = archive_query('archive_query');
6423 my @quirk = access_quirk();
6424 if ($quirk[0] eq 'backports') {
6425 local $isuite = $quirk[2];
6427 canonicalise_suite();
6428 push @vsns, archive_query('archive_query');
6434 "archive query failed (queried because --since-version not specified)";
6437 @vsns = map { $_->[0] } @vsns;
6438 @vsns = sort { -version_compare($a, $b) } @vsns;
6439 $changes_since_version = $vsns[0];
6440 progress f_ "changelog will contain changes since %s", $vsns[0];
6442 $changes_since_version = '_';
6443 progress __ "package seems new, not specifying -v<version>";
6446 if ($changes_since_version ne '_') {
6447 return ("-v$changes_since_version");
6453 sub changesopts () {
6454 return (changesopts_initial(), changesopts_version());
6457 sub massage_dbp_args ($;$) {
6458 my ($cmd,$xargs) = @_;
6459 # Since we split the source build out so we can do strange things
6460 # to it, massage the arguments to dpkg-buildpackage so that the
6461 # main build doessn't build source (or add an argument to stop it
6462 # building source by default).
6463 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6464 # -nc has the side effect of specifying -b if nothing else specified
6465 # and some combinations of -S, -b, et al, are errors, rather than
6466 # later simply overriding earlie. So we need to:
6467 # - search the command line for these options
6468 # - pick the last one
6469 # - perhaps add our own as a default
6470 # - perhaps adjust it to the corresponding non-source-building version
6472 foreach my $l ($cmd, $xargs) {
6474 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6477 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6478 my $r = WANTSRC_BUILDER;
6479 printdebug "massage split $dmode.\n";
6480 if ($dmode =~ s/^--build=//) {
6482 my @d = split /,/, $dmode;
6483 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6484 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6485 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6486 fail __ "Wanted to build nothing!" unless $r;
6487 $dmode = '--build='. join ',', grep m/./, @d;
6490 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6491 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6492 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6495 printdebug "massage done $r $dmode.\n";
6497 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6503 my $wasdir = must_getcwd();
6504 changedir $buildproductsdir;
6509 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6510 sub postbuild_mergechanges ($) {
6511 my ($msg_if_onlyone) = @_;
6512 # If there is only one .changes file, fail with $msg_if_onlyone,
6513 # or if that is undef, be a no-op.
6514 # Returns the changes file to report to the user.
6515 my $pat = changespat $version;
6516 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6517 @changesfiles = sort {
6518 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6522 if (@changesfiles==1) {
6523 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6524 only one changes file from build (%s)
6526 if defined $msg_if_onlyone;
6527 $result = $changesfiles[0];
6528 } elsif (@changesfiles==2) {
6529 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6530 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6531 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6534 runcmd_ordryrun_local @mergechanges, @changesfiles;
6535 my $multichanges = changespat $version,'multi';
6537 stat_exists $multichanges or fail f_
6538 "%s unexpectedly not created by build", $multichanges;
6539 foreach my $cf (glob $pat) {
6540 next if $cf eq $multichanges;
6541 rename "$cf", "$cf.inmulti" or fail f_
6542 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6545 $result = $multichanges;
6547 fail f_ "wrong number of different changes files (%s)",
6550 printdone f_ "build successful, results in %s\n", $result
6554 sub midbuild_checkchanges () {
6555 my $pat = changespat $version;
6556 return if $rmchanges;
6557 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6559 $_ ne changespat $version,'source' and
6560 $_ ne changespat $version,'multi'
6562 fail +(f_ <<END, $pat, "@unwanted")
6563 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6564 Suggest you delete %s.
6569 sub midbuild_checkchanges_vanilla ($) {
6571 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6574 sub postbuild_mergechanges_vanilla ($) {
6576 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6578 postbuild_mergechanges(undef);
6581 printdone __ "build successful\n";
6587 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6588 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6589 %s: warning: build-products-dir will be ignored; files will go to ..
6591 $buildproductsdir = '..';
6592 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6593 my $wantsrc = massage_dbp_args \@dbp;
6594 build_prep($wantsrc);
6595 if ($wantsrc & WANTSRC_SOURCE) {
6597 midbuild_checkchanges_vanilla $wantsrc;
6599 if ($wantsrc & WANTSRC_BUILDER) {
6600 push @dbp, changesopts_version();
6601 maybe_apply_patches_dirtily();
6602 runcmd_ordryrun_local @dbp;
6604 maybe_unapply_patches_again();
6605 postbuild_mergechanges_vanilla $wantsrc;
6609 $quilt_mode //= 'gbp';
6615 # gbp can make .origs out of thin air. In my tests it does this
6616 # even for a 1.0 format package, with no origs present. So I
6617 # guess it keys off just the version number. We don't know
6618 # exactly what .origs ought to exist, but let's assume that we
6619 # should run gbp if: the version has an upstream part and the main
6621 my $upstreamversion = upstreamversion $version;
6622 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6623 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6625 if ($gbp_make_orig) {
6627 $cleanmode = 'none'; # don't do it again
6630 my @dbp = @dpkgbuildpackage;
6632 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6634 if (!length $gbp_build[0]) {
6635 if (length executable_on_path('git-buildpackage')) {
6636 $gbp_build[0] = qw(git-buildpackage);
6638 $gbp_build[0] = 'gbp buildpackage';
6641 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6643 push @cmd, (qw(-us -uc --git-no-sign-tags),
6644 "--git-builder=".(shellquote @dbp));
6646 if ($gbp_make_orig) {
6647 my $priv = dgit_privdir();
6648 my $ok = "$priv/origs-gen-ok";
6649 unlink $ok or $!==&ENOENT or confess "$!";
6650 my @origs_cmd = @cmd;
6651 push @origs_cmd, qw(--git-cleaner=true);
6652 push @origs_cmd, "--git-prebuild=".
6653 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6654 push @origs_cmd, @ARGV;
6656 debugcmd @origs_cmd;
6658 do { local $!; stat_exists $ok; }
6659 or failedcmd @origs_cmd;
6661 dryrun_report @origs_cmd;
6665 build_prep($wantsrc);
6666 if ($wantsrc & WANTSRC_SOURCE) {
6668 midbuild_checkchanges_vanilla $wantsrc;
6670 push @cmd, '--git-cleaner=true';
6672 maybe_unapply_patches_again();
6673 if ($wantsrc & WANTSRC_BUILDER) {
6674 push @cmd, changesopts();
6675 runcmd_ordryrun_local @cmd, @ARGV;
6677 postbuild_mergechanges_vanilla $wantsrc;
6679 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6681 sub building_source_in_playtree {
6682 # If $includedirty, we have to build the source package from the
6683 # working tree, not a playtree, so that uncommitted changes are
6684 # included (copying or hardlinking them into the playtree could
6687 # Note that if we are building a source package in split brain
6688 # mode we do not support including uncommitted changes, because
6689 # that makes quilt fixup too hard. I.e. ($made_split_brain && (dgit is
6690 # building a source package)) => !$includedirty
6691 return !$includedirty;
6695 $sourcechanges = changespat $version,'source';
6697 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6698 or fail f_ "remove %s: %s", $sourcechanges, $!;
6700 # confess unless !!$made_split_brain == !!$do_split_brain;
6702 my @cmd = (@dpkgsource, qw(-b --));
6704 if (building_source_in_playtree()) {
6706 my $headref = git_rev_parse('HEAD');
6707 # If we are in split brain, there is already a playtree with
6708 # the thing we should package into a .dsc (thanks to quilt
6709 # fixup). If not, make a playtree
6710 prep_ud() unless $made_split_brain;
6711 changedir $playground;
6712 unless ($made_split_brain) {
6713 my $upstreamversion = upstreamversion $version;
6714 unpack_playtree_linkorigs($upstreamversion, sub { });
6715 unpack_playtree_need_cd_work($headref);
6719 $leafdir = basename $maindir;
6721 if ($buildproductsdir ne '..') {
6722 # Well, we are going to run dpkg-source -b which consumes
6723 # origs from .. and generates output there. To make this
6724 # work when the bpd is not .. , we would have to (i) link
6725 # origs from bpd to .. , (ii) check for files that
6726 # dpkg-source -b would/might overwrite, and afterwards
6727 # (iii) move all the outputs back to the bpd (iv) except
6728 # for the origs which should be deleted from .. if they
6729 # weren't there beforehand. And if there is an error and
6730 # we don't run to completion we would necessarily leave a
6731 # mess. This is too much. The real way to fix this
6732 # is for dpkg-source to have bpd support.
6733 confess unless $includedirty;
6735 "--include-dirty not supported with --build-products-dir, sorry";
6740 runcmd_ordryrun_local @cmd, $leafdir;
6743 runcmd_ordryrun_local qw(sh -ec),
6744 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6745 @dpkggenchanges, qw(-S), changesopts();
6748 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6749 $dsc = parsecontrol($dscfn, "source package");
6753 printdebug " renaming ($why) $l\n";
6754 rename_link_xf 0, "$l", bpd_abs()."/$l"
6755 or fail f_ "put in place new built file (%s): %s", $l, $@;
6757 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6758 $l =~ m/\S+$/ or next;
6761 $mv->('dsc', $dscfn);
6762 $mv->('changes', $sourcechanges);
6767 sub cmd_build_source {
6768 badusage __ "build-source takes no additional arguments" if @ARGV;
6769 build_prep(WANTSRC_SOURCE);
6771 maybe_unapply_patches_again();
6772 printdone f_ "source built, results in %s and %s",
6773 $dscfn, $sourcechanges;
6776 sub cmd_push_source {
6779 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6780 "sense with push-source!"
6782 build_check_quilt_splitbrain();
6784 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6785 __ "source changes file");
6786 unless (test_source_only_changes($changes)) {
6787 fail __ "user-specified changes file is not source-only";
6790 # Building a source package is very fast, so just do it
6792 confess "er, patches are applied dirtily but shouldn't be.."
6793 if $patches_applied_dirtily;
6794 $changesfile = $sourcechanges;
6799 sub binary_builder {
6800 my ($bbuilder, $pbmc_msg, @args) = @_;
6801 build_prep(WANTSRC_SOURCE);
6803 midbuild_checkchanges();
6806 stat_exists $dscfn or fail f_
6807 "%s (in build products dir): %s", $dscfn, $!;
6808 stat_exists $sourcechanges or fail f_
6809 "%s (in build products dir): %s", $sourcechanges, $!;
6811 runcmd_ordryrun_local @$bbuilder, @args;
6813 maybe_unapply_patches_again();
6815 postbuild_mergechanges($pbmc_msg);
6821 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6822 perhaps you need to pass -A ? (sbuild's default is to build only
6823 arch-specific binaries; dgit 1.4 used to override that.)
6828 my ($pbuilder) = @_;
6830 # @ARGV is allowed to contain only things that should be passed to
6831 # pbuilder under debbuildopts; just massage those
6832 my $wantsrc = massage_dbp_args \@ARGV;
6834 "you asked for a builder but your debbuildopts didn't ask for".
6835 " any binaries -- is this really what you meant?"
6836 unless $wantsrc & WANTSRC_BUILDER;
6838 "we must build a .dsc to pass to the builder but your debbuiltopts".
6839 " forbids the building of a source package; cannot continue"
6840 unless $wantsrc & WANTSRC_SOURCE;
6841 # We do not want to include the verb "build" in @pbuilder because
6842 # the user can customise @pbuilder and they shouldn't be required
6843 # to include "build" in their customised value. However, if the
6844 # user passes any additional args to pbuilder using the dgit
6845 # option --pbuilder:foo, such args need to come after the "build"
6846 # verb. opts_opt_multi_cmd does all of that.
6847 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6848 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6853 pbuilder(\@pbuilder);
6856 sub cmd_cowbuilder {
6857 pbuilder(\@cowbuilder);
6860 sub cmd_quilt_fixup {
6861 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6864 build_maybe_quilt_fixup();
6867 sub cmd_print_unapplied_treeish {
6868 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6870 my $headref = git_rev_parse('HEAD');
6871 my $clogp = commit_getclogp $headref;
6872 $package = getfield $clogp, 'Source';
6873 $version = getfield $clogp, 'Version';
6874 $isuite = getfield $clogp, 'Distribution';
6875 $csuite = $isuite; # we want this to be offline!
6879 changedir $playground;
6880 my $uv = upstreamversion $version;
6881 my $u = quilt_fakedsc2unapplied($headref, $uv);
6882 print $u, "\n" or confess "$!";
6885 sub import_dsc_result {
6886 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6887 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6889 check_gitattrs($newhash, __ "source tree");
6891 progress f_ "dgit: import-dsc: %s", $what_msg;
6894 sub cmd_import_dsc {
6898 last unless $ARGV[0] =~ m/^-/;
6901 if (m/^--require-valid-signature$/) {
6904 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6908 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6910 my ($dscfn, $dstbranch) = @ARGV;
6912 badusage __ "dry run makes no sense with import-dsc"
6915 my $force = $dstbranch =~ s/^\+// ? +1 :
6916 $dstbranch =~ s/^\.\.// ? -1 :
6918 my $info = $force ? " $&" : '';
6919 $info = "$dscfn$info";
6921 my $specbranch = $dstbranch;
6922 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6923 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6925 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6926 my $chead = cmdoutput_errok @symcmd;
6927 defined $chead or $?==256 or failedcmd @symcmd;
6929 fail f_ "%s is checked out - will not update it", $dstbranch
6930 if defined $chead and $chead eq $dstbranch;
6932 my $oldhash = git_get_ref $dstbranch;
6934 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6935 $dscdata = do { local $/ = undef; <D>; };
6936 D->error and fail f_ "read %s: %s", $dscfn, $!;
6939 # we don't normally need this so import it here
6940 use Dpkg::Source::Package;
6941 my $dp = new Dpkg::Source::Package filename => $dscfn,
6942 require_valid_signature => $needsig;
6944 local $SIG{__WARN__} = sub {
6946 return unless $needsig;
6947 fail __ "import-dsc signature check failed";
6949 if (!$dp->is_signed()) {
6950 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6952 my $r = $dp->check_signature();
6953 confess "->check_signature => $r" if $needsig && $r;
6959 $package = getfield $dsc, 'Source';
6961 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6962 unless forceing [qw(import-dsc-with-dgit-field)];
6963 parse_dsc_field_def_dsc_distro();
6965 $isuite = 'DGIT-IMPORT-DSC';
6966 $idistro //= $dsc_distro;
6970 if (defined $dsc_hash) {
6972 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6973 resolve_dsc_field_commit undef, undef;
6975 if (defined $dsc_hash) {
6976 my @cmd = (qw(sh -ec),
6977 "echo $dsc_hash | git cat-file --batch-check");
6978 my $objgot = cmdoutput @cmd;
6979 if ($objgot =~ m#^\w+ missing\b#) {
6980 fail f_ <<END, $dsc_hash
6981 .dsc contains Dgit field referring to object %s
6982 Your git tree does not have that object. Try `git fetch' from a
6983 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6986 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6988 progress __ "Not fast forward, forced update.";
6990 fail f_ "Not fast forward to %s", $dsc_hash;
6993 import_dsc_result $dstbranch, $dsc_hash,
6994 "dgit import-dsc (Dgit): $info",
6995 f_ "updated git ref %s", $dstbranch;
6999 fail f_ <<END, $dstbranch, $specbranch, $specbranch
7000 Branch %s already exists
7001 Specify ..%s for a pseudo-merge, binding in existing history
7002 Specify +%s to overwrite, discarding existing history
7004 if $oldhash && !$force;
7006 my @dfi = dsc_files_info();
7007 foreach my $fi (@dfi) {
7008 my $f = $fi->{Filename};
7009 # We transfer all the pieces of the dsc to the bpd, not just
7010 # origs. This is by analogy with dgit fetch, which wants to
7011 # keep them somewhere to avoid downloading them again.
7012 # We make symlinks, though. If the user wants copies, then
7013 # they can copy the parts of the dsc to the bpd using dcmd,
7015 my $here = "$buildproductsdir/$f";
7020 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7022 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7023 printdebug "not in bpd, $f ...\n";
7024 # $f does not exist in bpd, we need to transfer it
7026 $there =~ s{[^/]+$}{$f} or confess "$there ?";
7027 # $there is file we want, relative to user's cwd, or abs
7028 printdebug "not in bpd, $f, test $there ...\n";
7029 stat $there or fail f_
7030 "import %s requires %s, but: %s", $dscfn, $there, $!;
7031 if ($there =~ m#^(?:\./+)?\.\./+#) {
7032 # $there is relative to user's cwd
7033 my $there_from_parent = $';
7034 if ($buildproductsdir !~ m{^/}) {
7035 # abs2rel, despite its name, can take two relative paths
7036 $there = File::Spec->abs2rel($there,$buildproductsdir);
7037 # now $there is relative to bpd, great
7038 printdebug "not in bpd, $f, abs2rel, $there ...\n";
7040 $there = (dirname $maindir)."/$there_from_parent";
7041 # now $there is absoute
7042 printdebug "not in bpd, $f, rel2rel, $there ...\n";
7044 } elsif ($there =~ m#^/#) {
7045 # $there is absolute already
7046 printdebug "not in bpd, $f, abs, $there ...\n";
7049 "cannot import %s which seems to be inside working tree!",
7052 symlink $there, $here or fail f_
7053 "symlink %s to %s: %s", $there, $here, $!;
7054 progress f_ "made symlink %s -> %s", $here, $there;
7055 # print STDERR Dumper($fi);
7057 my @mergeinputs = generate_commits_from_dsc();
7058 die unless @mergeinputs == 1;
7060 my $newhash = $mergeinputs[0]{Commit};
7065 "Import, forced update - synthetic orphan git history.";
7066 } elsif ($force < 0) {
7067 progress __ "Import, merging.";
7068 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7069 my $version = getfield $dsc, 'Version';
7070 my $clogp = commit_getclogp $newhash;
7071 my $authline = clogp_authline $clogp;
7072 $newhash = make_commit_text <<ENDU
7080 .(f_ <<END, $package, $version, $dstbranch);
7081 Merge %s (%s) import into %s
7084 die; # caught earlier
7088 import_dsc_result $dstbranch, $newhash,
7089 "dgit import-dsc: $info",
7090 f_ "results are in git ref %s", $dstbranch;
7093 sub pre_archive_api_query () {
7094 not_necessarily_a_tree();
7096 sub cmd_archive_api_query {
7097 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7098 my ($subpath) = @ARGV;
7099 local $isuite = 'DGIT-API-QUERY-CMD';
7100 my @cmd = archive_api_query_cmd($subpath);
7103 exec @cmd or fail f_ "exec curl: %s\n", $!;
7106 sub repos_server_url () {
7107 $package = '_dgit-repos-server';
7108 local $access_forpush = 1;
7109 local $isuite = 'DGIT-REPOS-SERVER';
7110 my $url = access_giturl();
7113 sub pre_clone_dgit_repos_server () {
7114 not_necessarily_a_tree();
7116 sub cmd_clone_dgit_repos_server {
7117 badusage __ "need destination argument" unless @ARGV==1;
7118 my ($destdir) = @ARGV;
7119 my $url = repos_server_url();
7120 my @cmd = (@git, qw(clone), $url, $destdir);
7122 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7125 sub pre_print_dgit_repos_server_source_url () {
7126 not_necessarily_a_tree();
7128 sub cmd_print_dgit_repos_server_source_url {
7130 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7132 my $url = repos_server_url();
7133 print $url, "\n" or confess "$!";
7136 sub pre_print_dpkg_source_ignores {
7137 not_necessarily_a_tree();
7139 sub cmd_print_dpkg_source_ignores {
7141 "no arguments allowed to dgit print-dpkg-source-ignores"
7143 print "@dpkg_source_ignores\n" or confess "$!";
7146 sub cmd_setup_mergechangelogs {
7147 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7149 local $isuite = 'DGIT-SETUP-TREE';
7150 setup_mergechangelogs(1);
7153 sub cmd_setup_useremail {
7154 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7155 local $isuite = 'DGIT-SETUP-TREE';
7159 sub cmd_setup_gitattributes {
7160 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7161 local $isuite = 'DGIT-SETUP-TREE';
7165 sub cmd_setup_new_tree {
7166 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7167 local $isuite = 'DGIT-SETUP-TREE';
7171 #---------- argument parsing and main program ----------
7174 print "dgit version $our_version\n" or confess "$!";
7178 our (%valopts_long, %valopts_short);
7179 our (%funcopts_long);
7181 our (@modeopt_cfgs);
7183 sub defvalopt ($$$$) {
7184 my ($long,$short,$val_re,$how) = @_;
7185 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7186 $valopts_long{$long} = $oi;
7187 $valopts_short{$short} = $oi;
7188 # $how subref should:
7189 # do whatever assignemnt or thing it likes with $_[0]
7190 # if the option should not be passed on to remote, @rvalopts=()
7191 # or $how can be a scalar ref, meaning simply assign the value
7194 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7195 defvalopt '--distro', '-d', '.+', \$idistro;
7196 defvalopt '', '-k', '.+', \$keyid;
7197 defvalopt '--existing-package','', '.*', \$existing_package;
7198 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7199 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7200 defvalopt '--package', '-p', $package_re, \$package;
7201 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7203 defvalopt '', '-C', '.+', sub {
7204 ($changesfile) = (@_);
7205 if ($changesfile =~ s#^(.*)/##) {
7206 $buildproductsdir = $1;
7210 defvalopt '--initiator-tempdir','','.*', sub {
7211 ($initiator_tempdir) = (@_);
7212 $initiator_tempdir =~ m#^/# or
7213 badusage __ "--initiator-tempdir must be used specify an".
7214 " absolute, not relative, directory."
7217 sub defoptmodes ($@) {
7218 my ($varref, $cfgkey, $default, %optmap) = @_;
7220 while (my ($opt,$val) = each %optmap) {
7221 $funcopts_long{$opt} = sub { $$varref = $val; };
7222 $permit{$val} = $val;
7224 push @modeopt_cfgs, {
7227 Default => $default,
7232 defoptmodes \$dodep14tag, qw( dep14tag want
7235 --always-dep14tag always );
7240 if (defined $ENV{'DGIT_SSH'}) {
7241 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7242 } elsif (defined $ENV{'GIT_SSH'}) {
7243 @ssh = ($ENV{'GIT_SSH'});
7251 if (!defined $val) {
7252 badusage f_ "%s needs a value", $what unless @ARGV;
7254 push @rvalopts, $val;
7256 badusage f_ "bad value \`%s' for %s", $val, $what unless
7257 $val =~ m/^$oi->{Re}$(?!\n)/s;
7258 my $how = $oi->{How};
7259 if (ref($how) eq 'SCALAR') {
7264 push @ropts, @rvalopts;
7268 last unless $ARGV[0] =~ m/^-/;
7272 if (m/^--dry-run$/) {
7275 } elsif (m/^--damp-run$/) {
7278 } elsif (m/^--no-sign$/) {
7281 } elsif (m/^--help$/) {
7283 } elsif (m/^--version$/) {
7285 } elsif (m/^--new$/) {
7288 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7289 ($om = $opts_opt_map{$1}) &&
7293 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7294 !$opts_opt_cmdonly{$1} &&
7295 ($om = $opts_opt_map{$1})) {
7298 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7299 !$opts_opt_cmdonly{$1} &&
7300 ($om = $opts_opt_map{$1})) {
7302 my $cmd = shift @$om;
7303 @$om = ($cmd, grep { $_ ne $2 } @$om);
7304 } elsif (m/^--(gbp|dpm)$/s) {
7305 push @ropts, "--quilt=$1";
7307 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7310 } elsif (m/^--no-quilt-fixup$/s) {
7312 $quilt_mode = 'nocheck';
7313 } elsif (m/^--no-rm-on-error$/s) {
7316 } elsif (m/^--no-chase-dsc-distro$/s) {
7318 $chase_dsc_distro = 0;
7319 } elsif (m/^--overwrite$/s) {
7321 $overwrite_version = '';
7322 } elsif (m/^--overwrite=(.+)$/s) {
7324 $overwrite_version = $1;
7325 } elsif (m/^--delayed=(\d+)$/s) {
7328 } elsif (m/^--save-(dgit-view)=(.+)$/s ||
7329 m/^--(dgit-view)-save=(.+)$/s
7331 my ($k,$v) = ($1,$2);
7333 $v =~ s#^(?!refs/)#refs/heads/#;
7334 $internal_object_save{$k} = $v;
7335 } elsif (m/^--(no-)?rm-old-changes$/s) {
7338 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7340 push @deliberatelies, $&;
7341 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7345 } elsif (m/^--force-/) {
7347 f_ "%s: warning: ignoring unknown force option %s\n",
7350 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7351 # undocumented, for testing
7353 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7354 # ^ it's supposed to be an array ref
7355 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7356 $val = $2 ? $' : undef; #';
7357 $valopt->($oi->{Long});
7358 } elsif ($funcopts_long{$_}) {
7360 $funcopts_long{$_}();
7362 badusage f_ "unknown long option \`%s'", $_;
7369 } elsif (s/^-L/-/) {
7372 } elsif (s/^-h/-/) {
7374 } elsif (s/^-D/-/) {
7378 } elsif (s/^-N/-/) {
7383 push @changesopts, $_;
7385 } elsif (s/^-wn$//s) {
7387 $cleanmode = 'none';
7388 } elsif (s/^-wg(f?)(a?)$//s) {
7391 $cleanmode .= '-ff' if $1;
7392 $cleanmode .= ',always' if $2;
7393 } elsif (s/^-wd(d?)([na]?)$//s) {
7395 $cleanmode = 'dpkg-source';
7396 $cleanmode .= '-d' if $1;
7397 $cleanmode .= ',no-check' if $2 eq 'n';
7398 $cleanmode .= ',all-check' if $2 eq 'a';
7399 } elsif (s/^-wc$//s) {
7401 $cleanmode = 'check';
7402 } elsif (s/^-wci$//s) {
7404 $cleanmode = 'check,ignores';
7405 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7406 push @git, '-c', $&;
7407 $gitcfgs{cmdline}{$1} = [ $2 ];
7408 } elsif (s/^-c([^=]+)$//s) {
7409 push @git, '-c', $&;
7410 $gitcfgs{cmdline}{$1} = [ 'true' ];
7411 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7413 $val = undef unless length $val;
7414 $valopt->($oi->{Short});
7417 badusage f_ "unknown short option \`%s'", $_;
7424 sub check_env_sanity () {
7425 my $blocked = new POSIX::SigSet;
7426 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess "$!";
7429 foreach my $name (qw(PIPE CHLD)) {
7430 my $signame = "SIG$name";
7431 my $signum = eval "POSIX::$signame" // die;
7432 die f_ "%s is set to something other than SIG_DFL\n",
7434 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7435 $blocked->ismember($signum) and
7436 die f_ "%s is blocked\n", $signame;
7442 On entry to dgit, %s
7443 This is a bug produced by something in your execution environment.
7449 sub parseopts_late_defaults () {
7450 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7451 if defined $idistro;
7452 $isuite //= cfg('dgit.default.default-suite');
7454 foreach my $k (keys %opts_opt_map) {
7455 my $om = $opts_opt_map{$k};
7457 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7459 badcfg f_ "cannot set command for %s", $k
7460 unless length $om->[0];
7464 foreach my $c (access_cfg_cfgs("opts-$k")) {
7466 map { $_ ? @$_ : () }
7467 map { $gitcfgs{$_}{$c} }
7468 reverse @gitcfgsources;
7469 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7470 "\n" if $debuglevel >= 4;
7472 badcfg f_ "cannot configure options for %s", $k
7473 if $opts_opt_cmdonly{$k};
7474 my $insertpos = $opts_cfg_insertpos{$k};
7475 @$om = ( @$om[0..$insertpos-1],
7477 @$om[$insertpos..$#$om] );
7481 if (!defined $rmchanges) {
7482 local $access_forpush;
7483 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7486 if (!defined $quilt_mode) {
7487 local $access_forpush;
7488 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7489 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7491 $quilt_mode =~ m/^($quilt_modes_re)$/
7492 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7496 foreach my $moc (@modeopt_cfgs) {
7497 local $access_forpush;
7498 my $vr = $moc->{Var};
7499 next if defined $$vr;
7500 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7501 my $v = $moc->{Vals}{$$vr};
7502 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7508 local $access_forpush;
7509 default_from_access_cfg(\$cleanmode, 'clean-mode', 'dpkg-source',
7513 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7514 $buildproductsdir //= '..';
7515 $bpd_glob = $buildproductsdir;
7516 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7519 setlocale(LC_MESSAGES, "");
7522 if ($ENV{$fakeeditorenv}) {
7524 quilt_fixup_editor();
7530 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7531 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7532 if $dryrun_level == 1;
7534 print STDERR __ $helpmsg or confess "$!";
7537 $cmd = $subcommand = shift @ARGV;
7540 my $pre_fn = ${*::}{"pre_$cmd"};
7541 $pre_fn->() if $pre_fn;
7543 if ($invoked_in_git_tree) {
7544 changedir_git_toplevel();
7549 my $fn = ${*::}{"cmd_$cmd"};
7550 $fn or badusage f_ "unknown operation %s", $cmd;