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;
35 use File::Temp qw(tempdir);
38 use Dpkg::Compression;
39 use Dpkg::Compression::Process;
45 use List::MoreUtils qw(pairwise);
46 use Text::Glob qw(match_glob);
47 use Fcntl qw(:DEFAULT :flock);
52 our $our_version = 'UNRELEASED'; ###substituted###
53 our $absurdity = undef; ###substituted###
55 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
66 our $dryrun_level = 0;
68 our $buildproductsdir;
71 our $includedirty = 0;
75 our $existing_package = 'dpkg';
77 our $changes_since_version;
79 our $overwrite_version; # undef: not specified; '': check changelog
81 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
83 our %internal_object_save;
84 our $we_are_responder;
85 our $we_are_initiator;
86 our $initiator_tempdir;
87 our $patches_applied_dirtily = 00;
91 our $chase_dsc_distro=1;
93 our %forceopts = map { $_=>0 }
94 qw(unrepresentable unsupported-source-format
95 dsc-changes-mismatch changes-origs-exactly
96 uploading-binaries uploading-source-only
97 import-gitapply-absurd
98 import-gitapply-no-absurd
99 import-dsc-with-dgit-field);
101 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
103 our $suite_re = '[-+.0-9a-z]+';
104 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
106 | check (?: ,ignores )?
110 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
111 our $splitbraincache = 'dgit-intern/quilt-cache';
112 our $rewritemap = 'dgit-rewrite/map';
114 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
116 our (@git) = qw(git);
117 our (@dget) = qw(dget);
118 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
119 our (@dput) = qw(dput);
120 our (@debsign) = qw(debsign);
121 our (@gpg) = qw(gpg);
122 our (@sbuild) = (qw(sbuild --no-source));
124 our (@dgit) = qw(dgit);
125 our (@git_debrebase) = qw(git-debrebase);
126 our (@aptget) = qw(apt-get);
127 our (@aptcache) = qw(apt-cache);
128 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
129 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
130 our (@dpkggenchanges) = qw(dpkg-genchanges);
131 our (@mergechanges) = qw(mergechanges -f);
132 our (@gbp_build) = ('');
133 our (@gbp_pq) = ('gbp pq');
134 our (@changesopts) = ('');
135 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
136 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
138 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
141 'debsign' => \@debsign,
143 'sbuild' => \@sbuild,
147 'git-debrebase' => \@git_debrebase,
148 'apt-get' => \@aptget,
149 'apt-cache' => \@aptcache,
150 'dpkg-source' => \@dpkgsource,
151 'dpkg-buildpackage' => \@dpkgbuildpackage,
152 'dpkg-genchanges' => \@dpkggenchanges,
153 'gbp-build' => \@gbp_build,
154 'gbp-pq' => \@gbp_pq,
155 'ch' => \@changesopts,
156 'mergechanges' => \@mergechanges,
157 'pbuilder' => \@pbuilder,
158 'cowbuilder' => \@cowbuilder);
160 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
161 our %opts_cfg_insertpos = map {
163 scalar @{ $opts_opt_map{$_} }
164 } keys %opts_opt_map;
166 sub parseopts_late_defaults();
167 sub setup_gitattrs(;$);
168 sub check_gitattrs($$);
175 our $supplementary_message = '';
176 our $split_brain = 0;
180 return unless forkcheck_mainprocess();
181 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
184 our $remotename = 'dgit';
185 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
189 if (!defined $absurdity) {
191 $absurdity =~ s{/[^/]+$}{/absurd} or die;
195 my ($v,$distro) = @_;
196 return $tagformatfn->($v, $distro);
199 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
201 sub lbranch () { return "$branchprefix/$csuite"; }
202 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
203 sub lref () { return "refs/heads/".lbranch(); }
204 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
205 sub rrref () { return server_ref($csuite); }
208 my ($vsn, $sfx) = @_;
209 return &source_file_leafname($package, $vsn, $sfx);
211 sub is_orig_file_of_vsn ($$) {
212 my ($f, $upstreamvsn) = @_;
213 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
218 return srcfn($vsn,".dsc");
221 sub changespat ($;$) {
222 my ($vsn, $arch) = @_;
223 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
232 return unless forkcheck_mainprocess();
233 foreach my $f (@end) {
235 print STDERR "$us: cleanup: $@" if length $@;
240 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
244 sub forceable_fail ($$) {
245 my ($forceoptsl, $msg) = @_;
246 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
247 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
251 my ($forceoptsl) = @_;
252 my @got = grep { $forceopts{$_} } @$forceoptsl;
253 return 0 unless @got;
255 "warning: skipping checks or functionality due to --force-%s\n",
259 sub no_such_package () {
260 print STDERR f_ "%s: package %s does not exist in suite %s\n",
261 $us, $package, $isuite;
265 sub deliberately ($) {
267 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
270 sub deliberately_not_fast_forward () {
271 foreach (qw(not-fast-forward fresh-repo)) {
272 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
276 sub quiltmode_splitbrain () {
277 $quilt_mode =~ m/gbp|dpm|unapplied/;
280 sub opts_opt_multi_cmd {
283 push @cmd, split /\s+/, shift @_;
290 return opts_opt_multi_cmd [], @gbp_pq;
293 sub dgit_privdir () {
294 our $dgit_privdir_made //= ensure_a_playground 'dgit';
298 my $r = $buildproductsdir;
299 $r = "$maindir/$r" unless $r =~ m{^/};
303 sub get_tree_of_commit ($) {
304 my ($commitish) = @_;
305 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
306 $cdata =~ m/\n\n/; $cdata = $`;
307 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
311 sub branch_gdr_info ($$) {
312 my ($symref, $head) = @_;
313 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
314 gdr_ffq_prev_branchinfo($symref);
315 return () unless $status eq 'branch';
316 $ffq_prev = git_get_ref $ffq_prev;
317 $gdrlast = git_get_ref $gdrlast;
318 $gdrlast &&= is_fast_fwd $gdrlast, $head;
319 return ($ffq_prev, $gdrlast);
322 sub branch_is_gdr_unstitched_ff ($$$) {
323 my ($symref, $head, $ancestor) = @_;
324 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
325 return 0 unless $ffq_prev;
326 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
330 sub branch_is_gdr ($) {
332 # This is quite like git-debrebase's keycommits.
333 # We have our own implementation because:
334 # - our algorighm can do fewer tests so is faster
335 # - it saves testing to see if gdr is installed
337 # NB we use this jsut for deciding whether to run gdr make-patches
338 # Before reusing this algorithm for somthing else, its
339 # suitability should be reconsidered.
342 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
343 printdebug "branch_is_gdr $head...\n";
344 my $get_patches = sub {
345 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
348 my $tip_patches = $get_patches->($head);
351 my $cdata = git_cat_file $walk, 'commit';
352 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
353 if ($msg =~ m{^\[git-debrebase\ (
354 anchor | changelog | make-patches |
355 merged-breakwater | pseudomerge
357 # no need to analyse this - it's sufficient
358 # (gdr classifications: Anchor, MergedBreakwaters)
359 # (made by gdr: Pseudomerge, Changelog)
360 printdebug "branch_is_gdr $walk gdr $1 YES\n";
363 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
365 my $walk_tree = get_tree_of_commit $walk;
366 foreach my $p (@parents) {
367 my $p_tree = get_tree_of_commit $p;
368 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
369 # (gdr classification: Pseudomerge; not made by gdr)
370 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
376 # some other non-gdr merge
377 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
378 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
382 # (gdr classification: ?)
383 printdebug "branch_is_gdr $walk ?-octopus NO\n";
387 printdebug "branch_is_gdr $walk origin\n";
390 if ($get_patches->($walk) ne $tip_patches) {
391 # Our parent added, removed, or edited patches, and wasn't
392 # a gdr make-patches commit. gdr make-patches probably
393 # won't do that well, then.
394 # (gdr classification of parent: AddPatches or ?)
395 printdebug "branch_is_gdr $walk ?-patches NO\n";
398 if ($tip_patches eq '' and
399 !defined git_cat_file "$walk:debian") {
400 # (gdr classification of parent: BreakwaterStart
401 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
404 # (gdr classification: Upstream Packaging Mixed Changelog)
405 printdebug "branch_is_gdr $walk plain\n"
411 #---------- remote protocol support, common ----------
413 # remote push initiator/responder protocol:
414 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
415 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
416 # < dgit-remote-push-ready <actual-proto-vsn>
423 # > supplementary-message NBYTES # $protovsn >= 3
428 # > file parsed-changelog
429 # [indicates that output of dpkg-parsechangelog follows]
430 # > data-block NBYTES
431 # > [NBYTES bytes of data (no newline)]
432 # [maybe some more blocks]
441 # > param head DGIT-VIEW-HEAD
442 # > param csuite SUITE
443 # > param tagformat old|new
444 # > param maint-view MAINT-VIEW-HEAD
446 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
447 # > file buildinfo # for buildinfos to sign
449 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
450 # # goes into tag, for replay prevention
453 # [indicates that signed tag is wanted]
454 # < data-block NBYTES
455 # < [NBYTES bytes of data (no newline)]
456 # [maybe some more blocks]
460 # > want signed-dsc-changes
461 # < data-block NBYTES [transfer of signed dsc]
463 # < data-block NBYTES [transfer of signed changes]
465 # < data-block NBYTES [transfer of each signed buildinfo
466 # [etc] same number and order as "file buildinfo"]
474 sub i_child_report () {
475 # Sees if our child has died, and reap it if so. Returns a string
476 # describing how it died if it failed, or undef otherwise.
477 return undef unless $i_child_pid;
478 my $got = waitpid $i_child_pid, WNOHANG;
479 return undef if $got <= 0;
480 die unless $got == $i_child_pid;
481 $i_child_pid = undef;
482 return undef unless $?;
483 return f_ "build host child %s", waitstatusmsg();
488 fail f_ "connection lost: %s", $! if $fh->error;
489 fail f_ "protocol violation; %s not expected", $m;
492 sub badproto_badread ($$) {
494 fail f_ "connection lost: %s", $! if $!;
495 my $report = i_child_report();
496 fail $report if defined $report;
497 badproto $fh, f_ "eof (reading %s)", $wh;
500 sub protocol_expect (&$) {
501 my ($match, $fh) = @_;
504 defined && chomp or badproto_badread $fh, __ "protocol message";
512 badproto $fh, f_ "\`%s'", $_;
515 sub protocol_send_file ($$) {
516 my ($fh, $ourfn) = @_;
517 open PF, "<", $ourfn or die "$ourfn: $!";
520 my $got = read PF, $d, 65536;
521 die "$ourfn: $!" unless defined $got;
523 print $fh "data-block ".length($d)."\n" or confess $!;
524 print $fh $d or confess $!;
526 PF->error and die "$ourfn $!";
527 print $fh "data-end\n" or confess $!;
531 sub protocol_read_bytes ($$) {
532 my ($fh, $nbytes) = @_;
533 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
535 my $got = read $fh, $d, $nbytes;
536 $got==$nbytes or badproto_badread $fh, __ "data block";
540 sub protocol_receive_file ($$) {
541 my ($fh, $ourfn) = @_;
542 printdebug "() $ourfn\n";
543 open PF, ">", $ourfn or die "$ourfn: $!";
545 my ($y,$l) = protocol_expect {
546 m/^data-block (.*)$/ ? (1,$1) :
547 m/^data-end$/ ? (0,) :
551 my $d = protocol_read_bytes $fh, $l;
552 print PF $d or confess $!;
554 close PF or confess $!;
557 #---------- remote protocol support, responder ----------
559 sub responder_send_command ($) {
561 return unless $we_are_responder;
562 # called even without $we_are_responder
563 printdebug ">> $command\n";
564 print PO $command, "\n" or confess $!;
567 sub responder_send_file ($$) {
568 my ($keyword, $ourfn) = @_;
569 return unless $we_are_responder;
570 printdebug "]] $keyword $ourfn\n";
571 responder_send_command "file $keyword";
572 protocol_send_file \*PO, $ourfn;
575 sub responder_receive_files ($@) {
576 my ($keyword, @ourfns) = @_;
577 die unless $we_are_responder;
578 printdebug "[[ $keyword @ourfns\n";
579 responder_send_command "want $keyword";
580 foreach my $fn (@ourfns) {
581 protocol_receive_file \*PI, $fn;
584 protocol_expect { m/^files-end$/ } \*PI;
587 #---------- remote protocol support, initiator ----------
589 sub initiator_expect (&) {
591 protocol_expect { &$match } \*RO;
594 #---------- end remote code ----------
597 if ($we_are_responder) {
599 responder_send_command "progress ".length($m) or confess $!;
600 print PO $m or confess $!;
610 $ua = LWP::UserAgent->new();
614 progress "downloading $what...";
615 my $r = $ua->get(@_) or confess $!;
616 return undef if $r->code == 404;
617 $r->is_success or fail f_ "failed to fetch %s: %s",
618 $what, $r->status_line;
619 return $r->decoded_content(charset => 'none');
622 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
624 sub act_local () { return $dryrun_level <= 1; }
625 sub act_scary () { return !$dryrun_level; }
628 if (!$dryrun_level) {
629 progress f_ "%s ok: %s", $us, "@_";
631 progress f_ "would be ok: %s (but dry run only)", "@_";
636 printcmd(\*STDERR,$debugprefix."#",@_);
639 sub runcmd_ordryrun {
647 sub runcmd_ordryrun_local {
655 our $helpmsg = i_ <<END;
657 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
658 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
659 dgit [dgit-opts] build [dpkg-buildpackage-opts]
660 dgit [dgit-opts] sbuild [sbuild-opts]
661 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
662 dgit [dgit-opts] push [dgit-opts] [suite]
663 dgit [dgit-opts] push-source [dgit-opts] [suite]
664 dgit [dgit-opts] rpush build-host:build-dir ...
665 important dgit options:
666 -k<keyid> sign tag and package with <keyid> instead of default
667 --dry-run -n do not change anything, but go through the motions
668 --damp-run -L like --dry-run but make local changes, without signing
669 --new -N allow introducing a new package
670 --debug -D increase debug level
671 -c<name>=<value> set git config option (used directly by dgit too)
674 our $later_warning_msg = i_ <<END;
675 Perhaps the upload is stuck in incoming. Using the version from git.
679 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess $!;
684 @ARGV or badusage __ "too few arguments";
685 return scalar shift @ARGV;
689 not_necessarily_a_tree();
692 print __ $helpmsg or confess $!;
696 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
698 our %defcfg = ('dgit.default.distro' => 'debian',
699 'dgit.default.default-suite' => 'unstable',
700 'dgit.default.old-dsc-distro' => 'debian',
701 'dgit-suite.*-security.distro' => 'debian-security',
702 'dgit.default.username' => '',
703 'dgit.default.archive-query-default-component' => 'main',
704 'dgit.default.ssh' => 'ssh',
705 'dgit.default.archive-query' => 'madison:',
706 'dgit.default.sshpsql-dbname' => 'service=projectb',
707 'dgit.default.aptget-components' => 'main',
708 'dgit.default.dgit-tag-format' => 'new,old,maint',
709 'dgit.default.source-only-uploads' => 'ok',
710 'dgit.dsc-url-proto-ok.http' => 'true',
711 'dgit.dsc-url-proto-ok.https' => 'true',
712 'dgit.dsc-url-proto-ok.git' => 'true',
713 'dgit.vcs-git.suites', => 'sid', # ;-separated
714 'dgit.default.dsc-url-proto-ok' => 'false',
715 # old means "repo server accepts pushes with old dgit tags"
716 # new means "repo server accepts pushes with new dgit tags"
717 # maint means "repo server accepts split brain pushes"
718 # hist means "repo server may have old pushes without new tag"
719 # ("hist" is implied by "old")
720 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
721 'dgit-distro.debian.git-check' => 'url',
722 'dgit-distro.debian.git-check-suffix' => '/info/refs',
723 'dgit-distro.debian.new-private-pushers' => 't',
724 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
725 'dgit-distro.debian/push.git-url' => '',
726 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
727 'dgit-distro.debian/push.git-user-force' => 'dgit',
728 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
729 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
730 'dgit-distro.debian/push.git-create' => 'true',
731 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
732 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
733 # 'dgit-distro.debian.archive-query-tls-key',
734 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
735 # ^ this does not work because curl is broken nowadays
736 # Fixing #790093 properly will involve providing providing the key
737 # in some pacagke and maybe updating these paths.
739 # 'dgit-distro.debian.archive-query-tls-curl-args',
740 # '--ca-path=/etc/ssl/ca-debian',
741 # ^ this is a workaround but works (only) on DSA-administered machines
742 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
743 'dgit-distro.debian.git-url-suffix' => '',
744 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
745 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
746 'dgit-distro.debian-security.archive-query' => 'aptget:',
747 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
748 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
749 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
750 'dgit-distro.debian-security.nominal-distro' => 'debian',
751 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
752 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
753 'dgit-distro.ubuntu.git-check' => 'false',
754 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
755 'dgit-distro.test-dummy.ssh' => "$td/ssh",
756 'dgit-distro.test-dummy.username' => "alice",
757 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
758 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
759 'dgit-distro.test-dummy.git-url' => "$td/git",
760 'dgit-distro.test-dummy.git-host' => "git",
761 'dgit-distro.test-dummy.git-path' => "$td/git",
762 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
763 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
764 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
765 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
769 our @gitcfgsources = qw(cmdline local global system);
770 our $invoked_in_git_tree = 1;
772 sub git_slurp_config () {
773 # This algoritm is a bit subtle, but this is needed so that for
774 # options which we want to be single-valued, we allow the
775 # different config sources to override properly. See #835858.
776 foreach my $src (@gitcfgsources) {
777 next if $src eq 'cmdline';
778 # we do this ourselves since git doesn't handle it
780 $gitcfgs{$src} = git_slurp_config_src $src;
784 sub git_get_config ($) {
786 foreach my $src (@gitcfgsources) {
787 my $l = $gitcfgs{$src}{$c};
788 confess "internal error ($l $c)" if $l && !ref $l;
789 printdebug"C $c ".(defined $l ?
790 join " ", map { messagequote "'$_'" } @$l :
795 f_ "multiple values for %s (in %s git config)", $c, $src
797 $l->[0] =~ m/\n/ and badcfg f_
798 "value for config option %s (in %s git config) contains newline(s)!",
807 return undef if $c =~ /RETURN-UNDEF/;
808 printdebug "C? $c\n" if $debuglevel >= 5;
809 my $v = git_get_config($c);
810 return $v if defined $v;
811 my $dv = $defcfg{$c};
813 printdebug "CD $c $dv\n" if $debuglevel >= 4;
818 "need value for one of: %s\n".
819 "%s: distro or suite appears not to be (properly) supported",
823 sub not_necessarily_a_tree () {
824 # needs to be called from pre_*
825 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
826 $invoked_in_git_tree = 0;
829 sub access_basedistro__noalias () {
830 if (defined $idistro) {
833 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
834 return $def if defined $def;
835 foreach my $src (@gitcfgsources, 'internal') {
836 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
838 foreach my $k (keys %$kl) {
839 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
841 next unless match_glob $dpat, $isuite;
845 return cfg("dgit.default.distro");
849 sub access_basedistro () {
850 my $noalias = access_basedistro__noalias();
851 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
852 return $canon // $noalias;
855 sub access_nomdistro () {
856 my $base = access_basedistro();
857 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
858 $r =~ m/^$distro_re$/ or badcfg
859 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
860 $r, "/^$distro_re$/";
864 sub access_quirk () {
865 # returns (quirk name, distro to use instead or undef, quirk-specific info)
866 my $basedistro = access_basedistro();
867 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
869 if (defined $backports_quirk) {
870 my $re = $backports_quirk;
871 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
873 $re =~ s/\%/([-0-9a-z_]+)/
874 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
875 if ($isuite =~ m/^$re$/) {
876 return ('backports',"$basedistro-backports",$1);
879 return ('none',undef);
884 sub parse_cfg_bool ($$$) {
885 my ($what,$def,$v) = @_;
888 $v =~ m/^[ty1]/ ? 1 :
889 $v =~ m/^[fn0]/ ? 0 :
890 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
894 sub access_forpush_config () {
895 my $d = access_basedistro();
899 parse_cfg_bool('new-private-pushers', 0,
900 cfg("dgit-distro.$d.new-private-pushers",
903 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
906 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
907 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
908 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
910 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
913 sub access_forpush () {
914 $access_forpush //= access_forpush_config();
915 return $access_forpush;
919 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
920 defined $access_forpush and !$access_forpush;
921 badcfg __ "pushing but distro is configured readonly"
922 if access_forpush_config() eq '0';
924 $supplementary_message = __ <<'END' unless $we_are_responder;
925 Push failed, before we got started.
926 You can retry the push, after fixing the problem, if you like.
928 parseopts_late_defaults();
932 parseopts_late_defaults();
935 sub supplementary_message ($) {
937 if (!$we_are_responder) {
938 $supplementary_message = $msg;
940 } elsif ($protovsn >= 3) {
941 responder_send_command "supplementary-message ".length($msg)
943 print PO $msg or confess $!;
947 sub access_distros () {
948 # Returns list of distros to try, in order
951 # 0. `instead of' distro name(s) we have been pointed to
952 # 1. the access_quirk distro, if any
953 # 2a. the user's specified distro, or failing that } basedistro
954 # 2b. the distro calculated from the suite }
955 my @l = access_basedistro();
957 my (undef,$quirkdistro) = access_quirk();
958 unshift @l, $quirkdistro;
959 unshift @l, $instead_distro;
960 @l = grep { defined } @l;
962 push @l, access_nomdistro();
964 if (access_forpush()) {
965 @l = map { ("$_/push", $_) } @l;
970 sub access_cfg_cfgs (@) {
973 # The nesting of these loops determines the search order. We put
974 # the key loop on the outside so that we search all the distros
975 # for each key, before going on to the next key. That means that
976 # if access_cfg is called with a more specific, and then a less
977 # specific, key, an earlier distro can override the less specific
978 # without necessarily overriding any more specific keys. (If the
979 # distro wants to override the more specific keys it can simply do
980 # so; whereas if we did the loop the other way around, it would be
981 # impossible to for an earlier distro to override a less specific
982 # key but not the more specific ones without restating the unknown
983 # values of the more specific keys.
986 # We have to deal with RETURN-UNDEF specially, so that we don't
987 # terminate the search prematurely.
989 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
992 foreach my $d (access_distros()) {
993 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
995 push @cfgs, map { "dgit.default.$_" } @realkeys;
1000 sub access_cfg (@) {
1002 my (@cfgs) = access_cfg_cfgs(@keys);
1003 my $value = cfg(@cfgs);
1007 sub access_cfg_bool ($$) {
1008 my ($def, @keys) = @_;
1009 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1012 sub string_to_ssh ($) {
1014 if ($spec =~ m/\s/) {
1015 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1021 sub access_cfg_ssh () {
1022 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1023 if (!defined $gitssh) {
1026 return string_to_ssh $gitssh;
1030 sub access_runeinfo ($) {
1032 return ": dgit ".access_basedistro()." $info ;";
1035 sub access_someuserhost ($) {
1037 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1038 defined($user) && length($user) or
1039 $user = access_cfg("$some-user",'username');
1040 my $host = access_cfg("$some-host");
1041 return length($user) ? "$user\@$host" : $host;
1044 sub access_gituserhost () {
1045 return access_someuserhost('git');
1048 sub access_giturl (;$) {
1049 my ($optional) = @_;
1050 my $url = access_cfg('git-url','RETURN-UNDEF');
1053 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1054 return undef unless defined $proto;
1057 access_gituserhost().
1058 access_cfg('git-path');
1060 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1063 return "$url/$package$suffix";
1066 sub commit_getclogp ($) {
1067 # Returns the parsed changelog hashref for a particular commit
1069 our %commit_getclogp_memo;
1070 my $memo = $commit_getclogp_memo{$objid};
1071 return $memo if $memo;
1073 my $mclog = dgit_privdir()."clog";
1074 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1075 "$objid:debian/changelog";
1076 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1079 sub parse_dscdata () {
1080 my $dscfh = new IO::File \$dscdata, '<' or confess $!;
1081 printdebug Dumper($dscdata) if $debuglevel>1;
1082 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1083 printdebug Dumper($dsc) if $debuglevel>1;
1088 sub archive_query ($;@) {
1089 my ($method) = shift @_;
1090 fail __ "this operation does not support multiple comma-separated suites"
1092 my $query = access_cfg('archive-query','RETURN-UNDEF');
1093 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1096 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1099 sub archive_query_prepend_mirror {
1100 my $m = access_cfg('mirror');
1101 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1104 sub pool_dsc_subpath ($$) {
1105 my ($vsn,$component) = @_; # $package is implict arg
1106 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1107 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1110 sub cfg_apply_map ($$$) {
1111 my ($varref, $what, $mapspec) = @_;
1112 return unless $mapspec;
1114 printdebug "config $what EVAL{ $mapspec; }\n";
1116 eval "package Dgit::Config; $mapspec;";
1121 #---------- `ftpmasterapi' archive query method (nascent) ----------
1123 sub archive_api_query_cmd ($) {
1125 my @cmd = (@curl, qw(-sS));
1126 my $url = access_cfg('archive-query-url');
1127 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1129 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1130 foreach my $key (split /\:/, $keys) {
1131 $key =~ s/\%HOST\%/$host/g;
1133 fail "for $url: stat $key: $!" unless $!==ENOENT;
1136 fail f_ "config requested specific TLS key but do not know".
1137 " how to get curl to use exactly that EE key (%s)",
1139 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1140 # # Sadly the above line does not work because of changes
1141 # # to gnutls. The real fix for #790093 may involve
1142 # # new curl options.
1145 # Fixing #790093 properly will involve providing a value
1146 # for this on clients.
1147 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1148 push @cmd, split / /, $kargs if defined $kargs;
1150 push @cmd, $url.$subpath;
1154 sub api_query ($$;$) {
1156 my ($data, $subpath, $ok404) = @_;
1157 badcfg __ "ftpmasterapi archive query method takes no data part"
1159 my @cmd = archive_api_query_cmd($subpath);
1160 my $url = $cmd[$#cmd];
1161 push @cmd, qw(-w %{http_code});
1162 my $json = cmdoutput @cmd;
1163 unless ($json =~ s/\d+\d+\d$//) {
1164 failedcmd_report_cmd undef, @cmd;
1165 fail __ "curl failed to print 3-digit HTTP code";
1168 return undef if $code eq '404' && $ok404;
1169 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1170 unless $url =~ m#^file://# or $code =~ m/^2/;
1171 return decode_json($json);
1174 sub canonicalise_suite_ftpmasterapi {
1175 my ($proto,$data) = @_;
1176 my $suites = api_query($data, 'suites');
1178 foreach my $entry (@$suites) {
1180 my $v = $entry->{$_};
1181 defined $v && $v eq $isuite;
1182 } qw(codename name);
1183 push @matched, $entry;
1185 fail f_ "unknown suite %s, maybe -d would help", $isuite
1189 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1190 $cn = "$matched[0]{codename}";
1191 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1192 $cn =~ m/^$suite_re$/
1193 or die f_ "suite %s maps to bad codename\n", $isuite;
1195 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1200 sub archive_query_ftpmasterapi {
1201 my ($proto,$data) = @_;
1202 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1204 my $digester = Digest::SHA->new(256);
1205 foreach my $entry (@$info) {
1207 my $vsn = "$entry->{version}";
1208 my ($ok,$msg) = version_check $vsn;
1209 die f_ "bad version: %s\n", $msg unless $ok;
1210 my $component = "$entry->{component}";
1211 $component =~ m/^$component_re$/ or die __ "bad component";
1212 my $filename = "$entry->{filename}";
1213 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1214 or die __ "bad filename";
1215 my $sha256sum = "$entry->{sha256sum}";
1216 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1217 push @rows, [ $vsn, "/pool/$component/$filename",
1218 $digester, $sha256sum ];
1220 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1223 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1224 return archive_query_prepend_mirror @rows;
1227 sub file_in_archive_ftpmasterapi {
1228 my ($proto,$data,$filename) = @_;
1229 my $pat = $filename;
1232 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1233 my $info = api_query($data, "file_in_archive/$pat", 1);
1236 sub package_not_wholly_new_ftpmasterapi {
1237 my ($proto,$data,$pkg) = @_;
1238 my $info = api_query($data,"madison?package=${pkg}&f=json");
1242 #---------- `aptget' archive query method ----------
1245 our $aptget_releasefile;
1246 our $aptget_configpath;
1248 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1249 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1251 sub aptget_cache_clean {
1252 runcmd_ordryrun_local qw(sh -ec),
1253 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1257 sub aptget_lock_acquire () {
1258 my $lockfile = "$aptget_base/lock";
1259 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1260 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1263 sub aptget_prep ($) {
1265 return if defined $aptget_base;
1267 badcfg __ "aptget archive query method takes no data part"
1270 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1273 ensuredir "$cache/dgit";
1275 access_cfg('aptget-cachekey','RETURN-UNDEF')
1276 // access_nomdistro();
1278 $aptget_base = "$cache/dgit/aptget";
1279 ensuredir $aptget_base;
1281 my $quoted_base = $aptget_base;
1282 confess "$quoted_base contains bad chars, cannot continue"
1283 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1285 ensuredir $aptget_base;
1287 aptget_lock_acquire();
1289 aptget_cache_clean();
1291 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1292 my $sourceslist = "source.list#$cachekey";
1294 my $aptsuites = $isuite;
1295 cfg_apply_map(\$aptsuites, 'suite map',
1296 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1298 open SRCS, ">", "$aptget_base/$sourceslist" or confess $!;
1299 printf SRCS "deb-src %s %s %s\n",
1300 access_cfg('mirror'),
1302 access_cfg('aptget-components')
1305 ensuredir "$aptget_base/cache";
1306 ensuredir "$aptget_base/lists";
1308 open CONF, ">", $aptget_configpath or confess $!;
1310 Debug::NoLocking "true";
1311 APT::Get::List-Cleanup "false";
1312 #clear APT::Update::Post-Invoke-Success;
1313 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1314 Dir::State::Lists "$quoted_base/lists";
1315 Dir::Etc::preferences "$quoted_base/preferences";
1316 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1317 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1320 foreach my $key (qw(
1323 Dir::Cache::Archives
1324 Dir::Etc::SourceParts
1325 Dir::Etc::preferencesparts
1327 ensuredir "$aptget_base/$key";
1328 print CONF "$key \"$quoted_base/$key\";\n" or confess $!;
1331 my $oldatime = (time // confess $!) - 1;
1332 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1333 next unless stat_exists $oldlist;
1334 my ($mtime) = (stat _)[9];
1335 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1338 runcmd_ordryrun_local aptget_aptget(), qw(update);
1341 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1342 next unless stat_exists $oldlist;
1343 my ($atime) = (stat _)[8];
1344 next if $atime == $oldatime;
1345 push @releasefiles, $oldlist;
1347 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1348 @releasefiles = @inreleasefiles if @inreleasefiles;
1349 if (!@releasefiles) {
1350 fail f_ <<END, $isuite, $cache;
1351 apt seemed to not to update dgit's cached Release files for %s.
1353 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1356 confess "apt updated too many Release files (@releasefiles), erk"
1357 unless @releasefiles == 1;
1359 ($aptget_releasefile) = @releasefiles;
1362 sub canonicalise_suite_aptget {
1363 my ($proto,$data) = @_;
1366 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1368 foreach my $name (qw(Codename Suite)) {
1369 my $val = $release->{$name};
1371 printdebug "release file $name: $val\n";
1372 $val =~ m/^$suite_re$/o or fail f_
1373 "Release file (%s) specifies intolerable %s",
1374 $aptget_releasefile, $name;
1375 cfg_apply_map(\$val, 'suite rmap',
1376 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1383 sub archive_query_aptget {
1384 my ($proto,$data) = @_;
1387 ensuredir "$aptget_base/source";
1388 foreach my $old (<$aptget_base/source/*.dsc>) {
1389 unlink $old or die "$old: $!";
1392 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1393 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1394 # avoids apt-get source failing with ambiguous error code
1396 runcmd_ordryrun_local
1397 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1398 aptget_aptget(), qw(--download-only --only-source source), $package;
1400 my @dscs = <$aptget_base/source/*.dsc>;
1401 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1402 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1405 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1408 my $uri = "file://". uri_escape $dscs[0];
1409 $uri =~ s{\%2f}{/}gi;
1410 return [ (getfield $pre_dsc, 'Version'), $uri ];
1413 sub file_in_archive_aptget () { return undef; }
1414 sub package_not_wholly_new_aptget () { return undef; }
1416 #---------- `dummyapicat' archive query method ----------
1417 # (untranslated, because this is for testing purposes etc.)
1419 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1420 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1422 sub dummycatapi_run_in_mirror ($@) {
1423 # runs $fn with FIA open onto rune
1424 my ($rune, $argl, $fn) = @_;
1426 my $mirror = access_cfg('mirror');
1427 $mirror =~ s#^file://#/# or die "$mirror ?";
1428 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1429 qw(x), $mirror, @$argl);
1430 debugcmd "-|", @cmd;
1431 open FIA, "-|", @cmd or confess $!;
1433 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1437 sub file_in_archive_dummycatapi ($$$) {
1438 my ($proto,$data,$filename) = @_;
1440 dummycatapi_run_in_mirror '
1441 find -name "$1" -print0 |
1443 ', [$filename], sub {
1446 printdebug "| $_\n";
1447 m/^(\w+) (\S+)$/ or die "$_ ?";
1448 push @out, { sha256sum => $1, filename => $2 };
1454 sub package_not_wholly_new_dummycatapi {
1455 my ($proto,$data,$pkg) = @_;
1456 dummycatapi_run_in_mirror "
1457 find -name ${pkg}_*.dsc
1464 #---------- `madison' archive query method ----------
1466 sub archive_query_madison {
1467 return archive_query_prepend_mirror
1468 map { [ @$_[0..1] ] } madison_get_parse(@_);
1471 sub madison_get_parse {
1472 my ($proto,$data) = @_;
1473 die unless $proto eq 'madison';
1474 if (!length $data) {
1475 $data= access_cfg('madison-distro','RETURN-UNDEF');
1476 $data //= access_basedistro();
1478 $rmad{$proto,$data,$package} ||= cmdoutput
1479 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1480 my $rmad = $rmad{$proto,$data,$package};
1483 foreach my $l (split /\n/, $rmad) {
1484 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1485 \s*( [^ \t|]+ )\s* \|
1486 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1487 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1488 $1 eq $package or die "$rmad $package ?";
1495 $component = access_cfg('archive-query-default-component');
1497 $5 eq 'source' or die "$rmad ?";
1498 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1500 return sort { -version_compare($a->[0],$b->[0]); } @out;
1503 sub canonicalise_suite_madison {
1504 # madison canonicalises for us
1505 my @r = madison_get_parse(@_);
1507 "unable to canonicalise suite using package %s".
1508 " which does not appear to exist in suite %s;".
1509 " --existing-package may help",
1514 sub file_in_archive_madison { return undef; }
1515 sub package_not_wholly_new_madison { return undef; }
1517 #---------- `sshpsql' archive query method ----------
1518 # (untranslated, because this is obsolete)
1521 my ($data,$runeinfo,$sql) = @_;
1522 if (!length $data) {
1523 $data= access_someuserhost('sshpsql').':'.
1524 access_cfg('sshpsql-dbname');
1526 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1527 my ($userhost,$dbname) = ($`,$'); #';
1529 my @cmd = (access_cfg_ssh, $userhost,
1530 access_runeinfo("ssh-psql $runeinfo").
1531 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1532 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1534 open P, "-|", @cmd or confess $!;
1537 printdebug(">|$_|\n");
1540 $!=0; $?=0; close P or failedcmd @cmd;
1542 my $nrows = pop @rows;
1543 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1544 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1545 @rows = map { [ split /\|/, $_ ] } @rows;
1546 my $ncols = scalar @{ shift @rows };
1547 die if grep { scalar @$_ != $ncols } @rows;
1551 sub sql_injection_check {
1552 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1555 sub archive_query_sshpsql ($$) {
1556 my ($proto,$data) = @_;
1557 sql_injection_check $isuite, $package;
1558 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1559 SELECT source.version, component.name, files.filename, files.sha256sum
1561 JOIN src_associations ON source.id = src_associations.source
1562 JOIN suite ON suite.id = src_associations.suite
1563 JOIN dsc_files ON dsc_files.source = source.id
1564 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1565 JOIN component ON component.id = files_archive_map.component_id
1566 JOIN files ON files.id = dsc_files.file
1567 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1568 AND source.source='$package'
1569 AND files.filename LIKE '%.dsc';
1571 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1572 my $digester = Digest::SHA->new(256);
1574 my ($vsn,$component,$filename,$sha256sum) = @$_;
1575 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1577 return archive_query_prepend_mirror @rows;
1580 sub canonicalise_suite_sshpsql ($$) {
1581 my ($proto,$data) = @_;
1582 sql_injection_check $isuite;
1583 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1584 SELECT suite.codename
1585 FROM suite where suite_name='$isuite' or codename='$isuite';
1587 @rows = map { $_->[0] } @rows;
1588 fail "unknown suite $isuite" unless @rows;
1589 die "ambiguous $isuite: @rows ?" if @rows>1;
1593 sub file_in_archive_sshpsql ($$$) { return undef; }
1594 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1596 #---------- `dummycat' archive query method ----------
1597 # (untranslated, because this is for testing purposes etc.)
1599 sub canonicalise_suite_dummycat ($$) {
1600 my ($proto,$data) = @_;
1601 my $dpath = "$data/suite.$isuite";
1602 if (!open C, "<", $dpath) {
1603 $!==ENOENT or die "$dpath: $!";
1604 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1608 chomp or die "$dpath: $!";
1610 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1614 sub archive_query_dummycat ($$) {
1615 my ($proto,$data) = @_;
1616 canonicalise_suite();
1617 my $dpath = "$data/package.$csuite.$package";
1618 if (!open C, "<", $dpath) {
1619 $!==ENOENT or die "$dpath: $!";
1620 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1628 printdebug "dummycat query $csuite $package $dpath | $_\n";
1629 my @row = split /\s+/, $_;
1630 @row==2 or die "$dpath: $_ ?";
1633 C->error and die "$dpath: $!";
1635 return archive_query_prepend_mirror
1636 sort { -version_compare($a->[0],$b->[0]); } @rows;
1639 sub file_in_archive_dummycat () { return undef; }
1640 sub package_not_wholly_new_dummycat () { return undef; }
1642 #---------- tag format handling ----------
1643 # (untranslated, because everything should be new tag format by now)
1645 sub access_cfg_tagformats () {
1646 split /\,/, access_cfg('dgit-tag-format');
1649 sub access_cfg_tagformats_can_splitbrain () {
1650 my %y = map { $_ => 1 } access_cfg_tagformats;
1651 foreach my $needtf (qw(new maint)) {
1652 next if $y{$needtf};
1658 sub need_tagformat ($$) {
1659 my ($fmt, $why) = @_;
1660 fail "need to use tag format $fmt ($why) but also need".
1661 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1662 " - no way to proceed"
1663 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1664 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1667 sub select_tagformat () {
1669 return if $tagformatfn && !$tagformat_want;
1670 die 'bug' if $tagformatfn && $tagformat_want;
1671 # ... $tagformat_want assigned after previous select_tagformat
1673 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1674 printdebug "select_tagformat supported @supported\n";
1676 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1677 printdebug "select_tagformat specified @$tagformat_want\n";
1679 my ($fmt,$why,$override) = @$tagformat_want;
1681 fail "target distro supports tag formats @supported".
1682 " but have to use $fmt ($why)"
1684 or grep { $_ eq $fmt } @supported;
1686 $tagformat_want = undef;
1688 $tagformatfn = ${*::}{"debiantag_$fmt"};
1690 fail "trying to use unknown tag format \`$fmt' ($why) !"
1691 unless $tagformatfn;
1694 #---------- archive query entrypoints and rest of program ----------
1696 sub canonicalise_suite () {
1697 return if defined $csuite;
1698 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1699 $csuite = archive_query('canonicalise_suite');
1700 if ($isuite ne $csuite) {
1701 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1703 progress f_ "canonical suite name is %s", $csuite;
1707 sub get_archive_dsc () {
1708 canonicalise_suite();
1709 my @vsns = archive_query('archive_query');
1710 foreach my $vinfo (@vsns) {
1711 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1712 $dscurl = $vsn_dscurl;
1713 $dscdata = url_get($dscurl);
1715 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1720 $digester->add($dscdata);
1721 my $got = $digester->hexdigest();
1723 fail f_ "%s has hash %s but archive told us to expect %s",
1724 $dscurl, $got, $digest;
1727 my $fmt = getfield $dsc, 'Format';
1728 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1729 f_ "unsupported source format %s, sorry", $fmt;
1731 $dsc_checked = !!$digester;
1732 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1736 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1739 sub check_for_git ();
1740 sub check_for_git () {
1742 my $how = access_cfg('git-check');
1743 if ($how eq 'ssh-cmd') {
1745 (access_cfg_ssh, access_gituserhost(),
1746 access_runeinfo("git-check $package").
1747 " set -e; cd ".access_cfg('git-path').";".
1748 " if test -d $package.git; then echo 1; else echo 0; fi");
1749 my $r= cmdoutput @cmd;
1750 if (defined $r and $r =~ m/^divert (\w+)$/) {
1752 my ($usedistro,) = access_distros();
1753 # NB that if we are pushing, $usedistro will be $distro/push
1754 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1755 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1756 progress f_ "diverting to %s (using config for %s)",
1757 $divert, $instead_distro;
1758 return check_for_git();
1760 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1762 } elsif ($how eq 'url') {
1763 my $prefix = access_cfg('git-check-url','git-url');
1764 my $suffix = access_cfg('git-check-suffix','git-suffix',
1765 'RETURN-UNDEF') // '.git';
1766 my $url = "$prefix/$package$suffix";
1767 my @cmd = (@curl, qw(-sS -I), $url);
1768 my $result = cmdoutput @cmd;
1769 $result =~ s/^\S+ 200 .*\n\r?\n//;
1770 # curl -sS -I with https_proxy prints
1771 # HTTP/1.0 200 Connection established
1772 $result =~ m/^\S+ (404|200) /s or
1773 fail +(__ "unexpected results from git check query - ").
1774 Dumper($prefix, $result);
1776 if ($code eq '404') {
1778 } elsif ($code eq '200') {
1783 } elsif ($how eq 'true') {
1785 } elsif ($how eq 'false') {
1788 badcfg f_ "unknown git-check \`%s'", $how;
1792 sub create_remote_git_repo () {
1793 my $how = access_cfg('git-create');
1794 if ($how eq 'ssh-cmd') {
1796 (access_cfg_ssh, access_gituserhost(),
1797 access_runeinfo("git-create $package").
1798 "set -e; cd ".access_cfg('git-path').";".
1799 " cp -a _template $package.git");
1800 } elsif ($how eq 'true') {
1803 badcfg f_ "unknown git-create \`%s'", $how;
1807 our ($dsc_hash,$lastpush_mergeinput);
1808 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1812 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1813 $playground = fresh_playground 'dgit/unpack';
1816 sub mktree_in_ud_here () {
1817 playtree_setup $gitcfgs{local};
1820 sub git_write_tree () {
1821 my $tree = cmdoutput @git, qw(write-tree);
1822 $tree =~ m/^\w+$/ or die "$tree ?";
1826 sub git_add_write_tree () {
1827 runcmd @git, qw(add -Af .);
1828 return git_write_tree();
1831 sub remove_stray_gits ($) {
1833 my @gitscmd = qw(find -name .git -prune -print0);
1834 debugcmd "|",@gitscmd;
1835 open GITS, "-|", @gitscmd or confess $!;
1840 print STDERR f_ "%s: warning: removing from %s: %s\n",
1841 $us, $what, (messagequote $_);
1845 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1848 sub mktree_in_ud_from_only_subdir ($;$) {
1849 my ($what,$raw) = @_;
1850 # changes into the subdir
1853 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1854 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1858 remove_stray_gits($what);
1859 mktree_in_ud_here();
1861 my ($format, $fopts) = get_source_format();
1862 if (madformat($format)) {
1867 my $tree=git_add_write_tree();
1868 return ($tree,$dir);
1871 our @files_csum_info_fields =
1872 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1873 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1874 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1876 sub dsc_files_info () {
1877 foreach my $csumi (@files_csum_info_fields) {
1878 my ($fname, $module, $method) = @$csumi;
1879 my $field = $dsc->{$fname};
1880 next unless defined $field;
1881 eval "use $module; 1;" or die $@;
1883 foreach (split /\n/, $field) {
1885 m/^(\w+) (\d+) (\S+)$/ or
1886 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1887 my $digester = eval "$module"."->$method;" or die $@;
1892 Digester => $digester,
1897 fail f_ "missing any supported Checksums-* or Files field in %s",
1898 $dsc->get_option('name');
1902 map { $_->{Filename} } dsc_files_info();
1905 sub files_compare_inputs (@) {
1910 my $showinputs = sub {
1911 return join "; ", map { $_->get_option('name') } @$inputs;
1914 foreach my $in (@$inputs) {
1916 my $in_name = $in->get_option('name');
1918 printdebug "files_compare_inputs $in_name\n";
1920 foreach my $csumi (@files_csum_info_fields) {
1921 my ($fname) = @$csumi;
1922 printdebug "files_compare_inputs $in_name $fname\n";
1924 my $field = $in->{$fname};
1925 next unless defined $field;
1928 foreach (split /\n/, $field) {
1931 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1932 fail "could not parse $in_name $fname line \`$_'";
1934 printdebug "files_compare_inputs $in_name $fname $f\n";
1938 my $re = \ $record{$f}{$fname};
1940 $fchecked{$f}{$in_name} = 1;
1943 "hash or size of %s varies in %s fields (between: %s)",
1944 $f, $fname, $showinputs->();
1949 @files = sort @files;
1950 $expected_files //= \@files;
1951 "@$expected_files" eq "@files" or
1952 fail f_ "file list in %s varies between hash fields!",
1956 fail f_ "%s has no files list field(s)", $in_name;
1958 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1961 grep { keys %$_ == @$inputs-1 } values %fchecked
1962 or fail f_ "no file appears in all file lists (looked in: %s)",
1966 sub is_orig_file_in_dsc ($$) {
1967 my ($f, $dsc_files_info) = @_;
1968 return 0 if @$dsc_files_info <= 1;
1969 # One file means no origs, and the filename doesn't have a "what
1970 # part of dsc" component. (Consider versions ending `.orig'.)
1971 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1975 # This function determines whether a .changes file is source-only from
1976 # the point of view of dak. Thus, it permits *_source.buildinfo
1979 # It does not, however, permit any other buildinfo files. After a
1980 # source-only upload, the buildds will try to upload files like
1981 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1982 # named like this in their (otherwise) source-only upload, the uploads
1983 # of the buildd can be rejected by dak. Fixing the resultant
1984 # situation can require manual intervention. So we block such
1985 # .buildinfo files when the user tells us to perform a source-only
1986 # upload (such as when using the push-source subcommand with the -C
1987 # option, which calls this function).
1989 # Note, though, that when dgit is told to prepare a source-only
1990 # upload, such as when subcommands like build-source and push-source
1991 # without -C are used, dgit has a more restrictive notion of
1992 # source-only .changes than dak: such uploads will never include
1993 # *_source.buildinfo files. This is because there is no use for such
1994 # files when using a tool like dgit to produce the source package, as
1995 # dgit ensures the source is identical to git HEAD.
1996 sub test_source_only_changes ($) {
1998 foreach my $l (split /\n/, getfield $changes, 'Files') {
1999 $l =~ m/\S+$/ or next;
2000 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2001 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
2002 print f_ "purportedly source-only changes polluted by %s\n", $&;
2009 sub changes_update_origs_from_dsc ($$$$) {
2010 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2012 printdebug "checking origs needed ($upstreamvsn)...\n";
2013 $_ = getfield $changes, 'Files';
2014 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2015 fail __ "cannot find section/priority from .changes Files field";
2016 my $placementinfo = $1;
2018 printdebug "checking origs needed placement '$placementinfo'...\n";
2019 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2020 $l =~ m/\S+$/ or next;
2022 printdebug "origs $file | $l\n";
2023 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2024 printdebug "origs $file is_orig\n";
2025 my $have = archive_query('file_in_archive', $file);
2026 if (!defined $have) {
2027 print STDERR __ <<END;
2028 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2034 printdebug "origs $file \$#\$have=$#$have\n";
2035 foreach my $h (@$have) {
2038 foreach my $csumi (@files_csum_info_fields) {
2039 my ($fname, $module, $method, $archivefield) = @$csumi;
2040 next unless defined $h->{$archivefield};
2041 $_ = $dsc->{$fname};
2042 next unless defined;
2043 m/^(\w+) .* \Q$file\E$/m or
2044 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2045 if ($h->{$archivefield} eq $1) {
2049 "%s: %s (archive) != %s (local .dsc)",
2050 $archivefield, $h->{$archivefield}, $1;
2053 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2057 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2060 printdebug "origs $file f.same=$found_same".
2061 " #f._differ=$#found_differ\n";
2062 if (@found_differ && !$found_same) {
2064 (f_ "archive contains %s with different checksum", $file),
2067 # Now we edit the changes file to add or remove it
2068 foreach my $csumi (@files_csum_info_fields) {
2069 my ($fname, $module, $method, $archivefield) = @$csumi;
2070 next unless defined $changes->{$fname};
2072 # in archive, delete from .changes if it's there
2073 $changed{$file} = "removed" if
2074 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2075 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2076 # not in archive, but it's here in the .changes
2078 my $dsc_data = getfield $dsc, $fname;
2079 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2081 $extra =~ s/ \d+ /$&$placementinfo /
2082 or confess "$fname $extra >$dsc_data< ?"
2083 if $fname eq 'Files';
2084 $changes->{$fname} .= "\n". $extra;
2085 $changed{$file} = "added";
2090 foreach my $file (keys %changed) {
2092 "edited .changes for archive .orig contents: %s %s",
2093 $changed{$file}, $file;
2095 my $chtmp = "$changesfile.tmp";
2096 $changes->save($chtmp);
2098 rename $chtmp,$changesfile or die "$changesfile $!";
2100 progress f_ "[new .changes left in %s]", $changesfile;
2103 progress f_ "%s already has appropriate .orig(s) (if any)",
2108 sub make_commit ($) {
2110 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2113 sub clogp_authline ($) {
2115 my $author = getfield $clogp, 'Maintainer';
2116 if ($author =~ m/^[^"\@]+\,/) {
2117 # single entry Maintainer field with unquoted comma
2118 $author = ($& =~ y/,//rd).$'; # strip the comma
2120 # git wants a single author; any remaining commas in $author
2121 # are by now preceded by @ (or "). It seems safer to punt on
2122 # "..." for now rather than attempting to dequote or something.
2123 $author =~ s#,.*##ms unless $author =~ m/"/;
2124 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2125 my $authline = "$author $date";
2126 $authline =~ m/$git_authline_re/o or
2127 fail f_ "unexpected commit author line format \`%s'".
2128 " (was generated from changelog Maintainer field)",
2130 return ($1,$2,$3) if wantarray;
2134 sub vendor_patches_distro ($$) {
2135 my ($checkdistro, $what) = @_;
2136 return unless defined $checkdistro;
2138 my $series = "debian/patches/\L$checkdistro\E.series";
2139 printdebug "checking for vendor-specific $series ($what)\n";
2141 if (!open SERIES, "<", $series) {
2142 confess "$series $!" unless $!==ENOENT;
2149 print STDERR __ <<END;
2151 Unfortunately, this source package uses a feature of dpkg-source where
2152 the same source package unpacks to different source code on different
2153 distros. dgit cannot safely operate on such packages on affected
2154 distros, because the meaning of source packages is not stable.
2156 Please ask the distro/maintainer to remove the distro-specific series
2157 files and use a different technique (if necessary, uploading actually
2158 different packages, if different distros are supposed to have
2162 fail f_ "Found active distro-specific series file for".
2163 " %s (%s): %s, cannot continue",
2164 $checkdistro, $what, $series;
2166 die "$series $!" if SERIES->error;
2170 sub check_for_vendor_patches () {
2171 # This dpkg-source feature doesn't seem to be documented anywhere!
2172 # But it can be found in the changelog (reformatted):
2174 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2175 # Author: Raphael Hertzog <hertzog@debian.org>
2176 # Date: Sun Oct 3 09:36:48 2010 +0200
2178 # dpkg-source: correctly create .pc/.quilt_series with alternate
2181 # If you have debian/patches/ubuntu.series and you were
2182 # unpacking the source package on ubuntu, quilt was still
2183 # directed to debian/patches/series instead of
2184 # debian/patches/ubuntu.series.
2186 # debian/changelog | 3 +++
2187 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2188 # 2 files changed, 6 insertions(+), 1 deletion(-)
2191 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2192 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2193 __ "Dpkg::Vendor \`current vendor'");
2194 vendor_patches_distro(access_basedistro(),
2195 __ "(base) distro being accessed");
2196 vendor_patches_distro(access_nomdistro(),
2197 __ "(nominal) distro being accessed");
2200 sub check_bpd_exists () {
2201 stat $buildproductsdir
2202 or fail f_ "build-products-dir %s is not accessible: %s\n",
2203 $buildproductsdir, $!;
2206 sub generate_commits_from_dsc () {
2207 # See big comment in fetch_from_archive, below.
2208 # See also README.dsc-import.
2210 changedir $playground;
2212 my @dfi = dsc_files_info();
2213 foreach my $fi (@dfi) {
2214 my $f = $fi->{Filename};
2215 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2216 my $upper_f = (bpd_abs()."/$f");
2218 printdebug "considering reusing $f: ";
2220 if (link_ltarget "$upper_f,fetch", $f) {
2221 printdebug "linked (using ...,fetch).\n";
2222 } elsif ((printdebug "($!) "),
2224 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2225 } elsif (link_ltarget $upper_f, $f) {
2226 printdebug "linked.\n";
2227 } elsif ((printdebug "($!) "),
2229 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2231 printdebug "absent.\n";
2235 complete_file_from_dsc('.', $fi, \$refetched)
2238 printdebug "considering saving $f: ";
2240 if (rename_link_xf 1, $f, $upper_f) {
2241 printdebug "linked.\n";
2242 } elsif ((printdebug "($@) "),
2244 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2245 } elsif (!$refetched) {
2246 printdebug "no need.\n";
2247 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2248 printdebug "linked (using ...,fetch).\n";
2249 } elsif ((printdebug "($@) "),
2251 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2253 printdebug "cannot.\n";
2257 # We unpack and record the orig tarballs first, so that we only
2258 # need disk space for one private copy of the unpacked source.
2259 # But we can't make them into commits until we have the metadata
2260 # from the debian/changelog, so we record the tree objects now and
2261 # make them into commits later.
2263 my $upstreamv = upstreamversion $dsc->{version};
2264 my $orig_f_base = srcfn $upstreamv, '';
2266 foreach my $fi (@dfi) {
2267 # We actually import, and record as a commit, every tarball
2268 # (unless there is only one file, in which case there seems
2271 my $f = $fi->{Filename};
2272 printdebug "import considering $f ";
2273 (printdebug "only one dfi\n"), next if @dfi == 1;
2274 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2275 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2279 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2281 printdebug "Y ", (join ' ', map { $_//"(none)" }
2282 $compr_ext, $orig_f_part
2285 my $input = new IO::File $f, '<' or die "$f $!";
2289 if (defined $compr_ext) {
2291 Dpkg::Compression::compression_guess_from_filename $f;
2292 fail "Dpkg::Compression cannot handle file $f in source package"
2293 if defined $compr_ext && !defined $cname;
2295 new Dpkg::Compression::Process compression => $cname;
2296 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2297 my $compr_fh = new IO::Handle;
2298 my $compr_pid = open $compr_fh, "-|" // confess $!;
2300 open STDIN, "<&", $input or confess $!;
2302 die "dgit (child): exec $compr_cmd[0]: $!\n";
2307 rmtree "_unpack-tar";
2308 mkdir "_unpack-tar" or confess $!;
2309 my @tarcmd = qw(tar -x -f -
2310 --no-same-owner --no-same-permissions
2311 --no-acls --no-xattrs --no-selinux);
2312 my $tar_pid = fork // confess $!;
2314 chdir "_unpack-tar" or confess $!;
2315 open STDIN, "<&", $input or confess $!;
2317 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2319 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!;
2320 !$? or failedcmd @tarcmd;
2323 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2325 # finally, we have the results in "tarball", but maybe
2326 # with the wrong permissions
2328 runcmd qw(chmod -R +rwX _unpack-tar);
2329 changedir "_unpack-tar";
2330 remove_stray_gits($f);
2331 mktree_in_ud_here();
2333 my ($tree) = git_add_write_tree();
2334 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2335 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2337 printdebug "one subtree $1\n";
2339 printdebug "multiple subtrees\n";
2342 rmtree "_unpack-tar";
2344 my $ent = [ $f, $tree ];
2346 Orig => !!$orig_f_part,
2347 Sort => (!$orig_f_part ? 2 :
2348 $orig_f_part =~ m/-/g ? 1 :
2356 # put any without "_" first (spec is not clear whether files
2357 # are always in the usual order). Tarballs without "_" are
2358 # the main orig or the debian tarball.
2359 $a->{Sort} <=> $b->{Sort} or
2363 my $any_orig = grep { $_->{Orig} } @tartrees;
2365 my $dscfn = "$package.dsc";
2367 my $treeimporthow = 'package';
2369 open D, ">", $dscfn or die "$dscfn: $!";
2370 print D $dscdata or die "$dscfn: $!";
2371 close D or die "$dscfn: $!";
2372 my @cmd = qw(dpkg-source);
2373 push @cmd, '--no-check' if $dsc_checked;
2374 if (madformat $dsc->{format}) {
2375 push @cmd, '--skip-patches';
2376 $treeimporthow = 'unpatched';
2378 push @cmd, qw(-x --), $dscfn;
2381 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2382 if (madformat $dsc->{format}) {
2383 check_for_vendor_patches();
2387 if (madformat $dsc->{format}) {
2388 my @pcmd = qw(dpkg-source --before-build .);
2389 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2391 $dappliedtree = git_add_write_tree();
2394 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2398 printdebug "import clog search...\n";
2399 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2400 my ($thisstanza, $desc) = @_;
2401 no warnings qw(exiting);
2403 $clogp //= $thisstanza;
2405 printdebug "import clog $thisstanza->{version} $desc...\n";
2407 last if !$any_orig; # we don't need $r1clogp
2409 # We look for the first (most recent) changelog entry whose
2410 # version number is lower than the upstream version of this
2411 # package. Then the last (least recent) previous changelog
2412 # entry is treated as the one which introduced this upstream
2413 # version and used for the synthetic commits for the upstream
2416 # One might think that a more sophisticated algorithm would be
2417 # necessary. But: we do not want to scan the whole changelog
2418 # file. Stopping when we see an earlier version, which
2419 # necessarily then is an earlier upstream version, is the only
2420 # realistic way to do that. Then, either the earliest
2421 # changelog entry we have seen so far is indeed the earliest
2422 # upload of this upstream version; or there are only changelog
2423 # entries relating to later upstream versions (which is not
2424 # possible unless the changelog and .dsc disagree about the
2425 # version). Then it remains to choose between the physically
2426 # last entry in the file, and the one with the lowest version
2427 # number. If these are not the same, we guess that the
2428 # versions were created in a non-monotonic order rather than
2429 # that the changelog entries have been misordered.
2431 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2433 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2434 $r1clogp = $thisstanza;
2436 printdebug "import clog $r1clogp->{version} becomes r1\n";
2439 $clogp or fail __ "package changelog has no entries!";
2441 my $authline = clogp_authline $clogp;
2442 my $changes = getfield $clogp, 'Changes';
2443 $changes =~ s/^\n//; # Changes: \n
2444 my $cversion = getfield $clogp, 'Version';
2447 $r1clogp //= $clogp; # maybe there's only one entry;
2448 my $r1authline = clogp_authline $r1clogp;
2449 # Strictly, r1authline might now be wrong if it's going to be
2450 # unused because !$any_orig. Whatever.
2452 printdebug "import tartrees authline $authline\n";
2453 printdebug "import tartrees r1authline $r1authline\n";
2455 foreach my $tt (@tartrees) {
2456 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2458 my $mbody = f_ "Import %s", $tt->{F};
2459 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2462 committer $r1authline
2466 [dgit import orig $tt->{F}]
2474 [dgit import tarball $package $cversion $tt->{F}]
2479 printdebug "import main commit\n";
2481 open C, ">../commit.tmp" or confess $!;
2482 print C <<END or confess $!;
2485 print C <<END or confess $! foreach @tartrees;
2488 print C <<END or confess $!;
2494 [dgit import $treeimporthow $package $cversion]
2497 close C or confess $!;
2498 my $rawimport_hash = make_commit qw(../commit.tmp);
2500 if (madformat $dsc->{format}) {
2501 printdebug "import apply patches...\n";
2503 # regularise the state of the working tree so that
2504 # the checkout of $rawimport_hash works nicely.
2505 my $dappliedcommit = make_commit_text(<<END);
2512 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2514 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2516 # We need the answers to be reproducible
2517 my @authline = clogp_authline($clogp);
2518 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2519 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2520 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2521 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2522 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2523 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2525 my $path = $ENV{PATH} or die;
2527 # we use ../../gbp-pq-output, which (given that we are in
2528 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2531 foreach my $use_absurd (qw(0 1)) {
2532 runcmd @git, qw(checkout -q unpa);
2533 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2534 local $ENV{PATH} = $path;
2537 progress "warning: $@";
2538 $path = "$absurdity:$path";
2539 progress f_ "%s: trying slow absurd-git-apply...", $us;
2540 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2545 die "forbid absurd git-apply\n" if $use_absurd
2546 && forceing [qw(import-gitapply-no-absurd)];
2547 die "only absurd git-apply!\n" if !$use_absurd
2548 && forceing [qw(import-gitapply-absurd)];
2550 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2551 local $ENV{PATH} = $path if $use_absurd;
2553 my @showcmd = (gbp_pq, qw(import));
2554 my @realcmd = shell_cmd
2555 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2556 debugcmd "+",@realcmd;
2557 if (system @realcmd) {
2558 die f_ "%s failed: %s\n",
2559 +(shellquote @showcmd),
2560 failedcmd_waitstatus();
2563 my $gapplied = git_rev_parse('HEAD');
2564 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2565 $gappliedtree eq $dappliedtree or
2566 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2567 gbp-pq import and dpkg-source disagree!
2568 gbp-pq import gave commit %s
2569 gbp-pq import gave tree %s
2570 dpkg-source --before-build gave tree %s
2572 $rawimport_hash = $gapplied;
2577 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2582 progress f_ "synthesised git commit from .dsc %s", $cversion;
2584 my $rawimport_mergeinput = {
2585 Commit => $rawimport_hash,
2586 Info => __ "Import of source package",
2588 my @output = ($rawimport_mergeinput);
2590 if ($lastpush_mergeinput) {
2591 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2592 my $oversion = getfield $oldclogp, 'Version';
2594 version_compare($oversion, $cversion);
2596 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2597 { ReverseParents => 1,
2598 Message => (f_ <<END, $package, $cversion, $csuite) });
2599 Record %s (%s) in archive suite %s
2601 } elsif ($vcmp > 0) {
2602 print STDERR f_ <<END, $cversion, $oversion,
2604 Version actually in archive: %s (older)
2605 Last version pushed with dgit: %s (newer or same)
2608 __ $later_warning_msg or confess $!;
2609 @output = $lastpush_mergeinput;
2611 # Same version. Use what's in the server git branch,
2612 # discarding our own import. (This could happen if the
2613 # server automatically imports all packages into git.)
2614 @output = $lastpush_mergeinput;
2622 sub complete_file_from_dsc ($$;$) {
2623 our ($dstdir, $fi, $refetched) = @_;
2624 # Ensures that we have, in $dstdir, the file $fi, with the correct
2625 # contents. (Downloading it from alongside $dscurl if necessary.)
2626 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2627 # and will set $$refetched=1 if it did so (or tried to).
2629 my $f = $fi->{Filename};
2630 my $tf = "$dstdir/$f";
2634 my $checkhash = sub {
2635 open F, "<", "$tf" or die "$tf: $!";
2636 $fi->{Digester}->reset();
2637 $fi->{Digester}->addfile(*F);
2638 F->error and confess $!;
2639 $got = $fi->{Digester}->hexdigest();
2640 return $got eq $fi->{Hash};
2643 if (stat_exists $tf) {
2644 if ($checkhash->()) {
2645 progress f_ "using existing %s", $f;
2649 fail f_ "file %s has hash %s but .dsc demands hash %s".
2650 " (perhaps you should delete this file?)",
2651 $f, $got, $fi->{Hash};
2653 progress f_ "need to fetch correct version of %s", $f;
2654 unlink $tf or die "$tf $!";
2657 printdebug "$tf does not exist, need to fetch\n";
2661 $furl =~ s{/[^/]+$}{};
2663 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2664 die "$f ?" if $f =~ m#/#;
2665 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2666 return 0 if !act_local();
2669 fail f_ "file %s has hash %s but .dsc demands hash %s".
2670 " (got wrong file from archive!)",
2671 $f, $got, $fi->{Hash};
2676 sub ensure_we_have_orig () {
2677 my @dfi = dsc_files_info();
2678 foreach my $fi (@dfi) {
2679 my $f = $fi->{Filename};
2680 next unless is_orig_file_in_dsc($f, \@dfi);
2681 complete_file_from_dsc($buildproductsdir, $fi)
2686 #---------- git fetch ----------
2688 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2689 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2691 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2692 # locally fetched refs because they have unhelpful names and clutter
2693 # up gitk etc. So we track whether we have "used up" head ref (ie,
2694 # whether we have made another local ref which refers to this object).
2696 # (If we deleted them unconditionally, then we might end up
2697 # re-fetching the same git objects each time dgit fetch was run.)
2699 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2700 # in git_fetch_us to fetch the refs in question, and possibly a call
2701 # to lrfetchref_used.
2703 our (%lrfetchrefs_f, %lrfetchrefs_d);
2704 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2706 sub lrfetchref_used ($) {
2707 my ($fullrefname) = @_;
2708 my $objid = $lrfetchrefs_f{$fullrefname};
2709 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2712 sub git_lrfetch_sane {
2713 my ($url, $supplementary, @specs) = @_;
2714 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2715 # at least as regards @specs. Also leave the results in
2716 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2717 # able to clean these up.
2719 # With $supplementary==1, @specs must not contain wildcards
2720 # and we add to our previous fetches (non-atomically).
2722 # This is rather miserable:
2723 # When git fetch --prune is passed a fetchspec ending with a *,
2724 # it does a plausible thing. If there is no * then:
2725 # - it matches subpaths too, even if the supplied refspec
2726 # starts refs, and behaves completely madly if the source
2727 # has refs/refs/something. (See, for example, Debian #NNNN.)
2728 # - if there is no matching remote ref, it bombs out the whole
2730 # We want to fetch a fixed ref, and we don't know in advance
2731 # if it exists, so this is not suitable.
2733 # Our workaround is to use git ls-remote. git ls-remote has its
2734 # own qairks. Notably, it has the absurd multi-tail-matching
2735 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2736 # refs/refs/foo etc.
2738 # Also, we want an idempotent snapshot, but we have to make two
2739 # calls to the remote: one to git ls-remote and to git fetch. The
2740 # solution is use git ls-remote to obtain a target state, and
2741 # git fetch to try to generate it. If we don't manage to generate
2742 # the target state, we try again.
2744 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2746 my $specre = join '|', map {
2749 my $wildcard = $x =~ s/\\\*$/.*/;
2750 die if $wildcard && $supplementary;
2753 printdebug "git_lrfetch_sane specre=$specre\n";
2754 my $wanted_rref = sub {
2756 return m/^(?:$specre)$/;
2759 my $fetch_iteration = 0;
2762 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2763 if (++$fetch_iteration > 10) {
2764 fail __ "too many iterations trying to get sane fetch!";
2767 my @look = map { "refs/$_" } @specs;
2768 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2772 open GITLS, "-|", @lcmd or confess $!;
2774 printdebug "=> ", $_;
2775 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2776 my ($objid,$rrefname) = ($1,$2);
2777 if (!$wanted_rref->($rrefname)) {
2778 print STDERR f_ <<END, "@look", $rrefname;
2779 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2783 $wantr{$rrefname} = $objid;
2786 close GITLS or failedcmd @lcmd;
2788 # OK, now %want is exactly what we want for refs in @specs
2790 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2791 "+refs/$_:".lrfetchrefs."/$_";
2794 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2796 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2797 runcmd_ordryrun_local @fcmd if @fspecs;
2799 if (!$supplementary) {
2800 %lrfetchrefs_f = ();
2804 git_for_each_ref(lrfetchrefs, sub {
2805 my ($objid,$objtype,$lrefname,$reftail) = @_;
2806 $lrfetchrefs_f{$lrefname} = $objid;
2807 $objgot{$objid} = 1;
2810 if ($supplementary) {
2814 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2815 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2816 if (!exists $wantr{$rrefname}) {
2817 if ($wanted_rref->($rrefname)) {
2819 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2822 print STDERR f_ <<END, "@fspecs", $lrefname
2823 warning: git fetch %s created %s; this is silly, deleting it.
2826 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2827 delete $lrfetchrefs_f{$lrefname};
2831 foreach my $rrefname (sort keys %wantr) {
2832 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2833 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2834 my $want = $wantr{$rrefname};
2835 next if $got eq $want;
2836 if (!defined $objgot{$want}) {
2837 fail __ <<END unless act_local();
2838 --dry-run specified but we actually wanted the results of git fetch,
2839 so this is not going to work. Try running dgit fetch first,
2840 or using --damp-run instead of --dry-run.
2842 print STDERR f_ <<END, $lrefname, $want;
2843 warning: git ls-remote suggests we want %s
2844 warning: and it should refer to %s
2845 warning: but git fetch didn't fetch that object to any relevant ref.
2846 warning: This may be due to a race with someone updating the server.
2847 warning: Will try again...
2849 next FETCH_ITERATION;
2852 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2854 runcmd_ordryrun_local @git, qw(update-ref -m),
2855 "dgit fetch git fetch fixup", $lrefname, $want;
2856 $lrfetchrefs_f{$lrefname} = $want;
2861 if (defined $csuite) {
2862 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2863 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2864 my ($objid,$objtype,$lrefname,$reftail) = @_;
2865 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2866 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2870 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2871 Dumper(\%lrfetchrefs_f);
2874 sub git_fetch_us () {
2875 # Want to fetch only what we are going to use, unless
2876 # deliberately-not-ff, in which case we must fetch everything.
2878 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2880 (quiltmode_splitbrain
2881 ? (map { $_->('*',access_nomdistro) }
2882 \&debiantag_new, \&debiantag_maintview)
2883 : debiantags('*',access_nomdistro));
2884 push @specs, server_branch($csuite);
2885 push @specs, $rewritemap;
2886 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2888 my $url = access_giturl();
2889 git_lrfetch_sane $url, 0, @specs;
2892 my @tagpats = debiantags('*',access_nomdistro);
2894 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2895 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2896 printdebug "currently $fullrefname=$objid\n";
2897 $here{$fullrefname} = $objid;
2899 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2900 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2901 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2902 printdebug "offered $lref=$objid\n";
2903 if (!defined $here{$lref}) {
2904 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2905 runcmd_ordryrun_local @upd;
2906 lrfetchref_used $fullrefname;
2907 } elsif ($here{$lref} eq $objid) {
2908 lrfetchref_used $fullrefname;
2910 print STDERR f_ "Not updating %s from %s to %s.\n",
2911 $lref, $here{$lref}, $objid;
2916 #---------- dsc and archive handling ----------
2918 sub mergeinfo_getclogp ($) {
2919 # Ensures thit $mi->{Clogp} exists and returns it
2921 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2924 sub mergeinfo_version ($) {
2925 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2928 sub fetch_from_archive_record_1 ($) {
2930 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2931 cmdoutput @git, qw(log -n2), $hash;
2932 # ... gives git a chance to complain if our commit is malformed
2935 sub fetch_from_archive_record_2 ($) {
2937 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2941 dryrun_report @upd_cmd;
2945 sub parse_dsc_field_def_dsc_distro () {
2946 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2947 dgit.default.distro);
2950 sub parse_dsc_field ($$) {
2951 my ($dsc, $what) = @_;
2953 foreach my $field (@ourdscfield) {
2954 $f = $dsc->{$field};
2959 progress f_ "%s: NO git hash", $what;
2960 parse_dsc_field_def_dsc_distro();
2961 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2962 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2963 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
2964 $dsc_hint_tag = [ $dsc_hint_tag ];
2965 } elsif ($f =~ m/^\w+\s*$/) {
2967 parse_dsc_field_def_dsc_distro();
2968 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2970 progress f_ "%s: specified git hash", $what;
2972 fail f_ "%s: invalid Dgit info", $what;
2976 sub resolve_dsc_field_commit ($$) {
2977 my ($already_distro, $already_mapref) = @_;
2979 return unless defined $dsc_hash;
2982 defined $already_mapref &&
2983 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2984 ? $already_mapref : undef;
2988 my ($what, @fetch) = @_;
2990 local $idistro = $dsc_distro;
2991 my $lrf = lrfetchrefs;
2993 if (!$chase_dsc_distro) {
2994 progress f_ "not chasing .dsc distro %s: not fetching %s",
2999 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3001 my $url = access_giturl();
3002 if (!defined $url) {
3003 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3004 .dsc Dgit metadata is in context of distro %s
3005 for which we have no configured url and .dsc provides no hint
3008 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3009 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3010 parse_cfg_bool "dsc-url-proto-ok", 'false',
3011 cfg("dgit.dsc-url-proto-ok.$proto",
3012 "dgit.default.dsc-url-proto-ok")
3013 or fail f_ <<END, $dsc_distro, $proto;
3014 .dsc Dgit metadata is in context of distro %s
3015 for which we have no configured url;
3016 .dsc provides hinted url with protocol %s which is unsafe.
3017 (can be overridden by config - consult documentation)
3019 $url = $dsc_hint_url;
3022 git_lrfetch_sane $url, 1, @fetch;
3027 my $rewrite_enable = do {
3028 local $idistro = $dsc_distro;
3029 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3032 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3033 if (!defined $mapref) {
3034 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3035 $mapref = $lrf.'/'.$rewritemap;
3037 my $rewritemapdata = git_cat_file $mapref.':map';
3038 if (defined $rewritemapdata
3039 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3041 "server's git history rewrite map contains a relevant entry!";
3044 if (defined $dsc_hash) {
3045 progress __ "using rewritten git hash in place of .dsc value";
3047 progress __ "server data says .dsc hash is to be disregarded";
3052 if (!defined git_cat_file $dsc_hash) {
3053 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3054 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3055 defined git_cat_file $dsc_hash
3056 or fail f_ <<END, $dsc_hash;
3057 .dsc Dgit metadata requires commit %s
3058 but we could not obtain that object anywhere.
3060 foreach my $t (@tags) {
3061 my $fullrefname = $lrf.'/'.$t;
3062 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3063 next unless $lrfetchrefs_f{$fullrefname};
3064 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3065 lrfetchref_used $fullrefname;
3070 sub fetch_from_archive () {
3072 ensure_setup_existing_tree();
3074 # Ensures that lrref() is what is actually in the archive, one way
3075 # or another, according to us - ie this client's
3076 # appropritaely-updated archive view. Also returns the commit id.
3077 # If there is nothing in the archive, leaves lrref alone and
3078 # returns undef. git_fetch_us must have already been called.
3082 parse_dsc_field($dsc, __ 'last upload to archive');
3083 resolve_dsc_field_commit access_basedistro,
3084 lrfetchrefs."/".$rewritemap
3086 progress __ "no version available from the archive";
3089 # If the archive's .dsc has a Dgit field, there are three
3090 # relevant git commitids we need to choose between and/or merge
3092 # 1. $dsc_hash: the Dgit field from the archive
3093 # 2. $lastpush_hash: the suite branch on the dgit git server
3094 # 3. $lastfetch_hash: our local tracking brach for the suite
3096 # These may all be distinct and need not be in any fast forward
3099 # If the dsc was pushed to this suite, then the server suite
3100 # branch will have been updated; but it might have been pushed to
3101 # a different suite and copied by the archive. Conversely a more
3102 # recent version may have been pushed with dgit but not appeared
3103 # in the archive (yet).
3105 # $lastfetch_hash may be awkward because archive imports
3106 # (particularly, imports of Dgit-less .dscs) are performed only as
3107 # needed on individual clients, so different clients may perform a
3108 # different subset of them - and these imports are only made
3109 # public during push. So $lastfetch_hash may represent a set of
3110 # imports different to a subsequent upload by a different dgit
3113 # Our approach is as follows:
3115 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3116 # descendant of $dsc_hash, then it was pushed by a dgit user who
3117 # had based their work on $dsc_hash, so we should prefer it.
3118 # Otherwise, $dsc_hash was installed into this suite in the
3119 # archive other than by a dgit push, and (necessarily) after the
3120 # last dgit push into that suite (since a dgit push would have
3121 # been descended from the dgit server git branch); thus, in that
3122 # case, we prefer the archive's version (and produce a
3123 # pseudo-merge to overwrite the dgit server git branch).
3125 # (If there is no Dgit field in the archive's .dsc then
3126 # generate_commit_from_dsc uses the version numbers to decide
3127 # whether the suite branch or the archive is newer. If the suite
3128 # branch is newer it ignores the archive's .dsc; otherwise it
3129 # generates an import of the .dsc, and produces a pseudo-merge to
3130 # overwrite the suite branch with the archive contents.)
3132 # The outcome of that part of the algorithm is the `public view',
3133 # and is same for all dgit clients: it does not depend on any
3134 # unpublished history in the local tracking branch.
3136 # As between the public view and the local tracking branch: The
3137 # local tracking branch is only updated by dgit fetch, and
3138 # whenever dgit fetch runs it includes the public view in the
3139 # local tracking branch. Therefore if the public view is not
3140 # descended from the local tracking branch, the local tracking
3141 # branch must contain history which was imported from the archive
3142 # but never pushed; and, its tip is now out of date. So, we make
3143 # a pseudo-merge to overwrite the old imports and stitch the old
3146 # Finally: we do not necessarily reify the public view (as
3147 # described above). This is so that we do not end up stacking two
3148 # pseudo-merges. So what we actually do is figure out the inputs
3149 # to any public view pseudo-merge and put them in @mergeinputs.
3152 # $mergeinputs[]{Commit}
3153 # $mergeinputs[]{Info}
3154 # $mergeinputs[0] is the one whose tree we use
3155 # @mergeinputs is in the order we use in the actual commit)
3158 # $mergeinputs[]{Message} is a commit message to use
3159 # $mergeinputs[]{ReverseParents} if def specifies that parent
3160 # list should be in opposite order
3161 # Such an entry has no Commit or Info. It applies only when found
3162 # in the last entry. (This ugliness is to support making
3163 # identical imports to previous dgit versions.)
3165 my $lastpush_hash = git_get_ref(lrfetchref());
3166 printdebug "previous reference hash=$lastpush_hash\n";
3167 $lastpush_mergeinput = $lastpush_hash && {
3168 Commit => $lastpush_hash,
3169 Info => (__ "dgit suite branch on dgit git server"),
3172 my $lastfetch_hash = git_get_ref(lrref());
3173 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3174 my $lastfetch_mergeinput = $lastfetch_hash && {
3175 Commit => $lastfetch_hash,
3176 Info => (__ "dgit client's archive history view"),
3179 my $dsc_mergeinput = $dsc_hash && {
3180 Commit => $dsc_hash,
3181 Info => (__ "Dgit field in .dsc from archive"),
3185 my $del_lrfetchrefs = sub {
3188 printdebug "del_lrfetchrefs...\n";
3189 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3190 my $objid = $lrfetchrefs_d{$fullrefname};
3191 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3193 $gur ||= new IO::Handle;
3194 open $gur, "|-", qw(git update-ref --stdin) or confess $!;
3196 printf $gur "delete %s %s\n", $fullrefname, $objid;
3199 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3203 if (defined $dsc_hash) {
3204 ensure_we_have_orig();
3205 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3206 @mergeinputs = $dsc_mergeinput
3207 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3208 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3210 Git commit in archive is behind the last version allegedly pushed/uploaded.
3211 Commit referred to by archive: %s
3212 Last version pushed with dgit: %s
3215 __ $later_warning_msg or confess $!;
3216 @mergeinputs = ($lastpush_mergeinput);
3218 # Archive has .dsc which is not a descendant of the last dgit
3219 # push. This can happen if the archive moves .dscs about.
3220 # Just follow its lead.
3221 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3222 progress __ "archive .dsc names newer git commit";
3223 @mergeinputs = ($dsc_mergeinput);
3225 progress __ "archive .dsc names other git commit, fixing up";
3226 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3230 @mergeinputs = generate_commits_from_dsc();
3231 # We have just done an import. Now, our import algorithm might
3232 # have been improved. But even so we do not want to generate
3233 # a new different import of the same package. So if the
3234 # version numbers are the same, just use our existing version.
3235 # If the version numbers are different, the archive has changed
3236 # (perhaps, rewound).
3237 if ($lastfetch_mergeinput &&
3238 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3239 (mergeinfo_version $mergeinputs[0]) )) {
3240 @mergeinputs = ($lastfetch_mergeinput);
3242 } elsif ($lastpush_hash) {
3243 # only in git, not in the archive yet
3244 @mergeinputs = ($lastpush_mergeinput);
3245 print STDERR f_ <<END,
3247 Package not found in the archive, but has allegedly been pushed using dgit.
3250 __ $later_warning_msg or confess $!;
3252 printdebug "nothing found!\n";
3253 if (defined $skew_warning_vsn) {
3254 print STDERR f_ <<END, $skew_warning_vsn or confess $!;
3256 Warning: relevant archive skew detected.
3257 Archive allegedly contains %s
3258 But we were not able to obtain any version from the archive or git.
3262 unshift @end, $del_lrfetchrefs;
3266 if ($lastfetch_hash &&
3268 my $h = $_->{Commit};
3269 $h and is_fast_fwd($lastfetch_hash, $h);
3270 # If true, one of the existing parents of this commit
3271 # is a descendant of the $lastfetch_hash, so we'll
3272 # be ff from that automatically.
3276 push @mergeinputs, $lastfetch_mergeinput;
3279 printdebug "fetch mergeinfos:\n";
3280 foreach my $mi (@mergeinputs) {
3282 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3284 printdebug sprintf " ReverseParents=%d Message=%s",
3285 $mi->{ReverseParents}, $mi->{Message};
3289 my $compat_info= pop @mergeinputs
3290 if $mergeinputs[$#mergeinputs]{Message};
3292 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3295 if (@mergeinputs > 1) {
3297 my $tree_commit = $mergeinputs[0]{Commit};
3299 my $tree = get_tree_of_commit $tree_commit;;
3301 # We use the changelog author of the package in question the
3302 # author of this pseudo-merge. This is (roughly) correct if
3303 # this commit is simply representing aa non-dgit upload.
3304 # (Roughly because it does not record sponsorship - but we
3305 # don't have sponsorship info because that's in the .changes,
3306 # which isn't in the archivw.)
3308 # But, it might be that we are representing archive history
3309 # updates (including in-archive copies). These are not really
3310 # the responsibility of the person who created the .dsc, but
3311 # there is no-one whose name we should better use. (The
3312 # author of the .dsc-named commit is clearly worse.)
3314 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3315 my $author = clogp_authline $useclogp;
3316 my $cversion = getfield $useclogp, 'Version';
3318 my $mcf = dgit_privdir()."/mergecommit";
3319 open MC, ">", $mcf or die "$mcf $!";
3320 print MC <<END or confess $!;
3324 my @parents = grep { $_->{Commit} } @mergeinputs;
3325 @parents = reverse @parents if $compat_info->{ReverseParents};
3326 print MC <<END or confess $! foreach @parents;
3330 print MC <<END or confess $!;
3336 if (defined $compat_info->{Message}) {
3337 print MC $compat_info->{Message} or confess $!;
3339 print MC f_ <<END, $package, $cversion, $csuite or confess $!;
3340 Record %s (%s) in archive suite %s
3344 my $message_add_info = sub {
3346 my $mversion = mergeinfo_version $mi;
3347 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3351 $message_add_info->($mergeinputs[0]);
3352 print MC __ <<END or confess $!;
3353 should be treated as descended from
3355 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3358 close MC or confess $!;
3359 $hash = make_commit $mcf;
3361 $hash = $mergeinputs[0]{Commit};
3363 printdebug "fetch hash=$hash\n";
3366 my ($lasth, $what) = @_;
3367 return unless $lasth;
3368 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3371 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3373 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3375 fetch_from_archive_record_1($hash);
3377 if (defined $skew_warning_vsn) {
3378 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3379 my $gotclogp = commit_getclogp($hash);
3380 my $got_vsn = getfield $gotclogp, 'Version';
3381 printdebug "SKEW CHECK GOT $got_vsn\n";
3382 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3383 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess $!;
3385 Warning: archive skew detected. Using the available version:
3386 Archive allegedly contains %s
3387 We were able to obtain only %s
3393 if ($lastfetch_hash ne $hash) {
3394 fetch_from_archive_record_2($hash);
3397 lrfetchref_used lrfetchref();
3399 check_gitattrs($hash, __ "fetched source tree");
3401 unshift @end, $del_lrfetchrefs;
3405 sub set_local_git_config ($$) {
3407 runcmd @git, qw(config), $k, $v;
3410 sub setup_mergechangelogs (;$) {
3412 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3414 my $driver = 'dpkg-mergechangelogs';
3415 my $cb = "merge.$driver";
3416 confess unless defined $maindir;
3417 my $attrs = "$maindir_gitcommon/info/attributes";
3418 ensuredir "$maindir_gitcommon/info";
3420 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3421 if (!open ATTRS, "<", $attrs) {
3422 $!==ENOENT or die "$attrs: $!";
3426 next if m{^debian/changelog\s};
3427 print NATTRS $_, "\n" or confess $!;
3429 ATTRS->error and confess $!;
3432 print NATTRS "debian/changelog merge=$driver\n" or confess $!;
3435 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3436 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3438 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3441 sub setup_useremail (;$) {
3443 return unless $always || access_cfg_bool(1, 'setup-useremail');
3446 my ($k, $envvar) = @_;
3447 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3448 return unless defined $v;
3449 set_local_git_config "user.$k", $v;
3452 $setup->('email', 'DEBEMAIL');
3453 $setup->('name', 'DEBFULLNAME');
3456 sub ensure_setup_existing_tree () {
3457 my $k = "remote.$remotename.skipdefaultupdate";
3458 my $c = git_get_config $k;
3459 return if defined $c;
3460 set_local_git_config $k, 'true';
3463 sub open_main_gitattrs () {
3464 confess 'internal error no maindir' unless defined $maindir;
3465 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3467 or die "open $maindir_gitcommon/info/attributes: $!";
3471 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3473 sub is_gitattrs_setup () {
3476 # 1: gitattributes set up and should be left alone
3478 # 0: there is a dgit-defuse-attrs but it needs fixing
3479 # undef: there is none
3480 my $gai = open_main_gitattrs();
3481 return 0 unless $gai;
3483 next unless m{$gitattrs_ourmacro_re};
3484 return 1 if m{\s-working-tree-encoding\s};
3485 printdebug "is_gitattrs_setup: found old macro\n";
3488 $gai->error and confess $!;
3489 printdebug "is_gitattrs_setup: found nothing\n";
3493 sub setup_gitattrs (;$) {
3495 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3497 my $already = is_gitattrs_setup();
3500 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3501 not doing further gitattributes setup
3505 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3506 my $af = "$maindir_gitcommon/info/attributes";
3507 ensuredir "$maindir_gitcommon/info";
3509 open GAO, "> $af.new" or confess $!;
3510 print GAO <<END, __ <<ENDT or confess $! unless defined $already;
3514 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3516 my $gai = open_main_gitattrs();
3519 if (m{$gitattrs_ourmacro_re}) {
3520 die unless defined $already;
3524 print GAO $_, "\n" or confess $!;
3526 $gai->error and confess $!;
3528 close GAO or confess $!;
3529 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3532 sub setup_new_tree () {
3533 setup_mergechangelogs();
3538 sub check_gitattrs ($$) {
3539 my ($treeish, $what) = @_;
3541 return if is_gitattrs_setup;
3544 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3546 my $gafl = new IO::File;
3547 open $gafl, "-|", @cmd or confess $!;
3550 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3552 next unless m{(?:^|/)\.gitattributes$};
3554 # oh dear, found one
3555 print STDERR f_ <<END, $what;
3556 dgit: warning: %s contains .gitattributes
3557 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3562 # tree contains no .gitattributes files
3563 $?=0; $!=0; close $gafl or failedcmd @cmd;
3567 sub multisuite_suite_child ($$$) {
3568 my ($tsuite, $mergeinputs, $fn) = @_;
3569 # in child, sets things up, calls $fn->(), and returns undef
3570 # in parent, returns canonical suite name for $tsuite
3571 my $canonsuitefh = IO::File::new_tmpfile;
3572 my $pid = fork // confess $!;
3576 $us .= " [$isuite]";
3577 $debugprefix .= " ";
3578 progress f_ "fetching %s...", $tsuite;
3579 canonicalise_suite();
3580 print $canonsuitefh $csuite, "\n" or confess $!;
3581 close $canonsuitefh or confess $!;
3585 waitpid $pid,0 == $pid or confess $!;
3586 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3588 seek $canonsuitefh,0,0 or confess $!;
3589 local $csuite = <$canonsuitefh>;
3590 confess $! unless defined $csuite && chomp $csuite;
3592 printdebug "multisuite $tsuite missing\n";
3595 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3596 push @$mergeinputs, {
3603 sub fork_for_multisuite ($) {
3604 my ($before_fetch_merge) = @_;
3605 # if nothing unusual, just returns ''
3608 # returns 0 to caller in child, to do first of the specified suites
3609 # in child, $csuite is not yet set
3611 # returns 1 to caller in parent, to finish up anything needed after
3612 # in parent, $csuite is set to canonicalised portmanteau
3614 my $org_isuite = $isuite;
3615 my @suites = split /\,/, $isuite;
3616 return '' unless @suites > 1;
3617 printdebug "fork_for_multisuite: @suites\n";
3621 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3623 return 0 unless defined $cbasesuite;
3625 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3626 unless @mergeinputs;
3628 my @csuites = ($cbasesuite);
3630 $before_fetch_merge->();
3632 foreach my $tsuite (@suites[1..$#suites]) {
3633 $tsuite =~ s/^-/$cbasesuite-/;
3634 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3641 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3642 push @csuites, $csubsuite;
3645 foreach my $mi (@mergeinputs) {
3646 my $ref = git_get_ref $mi->{Ref};
3647 die "$mi->{Ref} ?" unless length $ref;
3648 $mi->{Commit} = $ref;
3651 $csuite = join ",", @csuites;
3653 my $previous = git_get_ref lrref;
3655 unshift @mergeinputs, {
3656 Commit => $previous,
3657 Info => (__ "local combined tracking branch"),
3659 "archive seems to have rewound: local tracking branch is ahead!"),
3663 foreach my $ix (0..$#mergeinputs) {
3664 $mergeinputs[$ix]{Index} = $ix;
3667 @mergeinputs = sort {
3668 -version_compare(mergeinfo_version $a,
3669 mergeinfo_version $b) # highest version first
3671 $a->{Index} <=> $b->{Index}; # earliest in spec first
3677 foreach my $mi (@mergeinputs) {
3678 printdebug "multisuite merge check $mi->{Info}\n";
3679 foreach my $previous (@needed) {
3680 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3681 printdebug "multisuite merge un-needed $previous->{Info}\n";
3685 printdebug "multisuite merge this-needed\n";
3686 $mi->{Character} = '+';
3689 $needed[0]{Character} = '*';
3691 my $output = $needed[0]{Commit};
3694 printdebug "multisuite merge nontrivial\n";
3695 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3697 my $commit = "tree $tree\n";
3698 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3699 "Input branches:\n",
3702 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3703 printdebug "multisuite merge include $mi->{Info}\n";
3704 $mi->{Character} //= ' ';
3705 $commit .= "parent $mi->{Commit}\n";
3706 $msg .= sprintf " %s %-25s %s\n",
3708 (mergeinfo_version $mi),
3711 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3712 $msg .= __ "\nKey\n".
3713 " * marks the highest version branch, which choose to use\n".
3714 " + marks each branch which was not already an ancestor\n\n";
3716 "[dgit multi-suite $csuite]\n";
3718 "author $authline\n".
3719 "committer $authline\n\n";
3720 $output = make_commit_text $commit.$msg;
3721 printdebug "multisuite merge generated $output\n";
3724 fetch_from_archive_record_1($output);
3725 fetch_from_archive_record_2($output);
3727 progress f_ "calculated combined tracking suite %s", $csuite;
3732 sub clone_set_head () {
3733 open H, "> .git/HEAD" or confess $!;
3734 print H "ref: ".lref()."\n" or confess $!;
3735 close H or confess $!;
3737 sub clone_finish ($) {
3739 runcmd @git, qw(reset --hard), lrref();
3740 runcmd qw(bash -ec), <<'END';
3742 git ls-tree -r --name-only -z HEAD | \
3743 xargs -0r touch -h -r . --
3745 printdone f_ "ready for work in %s", $dstdir;
3749 # in multisuite, returns twice!
3750 # once in parent after first suite fetched,
3751 # and then again in child after everything is finished
3753 badusage __ "dry run makes no sense with clone" unless act_local();
3755 my $multi_fetched = fork_for_multisuite(sub {
3756 printdebug "multi clone before fetch merge\n";
3760 if ($multi_fetched) {
3761 printdebug "multi clone after fetch merge\n";
3763 clone_finish($dstdir);
3766 printdebug "clone main body\n";
3768 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3772 canonicalise_suite();
3773 my $hasgit = check_for_git();
3775 runcmd @git, qw(init -q);
3779 my $giturl = access_giturl(1);
3780 if (defined $giturl) {
3781 runcmd @git, qw(remote add), 'origin', $giturl;
3784 progress __ "fetching existing git history";
3786 runcmd_ordryrun_local @git, qw(fetch origin);
3788 progress __ "starting new git history";
3790 fetch_from_archive() or no_such_package;
3791 my $vcsgiturl = $dsc->{'Vcs-Git'};
3792 if (length $vcsgiturl) {
3793 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3794 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3796 clone_finish($dstdir);
3800 canonicalise_suite();
3801 if (check_for_git()) {
3804 fetch_from_archive() or no_such_package();
3806 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3807 if (length $vcsgiturl and
3808 (grep { $csuite eq $_ }
3810 cfg 'dgit.vcs-git.suites')) {
3811 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3812 if (defined $current && $current ne $vcsgiturl) {
3813 print STDERR f_ <<END, $csuite;
3814 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3815 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3819 printdone f_ "fetched into %s", lrref();
3823 my $multi_fetched = fork_for_multisuite(sub { });
3824 fetch_one() unless $multi_fetched; # parent
3825 finish 0 if $multi_fetched eq '0'; # child
3830 runcmd_ordryrun_local @git, qw(merge -m),
3831 (f_ "Merge from %s [dgit]", $csuite),
3833 printdone f_ "fetched to %s and merged into HEAD", lrref();
3836 sub check_not_dirty () {
3837 my @forbid = qw(local-options local-patch-header);
3838 @forbid = map { "debian/source/$_" } @forbid;
3839 foreach my $f (@forbid) {
3840 if (stat_exists $f) {
3841 fail f_ "git tree contains %s", $f;
3845 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3846 push @cmd, qw(debian/source/format debian/source/options);
3849 my $bad = cmdoutput @cmd;
3852 "you have uncommitted changes to critical files, cannot continue:\n").
3856 return if $includedirty;
3858 git_check_unmodified();
3861 sub commit_admin ($) {
3864 runcmd_ordryrun_local @git, qw(commit -m), $m;
3867 sub quiltify_nofix_bail ($$) {
3868 my ($headinfo, $xinfo) = @_;
3869 if ($quilt_mode eq 'nofix') {
3871 "quilt fixup required but quilt mode is \`nofix'\n".
3872 "HEAD commit%s differs from tree implied by debian/patches%s",
3877 sub commit_quilty_patch () {
3878 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3880 foreach my $l (split /\n/, $output) {
3881 next unless $l =~ m/\S/;
3882 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3886 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3888 progress __ "nothing quilty to commit, ok.";
3891 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3892 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3893 runcmd_ordryrun_local @git, qw(add -f), @adds;
3894 commit_admin +(__ <<ENDT).<<END
3895 Commit Debian 3.0 (quilt) metadata
3898 [dgit ($our_version) quilt-fixup]
3902 sub get_source_format () {
3904 if (open F, "debian/source/options") {
3908 s/\s+$//; # ignore missing final newline
3910 my ($k, $v) = ($`, $'); #');
3911 $v =~ s/^"(.*)"$/$1/;
3917 F->error and confess $!;
3920 confess $! unless $!==&ENOENT;
3923 if (!open F, "debian/source/format") {
3924 confess $! unless $!==&ENOENT;
3928 F->error and confess $!;
3930 return ($_, \%options);
3933 sub madformat_wantfixup ($) {
3935 return 0 unless $format eq '3.0 (quilt)';
3936 our $quilt_mode_warned;
3937 if ($quilt_mode eq 'nocheck') {
3938 progress f_ "Not doing any fixup of \`%s'".
3939 " due to ----no-quilt-fixup or --quilt=nocheck", $format
3940 unless $quilt_mode_warned++;
3943 progress f_ "Format \`%s', need to check/update patch stack", $format
3944 unless $quilt_mode_warned++;
3948 sub maybe_split_brain_save ($$$) {
3949 my ($headref, $dgitview, $msg) = @_;
3950 # => message fragment "$saved" describing disposition of $dgitview
3951 # (used inside parens, in the English texts)
3952 my $save = $internal_object_save{'dgit-view'};
3953 return f_ "commit id %s", $dgitview unless defined $save;
3954 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3956 "dgit --dgit-view-save $msg HEAD=$headref",
3959 return f_ "and left in %s", $save;
3962 # An "infopair" is a tuple [ $thing, $what ]
3963 # (often $thing is a commit hash; $what is a description)
3965 sub infopair_cond_equal ($$) {
3967 $x->[0] eq $y->[0] or fail <<END;
3968 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3972 sub infopair_lrf_tag_lookup ($$) {
3973 my ($tagnames, $what) = @_;
3974 # $tagname may be an array ref
3975 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3976 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3977 foreach my $tagname (@tagnames) {
3978 my $lrefname = lrfetchrefs."/tags/$tagname";
3979 my $tagobj = $lrfetchrefs_f{$lrefname};
3980 next unless defined $tagobj;
3981 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3982 return [ git_rev_parse($tagobj), $what ];
3984 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
3985 Wanted tag %s (%s) on dgit server, but not found
3987 : (f_ <<END, $what, "@tagnames");
3988 Wanted tag %s (one of: %s) on dgit server, but not found
3992 sub infopair_cond_ff ($$) {
3993 my ($anc,$desc) = @_;
3994 is_fast_fwd($anc->[0], $desc->[0]) or
3995 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
3996 %s (%s) .. %s (%s) is not fast forward
4000 sub pseudomerge_version_check ($$) {
4001 my ($clogp, $archive_hash) = @_;
4003 my $arch_clogp = commit_getclogp $archive_hash;
4004 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4005 __ 'version currently in archive' ];
4006 if (defined $overwrite_version) {
4007 if (length $overwrite_version) {
4008 infopair_cond_equal([ $overwrite_version,
4009 '--overwrite= version' ],
4012 my $v = $i_arch_v->[0];
4014 "Checking package changelog for archive version %s ...", $v;
4017 my @xa = ("-f$v", "-t$v");
4018 my $vclogp = parsechangelog @xa;
4021 [ (getfield $vclogp, $fn),
4022 (f_ "%s field from dpkg-parsechangelog %s",
4025 my $cv = $gf->('Version');
4026 infopair_cond_equal($i_arch_v, $cv);
4027 $cd = $gf->('Distribution');
4030 $@ =~ s/^dgit: //gm;
4032 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4034 fail f_ <<END, $cd->[1], $cd->[0], $v
4036 Your tree seems to based on earlier (not uploaded) %s.
4038 if $cd->[0] =~ m/UNRELEASED/;
4042 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4046 sub pseudomerge_make_commit ($$$$ $$) {
4047 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4048 $msg_cmd, $msg_msg) = @_;
4049 progress f_ "Declaring that HEAD includes all changes in %s...",
4052 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4053 my $authline = clogp_authline $clogp;
4057 !defined $overwrite_version ? ""
4058 : !length $overwrite_version ? " --overwrite"
4059 : " --overwrite=".$overwrite_version;
4061 # Contributing parent is the first parent - that makes
4062 # git rev-list --first-parent DTRT.
4063 my $pmf = dgit_privdir()."/pseudomerge";
4064 open MC, ">", $pmf or die "$pmf $!";
4065 print MC <<END or confess $!;
4068 parent $archive_hash
4076 close MC or confess $!;
4078 return make_commit($pmf);
4081 sub splitbrain_pseudomerge ($$$$) {
4082 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4083 # => $merged_dgitview
4084 printdebug "splitbrain_pseudomerge...\n";
4086 # We: debian/PREVIOUS HEAD($maintview)
4087 # expect: o ----------------- o
4090 # a/d/PREVIOUS $dgitview
4093 # we do: `------------------ o
4097 return $dgitview unless defined $archive_hash;
4098 return $dgitview if deliberately_not_fast_forward();
4100 printdebug "splitbrain_pseudomerge...\n";
4102 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4104 if (!defined $overwrite_version) {
4105 progress __ "Checking that HEAD includes all changes in archive...";
4108 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4110 if (defined $overwrite_version) {
4112 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4113 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4114 __ "maintainer view tag");
4115 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4116 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4117 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4119 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4121 infopair_cond_equal($i_dgit, $i_archive);
4122 infopair_cond_ff($i_dep14, $i_dgit);
4123 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4126 $@ =~ s/^\n//; chomp $@;
4127 print STDERR <<END.(__ <<ENDT);
4130 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4135 my $arch_v = $i_arch_v->[0];
4136 my $r = pseudomerge_make_commit
4137 $clogp, $dgitview, $archive_hash, $i_arch_v,
4138 "dgit --quilt=$quilt_mode",
4139 (defined $overwrite_version
4140 ? f_ "Declare fast forward from %s\n", $arch_v
4141 : f_ "Make fast forward from %s\n", $arch_v);
4143 maybe_split_brain_save $maintview, $r, "pseudomerge";
4145 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4149 sub plain_overwrite_pseudomerge ($$$) {
4150 my ($clogp, $head, $archive_hash) = @_;
4152 printdebug "plain_overwrite_pseudomerge...";
4154 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4156 return $head if is_fast_fwd $archive_hash, $head;
4158 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4160 my $r = pseudomerge_make_commit
4161 $clogp, $head, $archive_hash, $i_arch_v,
4164 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4166 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4170 sub push_parse_changelog ($) {
4173 my $clogp = Dpkg::Control::Hash->new();
4174 $clogp->load($clogpfn) or die;
4176 my $clogpackage = getfield $clogp, 'Source';
4177 $package //= $clogpackage;
4178 fail f_ "-p specified %s but changelog specified %s",
4179 $package, $clogpackage
4180 unless $package eq $clogpackage;
4181 my $cversion = getfield $clogp, 'Version';
4183 if (!$we_are_initiator) {
4184 # rpush initiator can't do this because it doesn't have $isuite yet
4185 my $tag = debiantag($cversion, access_nomdistro);
4186 runcmd @git, qw(check-ref-format), $tag;
4189 my $dscfn = dscfn($cversion);
4191 return ($clogp, $cversion, $dscfn);
4194 sub push_parse_dsc ($$$) {
4195 my ($dscfn,$dscfnwhat, $cversion) = @_;
4196 $dsc = parsecontrol($dscfn,$dscfnwhat);
4197 my $dversion = getfield $dsc, 'Version';
4198 my $dscpackage = getfield $dsc, 'Source';
4199 ($dscpackage eq $package && $dversion eq $cversion) or
4200 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4201 $dscfn, $dscpackage, $dversion,
4202 $package, $cversion;
4205 sub push_tagwants ($$$$) {
4206 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4209 TagFn => \&debiantag,
4214 if (defined $maintviewhead) {
4216 TagFn => \&debiantag_maintview,
4217 Objid => $maintviewhead,
4218 TfSuffix => '-maintview',
4221 } elsif ($dodep14tag eq 'no' ? 0
4222 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4223 : $dodep14tag eq 'always'
4224 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4225 --dep14tag-always (or equivalent in config) means server must support
4226 both "new" and "maint" tag formats, but config says it doesn't.
4228 : die "$dodep14tag ?") {
4230 TagFn => \&debiantag_maintview,
4232 TfSuffix => '-dgit',
4236 foreach my $tw (@tagwants) {
4237 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4238 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4240 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4244 sub push_mktags ($$ $$ $) {
4246 $changesfile,$changesfilewhat,
4249 die unless $tagwants->[0]{View} eq 'dgit';
4251 my $declaredistro = access_nomdistro();
4252 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4253 $dsc->{$ourdscfield[0]} = join " ",
4254 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4256 $dsc->save("$dscfn.tmp") or confess $!;
4258 my $changes = parsecontrol($changesfile,$changesfilewhat);
4259 foreach my $field (qw(Source Distribution Version)) {
4260 $changes->{$field} eq $clogp->{$field} or
4261 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4262 $field, $changes->{$field}, $clogp->{$field};
4265 my $cversion = getfield $clogp, 'Version';
4266 my $clogsuite = getfield $clogp, 'Distribution';
4268 # We make the git tag by hand because (a) that makes it easier
4269 # to control the "tagger" (b) we can do remote signing
4270 my $authline = clogp_authline $clogp;
4271 my $delibs = join(" ", "",@deliberatelies);
4275 my $tfn = $tw->{Tfn};
4276 my $head = $tw->{Objid};
4277 my $tag = $tw->{Tag};
4279 open TO, '>', $tfn->('.tmp') or confess $!;
4280 print TO <<END or confess $!;
4287 if ($tw->{View} eq 'dgit') {
4288 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4289 %s release %s for %s (%s) [dgit]
4292 print TO <<END or confess $!;
4293 [dgit distro=$declaredistro$delibs]
4295 foreach my $ref (sort keys %previously) {
4296 print TO <<END or confess $!;
4297 [dgit previously:$ref=$previously{$ref}]
4300 } elsif ($tw->{View} eq 'maint') {
4301 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4302 %s release %s for %s (%s)
4303 (maintainer view tag generated by dgit --quilt=%s)
4308 confess Dumper($tw)."?";
4311 close TO or confess $!;
4313 my $tagobjfn = $tfn->('.tmp');
4315 if (!defined $keyid) {
4316 $keyid = access_cfg('keyid','RETURN-UNDEF');
4318 if (!defined $keyid) {
4319 $keyid = getfield $clogp, 'Maintainer';
4321 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
4322 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4323 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4324 push @sign_cmd, $tfn->('.tmp');
4325 runcmd_ordryrun @sign_cmd;
4327 $tagobjfn = $tfn->('.signed.tmp');
4328 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4329 $tfn->('.tmp'), $tfn->('.tmp.asc');
4335 my @r = map { $mktag->($_); } @$tagwants;
4339 sub sign_changes ($) {
4340 my ($changesfile) = @_;
4342 my @debsign_cmd = @debsign;
4343 push @debsign_cmd, "-k$keyid" if defined $keyid;
4344 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4345 push @debsign_cmd, $changesfile;
4346 runcmd_ordryrun @debsign_cmd;
4351 printdebug "actually entering push\n";
4353 supplementary_message(__ <<'END');
4354 Push failed, while checking state of the archive.
4355 You can retry the push, after fixing the problem, if you like.
4357 if (check_for_git()) {
4360 my $archive_hash = fetch_from_archive();
4361 if (!$archive_hash) {
4363 fail __ "package appears to be new in this suite;".
4364 " if this is intentional, use --new";
4367 supplementary_message(__ <<'END');
4368 Push failed, while preparing your push.
4369 You can retry the push, after fixing the problem, if you like.
4372 need_tagformat 'new', "quilt mode $quilt_mode"
4373 if quiltmode_splitbrain;
4377 access_giturl(); # check that success is vaguely likely
4378 rpush_handle_protovsn_bothends() if $we_are_initiator;
4381 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4382 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4384 responder_send_file('parsed-changelog', $clogpfn);
4386 my ($clogp, $cversion, $dscfn) =
4387 push_parse_changelog("$clogpfn");
4389 my $dscpath = "$buildproductsdir/$dscfn";
4390 stat_exists $dscpath or
4391 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4394 responder_send_file('dsc', $dscpath);
4396 push_parse_dsc($dscpath, $dscfn, $cversion);
4398 my $format = getfield $dsc, 'Format';
4399 printdebug "format $format\n";
4401 my $symref = git_get_symref();
4402 my $actualhead = git_rev_parse('HEAD');
4404 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4405 if (quiltmode_splitbrain()) {
4406 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4407 fail f_ <<END, $ffq_prev, $quilt_mode;
4408 Branch is managed by git-debrebase (%s
4409 exists), but quilt mode (%s) implies a split view.
4410 Pass the right --quilt option or adjust your git config.
4411 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4414 runcmd_ordryrun_local @git_debrebase, 'stitch';
4415 $actualhead = git_rev_parse('HEAD');
4418 my $dgithead = $actualhead;
4419 my $maintviewhead = undef;
4421 my $upstreamversion = upstreamversion $clogp->{Version};
4423 if (madformat_wantfixup($format)) {
4424 # user might have not used dgit build, so maybe do this now:
4425 if (quiltmode_splitbrain()) {
4426 changedir $playground;
4427 quilt_make_fake_dsc($upstreamversion);
4429 ($dgithead, $cachekey) =
4430 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4431 $dgithead or fail f_
4432 "--quilt=%s but no cached dgit view:
4433 perhaps HEAD changed since dgit build[-source] ?",
4436 $dgithead = splitbrain_pseudomerge($clogp,
4437 $actualhead, $dgithead,
4439 $maintviewhead = $actualhead;
4441 prep_ud(); # so _only_subdir() works, below
4443 commit_quilty_patch();
4447 if (defined $overwrite_version && !defined $maintviewhead
4449 $dgithead = plain_overwrite_pseudomerge($clogp,
4457 if ($archive_hash) {
4458 if (is_fast_fwd($archive_hash, $dgithead)) {
4460 } elsif (deliberately_not_fast_forward) {
4463 fail __ "dgit push: HEAD is not a descendant".
4464 " of the archive's version.\n".
4465 "To overwrite the archive's contents,".
4466 " pass --overwrite[=VERSION].\n".
4467 "To rewind history, if permitted by the archive,".
4468 " use --deliberately-not-fast-forward.";
4472 changedir $playground;
4473 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4474 runcmd qw(dpkg-source -x --),
4475 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4476 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4477 check_for_vendor_patches() if madformat($dsc->{format});
4479 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4480 debugcmd "+",@diffcmd;
4482 my $r = system @diffcmd;
4485 my $referent = $split_brain ? $dgithead : 'HEAD';
4486 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4489 my $raw = cmdoutput @git,
4490 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4492 foreach (split /\0/, $raw) {
4493 if (defined $changed) {
4494 push @mode_changes, "$changed: $_\n" if $changed;
4497 } elsif (m/^:0+ 0+ /) {
4499 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4500 $changed = "Mode change from $1 to $2"
4505 if (@mode_changes) {
4506 fail +(f_ <<ENDT, $dscfn).<<END
4507 HEAD specifies a different tree to %s:
4511 .(join '', @mode_changes)
4512 .(f_ <<ENDT, $tree, $referent);
4513 There is a problem with your source tree (see dgit(7) for some hints).
4514 To see a full diff, run git diff %s %s
4518 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4519 HEAD specifies a different tree to %s:
4523 Perhaps you forgot to build. Or perhaps there is a problem with your
4524 source tree (see dgit(7) for some hints). To see a full diff, run
4531 if (!$changesfile) {
4532 my $pat = changespat $cversion;
4533 my @cs = glob "$buildproductsdir/$pat";
4534 fail f_ "failed to find unique changes file".
4535 " (looked for %s in %s);".
4536 " perhaps you need to use dgit -C",
4537 $pat, $buildproductsdir
4539 ($changesfile) = @cs;
4541 $changesfile = "$buildproductsdir/$changesfile";
4544 # Check that changes and .dsc agree enough
4545 $changesfile =~ m{[^/]*$};
4546 my $changes = parsecontrol($changesfile,$&);
4547 files_compare_inputs($dsc, $changes)
4548 unless forceing [qw(dsc-changes-mismatch)];
4550 # Check whether this is a source only upload
4551 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4552 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4553 if ($sourceonlypolicy eq 'ok') {
4554 } elsif ($sourceonlypolicy eq 'always') {
4555 forceable_fail [qw(uploading-binaries)],
4556 __ "uploading binaries, although distro policy is source only"
4558 } elsif ($sourceonlypolicy eq 'never') {
4559 forceable_fail [qw(uploading-source-only)],
4560 __ "source-only upload, although distro policy requires .debs"
4562 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4563 forceable_fail [qw(uploading-source-only)],
4564 f_ "source-only upload, even though package is entirely NEW\n".
4565 "(this is contrary to policy in %s)",
4569 && !(archive_query('package_not_wholly_new', $package) // 1);
4571 badcfg f_ "unknown source-only-uploads policy \`%s'",
4575 # Perhaps adjust .dsc to contain right set of origs
4576 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4578 unless forceing [qw(changes-origs-exactly)];
4580 # Checks complete, we're going to try and go ahead:
4582 responder_send_file('changes',$changesfile);
4583 responder_send_command("param head $dgithead");
4584 responder_send_command("param csuite $csuite");
4585 responder_send_command("param isuite $isuite");
4586 responder_send_command("param tagformat $tagformat");
4587 if (defined $maintviewhead) {
4588 confess "internal error (protovsn=$protovsn)"
4589 if defined $protovsn and $protovsn < 4;
4590 responder_send_command("param maint-view $maintviewhead");
4593 # Perhaps send buildinfo(s) for signing
4594 my $changes_files = getfield $changes, 'Files';
4595 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4596 foreach my $bi (@buildinfos) {
4597 responder_send_command("param buildinfo-filename $bi");
4598 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4601 if (deliberately_not_fast_forward) {
4602 git_for_each_ref(lrfetchrefs, sub {
4603 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4604 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4605 responder_send_command("previously $rrefname=$objid");
4606 $previously{$rrefname} = $objid;
4610 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4611 dgit_privdir()."/tag");
4614 supplementary_message(__ <<'END');
4615 Push failed, while signing the tag.
4616 You can retry the push, after fixing the problem, if you like.
4618 # If we manage to sign but fail to record it anywhere, it's fine.
4619 if ($we_are_responder) {
4620 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4621 responder_receive_files('signed-tag', @tagobjfns);
4623 @tagobjfns = push_mktags($clogp,$dscpath,
4624 $changesfile,$changesfile,
4627 supplementary_message(__ <<'END');
4628 Push failed, *after* signing the tag.
4629 If you want to try again, you should use a new version number.
4632 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4634 foreach my $tw (@tagwants) {
4635 my $tag = $tw->{Tag};
4636 my $tagobjfn = $tw->{TagObjFn};
4638 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4639 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4640 runcmd_ordryrun_local
4641 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4644 supplementary_message(__ <<'END');
4645 Push failed, while updating the remote git repository - see messages above.
4646 If you want to try again, you should use a new version number.
4648 if (!check_for_git()) {
4649 create_remote_git_repo();
4652 my @pushrefs = $forceflag.$dgithead.":".rrref();
4653 foreach my $tw (@tagwants) {
4654 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4657 runcmd_ordryrun @git,
4658 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4659 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4661 supplementary_message(__ <<'END');
4662 Push failed, while obtaining signatures on the .changes and .dsc.
4663 If it was just that the signature failed, you may try again by using
4664 debsign by hand to sign the changes file (see the command dgit tried,
4665 above), and then dput that changes file to complete the upload.
4666 If you need to change the package, you must use a new version number.
4668 if ($we_are_responder) {
4669 my $dryrunsuffix = act_local() ? "" : ".tmp";
4670 my @rfiles = ($dscpath, $changesfile);
4671 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4672 responder_receive_files('signed-dsc-changes',
4673 map { "$_$dryrunsuffix" } @rfiles);
4676 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4678 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4680 sign_changes $changesfile;
4683 supplementary_message(f_ <<END, $changesfile);
4684 Push failed, while uploading package(s) to the archive server.
4685 You can retry the upload of exactly these same files with dput of:
4687 If that .changes file is broken, you will need to use a new version
4688 number for your next attempt at the upload.
4690 my $host = access_cfg('upload-host','RETURN-UNDEF');
4691 my @hostarg = defined($host) ? ($host,) : ();
4692 runcmd_ordryrun @dput, @hostarg, $changesfile;
4693 printdone f_ "pushed and uploaded %s", $cversion;
4695 supplementary_message('');
4696 responder_send_command("complete");
4700 not_necessarily_a_tree();
4705 badusage __ "-p is not allowed with clone; specify as argument instead"
4706 if defined $package;
4709 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4710 ($package,$isuite) = @ARGV;
4711 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4712 ($package,$dstdir) = @ARGV;
4713 } elsif (@ARGV==3) {
4714 ($package,$isuite,$dstdir) = @ARGV;
4716 badusage __ "incorrect arguments to dgit clone";
4720 $dstdir ||= "$package";
4721 if (stat_exists $dstdir) {
4722 fail f_ "%s already exists", $dstdir;
4726 if ($rmonerror && !$dryrun_level) {
4727 $cwd_remove= getcwd();
4729 return unless defined $cwd_remove;
4730 if (!chdir "$cwd_remove") {
4731 return if $!==&ENOENT;
4732 confess "chdir $cwd_remove: $!";
4734 printdebug "clone rmonerror removing $dstdir\n";
4736 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4737 } elsif (grep { $! == $_ }
4738 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4740 print STDERR f_ "check whether to remove %s: %s\n",
4747 $cwd_remove = undef;
4750 sub branchsuite () {
4751 my $branch = git_get_symref();
4752 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4759 sub package_from_d_control () {
4760 if (!defined $package) {
4761 my $sourcep = parsecontrol('debian/control','debian/control');
4762 $package = getfield $sourcep, 'Source';
4766 sub fetchpullargs () {
4767 package_from_d_control();
4769 $isuite = branchsuite();
4771 my $clogp = parsechangelog();
4772 my $clogsuite = getfield $clogp, 'Distribution';
4773 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4775 } elsif (@ARGV==1) {
4778 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4792 if (quiltmode_splitbrain()) {
4793 my ($format, $fopts) = get_source_format();
4794 madformat($format) and fail f_ <<END, $quilt_mode
4795 dgit pull not yet supported in split view mode (--quilt=%s)
4803 package_from_d_control();
4804 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4808 foreach my $canon (qw(0 1)) {
4813 canonicalise_suite();
4815 if (length git_get_ref lref()) {
4816 # local branch already exists, yay
4819 if (!length git_get_ref lrref()) {
4827 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4830 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4831 "dgit checkout $isuite";
4832 runcmd (@git, qw(checkout), lbranch());
4835 sub cmd_update_vcs_git () {
4837 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4838 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4840 ($specsuite) = (@ARGV);
4845 if ($ARGV[0] eq '-') {
4847 } elsif ($ARGV[0] eq '-') {
4852 package_from_d_control();
4854 if ($specsuite eq '.') {
4855 $ctrl = parsecontrol 'debian/control', 'debian/control';
4857 $isuite = $specsuite;
4861 my $url = getfield $ctrl, 'Vcs-Git';
4864 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4865 if (!defined $orgurl) {
4866 print STDERR f_ "setting up vcs-git: %s\n", $url;
4867 @cmd = (@git, qw(remote add vcs-git), $url);
4868 } elsif ($orgurl eq $url) {
4869 print STDERR f_ "vcs git already configured: %s\n", $url;
4871 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4872 @cmd = (@git, qw(remote set-url vcs-git), $url);
4874 runcmd_ordryrun_local @cmd;
4876 print f_ "fetching (%s)\n", "@ARGV";
4877 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4883 build_or_push_prep_early();
4888 } elsif (@ARGV==1) {
4889 ($specsuite) = (@ARGV);
4891 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4894 local ($package) = $existing_package; # this is a hack
4895 canonicalise_suite();
4897 canonicalise_suite();
4899 if (defined $specsuite &&
4900 $specsuite ne $isuite &&
4901 $specsuite ne $csuite) {
4902 fail f_ "dgit %s: changelog specifies %s (%s)".
4903 " but command line specifies %s",
4904 $subcommand, $isuite, $csuite, $specsuite;
4913 #---------- remote commands' implementation ----------
4915 sub pre_remote_push_build_host {
4916 my ($nrargs) = shift @ARGV;
4917 my (@rargs) = @ARGV[0..$nrargs-1];
4918 @ARGV = @ARGV[$nrargs..$#ARGV];
4920 my ($dir,$vsnwant) = @rargs;
4921 # vsnwant is a comma-separated list; we report which we have
4922 # chosen in our ready response (so other end can tell if they
4925 $we_are_responder = 1;
4926 $us .= " (build host)";
4928 open PI, "<&STDIN" or confess $!;
4929 open STDIN, "/dev/null" or confess $!;
4930 open PO, ">&STDOUT" or confess $!;
4932 open STDOUT, ">&STDERR" or confess $!;
4936 ($protovsn) = grep {
4937 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4938 } @rpushprotovsn_support;
4940 fail f_ "build host has dgit rpush protocol versions %s".
4941 " but invocation host has %s",
4942 (join ",", @rpushprotovsn_support), $vsnwant
4943 unless defined $protovsn;
4947 sub cmd_remote_push_build_host {
4948 responder_send_command("dgit-remote-push-ready $protovsn");
4952 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4953 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4954 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4955 # a good error message)
4957 sub rpush_handle_protovsn_bothends () {
4958 if ($protovsn < 4) {
4959 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4968 my $report = i_child_report();
4969 if (defined $report) {
4970 printdebug "($report)\n";
4971 } elsif ($i_child_pid) {
4972 printdebug "(killing build host child $i_child_pid)\n";
4973 kill 15, $i_child_pid;
4975 if (defined $i_tmp && !defined $initiator_tempdir) {
4977 eval { rmtree $i_tmp; };
4982 return unless forkcheck_mainprocess();
4987 my ($base,$selector,@args) = @_;
4988 $selector =~ s/\-/_/g;
4989 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4993 not_necessarily_a_tree();
4998 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5006 push @rargs, join ",", @rpushprotovsn_support;
5009 push @rdgit, @ropts;
5010 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5012 my @cmd = (@ssh, $host, shellquote @rdgit);
5015 $we_are_initiator=1;
5017 if (defined $initiator_tempdir) {
5018 rmtree $initiator_tempdir;
5019 mkdir $initiator_tempdir, 0700
5020 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5021 $i_tmp = $initiator_tempdir;
5025 $i_child_pid = open2(\*RO, \*RI, @cmd);
5027 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5028 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5029 $supplementary_message = '' unless $protovsn >= 3;
5032 my ($icmd,$iargs) = initiator_expect {
5033 m/^(\S+)(?: (.*))?$/;
5036 i_method "i_resp", $icmd, $iargs;
5040 sub i_resp_progress ($) {
5042 my $msg = protocol_read_bytes \*RO, $rhs;
5046 sub i_resp_supplementary_message ($) {
5048 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5051 sub i_resp_complete {
5052 my $pid = $i_child_pid;
5053 $i_child_pid = undef; # prevents killing some other process with same pid
5054 printdebug "waiting for build host child $pid...\n";
5055 my $got = waitpid $pid, 0;
5056 confess $! unless $got == $pid;
5057 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5060 printdebug __ "all done\n";
5064 sub i_resp_file ($) {
5066 my $localname = i_method "i_localname", $keyword;
5067 my $localpath = "$i_tmp/$localname";
5068 stat_exists $localpath and
5069 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5070 protocol_receive_file \*RO, $localpath;
5071 i_method "i_file", $keyword;
5076 sub i_resp_param ($) {
5077 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5081 sub i_resp_previously ($) {
5082 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5083 or badproto \*RO, __ "bad previously spec";
5084 my $r = system qw(git check-ref-format), $1;
5085 confess "bad previously ref spec ($r)" if $r;
5086 $previously{$1} = $2;
5091 sub i_resp_want ($) {
5093 die "$keyword ?" if $i_wanted{$keyword}++;
5095 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5096 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5097 die unless $isuite =~ m/^$suite_re$/;
5100 rpush_handle_protovsn_bothends();
5102 fail f_ "rpush negotiated protocol version %s".
5103 " which does not support quilt mode %s",
5104 $protovsn, $quilt_mode
5105 if quiltmode_splitbrain;
5107 my @localpaths = i_method "i_want", $keyword;
5108 printdebug "[[ $keyword @localpaths\n";
5109 foreach my $localpath (@localpaths) {
5110 protocol_send_file \*RI, $localpath;
5112 print RI "files-end\n" or confess $!;
5115 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5117 sub i_localname_parsed_changelog {
5118 return "remote-changelog.822";
5120 sub i_file_parsed_changelog {
5121 ($i_clogp, $i_version, $i_dscfn) =
5122 push_parse_changelog "$i_tmp/remote-changelog.822";
5123 die if $i_dscfn =~ m#/|^\W#;
5126 sub i_localname_dsc {
5127 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5132 sub i_localname_buildinfo ($) {
5133 my $bi = $i_param{'buildinfo-filename'};
5134 defined $bi or badproto \*RO, "buildinfo before filename";
5135 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5136 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5137 or badproto \*RO, "improper buildinfo filename";
5140 sub i_file_buildinfo {
5141 my $bi = $i_param{'buildinfo-filename'};
5142 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5143 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5144 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5145 files_compare_inputs($bd, $ch);
5146 (getfield $bd, $_) eq (getfield $ch, $_) or
5147 fail f_ "buildinfo mismatch in field %s", $_
5148 foreach qw(Source Version);
5149 !defined $bd->{$_} or
5150 fail f_ "buildinfo contains forbidden field %s", $_
5151 foreach qw(Changes Changed-by Distribution);
5153 push @i_buildinfos, $bi;
5154 delete $i_param{'buildinfo-filename'};
5157 sub i_localname_changes {
5158 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5159 $i_changesfn = $i_dscfn;
5160 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5161 return $i_changesfn;
5163 sub i_file_changes { }
5165 sub i_want_signed_tag {
5166 printdebug Dumper(\%i_param, $i_dscfn);
5167 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5168 && defined $i_param{'csuite'}
5169 or badproto \*RO, "premature desire for signed-tag";
5170 my $head = $i_param{'head'};
5171 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5173 my $maintview = $i_param{'maint-view'};
5174 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5177 if ($protovsn >= 4) {
5178 my $p = $i_param{'tagformat'} // '<undef>';
5180 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5183 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5185 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5187 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5190 push_mktags $i_clogp, $i_dscfn,
5191 $i_changesfn, (__ 'remote changes file'),
5195 sub i_want_signed_dsc_changes {
5196 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5197 sign_changes $i_changesfn;
5198 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5201 #---------- building etc. ----------
5207 #----- `3.0 (quilt)' handling -----
5209 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5211 sub quiltify_dpkg_commit ($$$;$) {
5212 my ($patchname,$author,$msg, $xinfo) = @_;
5215 mkpath '.git/dgit'; # we are in playtree
5216 my $descfn = ".git/dgit/quilt-description.tmp";
5217 open O, '>', $descfn or confess "$descfn: $!";
5218 $msg =~ s/\n+/\n\n/;
5219 print O <<END or confess $!;
5221 ${xinfo}Subject: $msg
5225 close O or confess $!;
5228 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5229 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5230 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5231 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5235 sub quiltify_trees_differ ($$;$$$) {
5236 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5237 # returns true iff the two tree objects differ other than in debian/
5238 # with $finegrained,
5239 # returns bitmask 01 - differ in upstream files except .gitignore
5240 # 02 - differ in .gitignore
5241 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5242 # is set for each modified .gitignore filename $fn
5243 # if $unrepres is defined, array ref to which is appeneded
5244 # a list of unrepresentable changes (removals of upstream files
5247 my @cmd = (@git, qw(diff-tree -z --no-renames));
5248 push @cmd, qw(--name-only) unless $unrepres;
5249 push @cmd, qw(-r) if $finegrained || $unrepres;
5251 my $diffs= cmdoutput @cmd;
5254 foreach my $f (split /\0/, $diffs) {
5255 if ($unrepres && !@lmodes) {
5256 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5259 my ($oldmode,$newmode) = @lmodes;
5262 next if $f =~ m#^debian(?:/.*)?$#s;
5266 die __ "not a plain file or symlink\n"
5267 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5268 $oldmode =~ m/^(?:10|12)\d{4}$/;
5269 if ($oldmode =~ m/[^0]/ &&
5270 $newmode =~ m/[^0]/) {
5271 # both old and new files exist
5272 die __ "mode or type changed\n" if $oldmode ne $newmode;
5273 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5274 } elsif ($oldmode =~ m/[^0]/) {
5276 die __ "deletion of symlink\n"
5277 unless $oldmode =~ m/^10/;
5280 die __ "creation with non-default mode\n"
5281 unless $newmode =~ m/^100644$/ or
5282 $newmode =~ m/^120000$/;
5286 local $/="\n"; chomp $@;
5287 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5291 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5292 $r |= $isignore ? 02 : 01;
5293 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5295 printdebug "quiltify_trees_differ $x $y => $r\n";
5299 sub quiltify_tree_sentinelfiles ($) {
5300 # lists the `sentinel' files present in the tree
5302 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5303 qw(-- debian/rules debian/control);
5308 sub quiltify_splitbrain_needed () {
5309 if (!$split_brain) {
5310 progress __ "dgit view: changes are required...";
5311 runcmd @git, qw(checkout -q -b dgit-view);
5316 sub quiltify_splitbrain ($$$$$$$) {
5317 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5318 $editedignores, $cachekey) = @_;
5319 my $gitignore_special = 1;
5320 if ($quilt_mode !~ m/gbp|dpm/) {
5321 # treat .gitignore just like any other upstream file
5322 $diffbits = { %$diffbits };
5323 $_ = !!$_ foreach values %$diffbits;
5324 $gitignore_special = 0;
5326 # We would like any commits we generate to be reproducible
5327 my @authline = clogp_authline($clogp);
5328 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5329 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5330 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5331 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5332 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5333 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5335 my $fulldiffhint = sub {
5337 my $cmd = "git diff $x $y -- :/ ':!debian'";
5338 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5339 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5343 if ($quilt_mode =~ m/gbp|unapplied/ &&
5344 ($diffbits->{O2H} & 01)) {
5346 "--quilt=%s specified, implying patches-unapplied git tree\n".
5347 " but git tree differs from orig in upstream files.",
5349 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5350 if (!stat_exists "debian/patches") {
5352 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5356 if ($quilt_mode =~ m/dpm/ &&
5357 ($diffbits->{H2A} & 01)) {
5358 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5359 --quilt=%s specified, implying patches-applied git tree
5360 but git tree differs from result of applying debian/patches to upstream
5363 if ($quilt_mode =~ m/gbp|unapplied/ &&
5364 ($diffbits->{O2A} & 01)) { # some patches
5365 quiltify_splitbrain_needed();
5366 progress __ "dgit view: creating patches-applied version using gbp pq";
5367 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5368 # gbp pq import creates a fresh branch; push back to dgit-view
5369 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5370 runcmd @git, qw(checkout -q dgit-view);
5372 if ($quilt_mode =~ m/gbp|dpm/ &&
5373 ($diffbits->{O2A} & 02)) {
5374 fail f_ <<END, $quilt_mode;
5375 --quilt=%s specified, implying that HEAD is for use with a
5376 tool which does not create patches for changes to upstream
5377 .gitignores: but, such patches exist in debian/patches.
5380 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5381 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5382 quiltify_splitbrain_needed();
5384 "dgit view: creating patch to represent .gitignore changes";
5385 ensuredir "debian/patches";
5386 my $gipatch = "debian/patches/auto-gitignore";
5387 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5388 stat GIPATCH or confess "$gipatch: $!";
5389 fail f_ "%s already exists; but want to create it".
5390 " to record .gitignore changes",
5393 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5394 Subject: Update .gitignore from Debian packaging branch
5396 The Debian packaging git branch contains these updates to the upstream
5397 .gitignore file(s). This patch is autogenerated, to provide these
5398 updates to users of the official Debian archive view of the package.
5401 [dgit ($our_version) update-gitignore]
5404 close GIPATCH or die "$gipatch: $!";
5405 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5406 $unapplied, $headref, "--", sort keys %$editedignores;
5407 open SERIES, "+>>", "debian/patches/series" or confess $!;
5408 defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
5410 defined read SERIES, $newline, 1 or confess $!;
5411 print SERIES "\n" or confess $! unless $newline eq "\n";
5412 print SERIES "auto-gitignore\n" or confess $!;
5413 close SERIES or die $!;
5414 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5415 commit_admin +(__ <<END).<<ENDU
5416 Commit patch to update .gitignore
5419 [dgit ($our_version) update-gitignore-quilt-fixup]
5423 my $dgitview = git_rev_parse 'HEAD';
5426 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5428 changedir "$playground/work";
5430 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5431 progress f_ "dgit view: created (%s)", $saved;
5434 sub quiltify ($$$$) {
5435 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5437 # Quilt patchification algorithm
5439 # We search backwards through the history of the main tree's HEAD
5440 # (T) looking for a start commit S whose tree object is identical
5441 # to to the patch tip tree (ie the tree corresponding to the
5442 # current dpkg-committed patch series). For these purposes
5443 # `identical' disregards anything in debian/ - this wrinkle is
5444 # necessary because dpkg-source treates debian/ specially.
5446 # We can only traverse edges where at most one of the ancestors'
5447 # trees differs (in changes outside in debian/). And we cannot
5448 # handle edges which change .pc/ or debian/patches. To avoid
5449 # going down a rathole we avoid traversing edges which introduce
5450 # debian/rules or debian/control. And we set a limit on the
5451 # number of edges we are willing to look at.
5453 # If we succeed, we walk forwards again. For each traversed edge
5454 # PC (with P parent, C child) (starting with P=S and ending with
5455 # C=T) to we do this:
5457 # - dpkg-source --commit with a patch name and message derived from C
5458 # After traversing PT, we git commit the changes which
5459 # should be contained within debian/patches.
5461 # The search for the path S..T is breadth-first. We maintain a
5462 # todo list containing search nodes. A search node identifies a
5463 # commit, and looks something like this:
5465 # Commit => $git_commit_id,
5466 # Child => $c, # or undef if P=T
5467 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5468 # Nontrivial => true iff $p..$c has relevant changes
5475 my %considered; # saves being exponential on some weird graphs
5477 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5480 my ($search,$whynot) = @_;
5481 printdebug " search NOT $search->{Commit} $whynot\n";
5482 $search->{Whynot} = $whynot;
5483 push @nots, $search;
5484 no warnings qw(exiting);
5493 my $c = shift @todo;
5494 next if $considered{$c->{Commit}}++;
5496 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5498 printdebug "quiltify investigate $c->{Commit}\n";
5501 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5502 printdebug " search finished hooray!\n";
5507 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5508 if ($quilt_mode eq 'smash') {
5509 printdebug " search quitting smash\n";
5513 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5514 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5515 if $c_sentinels ne $t_sentinels;
5517 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5518 $commitdata =~ m/\n\n/;
5520 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5521 @parents = map { { Commit => $_, Child => $c } } @parents;
5523 $not->($c, __ "root commit") if !@parents;
5525 foreach my $p (@parents) {
5526 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5528 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5529 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5532 foreach my $p (@parents) {
5533 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5535 my @cmd= (@git, qw(diff-tree -r --name-only),
5536 $p->{Commit},$c->{Commit},
5537 qw(-- debian/patches .pc debian/source/format));
5538 my $patchstackchange = cmdoutput @cmd;
5539 if (length $patchstackchange) {
5540 $patchstackchange =~ s/\n/,/g;
5541 $not->($p, f_ "changed %s", $patchstackchange);
5544 printdebug " search queue P=$p->{Commit} ",
5545 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5551 printdebug "quiltify want to smash\n";
5554 my $x = $_[0]{Commit};
5555 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5558 if ($quilt_mode eq 'linear') {
5560 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5562 my $all_gdr = !!@nots;
5563 foreach my $notp (@nots) {
5564 my $c = $notp->{Child};
5565 my $cprange = $abbrev->($notp);
5566 $cprange .= "..".$abbrev->($c) if $c;
5567 print STDERR f_ "%s: %s: %s\n",
5568 $us, $cprange, $notp->{Whynot};
5569 $all_gdr &&= $notp->{Child} &&
5570 (git_cat_file $notp->{Child}{Commit}, 'commit')
5571 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5575 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5577 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5579 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5580 } elsif ($quilt_mode eq 'smash') {
5581 } elsif ($quilt_mode eq 'auto') {
5582 progress __ "quilt fixup cannot be linear, smashing...";
5584 confess "$quilt_mode ?";
5587 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5588 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5590 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5592 quiltify_dpkg_commit "auto-$version-$target-$time",
5593 (getfield $clogp, 'Maintainer'),
5594 (f_ "Automatically generated patch (%s)\n".
5595 "Last (up to) %s git changes, FYI:\n\n",
5596 $clogp->{Version}, $ncommits).
5601 progress __ "quiltify linearisation planning successful, executing...";
5603 for (my $p = $sref_S;
5604 my $c = $p->{Child};
5606 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5607 next unless $p->{Nontrivial};
5609 my $cc = $c->{Commit};
5611 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5612 $commitdata =~ m/\n\n/ or die "$c ?";
5615 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5618 my $commitdate = cmdoutput
5619 @git, qw(log -n1 --pretty=format:%aD), $cc;
5621 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5623 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5630 my $gbp_check_suitable = sub {
5635 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5636 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5637 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5638 die __ "is series file\n" if m{$series_filename_re}o;
5639 die __ "too long\n" if length > 200;
5641 return $_ unless $@;
5643 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5648 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5650 (\S+) \s* \n //ixm) {
5651 $patchname = $gbp_check_suitable->($1, 'Name');
5653 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5655 (\S+) \s* \n //ixm) {
5656 $patchdir = $gbp_check_suitable->($1, 'Topic');
5661 if (!defined $patchname) {
5662 $patchname = $title;
5663 $patchname =~ s/[.:]$//;
5666 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5667 my $translitname = $converter->convert($patchname);
5668 die unless defined $translitname;
5669 $patchname = $translitname;
5672 +(f_ "dgit: patch title transliteration error: %s", $@)
5674 $patchname =~ y/ A-Z/-a-z/;
5675 $patchname =~ y/-a-z0-9_.+=~//cd;
5676 $patchname =~ s/^\W/x-$&/;
5677 $patchname = substr($patchname,0,40);
5678 $patchname .= ".patch";
5680 if (!defined $patchdir) {
5683 if (length $patchdir) {
5684 $patchname = "$patchdir/$patchname";
5686 if ($patchname =~ m{^(.*)/}) {
5687 mkpath "debian/patches/$1";
5692 stat "debian/patches/$patchname$index";
5694 $!==ENOENT or confess "$patchname$index $!";
5696 runcmd @git, qw(checkout -q), $cc;
5698 # We use the tip's changelog so that dpkg-source doesn't
5699 # produce complaining messages from dpkg-parsechangelog. None
5700 # of the information dpkg-source gets from the changelog is
5701 # actually relevant - it gets put into the original message
5702 # which dpkg-source provides our stunt editor, and then
5704 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5706 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5707 "Date: $commitdate\n".
5708 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5710 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5713 runcmd @git, qw(checkout -q master);
5716 sub build_maybe_quilt_fixup () {
5717 my ($format,$fopts) = get_source_format;
5718 return unless madformat_wantfixup $format;
5721 check_for_vendor_patches();
5723 if (quiltmode_splitbrain) {
5724 fail <<END unless access_cfg_tagformats_can_splitbrain;
5725 quilt mode $quilt_mode requires split view so server needs to support
5726 both "new" and "maint" tag formats, but config says it doesn't.
5730 my $clogp = parsechangelog();
5731 my $headref = git_rev_parse('HEAD');
5732 my $symref = git_get_symref();
5734 if ($quilt_mode eq 'linear'
5735 && !$fopts->{'single-debian-patch'}
5736 && branch_is_gdr($headref)) {
5737 # This is much faster. It also makes patches that gdr
5738 # likes better for future updates without laundering.
5740 # However, it can fail in some casses where we would
5741 # succeed: if there are existing patches, which correspond
5742 # to a prefix of the branch, but are not in gbp/gdr
5743 # format, gdr will fail (exiting status 7), but we might
5744 # be able to figure out where to start linearising. That
5745 # will be slower so hopefully there's not much to do.
5746 my @cmd = (@git_debrebase,
5747 qw(--noop-ok -funclean-mixed -funclean-ordering
5748 make-patches --quiet-would-amend));
5749 # We tolerate soe snags that gdr wouldn't, by default.
5755 and not ($? == 7*256 or
5756 $? == -1 && $!==ENOENT);
5760 $headref = git_rev_parse('HEAD');
5764 changedir $playground;
5766 my $upstreamversion = upstreamversion $version;
5768 if ($fopts->{'single-debian-patch'}) {
5769 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5771 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5775 runcmd_ordryrun_local
5776 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5779 sub unpack_playtree_mkwork ($) {
5782 mkdir "work" or confess $!;
5784 mktree_in_ud_here();
5785 runcmd @git, qw(reset -q --hard), $headref;
5788 sub unpack_playtree_linkorigs ($$) {
5789 my ($upstreamversion, $fn) = @_;
5790 # calls $fn->($leafname);
5792 my $bpd_abs = bpd_abs();
5793 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5794 while ($!=0, defined(my $b = readdir QFD)) {
5795 my $f = bpd_abs()."/".$b;
5797 local ($debuglevel) = $debuglevel-1;
5798 printdebug "QF linkorigs $b, $f ?\n";
5800 next unless is_orig_file_of_vsn $b, $upstreamversion;
5801 printdebug "QF linkorigs $b, $f Y\n";
5802 link_ltarget $f, $b or die "$b $!";
5805 die "$buildproductsdir: $!" if $!;
5809 sub quilt_fixup_delete_pc () {
5810 runcmd @git, qw(rm -rqf .pc);
5811 commit_admin +(__ <<END).<<ENDU
5812 Commit removal of .pc (quilt series tracking data)
5815 [dgit ($our_version) upgrade quilt-remove-pc]
5819 sub quilt_fixup_singlepatch ($$$) {
5820 my ($clogp, $headref, $upstreamversion) = @_;
5822 progress __ "starting quiltify (single-debian-patch)";
5824 # dpkg-source --commit generates new patches even if
5825 # single-debian-patch is in debian/source/options. In order to
5826 # get it to generate debian/patches/debian-changes, it is
5827 # necessary to build the source package.
5829 unpack_playtree_linkorigs($upstreamversion, sub { });
5830 unpack_playtree_mkwork($headref);
5832 rmtree("debian/patches");
5834 runcmd @dpkgsource, qw(-b .);
5836 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5837 rename srcfn("$upstreamversion", "/debian/patches"),
5838 "work/debian/patches"
5840 or confess "install d/patches: $!";
5843 commit_quilty_patch();
5846 sub quilt_make_fake_dsc ($) {
5847 my ($upstreamversion) = @_;
5849 my $fakeversion="$upstreamversion-~~DGITFAKE";
5851 my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
5852 print $fakedsc <<END or confess $!;
5855 Version: $fakeversion
5859 my $dscaddfile=sub {
5862 my $md = new Digest::MD5;
5864 my $fh = new IO::File $b, '<' or die "$b $!";
5865 stat $fh or confess $!;
5869 print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!;
5872 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5874 my @files=qw(debian/source/format debian/rules
5875 debian/control debian/changelog);
5876 foreach my $maybe (qw(debian/patches debian/source/options
5877 debian/tests/control)) {
5878 next unless stat_exists "$maindir/$maybe";
5879 push @files, $maybe;
5882 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5883 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5885 $dscaddfile->($debtar);
5886 close $fakedsc or confess $!;
5889 sub quilt_fakedsc2unapplied ($$) {
5890 my ($headref, $upstreamversion) = @_;
5891 # must be run in the playground
5892 # quilt_make_fake_dsc must have been called
5895 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5897 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5898 rename $fakexdir, "fake" or die "$fakexdir $!";
5902 remove_stray_gits(__ "source package");
5903 mktree_in_ud_here();
5907 rmtree 'debian'; # git checkout commitish paths does not delete!
5908 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5909 my $unapplied=git_add_write_tree();
5910 printdebug "fake orig tree object $unapplied\n";
5914 sub quilt_check_splitbrain_cache ($$) {
5915 my ($headref, $upstreamversion) = @_;
5916 # Called only if we are in (potentially) split brain mode.
5917 # Called in playground.
5918 # Computes the cache key and looks in the cache.
5919 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5921 my $splitbrain_cachekey;
5924 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5926 # we look in the reflog of dgit-intern/quilt-cache
5927 # we look for an entry whose message is the key for the cache lookup
5928 my @cachekey = (qw(dgit), $our_version);
5929 push @cachekey, $upstreamversion;
5930 push @cachekey, $quilt_mode;
5931 push @cachekey, $headref;
5933 push @cachekey, hashfile('fake.dsc');
5935 my $srcshash = Digest::SHA->new(256);
5936 my %sfs = ( %INC, '$0(dgit)' => $0 );
5937 foreach my $sfk (sort keys %sfs) {
5938 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5939 $srcshash->add($sfk," ");
5940 $srcshash->add(hashfile($sfs{$sfk}));
5941 $srcshash->add("\n");
5943 push @cachekey, $srcshash->hexdigest();
5944 $splitbrain_cachekey = "@cachekey";
5946 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5948 my $cachehit = reflog_cache_lookup
5949 "refs/$splitbraincache", $splitbrain_cachekey;
5952 unpack_playtree_mkwork($headref);
5953 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5954 if ($cachehit ne $headref) {
5955 progress f_ "dgit view: found cached (%s)", $saved;
5956 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5958 return ($cachehit, $splitbrain_cachekey);
5960 progress __ "dgit view: found cached, no changes required";
5961 return ($headref, $splitbrain_cachekey);
5964 printdebug "splitbrain cache miss\n";
5965 return (undef, $splitbrain_cachekey);
5968 sub quilt_fixup_multipatch ($$$) {
5969 my ($clogp, $headref, $upstreamversion) = @_;
5971 progress f_ "examining quilt state (multiple patches, %s mode)",
5975 # - honour any existing .pc in case it has any strangeness
5976 # - determine the git commit corresponding to the tip of
5977 # the patch stack (if there is one)
5978 # - if there is such a git commit, convert each subsequent
5979 # git commit into a quilt patch with dpkg-source --commit
5980 # - otherwise convert all the differences in the tree into
5981 # a single git commit
5985 # Our git tree doesn't necessarily contain .pc. (Some versions of
5986 # dgit would include the .pc in the git tree.) If there isn't
5987 # one, we need to generate one by unpacking the patches that we
5990 # We first look for a .pc in the git tree. If there is one, we
5991 # will use it. (This is not the normal case.)
5993 # Otherwise need to regenerate .pc so that dpkg-source --commit
5994 # can work. We do this as follows:
5995 # 1. Collect all relevant .orig from parent directory
5996 # 2. Generate a debian.tar.gz out of
5997 # debian/{patches,rules,source/format,source/options}
5998 # 3. Generate a fake .dsc containing just these fields:
5999 # Format Source Version Files
6000 # 4. Extract the fake .dsc
6001 # Now the fake .dsc has a .pc directory.
6002 # (In fact we do this in every case, because in future we will
6003 # want to search for a good base commit for generating patches.)
6005 # Then we can actually do the dpkg-source --commit
6006 # 1. Make a new working tree with the same object
6007 # store as our main tree and check out the main
6009 # 2. Copy .pc from the fake's extraction, if necessary
6010 # 3. Run dpkg-source --commit
6011 # 4. If the result has changes to debian/, then
6012 # - git add them them
6013 # - git add .pc if we had a .pc in-tree
6015 # 5. If we had a .pc in-tree, delete it, and git commit
6016 # 6. Back in the main tree, fast forward to the new HEAD
6018 # Another situation we may have to cope with is gbp-style
6019 # patches-unapplied trees.
6021 # We would want to detect these, so we know to escape into
6022 # quilt_fixup_gbp. However, this is in general not possible.
6023 # Consider a package with a one patch which the dgit user reverts
6024 # (with git revert or the moral equivalent).
6026 # That is indistinguishable in contents from a patches-unapplied
6027 # tree. And looking at the history to distinguish them is not
6028 # useful because the user might have made a confusing-looking git
6029 # history structure (which ought to produce an error if dgit can't
6030 # cope, not a silent reintroduction of an unwanted patch).
6032 # So gbp users will have to pass an option. But we can usually
6033 # detect their failure to do so: if the tree is not a clean
6034 # patches-applied tree, quilt linearisation fails, but the tree
6035 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6036 # they want --quilt=unapplied.
6038 # To help detect this, when we are extracting the fake dsc, we
6039 # first extract it with --skip-patches, and then apply the patches
6040 # afterwards with dpkg-source --before-build. That lets us save a
6041 # tree object corresponding to .origs.
6043 my $splitbrain_cachekey;
6045 quilt_make_fake_dsc($upstreamversion);
6047 if (quiltmode_splitbrain()) {
6049 ($cachehit, $splitbrain_cachekey) =
6050 quilt_check_splitbrain_cache($headref, $upstreamversion);
6051 return if $cachehit;
6053 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6057 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6059 if (system @bbcmd) {
6060 failedcmd @bbcmd if $? < 0;
6062 failed to apply your git tree's patch stack (from debian/patches/) to
6063 the corresponding upstream tarball(s). Your source tree and .orig
6064 are probably too inconsistent. dgit can only fix up certain kinds of
6065 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6071 unpack_playtree_mkwork($headref);
6074 if (stat_exists ".pc") {
6076 progress __ "Tree already contains .pc - will use it then delete it.";
6079 rename '../fake/.pc','.pc' or confess $!;
6082 changedir '../fake';
6084 my $oldtiptree=git_add_write_tree();
6085 printdebug "fake o+d/p tree object $unapplied\n";
6086 changedir '../work';
6089 # We calculate some guesswork now about what kind of tree this might
6090 # be. This is mostly for error reporting.
6096 # O = orig, without patches applied
6097 # A = "applied", ie orig with H's debian/patches applied
6098 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6099 \%editedignores, \@unrepres),
6100 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6101 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6105 foreach my $b (qw(01 02)) {
6106 foreach my $v (qw(O2H O2A H2A)) {
6107 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
6110 printdebug "differences \@dl @dl.\n";
6113 "%s: base trees orig=%.20s o+d/p=%.20s",
6114 $us, $unapplied, $oldtiptree;
6116 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6117 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6118 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6119 $us, $dl[2], $dl[5];
6122 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6125 forceable_fail [qw(unrepresentable)], __ <<END;
6126 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6131 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6132 push @failsuggestion, [ 'unapplied', __
6133 "This might be a patches-unapplied branch." ];
6134 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6135 push @failsuggestion, [ 'applied', __
6136 "This might be a patches-applied branch." ];
6138 push @failsuggestion, [ 'quilt-mode', __
6139 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6141 push @failsuggestion, [ 'gitattrs', __
6142 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6143 if stat_exists '.gitattributes';
6145 push @failsuggestion, [ 'origs', __
6146 "Maybe orig tarball(s) are not identical to git representation?" ];
6148 if (quiltmode_splitbrain()) {
6149 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6150 $diffbits, \%editedignores,
6151 $splitbrain_cachekey);
6155 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6156 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6158 if (!open P, '>>', ".pc/applied-patches") {
6159 $!==&ENOENT or confess $!;
6164 commit_quilty_patch();
6166 if ($mustdeletepc) {
6167 quilt_fixup_delete_pc();
6171 sub quilt_fixup_editor () {
6172 my $descfn = $ENV{$fakeeditorenv};
6173 my $editing = $ARGV[$#ARGV];
6174 open I1, '<', $descfn or confess "$descfn: $!";
6175 open I2, '<', $editing or confess "$editing: $!";
6176 unlink $editing or confess "$editing: $!";
6177 open O, '>', $editing or confess "$editing: $!";
6178 while (<I1>) { print O or confess $!; } I1->error and confess $!;
6181 $copying ||= m/^\-\-\- /;
6182 next unless $copying;
6183 print O or confess $!;
6185 I2->error and confess $!;
6190 sub maybe_apply_patches_dirtily () {
6191 return unless $quilt_mode =~ m/gbp|unapplied/;
6192 print STDERR __ <<END or confess $!;
6194 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6195 dgit: Have to apply the patches - making the tree dirty.
6196 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6199 $patches_applied_dirtily = 01;
6200 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6201 runcmd qw(dpkg-source --before-build .);
6204 sub maybe_unapply_patches_again () {
6205 progress __ "dgit: Unapplying patches again to tidy up the tree."
6206 if $patches_applied_dirtily;
6207 runcmd qw(dpkg-source --after-build .)
6208 if $patches_applied_dirtily & 01;
6210 if $patches_applied_dirtily & 02;
6211 $patches_applied_dirtily = 0;
6214 #----- other building -----
6216 sub clean_tree_check_git ($$) {
6217 my ($honour_ignores, $message) = @_;
6218 my @cmd = (@git, qw(clean -dn));
6219 push @cmd, qw(-x) unless $honour_ignores;
6220 my $leftovers = cmdoutput @cmd;
6221 if (length $leftovers) {
6222 print STDERR $leftovers, "\n" or confess $!;
6227 sub clean_tree_check_git_wd ($) {
6229 return if $cleanmode =~ m{no-check};
6230 return if $patches_applied_dirtily; # yuk
6231 clean_tree_check_git +($cleanmode !~ m{all-check}),
6232 (f_ <<END, $message);
6234 If this is just missing .gitignore entries, use a different clean
6235 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6236 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6240 sub clean_tree_check () {
6241 # Not yet fully implemented.
6242 # This function needs to not care about modified but tracked files.
6243 # That was done by check_not_dirty, and by now we may have run
6244 # the rules clean target which might modify tracked files (!)
6245 if ($cleanmode =~ m{^check}) {
6246 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6247 "tree contains uncommitted files and --clean=check specified";
6248 } elsif ($cleanmode =~ m{^dpkg-source}) {
6249 clean_tree_check_git_wd __
6250 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6251 } elsif ($cleanmode =~ m{^git}) {
6252 # If we were actually cleaning these files would be summarily
6253 # deleted. Since we're not, and not using the working tree
6254 # anyway, we can just ignore them - nothing will use them.
6255 } elsif ($cleanmode eq 'none') {
6257 confess "$cleanmode ?";
6262 # We always clean the tree ourselves, rather than leave it to the
6263 # builder (dpkg-source, or soemthing which calls dpkg-source).
6264 if ($cleanmode =~ m{^dpkg-source}) {
6265 my @cmd = @dpkgbuildpackage;
6266 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6267 push @cmd, qw(-T clean);
6268 maybe_apply_patches_dirtily();
6269 runcmd_ordryrun_local @cmd;
6270 clean_tree_check_git_wd __
6271 "tree contains uncommitted files (after running rules clean)";
6272 } elsif ($cleanmode eq 'git') {
6273 runcmd_ordryrun_local @git, qw(clean -xdf);
6274 } elsif ($cleanmode eq 'git-ff') {
6275 runcmd_ordryrun_local @git, qw(clean -xdff);
6276 } elsif ($cleanmode =~ m{^check}) {
6278 } elsif ($cleanmode eq 'none') {
6280 confess "$cleanmode ?";
6285 badusage __ "clean takes no additional arguments" if @ARGV;
6288 maybe_unapply_patches_again();
6291 # return values from massage_dbp_args are one or both of these flags
6292 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6293 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6295 sub build_or_push_prep_early () {
6296 our $build_or_push_prep_early_done //= 0;
6297 return if $build_or_push_prep_early_done++;
6298 badusage f_ "-p is not allowed with dgit %s", $subcommand
6299 if defined $package;
6300 my $clogp = parsechangelog();
6301 $isuite = getfield $clogp, 'Distribution';
6302 $package = getfield $clogp, 'Source';
6303 $version = getfield $clogp, 'Version';
6304 $dscfn = dscfn($version);
6307 sub build_prep_early () {
6308 build_or_push_prep_early();
6313 sub build_prep ($) {
6317 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)) {
6318 # Clean the tree because we're going to use the contents of
6319 # $maindir. (We trying to include dirty changes in the source
6320 # package, or we are running the builder in $maindir.)
6323 # We don't actually need to do anything in $maindir, but we
6324 # should do some kind of cleanliness check because (i) the
6325 # user may have forgotten a `git add', and (ii) if the user
6326 # said -wc we should still do the check.
6329 build_maybe_quilt_fixup();
6331 my $pat = changespat $version;
6332 foreach my $f (glob "$buildproductsdir/$pat") {
6335 fail f_ "remove old changes file %s: %s", $f, $!;
6337 progress f_ "would remove %s", $f;
6343 sub changesopts_initial () {
6344 my @opts =@changesopts[1..$#changesopts];
6347 sub changesopts_version () {
6348 if (!defined $changes_since_version) {
6351 @vsns = archive_query('archive_query');
6352 my @quirk = access_quirk();
6353 if ($quirk[0] eq 'backports') {
6354 local $isuite = $quirk[2];
6356 canonicalise_suite();
6357 push @vsns, archive_query('archive_query');
6363 "archive query failed (queried because --since-version not specified)";
6366 @vsns = map { $_->[0] } @vsns;
6367 @vsns = sort { -version_compare($a, $b) } @vsns;
6368 $changes_since_version = $vsns[0];
6369 progress f_ "changelog will contain changes since %s", $vsns[0];
6371 $changes_since_version = '_';
6372 progress __ "package seems new, not specifying -v<version>";
6375 if ($changes_since_version ne '_') {
6376 return ("-v$changes_since_version");
6382 sub changesopts () {
6383 return (changesopts_initial(), changesopts_version());
6386 sub massage_dbp_args ($;$) {
6387 my ($cmd,$xargs) = @_;
6388 # Since we split the source build out so we can do strange things
6389 # to it, massage the arguments to dpkg-buildpackage so that the
6390 # main build doessn't build source (or add an argument to stop it
6391 # building source by default).
6392 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6393 # -nc has the side effect of specifying -b if nothing else specified
6394 # and some combinations of -S, -b, et al, are errors, rather than
6395 # later simply overriding earlie. So we need to:
6396 # - search the command line for these options
6397 # - pick the last one
6398 # - perhaps add our own as a default
6399 # - perhaps adjust it to the corresponding non-source-building version
6401 foreach my $l ($cmd, $xargs) {
6403 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6406 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6407 my $r = WANTSRC_BUILDER;
6408 printdebug "massage split $dmode.\n";
6409 if ($dmode =~ s/^--build=//) {
6411 my @d = split /,/, $dmode;
6412 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6413 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6414 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6415 fail __ "Wanted to build nothing!" unless $r;
6416 $dmode = '--build='. join ',', grep m/./, @d;
6419 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6420 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6421 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6424 printdebug "massage done $r $dmode.\n";
6426 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6432 my $wasdir = must_getcwd();
6433 changedir $buildproductsdir;
6438 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6439 sub postbuild_mergechanges ($) {
6440 my ($msg_if_onlyone) = @_;
6441 # If there is only one .changes file, fail with $msg_if_onlyone,
6442 # or if that is undef, be a no-op.
6443 # Returns the changes file to report to the user.
6444 my $pat = changespat $version;
6445 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6446 @changesfiles = sort {
6447 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6451 if (@changesfiles==1) {
6452 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6453 only one changes file from build (%s)
6455 if defined $msg_if_onlyone;
6456 $result = $changesfiles[0];
6457 } elsif (@changesfiles==2) {
6458 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6459 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6460 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6463 runcmd_ordryrun_local @mergechanges, @changesfiles;
6464 my $multichanges = changespat $version,'multi';
6466 stat_exists $multichanges or fail f_
6467 "%s unexpectedly not created by build", $multichanges;
6468 foreach my $cf (glob $pat) {
6469 next if $cf eq $multichanges;
6470 rename "$cf", "$cf.inmulti" or fail f_
6471 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6474 $result = $multichanges;
6476 fail f_ "wrong number of different changes files (%s)",
6479 printdone f_ "build successful, results in %s\n", $result
6483 sub midbuild_checkchanges () {
6484 my $pat = changespat $version;
6485 return if $rmchanges;
6486 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6488 $_ ne changespat $version,'source' and
6489 $_ ne changespat $version,'multi'
6491 fail +(f_ <<END, $pat, "@unwanted")
6492 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6493 Suggest you delete %s.
6498 sub midbuild_checkchanges_vanilla ($) {
6500 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6503 sub postbuild_mergechanges_vanilla ($) {
6505 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6507 postbuild_mergechanges(undef);
6510 printdone __ "build successful\n";
6516 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6517 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6518 %s: warning: build-products-dir will be ignored; files will go to ..
6520 $buildproductsdir = '..';
6521 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6522 my $wantsrc = massage_dbp_args \@dbp;
6523 build_prep($wantsrc);
6524 if ($wantsrc & WANTSRC_SOURCE) {
6526 midbuild_checkchanges_vanilla $wantsrc;
6528 if ($wantsrc & WANTSRC_BUILDER) {
6529 push @dbp, changesopts_version();
6530 maybe_apply_patches_dirtily();
6531 runcmd_ordryrun_local @dbp;
6533 maybe_unapply_patches_again();
6534 postbuild_mergechanges_vanilla $wantsrc;
6538 $quilt_mode //= 'gbp';
6544 # gbp can make .origs out of thin air. In my tests it does this
6545 # even for a 1.0 format package, with no origs present. So I
6546 # guess it keys off just the version number. We don't know
6547 # exactly what .origs ought to exist, but let's assume that we
6548 # should run gbp if: the version has an upstream part and the main
6550 my $upstreamversion = upstreamversion $version;
6551 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6552 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6554 if ($gbp_make_orig) {
6556 $cleanmode = 'none'; # don't do it again
6559 my @dbp = @dpkgbuildpackage;
6561 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6563 if (!length $gbp_build[0]) {
6564 if (length executable_on_path('git-buildpackage')) {
6565 $gbp_build[0] = qw(git-buildpackage);
6567 $gbp_build[0] = 'gbp buildpackage';
6570 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6572 push @cmd, (qw(-us -uc --git-no-sign-tags),
6573 "--git-builder=".(shellquote @dbp));
6575 if ($gbp_make_orig) {
6576 my $priv = dgit_privdir();
6577 my $ok = "$priv/origs-gen-ok";
6578 unlink $ok or $!==&ENOENT or confess $!;
6579 my @origs_cmd = @cmd;
6580 push @origs_cmd, qw(--git-cleaner=true);
6581 push @origs_cmd, "--git-prebuild=".
6582 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6583 push @origs_cmd, @ARGV;
6585 debugcmd @origs_cmd;
6587 do { local $!; stat_exists $ok; }
6588 or failedcmd @origs_cmd;
6590 dryrun_report @origs_cmd;
6594 build_prep($wantsrc);
6595 if ($wantsrc & WANTSRC_SOURCE) {
6597 midbuild_checkchanges_vanilla $wantsrc;
6599 push @cmd, '--git-cleaner=true';
6601 maybe_unapply_patches_again();
6602 if ($wantsrc & WANTSRC_BUILDER) {
6603 push @cmd, changesopts();
6604 runcmd_ordryrun_local @cmd, @ARGV;
6606 postbuild_mergechanges_vanilla $wantsrc;
6608 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6610 sub building_source_in_playtree {
6611 # If $includedirty, we have to build the source package from the
6612 # working tree, not a playtree, so that uncommitted changes are
6613 # included (copying or hardlinking them into the playtree could
6616 # Note that if we are building a source package in split brain
6617 # mode we do not support including uncommitted changes, because
6618 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6619 # building a source package)) => !$includedirty
6620 return !$includedirty;
6624 $sourcechanges = changespat $version,'source';
6626 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6627 or fail f_ "remove %s: %s", $sourcechanges, $!;
6629 my @cmd = (@dpkgsource, qw(-b --));
6631 if (building_source_in_playtree()) {
6633 my $headref = git_rev_parse('HEAD');
6634 # If we are in split brain, there is already a playtree with
6635 # the thing we should package into a .dsc (thanks to quilt
6636 # fixup). If not, make a playtree
6637 prep_ud() unless $split_brain;
6638 changedir $playground;
6639 unless ($split_brain) {
6640 my $upstreamversion = upstreamversion $version;
6641 unpack_playtree_linkorigs($upstreamversion, sub { });
6642 unpack_playtree_mkwork($headref);
6646 $leafdir = basename $maindir;
6648 if ($buildproductsdir ne '..') {
6649 # Well, we are going to run dpkg-source -b which consumes
6650 # origs from .. and generates output there. To make this
6651 # work when the bpd is not .. , we would have to (i) link
6652 # origs from bpd to .. , (ii) check for files that
6653 # dpkg-source -b would/might overwrite, and afterwards
6654 # (iii) move all the outputs back to the bpd (iv) except
6655 # for the origs which should be deleted from .. if they
6656 # weren't there beforehand. And if there is an error and
6657 # we don't run to completion we would necessarily leave a
6658 # mess. This is too much. The real way to fix this
6659 # is for dpkg-source to have bpd support.
6660 confess unless $includedirty;
6662 "--include-dirty not supported with --build-products-dir, sorry";
6667 runcmd_ordryrun_local @cmd, $leafdir;
6670 runcmd_ordryrun_local qw(sh -ec),
6671 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6672 @dpkggenchanges, qw(-S), changesopts();
6675 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6676 $dsc = parsecontrol($dscfn, "source package");
6680 printdebug " renaming ($why) $l\n";
6681 rename_link_xf 0, "$l", bpd_abs()."/$l"
6682 or fail f_ "put in place new built file (%s): %s", $l, $@;
6684 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6685 $l =~ m/\S+$/ or next;
6688 $mv->('dsc', $dscfn);
6689 $mv->('changes', $sourcechanges);
6694 sub cmd_build_source {
6695 badusage __ "build-source takes no additional arguments" if @ARGV;
6696 build_prep(WANTSRC_SOURCE);
6698 maybe_unapply_patches_again();
6699 printdone f_ "source built, results in %s and %s",
6700 $dscfn, $sourcechanges;
6703 sub cmd_push_source {
6706 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6707 "sense with push-source!"
6709 build_maybe_quilt_fixup();
6711 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6712 __ "source changes file");
6713 unless (test_source_only_changes($changes)) {
6714 fail __ "user-specified changes file is not source-only";
6717 # Building a source package is very fast, so just do it
6719 confess "er, patches are applied dirtily but shouldn't be.."
6720 if $patches_applied_dirtily;
6721 $changesfile = $sourcechanges;
6726 sub binary_builder {
6727 my ($bbuilder, $pbmc_msg, @args) = @_;
6728 build_prep(WANTSRC_SOURCE);
6730 midbuild_checkchanges();
6733 stat_exists $dscfn or fail f_
6734 "%s (in build products dir): %s", $dscfn, $!;
6735 stat_exists $sourcechanges or fail f_
6736 "%s (in build products dir): %s", $sourcechanges, $!;
6738 runcmd_ordryrun_local @$bbuilder, @args;
6740 maybe_unapply_patches_again();
6742 postbuild_mergechanges($pbmc_msg);
6748 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6749 perhaps you need to pass -A ? (sbuild's default is to build only
6750 arch-specific binaries; dgit 1.4 used to override that.)
6755 my ($pbuilder) = @_;
6757 # @ARGV is allowed to contain only things that should be passed to
6758 # pbuilder under debbuildopts; just massage those
6759 my $wantsrc = massage_dbp_args \@ARGV;
6761 "you asked for a builder but your debbuildopts didn't ask for".
6762 " any binaries -- is this really what you meant?"
6763 unless $wantsrc & WANTSRC_BUILDER;
6765 "we must build a .dsc to pass to the builder but your debbuiltopts".
6766 " forbids the building of a source package; cannot continue"
6767 unless $wantsrc & WANTSRC_SOURCE;
6768 # We do not want to include the verb "build" in @pbuilder because
6769 # the user can customise @pbuilder and they shouldn't be required
6770 # to include "build" in their customised value. However, if the
6771 # user passes any additional args to pbuilder using the dgit
6772 # option --pbuilder:foo, such args need to come after the "build"
6773 # verb. opts_opt_multi_cmd does all of that.
6774 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6775 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6780 pbuilder(\@pbuilder);
6783 sub cmd_cowbuilder {
6784 pbuilder(\@cowbuilder);
6787 sub cmd_quilt_fixup {
6788 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6791 build_maybe_quilt_fixup();
6794 sub cmd_print_unapplied_treeish {
6795 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6797 my $headref = git_rev_parse('HEAD');
6798 my $clogp = commit_getclogp $headref;
6799 $package = getfield $clogp, 'Source';
6800 $version = getfield $clogp, 'Version';
6801 $isuite = getfield $clogp, 'Distribution';
6802 $csuite = $isuite; # we want this to be offline!
6806 changedir $playground;
6807 my $uv = upstreamversion $version;
6808 quilt_make_fake_dsc($uv);
6809 my $u = quilt_fakedsc2unapplied($headref, $uv);
6810 print $u, "\n" or confess $!;
6813 sub import_dsc_result {
6814 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6815 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6817 check_gitattrs($newhash, __ "source tree");
6819 progress f_ "dgit: import-dsc: %s", $what_msg;
6822 sub cmd_import_dsc {
6826 last unless $ARGV[0] =~ m/^-/;
6829 if (m/^--require-valid-signature$/) {
6832 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6836 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6838 my ($dscfn, $dstbranch) = @ARGV;
6840 badusage __ "dry run makes no sense with import-dsc"
6843 my $force = $dstbranch =~ s/^\+// ? +1 :
6844 $dstbranch =~ s/^\.\.// ? -1 :
6846 my $info = $force ? " $&" : '';
6847 $info = "$dscfn$info";
6849 my $specbranch = $dstbranch;
6850 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6851 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6853 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6854 my $chead = cmdoutput_errok @symcmd;
6855 defined $chead or $?==256 or failedcmd @symcmd;
6857 fail f_ "%s is checked out - will not update it", $dstbranch
6858 if defined $chead and $chead eq $dstbranch;
6860 my $oldhash = git_get_ref $dstbranch;
6862 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6863 $dscdata = do { local $/ = undef; <D>; };
6864 D->error and fail f_ "read %s: %s", $dscfn, $!;
6867 # we don't normally need this so import it here
6868 use Dpkg::Source::Package;
6869 my $dp = new Dpkg::Source::Package filename => $dscfn,
6870 require_valid_signature => $needsig;
6872 local $SIG{__WARN__} = sub {
6874 return unless $needsig;
6875 fail __ "import-dsc signature check failed";
6877 if (!$dp->is_signed()) {
6878 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6880 my $r = $dp->check_signature();
6881 confess "->check_signature => $r" if $needsig && $r;
6887 $package = getfield $dsc, 'Source';
6889 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6890 unless forceing [qw(import-dsc-with-dgit-field)];
6891 parse_dsc_field_def_dsc_distro();
6893 $isuite = 'DGIT-IMPORT-DSC';
6894 $idistro //= $dsc_distro;
6898 if (defined $dsc_hash) {
6900 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6901 resolve_dsc_field_commit undef, undef;
6903 if (defined $dsc_hash) {
6904 my @cmd = (qw(sh -ec),
6905 "echo $dsc_hash | git cat-file --batch-check");
6906 my $objgot = cmdoutput @cmd;
6907 if ($objgot =~ m#^\w+ missing\b#) {
6908 fail f_ <<END, $dsc_hash
6909 .dsc contains Dgit field referring to object %s
6910 Your git tree does not have that object. Try `git fetch' from a
6911 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6914 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6916 progress __ "Not fast forward, forced update.";
6918 fail f_ "Not fast forward to %s", $dsc_hash;
6921 import_dsc_result $dstbranch, $dsc_hash,
6922 "dgit import-dsc (Dgit): $info",
6923 f_ "updated git ref %s", $dstbranch;
6927 fail f_ <<END, $dstbranch, $specbranch, $specbranch
6928 Branch %s already exists
6929 Specify ..%s for a pseudo-merge, binding in existing history
6930 Specify +%s to overwrite, discarding existing history
6932 if $oldhash && !$force;
6934 my @dfi = dsc_files_info();
6935 foreach my $fi (@dfi) {
6936 my $f = $fi->{Filename};
6937 my $here = "$buildproductsdir/$f";
6940 fail f_ "lstat %s works but stat gives %s !", $here, $!;
6942 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
6944 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6946 } elsif ($dscfn =~ m#^/#) {
6950 "cannot import %s which seems to be inside working tree!",
6953 $there =~ s#/+[^/]+$## or fail f_
6954 "import %s requires .../%s, but it does not exist",
6957 my $test = $there =~ m{^/} ? $there : "../$there";
6958 stat $test or fail f_
6959 "import %s requires %s, but: %s", $dscfn, $test, $!;
6960 symlink $there, $here or fail f_
6961 "symlink %s to %s: %s", $there, $here, $!;
6962 progress f_ "made symlink %s -> %s", $here, $there;
6963 # print STDERR Dumper($fi);
6965 my @mergeinputs = generate_commits_from_dsc();
6966 die unless @mergeinputs == 1;
6968 my $newhash = $mergeinputs[0]{Commit};
6973 "Import, forced update - synthetic orphan git history.";
6974 } elsif ($force < 0) {
6975 progress __ "Import, merging.";
6976 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6977 my $version = getfield $dsc, 'Version';
6978 my $clogp = commit_getclogp $newhash;
6979 my $authline = clogp_authline $clogp;
6980 $newhash = make_commit_text <<ENDU
6988 .(f_ <<END, $package, $version, $dstbranch);
6989 Merge %s (%s) import into %s
6992 die; # caught earlier
6996 import_dsc_result $dstbranch, $newhash,
6997 "dgit import-dsc: $info",
6998 f_ "results are in git ref %s", $dstbranch;
7001 sub pre_archive_api_query () {
7002 not_necessarily_a_tree();
7004 sub cmd_archive_api_query {
7005 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7006 my ($subpath) = @ARGV;
7007 local $isuite = 'DGIT-API-QUERY-CMD';
7008 my @cmd = archive_api_query_cmd($subpath);
7011 exec @cmd or fail f_ "exec curl: %s\n", $!;
7014 sub repos_server_url () {
7015 $package = '_dgit-repos-server';
7016 local $access_forpush = 1;
7017 local $isuite = 'DGIT-REPOS-SERVER';
7018 my $url = access_giturl();
7021 sub pre_clone_dgit_repos_server () {
7022 not_necessarily_a_tree();
7024 sub cmd_clone_dgit_repos_server {
7025 badusage __ "need destination argument" unless @ARGV==1;
7026 my ($destdir) = @ARGV;
7027 my $url = repos_server_url();
7028 my @cmd = (@git, qw(clone), $url, $destdir);
7030 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7033 sub pre_print_dgit_repos_server_source_url () {
7034 not_necessarily_a_tree();
7036 sub cmd_print_dgit_repos_server_source_url {
7038 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7040 my $url = repos_server_url();
7041 print $url, "\n" or confess $!;
7044 sub pre_print_dpkg_source_ignores {
7045 not_necessarily_a_tree();
7047 sub cmd_print_dpkg_source_ignores {
7049 "no arguments allowed to dgit print-dpkg-source-ignores"
7051 print "@dpkg_source_ignores\n" or confess $!;
7054 sub cmd_setup_mergechangelogs {
7055 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7057 local $isuite = 'DGIT-SETUP-TREE';
7058 setup_mergechangelogs(1);
7061 sub cmd_setup_useremail {
7062 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7063 local $isuite = 'DGIT-SETUP-TREE';
7067 sub cmd_setup_gitattributes {
7068 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7069 local $isuite = 'DGIT-SETUP-TREE';
7073 sub cmd_setup_new_tree {
7074 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7075 local $isuite = 'DGIT-SETUP-TREE';
7079 #---------- argument parsing and main program ----------
7082 print "dgit version $our_version\n" or confess $!;
7086 our (%valopts_long, %valopts_short);
7087 our (%funcopts_long);
7089 our (@modeopt_cfgs);
7091 sub defvalopt ($$$$) {
7092 my ($long,$short,$val_re,$how) = @_;
7093 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7094 $valopts_long{$long} = $oi;
7095 $valopts_short{$short} = $oi;
7096 # $how subref should:
7097 # do whatever assignemnt or thing it likes with $_[0]
7098 # if the option should not be passed on to remote, @rvalopts=()
7099 # or $how can be a scalar ref, meaning simply assign the value
7102 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7103 defvalopt '--distro', '-d', '.+', \$idistro;
7104 defvalopt '', '-k', '.+', \$keyid;
7105 defvalopt '--existing-package','', '.*', \$existing_package;
7106 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7107 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7108 defvalopt '--package', '-p', $package_re, \$package;
7109 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7111 defvalopt '', '-C', '.+', sub {
7112 ($changesfile) = (@_);
7113 if ($changesfile =~ s#^(.*)/##) {
7114 $buildproductsdir = $1;
7118 defvalopt '--initiator-tempdir','','.*', sub {
7119 ($initiator_tempdir) = (@_);
7120 $initiator_tempdir =~ m#^/# or
7121 badusage __ "--initiator-tempdir must be used specify an".
7122 " absolute, not relative, directory."
7125 sub defoptmodes ($@) {
7126 my ($varref, $cfgkey, $default, %optmap) = @_;
7128 while (my ($opt,$val) = each %optmap) {
7129 $funcopts_long{$opt} = sub { $$varref = $val; };
7130 $permit{$val} = $val;
7132 push @modeopt_cfgs, {
7135 Default => $default,
7140 defoptmodes \$dodep14tag, qw( dep14tag want
7143 --always-dep14tag always );
7148 if (defined $ENV{'DGIT_SSH'}) {
7149 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7150 } elsif (defined $ENV{'GIT_SSH'}) {
7151 @ssh = ($ENV{'GIT_SSH'});
7159 if (!defined $val) {
7160 badusage f_ "%s needs a value", $what unless @ARGV;
7162 push @rvalopts, $val;
7164 badusage f_ "bad value \`%s' for %s", $val, $what unless
7165 $val =~ m/^$oi->{Re}$(?!\n)/s;
7166 my $how = $oi->{How};
7167 if (ref($how) eq 'SCALAR') {
7172 push @ropts, @rvalopts;
7176 last unless $ARGV[0] =~ m/^-/;
7180 if (m/^--dry-run$/) {
7183 } elsif (m/^--damp-run$/) {
7186 } elsif (m/^--no-sign$/) {
7189 } elsif (m/^--help$/) {
7191 } elsif (m/^--version$/) {
7193 } elsif (m/^--new$/) {
7196 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7197 ($om = $opts_opt_map{$1}) &&
7201 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7202 !$opts_opt_cmdonly{$1} &&
7203 ($om = $opts_opt_map{$1})) {
7206 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7207 !$opts_opt_cmdonly{$1} &&
7208 ($om = $opts_opt_map{$1})) {
7210 my $cmd = shift @$om;
7211 @$om = ($cmd, grep { $_ ne $2 } @$om);
7212 } elsif (m/^--(gbp|dpm)$/s) {
7213 push @ropts, "--quilt=$1";
7215 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7218 } elsif (m/^--no-quilt-fixup$/s) {
7220 $quilt_mode = 'nocheck';
7221 } elsif (m/^--no-rm-on-error$/s) {
7224 } elsif (m/^--no-chase-dsc-distro$/s) {
7226 $chase_dsc_distro = 0;
7227 } elsif (m/^--overwrite$/s) {
7229 $overwrite_version = '';
7230 } elsif (m/^--overwrite=(.+)$/s) {
7232 $overwrite_version = $1;
7233 } elsif (m/^--delayed=(\d+)$/s) {
7236 } elsif (my ($k,$v) =
7237 m/^--save-(dgit-view)=(.+)$/s ||
7238 m/^--(dgit-view)-save=(.+)$/s
7241 $v =~ s#^(?!refs/)#refs/heads/#;
7242 $internal_object_save{$k} = $v;
7243 } elsif (m/^--(no-)?rm-old-changes$/s) {
7246 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7248 push @deliberatelies, $&;
7249 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7253 } elsif (m/^--force-/) {
7255 f_ "%s: warning: ignoring unknown force option %s\n",
7258 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7259 # undocumented, for testing
7261 $tagformat_want = [ $1, 'command line', 1 ];
7262 # 1 menas overrides distro configuration
7263 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7264 # undocumented, for testing
7266 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7267 # ^ it's supposed to be an array ref
7268 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7269 $val = $2 ? $' : undef; #';
7270 $valopt->($oi->{Long});
7271 } elsif ($funcopts_long{$_}) {
7273 $funcopts_long{$_}();
7275 badusage f_ "unknown long option \`%s'", $_;
7282 } elsif (s/^-L/-/) {
7285 } elsif (s/^-h/-/) {
7287 } elsif (s/^-D/-/) {
7291 } elsif (s/^-N/-/) {
7296 push @changesopts, $_;
7298 } elsif (s/^-wn$//s) {
7300 $cleanmode = 'none';
7301 } elsif (s/^-wg$//s) {
7304 } elsif (s/^-wgf$//s) {
7306 $cleanmode = 'git-ff';
7307 } elsif (s/^-wd(d?)([na]?)$//s) {
7309 $cleanmode = 'dpkg-source';
7310 $cleanmode .= '-d' if $1;
7311 $cleanmode .= ',no-check' if $2 eq 'n';
7312 $cleanmode .= ',all-check' if $2 eq 'a';
7313 } elsif (s/^-wc$//s) {
7315 $cleanmode = 'check';
7316 } elsif (s/^-wci$//s) {
7318 $cleanmode = 'check,ignores';
7319 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7320 push @git, '-c', $&;
7321 $gitcfgs{cmdline}{$1} = [ $2 ];
7322 } elsif (s/^-c([^=]+)$//s) {
7323 push @git, '-c', $&;
7324 $gitcfgs{cmdline}{$1} = [ 'true' ];
7325 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7327 $val = undef unless length $val;
7328 $valopt->($oi->{Short});
7331 badusage f_ "unknown short option \`%s'", $_;
7338 sub check_env_sanity () {
7339 my $blocked = new POSIX::SigSet;
7340 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
7343 foreach my $name (qw(PIPE CHLD)) {
7344 my $signame = "SIG$name";
7345 my $signum = eval "POSIX::$signame" // die;
7346 die f_ "%s is set to something other than SIG_DFL\n",
7348 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7349 $blocked->ismember($signum) and
7350 die f_ "%s is blocked\n", $signame;
7356 On entry to dgit, %s
7357 This is a bug produced by something in your execution environment.
7363 sub parseopts_late_defaults () {
7364 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7365 if defined $idistro;
7366 $isuite //= cfg('dgit.default.default-suite');
7368 foreach my $k (keys %opts_opt_map) {
7369 my $om = $opts_opt_map{$k};
7371 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7373 badcfg f_ "cannot set command for %s", $k
7374 unless length $om->[0];
7378 foreach my $c (access_cfg_cfgs("opts-$k")) {
7380 map { $_ ? @$_ : () }
7381 map { $gitcfgs{$_}{$c} }
7382 reverse @gitcfgsources;
7383 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7384 "\n" if $debuglevel >= 4;
7386 badcfg f_ "cannot configure options for %s", $k
7387 if $opts_opt_cmdonly{$k};
7388 my $insertpos = $opts_cfg_insertpos{$k};
7389 @$om = ( @$om[0..$insertpos-1],
7391 @$om[$insertpos..$#$om] );
7395 if (!defined $rmchanges) {
7396 local $access_forpush;
7397 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7400 if (!defined $quilt_mode) {
7401 local $access_forpush;
7402 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7403 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7405 $quilt_mode =~ m/^($quilt_modes_re)$/
7406 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7410 foreach my $moc (@modeopt_cfgs) {
7411 local $access_forpush;
7412 my $vr = $moc->{Var};
7413 next if defined $$vr;
7414 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7415 my $v = $moc->{Vals}{$$vr};
7416 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7421 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7422 if $split_brain && $includedirty;
7424 if (!defined $cleanmode) {
7425 local $access_forpush;
7426 $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
7427 $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
7429 $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
7430 $cleanmode //= 'dpkg-source';
7432 badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7433 $cleanmode =~ m/$cleanmode_re/;
7436 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7437 $buildproductsdir //= '..';
7438 $bpd_glob = $buildproductsdir;
7439 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7442 setlocale(LC_MESSAGES, "");
7445 if ($ENV{$fakeeditorenv}) {
7447 quilt_fixup_editor();
7453 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7454 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7455 if $dryrun_level == 1;
7457 print STDERR __ $helpmsg or confess $!;
7460 $cmd = $subcommand = shift @ARGV;
7463 my $pre_fn = ${*::}{"pre_$cmd"};
7464 $pre_fn->() if $pre_fn;
7466 if ($invoked_in_git_tree) {
7467 changedir_git_toplevel();
7472 my $fn = ${*::}{"cmd_$cmd"};
7473 $fn or badusage f_ "unknown operation %s", $cmd;