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 generate_commits_from_dsc () {
2201 # See big comment in fetch_from_archive, below.
2202 # See also README.dsc-import.
2204 changedir $playground;
2206 my @dfi = dsc_files_info();
2207 foreach my $fi (@dfi) {
2208 my $f = $fi->{Filename};
2209 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2210 my $upper_f = (bpd_abs()."/$f");
2212 printdebug "considering reusing $f: ";
2214 if (link_ltarget "$upper_f,fetch", $f) {
2215 printdebug "linked (using ...,fetch).\n";
2216 } elsif ((printdebug "($!) "),
2218 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2219 } elsif (link_ltarget $upper_f, $f) {
2220 printdebug "linked.\n";
2221 } elsif ((printdebug "($!) "),
2223 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2225 printdebug "absent.\n";
2229 complete_file_from_dsc('.', $fi, \$refetched)
2232 printdebug "considering saving $f: ";
2234 if (rename_link_xf 1, $f, $upper_f) {
2235 printdebug "linked.\n";
2236 } elsif ((printdebug "($@) "),
2238 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2239 } elsif (!$refetched) {
2240 printdebug "no need.\n";
2241 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2242 printdebug "linked (using ...,fetch).\n";
2243 } elsif ((printdebug "($@) "),
2245 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2247 printdebug "cannot.\n";
2251 # We unpack and record the orig tarballs first, so that we only
2252 # need disk space for one private copy of the unpacked source.
2253 # But we can't make them into commits until we have the metadata
2254 # from the debian/changelog, so we record the tree objects now and
2255 # make them into commits later.
2257 my $upstreamv = upstreamversion $dsc->{version};
2258 my $orig_f_base = srcfn $upstreamv, '';
2260 foreach my $fi (@dfi) {
2261 # We actually import, and record as a commit, every tarball
2262 # (unless there is only one file, in which case there seems
2265 my $f = $fi->{Filename};
2266 printdebug "import considering $f ";
2267 (printdebug "only one dfi\n"), next if @dfi == 1;
2268 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2269 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2273 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2275 printdebug "Y ", (join ' ', map { $_//"(none)" }
2276 $compr_ext, $orig_f_part
2279 my $input = new IO::File $f, '<' or die "$f $!";
2283 if (defined $compr_ext) {
2285 Dpkg::Compression::compression_guess_from_filename $f;
2286 fail "Dpkg::Compression cannot handle file $f in source package"
2287 if defined $compr_ext && !defined $cname;
2289 new Dpkg::Compression::Process compression => $cname;
2290 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2291 my $compr_fh = new IO::Handle;
2292 my $compr_pid = open $compr_fh, "-|" // confess $!;
2294 open STDIN, "<&", $input or confess $!;
2296 die "dgit (child): exec $compr_cmd[0]: $!\n";
2301 rmtree "_unpack-tar";
2302 mkdir "_unpack-tar" or confess $!;
2303 my @tarcmd = qw(tar -x -f -
2304 --no-same-owner --no-same-permissions
2305 --no-acls --no-xattrs --no-selinux);
2306 my $tar_pid = fork // confess $!;
2308 chdir "_unpack-tar" or confess $!;
2309 open STDIN, "<&", $input or confess $!;
2311 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2313 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!;
2314 !$? or failedcmd @tarcmd;
2317 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2319 # finally, we have the results in "tarball", but maybe
2320 # with the wrong permissions
2322 runcmd qw(chmod -R +rwX _unpack-tar);
2323 changedir "_unpack-tar";
2324 remove_stray_gits($f);
2325 mktree_in_ud_here();
2327 my ($tree) = git_add_write_tree();
2328 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2329 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2331 printdebug "one subtree $1\n";
2333 printdebug "multiple subtrees\n";
2336 rmtree "_unpack-tar";
2338 my $ent = [ $f, $tree ];
2340 Orig => !!$orig_f_part,
2341 Sort => (!$orig_f_part ? 2 :
2342 $orig_f_part =~ m/-/g ? 1 :
2350 # put any without "_" first (spec is not clear whether files
2351 # are always in the usual order). Tarballs without "_" are
2352 # the main orig or the debian tarball.
2353 $a->{Sort} <=> $b->{Sort} or
2357 my $any_orig = grep { $_->{Orig} } @tartrees;
2359 my $dscfn = "$package.dsc";
2361 my $treeimporthow = 'package';
2363 open D, ">", $dscfn or die "$dscfn: $!";
2364 print D $dscdata or die "$dscfn: $!";
2365 close D or die "$dscfn: $!";
2366 my @cmd = qw(dpkg-source);
2367 push @cmd, '--no-check' if $dsc_checked;
2368 if (madformat $dsc->{format}) {
2369 push @cmd, '--skip-patches';
2370 $treeimporthow = 'unpatched';
2372 push @cmd, qw(-x --), $dscfn;
2375 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2376 if (madformat $dsc->{format}) {
2377 check_for_vendor_patches();
2381 if (madformat $dsc->{format}) {
2382 my @pcmd = qw(dpkg-source --before-build .);
2383 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2385 $dappliedtree = git_add_write_tree();
2388 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2392 printdebug "import clog search...\n";
2393 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2394 my ($thisstanza, $desc) = @_;
2395 no warnings qw(exiting);
2397 $clogp //= $thisstanza;
2399 printdebug "import clog $thisstanza->{version} $desc...\n";
2401 last if !$any_orig; # we don't need $r1clogp
2403 # We look for the first (most recent) changelog entry whose
2404 # version number is lower than the upstream version of this
2405 # package. Then the last (least recent) previous changelog
2406 # entry is treated as the one which introduced this upstream
2407 # version and used for the synthetic commits for the upstream
2410 # One might think that a more sophisticated algorithm would be
2411 # necessary. But: we do not want to scan the whole changelog
2412 # file. Stopping when we see an earlier version, which
2413 # necessarily then is an earlier upstream version, is the only
2414 # realistic way to do that. Then, either the earliest
2415 # changelog entry we have seen so far is indeed the earliest
2416 # upload of this upstream version; or there are only changelog
2417 # entries relating to later upstream versions (which is not
2418 # possible unless the changelog and .dsc disagree about the
2419 # version). Then it remains to choose between the physically
2420 # last entry in the file, and the one with the lowest version
2421 # number. If these are not the same, we guess that the
2422 # versions were created in a non-monotonic order rather than
2423 # that the changelog entries have been misordered.
2425 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2427 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2428 $r1clogp = $thisstanza;
2430 printdebug "import clog $r1clogp->{version} becomes r1\n";
2433 $clogp or fail __ "package changelog has no entries!";
2435 my $authline = clogp_authline $clogp;
2436 my $changes = getfield $clogp, 'Changes';
2437 $changes =~ s/^\n//; # Changes: \n
2438 my $cversion = getfield $clogp, 'Version';
2441 $r1clogp //= $clogp; # maybe there's only one entry;
2442 my $r1authline = clogp_authline $r1clogp;
2443 # Strictly, r1authline might now be wrong if it's going to be
2444 # unused because !$any_orig. Whatever.
2446 printdebug "import tartrees authline $authline\n";
2447 printdebug "import tartrees r1authline $r1authline\n";
2449 foreach my $tt (@tartrees) {
2450 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2452 my $mbody = f_ "Import %s", $tt->{F};
2453 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2456 committer $r1authline
2460 [dgit import orig $tt->{F}]
2468 [dgit import tarball $package $cversion $tt->{F}]
2473 printdebug "import main commit\n";
2475 open C, ">../commit.tmp" or confess $!;
2476 print C <<END or confess $!;
2479 print C <<END or confess $! foreach @tartrees;
2482 print C <<END or confess $!;
2488 [dgit import $treeimporthow $package $cversion]
2491 close C or confess $!;
2492 my $rawimport_hash = make_commit qw(../commit.tmp);
2494 if (madformat $dsc->{format}) {
2495 printdebug "import apply patches...\n";
2497 # regularise the state of the working tree so that
2498 # the checkout of $rawimport_hash works nicely.
2499 my $dappliedcommit = make_commit_text(<<END);
2506 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2508 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2510 # We need the answers to be reproducible
2511 my @authline = clogp_authline($clogp);
2512 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2513 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2514 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2515 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2516 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2517 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2519 my $path = $ENV{PATH} or die;
2521 # we use ../../gbp-pq-output, which (given that we are in
2522 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2525 foreach my $use_absurd (qw(0 1)) {
2526 runcmd @git, qw(checkout -q unpa);
2527 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2528 local $ENV{PATH} = $path;
2531 progress "warning: $@";
2532 $path = "$absurdity:$path";
2533 progress f_ "%s: trying slow absurd-git-apply...", $us;
2534 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2539 die "forbid absurd git-apply\n" if $use_absurd
2540 && forceing [qw(import-gitapply-no-absurd)];
2541 die "only absurd git-apply!\n" if !$use_absurd
2542 && forceing [qw(import-gitapply-absurd)];
2544 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2545 local $ENV{PATH} = $path if $use_absurd;
2547 my @showcmd = (gbp_pq, qw(import));
2548 my @realcmd = shell_cmd
2549 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2550 debugcmd "+",@realcmd;
2551 if (system @realcmd) {
2552 die f_ "%s failed: %s\n",
2553 +(shellquote @showcmd),
2554 failedcmd_waitstatus();
2557 my $gapplied = git_rev_parse('HEAD');
2558 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2559 $gappliedtree eq $dappliedtree or
2560 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2561 gbp-pq import and dpkg-source disagree!
2562 gbp-pq import gave commit %s
2563 gbp-pq import gave tree %s
2564 dpkg-source --before-build gave tree %s
2566 $rawimport_hash = $gapplied;
2571 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2576 progress f_ "synthesised git commit from .dsc %s", $cversion;
2578 my $rawimport_mergeinput = {
2579 Commit => $rawimport_hash,
2580 Info => __ "Import of source package",
2582 my @output = ($rawimport_mergeinput);
2584 if ($lastpush_mergeinput) {
2585 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2586 my $oversion = getfield $oldclogp, 'Version';
2588 version_compare($oversion, $cversion);
2590 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2591 { ReverseParents => 1,
2592 Message => (f_ <<END, $package, $cversion, $csuite) });
2593 Record %s (%s) in archive suite %s
2595 } elsif ($vcmp > 0) {
2596 print STDERR f_ <<END, $cversion, $oversion,
2598 Version actually in archive: %s (older)
2599 Last version pushed with dgit: %s (newer or same)
2602 __ $later_warning_msg or confess $!;
2603 @output = $lastpush_mergeinput;
2605 # Same version. Use what's in the server git branch,
2606 # discarding our own import. (This could happen if the
2607 # server automatically imports all packages into git.)
2608 @output = $lastpush_mergeinput;
2616 sub complete_file_from_dsc ($$;$) {
2617 our ($dstdir, $fi, $refetched) = @_;
2618 # Ensures that we have, in $dstdir, the file $fi, with the correct
2619 # contents. (Downloading it from alongside $dscurl if necessary.)
2620 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2621 # and will set $$refetched=1 if it did so (or tried to).
2623 my $f = $fi->{Filename};
2624 my $tf = "$dstdir/$f";
2628 my $checkhash = sub {
2629 open F, "<", "$tf" or die "$tf: $!";
2630 $fi->{Digester}->reset();
2631 $fi->{Digester}->addfile(*F);
2632 F->error and confess $!;
2633 $got = $fi->{Digester}->hexdigest();
2634 return $got eq $fi->{Hash};
2637 if (stat_exists $tf) {
2638 if ($checkhash->()) {
2639 progress f_ "using existing %s", $f;
2643 fail f_ "file %s has hash %s but .dsc demands hash %s".
2644 " (perhaps you should delete this file?)",
2645 $f, $got, $fi->{Hash};
2647 progress f_ "need to fetch correct version of %s", $f;
2648 unlink $tf or die "$tf $!";
2651 printdebug "$tf does not exist, need to fetch\n";
2655 $furl =~ s{/[^/]+$}{};
2657 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2658 die "$f ?" if $f =~ m#/#;
2659 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2660 return 0 if !act_local();
2663 fail f_ "file %s has hash %s but .dsc demands hash %s".
2664 " (got wrong file from archive!)",
2665 $f, $got, $fi->{Hash};
2670 sub ensure_we_have_orig () {
2671 my @dfi = dsc_files_info();
2672 foreach my $fi (@dfi) {
2673 my $f = $fi->{Filename};
2674 next unless is_orig_file_in_dsc($f, \@dfi);
2675 complete_file_from_dsc($buildproductsdir, $fi)
2680 #---------- git fetch ----------
2682 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2683 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2685 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2686 # locally fetched refs because they have unhelpful names and clutter
2687 # up gitk etc. So we track whether we have "used up" head ref (ie,
2688 # whether we have made another local ref which refers to this object).
2690 # (If we deleted them unconditionally, then we might end up
2691 # re-fetching the same git objects each time dgit fetch was run.)
2693 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2694 # in git_fetch_us to fetch the refs in question, and possibly a call
2695 # to lrfetchref_used.
2697 our (%lrfetchrefs_f, %lrfetchrefs_d);
2698 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2700 sub lrfetchref_used ($) {
2701 my ($fullrefname) = @_;
2702 my $objid = $lrfetchrefs_f{$fullrefname};
2703 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2706 sub git_lrfetch_sane {
2707 my ($url, $supplementary, @specs) = @_;
2708 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2709 # at least as regards @specs. Also leave the results in
2710 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2711 # able to clean these up.
2713 # With $supplementary==1, @specs must not contain wildcards
2714 # and we add to our previous fetches (non-atomically).
2716 # This is rather miserable:
2717 # When git fetch --prune is passed a fetchspec ending with a *,
2718 # it does a plausible thing. If there is no * then:
2719 # - it matches subpaths too, even if the supplied refspec
2720 # starts refs, and behaves completely madly if the source
2721 # has refs/refs/something. (See, for example, Debian #NNNN.)
2722 # - if there is no matching remote ref, it bombs out the whole
2724 # We want to fetch a fixed ref, and we don't know in advance
2725 # if it exists, so this is not suitable.
2727 # Our workaround is to use git ls-remote. git ls-remote has its
2728 # own qairks. Notably, it has the absurd multi-tail-matching
2729 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2730 # refs/refs/foo etc.
2732 # Also, we want an idempotent snapshot, but we have to make two
2733 # calls to the remote: one to git ls-remote and to git fetch. The
2734 # solution is use git ls-remote to obtain a target state, and
2735 # git fetch to try to generate it. If we don't manage to generate
2736 # the target state, we try again.
2738 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2740 my $specre = join '|', map {
2743 my $wildcard = $x =~ s/\\\*$/.*/;
2744 die if $wildcard && $supplementary;
2747 printdebug "git_lrfetch_sane specre=$specre\n";
2748 my $wanted_rref = sub {
2750 return m/^(?:$specre)$/;
2753 my $fetch_iteration = 0;
2756 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2757 if (++$fetch_iteration > 10) {
2758 fail __ "too many iterations trying to get sane fetch!";
2761 my @look = map { "refs/$_" } @specs;
2762 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2766 open GITLS, "-|", @lcmd or confess $!;
2768 printdebug "=> ", $_;
2769 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2770 my ($objid,$rrefname) = ($1,$2);
2771 if (!$wanted_rref->($rrefname)) {
2772 print STDERR f_ <<END, "@look", $rrefname;
2773 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2777 $wantr{$rrefname} = $objid;
2780 close GITLS or failedcmd @lcmd;
2782 # OK, now %want is exactly what we want for refs in @specs
2784 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2785 "+refs/$_:".lrfetchrefs."/$_";
2788 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2790 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2791 runcmd_ordryrun_local @fcmd if @fspecs;
2793 if (!$supplementary) {
2794 %lrfetchrefs_f = ();
2798 git_for_each_ref(lrfetchrefs, sub {
2799 my ($objid,$objtype,$lrefname,$reftail) = @_;
2800 $lrfetchrefs_f{$lrefname} = $objid;
2801 $objgot{$objid} = 1;
2804 if ($supplementary) {
2808 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2809 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2810 if (!exists $wantr{$rrefname}) {
2811 if ($wanted_rref->($rrefname)) {
2813 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2816 print STDERR f_ <<END, "@fspecs", $lrefname
2817 warning: git fetch %s created %s; this is silly, deleting it.
2820 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2821 delete $lrfetchrefs_f{$lrefname};
2825 foreach my $rrefname (sort keys %wantr) {
2826 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2827 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2828 my $want = $wantr{$rrefname};
2829 next if $got eq $want;
2830 if (!defined $objgot{$want}) {
2831 fail __ <<END unless act_local();
2832 --dry-run specified but we actually wanted the results of git fetch,
2833 so this is not going to work. Try running dgit fetch first,
2834 or using --damp-run instead of --dry-run.
2836 print STDERR f_ <<END, $lrefname, $want;
2837 warning: git ls-remote suggests we want %s
2838 warning: and it should refer to %s
2839 warning: but git fetch didn't fetch that object to any relevant ref.
2840 warning: This may be due to a race with someone updating the server.
2841 warning: Will try again...
2843 next FETCH_ITERATION;
2846 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2848 runcmd_ordryrun_local @git, qw(update-ref -m),
2849 "dgit fetch git fetch fixup", $lrefname, $want;
2850 $lrfetchrefs_f{$lrefname} = $want;
2855 if (defined $csuite) {
2856 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2857 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2858 my ($objid,$objtype,$lrefname,$reftail) = @_;
2859 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2860 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2864 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2865 Dumper(\%lrfetchrefs_f);
2868 sub git_fetch_us () {
2869 # Want to fetch only what we are going to use, unless
2870 # deliberately-not-ff, in which case we must fetch everything.
2872 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2874 (quiltmode_splitbrain
2875 ? (map { $_->('*',access_nomdistro) }
2876 \&debiantag_new, \&debiantag_maintview)
2877 : debiantags('*',access_nomdistro));
2878 push @specs, server_branch($csuite);
2879 push @specs, $rewritemap;
2880 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2882 my $url = access_giturl();
2883 git_lrfetch_sane $url, 0, @specs;
2886 my @tagpats = debiantags('*',access_nomdistro);
2888 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2889 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2890 printdebug "currently $fullrefname=$objid\n";
2891 $here{$fullrefname} = $objid;
2893 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2894 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2895 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2896 printdebug "offered $lref=$objid\n";
2897 if (!defined $here{$lref}) {
2898 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2899 runcmd_ordryrun_local @upd;
2900 lrfetchref_used $fullrefname;
2901 } elsif ($here{$lref} eq $objid) {
2902 lrfetchref_used $fullrefname;
2904 print STDERR f_ "Not updating %s from %s to %s.\n",
2905 $lref, $here{$lref}, $objid;
2910 #---------- dsc and archive handling ----------
2912 sub mergeinfo_getclogp ($) {
2913 # Ensures thit $mi->{Clogp} exists and returns it
2915 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2918 sub mergeinfo_version ($) {
2919 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2922 sub fetch_from_archive_record_1 ($) {
2924 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2925 cmdoutput @git, qw(log -n2), $hash;
2926 # ... gives git a chance to complain if our commit is malformed
2929 sub fetch_from_archive_record_2 ($) {
2931 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2935 dryrun_report @upd_cmd;
2939 sub parse_dsc_field_def_dsc_distro () {
2940 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2941 dgit.default.distro);
2944 sub parse_dsc_field ($$) {
2945 my ($dsc, $what) = @_;
2947 foreach my $field (@ourdscfield) {
2948 $f = $dsc->{$field};
2953 progress f_ "%s: NO git hash", $what;
2954 parse_dsc_field_def_dsc_distro();
2955 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2956 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2957 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
2958 $dsc_hint_tag = [ $dsc_hint_tag ];
2959 } elsif ($f =~ m/^\w+\s*$/) {
2961 parse_dsc_field_def_dsc_distro();
2962 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2964 progress f_ "%s: specified git hash", $what;
2966 fail f_ "%s: invalid Dgit info", $what;
2970 sub resolve_dsc_field_commit ($$) {
2971 my ($already_distro, $already_mapref) = @_;
2973 return unless defined $dsc_hash;
2976 defined $already_mapref &&
2977 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2978 ? $already_mapref : undef;
2982 my ($what, @fetch) = @_;
2984 local $idistro = $dsc_distro;
2985 my $lrf = lrfetchrefs;
2987 if (!$chase_dsc_distro) {
2988 progress f_ "not chasing .dsc distro %s: not fetching %s",
2993 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
2995 my $url = access_giturl();
2996 if (!defined $url) {
2997 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
2998 .dsc Dgit metadata is in context of distro %s
2999 for which we have no configured url and .dsc provides no hint
3002 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3003 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3004 parse_cfg_bool "dsc-url-proto-ok", 'false',
3005 cfg("dgit.dsc-url-proto-ok.$proto",
3006 "dgit.default.dsc-url-proto-ok")
3007 or fail f_ <<END, $dsc_distro, $proto;
3008 .dsc Dgit metadata is in context of distro %s
3009 for which we have no configured url;
3010 .dsc provides hinted url with protocol %s which is unsafe.
3011 (can be overridden by config - consult documentation)
3013 $url = $dsc_hint_url;
3016 git_lrfetch_sane $url, 1, @fetch;
3021 my $rewrite_enable = do {
3022 local $idistro = $dsc_distro;
3023 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3026 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3027 if (!defined $mapref) {
3028 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3029 $mapref = $lrf.'/'.$rewritemap;
3031 my $rewritemapdata = git_cat_file $mapref.':map';
3032 if (defined $rewritemapdata
3033 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3035 "server's git history rewrite map contains a relevant entry!";
3038 if (defined $dsc_hash) {
3039 progress __ "using rewritten git hash in place of .dsc value";
3041 progress __ "server data says .dsc hash is to be disregarded";
3046 if (!defined git_cat_file $dsc_hash) {
3047 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3048 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3049 defined git_cat_file $dsc_hash
3050 or fail f_ <<END, $dsc_hash;
3051 .dsc Dgit metadata requires commit %s
3052 but we could not obtain that object anywhere.
3054 foreach my $t (@tags) {
3055 my $fullrefname = $lrf.'/'.$t;
3056 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3057 next unless $lrfetchrefs_f{$fullrefname};
3058 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3059 lrfetchref_used $fullrefname;
3064 sub fetch_from_archive () {
3065 ensure_setup_existing_tree();
3067 # Ensures that lrref() is what is actually in the archive, one way
3068 # or another, according to us - ie this client's
3069 # appropritaely-updated archive view. Also returns the commit id.
3070 # If there is nothing in the archive, leaves lrref alone and
3071 # returns undef. git_fetch_us must have already been called.
3075 parse_dsc_field($dsc, __ 'last upload to archive');
3076 resolve_dsc_field_commit access_basedistro,
3077 lrfetchrefs."/".$rewritemap
3079 progress __ "no version available from the archive";
3082 # If the archive's .dsc has a Dgit field, there are three
3083 # relevant git commitids we need to choose between and/or merge
3085 # 1. $dsc_hash: the Dgit field from the archive
3086 # 2. $lastpush_hash: the suite branch on the dgit git server
3087 # 3. $lastfetch_hash: our local tracking brach for the suite
3089 # These may all be distinct and need not be in any fast forward
3092 # If the dsc was pushed to this suite, then the server suite
3093 # branch will have been updated; but it might have been pushed to
3094 # a different suite and copied by the archive. Conversely a more
3095 # recent version may have been pushed with dgit but not appeared
3096 # in the archive (yet).
3098 # $lastfetch_hash may be awkward because archive imports
3099 # (particularly, imports of Dgit-less .dscs) are performed only as
3100 # needed on individual clients, so different clients may perform a
3101 # different subset of them - and these imports are only made
3102 # public during push. So $lastfetch_hash may represent a set of
3103 # imports different to a subsequent upload by a different dgit
3106 # Our approach is as follows:
3108 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3109 # descendant of $dsc_hash, then it was pushed by a dgit user who
3110 # had based their work on $dsc_hash, so we should prefer it.
3111 # Otherwise, $dsc_hash was installed into this suite in the
3112 # archive other than by a dgit push, and (necessarily) after the
3113 # last dgit push into that suite (since a dgit push would have
3114 # been descended from the dgit server git branch); thus, in that
3115 # case, we prefer the archive's version (and produce a
3116 # pseudo-merge to overwrite the dgit server git branch).
3118 # (If there is no Dgit field in the archive's .dsc then
3119 # generate_commit_from_dsc uses the version numbers to decide
3120 # whether the suite branch or the archive is newer. If the suite
3121 # branch is newer it ignores the archive's .dsc; otherwise it
3122 # generates an import of the .dsc, and produces a pseudo-merge to
3123 # overwrite the suite branch with the archive contents.)
3125 # The outcome of that part of the algorithm is the `public view',
3126 # and is same for all dgit clients: it does not depend on any
3127 # unpublished history in the local tracking branch.
3129 # As between the public view and the local tracking branch: The
3130 # local tracking branch is only updated by dgit fetch, and
3131 # whenever dgit fetch runs it includes the public view in the
3132 # local tracking branch. Therefore if the public view is not
3133 # descended from the local tracking branch, the local tracking
3134 # branch must contain history which was imported from the archive
3135 # but never pushed; and, its tip is now out of date. So, we make
3136 # a pseudo-merge to overwrite the old imports and stitch the old
3139 # Finally: we do not necessarily reify the public view (as
3140 # described above). This is so that we do not end up stacking two
3141 # pseudo-merges. So what we actually do is figure out the inputs
3142 # to any public view pseudo-merge and put them in @mergeinputs.
3145 # $mergeinputs[]{Commit}
3146 # $mergeinputs[]{Info}
3147 # $mergeinputs[0] is the one whose tree we use
3148 # @mergeinputs is in the order we use in the actual commit)
3151 # $mergeinputs[]{Message} is a commit message to use
3152 # $mergeinputs[]{ReverseParents} if def specifies that parent
3153 # list should be in opposite order
3154 # Such an entry has no Commit or Info. It applies only when found
3155 # in the last entry. (This ugliness is to support making
3156 # identical imports to previous dgit versions.)
3158 my $lastpush_hash = git_get_ref(lrfetchref());
3159 printdebug "previous reference hash=$lastpush_hash\n";
3160 $lastpush_mergeinput = $lastpush_hash && {
3161 Commit => $lastpush_hash,
3162 Info => (__ "dgit suite branch on dgit git server"),
3165 my $lastfetch_hash = git_get_ref(lrref());
3166 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3167 my $lastfetch_mergeinput = $lastfetch_hash && {
3168 Commit => $lastfetch_hash,
3169 Info => (__ "dgit client's archive history view"),
3172 my $dsc_mergeinput = $dsc_hash && {
3173 Commit => $dsc_hash,
3174 Info => (__ "Dgit field in .dsc from archive"),
3178 my $del_lrfetchrefs = sub {
3181 printdebug "del_lrfetchrefs...\n";
3182 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3183 my $objid = $lrfetchrefs_d{$fullrefname};
3184 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3186 $gur ||= new IO::Handle;
3187 open $gur, "|-", qw(git update-ref --stdin) or confess $!;
3189 printf $gur "delete %s %s\n", $fullrefname, $objid;
3192 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3196 if (defined $dsc_hash) {
3197 ensure_we_have_orig();
3198 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3199 @mergeinputs = $dsc_mergeinput
3200 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3201 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3203 Git commit in archive is behind the last version allegedly pushed/uploaded.
3204 Commit referred to by archive: %s
3205 Last version pushed with dgit: %s
3208 __ $later_warning_msg or confess $!;
3209 @mergeinputs = ($lastpush_mergeinput);
3211 # Archive has .dsc which is not a descendant of the last dgit
3212 # push. This can happen if the archive moves .dscs about.
3213 # Just follow its lead.
3214 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3215 progress __ "archive .dsc names newer git commit";
3216 @mergeinputs = ($dsc_mergeinput);
3218 progress __ "archive .dsc names other git commit, fixing up";
3219 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3223 @mergeinputs = generate_commits_from_dsc();
3224 # We have just done an import. Now, our import algorithm might
3225 # have been improved. But even so we do not want to generate
3226 # a new different import of the same package. So if the
3227 # version numbers are the same, just use our existing version.
3228 # If the version numbers are different, the archive has changed
3229 # (perhaps, rewound).
3230 if ($lastfetch_mergeinput &&
3231 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3232 (mergeinfo_version $mergeinputs[0]) )) {
3233 @mergeinputs = ($lastfetch_mergeinput);
3235 } elsif ($lastpush_hash) {
3236 # only in git, not in the archive yet
3237 @mergeinputs = ($lastpush_mergeinput);
3238 print STDERR f_ <<END,
3240 Package not found in the archive, but has allegedly been pushed using dgit.
3243 __ $later_warning_msg or confess $!;
3245 printdebug "nothing found!\n";
3246 if (defined $skew_warning_vsn) {
3247 print STDERR f_ <<END, $skew_warning_vsn or confess $!;
3249 Warning: relevant archive skew detected.
3250 Archive allegedly contains %s
3251 But we were not able to obtain any version from the archive or git.
3255 unshift @end, $del_lrfetchrefs;
3259 if ($lastfetch_hash &&
3261 my $h = $_->{Commit};
3262 $h and is_fast_fwd($lastfetch_hash, $h);
3263 # If true, one of the existing parents of this commit
3264 # is a descendant of the $lastfetch_hash, so we'll
3265 # be ff from that automatically.
3269 push @mergeinputs, $lastfetch_mergeinput;
3272 printdebug "fetch mergeinfos:\n";
3273 foreach my $mi (@mergeinputs) {
3275 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3277 printdebug sprintf " ReverseParents=%d Message=%s",
3278 $mi->{ReverseParents}, $mi->{Message};
3282 my $compat_info= pop @mergeinputs
3283 if $mergeinputs[$#mergeinputs]{Message};
3285 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3288 if (@mergeinputs > 1) {
3290 my $tree_commit = $mergeinputs[0]{Commit};
3292 my $tree = get_tree_of_commit $tree_commit;;
3294 # We use the changelog author of the package in question the
3295 # author of this pseudo-merge. This is (roughly) correct if
3296 # this commit is simply representing aa non-dgit upload.
3297 # (Roughly because it does not record sponsorship - but we
3298 # don't have sponsorship info because that's in the .changes,
3299 # which isn't in the archivw.)
3301 # But, it might be that we are representing archive history
3302 # updates (including in-archive copies). These are not really
3303 # the responsibility of the person who created the .dsc, but
3304 # there is no-one whose name we should better use. (The
3305 # author of the .dsc-named commit is clearly worse.)
3307 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3308 my $author = clogp_authline $useclogp;
3309 my $cversion = getfield $useclogp, 'Version';
3311 my $mcf = dgit_privdir()."/mergecommit";
3312 open MC, ">", $mcf or die "$mcf $!";
3313 print MC <<END or confess $!;
3317 my @parents = grep { $_->{Commit} } @mergeinputs;
3318 @parents = reverse @parents if $compat_info->{ReverseParents};
3319 print MC <<END or confess $! foreach @parents;
3323 print MC <<END or confess $!;
3329 if (defined $compat_info->{Message}) {
3330 print MC $compat_info->{Message} or confess $!;
3332 print MC f_ <<END, $package, $cversion, $csuite or confess $!;
3333 Record %s (%s) in archive suite %s
3337 my $message_add_info = sub {
3339 my $mversion = mergeinfo_version $mi;
3340 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3344 $message_add_info->($mergeinputs[0]);
3345 print MC __ <<END or confess $!;
3346 should be treated as descended from
3348 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3351 close MC or confess $!;
3352 $hash = make_commit $mcf;
3354 $hash = $mergeinputs[0]{Commit};
3356 printdebug "fetch hash=$hash\n";
3359 my ($lasth, $what) = @_;
3360 return unless $lasth;
3361 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3364 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3366 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3368 fetch_from_archive_record_1($hash);
3370 if (defined $skew_warning_vsn) {
3371 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3372 my $gotclogp = commit_getclogp($hash);
3373 my $got_vsn = getfield $gotclogp, 'Version';
3374 printdebug "SKEW CHECK GOT $got_vsn\n";
3375 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3376 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess $!;
3378 Warning: archive skew detected. Using the available version:
3379 Archive allegedly contains %s
3380 We were able to obtain only %s
3386 if ($lastfetch_hash ne $hash) {
3387 fetch_from_archive_record_2($hash);
3390 lrfetchref_used lrfetchref();
3392 check_gitattrs($hash, __ "fetched source tree");
3394 unshift @end, $del_lrfetchrefs;
3398 sub set_local_git_config ($$) {
3400 runcmd @git, qw(config), $k, $v;
3403 sub setup_mergechangelogs (;$) {
3405 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3407 my $driver = 'dpkg-mergechangelogs';
3408 my $cb = "merge.$driver";
3409 confess unless defined $maindir;
3410 my $attrs = "$maindir_gitcommon/info/attributes";
3411 ensuredir "$maindir_gitcommon/info";
3413 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3414 if (!open ATTRS, "<", $attrs) {
3415 $!==ENOENT or die "$attrs: $!";
3419 next if m{^debian/changelog\s};
3420 print NATTRS $_, "\n" or confess $!;
3422 ATTRS->error and confess $!;
3425 print NATTRS "debian/changelog merge=$driver\n" or confess $!;
3428 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3429 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3431 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3434 sub setup_useremail (;$) {
3436 return unless $always || access_cfg_bool(1, 'setup-useremail');
3439 my ($k, $envvar) = @_;
3440 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3441 return unless defined $v;
3442 set_local_git_config "user.$k", $v;
3445 $setup->('email', 'DEBEMAIL');
3446 $setup->('name', 'DEBFULLNAME');
3449 sub ensure_setup_existing_tree () {
3450 my $k = "remote.$remotename.skipdefaultupdate";
3451 my $c = git_get_config $k;
3452 return if defined $c;
3453 set_local_git_config $k, 'true';
3456 sub open_main_gitattrs () {
3457 confess 'internal error no maindir' unless defined $maindir;
3458 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3460 or die "open $maindir_gitcommon/info/attributes: $!";
3464 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3466 sub is_gitattrs_setup () {
3469 # 1: gitattributes set up and should be left alone
3471 # 0: there is a dgit-defuse-attrs but it needs fixing
3472 # undef: there is none
3473 my $gai = open_main_gitattrs();
3474 return 0 unless $gai;
3476 next unless m{$gitattrs_ourmacro_re};
3477 return 1 if m{\s-working-tree-encoding\s};
3478 printdebug "is_gitattrs_setup: found old macro\n";
3481 $gai->error and confess $!;
3482 printdebug "is_gitattrs_setup: found nothing\n";
3486 sub setup_gitattrs (;$) {
3488 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3490 my $already = is_gitattrs_setup();
3493 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3494 not doing further gitattributes setup
3498 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3499 my $af = "$maindir_gitcommon/info/attributes";
3500 ensuredir "$maindir_gitcommon/info";
3502 open GAO, "> $af.new" or confess $!;
3503 print GAO <<END, __ <<ENDT or confess $! unless defined $already;
3507 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3509 my $gai = open_main_gitattrs();
3512 if (m{$gitattrs_ourmacro_re}) {
3513 die unless defined $already;
3517 print GAO $_, "\n" or confess $!;
3519 $gai->error and confess $!;
3521 close GAO or confess $!;
3522 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3525 sub setup_new_tree () {
3526 setup_mergechangelogs();
3531 sub check_gitattrs ($$) {
3532 my ($treeish, $what) = @_;
3534 return if is_gitattrs_setup;
3537 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3539 my $gafl = new IO::File;
3540 open $gafl, "-|", @cmd or confess $!;
3543 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3545 next unless m{(?:^|/)\.gitattributes$};
3547 # oh dear, found one
3548 print STDERR f_ <<END, $what;
3549 dgit: warning: %s contains .gitattributes
3550 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3555 # tree contains no .gitattributes files
3556 $?=0; $!=0; close $gafl or failedcmd @cmd;
3560 sub multisuite_suite_child ($$$) {
3561 my ($tsuite, $mergeinputs, $fn) = @_;
3562 # in child, sets things up, calls $fn->(), and returns undef
3563 # in parent, returns canonical suite name for $tsuite
3564 my $canonsuitefh = IO::File::new_tmpfile;
3565 my $pid = fork // confess $!;
3569 $us .= " [$isuite]";
3570 $debugprefix .= " ";
3571 progress f_ "fetching %s...", $tsuite;
3572 canonicalise_suite();
3573 print $canonsuitefh $csuite, "\n" or confess $!;
3574 close $canonsuitefh or confess $!;
3578 waitpid $pid,0 == $pid or confess $!;
3579 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3581 seek $canonsuitefh,0,0 or confess $!;
3582 local $csuite = <$canonsuitefh>;
3583 confess $! unless defined $csuite && chomp $csuite;
3585 printdebug "multisuite $tsuite missing\n";
3588 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3589 push @$mergeinputs, {
3596 sub fork_for_multisuite ($) {
3597 my ($before_fetch_merge) = @_;
3598 # if nothing unusual, just returns ''
3601 # returns 0 to caller in child, to do first of the specified suites
3602 # in child, $csuite is not yet set
3604 # returns 1 to caller in parent, to finish up anything needed after
3605 # in parent, $csuite is set to canonicalised portmanteau
3607 my $org_isuite = $isuite;
3608 my @suites = split /\,/, $isuite;
3609 return '' unless @suites > 1;
3610 printdebug "fork_for_multisuite: @suites\n";
3614 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3616 return 0 unless defined $cbasesuite;
3618 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3619 unless @mergeinputs;
3621 my @csuites = ($cbasesuite);
3623 $before_fetch_merge->();
3625 foreach my $tsuite (@suites[1..$#suites]) {
3626 $tsuite =~ s/^-/$cbasesuite-/;
3627 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3634 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3635 push @csuites, $csubsuite;
3638 foreach my $mi (@mergeinputs) {
3639 my $ref = git_get_ref $mi->{Ref};
3640 die "$mi->{Ref} ?" unless length $ref;
3641 $mi->{Commit} = $ref;
3644 $csuite = join ",", @csuites;
3646 my $previous = git_get_ref lrref;
3648 unshift @mergeinputs, {
3649 Commit => $previous,
3650 Info => (__ "local combined tracking branch"),
3652 "archive seems to have rewound: local tracking branch is ahead!"),
3656 foreach my $ix (0..$#mergeinputs) {
3657 $mergeinputs[$ix]{Index} = $ix;
3660 @mergeinputs = sort {
3661 -version_compare(mergeinfo_version $a,
3662 mergeinfo_version $b) # highest version first
3664 $a->{Index} <=> $b->{Index}; # earliest in spec first
3670 foreach my $mi (@mergeinputs) {
3671 printdebug "multisuite merge check $mi->{Info}\n";
3672 foreach my $previous (@needed) {
3673 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3674 printdebug "multisuite merge un-needed $previous->{Info}\n";
3678 printdebug "multisuite merge this-needed\n";
3679 $mi->{Character} = '+';
3682 $needed[0]{Character} = '*';
3684 my $output = $needed[0]{Commit};
3687 printdebug "multisuite merge nontrivial\n";
3688 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3690 my $commit = "tree $tree\n";
3691 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3692 "Input branches:\n",
3695 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3696 printdebug "multisuite merge include $mi->{Info}\n";
3697 $mi->{Character} //= ' ';
3698 $commit .= "parent $mi->{Commit}\n";
3699 $msg .= sprintf " %s %-25s %s\n",
3701 (mergeinfo_version $mi),
3704 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3705 $msg .= __ "\nKey\n".
3706 " * marks the highest version branch, which choose to use\n".
3707 " + marks each branch which was not already an ancestor\n\n";
3709 "[dgit multi-suite $csuite]\n";
3711 "author $authline\n".
3712 "committer $authline\n\n";
3713 $output = make_commit_text $commit.$msg;
3714 printdebug "multisuite merge generated $output\n";
3717 fetch_from_archive_record_1($output);
3718 fetch_from_archive_record_2($output);
3720 progress f_ "calculated combined tracking suite %s", $csuite;
3725 sub clone_set_head () {
3726 open H, "> .git/HEAD" or confess $!;
3727 print H "ref: ".lref()."\n" or confess $!;
3728 close H or confess $!;
3730 sub clone_finish ($) {
3732 runcmd @git, qw(reset --hard), lrref();
3733 runcmd qw(bash -ec), <<'END';
3735 git ls-tree -r --name-only -z HEAD | \
3736 xargs -0r touch -h -r . --
3738 printdone f_ "ready for work in %s", $dstdir;
3742 # in multisuite, returns twice!
3743 # once in parent after first suite fetched,
3744 # and then again in child after everything is finished
3746 badusage __ "dry run makes no sense with clone" unless act_local();
3748 my $multi_fetched = fork_for_multisuite(sub {
3749 printdebug "multi clone before fetch merge\n";
3753 if ($multi_fetched) {
3754 printdebug "multi clone after fetch merge\n";
3756 clone_finish($dstdir);
3759 printdebug "clone main body\n";
3761 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3764 canonicalise_suite();
3765 my $hasgit = check_for_git();
3767 runcmd @git, qw(init -q);
3771 my $giturl = access_giturl(1);
3772 if (defined $giturl) {
3773 runcmd @git, qw(remote add), 'origin', $giturl;
3776 progress __ "fetching existing git history";
3778 runcmd_ordryrun_local @git, qw(fetch origin);
3780 progress __ "starting new git history";
3782 fetch_from_archive() or no_such_package;
3783 my $vcsgiturl = $dsc->{'Vcs-Git'};
3784 if (length $vcsgiturl) {
3785 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3786 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3788 clone_finish($dstdir);
3792 canonicalise_suite();
3793 if (check_for_git()) {
3796 fetch_from_archive() or no_such_package();
3798 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3799 if (length $vcsgiturl and
3800 (grep { $csuite eq $_ }
3802 cfg 'dgit.vcs-git.suites')) {
3803 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3804 if (defined $current && $current ne $vcsgiturl) {
3805 print STDERR f_ <<END, $csuite;
3806 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3807 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3811 printdone f_ "fetched into %s", lrref();
3815 my $multi_fetched = fork_for_multisuite(sub { });
3816 fetch_one() unless $multi_fetched; # parent
3817 finish 0 if $multi_fetched eq '0'; # child
3822 runcmd_ordryrun_local @git, qw(merge -m),
3823 (f_ "Merge from %s [dgit]", $csuite),
3825 printdone f_ "fetched to %s and merged into HEAD", lrref();
3828 sub check_not_dirty () {
3829 my @forbid = qw(local-options local-patch-header);
3830 @forbid = map { "debian/source/$_" } @forbid;
3831 foreach my $f (@forbid) {
3832 if (stat_exists $f) {
3833 fail f_ "git tree contains %s", $f;
3837 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3838 push @cmd, qw(debian/source/format debian/source/options);
3841 my $bad = cmdoutput @cmd;
3844 "you have uncommitted changes to critical files, cannot continue:\n").
3848 return if $includedirty;
3850 git_check_unmodified();
3853 sub commit_admin ($) {
3856 runcmd_ordryrun_local @git, qw(commit -m), $m;
3859 sub quiltify_nofix_bail ($$) {
3860 my ($headinfo, $xinfo) = @_;
3861 if ($quilt_mode eq 'nofix') {
3863 "quilt fixup required but quilt mode is \`nofix'\n".
3864 "HEAD commit%s differs from tree implied by debian/patches%s",
3869 sub commit_quilty_patch () {
3870 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3872 foreach my $l (split /\n/, $output) {
3873 next unless $l =~ m/\S/;
3874 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3878 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3880 progress __ "nothing quilty to commit, ok.";
3883 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3884 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3885 runcmd_ordryrun_local @git, qw(add -f), @adds;
3886 commit_admin +(__ <<ENDT).<<END
3887 Commit Debian 3.0 (quilt) metadata
3890 [dgit ($our_version) quilt-fixup]
3894 sub get_source_format () {
3896 if (open F, "debian/source/options") {
3900 s/\s+$//; # ignore missing final newline
3902 my ($k, $v) = ($`, $'); #');
3903 $v =~ s/^"(.*)"$/$1/;
3909 F->error and confess $!;
3912 confess $! unless $!==&ENOENT;
3915 if (!open F, "debian/source/format") {
3916 confess $! unless $!==&ENOENT;
3920 F->error and confess $!;
3922 return ($_, \%options);
3925 sub madformat_wantfixup ($) {
3927 return 0 unless $format eq '3.0 (quilt)';
3928 our $quilt_mode_warned;
3929 if ($quilt_mode eq 'nocheck') {
3930 progress f_ "Not doing any fixup of \`%s'".
3931 " due to ----no-quilt-fixup or --quilt=nocheck", $format
3932 unless $quilt_mode_warned++;
3935 progress f_ "Format \`%s', need to check/update patch stack", $format
3936 unless $quilt_mode_warned++;
3940 sub maybe_split_brain_save ($$$) {
3941 my ($headref, $dgitview, $msg) = @_;
3942 # => message fragment "$saved" describing disposition of $dgitview
3943 # (used inside parens, in the English texts)
3944 my $save = $internal_object_save{'dgit-view'};
3945 return f_ "commit id %s", $dgitview unless defined $save;
3946 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3948 "dgit --dgit-view-save $msg HEAD=$headref",
3951 return f_ "and left in %s", $save;
3954 # An "infopair" is a tuple [ $thing, $what ]
3955 # (often $thing is a commit hash; $what is a description)
3957 sub infopair_cond_equal ($$) {
3959 $x->[0] eq $y->[0] or fail <<END;
3960 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3964 sub infopair_lrf_tag_lookup ($$) {
3965 my ($tagnames, $what) = @_;
3966 # $tagname may be an array ref
3967 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3968 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3969 foreach my $tagname (@tagnames) {
3970 my $lrefname = lrfetchrefs."/tags/$tagname";
3971 my $tagobj = $lrfetchrefs_f{$lrefname};
3972 next unless defined $tagobj;
3973 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3974 return [ git_rev_parse($tagobj), $what ];
3976 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
3977 Wanted tag %s (%s) on dgit server, but not found
3979 : (f_ <<END, $what, "@tagnames");
3980 Wanted tag %s (one of: %s) on dgit server, but not found
3984 sub infopair_cond_ff ($$) {
3985 my ($anc,$desc) = @_;
3986 is_fast_fwd($anc->[0], $desc->[0]) or
3987 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
3988 %s (%s) .. %s (%s) is not fast forward
3992 sub pseudomerge_version_check ($$) {
3993 my ($clogp, $archive_hash) = @_;
3995 my $arch_clogp = commit_getclogp $archive_hash;
3996 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3997 __ 'version currently in archive' ];
3998 if (defined $overwrite_version) {
3999 if (length $overwrite_version) {
4000 infopair_cond_equal([ $overwrite_version,
4001 '--overwrite= version' ],
4004 my $v = $i_arch_v->[0];
4006 "Checking package changelog for archive version %s ...", $v;
4009 my @xa = ("-f$v", "-t$v");
4010 my $vclogp = parsechangelog @xa;
4013 [ (getfield $vclogp, $fn),
4014 (f_ "%s field from dpkg-parsechangelog %s",
4017 my $cv = $gf->('Version');
4018 infopair_cond_equal($i_arch_v, $cv);
4019 $cd = $gf->('Distribution');
4022 $@ =~ s/^dgit: //gm;
4024 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4026 fail f_ <<END, $cd->[1], $cd->[0], $v
4028 Your tree seems to based on earlier (not uploaded) %s.
4030 if $cd->[0] =~ m/UNRELEASED/;
4034 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4038 sub pseudomerge_make_commit ($$$$ $$) {
4039 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4040 $msg_cmd, $msg_msg) = @_;
4041 progress f_ "Declaring that HEAD includes all changes in %s...",
4044 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4045 my $authline = clogp_authline $clogp;
4049 !defined $overwrite_version ? ""
4050 : !length $overwrite_version ? " --overwrite"
4051 : " --overwrite=".$overwrite_version;
4053 # Contributing parent is the first parent - that makes
4054 # git rev-list --first-parent DTRT.
4055 my $pmf = dgit_privdir()."/pseudomerge";
4056 open MC, ">", $pmf or die "$pmf $!";
4057 print MC <<END or confess $!;
4060 parent $archive_hash
4068 close MC or confess $!;
4070 return make_commit($pmf);
4073 sub splitbrain_pseudomerge ($$$$) {
4074 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4075 # => $merged_dgitview
4076 printdebug "splitbrain_pseudomerge...\n";
4078 # We: debian/PREVIOUS HEAD($maintview)
4079 # expect: o ----------------- o
4082 # a/d/PREVIOUS $dgitview
4085 # we do: `------------------ o
4089 return $dgitview unless defined $archive_hash;
4090 return $dgitview if deliberately_not_fast_forward();
4092 printdebug "splitbrain_pseudomerge...\n";
4094 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4096 if (!defined $overwrite_version) {
4097 progress __ "Checking that HEAD includes all changes in archive...";
4100 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4102 if (defined $overwrite_version) {
4104 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4105 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4106 __ "maintainer view tag");
4107 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4108 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4109 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4111 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4113 infopair_cond_equal($i_dgit, $i_archive);
4114 infopair_cond_ff($i_dep14, $i_dgit);
4115 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4118 $@ =~ s/^\n//; chomp $@;
4119 print STDERR <<END.(__ <<ENDT);
4122 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4127 my $arch_v = $i_arch_v->[0];
4128 my $r = pseudomerge_make_commit
4129 $clogp, $dgitview, $archive_hash, $i_arch_v,
4130 "dgit --quilt=$quilt_mode",
4131 (defined $overwrite_version
4132 ? f_ "Declare fast forward from %s\n", $arch_v
4133 : f_ "Make fast forward from %s\n", $arch_v);
4135 maybe_split_brain_save $maintview, $r, "pseudomerge";
4137 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4141 sub plain_overwrite_pseudomerge ($$$) {
4142 my ($clogp, $head, $archive_hash) = @_;
4144 printdebug "plain_overwrite_pseudomerge...";
4146 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4148 return $head if is_fast_fwd $archive_hash, $head;
4150 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4152 my $r = pseudomerge_make_commit
4153 $clogp, $head, $archive_hash, $i_arch_v,
4156 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4158 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4162 sub push_parse_changelog ($) {
4165 my $clogp = Dpkg::Control::Hash->new();
4166 $clogp->load($clogpfn) or die;
4168 my $clogpackage = getfield $clogp, 'Source';
4169 $package //= $clogpackage;
4170 fail f_ "-p specified %s but changelog specified %s",
4171 $package, $clogpackage
4172 unless $package eq $clogpackage;
4173 my $cversion = getfield $clogp, 'Version';
4175 if (!$we_are_initiator) {
4176 # rpush initiator can't do this because it doesn't have $isuite yet
4177 my $tag = debiantag($cversion, access_nomdistro);
4178 runcmd @git, qw(check-ref-format), $tag;
4181 my $dscfn = dscfn($cversion);
4183 return ($clogp, $cversion, $dscfn);
4186 sub push_parse_dsc ($$$) {
4187 my ($dscfn,$dscfnwhat, $cversion) = @_;
4188 $dsc = parsecontrol($dscfn,$dscfnwhat);
4189 my $dversion = getfield $dsc, 'Version';
4190 my $dscpackage = getfield $dsc, 'Source';
4191 ($dscpackage eq $package && $dversion eq $cversion) or
4192 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4193 $dscfn, $dscpackage, $dversion,
4194 $package, $cversion;
4197 sub push_tagwants ($$$$) {
4198 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4201 TagFn => \&debiantag,
4206 if (defined $maintviewhead) {
4208 TagFn => \&debiantag_maintview,
4209 Objid => $maintviewhead,
4210 TfSuffix => '-maintview',
4213 } elsif ($dodep14tag eq 'no' ? 0
4214 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4215 : $dodep14tag eq 'always'
4216 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4217 --dep14tag-always (or equivalent in config) means server must support
4218 both "new" and "maint" tag formats, but config says it doesn't.
4220 : die "$dodep14tag ?") {
4222 TagFn => \&debiantag_maintview,
4224 TfSuffix => '-dgit',
4228 foreach my $tw (@tagwants) {
4229 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4230 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4232 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4236 sub push_mktags ($$ $$ $) {
4238 $changesfile,$changesfilewhat,
4241 die unless $tagwants->[0]{View} eq 'dgit';
4243 my $declaredistro = access_nomdistro();
4244 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4245 $dsc->{$ourdscfield[0]} = join " ",
4246 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4248 $dsc->save("$dscfn.tmp") or confess $!;
4250 my $changes = parsecontrol($changesfile,$changesfilewhat);
4251 foreach my $field (qw(Source Distribution Version)) {
4252 $changes->{$field} eq $clogp->{$field} or
4253 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4254 $field, $changes->{$field}, $clogp->{$field};
4257 my $cversion = getfield $clogp, 'Version';
4258 my $clogsuite = getfield $clogp, 'Distribution';
4260 # We make the git tag by hand because (a) that makes it easier
4261 # to control the "tagger" (b) we can do remote signing
4262 my $authline = clogp_authline $clogp;
4263 my $delibs = join(" ", "",@deliberatelies);
4267 my $tfn = $tw->{Tfn};
4268 my $head = $tw->{Objid};
4269 my $tag = $tw->{Tag};
4271 open TO, '>', $tfn->('.tmp') or confess $!;
4272 print TO <<END or confess $!;
4279 if ($tw->{View} eq 'dgit') {
4280 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4281 %s release %s for %s (%s) [dgit]
4284 print TO <<END or confess $!;
4285 [dgit distro=$declaredistro$delibs]
4287 foreach my $ref (sort keys %previously) {
4288 print TO <<END or confess $!;
4289 [dgit previously:$ref=$previously{$ref}]
4292 } elsif ($tw->{View} eq 'maint') {
4293 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4294 %s release %s for %s (%s)
4295 (maintainer view tag generated by dgit --quilt=%s)
4300 confess Dumper($tw)."?";
4303 close TO or confess $!;
4305 my $tagobjfn = $tfn->('.tmp');
4307 if (!defined $keyid) {
4308 $keyid = access_cfg('keyid','RETURN-UNDEF');
4310 if (!defined $keyid) {
4311 $keyid = getfield $clogp, 'Maintainer';
4313 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
4314 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4315 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4316 push @sign_cmd, $tfn->('.tmp');
4317 runcmd_ordryrun @sign_cmd;
4319 $tagobjfn = $tfn->('.signed.tmp');
4320 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4321 $tfn->('.tmp'), $tfn->('.tmp.asc');
4327 my @r = map { $mktag->($_); } @$tagwants;
4331 sub sign_changes ($) {
4332 my ($changesfile) = @_;
4334 my @debsign_cmd = @debsign;
4335 push @debsign_cmd, "-k$keyid" if defined $keyid;
4336 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4337 push @debsign_cmd, $changesfile;
4338 runcmd_ordryrun @debsign_cmd;
4343 printdebug "actually entering push\n";
4345 supplementary_message(__ <<'END');
4346 Push failed, while checking state of the archive.
4347 You can retry the push, after fixing the problem, if you like.
4349 if (check_for_git()) {
4352 my $archive_hash = fetch_from_archive();
4353 if (!$archive_hash) {
4355 fail __ "package appears to be new in this suite;".
4356 " if this is intentional, use --new";
4359 supplementary_message(__ <<'END');
4360 Push failed, while preparing your push.
4361 You can retry the push, after fixing the problem, if you like.
4364 need_tagformat 'new', "quilt mode $quilt_mode"
4365 if quiltmode_splitbrain;
4369 access_giturl(); # check that success is vaguely likely
4370 rpush_handle_protovsn_bothends() if $we_are_initiator;
4373 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4374 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4376 responder_send_file('parsed-changelog', $clogpfn);
4378 my ($clogp, $cversion, $dscfn) =
4379 push_parse_changelog("$clogpfn");
4381 my $dscpath = "$buildproductsdir/$dscfn";
4382 stat_exists $dscpath or
4383 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4386 responder_send_file('dsc', $dscpath);
4388 push_parse_dsc($dscpath, $dscfn, $cversion);
4390 my $format = getfield $dsc, 'Format';
4391 printdebug "format $format\n";
4393 my $symref = git_get_symref();
4394 my $actualhead = git_rev_parse('HEAD');
4396 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4397 if (quiltmode_splitbrain()) {
4398 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4399 fail f_ <<END, $ffq_prev, $quilt_mode;
4400 Branch is managed by git-debrebase (%s
4401 exists), but quilt mode (%s) implies a split view.
4402 Pass the right --quilt option or adjust your git config.
4403 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4406 runcmd_ordryrun_local @git_debrebase, 'stitch';
4407 $actualhead = git_rev_parse('HEAD');
4410 my $dgithead = $actualhead;
4411 my $maintviewhead = undef;
4413 my $upstreamversion = upstreamversion $clogp->{Version};
4415 if (madformat_wantfixup($format)) {
4416 # user might have not used dgit build, so maybe do this now:
4417 if (quiltmode_splitbrain()) {
4418 changedir $playground;
4419 quilt_make_fake_dsc($upstreamversion);
4421 ($dgithead, $cachekey) =
4422 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4423 $dgithead or fail f_
4424 "--quilt=%s but no cached dgit view:
4425 perhaps HEAD changed since dgit build[-source] ?",
4428 $dgithead = splitbrain_pseudomerge($clogp,
4429 $actualhead, $dgithead,
4431 $maintviewhead = $actualhead;
4433 prep_ud(); # so _only_subdir() works, below
4435 commit_quilty_patch();
4439 if (defined $overwrite_version && !defined $maintviewhead
4441 $dgithead = plain_overwrite_pseudomerge($clogp,
4449 if ($archive_hash) {
4450 if (is_fast_fwd($archive_hash, $dgithead)) {
4452 } elsif (deliberately_not_fast_forward) {
4455 fail __ "dgit push: HEAD is not a descendant".
4456 " of the archive's version.\n".
4457 "To overwrite the archive's contents,".
4458 " pass --overwrite[=VERSION].\n".
4459 "To rewind history, if permitted by the archive,".
4460 " use --deliberately-not-fast-forward.";
4464 changedir $playground;
4465 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4466 runcmd qw(dpkg-source -x --),
4467 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4468 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4469 check_for_vendor_patches() if madformat($dsc->{format});
4471 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4472 debugcmd "+",@diffcmd;
4474 my $r = system @diffcmd;
4477 my $referent = $split_brain ? $dgithead : 'HEAD';
4478 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4481 my $raw = cmdoutput @git,
4482 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4484 foreach (split /\0/, $raw) {
4485 if (defined $changed) {
4486 push @mode_changes, "$changed: $_\n" if $changed;
4489 } elsif (m/^:0+ 0+ /) {
4491 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4492 $changed = "Mode change from $1 to $2"
4497 if (@mode_changes) {
4498 fail +(f_ <<ENDT, $dscfn).<<END
4499 HEAD specifies a different tree to %s:
4503 .(join '', @mode_changes)
4504 .(f_ <<ENDT, $tree, $referent);
4505 There is a problem with your source tree (see dgit(7) for some hints).
4506 To see a full diff, run git diff %s %s
4510 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4511 HEAD specifies a different tree to %s:
4515 Perhaps you forgot to build. Or perhaps there is a problem with your
4516 source tree (see dgit(7) for some hints). To see a full diff, run
4523 if (!$changesfile) {
4524 my $pat = changespat $cversion;
4525 my @cs = glob "$buildproductsdir/$pat";
4526 fail f_ "failed to find unique changes file".
4527 " (looked for %s in %s);".
4528 " perhaps you need to use dgit -C",
4529 $pat, $buildproductsdir
4531 ($changesfile) = @cs;
4533 $changesfile = "$buildproductsdir/$changesfile";
4536 # Check that changes and .dsc agree enough
4537 $changesfile =~ m{[^/]*$};
4538 my $changes = parsecontrol($changesfile,$&);
4539 files_compare_inputs($dsc, $changes)
4540 unless forceing [qw(dsc-changes-mismatch)];
4542 # Check whether this is a source only upload
4543 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4544 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4545 if ($sourceonlypolicy eq 'ok') {
4546 } elsif ($sourceonlypolicy eq 'always') {
4547 forceable_fail [qw(uploading-binaries)],
4548 __ "uploading binaries, although distro policy is source only"
4550 } elsif ($sourceonlypolicy eq 'never') {
4551 forceable_fail [qw(uploading-source-only)],
4552 __ "source-only upload, although distro policy requires .debs"
4554 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4555 forceable_fail [qw(uploading-source-only)],
4556 f_ "source-only upload, even though package is entirely NEW\n".
4557 "(this is contrary to policy in %s)",
4561 && !(archive_query('package_not_wholly_new', $package) // 1);
4563 badcfg f_ "unknown source-only-uploads policy \`%s'",
4567 # Perhaps adjust .dsc to contain right set of origs
4568 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4570 unless forceing [qw(changes-origs-exactly)];
4572 # Checks complete, we're going to try and go ahead:
4574 responder_send_file('changes',$changesfile);
4575 responder_send_command("param head $dgithead");
4576 responder_send_command("param csuite $csuite");
4577 responder_send_command("param isuite $isuite");
4578 responder_send_command("param tagformat $tagformat");
4579 if (defined $maintviewhead) {
4580 confess "internal error (protovsn=$protovsn)"
4581 if defined $protovsn and $protovsn < 4;
4582 responder_send_command("param maint-view $maintviewhead");
4585 # Perhaps send buildinfo(s) for signing
4586 my $changes_files = getfield $changes, 'Files';
4587 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4588 foreach my $bi (@buildinfos) {
4589 responder_send_command("param buildinfo-filename $bi");
4590 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4593 if (deliberately_not_fast_forward) {
4594 git_for_each_ref(lrfetchrefs, sub {
4595 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4596 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4597 responder_send_command("previously $rrefname=$objid");
4598 $previously{$rrefname} = $objid;
4602 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4603 dgit_privdir()."/tag");
4606 supplementary_message(__ <<'END');
4607 Push failed, while signing the tag.
4608 You can retry the push, after fixing the problem, if you like.
4610 # If we manage to sign but fail to record it anywhere, it's fine.
4611 if ($we_are_responder) {
4612 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4613 responder_receive_files('signed-tag', @tagobjfns);
4615 @tagobjfns = push_mktags($clogp,$dscpath,
4616 $changesfile,$changesfile,
4619 supplementary_message(__ <<'END');
4620 Push failed, *after* signing the tag.
4621 If you want to try again, you should use a new version number.
4624 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4626 foreach my $tw (@tagwants) {
4627 my $tag = $tw->{Tag};
4628 my $tagobjfn = $tw->{TagObjFn};
4630 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4631 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4632 runcmd_ordryrun_local
4633 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4636 supplementary_message(__ <<'END');
4637 Push failed, while updating the remote git repository - see messages above.
4638 If you want to try again, you should use a new version number.
4640 if (!check_for_git()) {
4641 create_remote_git_repo();
4644 my @pushrefs = $forceflag.$dgithead.":".rrref();
4645 foreach my $tw (@tagwants) {
4646 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4649 runcmd_ordryrun @git,
4650 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4651 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4653 supplementary_message(__ <<'END');
4654 Push failed, while obtaining signatures on the .changes and .dsc.
4655 If it was just that the signature failed, you may try again by using
4656 debsign by hand to sign the changes file (see the command dgit tried,
4657 above), and then dput that changes file to complete the upload.
4658 If you need to change the package, you must use a new version number.
4660 if ($we_are_responder) {
4661 my $dryrunsuffix = act_local() ? "" : ".tmp";
4662 my @rfiles = ($dscpath, $changesfile);
4663 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4664 responder_receive_files('signed-dsc-changes',
4665 map { "$_$dryrunsuffix" } @rfiles);
4668 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4670 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4672 sign_changes $changesfile;
4675 supplementary_message(f_ <<END, $changesfile);
4676 Push failed, while uploading package(s) to the archive server.
4677 You can retry the upload of exactly these same files with dput of:
4679 If that .changes file is broken, you will need to use a new version
4680 number for your next attempt at the upload.
4682 my $host = access_cfg('upload-host','RETURN-UNDEF');
4683 my @hostarg = defined($host) ? ($host,) : ();
4684 runcmd_ordryrun @dput, @hostarg, $changesfile;
4685 printdone f_ "pushed and uploaded %s", $cversion;
4687 supplementary_message('');
4688 responder_send_command("complete");
4692 not_necessarily_a_tree();
4697 badusage __ "-p is not allowed with clone; specify as argument instead"
4698 if defined $package;
4701 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4702 ($package,$isuite) = @ARGV;
4703 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4704 ($package,$dstdir) = @ARGV;
4705 } elsif (@ARGV==3) {
4706 ($package,$isuite,$dstdir) = @ARGV;
4708 badusage __ "incorrect arguments to dgit clone";
4712 $dstdir ||= "$package";
4713 if (stat_exists $dstdir) {
4714 fail f_ "%s already exists", $dstdir;
4718 if ($rmonerror && !$dryrun_level) {
4719 $cwd_remove= getcwd();
4721 return unless defined $cwd_remove;
4722 if (!chdir "$cwd_remove") {
4723 return if $!==&ENOENT;
4724 confess "chdir $cwd_remove: $!";
4726 printdebug "clone rmonerror removing $dstdir\n";
4728 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4729 } elsif (grep { $! == $_ }
4730 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4732 print STDERR f_ "check whether to remove %s: %s\n",
4739 $cwd_remove = undef;
4742 sub branchsuite () {
4743 my $branch = git_get_symref();
4744 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4751 sub package_from_d_control () {
4752 if (!defined $package) {
4753 my $sourcep = parsecontrol('debian/control','debian/control');
4754 $package = getfield $sourcep, 'Source';
4758 sub fetchpullargs () {
4759 package_from_d_control();
4761 $isuite = branchsuite();
4763 my $clogp = parsechangelog();
4764 my $clogsuite = getfield $clogp, 'Distribution';
4765 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4767 } elsif (@ARGV==1) {
4770 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4784 if (quiltmode_splitbrain()) {
4785 my ($format, $fopts) = get_source_format();
4786 madformat($format) and fail f_ <<END, $quilt_mode
4787 dgit pull not yet supported in split view mode (--quilt=%s)
4795 package_from_d_control();
4796 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4800 foreach my $canon (qw(0 1)) {
4805 canonicalise_suite();
4807 if (length git_get_ref lref()) {
4808 # local branch already exists, yay
4811 if (!length git_get_ref lrref()) {
4819 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4822 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4823 "dgit checkout $isuite";
4824 runcmd (@git, qw(checkout), lbranch());
4827 sub cmd_update_vcs_git () {
4829 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4830 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4832 ($specsuite) = (@ARGV);
4837 if ($ARGV[0] eq '-') {
4839 } elsif ($ARGV[0] eq '-') {
4844 package_from_d_control();
4846 if ($specsuite eq '.') {
4847 $ctrl = parsecontrol 'debian/control', 'debian/control';
4849 $isuite = $specsuite;
4853 my $url = getfield $ctrl, 'Vcs-Git';
4856 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4857 if (!defined $orgurl) {
4858 print STDERR f_ "setting up vcs-git: %s\n", $url;
4859 @cmd = (@git, qw(remote add vcs-git), $url);
4860 } elsif ($orgurl eq $url) {
4861 print STDERR f_ "vcs git already configured: %s\n", $url;
4863 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4864 @cmd = (@git, qw(remote set-url vcs-git), $url);
4866 runcmd_ordryrun_local @cmd;
4868 print f_ "fetching (%s)\n", "@ARGV";
4869 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4875 build_or_push_prep_early();
4880 } elsif (@ARGV==1) {
4881 ($specsuite) = (@ARGV);
4883 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4886 local ($package) = $existing_package; # this is a hack
4887 canonicalise_suite();
4889 canonicalise_suite();
4891 if (defined $specsuite &&
4892 $specsuite ne $isuite &&
4893 $specsuite ne $csuite) {
4894 fail f_ "dgit %s: changelog specifies %s (%s)".
4895 " but command line specifies %s",
4896 $subcommand, $isuite, $csuite, $specsuite;
4905 #---------- remote commands' implementation ----------
4907 sub pre_remote_push_build_host {
4908 my ($nrargs) = shift @ARGV;
4909 my (@rargs) = @ARGV[0..$nrargs-1];
4910 @ARGV = @ARGV[$nrargs..$#ARGV];
4912 my ($dir,$vsnwant) = @rargs;
4913 # vsnwant is a comma-separated list; we report which we have
4914 # chosen in our ready response (so other end can tell if they
4917 $we_are_responder = 1;
4918 $us .= " (build host)";
4920 open PI, "<&STDIN" or confess $!;
4921 open STDIN, "/dev/null" or confess $!;
4922 open PO, ">&STDOUT" or confess $!;
4924 open STDOUT, ">&STDERR" or confess $!;
4928 ($protovsn) = grep {
4929 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4930 } @rpushprotovsn_support;
4932 fail f_ "build host has dgit rpush protocol versions %s".
4933 " but invocation host has %s",
4934 (join ",", @rpushprotovsn_support), $vsnwant
4935 unless defined $protovsn;
4939 sub cmd_remote_push_build_host {
4940 responder_send_command("dgit-remote-push-ready $protovsn");
4944 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4945 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4946 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4947 # a good error message)
4949 sub rpush_handle_protovsn_bothends () {
4950 if ($protovsn < 4) {
4951 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4960 my $report = i_child_report();
4961 if (defined $report) {
4962 printdebug "($report)\n";
4963 } elsif ($i_child_pid) {
4964 printdebug "(killing build host child $i_child_pid)\n";
4965 kill 15, $i_child_pid;
4967 if (defined $i_tmp && !defined $initiator_tempdir) {
4969 eval { rmtree $i_tmp; };
4974 return unless forkcheck_mainprocess();
4979 my ($base,$selector,@args) = @_;
4980 $selector =~ s/\-/_/g;
4981 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4985 not_necessarily_a_tree();
4990 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4998 push @rargs, join ",", @rpushprotovsn_support;
5001 push @rdgit, @ropts;
5002 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5004 my @cmd = (@ssh, $host, shellquote @rdgit);
5007 $we_are_initiator=1;
5009 if (defined $initiator_tempdir) {
5010 rmtree $initiator_tempdir;
5011 mkdir $initiator_tempdir, 0700
5012 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5013 $i_tmp = $initiator_tempdir;
5017 $i_child_pid = open2(\*RO, \*RI, @cmd);
5019 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5020 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5021 $supplementary_message = '' unless $protovsn >= 3;
5024 my ($icmd,$iargs) = initiator_expect {
5025 m/^(\S+)(?: (.*))?$/;
5028 i_method "i_resp", $icmd, $iargs;
5032 sub i_resp_progress ($) {
5034 my $msg = protocol_read_bytes \*RO, $rhs;
5038 sub i_resp_supplementary_message ($) {
5040 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5043 sub i_resp_complete {
5044 my $pid = $i_child_pid;
5045 $i_child_pid = undef; # prevents killing some other process with same pid
5046 printdebug "waiting for build host child $pid...\n";
5047 my $got = waitpid $pid, 0;
5048 confess $! unless $got == $pid;
5049 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5052 printdebug __ "all done\n";
5056 sub i_resp_file ($) {
5058 my $localname = i_method "i_localname", $keyword;
5059 my $localpath = "$i_tmp/$localname";
5060 stat_exists $localpath and
5061 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5062 protocol_receive_file \*RO, $localpath;
5063 i_method "i_file", $keyword;
5068 sub i_resp_param ($) {
5069 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5073 sub i_resp_previously ($) {
5074 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5075 or badproto \*RO, __ "bad previously spec";
5076 my $r = system qw(git check-ref-format), $1;
5077 confess "bad previously ref spec ($r)" if $r;
5078 $previously{$1} = $2;
5083 sub i_resp_want ($) {
5085 die "$keyword ?" if $i_wanted{$keyword}++;
5087 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5088 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5089 die unless $isuite =~ m/^$suite_re$/;
5092 rpush_handle_protovsn_bothends();
5094 fail f_ "rpush negotiated protocol version %s".
5095 " which does not support quilt mode %s",
5096 $protovsn, $quilt_mode
5097 if quiltmode_splitbrain;
5099 my @localpaths = i_method "i_want", $keyword;
5100 printdebug "[[ $keyword @localpaths\n";
5101 foreach my $localpath (@localpaths) {
5102 protocol_send_file \*RI, $localpath;
5104 print RI "files-end\n" or confess $!;
5107 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5109 sub i_localname_parsed_changelog {
5110 return "remote-changelog.822";
5112 sub i_file_parsed_changelog {
5113 ($i_clogp, $i_version, $i_dscfn) =
5114 push_parse_changelog "$i_tmp/remote-changelog.822";
5115 die if $i_dscfn =~ m#/|^\W#;
5118 sub i_localname_dsc {
5119 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5124 sub i_localname_buildinfo ($) {
5125 my $bi = $i_param{'buildinfo-filename'};
5126 defined $bi or badproto \*RO, "buildinfo before filename";
5127 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5128 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5129 or badproto \*RO, "improper buildinfo filename";
5132 sub i_file_buildinfo {
5133 my $bi = $i_param{'buildinfo-filename'};
5134 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5135 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5136 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5137 files_compare_inputs($bd, $ch);
5138 (getfield $bd, $_) eq (getfield $ch, $_) or
5139 fail f_ "buildinfo mismatch in field %s", $_
5140 foreach qw(Source Version);
5141 !defined $bd->{$_} or
5142 fail f_ "buildinfo contains forbidden field %s", $_
5143 foreach qw(Changes Changed-by Distribution);
5145 push @i_buildinfos, $bi;
5146 delete $i_param{'buildinfo-filename'};
5149 sub i_localname_changes {
5150 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5151 $i_changesfn = $i_dscfn;
5152 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5153 return $i_changesfn;
5155 sub i_file_changes { }
5157 sub i_want_signed_tag {
5158 printdebug Dumper(\%i_param, $i_dscfn);
5159 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5160 && defined $i_param{'csuite'}
5161 or badproto \*RO, "premature desire for signed-tag";
5162 my $head = $i_param{'head'};
5163 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5165 my $maintview = $i_param{'maint-view'};
5166 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5169 if ($protovsn >= 4) {
5170 my $p = $i_param{'tagformat'} // '<undef>';
5172 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5175 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5177 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5179 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5182 push_mktags $i_clogp, $i_dscfn,
5183 $i_changesfn, (__ 'remote changes file'),
5187 sub i_want_signed_dsc_changes {
5188 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5189 sign_changes $i_changesfn;
5190 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5193 #---------- building etc. ----------
5199 #----- `3.0 (quilt)' handling -----
5201 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5203 sub quiltify_dpkg_commit ($$$;$) {
5204 my ($patchname,$author,$msg, $xinfo) = @_;
5207 mkpath '.git/dgit'; # we are in playtree
5208 my $descfn = ".git/dgit/quilt-description.tmp";
5209 open O, '>', $descfn or confess "$descfn: $!";
5210 $msg =~ s/\n+/\n\n/;
5211 print O <<END or confess $!;
5213 ${xinfo}Subject: $msg
5217 close O or confess $!;
5220 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5221 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5222 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5223 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5227 sub quiltify_trees_differ ($$;$$$) {
5228 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5229 # returns true iff the two tree objects differ other than in debian/
5230 # with $finegrained,
5231 # returns bitmask 01 - differ in upstream files except .gitignore
5232 # 02 - differ in .gitignore
5233 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5234 # is set for each modified .gitignore filename $fn
5235 # if $unrepres is defined, array ref to which is appeneded
5236 # a list of unrepresentable changes (removals of upstream files
5239 my @cmd = (@git, qw(diff-tree -z --no-renames));
5240 push @cmd, qw(--name-only) unless $unrepres;
5241 push @cmd, qw(-r) if $finegrained || $unrepres;
5243 my $diffs= cmdoutput @cmd;
5246 foreach my $f (split /\0/, $diffs) {
5247 if ($unrepres && !@lmodes) {
5248 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5251 my ($oldmode,$newmode) = @lmodes;
5254 next if $f =~ m#^debian(?:/.*)?$#s;
5258 die __ "not a plain file or symlink\n"
5259 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5260 $oldmode =~ m/^(?:10|12)\d{4}$/;
5261 if ($oldmode =~ m/[^0]/ &&
5262 $newmode =~ m/[^0]/) {
5263 # both old and new files exist
5264 die __ "mode or type changed\n" if $oldmode ne $newmode;
5265 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5266 } elsif ($oldmode =~ m/[^0]/) {
5268 die __ "deletion of symlink\n"
5269 unless $oldmode =~ m/^10/;
5272 die __ "creation with non-default mode\n"
5273 unless $newmode =~ m/^100644$/ or
5274 $newmode =~ m/^120000$/;
5278 local $/="\n"; chomp $@;
5279 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5283 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5284 $r |= $isignore ? 02 : 01;
5285 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5287 printdebug "quiltify_trees_differ $x $y => $r\n";
5291 sub quiltify_tree_sentinelfiles ($) {
5292 # lists the `sentinel' files present in the tree
5294 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5295 qw(-- debian/rules debian/control);
5300 sub quiltify_splitbrain_needed () {
5301 if (!$split_brain) {
5302 progress __ "dgit view: changes are required...";
5303 runcmd @git, qw(checkout -q -b dgit-view);
5308 sub quiltify_splitbrain ($$$$$$$) {
5309 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5310 $editedignores, $cachekey) = @_;
5311 my $gitignore_special = 1;
5312 if ($quilt_mode !~ m/gbp|dpm/) {
5313 # treat .gitignore just like any other upstream file
5314 $diffbits = { %$diffbits };
5315 $_ = !!$_ foreach values %$diffbits;
5316 $gitignore_special = 0;
5318 # We would like any commits we generate to be reproducible
5319 my @authline = clogp_authline($clogp);
5320 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5321 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5322 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5323 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5324 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5325 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5327 my $fulldiffhint = sub {
5329 my $cmd = "git diff $x $y -- :/ ':!debian'";
5330 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5331 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5335 if ($quilt_mode =~ m/gbp|unapplied/ &&
5336 ($diffbits->{O2H} & 01)) {
5338 "--quilt=%s specified, implying patches-unapplied git tree\n".
5339 " but git tree differs from orig in upstream files.",
5341 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5342 if (!stat_exists "debian/patches") {
5344 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5348 if ($quilt_mode =~ m/dpm/ &&
5349 ($diffbits->{H2A} & 01)) {
5350 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5351 --quilt=%s specified, implying patches-applied git tree
5352 but git tree differs from result of applying debian/patches to upstream
5355 if ($quilt_mode =~ m/gbp|unapplied/ &&
5356 ($diffbits->{O2A} & 01)) { # some patches
5357 quiltify_splitbrain_needed();
5358 progress __ "dgit view: creating patches-applied version using gbp pq";
5359 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5360 # gbp pq import creates a fresh branch; push back to dgit-view
5361 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5362 runcmd @git, qw(checkout -q dgit-view);
5364 if ($quilt_mode =~ m/gbp|dpm/ &&
5365 ($diffbits->{O2A} & 02)) {
5366 fail f_ <<END, $quilt_mode;
5367 --quilt=%s specified, implying that HEAD is for use with a
5368 tool which does not create patches for changes to upstream
5369 .gitignores: but, such patches exist in debian/patches.
5372 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5373 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5374 quiltify_splitbrain_needed();
5376 "dgit view: creating patch to represent .gitignore changes";
5377 ensuredir "debian/patches";
5378 my $gipatch = "debian/patches/auto-gitignore";
5379 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5380 stat GIPATCH or confess "$gipatch: $!";
5381 fail f_ "%s already exists; but want to create it".
5382 " to record .gitignore changes",
5385 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5386 Subject: Update .gitignore from Debian packaging branch
5388 The Debian packaging git branch contains these updates to the upstream
5389 .gitignore file(s). This patch is autogenerated, to provide these
5390 updates to users of the official Debian archive view of the package.
5393 [dgit ($our_version) update-gitignore]
5396 close GIPATCH or die "$gipatch: $!";
5397 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5398 $unapplied, $headref, "--", sort keys %$editedignores;
5399 open SERIES, "+>>", "debian/patches/series" or confess $!;
5400 defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
5402 defined read SERIES, $newline, 1 or confess $!;
5403 print SERIES "\n" or confess $! unless $newline eq "\n";
5404 print SERIES "auto-gitignore\n" or confess $!;
5405 close SERIES or die $!;
5406 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5407 commit_admin +(__ <<END).<<ENDU
5408 Commit patch to update .gitignore
5411 [dgit ($our_version) update-gitignore-quilt-fixup]
5415 my $dgitview = git_rev_parse 'HEAD';
5418 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5420 changedir "$playground/work";
5422 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5423 progress f_ "dgit view: created (%s)", $saved;
5426 sub quiltify ($$$$) {
5427 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5429 # Quilt patchification algorithm
5431 # We search backwards through the history of the main tree's HEAD
5432 # (T) looking for a start commit S whose tree object is identical
5433 # to to the patch tip tree (ie the tree corresponding to the
5434 # current dpkg-committed patch series). For these purposes
5435 # `identical' disregards anything in debian/ - this wrinkle is
5436 # necessary because dpkg-source treates debian/ specially.
5438 # We can only traverse edges where at most one of the ancestors'
5439 # trees differs (in changes outside in debian/). And we cannot
5440 # handle edges which change .pc/ or debian/patches. To avoid
5441 # going down a rathole we avoid traversing edges which introduce
5442 # debian/rules or debian/control. And we set a limit on the
5443 # number of edges we are willing to look at.
5445 # If we succeed, we walk forwards again. For each traversed edge
5446 # PC (with P parent, C child) (starting with P=S and ending with
5447 # C=T) to we do this:
5449 # - dpkg-source --commit with a patch name and message derived from C
5450 # After traversing PT, we git commit the changes which
5451 # should be contained within debian/patches.
5453 # The search for the path S..T is breadth-first. We maintain a
5454 # todo list containing search nodes. A search node identifies a
5455 # commit, and looks something like this:
5457 # Commit => $git_commit_id,
5458 # Child => $c, # or undef if P=T
5459 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5460 # Nontrivial => true iff $p..$c has relevant changes
5467 my %considered; # saves being exponential on some weird graphs
5469 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5472 my ($search,$whynot) = @_;
5473 printdebug " search NOT $search->{Commit} $whynot\n";
5474 $search->{Whynot} = $whynot;
5475 push @nots, $search;
5476 no warnings qw(exiting);
5485 my $c = shift @todo;
5486 next if $considered{$c->{Commit}}++;
5488 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5490 printdebug "quiltify investigate $c->{Commit}\n";
5493 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5494 printdebug " search finished hooray!\n";
5499 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5500 if ($quilt_mode eq 'smash') {
5501 printdebug " search quitting smash\n";
5505 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5506 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5507 if $c_sentinels ne $t_sentinels;
5509 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5510 $commitdata =~ m/\n\n/;
5512 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5513 @parents = map { { Commit => $_, Child => $c } } @parents;
5515 $not->($c, __ "root commit") if !@parents;
5517 foreach my $p (@parents) {
5518 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5520 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5521 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5524 foreach my $p (@parents) {
5525 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5527 my @cmd= (@git, qw(diff-tree -r --name-only),
5528 $p->{Commit},$c->{Commit},
5529 qw(-- debian/patches .pc debian/source/format));
5530 my $patchstackchange = cmdoutput @cmd;
5531 if (length $patchstackchange) {
5532 $patchstackchange =~ s/\n/,/g;
5533 $not->($p, f_ "changed %s", $patchstackchange);
5536 printdebug " search queue P=$p->{Commit} ",
5537 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5543 printdebug "quiltify want to smash\n";
5546 my $x = $_[0]{Commit};
5547 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5550 if ($quilt_mode eq 'linear') {
5552 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5554 my $all_gdr = !!@nots;
5555 foreach my $notp (@nots) {
5556 my $c = $notp->{Child};
5557 my $cprange = $abbrev->($notp);
5558 $cprange .= "..".$abbrev->($c) if $c;
5559 print STDERR f_ "%s: %s: %s\n",
5560 $us, $cprange, $notp->{Whynot};
5561 $all_gdr &&= $notp->{Child} &&
5562 (git_cat_file $notp->{Child}{Commit}, 'commit')
5563 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5567 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5569 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5571 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5572 } elsif ($quilt_mode eq 'smash') {
5573 } elsif ($quilt_mode eq 'auto') {
5574 progress __ "quilt fixup cannot be linear, smashing...";
5576 confess "$quilt_mode ?";
5579 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5580 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5582 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5584 quiltify_dpkg_commit "auto-$version-$target-$time",
5585 (getfield $clogp, 'Maintainer'),
5586 (f_ "Automatically generated patch (%s)\n".
5587 "Last (up to) %s git changes, FYI:\n\n",
5588 $clogp->{Version}, $ncommits).
5593 progress __ "quiltify linearisation planning successful, executing...";
5595 for (my $p = $sref_S;
5596 my $c = $p->{Child};
5598 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5599 next unless $p->{Nontrivial};
5601 my $cc = $c->{Commit};
5603 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5604 $commitdata =~ m/\n\n/ or die "$c ?";
5607 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5610 my $commitdate = cmdoutput
5611 @git, qw(log -n1 --pretty=format:%aD), $cc;
5613 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5615 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5622 my $gbp_check_suitable = sub {
5627 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5628 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5629 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5630 die __ "is series file\n" if m{$series_filename_re}o;
5631 die __ "too long\n" if length > 200;
5633 return $_ unless $@;
5635 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5640 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5642 (\S+) \s* \n //ixm) {
5643 $patchname = $gbp_check_suitable->($1, 'Name');
5645 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5647 (\S+) \s* \n //ixm) {
5648 $patchdir = $gbp_check_suitable->($1, 'Topic');
5653 if (!defined $patchname) {
5654 $patchname = $title;
5655 $patchname =~ s/[.:]$//;
5658 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5659 my $translitname = $converter->convert($patchname);
5660 die unless defined $translitname;
5661 $patchname = $translitname;
5664 +(f_ "dgit: patch title transliteration error: %s", $@)
5666 $patchname =~ y/ A-Z/-a-z/;
5667 $patchname =~ y/-a-z0-9_.+=~//cd;
5668 $patchname =~ s/^\W/x-$&/;
5669 $patchname = substr($patchname,0,40);
5670 $patchname .= ".patch";
5672 if (!defined $patchdir) {
5675 if (length $patchdir) {
5676 $patchname = "$patchdir/$patchname";
5678 if ($patchname =~ m{^(.*)/}) {
5679 mkpath "debian/patches/$1";
5684 stat "debian/patches/$patchname$index";
5686 $!==ENOENT or confess "$patchname$index $!";
5688 runcmd @git, qw(checkout -q), $cc;
5690 # We use the tip's changelog so that dpkg-source doesn't
5691 # produce complaining messages from dpkg-parsechangelog. None
5692 # of the information dpkg-source gets from the changelog is
5693 # actually relevant - it gets put into the original message
5694 # which dpkg-source provides our stunt editor, and then
5696 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5698 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5699 "Date: $commitdate\n".
5700 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5702 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5705 runcmd @git, qw(checkout -q master);
5708 sub build_maybe_quilt_fixup () {
5709 my ($format,$fopts) = get_source_format;
5710 return unless madformat_wantfixup $format;
5713 check_for_vendor_patches();
5715 if (quiltmode_splitbrain) {
5716 fail <<END unless access_cfg_tagformats_can_splitbrain;
5717 quilt mode $quilt_mode requires split view so server needs to support
5718 both "new" and "maint" tag formats, but config says it doesn't.
5722 my $clogp = parsechangelog();
5723 my $headref = git_rev_parse('HEAD');
5724 my $symref = git_get_symref();
5726 if ($quilt_mode eq 'linear'
5727 && !$fopts->{'single-debian-patch'}
5728 && branch_is_gdr($headref)) {
5729 # This is much faster. It also makes patches that gdr
5730 # likes better for future updates without laundering.
5732 # However, it can fail in some casses where we would
5733 # succeed: if there are existing patches, which correspond
5734 # to a prefix of the branch, but are not in gbp/gdr
5735 # format, gdr will fail (exiting status 7), but we might
5736 # be able to figure out where to start linearising. That
5737 # will be slower so hopefully there's not much to do.
5738 my @cmd = (@git_debrebase,
5739 qw(--noop-ok -funclean-mixed -funclean-ordering
5740 make-patches --quiet-would-amend));
5741 # We tolerate soe snags that gdr wouldn't, by default.
5747 and not ($? == 7*256 or
5748 $? == -1 && $!==ENOENT);
5752 $headref = git_rev_parse('HEAD');
5756 changedir $playground;
5758 my $upstreamversion = upstreamversion $version;
5760 if ($fopts->{'single-debian-patch'}) {
5761 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5763 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5767 runcmd_ordryrun_local
5768 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5771 sub unpack_playtree_mkwork ($) {
5774 mkdir "work" or confess $!;
5776 mktree_in_ud_here();
5777 runcmd @git, qw(reset -q --hard), $headref;
5780 sub unpack_playtree_linkorigs ($$) {
5781 my ($upstreamversion, $fn) = @_;
5782 # calls $fn->($leafname);
5784 my $bpd_abs = bpd_abs();
5785 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5786 while ($!=0, defined(my $b = readdir QFD)) {
5787 my $f = bpd_abs()."/".$b;
5789 local ($debuglevel) = $debuglevel-1;
5790 printdebug "QF linkorigs $b, $f ?\n";
5792 next unless is_orig_file_of_vsn $b, $upstreamversion;
5793 printdebug "QF linkorigs $b, $f Y\n";
5794 link_ltarget $f, $b or die "$b $!";
5797 die "$buildproductsdir: $!" if $!;
5801 sub quilt_fixup_delete_pc () {
5802 runcmd @git, qw(rm -rqf .pc);
5803 commit_admin +(__ <<END).<<ENDU
5804 Commit removal of .pc (quilt series tracking data)
5807 [dgit ($our_version) upgrade quilt-remove-pc]
5811 sub quilt_fixup_singlepatch ($$$) {
5812 my ($clogp, $headref, $upstreamversion) = @_;
5814 progress __ "starting quiltify (single-debian-patch)";
5816 # dpkg-source --commit generates new patches even if
5817 # single-debian-patch is in debian/source/options. In order to
5818 # get it to generate debian/patches/debian-changes, it is
5819 # necessary to build the source package.
5821 unpack_playtree_linkorigs($upstreamversion, sub { });
5822 unpack_playtree_mkwork($headref);
5824 rmtree("debian/patches");
5826 runcmd @dpkgsource, qw(-b .);
5828 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5829 rename srcfn("$upstreamversion", "/debian/patches"),
5830 "work/debian/patches"
5832 or confess "install d/patches: $!";
5835 commit_quilty_patch();
5838 sub quilt_make_fake_dsc ($) {
5839 my ($upstreamversion) = @_;
5841 my $fakeversion="$upstreamversion-~~DGITFAKE";
5843 my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
5844 print $fakedsc <<END or confess $!;
5847 Version: $fakeversion
5851 my $dscaddfile=sub {
5854 my $md = new Digest::MD5;
5856 my $fh = new IO::File $b, '<' or die "$b $!";
5857 stat $fh or confess $!;
5861 print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!;
5864 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5866 my @files=qw(debian/source/format debian/rules
5867 debian/control debian/changelog);
5868 foreach my $maybe (qw(debian/patches debian/source/options
5869 debian/tests/control)) {
5870 next unless stat_exists "$maindir/$maybe";
5871 push @files, $maybe;
5874 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5875 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5877 $dscaddfile->($debtar);
5878 close $fakedsc or confess $!;
5881 sub quilt_fakedsc2unapplied ($$) {
5882 my ($headref, $upstreamversion) = @_;
5883 # must be run in the playground
5884 # quilt_make_fake_dsc must have been called
5887 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5889 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5890 rename $fakexdir, "fake" or die "$fakexdir $!";
5894 remove_stray_gits(__ "source package");
5895 mktree_in_ud_here();
5899 rmtree 'debian'; # git checkout commitish paths does not delete!
5900 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5901 my $unapplied=git_add_write_tree();
5902 printdebug "fake orig tree object $unapplied\n";
5906 sub quilt_check_splitbrain_cache ($$) {
5907 my ($headref, $upstreamversion) = @_;
5908 # Called only if we are in (potentially) split brain mode.
5909 # Called in playground.
5910 # Computes the cache key and looks in the cache.
5911 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5913 my $splitbrain_cachekey;
5916 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5918 # we look in the reflog of dgit-intern/quilt-cache
5919 # we look for an entry whose message is the key for the cache lookup
5920 my @cachekey = (qw(dgit), $our_version);
5921 push @cachekey, $upstreamversion;
5922 push @cachekey, $quilt_mode;
5923 push @cachekey, $headref;
5925 push @cachekey, hashfile('fake.dsc');
5927 my $srcshash = Digest::SHA->new(256);
5928 my %sfs = ( %INC, '$0(dgit)' => $0 );
5929 foreach my $sfk (sort keys %sfs) {
5930 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5931 $srcshash->add($sfk," ");
5932 $srcshash->add(hashfile($sfs{$sfk}));
5933 $srcshash->add("\n");
5935 push @cachekey, $srcshash->hexdigest();
5936 $splitbrain_cachekey = "@cachekey";
5938 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5940 my $cachehit = reflog_cache_lookup
5941 "refs/$splitbraincache", $splitbrain_cachekey;
5944 unpack_playtree_mkwork($headref);
5945 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5946 if ($cachehit ne $headref) {
5947 progress f_ "dgit view: found cached (%s)", $saved;
5948 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5950 return ($cachehit, $splitbrain_cachekey);
5952 progress __ "dgit view: found cached, no changes required";
5953 return ($headref, $splitbrain_cachekey);
5956 printdebug "splitbrain cache miss\n";
5957 return (undef, $splitbrain_cachekey);
5960 sub quilt_fixup_multipatch ($$$) {
5961 my ($clogp, $headref, $upstreamversion) = @_;
5963 progress f_ "examining quilt state (multiple patches, %s mode)",
5967 # - honour any existing .pc in case it has any strangeness
5968 # - determine the git commit corresponding to the tip of
5969 # the patch stack (if there is one)
5970 # - if there is such a git commit, convert each subsequent
5971 # git commit into a quilt patch with dpkg-source --commit
5972 # - otherwise convert all the differences in the tree into
5973 # a single git commit
5977 # Our git tree doesn't necessarily contain .pc. (Some versions of
5978 # dgit would include the .pc in the git tree.) If there isn't
5979 # one, we need to generate one by unpacking the patches that we
5982 # We first look for a .pc in the git tree. If there is one, we
5983 # will use it. (This is not the normal case.)
5985 # Otherwise need to regenerate .pc so that dpkg-source --commit
5986 # can work. We do this as follows:
5987 # 1. Collect all relevant .orig from parent directory
5988 # 2. Generate a debian.tar.gz out of
5989 # debian/{patches,rules,source/format,source/options}
5990 # 3. Generate a fake .dsc containing just these fields:
5991 # Format Source Version Files
5992 # 4. Extract the fake .dsc
5993 # Now the fake .dsc has a .pc directory.
5994 # (In fact we do this in every case, because in future we will
5995 # want to search for a good base commit for generating patches.)
5997 # Then we can actually do the dpkg-source --commit
5998 # 1. Make a new working tree with the same object
5999 # store as our main tree and check out the main
6001 # 2. Copy .pc from the fake's extraction, if necessary
6002 # 3. Run dpkg-source --commit
6003 # 4. If the result has changes to debian/, then
6004 # - git add them them
6005 # - git add .pc if we had a .pc in-tree
6007 # 5. If we had a .pc in-tree, delete it, and git commit
6008 # 6. Back in the main tree, fast forward to the new HEAD
6010 # Another situation we may have to cope with is gbp-style
6011 # patches-unapplied trees.
6013 # We would want to detect these, so we know to escape into
6014 # quilt_fixup_gbp. However, this is in general not possible.
6015 # Consider a package with a one patch which the dgit user reverts
6016 # (with git revert or the moral equivalent).
6018 # That is indistinguishable in contents from a patches-unapplied
6019 # tree. And looking at the history to distinguish them is not
6020 # useful because the user might have made a confusing-looking git
6021 # history structure (which ought to produce an error if dgit can't
6022 # cope, not a silent reintroduction of an unwanted patch).
6024 # So gbp users will have to pass an option. But we can usually
6025 # detect their failure to do so: if the tree is not a clean
6026 # patches-applied tree, quilt linearisation fails, but the tree
6027 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6028 # they want --quilt=unapplied.
6030 # To help detect this, when we are extracting the fake dsc, we
6031 # first extract it with --skip-patches, and then apply the patches
6032 # afterwards with dpkg-source --before-build. That lets us save a
6033 # tree object corresponding to .origs.
6035 my $splitbrain_cachekey;
6037 quilt_make_fake_dsc($upstreamversion);
6039 if (quiltmode_splitbrain()) {
6041 ($cachehit, $splitbrain_cachekey) =
6042 quilt_check_splitbrain_cache($headref, $upstreamversion);
6043 return if $cachehit;
6045 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6049 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6051 if (system @bbcmd) {
6052 failedcmd @bbcmd if $? < 0;
6054 failed to apply your git tree's patch stack (from debian/patches/) to
6055 the corresponding upstream tarball(s). Your source tree and .orig
6056 are probably too inconsistent. dgit can only fix up certain kinds of
6057 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6063 unpack_playtree_mkwork($headref);
6066 if (stat_exists ".pc") {
6068 progress __ "Tree already contains .pc - will use it then delete it.";
6071 rename '../fake/.pc','.pc' or confess $!;
6074 changedir '../fake';
6076 my $oldtiptree=git_add_write_tree();
6077 printdebug "fake o+d/p tree object $unapplied\n";
6078 changedir '../work';
6081 # We calculate some guesswork now about what kind of tree this might
6082 # be. This is mostly for error reporting.
6088 # O = orig, without patches applied
6089 # A = "applied", ie orig with H's debian/patches applied
6090 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6091 \%editedignores, \@unrepres),
6092 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6093 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6097 foreach my $b (qw(01 02)) {
6098 foreach my $v (qw(O2H O2A H2A)) {
6099 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
6102 printdebug "differences \@dl @dl.\n";
6105 "%s: base trees orig=%.20s o+d/p=%.20s",
6106 $us, $unapplied, $oldtiptree;
6108 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6109 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6110 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6111 $us, $dl[2], $dl[5];
6114 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6117 forceable_fail [qw(unrepresentable)], __ <<END;
6118 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6123 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6124 push @failsuggestion, [ 'unapplied', __
6125 "This might be a patches-unapplied branch." ];
6126 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6127 push @failsuggestion, [ 'applied', __
6128 "This might be a patches-applied branch." ];
6130 push @failsuggestion, [ 'quilt-mode', __
6131 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6133 push @failsuggestion, [ 'gitattrs', __
6134 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6135 if stat_exists '.gitattributes';
6137 push @failsuggestion, [ 'origs', __
6138 "Maybe orig tarball(s) are not identical to git representation?" ];
6140 if (quiltmode_splitbrain()) {
6141 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6142 $diffbits, \%editedignores,
6143 $splitbrain_cachekey);
6147 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6148 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6150 if (!open P, '>>', ".pc/applied-patches") {
6151 $!==&ENOENT or confess $!;
6156 commit_quilty_patch();
6158 if ($mustdeletepc) {
6159 quilt_fixup_delete_pc();
6163 sub quilt_fixup_editor () {
6164 my $descfn = $ENV{$fakeeditorenv};
6165 my $editing = $ARGV[$#ARGV];
6166 open I1, '<', $descfn or confess "$descfn: $!";
6167 open I2, '<', $editing or confess "$editing: $!";
6168 unlink $editing or confess "$editing: $!";
6169 open O, '>', $editing or confess "$editing: $!";
6170 while (<I1>) { print O or confess $!; } I1->error and confess $!;
6173 $copying ||= m/^\-\-\- /;
6174 next unless $copying;
6175 print O or confess $!;
6177 I2->error and confess $!;
6182 sub maybe_apply_patches_dirtily () {
6183 return unless $quilt_mode =~ m/gbp|unapplied/;
6184 print STDERR __ <<END or confess $!;
6186 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6187 dgit: Have to apply the patches - making the tree dirty.
6188 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6191 $patches_applied_dirtily = 01;
6192 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6193 runcmd qw(dpkg-source --before-build .);
6196 sub maybe_unapply_patches_again () {
6197 progress __ "dgit: Unapplying patches again to tidy up the tree."
6198 if $patches_applied_dirtily;
6199 runcmd qw(dpkg-source --after-build .)
6200 if $patches_applied_dirtily & 01;
6202 if $patches_applied_dirtily & 02;
6203 $patches_applied_dirtily = 0;
6206 #----- other building -----
6208 sub clean_tree_check_git ($$) {
6209 my ($honour_ignores, $message) = @_;
6210 my @cmd = (@git, qw(clean -dn));
6211 push @cmd, qw(-x) unless $honour_ignores;
6212 my $leftovers = cmdoutput @cmd;
6213 if (length $leftovers) {
6214 print STDERR $leftovers, "\n" or confess $!;
6219 sub clean_tree_check_git_wd ($) {
6221 return if $cleanmode =~ m{no-check};
6222 return if $patches_applied_dirtily; # yuk
6223 clean_tree_check_git +($cleanmode !~ m{all-check}),
6224 (f_ <<END, $message);
6226 If this is just missing .gitignore entries, use a different clean
6227 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6228 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6232 sub clean_tree_check () {
6233 # Not yet fully implemented.
6234 # This function needs to not care about modified but tracked files.
6235 # That was done by check_not_dirty, and by now we may have run
6236 # the rules clean target which might modify tracked files (!)
6237 if ($cleanmode =~ m{^check}) {
6238 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6239 "tree contains uncommitted files and --clean=check specified";
6240 } elsif ($cleanmode =~ m{^dpkg-source}) {
6241 clean_tree_check_git_wd __
6242 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6243 } elsif ($cleanmode =~ m{^git}) {
6244 # If we were actually cleaning these files would be summarily
6245 # deleted. Since we're not, and not using the working tree
6246 # anyway, we can just ignore them - nothing will use them.
6247 } elsif ($cleanmode eq 'none') {
6249 confess "$cleanmode ?";
6254 # We always clean the tree ourselves, rather than leave it to the
6255 # builder (dpkg-source, or soemthing which calls dpkg-source).
6256 if ($cleanmode =~ m{^dpkg-source}) {
6257 my @cmd = @dpkgbuildpackage;
6258 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6259 push @cmd, qw(-T clean);
6260 maybe_apply_patches_dirtily();
6261 runcmd_ordryrun_local @cmd;
6262 clean_tree_check_git_wd __
6263 "tree contains uncommitted files (after running rules clean)";
6264 } elsif ($cleanmode eq 'git') {
6265 runcmd_ordryrun_local @git, qw(clean -xdf);
6266 } elsif ($cleanmode eq 'git-ff') {
6267 runcmd_ordryrun_local @git, qw(clean -xdff);
6268 } elsif ($cleanmode =~ m{^check}) {
6270 } elsif ($cleanmode eq 'none') {
6272 confess "$cleanmode ?";
6277 badusage __ "clean takes no additional arguments" if @ARGV;
6280 maybe_unapply_patches_again();
6283 # return values from massage_dbp_args are one or both of these flags
6284 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6285 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6287 sub build_or_push_prep_early () {
6288 our $build_or_push_prep_early_done //= 0;
6289 return if $build_or_push_prep_early_done++;
6290 badusage f_ "-p is not allowed with dgit %s", $subcommand
6291 if defined $package;
6292 my $clogp = parsechangelog();
6293 $isuite = getfield $clogp, 'Distribution';
6294 $package = getfield $clogp, 'Source';
6295 $version = getfield $clogp, 'Version';
6296 $dscfn = dscfn($version);
6299 sub build_prep_early () {
6300 build_or_push_prep_early();
6305 sub build_prep ($) {
6308 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)) {
6309 # Clean the tree because we're going to use the contents of
6310 # $maindir. (We trying to include dirty changes in the source
6311 # package, or we are running the builder in $maindir.)
6314 # We don't actually need to do anything in $maindir, but we
6315 # should do some kind of cleanliness check because (i) the
6316 # user may have forgotten a `git add', and (ii) if the user
6317 # said -wc we should still do the check.
6320 build_maybe_quilt_fixup();
6322 my $pat = changespat $version;
6323 foreach my $f (glob "$buildproductsdir/$pat") {
6326 fail f_ "remove old changes file %s: %s", $f, $!;
6328 progress f_ "would remove %s", $f;
6334 sub changesopts_initial () {
6335 my @opts =@changesopts[1..$#changesopts];
6338 sub changesopts_version () {
6339 if (!defined $changes_since_version) {
6342 @vsns = archive_query('archive_query');
6343 my @quirk = access_quirk();
6344 if ($quirk[0] eq 'backports') {
6345 local $isuite = $quirk[2];
6347 canonicalise_suite();
6348 push @vsns, archive_query('archive_query');
6354 "archive query failed (queried because --since-version not specified)";
6357 @vsns = map { $_->[0] } @vsns;
6358 @vsns = sort { -version_compare($a, $b) } @vsns;
6359 $changes_since_version = $vsns[0];
6360 progress f_ "changelog will contain changes since %s", $vsns[0];
6362 $changes_since_version = '_';
6363 progress __ "package seems new, not specifying -v<version>";
6366 if ($changes_since_version ne '_') {
6367 return ("-v$changes_since_version");
6373 sub changesopts () {
6374 return (changesopts_initial(), changesopts_version());
6377 sub massage_dbp_args ($;$) {
6378 my ($cmd,$xargs) = @_;
6379 # Since we split the source build out so we can do strange things
6380 # to it, massage the arguments to dpkg-buildpackage so that the
6381 # main build doessn't build source (or add an argument to stop it
6382 # building source by default).
6383 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6384 # -nc has the side effect of specifying -b if nothing else specified
6385 # and some combinations of -S, -b, et al, are errors, rather than
6386 # later simply overriding earlie. So we need to:
6387 # - search the command line for these options
6388 # - pick the last one
6389 # - perhaps add our own as a default
6390 # - perhaps adjust it to the corresponding non-source-building version
6392 foreach my $l ($cmd, $xargs) {
6394 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6397 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6398 my $r = WANTSRC_BUILDER;
6399 printdebug "massage split $dmode.\n";
6400 if ($dmode =~ s/^--build=//) {
6402 my @d = split /,/, $dmode;
6403 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6404 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6405 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6406 fail __ "Wanted to build nothing!" unless $r;
6407 $dmode = '--build='. join ',', grep m/./, @d;
6410 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6411 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6412 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6415 printdebug "massage done $r $dmode.\n";
6417 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6423 my $wasdir = must_getcwd();
6424 changedir $buildproductsdir;
6429 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6430 sub postbuild_mergechanges ($) {
6431 my ($msg_if_onlyone) = @_;
6432 # If there is only one .changes file, fail with $msg_if_onlyone,
6433 # or if that is undef, be a no-op.
6434 # Returns the changes file to report to the user.
6435 my $pat = changespat $version;
6436 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6437 @changesfiles = sort {
6438 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6442 if (@changesfiles==1) {
6443 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6444 only one changes file from build (%s)
6446 if defined $msg_if_onlyone;
6447 $result = $changesfiles[0];
6448 } elsif (@changesfiles==2) {
6449 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6450 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6451 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6454 runcmd_ordryrun_local @mergechanges, @changesfiles;
6455 my $multichanges = changespat $version,'multi';
6457 stat_exists $multichanges or fail f_
6458 "%s unexpectedly not created by build", $multichanges;
6459 foreach my $cf (glob $pat) {
6460 next if $cf eq $multichanges;
6461 rename "$cf", "$cf.inmulti" or fail f_
6462 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6465 $result = $multichanges;
6467 fail f_ "wrong number of different changes files (%s)",
6470 printdone f_ "build successful, results in %s\n", $result
6474 sub midbuild_checkchanges () {
6475 my $pat = changespat $version;
6476 return if $rmchanges;
6477 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6479 $_ ne changespat $version,'source' and
6480 $_ ne changespat $version,'multi'
6482 fail +(f_ <<END, $pat, "@unwanted")
6483 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6484 Suggest you delete %s.
6489 sub midbuild_checkchanges_vanilla ($) {
6491 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6494 sub postbuild_mergechanges_vanilla ($) {
6496 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6498 postbuild_mergechanges(undef);
6501 printdone __ "build successful\n";
6507 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6508 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6509 %s: warning: build-products-dir will be ignored; files will go to ..
6511 $buildproductsdir = '..';
6512 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6513 my $wantsrc = massage_dbp_args \@dbp;
6514 build_prep($wantsrc);
6515 if ($wantsrc & WANTSRC_SOURCE) {
6517 midbuild_checkchanges_vanilla $wantsrc;
6519 if ($wantsrc & WANTSRC_BUILDER) {
6520 push @dbp, changesopts_version();
6521 maybe_apply_patches_dirtily();
6522 runcmd_ordryrun_local @dbp;
6524 maybe_unapply_patches_again();
6525 postbuild_mergechanges_vanilla $wantsrc;
6529 $quilt_mode //= 'gbp';
6535 # gbp can make .origs out of thin air. In my tests it does this
6536 # even for a 1.0 format package, with no origs present. So I
6537 # guess it keys off just the version number. We don't know
6538 # exactly what .origs ought to exist, but let's assume that we
6539 # should run gbp if: the version has an upstream part and the main
6541 my $upstreamversion = upstreamversion $version;
6542 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6543 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6545 if ($gbp_make_orig) {
6547 $cleanmode = 'none'; # don't do it again
6550 my @dbp = @dpkgbuildpackage;
6552 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6554 if (!length $gbp_build[0]) {
6555 if (length executable_on_path('git-buildpackage')) {
6556 $gbp_build[0] = qw(git-buildpackage);
6558 $gbp_build[0] = 'gbp buildpackage';
6561 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6563 push @cmd, (qw(-us -uc --git-no-sign-tags),
6564 "--git-builder=".(shellquote @dbp));
6566 if ($gbp_make_orig) {
6567 my $priv = dgit_privdir();
6568 my $ok = "$priv/origs-gen-ok";
6569 unlink $ok or $!==&ENOENT or confess $!;
6570 my @origs_cmd = @cmd;
6571 push @origs_cmd, qw(--git-cleaner=true);
6572 push @origs_cmd, "--git-prebuild=".
6573 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6574 push @origs_cmd, @ARGV;
6576 debugcmd @origs_cmd;
6578 do { local $!; stat_exists $ok; }
6579 or failedcmd @origs_cmd;
6581 dryrun_report @origs_cmd;
6585 build_prep($wantsrc);
6586 if ($wantsrc & WANTSRC_SOURCE) {
6588 midbuild_checkchanges_vanilla $wantsrc;
6590 push @cmd, '--git-cleaner=true';
6592 maybe_unapply_patches_again();
6593 if ($wantsrc & WANTSRC_BUILDER) {
6594 push @cmd, changesopts();
6595 runcmd_ordryrun_local @cmd, @ARGV;
6597 postbuild_mergechanges_vanilla $wantsrc;
6599 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6601 sub building_source_in_playtree {
6602 # If $includedirty, we have to build the source package from the
6603 # working tree, not a playtree, so that uncommitted changes are
6604 # included (copying or hardlinking them into the playtree could
6607 # Note that if we are building a source package in split brain
6608 # mode we do not support including uncommitted changes, because
6609 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6610 # building a source package)) => !$includedirty
6611 return !$includedirty;
6615 $sourcechanges = changespat $version,'source';
6617 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6618 or fail f_ "remove %s: %s", $sourcechanges, $!;
6620 my @cmd = (@dpkgsource, qw(-b --));
6622 if (building_source_in_playtree()) {
6624 my $headref = git_rev_parse('HEAD');
6625 # If we are in split brain, there is already a playtree with
6626 # the thing we should package into a .dsc (thanks to quilt
6627 # fixup). If not, make a playtree
6628 prep_ud() unless $split_brain;
6629 changedir $playground;
6630 unless ($split_brain) {
6631 my $upstreamversion = upstreamversion $version;
6632 unpack_playtree_linkorigs($upstreamversion, sub { });
6633 unpack_playtree_mkwork($headref);
6637 $leafdir = basename $maindir;
6639 if ($buildproductsdir ne '..') {
6640 # Well, we are going to run dpkg-source -b which consumes
6641 # origs from .. and generates output there. To make this
6642 # work when the bpd is not .. , we would have to (i) link
6643 # origs from bpd to .. , (ii) check for files that
6644 # dpkg-source -b would/might overwrite, and afterwards
6645 # (iii) move all the outputs back to the bpd (iv) except
6646 # for the origs which should be deleted from .. if they
6647 # weren't there beforehand. And if there is an error and
6648 # we don't run to completion we would necessarily leave a
6649 # mess. This is too much. The real way to fix this
6650 # is for dpkg-source to have bpd support.
6651 confess unless $includedirty;
6653 "--include-dirty not supported with --build-products-dir, sorry";
6658 runcmd_ordryrun_local @cmd, $leafdir;
6661 runcmd_ordryrun_local qw(sh -ec),
6662 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6663 @dpkggenchanges, qw(-S), changesopts();
6666 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6667 $dsc = parsecontrol($dscfn, "source package");
6671 printdebug " renaming ($why) $l\n";
6672 rename_link_xf 0, "$l", bpd_abs()."/$l"
6673 or fail f_ "put in place new built file (%s): %s", $l, $@;
6675 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6676 $l =~ m/\S+$/ or next;
6679 $mv->('dsc', $dscfn);
6680 $mv->('changes', $sourcechanges);
6685 sub cmd_build_source {
6686 badusage __ "build-source takes no additional arguments" if @ARGV;
6687 build_prep(WANTSRC_SOURCE);
6689 maybe_unapply_patches_again();
6690 printdone f_ "source built, results in %s and %s",
6691 $dscfn, $sourcechanges;
6694 sub cmd_push_source {
6697 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6698 "sense with push-source!"
6700 build_maybe_quilt_fixup();
6702 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6703 __ "source changes file");
6704 unless (test_source_only_changes($changes)) {
6705 fail __ "user-specified changes file is not source-only";
6708 # Building a source package is very fast, so just do it
6710 confess "er, patches are applied dirtily but shouldn't be.."
6711 if $patches_applied_dirtily;
6712 $changesfile = $sourcechanges;
6717 sub binary_builder {
6718 my ($bbuilder, $pbmc_msg, @args) = @_;
6719 build_prep(WANTSRC_SOURCE);
6721 midbuild_checkchanges();
6724 stat_exists $dscfn or fail f_
6725 "%s (in build products dir): %s", $dscfn, $!;
6726 stat_exists $sourcechanges or fail f_
6727 "%s (in build products dir): %s", $sourcechanges, $!;
6729 runcmd_ordryrun_local @$bbuilder, @args;
6731 maybe_unapply_patches_again();
6733 postbuild_mergechanges($pbmc_msg);
6739 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6740 perhaps you need to pass -A ? (sbuild's default is to build only
6741 arch-specific binaries; dgit 1.4 used to override that.)
6746 my ($pbuilder) = @_;
6748 # @ARGV is allowed to contain only things that should be passed to
6749 # pbuilder under debbuildopts; just massage those
6750 my $wantsrc = massage_dbp_args \@ARGV;
6752 "you asked for a builder but your debbuildopts didn't ask for".
6753 " any binaries -- is this really what you meant?"
6754 unless $wantsrc & WANTSRC_BUILDER;
6756 "we must build a .dsc to pass to the builder but your debbuiltopts".
6757 " forbids the building of a source package; cannot continue"
6758 unless $wantsrc & WANTSRC_SOURCE;
6759 # We do not want to include the verb "build" in @pbuilder because
6760 # the user can customise @pbuilder and they shouldn't be required
6761 # to include "build" in their customised value. However, if the
6762 # user passes any additional args to pbuilder using the dgit
6763 # option --pbuilder:foo, such args need to come after the "build"
6764 # verb. opts_opt_multi_cmd does all of that.
6765 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6766 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6771 pbuilder(\@pbuilder);
6774 sub cmd_cowbuilder {
6775 pbuilder(\@cowbuilder);
6778 sub cmd_quilt_fixup {
6779 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6782 build_maybe_quilt_fixup();
6785 sub cmd_print_unapplied_treeish {
6786 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6788 my $headref = git_rev_parse('HEAD');
6789 my $clogp = commit_getclogp $headref;
6790 $package = getfield $clogp, 'Source';
6791 $version = getfield $clogp, 'Version';
6792 $isuite = getfield $clogp, 'Distribution';
6793 $csuite = $isuite; # we want this to be offline!
6797 changedir $playground;
6798 my $uv = upstreamversion $version;
6799 quilt_make_fake_dsc($uv);
6800 my $u = quilt_fakedsc2unapplied($headref, $uv);
6801 print $u, "\n" or confess $!;
6804 sub import_dsc_result {
6805 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6806 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6808 check_gitattrs($newhash, __ "source tree");
6810 progress f_ "dgit: import-dsc: %s", $what_msg;
6813 sub cmd_import_dsc {
6817 last unless $ARGV[0] =~ m/^-/;
6820 if (m/^--require-valid-signature$/) {
6823 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6827 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6829 my ($dscfn, $dstbranch) = @ARGV;
6831 badusage __ "dry run makes no sense with import-dsc"
6834 my $force = $dstbranch =~ s/^\+// ? +1 :
6835 $dstbranch =~ s/^\.\.// ? -1 :
6837 my $info = $force ? " $&" : '';
6838 $info = "$dscfn$info";
6840 my $specbranch = $dstbranch;
6841 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6842 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6844 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6845 my $chead = cmdoutput_errok @symcmd;
6846 defined $chead or $?==256 or failedcmd @symcmd;
6848 fail f_ "%s is checked out - will not update it", $dstbranch
6849 if defined $chead and $chead eq $dstbranch;
6851 my $oldhash = git_get_ref $dstbranch;
6853 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6854 $dscdata = do { local $/ = undef; <D>; };
6855 D->error and fail f_ "read %s: %s", $dscfn, $!;
6858 # we don't normally need this so import it here
6859 use Dpkg::Source::Package;
6860 my $dp = new Dpkg::Source::Package filename => $dscfn,
6861 require_valid_signature => $needsig;
6863 local $SIG{__WARN__} = sub {
6865 return unless $needsig;
6866 fail __ "import-dsc signature check failed";
6868 if (!$dp->is_signed()) {
6869 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6871 my $r = $dp->check_signature();
6872 confess "->check_signature => $r" if $needsig && $r;
6878 $package = getfield $dsc, 'Source';
6880 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6881 unless forceing [qw(import-dsc-with-dgit-field)];
6882 parse_dsc_field_def_dsc_distro();
6884 $isuite = 'DGIT-IMPORT-DSC';
6885 $idistro //= $dsc_distro;
6889 if (defined $dsc_hash) {
6891 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6892 resolve_dsc_field_commit undef, undef;
6894 if (defined $dsc_hash) {
6895 my @cmd = (qw(sh -ec),
6896 "echo $dsc_hash | git cat-file --batch-check");
6897 my $objgot = cmdoutput @cmd;
6898 if ($objgot =~ m#^\w+ missing\b#) {
6899 fail f_ <<END, $dsc_hash
6900 .dsc contains Dgit field referring to object %s
6901 Your git tree does not have that object. Try `git fetch' from a
6902 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6905 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6907 progress __ "Not fast forward, forced update.";
6909 fail f_ "Not fast forward to %s", $dsc_hash;
6912 import_dsc_result $dstbranch, $dsc_hash,
6913 "dgit import-dsc (Dgit): $info",
6914 f_ "updated git ref %s", $dstbranch;
6918 fail f_ <<END, $dstbranch, $specbranch, $specbranch
6919 Branch %s already exists
6920 Specify ..%s for a pseudo-merge, binding in existing history
6921 Specify +%s to overwrite, discarding existing history
6923 if $oldhash && !$force;
6925 my @dfi = dsc_files_info();
6926 foreach my $fi (@dfi) {
6927 my $f = $fi->{Filename};
6928 my $here = "$buildproductsdir/$f";
6931 fail f_ "lstat %s works but stat gives %s !", $here, $!;
6933 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
6935 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6937 } elsif ($dscfn =~ m#^/#) {
6941 "cannot import %s which seems to be inside working tree!",
6944 $there =~ s#/+[^/]+$## or fail f_
6945 "import %s requires .../%s, but it does not exist",
6948 my $test = $there =~ m{^/} ? $there : "../$there";
6949 stat $test or fail f_
6950 "import %s requires %s, but: %s", $dscfn, $test, $!;
6951 symlink $there, $here or fail f_
6952 "symlink %s to %s: %s", $there, $here, $!;
6953 progress f_ "made symlink %s -> %s", $here, $there;
6954 # print STDERR Dumper($fi);
6956 my @mergeinputs = generate_commits_from_dsc();
6957 die unless @mergeinputs == 1;
6959 my $newhash = $mergeinputs[0]{Commit};
6964 "Import, forced update - synthetic orphan git history.";
6965 } elsif ($force < 0) {
6966 progress __ "Import, merging.";
6967 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6968 my $version = getfield $dsc, 'Version';
6969 my $clogp = commit_getclogp $newhash;
6970 my $authline = clogp_authline $clogp;
6971 $newhash = make_commit_text <<ENDU
6979 .(f_ <<END, $package, $version, $dstbranch);
6980 Merge %s (%s) import into %s
6983 die; # caught earlier
6987 import_dsc_result $dstbranch, $newhash,
6988 "dgit import-dsc: $info",
6989 f_ "results are in git ref %s", $dstbranch;
6992 sub pre_archive_api_query () {
6993 not_necessarily_a_tree();
6995 sub cmd_archive_api_query {
6996 badusage __ "need only 1 subpath argument" unless @ARGV==1;
6997 my ($subpath) = @ARGV;
6998 local $isuite = 'DGIT-API-QUERY-CMD';
6999 my @cmd = archive_api_query_cmd($subpath);
7002 exec @cmd or fail f_ "exec curl: %s\n", $!;
7005 sub repos_server_url () {
7006 $package = '_dgit-repos-server';
7007 local $access_forpush = 1;
7008 local $isuite = 'DGIT-REPOS-SERVER';
7009 my $url = access_giturl();
7012 sub pre_clone_dgit_repos_server () {
7013 not_necessarily_a_tree();
7015 sub cmd_clone_dgit_repos_server {
7016 badusage __ "need destination argument" unless @ARGV==1;
7017 my ($destdir) = @ARGV;
7018 my $url = repos_server_url();
7019 my @cmd = (@git, qw(clone), $url, $destdir);
7021 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7024 sub pre_print_dgit_repos_server_source_url () {
7025 not_necessarily_a_tree();
7027 sub cmd_print_dgit_repos_server_source_url {
7029 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7031 my $url = repos_server_url();
7032 print $url, "\n" or confess $!;
7035 sub pre_print_dpkg_source_ignores {
7036 not_necessarily_a_tree();
7038 sub cmd_print_dpkg_source_ignores {
7040 "no arguments allowed to dgit print-dpkg-source-ignores"
7042 print "@dpkg_source_ignores\n" or confess $!;
7045 sub cmd_setup_mergechangelogs {
7046 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7048 local $isuite = 'DGIT-SETUP-TREE';
7049 setup_mergechangelogs(1);
7052 sub cmd_setup_useremail {
7053 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7054 local $isuite = 'DGIT-SETUP-TREE';
7058 sub cmd_setup_gitattributes {
7059 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7060 local $isuite = 'DGIT-SETUP-TREE';
7064 sub cmd_setup_new_tree {
7065 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7066 local $isuite = 'DGIT-SETUP-TREE';
7070 #---------- argument parsing and main program ----------
7073 print "dgit version $our_version\n" or confess $!;
7077 our (%valopts_long, %valopts_short);
7078 our (%funcopts_long);
7080 our (@modeopt_cfgs);
7082 sub defvalopt ($$$$) {
7083 my ($long,$short,$val_re,$how) = @_;
7084 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7085 $valopts_long{$long} = $oi;
7086 $valopts_short{$short} = $oi;
7087 # $how subref should:
7088 # do whatever assignemnt or thing it likes with $_[0]
7089 # if the option should not be passed on to remote, @rvalopts=()
7090 # or $how can be a scalar ref, meaning simply assign the value
7093 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7094 defvalopt '--distro', '-d', '.+', \$idistro;
7095 defvalopt '', '-k', '.+', \$keyid;
7096 defvalopt '--existing-package','', '.*', \$existing_package;
7097 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7098 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7099 defvalopt '--package', '-p', $package_re, \$package;
7100 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7102 defvalopt '', '-C', '.+', sub {
7103 ($changesfile) = (@_);
7104 if ($changesfile =~ s#^(.*)/##) {
7105 $buildproductsdir = $1;
7109 defvalopt '--initiator-tempdir','','.*', sub {
7110 ($initiator_tempdir) = (@_);
7111 $initiator_tempdir =~ m#^/# or
7112 badusage __ "--initiator-tempdir must be used specify an".
7113 " absolute, not relative, directory."
7116 sub defoptmodes ($@) {
7117 my ($varref, $cfgkey, $default, %optmap) = @_;
7119 while (my ($opt,$val) = each %optmap) {
7120 $funcopts_long{$opt} = sub { $$varref = $val; };
7121 $permit{$val} = $val;
7123 push @modeopt_cfgs, {
7126 Default => $default,
7131 defoptmodes \$dodep14tag, qw( dep14tag want
7134 --always-dep14tag always );
7139 if (defined $ENV{'DGIT_SSH'}) {
7140 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7141 } elsif (defined $ENV{'GIT_SSH'}) {
7142 @ssh = ($ENV{'GIT_SSH'});
7150 if (!defined $val) {
7151 badusage f_ "%s needs a value", $what unless @ARGV;
7153 push @rvalopts, $val;
7155 badusage f_ "bad value \`%s' for %s", $val, $what unless
7156 $val =~ m/^$oi->{Re}$(?!\n)/s;
7157 my $how = $oi->{How};
7158 if (ref($how) eq 'SCALAR') {
7163 push @ropts, @rvalopts;
7167 last unless $ARGV[0] =~ m/^-/;
7171 if (m/^--dry-run$/) {
7174 } elsif (m/^--damp-run$/) {
7177 } elsif (m/^--no-sign$/) {
7180 } elsif (m/^--help$/) {
7182 } elsif (m/^--version$/) {
7184 } elsif (m/^--new$/) {
7187 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7188 ($om = $opts_opt_map{$1}) &&
7192 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7193 !$opts_opt_cmdonly{$1} &&
7194 ($om = $opts_opt_map{$1})) {
7197 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7198 !$opts_opt_cmdonly{$1} &&
7199 ($om = $opts_opt_map{$1})) {
7201 my $cmd = shift @$om;
7202 @$om = ($cmd, grep { $_ ne $2 } @$om);
7203 } elsif (m/^--(gbp|dpm)$/s) {
7204 push @ropts, "--quilt=$1";
7206 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7209 } elsif (m/^--no-quilt-fixup$/s) {
7211 $quilt_mode = 'nocheck';
7212 } elsif (m/^--no-rm-on-error$/s) {
7215 } elsif (m/^--no-chase-dsc-distro$/s) {
7217 $chase_dsc_distro = 0;
7218 } elsif (m/^--overwrite$/s) {
7220 $overwrite_version = '';
7221 } elsif (m/^--overwrite=(.+)$/s) {
7223 $overwrite_version = $1;
7224 } elsif (m/^--delayed=(\d+)$/s) {
7227 } elsif (my ($k,$v) =
7228 m/^--save-(dgit-view)=(.+)$/s ||
7229 m/^--(dgit-view)-save=(.+)$/s
7232 $v =~ s#^(?!refs/)#refs/heads/#;
7233 $internal_object_save{$k} = $v;
7234 } elsif (m/^--(no-)?rm-old-changes$/s) {
7237 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7239 push @deliberatelies, $&;
7240 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7244 } elsif (m/^--force-/) {
7246 f_ "%s: warning: ignoring unknown force option %s\n",
7249 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7250 # undocumented, for testing
7252 $tagformat_want = [ $1, 'command line', 1 ];
7253 # 1 menas overrides distro configuration
7254 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7255 # undocumented, for testing
7257 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7258 # ^ it's supposed to be an array ref
7259 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7260 $val = $2 ? $' : undef; #';
7261 $valopt->($oi->{Long});
7262 } elsif ($funcopts_long{$_}) {
7264 $funcopts_long{$_}();
7266 badusage f_ "unknown long option \`%s'", $_;
7273 } elsif (s/^-L/-/) {
7276 } elsif (s/^-h/-/) {
7278 } elsif (s/^-D/-/) {
7282 } elsif (s/^-N/-/) {
7287 push @changesopts, $_;
7289 } elsif (s/^-wn$//s) {
7291 $cleanmode = 'none';
7292 } elsif (s/^-wg$//s) {
7295 } elsif (s/^-wgf$//s) {
7297 $cleanmode = 'git-ff';
7298 } elsif (s/^-wd(d?)([na]?)$//s) {
7300 $cleanmode = 'dpkg-source';
7301 $cleanmode .= '-d' if $1;
7302 $cleanmode .= ',no-check' if $2 eq 'n';
7303 $cleanmode .= ',all-check' if $2 eq 'a';
7304 } elsif (s/^-wc$//s) {
7306 $cleanmode = 'check';
7307 } elsif (s/^-wci$//s) {
7309 $cleanmode = 'check,ignores';
7310 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7311 push @git, '-c', $&;
7312 $gitcfgs{cmdline}{$1} = [ $2 ];
7313 } elsif (s/^-c([^=]+)$//s) {
7314 push @git, '-c', $&;
7315 $gitcfgs{cmdline}{$1} = [ 'true' ];
7316 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7318 $val = undef unless length $val;
7319 $valopt->($oi->{Short});
7322 badusage f_ "unknown short option \`%s'", $_;
7329 sub check_env_sanity () {
7330 my $blocked = new POSIX::SigSet;
7331 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
7334 foreach my $name (qw(PIPE CHLD)) {
7335 my $signame = "SIG$name";
7336 my $signum = eval "POSIX::$signame" // die;
7337 die f_ "%s is set to something other than SIG_DFL\n",
7339 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7340 $blocked->ismember($signum) and
7341 die f_ "%s is blocked\n", $signame;
7347 On entry to dgit, %s
7348 This is a bug produced by something in your execution environment.
7354 sub parseopts_late_defaults () {
7355 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7356 if defined $idistro;
7357 $isuite //= cfg('dgit.default.default-suite');
7359 foreach my $k (keys %opts_opt_map) {
7360 my $om = $opts_opt_map{$k};
7362 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7364 badcfg f_ "cannot set command for %s", $k
7365 unless length $om->[0];
7369 foreach my $c (access_cfg_cfgs("opts-$k")) {
7371 map { $_ ? @$_ : () }
7372 map { $gitcfgs{$_}{$c} }
7373 reverse @gitcfgsources;
7374 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7375 "\n" if $debuglevel >= 4;
7377 badcfg f_ "cannot configure options for %s", $k
7378 if $opts_opt_cmdonly{$k};
7379 my $insertpos = $opts_cfg_insertpos{$k};
7380 @$om = ( @$om[0..$insertpos-1],
7382 @$om[$insertpos..$#$om] );
7386 if (!defined $rmchanges) {
7387 local $access_forpush;
7388 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7391 if (!defined $quilt_mode) {
7392 local $access_forpush;
7393 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7394 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7396 $quilt_mode =~ m/^($quilt_modes_re)$/
7397 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7401 foreach my $moc (@modeopt_cfgs) {
7402 local $access_forpush;
7403 my $vr = $moc->{Var};
7404 next if defined $$vr;
7405 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7406 my $v = $moc->{Vals}{$$vr};
7407 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7412 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7413 if $split_brain && $includedirty;
7415 if (!defined $cleanmode) {
7416 local $access_forpush;
7417 $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
7418 $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
7420 $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
7421 $cleanmode //= 'dpkg-source';
7423 badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7424 $cleanmode =~ m/$cleanmode_re/;
7427 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7428 $buildproductsdir //= '..';
7429 $bpd_glob = $buildproductsdir;
7430 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7433 setlocale(LC_MESSAGES, "");
7436 if ($ENV{$fakeeditorenv}) {
7438 quilt_fixup_editor();
7444 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7445 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7446 if $dryrun_level == 1;
7448 print STDERR __ $helpmsg or confess $!;
7451 $cmd = $subcommand = shift @ARGV;
7454 my $pre_fn = ${*::}{"pre_$cmd"};
7455 $pre_fn->() if $pre_fn;
7457 if ($invoked_in_git_tree) {
7458 changedir_git_toplevel();
7463 my $fn = ${*::}{"cmd_$cmd"};
7464 $fn or badusage f_ "unknown operation %s", $cmd;