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 )?
105 | (?: git | git-ff ) (?: ,always )?
106 | check (?: ,ignores )?
110 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
111 our $splitbraincache = 'dgit-intern/quilt-cache';
112 our $rewritemap = 'dgit-rewrite/map';
114 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
116 our (@git) = qw(git);
117 our (@dget) = qw(dget);
118 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
119 our (@dput) = qw(dput);
120 our (@debsign) = qw(debsign);
121 our (@gpg) = qw(gpg);
122 our (@sbuild) = (qw(sbuild --no-source));
124 our (@dgit) = qw(dgit);
125 our (@git_debrebase) = qw(git-debrebase);
126 our (@aptget) = qw(apt-get);
127 our (@aptcache) = qw(apt-cache);
128 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
129 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
130 our (@dpkggenchanges) = qw(dpkg-genchanges);
131 our (@mergechanges) = qw(mergechanges -f);
132 our (@gbp_build) = ('');
133 our (@gbp_pq) = ('gbp pq');
134 our (@changesopts) = ('');
135 our (@pbuilder) = ("sudo -E pbuilder","--no-source-only-changes");
136 our (@cowbuilder) = ("sudo -E cowbuilder","--no-source-only-changes");
138 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
141 'debsign' => \@debsign,
143 'sbuild' => \@sbuild,
147 'git-debrebase' => \@git_debrebase,
148 'apt-get' => \@aptget,
149 'apt-cache' => \@aptcache,
150 'dpkg-source' => \@dpkgsource,
151 'dpkg-buildpackage' => \@dpkgbuildpackage,
152 'dpkg-genchanges' => \@dpkggenchanges,
153 'gbp-build' => \@gbp_build,
154 'gbp-pq' => \@gbp_pq,
155 'ch' => \@changesopts,
156 'mergechanges' => \@mergechanges,
157 'pbuilder' => \@pbuilder,
158 'cowbuilder' => \@cowbuilder);
160 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
161 our %opts_cfg_insertpos = map {
163 scalar @{ $opts_opt_map{$_} }
164 } keys %opts_opt_map;
166 sub parseopts_late_defaults();
167 sub setup_gitattrs(;$);
168 sub check_gitattrs($$);
175 our $supplementary_message = '';
176 our $split_brain = 0;
180 return unless forkcheck_mainprocess();
181 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
184 our $remotename = 'dgit';
185 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
189 if (!defined $absurdity) {
191 $absurdity =~ s{/[^/]+$}{/absurd} or die;
195 my ($v,$distro) = @_;
196 return $tagformatfn->($v, $distro);
199 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
201 sub lbranch () { return "$branchprefix/$csuite"; }
202 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
203 sub lref () { return "refs/heads/".lbranch(); }
204 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
205 sub rrref () { return server_ref($csuite); }
208 my ($vsn, $sfx) = @_;
209 return &source_file_leafname($package, $vsn, $sfx);
211 sub is_orig_file_of_vsn ($$) {
212 my ($f, $upstreamvsn) = @_;
213 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
218 return srcfn($vsn,".dsc");
221 sub changespat ($;$) {
222 my ($vsn, $arch) = @_;
223 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
232 return unless forkcheck_mainprocess();
233 foreach my $f (@end) {
235 print STDERR "$us: cleanup: $@" if length $@;
240 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
244 sub forceable_fail ($$) {
245 my ($forceoptsl, $msg) = @_;
246 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
247 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
251 my ($forceoptsl) = @_;
252 my @got = grep { $forceopts{$_} } @$forceoptsl;
253 return 0 unless @got;
255 "warning: skipping checks or functionality due to --force-%s\n",
259 sub no_such_package () {
260 print STDERR f_ "%s: package %s does not exist in suite %s\n",
261 $us, $package, $isuite;
265 sub deliberately ($) {
267 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
270 sub deliberately_not_fast_forward () {
271 foreach (qw(not-fast-forward fresh-repo)) {
272 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
276 sub quiltmode_splitbrain () {
277 $quilt_mode =~ m/gbp|dpm|unapplied/;
280 sub opts_opt_multi_cmd {
283 push @cmd, split /\s+/, shift @_;
290 return opts_opt_multi_cmd [], @gbp_pq;
293 sub dgit_privdir () {
294 our $dgit_privdir_made //= ensure_a_playground 'dgit';
298 my $r = $buildproductsdir;
299 $r = "$maindir/$r" unless $r =~ m{^/};
303 sub get_tree_of_commit ($) {
304 my ($commitish) = @_;
305 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
306 $cdata =~ m/\n\n/; $cdata = $`;
307 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
311 sub branch_gdr_info ($$) {
312 my ($symref, $head) = @_;
313 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
314 gdr_ffq_prev_branchinfo($symref);
315 return () unless $status eq 'branch';
316 $ffq_prev = git_get_ref $ffq_prev;
317 $gdrlast = git_get_ref $gdrlast;
318 $gdrlast &&= is_fast_fwd $gdrlast, $head;
319 return ($ffq_prev, $gdrlast);
322 sub branch_is_gdr_unstitched_ff ($$$) {
323 my ($symref, $head, $ancestor) = @_;
324 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
325 return 0 unless $ffq_prev;
326 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
330 sub branch_is_gdr ($) {
332 # This is quite like git-debrebase's keycommits.
333 # We have our own implementation because:
334 # - our algorighm can do fewer tests so is faster
335 # - it saves testing to see if gdr is installed
337 # NB we use this jsut for deciding whether to run gdr make-patches
338 # Before reusing this algorithm for somthing else, its
339 # suitability should be reconsidered.
342 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
343 printdebug "branch_is_gdr $head...\n";
344 my $get_patches = sub {
345 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
348 my $tip_patches = $get_patches->($head);
351 my $cdata = git_cat_file $walk, 'commit';
352 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
353 if ($msg =~ m{^\[git-debrebase\ (
354 anchor | changelog | make-patches |
355 merged-breakwater | pseudomerge
357 # no need to analyse this - it's sufficient
358 # (gdr classifications: Anchor, MergedBreakwaters)
359 # (made by gdr: Pseudomerge, Changelog)
360 printdebug "branch_is_gdr $walk gdr $1 YES\n";
363 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
365 my $walk_tree = get_tree_of_commit $walk;
366 foreach my $p (@parents) {
367 my $p_tree = get_tree_of_commit $p;
368 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
369 # (gdr classification: Pseudomerge; not made by gdr)
370 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
376 # some other non-gdr merge
377 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
378 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
382 # (gdr classification: ?)
383 printdebug "branch_is_gdr $walk ?-octopus NO\n";
387 printdebug "branch_is_gdr $walk origin\n";
390 if ($get_patches->($walk) ne $tip_patches) {
391 # Our parent added, removed, or edited patches, and wasn't
392 # a gdr make-patches commit. gdr make-patches probably
393 # won't do that well, then.
394 # (gdr classification of parent: AddPatches or ?)
395 printdebug "branch_is_gdr $walk ?-patches NO\n";
398 if ($tip_patches eq '' and
399 !defined git_cat_file "$walk:debian") {
400 # (gdr classification of parent: BreakwaterStart
401 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
404 # (gdr classification: Upstream Packaging Mixed Changelog)
405 printdebug "branch_is_gdr $walk plain\n"
411 #---------- remote protocol support, common ----------
413 # remote push initiator/responder protocol:
414 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
415 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
416 # < dgit-remote-push-ready <actual-proto-vsn>
423 # > supplementary-message NBYTES # $protovsn >= 3
428 # > file parsed-changelog
429 # [indicates that output of dpkg-parsechangelog follows]
430 # > data-block NBYTES
431 # > [NBYTES bytes of data (no newline)]
432 # [maybe some more blocks]
441 # > param head DGIT-VIEW-HEAD
442 # > param csuite SUITE
443 # > param tagformat old|new
444 # > param maint-view MAINT-VIEW-HEAD
446 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
447 # > file buildinfo # for buildinfos to sign
449 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
450 # # goes into tag, for replay prevention
453 # [indicates that signed tag is wanted]
454 # < data-block NBYTES
455 # < [NBYTES bytes of data (no newline)]
456 # [maybe some more blocks]
460 # > want signed-dsc-changes
461 # < data-block NBYTES [transfer of signed dsc]
463 # < data-block NBYTES [transfer of signed changes]
465 # < data-block NBYTES [transfer of each signed buildinfo
466 # [etc] same number and order as "file buildinfo"]
474 sub i_child_report () {
475 # Sees if our child has died, and reap it if so. Returns a string
476 # describing how it died if it failed, or undef otherwise.
477 return undef unless $i_child_pid;
478 my $got = waitpid $i_child_pid, WNOHANG;
479 return undef if $got <= 0;
480 die unless $got == $i_child_pid;
481 $i_child_pid = undef;
482 return undef unless $?;
483 return f_ "build host child %s", waitstatusmsg();
488 fail f_ "connection lost: %s", $! if $fh->error;
489 fail f_ "protocol violation; %s not expected", $m;
492 sub badproto_badread ($$) {
494 fail f_ "connection lost: %s", $! if $!;
495 my $report = i_child_report();
496 fail $report if defined $report;
497 badproto $fh, f_ "eof (reading %s)", $wh;
500 sub protocol_expect (&$) {
501 my ($match, $fh) = @_;
504 defined && chomp or badproto_badread $fh, __ "protocol message";
512 badproto $fh, f_ "\`%s'", $_;
515 sub protocol_send_file ($$) {
516 my ($fh, $ourfn) = @_;
517 open PF, "<", $ourfn or die "$ourfn: $!";
520 my $got = read PF, $d, 65536;
521 die "$ourfn: $!" unless defined $got;
523 print $fh "data-block ".length($d)."\n" or confess $!;
524 print $fh $d or confess $!;
526 PF->error and die "$ourfn $!";
527 print $fh "data-end\n" or confess $!;
531 sub protocol_read_bytes ($$) {
532 my ($fh, $nbytes) = @_;
533 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, __ "bad byte count";
535 my $got = read $fh, $d, $nbytes;
536 $got==$nbytes or badproto_badread $fh, __ "data block";
540 sub protocol_receive_file ($$) {
541 my ($fh, $ourfn) = @_;
542 printdebug "() $ourfn\n";
543 open PF, ">", $ourfn or die "$ourfn: $!";
545 my ($y,$l) = protocol_expect {
546 m/^data-block (.*)$/ ? (1,$1) :
547 m/^data-end$/ ? (0,) :
551 my $d = protocol_read_bytes $fh, $l;
552 print PF $d or confess $!;
554 close PF or confess $!;
557 #---------- remote protocol support, responder ----------
559 sub responder_send_command ($) {
561 return unless $we_are_responder;
562 # called even without $we_are_responder
563 printdebug ">> $command\n";
564 print PO $command, "\n" or confess $!;
567 sub responder_send_file ($$) {
568 my ($keyword, $ourfn) = @_;
569 return unless $we_are_responder;
570 printdebug "]] $keyword $ourfn\n";
571 responder_send_command "file $keyword";
572 protocol_send_file \*PO, $ourfn;
575 sub responder_receive_files ($@) {
576 my ($keyword, @ourfns) = @_;
577 die unless $we_are_responder;
578 printdebug "[[ $keyword @ourfns\n";
579 responder_send_command "want $keyword";
580 foreach my $fn (@ourfns) {
581 protocol_receive_file \*PI, $fn;
584 protocol_expect { m/^files-end$/ } \*PI;
587 #---------- remote protocol support, initiator ----------
589 sub initiator_expect (&) {
591 protocol_expect { &$match } \*RO;
594 #---------- end remote code ----------
597 if ($we_are_responder) {
599 responder_send_command "progress ".length($m) or confess $!;
600 print PO $m or confess $!;
610 $ua = LWP::UserAgent->new();
614 progress "downloading $what...";
615 my $r = $ua->get(@_) or confess $!;
616 return undef if $r->code == 404;
617 $r->is_success or fail f_ "failed to fetch %s: %s",
618 $what, $r->status_line;
619 return $r->decoded_content(charset => 'none');
622 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
624 sub act_local () { return $dryrun_level <= 1; }
625 sub act_scary () { return !$dryrun_level; }
628 if (!$dryrun_level) {
629 progress f_ "%s ok: %s", $us, "@_";
631 progress f_ "would be ok: %s (but dry run only)", "@_";
636 printcmd(\*STDERR,$debugprefix."#",@_);
639 sub runcmd_ordryrun {
647 sub runcmd_ordryrun_local {
655 our $helpmsg = i_ <<END;
657 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
658 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
659 dgit [dgit-opts] build [dpkg-buildpackage-opts]
660 dgit [dgit-opts] sbuild [sbuild-opts]
661 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
662 dgit [dgit-opts] push [dgit-opts] [suite]
663 dgit [dgit-opts] push-source [dgit-opts] [suite]
664 dgit [dgit-opts] rpush build-host:build-dir ...
665 important dgit options:
666 -k<keyid> sign tag and package with <keyid> instead of default
667 --dry-run -n do not change anything, but go through the motions
668 --damp-run -L like --dry-run but make local changes, without signing
669 --new -N allow introducing a new package
670 --debug -D increase debug level
671 -c<name>=<value> set git config option (used directly by dgit too)
674 our $later_warning_msg = i_ <<END;
675 Perhaps the upload is stuck in incoming. Using the version from git.
679 print STDERR f_ "%s: %s\n%s", $us, "@_", __ $helpmsg or confess $!;
684 @ARGV or badusage __ "too few arguments";
685 return scalar shift @ARGV;
689 not_necessarily_a_tree();
692 print __ $helpmsg or confess $!;
696 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
698 our %defcfg = ('dgit.default.distro' => 'debian',
699 'dgit.default.default-suite' => 'unstable',
700 'dgit.default.old-dsc-distro' => 'debian',
701 'dgit-suite.*-security.distro' => 'debian-security',
702 'dgit.default.username' => '',
703 'dgit.default.archive-query-default-component' => 'main',
704 'dgit.default.ssh' => 'ssh',
705 'dgit.default.archive-query' => 'madison:',
706 'dgit.default.sshpsql-dbname' => 'service=projectb',
707 'dgit.default.aptget-components' => 'main',
708 'dgit.default.dgit-tag-format' => 'new,old,maint',
709 'dgit.default.source-only-uploads' => 'ok',
710 'dgit.dsc-url-proto-ok.http' => 'true',
711 'dgit.dsc-url-proto-ok.https' => 'true',
712 'dgit.dsc-url-proto-ok.git' => 'true',
713 'dgit.vcs-git.suites', => 'sid', # ;-separated
714 'dgit.default.dsc-url-proto-ok' => 'false',
715 # old means "repo server accepts pushes with old dgit tags"
716 # new means "repo server accepts pushes with new dgit tags"
717 # maint means "repo server accepts split brain pushes"
718 # hist means "repo server may have old pushes without new tag"
719 # ("hist" is implied by "old")
720 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
721 'dgit-distro.debian.git-check' => 'url',
722 'dgit-distro.debian.git-check-suffix' => '/info/refs',
723 'dgit-distro.debian.new-private-pushers' => 't',
724 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
725 'dgit-distro.debian/push.git-url' => '',
726 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
727 'dgit-distro.debian/push.git-user-force' => 'dgit',
728 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
729 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
730 'dgit-distro.debian/push.git-create' => 'true',
731 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
732 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
733 # 'dgit-distro.debian.archive-query-tls-key',
734 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
735 # ^ this does not work because curl is broken nowadays
736 # Fixing #790093 properly will involve providing providing the key
737 # in some pacagke and maybe updating these paths.
739 # 'dgit-distro.debian.archive-query-tls-curl-args',
740 # '--ca-path=/etc/ssl/ca-debian',
741 # ^ this is a workaround but works (only) on DSA-administered machines
742 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
743 'dgit-distro.debian.git-url-suffix' => '',
744 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
745 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
746 'dgit-distro.debian-security.archive-query' => 'aptget:',
747 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
748 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
749 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
750 'dgit-distro.debian-security.nominal-distro' => 'debian',
751 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
752 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
753 'dgit-distro.ubuntu.git-check' => 'false',
754 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
755 'dgit-distro.test-dummy.ssh' => "$td/ssh",
756 'dgit-distro.test-dummy.username' => "alice",
757 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
758 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
759 'dgit-distro.test-dummy.git-url' => "$td/git",
760 'dgit-distro.test-dummy.git-host' => "git",
761 'dgit-distro.test-dummy.git-path' => "$td/git",
762 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
763 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
764 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
765 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
769 our @gitcfgsources = qw(cmdline local global system);
770 our $invoked_in_git_tree = 1;
772 sub git_slurp_config () {
773 # This algoritm is a bit subtle, but this is needed so that for
774 # options which we want to be single-valued, we allow the
775 # different config sources to override properly. See #835858.
776 foreach my $src (@gitcfgsources) {
777 next if $src eq 'cmdline';
778 # we do this ourselves since git doesn't handle it
780 $gitcfgs{$src} = git_slurp_config_src $src;
784 sub git_get_config ($) {
786 foreach my $src (@gitcfgsources) {
787 my $l = $gitcfgs{$src}{$c};
788 confess "internal error ($l $c)" if $l && !ref $l;
789 printdebug"C $c ".(defined $l ?
790 join " ", map { messagequote "'$_'" } @$l :
795 f_ "multiple values for %s (in %s git config)", $c, $src
797 $l->[0] =~ m/\n/ and badcfg f_
798 "value for config option %s (in %s git config) contains newline(s)!",
807 return undef if $c =~ /RETURN-UNDEF/;
808 printdebug "C? $c\n" if $debuglevel >= 5;
809 my $v = git_get_config($c);
810 return $v if defined $v;
811 my $dv = $defcfg{$c};
813 printdebug "CD $c $dv\n" if $debuglevel >= 4;
818 "need value for one of: %s\n".
819 "%s: distro or suite appears not to be (properly) supported",
823 sub not_necessarily_a_tree () {
824 # needs to be called from pre_*
825 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
826 $invoked_in_git_tree = 0;
829 sub access_basedistro__noalias () {
830 if (defined $idistro) {
833 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
834 return $def if defined $def;
835 foreach my $src (@gitcfgsources, 'internal') {
836 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
838 foreach my $k (keys %$kl) {
839 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
841 next unless match_glob $dpat, $isuite;
845 return cfg("dgit.default.distro");
849 sub access_basedistro () {
850 my $noalias = access_basedistro__noalias();
851 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
852 return $canon // $noalias;
855 sub access_nomdistro () {
856 my $base = access_basedistro();
857 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
858 $r =~ m/^$distro_re$/ or badcfg
859 f_ "bad syntax for (nominal) distro \`%s' (does not match %s)",
860 $r, "/^$distro_re$/";
864 sub access_quirk () {
865 # returns (quirk name, distro to use instead or undef, quirk-specific info)
866 my $basedistro = access_basedistro();
867 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
869 if (defined $backports_quirk) {
870 my $re = $backports_quirk;
871 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
873 $re =~ s/\%/([-0-9a-z_]+)/
874 or $re =~ m/[()]/ or badcfg __ "backports-quirk needs \% or ( )";
875 if ($isuite =~ m/^$re$/) {
876 return ('backports',"$basedistro-backports",$1);
879 return ('none',undef);
884 sub parse_cfg_bool ($$$) {
885 my ($what,$def,$v) = @_;
888 $v =~ m/^[ty1]/ ? 1 :
889 $v =~ m/^[fn0]/ ? 0 :
890 badcfg f_ "%s needs t (true, y, 1) or f (false, n, 0) not \`%s'",
894 sub access_forpush_config () {
895 my $d = access_basedistro();
899 parse_cfg_bool('new-private-pushers', 0,
900 cfg("dgit-distro.$d.new-private-pushers",
903 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
906 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
907 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
908 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
910 "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
913 sub access_forpush () {
914 $access_forpush //= access_forpush_config();
915 return $access_forpush;
919 confess +(__ 'internal error').' '.Dumper($access_forpush)," ?" if
920 defined $access_forpush and !$access_forpush;
921 badcfg __ "pushing but distro is configured readonly"
922 if access_forpush_config() eq '0';
924 $supplementary_message = __ <<'END' unless $we_are_responder;
925 Push failed, before we got started.
926 You can retry the push, after fixing the problem, if you like.
928 parseopts_late_defaults();
932 parseopts_late_defaults();
935 sub supplementary_message ($) {
937 if (!$we_are_responder) {
938 $supplementary_message = $msg;
940 } elsif ($protovsn >= 3) {
941 responder_send_command "supplementary-message ".length($msg)
943 print PO $msg or confess $!;
947 sub access_distros () {
948 # Returns list of distros to try, in order
951 # 0. `instead of' distro name(s) we have been pointed to
952 # 1. the access_quirk distro, if any
953 # 2a. the user's specified distro, or failing that } basedistro
954 # 2b. the distro calculated from the suite }
955 my @l = access_basedistro();
957 my (undef,$quirkdistro) = access_quirk();
958 unshift @l, $quirkdistro;
959 unshift @l, $instead_distro;
960 @l = grep { defined } @l;
962 push @l, access_nomdistro();
964 if (access_forpush()) {
965 @l = map { ("$_/push", $_) } @l;
970 sub access_cfg_cfgs (@) {
973 # The nesting of these loops determines the search order. We put
974 # the key loop on the outside so that we search all the distros
975 # for each key, before going on to the next key. That means that
976 # if access_cfg is called with a more specific, and then a less
977 # specific, key, an earlier distro can override the less specific
978 # without necessarily overriding any more specific keys. (If the
979 # distro wants to override the more specific keys it can simply do
980 # so; whereas if we did the loop the other way around, it would be
981 # impossible to for an earlier distro to override a less specific
982 # key but not the more specific ones without restating the unknown
983 # values of the more specific keys.
986 # We have to deal with RETURN-UNDEF specially, so that we don't
987 # terminate the search prematurely.
989 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
992 foreach my $d (access_distros()) {
993 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
995 push @cfgs, map { "dgit.default.$_" } @realkeys;
1000 sub access_cfg (@) {
1002 my (@cfgs) = access_cfg_cfgs(@keys);
1003 my $value = cfg(@cfgs);
1007 sub access_cfg_bool ($$) {
1008 my ($def, @keys) = @_;
1009 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
1012 sub string_to_ssh ($) {
1014 if ($spec =~ m/\s/) {
1015 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1021 sub access_cfg_ssh () {
1022 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1023 if (!defined $gitssh) {
1026 return string_to_ssh $gitssh;
1030 sub access_runeinfo ($) {
1032 return ": dgit ".access_basedistro()." $info ;";
1035 sub access_someuserhost ($) {
1037 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1038 defined($user) && length($user) or
1039 $user = access_cfg("$some-user",'username');
1040 my $host = access_cfg("$some-host");
1041 return length($user) ? "$user\@$host" : $host;
1044 sub access_gituserhost () {
1045 return access_someuserhost('git');
1048 sub access_giturl (;$) {
1049 my ($optional) = @_;
1050 my $url = access_cfg('git-url','RETURN-UNDEF');
1053 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1054 return undef unless defined $proto;
1057 access_gituserhost().
1058 access_cfg('git-path');
1060 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1063 return "$url/$package$suffix";
1066 sub commit_getclogp ($) {
1067 # Returns the parsed changelog hashref for a particular commit
1069 our %commit_getclogp_memo;
1070 my $memo = $commit_getclogp_memo{$objid};
1071 return $memo if $memo;
1073 my $mclog = dgit_privdir()."clog";
1074 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1075 "$objid:debian/changelog";
1076 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1079 sub parse_dscdata () {
1080 my $dscfh = new IO::File \$dscdata, '<' or confess $!;
1081 printdebug Dumper($dscdata) if $debuglevel>1;
1082 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1083 printdebug Dumper($dsc) if $debuglevel>1;
1088 sub archive_query ($;@) {
1089 my ($method) = shift @_;
1090 fail __ "this operation does not support multiple comma-separated suites"
1092 my $query = access_cfg('archive-query','RETURN-UNDEF');
1093 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1096 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1099 sub archive_query_prepend_mirror {
1100 my $m = access_cfg('mirror');
1101 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1104 sub pool_dsc_subpath ($$) {
1105 my ($vsn,$component) = @_; # $package is implict arg
1106 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1107 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1110 sub cfg_apply_map ($$$) {
1111 my ($varref, $what, $mapspec) = @_;
1112 return unless $mapspec;
1114 printdebug "config $what EVAL{ $mapspec; }\n";
1116 eval "package Dgit::Config; $mapspec;";
1121 #---------- `ftpmasterapi' archive query method (nascent) ----------
1123 sub archive_api_query_cmd ($) {
1125 my @cmd = (@curl, qw(-sS));
1126 my $url = access_cfg('archive-query-url');
1127 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1129 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1130 foreach my $key (split /\:/, $keys) {
1131 $key =~ s/\%HOST\%/$host/g;
1133 fail "for $url: stat $key: $!" unless $!==ENOENT;
1136 fail f_ "config requested specific TLS key but do not know".
1137 " how to get curl to use exactly that EE key (%s)",
1139 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1140 # # Sadly the above line does not work because of changes
1141 # # to gnutls. The real fix for #790093 may involve
1142 # # new curl options.
1145 # Fixing #790093 properly will involve providing a value
1146 # for this on clients.
1147 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1148 push @cmd, split / /, $kargs if defined $kargs;
1150 push @cmd, $url.$subpath;
1154 sub api_query ($$;$) {
1156 my ($data, $subpath, $ok404) = @_;
1157 badcfg __ "ftpmasterapi archive query method takes no data part"
1159 my @cmd = archive_api_query_cmd($subpath);
1160 my $url = $cmd[$#cmd];
1161 push @cmd, qw(-w %{http_code});
1162 my $json = cmdoutput @cmd;
1163 unless ($json =~ s/\d+\d+\d$//) {
1164 failedcmd_report_cmd undef, @cmd;
1165 fail __ "curl failed to print 3-digit HTTP code";
1168 return undef if $code eq '404' && $ok404;
1169 fail f_ "fetch of %s gave HTTP code %s", $url, $code
1170 unless $url =~ m#^file://# or $code =~ m/^2/;
1171 return decode_json($json);
1174 sub canonicalise_suite_ftpmasterapi {
1175 my ($proto,$data) = @_;
1176 my $suites = api_query($data, 'suites');
1178 foreach my $entry (@$suites) {
1180 my $v = $entry->{$_};
1181 defined $v && $v eq $isuite;
1182 } qw(codename name);
1183 push @matched, $entry;
1185 fail f_ "unknown suite %s, maybe -d would help", $isuite
1189 @matched==1 or die f_ "multiple matches for suite %s\n", $isuite;
1190 $cn = "$matched[0]{codename}";
1191 defined $cn or die f_ "suite %s info has no codename\n", $isuite;
1192 $cn =~ m/^$suite_re$/
1193 or die f_ "suite %s maps to bad codename\n", $isuite;
1195 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper(\@matched)
1200 sub archive_query_ftpmasterapi {
1201 my ($proto,$data) = @_;
1202 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1204 my $digester = Digest::SHA->new(256);
1205 foreach my $entry (@$info) {
1207 my $vsn = "$entry->{version}";
1208 my ($ok,$msg) = version_check $vsn;
1209 die f_ "bad version: %s\n", $msg unless $ok;
1210 my $component = "$entry->{component}";
1211 $component =~ m/^$component_re$/ or die __ "bad component";
1212 my $filename = "$entry->{filename}";
1213 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1214 or die __ "bad filename";
1215 my $sha256sum = "$entry->{sha256sum}";
1216 $sha256sum =~ m/^[0-9a-f]+$/ or die __ "bad sha256sum";
1217 push @rows, [ $vsn, "/pool/$component/$filename",
1218 $digester, $sha256sum ];
1220 die +(__ "bad ftpmaster api response: ")."$@\n".Dumper($entry)
1223 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1224 return archive_query_prepend_mirror @rows;
1227 sub file_in_archive_ftpmasterapi {
1228 my ($proto,$data,$filename) = @_;
1229 my $pat = $filename;
1232 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1233 my $info = api_query($data, "file_in_archive/$pat", 1);
1236 sub package_not_wholly_new_ftpmasterapi {
1237 my ($proto,$data,$pkg) = @_;
1238 my $info = api_query($data,"madison?package=${pkg}&f=json");
1242 #---------- `aptget' archive query method ----------
1245 our $aptget_releasefile;
1246 our $aptget_configpath;
1248 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1249 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1251 sub aptget_cache_clean {
1252 runcmd_ordryrun_local qw(sh -ec),
1253 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1257 sub aptget_lock_acquire () {
1258 my $lockfile = "$aptget_base/lock";
1259 open APTGET_LOCK, '>', $lockfile or confess "open $lockfile: $!";
1260 flock APTGET_LOCK, LOCK_EX or confess "lock $lockfile: $!";
1263 sub aptget_prep ($) {
1265 return if defined $aptget_base;
1267 badcfg __ "aptget archive query method takes no data part"
1270 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1273 ensuredir "$cache/dgit";
1275 access_cfg('aptget-cachekey','RETURN-UNDEF')
1276 // access_nomdistro();
1278 $aptget_base = "$cache/dgit/aptget";
1279 ensuredir $aptget_base;
1281 my $quoted_base = $aptget_base;
1282 confess "$quoted_base contains bad chars, cannot continue"
1283 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1285 ensuredir $aptget_base;
1287 aptget_lock_acquire();
1289 aptget_cache_clean();
1291 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1292 my $sourceslist = "source.list#$cachekey";
1294 my $aptsuites = $isuite;
1295 cfg_apply_map(\$aptsuites, 'suite map',
1296 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1298 open SRCS, ">", "$aptget_base/$sourceslist" or confess $!;
1299 printf SRCS "deb-src %s %s %s\n",
1300 access_cfg('mirror'),
1302 access_cfg('aptget-components')
1305 ensuredir "$aptget_base/cache";
1306 ensuredir "$aptget_base/lists";
1308 open CONF, ">", $aptget_configpath or confess $!;
1310 Debug::NoLocking "true";
1311 APT::Get::List-Cleanup "false";
1312 #clear APT::Update::Post-Invoke-Success;
1313 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1314 Dir::State::Lists "$quoted_base/lists";
1315 Dir::Etc::preferences "$quoted_base/preferences";
1316 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1317 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1320 foreach my $key (qw(
1323 Dir::Cache::Archives
1324 Dir::Etc::SourceParts
1325 Dir::Etc::preferencesparts
1327 ensuredir "$aptget_base/$key";
1328 print CONF "$key \"$quoted_base/$key\";\n" or confess $!;
1331 my $oldatime = (time // confess $!) - 1;
1332 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1333 next unless stat_exists $oldlist;
1334 my ($mtime) = (stat _)[9];
1335 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1338 runcmd_ordryrun_local aptget_aptget(), qw(update);
1341 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1342 next unless stat_exists $oldlist;
1343 my ($atime) = (stat _)[8];
1344 next if $atime == $oldatime;
1345 push @releasefiles, $oldlist;
1347 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1348 @releasefiles = @inreleasefiles if @inreleasefiles;
1349 if (!@releasefiles) {
1350 fail f_ <<END, $isuite, $cache;
1351 apt seemed to not to update dgit's cached Release files for %s.
1353 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1356 confess "apt updated too many Release files (@releasefiles), erk"
1357 unless @releasefiles == 1;
1359 ($aptget_releasefile) = @releasefiles;
1362 sub canonicalise_suite_aptget {
1363 my ($proto,$data) = @_;
1366 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1368 foreach my $name (qw(Codename Suite)) {
1369 my $val = $release->{$name};
1371 printdebug "release file $name: $val\n";
1372 $val =~ m/^$suite_re$/o or fail f_
1373 "Release file (%s) specifies intolerable %s",
1374 $aptget_releasefile, $name;
1375 cfg_apply_map(\$val, 'suite rmap',
1376 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1383 sub archive_query_aptget {
1384 my ($proto,$data) = @_;
1387 ensuredir "$aptget_base/source";
1388 foreach my $old (<$aptget_base/source/*.dsc>) {
1389 unlink $old or die "$old: $!";
1392 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1393 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1394 # avoids apt-get source failing with ambiguous error code
1396 runcmd_ordryrun_local
1397 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1398 aptget_aptget(), qw(--download-only --only-source source), $package;
1400 my @dscs = <$aptget_base/source/*.dsc>;
1401 fail __ "apt-get source did not produce a .dsc" unless @dscs;
1402 fail f_ "apt-get source produced several .dscs (%s)", "@dscs"
1405 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1408 my $uri = "file://". uri_escape $dscs[0];
1409 $uri =~ s{\%2f}{/}gi;
1410 return [ (getfield $pre_dsc, 'Version'), $uri ];
1413 sub file_in_archive_aptget () { return undef; }
1414 sub package_not_wholly_new_aptget () { return undef; }
1416 #---------- `dummyapicat' archive query method ----------
1417 # (untranslated, because this is for testing purposes etc.)
1419 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1420 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1422 sub dummycatapi_run_in_mirror ($@) {
1423 # runs $fn with FIA open onto rune
1424 my ($rune, $argl, $fn) = @_;
1426 my $mirror = access_cfg('mirror');
1427 $mirror =~ s#^file://#/# or die "$mirror ?";
1428 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1429 qw(x), $mirror, @$argl);
1430 debugcmd "-|", @cmd;
1431 open FIA, "-|", @cmd or confess $!;
1433 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1437 sub file_in_archive_dummycatapi ($$$) {
1438 my ($proto,$data,$filename) = @_;
1440 dummycatapi_run_in_mirror '
1441 find -name "$1" -print0 |
1443 ', [$filename], sub {
1446 printdebug "| $_\n";
1447 m/^(\w+) (\S+)$/ or die "$_ ?";
1448 push @out, { sha256sum => $1, filename => $2 };
1454 sub package_not_wholly_new_dummycatapi {
1455 my ($proto,$data,$pkg) = @_;
1456 dummycatapi_run_in_mirror "
1457 find -name ${pkg}_*.dsc
1464 #---------- `madison' archive query method ----------
1466 sub archive_query_madison {
1467 return archive_query_prepend_mirror
1468 map { [ @$_[0..1] ] } madison_get_parse(@_);
1471 sub madison_get_parse {
1472 my ($proto,$data) = @_;
1473 die unless $proto eq 'madison';
1474 if (!length $data) {
1475 $data= access_cfg('madison-distro','RETURN-UNDEF');
1476 $data //= access_basedistro();
1478 $rmad{$proto,$data,$package} ||= cmdoutput
1479 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1480 my $rmad = $rmad{$proto,$data,$package};
1483 foreach my $l (split /\n/, $rmad) {
1484 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1485 \s*( [^ \t|]+ )\s* \|
1486 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1487 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1488 $1 eq $package or die "$rmad $package ?";
1495 $component = access_cfg('archive-query-default-component');
1497 $5 eq 'source' or die "$rmad ?";
1498 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1500 return sort { -version_compare($a->[0],$b->[0]); } @out;
1503 sub canonicalise_suite_madison {
1504 # madison canonicalises for us
1505 my @r = madison_get_parse(@_);
1507 "unable to canonicalise suite using package %s".
1508 " which does not appear to exist in suite %s;".
1509 " --existing-package may help",
1514 sub file_in_archive_madison { return undef; }
1515 sub package_not_wholly_new_madison { return undef; }
1517 #---------- `sshpsql' archive query method ----------
1518 # (untranslated, because this is obsolete)
1521 my ($data,$runeinfo,$sql) = @_;
1522 if (!length $data) {
1523 $data= access_someuserhost('sshpsql').':'.
1524 access_cfg('sshpsql-dbname');
1526 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1527 my ($userhost,$dbname) = ($`,$'); #';
1529 my @cmd = (access_cfg_ssh, $userhost,
1530 access_runeinfo("ssh-psql $runeinfo").
1531 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1532 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1534 open P, "-|", @cmd or confess $!;
1537 printdebug(">|$_|\n");
1540 $!=0; $?=0; close P or failedcmd @cmd;
1542 my $nrows = pop @rows;
1543 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1544 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1545 @rows = map { [ split /\|/, $_ ] } @rows;
1546 my $ncols = scalar @{ shift @rows };
1547 die if grep { scalar @$_ != $ncols } @rows;
1551 sub sql_injection_check {
1552 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1555 sub archive_query_sshpsql ($$) {
1556 my ($proto,$data) = @_;
1557 sql_injection_check $isuite, $package;
1558 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1559 SELECT source.version, component.name, files.filename, files.sha256sum
1561 JOIN src_associations ON source.id = src_associations.source
1562 JOIN suite ON suite.id = src_associations.suite
1563 JOIN dsc_files ON dsc_files.source = source.id
1564 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1565 JOIN component ON component.id = files_archive_map.component_id
1566 JOIN files ON files.id = dsc_files.file
1567 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1568 AND source.source='$package'
1569 AND files.filename LIKE '%.dsc';
1571 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1572 my $digester = Digest::SHA->new(256);
1574 my ($vsn,$component,$filename,$sha256sum) = @$_;
1575 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1577 return archive_query_prepend_mirror @rows;
1580 sub canonicalise_suite_sshpsql ($$) {
1581 my ($proto,$data) = @_;
1582 sql_injection_check $isuite;
1583 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1584 SELECT suite.codename
1585 FROM suite where suite_name='$isuite' or codename='$isuite';
1587 @rows = map { $_->[0] } @rows;
1588 fail "unknown suite $isuite" unless @rows;
1589 die "ambiguous $isuite: @rows ?" if @rows>1;
1593 sub file_in_archive_sshpsql ($$$) { return undef; }
1594 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1596 #---------- `dummycat' archive query method ----------
1597 # (untranslated, because this is for testing purposes etc.)
1599 sub canonicalise_suite_dummycat ($$) {
1600 my ($proto,$data) = @_;
1601 my $dpath = "$data/suite.$isuite";
1602 if (!open C, "<", $dpath) {
1603 $!==ENOENT or die "$dpath: $!";
1604 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1608 chomp or die "$dpath: $!";
1610 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1614 sub archive_query_dummycat ($$) {
1615 my ($proto,$data) = @_;
1616 canonicalise_suite();
1617 my $dpath = "$data/package.$csuite.$package";
1618 if (!open C, "<", $dpath) {
1619 $!==ENOENT or die "$dpath: $!";
1620 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1628 printdebug "dummycat query $csuite $package $dpath | $_\n";
1629 my @row = split /\s+/, $_;
1630 @row==2 or die "$dpath: $_ ?";
1633 C->error and die "$dpath: $!";
1635 return archive_query_prepend_mirror
1636 sort { -version_compare($a->[0],$b->[0]); } @rows;
1639 sub file_in_archive_dummycat () { return undef; }
1640 sub package_not_wholly_new_dummycat () { return undef; }
1642 #---------- tag format handling ----------
1643 # (untranslated, because everything should be new tag format by now)
1645 sub access_cfg_tagformats () {
1646 split /\,/, access_cfg('dgit-tag-format');
1649 sub access_cfg_tagformats_can_splitbrain () {
1650 my %y = map { $_ => 1 } access_cfg_tagformats;
1651 foreach my $needtf (qw(new maint)) {
1652 next if $y{$needtf};
1658 sub need_tagformat ($$) {
1659 my ($fmt, $why) = @_;
1660 fail "need to use tag format $fmt ($why) but also need".
1661 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1662 " - no way to proceed"
1663 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1664 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1667 sub select_tagformat () {
1669 return if $tagformatfn && !$tagformat_want;
1670 die 'bug' if $tagformatfn && $tagformat_want;
1671 # ... $tagformat_want assigned after previous select_tagformat
1673 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1674 printdebug "select_tagformat supported @supported\n";
1676 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1677 printdebug "select_tagformat specified @$tagformat_want\n";
1679 my ($fmt,$why,$override) = @$tagformat_want;
1681 fail "target distro supports tag formats @supported".
1682 " but have to use $fmt ($why)"
1684 or grep { $_ eq $fmt } @supported;
1686 $tagformat_want = undef;
1688 $tagformatfn = ${*::}{"debiantag_$fmt"};
1690 fail "trying to use unknown tag format \`$fmt' ($why) !"
1691 unless $tagformatfn;
1694 #---------- archive query entrypoints and rest of program ----------
1696 sub canonicalise_suite () {
1697 return if defined $csuite;
1698 fail f_ "cannot operate on %s suite", $isuite if $isuite eq 'UNRELEASED';
1699 $csuite = archive_query('canonicalise_suite');
1700 if ($isuite ne $csuite) {
1701 progress f_ "canonical suite name for %s is %s", $isuite, $csuite;
1703 progress f_ "canonical suite name is %s", $csuite;
1707 sub get_archive_dsc () {
1708 canonicalise_suite();
1709 my @vsns = archive_query('archive_query');
1710 foreach my $vinfo (@vsns) {
1711 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1712 $dscurl = $vsn_dscurl;
1713 $dscdata = url_get($dscurl);
1715 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1720 $digester->add($dscdata);
1721 my $got = $digester->hexdigest();
1723 fail f_ "%s has hash %s but archive told us to expect %s",
1724 $dscurl, $got, $digest;
1727 my $fmt = getfield $dsc, 'Format';
1728 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1729 f_ "unsupported source format %s, sorry", $fmt;
1731 $dsc_checked = !!$digester;
1732 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1736 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1739 sub check_for_git ();
1740 sub check_for_git () {
1742 my $how = access_cfg('git-check');
1743 if ($how eq 'ssh-cmd') {
1745 (access_cfg_ssh, access_gituserhost(),
1746 access_runeinfo("git-check $package").
1747 " set -e; cd ".access_cfg('git-path').";".
1748 " if test -d $package.git; then echo 1; else echo 0; fi");
1749 my $r= cmdoutput @cmd;
1750 if (defined $r and $r =~ m/^divert (\w+)$/) {
1752 my ($usedistro,) = access_distros();
1753 # NB that if we are pushing, $usedistro will be $distro/push
1754 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1755 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1756 progress f_ "diverting to %s (using config for %s)",
1757 $divert, $instead_distro;
1758 return check_for_git();
1760 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1762 } elsif ($how eq 'url') {
1763 my $prefix = access_cfg('git-check-url','git-url');
1764 my $suffix = access_cfg('git-check-suffix','git-suffix',
1765 'RETURN-UNDEF') // '.git';
1766 my $url = "$prefix/$package$suffix";
1767 my @cmd = (@curl, qw(-sS -I), $url);
1768 my $result = cmdoutput @cmd;
1769 $result =~ s/^\S+ 200 .*\n\r?\n//;
1770 # curl -sS -I with https_proxy prints
1771 # HTTP/1.0 200 Connection established
1772 $result =~ m/^\S+ (404|200) /s or
1773 fail +(__ "unexpected results from git check query - ").
1774 Dumper($prefix, $result);
1776 if ($code eq '404') {
1778 } elsif ($code eq '200') {
1783 } elsif ($how eq 'true') {
1785 } elsif ($how eq 'false') {
1788 badcfg f_ "unknown git-check \`%s'", $how;
1792 sub create_remote_git_repo () {
1793 my $how = access_cfg('git-create');
1794 if ($how eq 'ssh-cmd') {
1796 (access_cfg_ssh, access_gituserhost(),
1797 access_runeinfo("git-create $package").
1798 "set -e; cd ".access_cfg('git-path').";".
1799 " cp -a _template $package.git");
1800 } elsif ($how eq 'true') {
1803 badcfg f_ "unknown git-create \`%s'", $how;
1807 our ($dsc_hash,$lastpush_mergeinput);
1808 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1812 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1813 $playground = fresh_playground 'dgit/unpack';
1816 sub mktree_in_ud_here () {
1817 playtree_setup $gitcfgs{local};
1820 sub git_write_tree () {
1821 my $tree = cmdoutput @git, qw(write-tree);
1822 $tree =~ m/^\w+$/ or die "$tree ?";
1826 sub git_add_write_tree () {
1827 runcmd @git, qw(add -Af .);
1828 return git_write_tree();
1831 sub remove_stray_gits ($) {
1833 my @gitscmd = qw(find -name .git -prune -print0);
1834 debugcmd "|",@gitscmd;
1835 open GITS, "-|", @gitscmd or confess $!;
1840 print STDERR f_ "%s: warning: removing from %s: %s\n",
1841 $us, $what, (messagequote $_);
1845 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1848 sub mktree_in_ud_from_only_subdir ($;$) {
1849 my ($what,$raw) = @_;
1850 # changes into the subdir
1853 confess "expected one subdir but found @dirs ?" unless @dirs==1;
1854 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1858 remove_stray_gits($what);
1859 mktree_in_ud_here();
1861 my ($format, $fopts) = get_source_format();
1862 if (madformat($format)) {
1867 my $tree=git_add_write_tree();
1868 return ($tree,$dir);
1871 our @files_csum_info_fields =
1872 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1873 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1874 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1876 sub dsc_files_info () {
1877 foreach my $csumi (@files_csum_info_fields) {
1878 my ($fname, $module, $method) = @$csumi;
1879 my $field = $dsc->{$fname};
1880 next unless defined $field;
1881 eval "use $module; 1;" or die $@;
1883 foreach (split /\n/, $field) {
1885 m/^(\w+) (\d+) (\S+)$/ or
1886 fail f_ "could not parse .dsc %s line \`%s'", $fname, $_;
1887 my $digester = eval "$module"."->$method;" or die $@;
1892 Digester => $digester,
1897 fail f_ "missing any supported Checksums-* or Files field in %s",
1898 $dsc->get_option('name');
1902 map { $_->{Filename} } dsc_files_info();
1905 sub files_compare_inputs (@) {
1910 my $showinputs = sub {
1911 return join "; ", map { $_->get_option('name') } @$inputs;
1914 foreach my $in (@$inputs) {
1916 my $in_name = $in->get_option('name');
1918 printdebug "files_compare_inputs $in_name\n";
1920 foreach my $csumi (@files_csum_info_fields) {
1921 my ($fname) = @$csumi;
1922 printdebug "files_compare_inputs $in_name $fname\n";
1924 my $field = $in->{$fname};
1925 next unless defined $field;
1928 foreach (split /\n/, $field) {
1931 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1932 fail "could not parse $in_name $fname line \`$_'";
1934 printdebug "files_compare_inputs $in_name $fname $f\n";
1938 my $re = \ $record{$f}{$fname};
1940 $fchecked{$f}{$in_name} = 1;
1943 "hash or size of %s varies in %s fields (between: %s)",
1944 $f, $fname, $showinputs->();
1949 @files = sort @files;
1950 $expected_files //= \@files;
1951 "@$expected_files" eq "@files" or
1952 fail f_ "file list in %s varies between hash fields!",
1956 fail f_ "%s has no files list field(s)", $in_name;
1958 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1961 grep { keys %$_ == @$inputs-1 } values %fchecked
1962 or fail f_ "no file appears in all file lists (looked in: %s)",
1966 sub is_orig_file_in_dsc ($$) {
1967 my ($f, $dsc_files_info) = @_;
1968 return 0 if @$dsc_files_info <= 1;
1969 # One file means no origs, and the filename doesn't have a "what
1970 # part of dsc" component. (Consider versions ending `.orig'.)
1971 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1975 # This function determines whether a .changes file is source-only from
1976 # the point of view of dak. Thus, it permits *_source.buildinfo
1979 # It does not, however, permit any other buildinfo files. After a
1980 # source-only upload, the buildds will try to upload files like
1981 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1982 # named like this in their (otherwise) source-only upload, the uploads
1983 # of the buildd can be rejected by dak. Fixing the resultant
1984 # situation can require manual intervention. So we block such
1985 # .buildinfo files when the user tells us to perform a source-only
1986 # upload (such as when using the push-source subcommand with the -C
1987 # option, which calls this function).
1989 # Note, though, that when dgit is told to prepare a source-only
1990 # upload, such as when subcommands like build-source and push-source
1991 # without -C are used, dgit has a more restrictive notion of
1992 # source-only .changes than dak: such uploads will never include
1993 # *_source.buildinfo files. This is because there is no use for such
1994 # files when using a tool like dgit to produce the source package, as
1995 # dgit ensures the source is identical to git HEAD.
1996 sub test_source_only_changes ($) {
1998 foreach my $l (split /\n/, getfield $changes, 'Files') {
1999 $l =~ m/\S+$/ or next;
2000 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
2001 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
2002 print f_ "purportedly source-only changes polluted by %s\n", $&;
2009 sub changes_update_origs_from_dsc ($$$$) {
2010 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
2012 printdebug "checking origs needed ($upstreamvsn)...\n";
2013 $_ = getfield $changes, 'Files';
2014 m/^\w+ \d+ (\S+ \S+) \S+$/m or
2015 fail __ "cannot find section/priority from .changes Files field";
2016 my $placementinfo = $1;
2018 printdebug "checking origs needed placement '$placementinfo'...\n";
2019 foreach my $l (split /\n/, getfield $dsc, 'Files') {
2020 $l =~ m/\S+$/ or next;
2022 printdebug "origs $file | $l\n";
2023 next unless is_orig_file_of_vsn $file, $upstreamvsn;
2024 printdebug "origs $file is_orig\n";
2025 my $have = archive_query('file_in_archive', $file);
2026 if (!defined $have) {
2027 print STDERR __ <<END;
2028 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2034 printdebug "origs $file \$#\$have=$#$have\n";
2035 foreach my $h (@$have) {
2038 foreach my $csumi (@files_csum_info_fields) {
2039 my ($fname, $module, $method, $archivefield) = @$csumi;
2040 next unless defined $h->{$archivefield};
2041 $_ = $dsc->{$fname};
2042 next unless defined;
2043 m/^(\w+) .* \Q$file\E$/m or
2044 fail f_ ".dsc %s missing entry for %s", $fname, $file;
2045 if ($h->{$archivefield} eq $1) {
2049 "%s: %s (archive) != %s (local .dsc)",
2050 $archivefield, $h->{$archivefield}, $1;
2053 confess "$file ".Dumper($h)." ?!" if $same && @differ;
2057 f_ "archive %s: %s", $h->{filename}, join "; ", @differ
2060 printdebug "origs $file f.same=$found_same".
2061 " #f._differ=$#found_differ\n";
2062 if (@found_differ && !$found_same) {
2064 (f_ "archive contains %s with different checksum", $file),
2067 # Now we edit the changes file to add or remove it
2068 foreach my $csumi (@files_csum_info_fields) {
2069 my ($fname, $module, $method, $archivefield) = @$csumi;
2070 next unless defined $changes->{$fname};
2072 # in archive, delete from .changes if it's there
2073 $changed{$file} = "removed" if
2074 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2075 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2076 # not in archive, but it's here in the .changes
2078 my $dsc_data = getfield $dsc, $fname;
2079 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2081 $extra =~ s/ \d+ /$&$placementinfo /
2082 or confess "$fname $extra >$dsc_data< ?"
2083 if $fname eq 'Files';
2084 $changes->{$fname} .= "\n". $extra;
2085 $changed{$file} = "added";
2090 foreach my $file (keys %changed) {
2092 "edited .changes for archive .orig contents: %s %s",
2093 $changed{$file}, $file;
2095 my $chtmp = "$changesfile.tmp";
2096 $changes->save($chtmp);
2098 rename $chtmp,$changesfile or die "$changesfile $!";
2100 progress f_ "[new .changes left in %s]", $changesfile;
2103 progress f_ "%s already has appropriate .orig(s) (if any)",
2108 sub make_commit ($) {
2110 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2113 sub clogp_authline ($) {
2115 my $author = getfield $clogp, 'Maintainer';
2116 if ($author =~ m/^[^"\@]+\,/) {
2117 # single entry Maintainer field with unquoted comma
2118 $author = ($& =~ y/,//rd).$'; # strip the comma
2120 # git wants a single author; any remaining commas in $author
2121 # are by now preceded by @ (or "). It seems safer to punt on
2122 # "..." for now rather than attempting to dequote or something.
2123 $author =~ s#,.*##ms unless $author =~ m/"/;
2124 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2125 my $authline = "$author $date";
2126 $authline =~ m/$git_authline_re/o or
2127 fail f_ "unexpected commit author line format \`%s'".
2128 " (was generated from changelog Maintainer field)",
2130 return ($1,$2,$3) if wantarray;
2134 sub vendor_patches_distro ($$) {
2135 my ($checkdistro, $what) = @_;
2136 return unless defined $checkdistro;
2138 my $series = "debian/patches/\L$checkdistro\E.series";
2139 printdebug "checking for vendor-specific $series ($what)\n";
2141 if (!open SERIES, "<", $series) {
2142 confess "$series $!" unless $!==ENOENT;
2149 print STDERR __ <<END;
2151 Unfortunately, this source package uses a feature of dpkg-source where
2152 the same source package unpacks to different source code on different
2153 distros. dgit cannot safely operate on such packages on affected
2154 distros, because the meaning of source packages is not stable.
2156 Please ask the distro/maintainer to remove the distro-specific series
2157 files and use a different technique (if necessary, uploading actually
2158 different packages, if different distros are supposed to have
2162 fail f_ "Found active distro-specific series file for".
2163 " %s (%s): %s, cannot continue",
2164 $checkdistro, $what, $series;
2166 die "$series $!" if SERIES->error;
2170 sub check_for_vendor_patches () {
2171 # This dpkg-source feature doesn't seem to be documented anywhere!
2172 # But it can be found in the changelog (reformatted):
2174 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2175 # Author: Raphael Hertzog <hertzog@debian.org>
2176 # Date: Sun Oct 3 09:36:48 2010 +0200
2178 # dpkg-source: correctly create .pc/.quilt_series with alternate
2181 # If you have debian/patches/ubuntu.series and you were
2182 # unpacking the source package on ubuntu, quilt was still
2183 # directed to debian/patches/series instead of
2184 # debian/patches/ubuntu.series.
2186 # debian/changelog | 3 +++
2187 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2188 # 2 files changed, 6 insertions(+), 1 deletion(-)
2191 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2192 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2193 __ "Dpkg::Vendor \`current vendor'");
2194 vendor_patches_distro(access_basedistro(),
2195 __ "(base) distro being accessed");
2196 vendor_patches_distro(access_nomdistro(),
2197 __ "(nominal) distro being accessed");
2200 sub check_bpd_exists () {
2201 stat $buildproductsdir
2202 or fail f_ "build-products-dir %s is not accessible: %s\n",
2203 $buildproductsdir, $!;
2206 sub dotdot_bpd_transfer_origs ($$$) {
2207 my ($bpd_abs, $upstreamversion, $wanted) = @_;
2208 # checks is_orig_file_of_vsn and if
2209 # calls $wanted->{$leaf} and expects boolish
2211 return if $buildproductsdir eq '..';
2214 my $dotdot = $maindir;
2215 $dotdot =~ s{/[^/]+$}{};
2216 opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
2217 while ($!=0, defined(my $leaf = readdir DD)) {
2219 local ($debuglevel) = $debuglevel-1;
2220 printdebug "DD_BPD $leaf ?\n";
2222 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
2223 next unless $wanted->($leaf);
2224 next if lstat "$bpd_abs/$leaf";
2227 "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
2230 $! == &ENOENT or fail f_
2231 "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
2232 lstat "$dotdot/$leaf" or fail f_
2233 "check orig file %s in ..: %s", $leaf, $!;
2235 stat "$dotdot/$leaf" or fail f_
2236 "check targe of orig symlink %s in ..: %s", $leaf, $!;
2237 my $ltarget = readlink "$dotdot/$leaf" or
2238 die "readlink $dotdot/$leaf: $!";
2239 if ($ltarget !~ m{^/}) {
2240 $ltarget = "$dotdot/$ltarget";
2242 symlink $ltarget, "$bpd_abs/$leaf"
2243 or die "$ltarget $bpd_abs $leaf: $!";
2245 "%s: cloned orig symlink from ..: %s\n",
2247 } elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
2249 "%s: hardlinked orig from ..: %s\n",
2251 } elsif ($! != EXDEV) {
2252 fail f_ "failed to make %s a hardlink to %s: %s",
2253 "$bpd_abs/$leaf", "$dotdot/$leaf", $!;
2255 symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
2256 or die "$bpd_abs $dotdot $leaf $!";
2258 "%s: symmlinked orig from .. on other filesystem: %s\n",
2262 die "$dotdot; $!" if $!;
2266 sub generate_commits_from_dsc () {
2267 # See big comment in fetch_from_archive, below.
2268 # See also README.dsc-import.
2270 changedir $playground;
2272 my $bpd_abs = bpd_abs();
2273 my $upstreamv = upstreamversion $dsc->{version};
2274 my @dfi = dsc_files_info();
2276 dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
2277 sub { grep { $_->{Filename} eq $_[0] } @dfi };
2279 foreach my $fi (@dfi) {
2280 my $f = $fi->{Filename};
2281 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2282 my $upper_f = "$bpd_abs/$f";
2284 printdebug "considering reusing $f: ";
2286 if (link_ltarget "$upper_f,fetch", $f) {
2287 printdebug "linked (using ...,fetch).\n";
2288 } elsif ((printdebug "($!) "),
2290 fail f_ "accessing %s: %s", "$buildproductsdir/$f,fetch", $!;
2291 } elsif (link_ltarget $upper_f, $f) {
2292 printdebug "linked.\n";
2293 } elsif ((printdebug "($!) "),
2295 fail f_ "accessing %s: %s", "$buildproductsdir/$f", $!;
2297 printdebug "absent.\n";
2301 complete_file_from_dsc('.', $fi, \$refetched)
2304 printdebug "considering saving $f: ";
2306 if (rename_link_xf 1, $f, $upper_f) {
2307 printdebug "linked.\n";
2308 } elsif ((printdebug "($@) "),
2310 fail f_ "saving %s: %s", "$buildproductsdir/$f", $@;
2311 } elsif (!$refetched) {
2312 printdebug "no need.\n";
2313 } elsif (rename_link_xf 1, $f, "$upper_f,fetch") {
2314 printdebug "linked (using ...,fetch).\n";
2315 } elsif ((printdebug "($@) "),
2317 fail f_ "saving %s: %s", "$buildproductsdir/$f,fetch", $@;
2319 printdebug "cannot.\n";
2323 # We unpack and record the orig tarballs first, so that we only
2324 # need disk space for one private copy of the unpacked source.
2325 # But we can't make them into commits until we have the metadata
2326 # from the debian/changelog, so we record the tree objects now and
2327 # make them into commits later.
2329 my $orig_f_base = srcfn $upstreamv, '';
2331 foreach my $fi (@dfi) {
2332 # We actually import, and record as a commit, every tarball
2333 # (unless there is only one file, in which case there seems
2336 my $f = $fi->{Filename};
2337 printdebug "import considering $f ";
2338 (printdebug "only one dfi\n"), next if @dfi == 1;
2339 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2340 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2344 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2346 printdebug "Y ", (join ' ', map { $_//"(none)" }
2347 $compr_ext, $orig_f_part
2350 my $input = new IO::File $f, '<' or die "$f $!";
2354 if (defined $compr_ext) {
2356 Dpkg::Compression::compression_guess_from_filename $f;
2357 fail "Dpkg::Compression cannot handle file $f in source package"
2358 if defined $compr_ext && !defined $cname;
2360 new Dpkg::Compression::Process compression => $cname;
2361 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2362 my $compr_fh = new IO::Handle;
2363 my $compr_pid = open $compr_fh, "-|" // confess $!;
2365 open STDIN, "<&", $input or confess $!;
2367 die "dgit (child): exec $compr_cmd[0]: $!\n";
2372 rmtree "_unpack-tar";
2373 mkdir "_unpack-tar" or confess $!;
2374 my @tarcmd = qw(tar -x -f -
2375 --no-same-owner --no-same-permissions
2376 --no-acls --no-xattrs --no-selinux);
2377 my $tar_pid = fork // confess $!;
2379 chdir "_unpack-tar" or confess $!;
2380 open STDIN, "<&", $input or confess $!;
2382 die f_ "dgit (child): exec %s: %s", $tarcmd[0], $!;
2384 $!=0; (waitpid $tar_pid, 0) == $tar_pid or confess $!;
2385 !$? or failedcmd @tarcmd;
2388 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2390 # finally, we have the results in "tarball", but maybe
2391 # with the wrong permissions
2393 runcmd qw(chmod -R +rwX _unpack-tar);
2394 changedir "_unpack-tar";
2395 remove_stray_gits($f);
2396 mktree_in_ud_here();
2398 my ($tree) = git_add_write_tree();
2399 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2400 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2402 printdebug "one subtree $1\n";
2404 printdebug "multiple subtrees\n";
2407 rmtree "_unpack-tar";
2409 my $ent = [ $f, $tree ];
2411 Orig => !!$orig_f_part,
2412 Sort => (!$orig_f_part ? 2 :
2413 $orig_f_part =~ m/-/g ? 1 :
2421 # put any without "_" first (spec is not clear whether files
2422 # are always in the usual order). Tarballs without "_" are
2423 # the main orig or the debian tarball.
2424 $a->{Sort} <=> $b->{Sort} or
2428 my $any_orig = grep { $_->{Orig} } @tartrees;
2430 my $dscfn = "$package.dsc";
2432 my $treeimporthow = 'package';
2434 open D, ">", $dscfn or die "$dscfn: $!";
2435 print D $dscdata or die "$dscfn: $!";
2436 close D or die "$dscfn: $!";
2437 my @cmd = qw(dpkg-source);
2438 push @cmd, '--no-check' if $dsc_checked;
2439 if (madformat $dsc->{format}) {
2440 push @cmd, '--skip-patches';
2441 $treeimporthow = 'unpatched';
2443 push @cmd, qw(-x --), $dscfn;
2446 my ($tree,$dir) = mktree_in_ud_from_only_subdir(__ "source package");
2447 if (madformat $dsc->{format}) {
2448 check_for_vendor_patches();
2452 if (madformat $dsc->{format}) {
2453 my @pcmd = qw(dpkg-source --before-build .);
2454 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2456 $dappliedtree = git_add_write_tree();
2459 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2463 printdebug "import clog search...\n";
2464 parsechangelog_loop \@clogcmd, (__ "package changelog"), sub {
2465 my ($thisstanza, $desc) = @_;
2466 no warnings qw(exiting);
2468 $clogp //= $thisstanza;
2470 printdebug "import clog $thisstanza->{version} $desc...\n";
2472 last if !$any_orig; # we don't need $r1clogp
2474 # We look for the first (most recent) changelog entry whose
2475 # version number is lower than the upstream version of this
2476 # package. Then the last (least recent) previous changelog
2477 # entry is treated as the one which introduced this upstream
2478 # version and used for the synthetic commits for the upstream
2481 # One might think that a more sophisticated algorithm would be
2482 # necessary. But: we do not want to scan the whole changelog
2483 # file. Stopping when we see an earlier version, which
2484 # necessarily then is an earlier upstream version, is the only
2485 # realistic way to do that. Then, either the earliest
2486 # changelog entry we have seen so far is indeed the earliest
2487 # upload of this upstream version; or there are only changelog
2488 # entries relating to later upstream versions (which is not
2489 # possible unless the changelog and .dsc disagree about the
2490 # version). Then it remains to choose between the physically
2491 # last entry in the file, and the one with the lowest version
2492 # number. If these are not the same, we guess that the
2493 # versions were created in a non-monotonic order rather than
2494 # that the changelog entries have been misordered.
2496 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2498 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2499 $r1clogp = $thisstanza;
2501 printdebug "import clog $r1clogp->{version} becomes r1\n";
2504 $clogp or fail __ "package changelog has no entries!";
2506 my $authline = clogp_authline $clogp;
2507 my $changes = getfield $clogp, 'Changes';
2508 $changes =~ s/^\n//; # Changes: \n
2509 my $cversion = getfield $clogp, 'Version';
2512 $r1clogp //= $clogp; # maybe there's only one entry;
2513 my $r1authline = clogp_authline $r1clogp;
2514 # Strictly, r1authline might now be wrong if it's going to be
2515 # unused because !$any_orig. Whatever.
2517 printdebug "import tartrees authline $authline\n";
2518 printdebug "import tartrees r1authline $r1authline\n";
2520 foreach my $tt (@tartrees) {
2521 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2523 my $mbody = f_ "Import %s", $tt->{F};
2524 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2527 committer $r1authline
2531 [dgit import orig $tt->{F}]
2539 [dgit import tarball $package $cversion $tt->{F}]
2544 printdebug "import main commit\n";
2546 open C, ">../commit.tmp" or confess $!;
2547 print C <<END or confess $!;
2550 print C <<END or confess $! foreach @tartrees;
2553 print C <<END or confess $!;
2559 [dgit import $treeimporthow $package $cversion]
2562 close C or confess $!;
2563 my $rawimport_hash = make_commit qw(../commit.tmp);
2565 if (madformat $dsc->{format}) {
2566 printdebug "import apply patches...\n";
2568 # regularise the state of the working tree so that
2569 # the checkout of $rawimport_hash works nicely.
2570 my $dappliedcommit = make_commit_text(<<END);
2577 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2579 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2581 # We need the answers to be reproducible
2582 my @authline = clogp_authline($clogp);
2583 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2584 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2585 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2586 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2587 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2588 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2590 my $path = $ENV{PATH} or die;
2592 # we use ../../gbp-pq-output, which (given that we are in
2593 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2596 foreach my $use_absurd (qw(0 1)) {
2597 runcmd @git, qw(checkout -q unpa);
2598 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2599 local $ENV{PATH} = $path;
2602 progress "warning: $@";
2603 $path = "$absurdity:$path";
2604 progress f_ "%s: trying slow absurd-git-apply...", $us;
2605 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2610 die "forbid absurd git-apply\n" if $use_absurd
2611 && forceing [qw(import-gitapply-no-absurd)];
2612 die "only absurd git-apply!\n" if !$use_absurd
2613 && forceing [qw(import-gitapply-absurd)];
2615 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2616 local $ENV{PATH} = $path if $use_absurd;
2618 my @showcmd = (gbp_pq, qw(import));
2619 my @realcmd = shell_cmd
2620 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2621 debugcmd "+",@realcmd;
2622 if (system @realcmd) {
2623 die f_ "%s failed: %s\n",
2624 +(shellquote @showcmd),
2625 failedcmd_waitstatus();
2628 my $gapplied = git_rev_parse('HEAD');
2629 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2630 $gappliedtree eq $dappliedtree or
2631 fail f_ <<END, $gapplied, $gappliedtree, $dappliedtree;
2632 gbp-pq import and dpkg-source disagree!
2633 gbp-pq import gave commit %s
2634 gbp-pq import gave tree %s
2635 dpkg-source --before-build gave tree %s
2637 $rawimport_hash = $gapplied;
2642 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2647 progress f_ "synthesised git commit from .dsc %s", $cversion;
2649 my $rawimport_mergeinput = {
2650 Commit => $rawimport_hash,
2651 Info => __ "Import of source package",
2653 my @output = ($rawimport_mergeinput);
2655 if ($lastpush_mergeinput) {
2656 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2657 my $oversion = getfield $oldclogp, 'Version';
2659 version_compare($oversion, $cversion);
2661 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2662 { ReverseParents => 1,
2663 Message => (f_ <<END, $package, $cversion, $csuite) });
2664 Record %s (%s) in archive suite %s
2666 } elsif ($vcmp > 0) {
2667 print STDERR f_ <<END, $cversion, $oversion,
2669 Version actually in archive: %s (older)
2670 Last version pushed with dgit: %s (newer or same)
2673 __ $later_warning_msg or confess $!;
2674 @output = $lastpush_mergeinput;
2676 # Same version. Use what's in the server git branch,
2677 # discarding our own import. (This could happen if the
2678 # server automatically imports all packages into git.)
2679 @output = $lastpush_mergeinput;
2687 sub complete_file_from_dsc ($$;$) {
2688 our ($dstdir, $fi, $refetched) = @_;
2689 # Ensures that we have, in $dstdir, the file $fi, with the correct
2690 # contents. (Downloading it from alongside $dscurl if necessary.)
2691 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2692 # and will set $$refetched=1 if it did so (or tried to).
2694 my $f = $fi->{Filename};
2695 my $tf = "$dstdir/$f";
2699 my $checkhash = sub {
2700 open F, "<", "$tf" or die "$tf: $!";
2701 $fi->{Digester}->reset();
2702 $fi->{Digester}->addfile(*F);
2703 F->error and confess $!;
2704 $got = $fi->{Digester}->hexdigest();
2705 return $got eq $fi->{Hash};
2708 if (stat_exists $tf) {
2709 if ($checkhash->()) {
2710 progress f_ "using existing %s", $f;
2714 fail f_ "file %s has hash %s but .dsc demands hash %s".
2715 " (perhaps you should delete this file?)",
2716 $f, $got, $fi->{Hash};
2718 progress f_ "need to fetch correct version of %s", $f;
2719 unlink $tf or die "$tf $!";
2722 printdebug "$tf does not exist, need to fetch\n";
2726 $furl =~ s{/[^/]+$}{};
2728 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2729 die "$f ?" if $f =~ m#/#;
2730 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2731 return 0 if !act_local();
2734 fail f_ "file %s has hash %s but .dsc demands hash %s".
2735 " (got wrong file from archive!)",
2736 $f, $got, $fi->{Hash};
2741 sub ensure_we_have_orig () {
2742 my @dfi = dsc_files_info();
2743 foreach my $fi (@dfi) {
2744 my $f = $fi->{Filename};
2745 next unless is_orig_file_in_dsc($f, \@dfi);
2746 complete_file_from_dsc($buildproductsdir, $fi)
2751 #---------- git fetch ----------
2753 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2754 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2756 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2757 # locally fetched refs because they have unhelpful names and clutter
2758 # up gitk etc. So we track whether we have "used up" head ref (ie,
2759 # whether we have made another local ref which refers to this object).
2761 # (If we deleted them unconditionally, then we might end up
2762 # re-fetching the same git objects each time dgit fetch was run.)
2764 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2765 # in git_fetch_us to fetch the refs in question, and possibly a call
2766 # to lrfetchref_used.
2768 our (%lrfetchrefs_f, %lrfetchrefs_d);
2769 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2771 sub lrfetchref_used ($) {
2772 my ($fullrefname) = @_;
2773 my $objid = $lrfetchrefs_f{$fullrefname};
2774 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2777 sub git_lrfetch_sane {
2778 my ($url, $supplementary, @specs) = @_;
2779 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2780 # at least as regards @specs. Also leave the results in
2781 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2782 # able to clean these up.
2784 # With $supplementary==1, @specs must not contain wildcards
2785 # and we add to our previous fetches (non-atomically).
2787 # This is rather miserable:
2788 # When git fetch --prune is passed a fetchspec ending with a *,
2789 # it does a plausible thing. If there is no * then:
2790 # - it matches subpaths too, even if the supplied refspec
2791 # starts refs, and behaves completely madly if the source
2792 # has refs/refs/something. (See, for example, Debian #NNNN.)
2793 # - if there is no matching remote ref, it bombs out the whole
2795 # We want to fetch a fixed ref, and we don't know in advance
2796 # if it exists, so this is not suitable.
2798 # Our workaround is to use git ls-remote. git ls-remote has its
2799 # own qairks. Notably, it has the absurd multi-tail-matching
2800 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2801 # refs/refs/foo etc.
2803 # Also, we want an idempotent snapshot, but we have to make two
2804 # calls to the remote: one to git ls-remote and to git fetch. The
2805 # solution is use git ls-remote to obtain a target state, and
2806 # git fetch to try to generate it. If we don't manage to generate
2807 # the target state, we try again.
2809 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2811 my $specre = join '|', map {
2814 my $wildcard = $x =~ s/\\\*$/.*/;
2815 die if $wildcard && $supplementary;
2818 printdebug "git_lrfetch_sane specre=$specre\n";
2819 my $wanted_rref = sub {
2821 return m/^(?:$specre)$/;
2824 my $fetch_iteration = 0;
2827 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2828 if (++$fetch_iteration > 10) {
2829 fail __ "too many iterations trying to get sane fetch!";
2832 my @look = map { "refs/$_" } @specs;
2833 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2837 open GITLS, "-|", @lcmd or confess $!;
2839 printdebug "=> ", $_;
2840 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2841 my ($objid,$rrefname) = ($1,$2);
2842 if (!$wanted_rref->($rrefname)) {
2843 print STDERR f_ <<END, "@look", $rrefname;
2844 warning: git ls-remote %s reported %s; this is silly, ignoring it.
2848 $wantr{$rrefname} = $objid;
2851 close GITLS or failedcmd @lcmd;
2853 # OK, now %want is exactly what we want for refs in @specs
2855 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2856 "+refs/$_:".lrfetchrefs."/$_";
2859 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2861 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2862 runcmd_ordryrun_local @fcmd if @fspecs;
2864 if (!$supplementary) {
2865 %lrfetchrefs_f = ();
2869 git_for_each_ref(lrfetchrefs, sub {
2870 my ($objid,$objtype,$lrefname,$reftail) = @_;
2871 $lrfetchrefs_f{$lrefname} = $objid;
2872 $objgot{$objid} = 1;
2875 if ($supplementary) {
2879 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2880 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2881 if (!exists $wantr{$rrefname}) {
2882 if ($wanted_rref->($rrefname)) {
2884 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2887 print STDERR f_ <<END, "@fspecs", $lrefname
2888 warning: git fetch %s created %s; this is silly, deleting it.
2891 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2892 delete $lrfetchrefs_f{$lrefname};
2896 foreach my $rrefname (sort keys %wantr) {
2897 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2898 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2899 my $want = $wantr{$rrefname};
2900 next if $got eq $want;
2901 if (!defined $objgot{$want}) {
2902 fail __ <<END unless act_local();
2903 --dry-run specified but we actually wanted the results of git fetch,
2904 so this is not going to work. Try running dgit fetch first,
2905 or using --damp-run instead of --dry-run.
2907 print STDERR f_ <<END, $lrefname, $want;
2908 warning: git ls-remote suggests we want %s
2909 warning: and it should refer to %s
2910 warning: but git fetch didn't fetch that object to any relevant ref.
2911 warning: This may be due to a race with someone updating the server.
2912 warning: Will try again...
2914 next FETCH_ITERATION;
2917 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2919 runcmd_ordryrun_local @git, qw(update-ref -m),
2920 "dgit fetch git fetch fixup", $lrefname, $want;
2921 $lrfetchrefs_f{$lrefname} = $want;
2926 if (defined $csuite) {
2927 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2928 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2929 my ($objid,$objtype,$lrefname,$reftail) = @_;
2930 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2931 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2935 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2936 Dumper(\%lrfetchrefs_f);
2939 sub git_fetch_us () {
2940 # Want to fetch only what we are going to use, unless
2941 # deliberately-not-ff, in which case we must fetch everything.
2943 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2945 (quiltmode_splitbrain
2946 ? (map { $_->('*',access_nomdistro) }
2947 \&debiantag_new, \&debiantag_maintview)
2948 : debiantags('*',access_nomdistro));
2949 push @specs, server_branch($csuite);
2950 push @specs, $rewritemap;
2951 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2953 my $url = access_giturl();
2954 git_lrfetch_sane $url, 0, @specs;
2957 my @tagpats = debiantags('*',access_nomdistro);
2959 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2960 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2961 printdebug "currently $fullrefname=$objid\n";
2962 $here{$fullrefname} = $objid;
2964 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2965 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2966 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2967 printdebug "offered $lref=$objid\n";
2968 if (!defined $here{$lref}) {
2969 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2970 runcmd_ordryrun_local @upd;
2971 lrfetchref_used $fullrefname;
2972 } elsif ($here{$lref} eq $objid) {
2973 lrfetchref_used $fullrefname;
2975 print STDERR f_ "Not updating %s from %s to %s.\n",
2976 $lref, $here{$lref}, $objid;
2981 #---------- dsc and archive handling ----------
2983 sub mergeinfo_getclogp ($) {
2984 # Ensures thit $mi->{Clogp} exists and returns it
2986 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2989 sub mergeinfo_version ($) {
2990 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2993 sub fetch_from_archive_record_1 ($) {
2995 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2996 cmdoutput @git, qw(log -n2), $hash;
2997 # ... gives git a chance to complain if our commit is malformed
3000 sub fetch_from_archive_record_2 ($) {
3002 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
3006 dryrun_report @upd_cmd;
3010 sub parse_dsc_field_def_dsc_distro () {
3011 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
3012 dgit.default.distro);
3015 sub parse_dsc_field ($$) {
3016 my ($dsc, $what) = @_;
3018 foreach my $field (@ourdscfield) {
3019 $f = $dsc->{$field};
3024 progress f_ "%s: NO git hash", $what;
3025 parse_dsc_field_def_dsc_distro();
3026 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
3027 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
3028 progress f_ "%s: specified git info (%s)", $what, $dsc_distro;
3029 $dsc_hint_tag = [ $dsc_hint_tag ];
3030 } elsif ($f =~ m/^\w+\s*$/) {
3032 parse_dsc_field_def_dsc_distro();
3033 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
3035 progress f_ "%s: specified git hash", $what;
3037 fail f_ "%s: invalid Dgit info", $what;
3041 sub resolve_dsc_field_commit ($$) {
3042 my ($already_distro, $already_mapref) = @_;
3044 return unless defined $dsc_hash;
3047 defined $already_mapref &&
3048 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
3049 ? $already_mapref : undef;
3053 my ($what, @fetch) = @_;
3055 local $idistro = $dsc_distro;
3056 my $lrf = lrfetchrefs;
3058 if (!$chase_dsc_distro) {
3059 progress f_ "not chasing .dsc distro %s: not fetching %s",
3064 progress f_ ".dsc names distro %s: fetching %s", $dsc_distro, $what;
3066 my $url = access_giturl();
3067 if (!defined $url) {
3068 defined $dsc_hint_url or fail f_ <<END, $dsc_distro;
3069 .dsc Dgit metadata is in context of distro %s
3070 for which we have no configured url and .dsc provides no hint
3073 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
3074 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
3075 parse_cfg_bool "dsc-url-proto-ok", 'false',
3076 cfg("dgit.dsc-url-proto-ok.$proto",
3077 "dgit.default.dsc-url-proto-ok")
3078 or fail f_ <<END, $dsc_distro, $proto;
3079 .dsc Dgit metadata is in context of distro %s
3080 for which we have no configured url;
3081 .dsc provides hinted url with protocol %s which is unsafe.
3082 (can be overridden by config - consult documentation)
3084 $url = $dsc_hint_url;
3087 git_lrfetch_sane $url, 1, @fetch;
3092 my $rewrite_enable = do {
3093 local $idistro = $dsc_distro;
3094 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
3097 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
3098 if (!defined $mapref) {
3099 my $lrf = $do_fetch->((__ "rewrite map"), $rewritemap) or return;
3100 $mapref = $lrf.'/'.$rewritemap;
3102 my $rewritemapdata = git_cat_file $mapref.':map';
3103 if (defined $rewritemapdata
3104 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
3106 "server's git history rewrite map contains a relevant entry!";
3109 if (defined $dsc_hash) {
3110 progress __ "using rewritten git hash in place of .dsc value";
3112 progress __ "server data says .dsc hash is to be disregarded";
3117 if (!defined git_cat_file $dsc_hash) {
3118 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3119 my $lrf = $do_fetch->((__ "additional commits"), @tags) &&
3120 defined git_cat_file $dsc_hash
3121 or fail f_ <<END, $dsc_hash;
3122 .dsc Dgit metadata requires commit %s
3123 but we could not obtain that object anywhere.
3125 foreach my $t (@tags) {
3126 my $fullrefname = $lrf.'/'.$t;
3127 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3128 next unless $lrfetchrefs_f{$fullrefname};
3129 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3130 lrfetchref_used $fullrefname;
3135 sub fetch_from_archive () {
3137 ensure_setup_existing_tree();
3139 # Ensures that lrref() is what is actually in the archive, one way
3140 # or another, according to us - ie this client's
3141 # appropritaely-updated archive view. Also returns the commit id.
3142 # If there is nothing in the archive, leaves lrref alone and
3143 # returns undef. git_fetch_us must have already been called.
3147 parse_dsc_field($dsc, __ 'last upload to archive');
3148 resolve_dsc_field_commit access_basedistro,
3149 lrfetchrefs."/".$rewritemap
3151 progress __ "no version available from the archive";
3154 # If the archive's .dsc has a Dgit field, there are three
3155 # relevant git commitids we need to choose between and/or merge
3157 # 1. $dsc_hash: the Dgit field from the archive
3158 # 2. $lastpush_hash: the suite branch on the dgit git server
3159 # 3. $lastfetch_hash: our local tracking brach for the suite
3161 # These may all be distinct and need not be in any fast forward
3164 # If the dsc was pushed to this suite, then the server suite
3165 # branch will have been updated; but it might have been pushed to
3166 # a different suite and copied by the archive. Conversely a more
3167 # recent version may have been pushed with dgit but not appeared
3168 # in the archive (yet).
3170 # $lastfetch_hash may be awkward because archive imports
3171 # (particularly, imports of Dgit-less .dscs) are performed only as
3172 # needed on individual clients, so different clients may perform a
3173 # different subset of them - and these imports are only made
3174 # public during push. So $lastfetch_hash may represent a set of
3175 # imports different to a subsequent upload by a different dgit
3178 # Our approach is as follows:
3180 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3181 # descendant of $dsc_hash, then it was pushed by a dgit user who
3182 # had based their work on $dsc_hash, so we should prefer it.
3183 # Otherwise, $dsc_hash was installed into this suite in the
3184 # archive other than by a dgit push, and (necessarily) after the
3185 # last dgit push into that suite (since a dgit push would have
3186 # been descended from the dgit server git branch); thus, in that
3187 # case, we prefer the archive's version (and produce a
3188 # pseudo-merge to overwrite the dgit server git branch).
3190 # (If there is no Dgit field in the archive's .dsc then
3191 # generate_commit_from_dsc uses the version numbers to decide
3192 # whether the suite branch or the archive is newer. If the suite
3193 # branch is newer it ignores the archive's .dsc; otherwise it
3194 # generates an import of the .dsc, and produces a pseudo-merge to
3195 # overwrite the suite branch with the archive contents.)
3197 # The outcome of that part of the algorithm is the `public view',
3198 # and is same for all dgit clients: it does not depend on any
3199 # unpublished history in the local tracking branch.
3201 # As between the public view and the local tracking branch: The
3202 # local tracking branch is only updated by dgit fetch, and
3203 # whenever dgit fetch runs it includes the public view in the
3204 # local tracking branch. Therefore if the public view is not
3205 # descended from the local tracking branch, the local tracking
3206 # branch must contain history which was imported from the archive
3207 # but never pushed; and, its tip is now out of date. So, we make
3208 # a pseudo-merge to overwrite the old imports and stitch the old
3211 # Finally: we do not necessarily reify the public view (as
3212 # described above). This is so that we do not end up stacking two
3213 # pseudo-merges. So what we actually do is figure out the inputs
3214 # to any public view pseudo-merge and put them in @mergeinputs.
3217 # $mergeinputs[]{Commit}
3218 # $mergeinputs[]{Info}
3219 # $mergeinputs[0] is the one whose tree we use
3220 # @mergeinputs is in the order we use in the actual commit)
3223 # $mergeinputs[]{Message} is a commit message to use
3224 # $mergeinputs[]{ReverseParents} if def specifies that parent
3225 # list should be in opposite order
3226 # Such an entry has no Commit or Info. It applies only when found
3227 # in the last entry. (This ugliness is to support making
3228 # identical imports to previous dgit versions.)
3230 my $lastpush_hash = git_get_ref(lrfetchref());
3231 printdebug "previous reference hash=$lastpush_hash\n";
3232 $lastpush_mergeinput = $lastpush_hash && {
3233 Commit => $lastpush_hash,
3234 Info => (__ "dgit suite branch on dgit git server"),
3237 my $lastfetch_hash = git_get_ref(lrref());
3238 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3239 my $lastfetch_mergeinput = $lastfetch_hash && {
3240 Commit => $lastfetch_hash,
3241 Info => (__ "dgit client's archive history view"),
3244 my $dsc_mergeinput = $dsc_hash && {
3245 Commit => $dsc_hash,
3246 Info => (__ "Dgit field in .dsc from archive"),
3250 my $del_lrfetchrefs = sub {
3253 printdebug "del_lrfetchrefs...\n";
3254 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3255 my $objid = $lrfetchrefs_d{$fullrefname};
3256 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3258 $gur ||= new IO::Handle;
3259 open $gur, "|-", qw(git update-ref --stdin) or confess $!;
3261 printf $gur "delete %s %s\n", $fullrefname, $objid;
3264 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3268 if (defined $dsc_hash) {
3269 ensure_we_have_orig();
3270 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3271 @mergeinputs = $dsc_mergeinput
3272 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3273 print STDERR f_ <<END, $dsc_hash, $lastpush_hash,
3275 Git commit in archive is behind the last version allegedly pushed/uploaded.
3276 Commit referred to by archive: %s
3277 Last version pushed with dgit: %s
3280 __ $later_warning_msg or confess $!;
3281 @mergeinputs = ($lastpush_mergeinput);
3283 # Archive has .dsc which is not a descendant of the last dgit
3284 # push. This can happen if the archive moves .dscs about.
3285 # Just follow its lead.
3286 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3287 progress __ "archive .dsc names newer git commit";
3288 @mergeinputs = ($dsc_mergeinput);
3290 progress __ "archive .dsc names other git commit, fixing up";
3291 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3295 @mergeinputs = generate_commits_from_dsc();
3296 # We have just done an import. Now, our import algorithm might
3297 # have been improved. But even so we do not want to generate
3298 # a new different import of the same package. So if the
3299 # version numbers are the same, just use our existing version.
3300 # If the version numbers are different, the archive has changed
3301 # (perhaps, rewound).
3302 if ($lastfetch_mergeinput &&
3303 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3304 (mergeinfo_version $mergeinputs[0]) )) {
3305 @mergeinputs = ($lastfetch_mergeinput);
3307 } elsif ($lastpush_hash) {
3308 # only in git, not in the archive yet
3309 @mergeinputs = ($lastpush_mergeinput);
3310 print STDERR f_ <<END,
3312 Package not found in the archive, but has allegedly been pushed using dgit.
3315 __ $later_warning_msg or confess $!;
3317 printdebug "nothing found!\n";
3318 if (defined $skew_warning_vsn) {
3319 print STDERR f_ <<END, $skew_warning_vsn or confess $!;
3321 Warning: relevant archive skew detected.
3322 Archive allegedly contains %s
3323 But we were not able to obtain any version from the archive or git.
3327 unshift @end, $del_lrfetchrefs;
3331 if ($lastfetch_hash &&
3333 my $h = $_->{Commit};
3334 $h and is_fast_fwd($lastfetch_hash, $h);
3335 # If true, one of the existing parents of this commit
3336 # is a descendant of the $lastfetch_hash, so we'll
3337 # be ff from that automatically.
3341 push @mergeinputs, $lastfetch_mergeinput;
3344 printdebug "fetch mergeinfos:\n";
3345 foreach my $mi (@mergeinputs) {
3347 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3349 printdebug sprintf " ReverseParents=%d Message=%s",
3350 $mi->{ReverseParents}, $mi->{Message};
3354 my $compat_info= pop @mergeinputs
3355 if $mergeinputs[$#mergeinputs]{Message};
3357 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3360 if (@mergeinputs > 1) {
3362 my $tree_commit = $mergeinputs[0]{Commit};
3364 my $tree = get_tree_of_commit $tree_commit;;
3366 # We use the changelog author of the package in question the
3367 # author of this pseudo-merge. This is (roughly) correct if
3368 # this commit is simply representing aa non-dgit upload.
3369 # (Roughly because it does not record sponsorship - but we
3370 # don't have sponsorship info because that's in the .changes,
3371 # which isn't in the archivw.)
3373 # But, it might be that we are representing archive history
3374 # updates (including in-archive copies). These are not really
3375 # the responsibility of the person who created the .dsc, but
3376 # there is no-one whose name we should better use. (The
3377 # author of the .dsc-named commit is clearly worse.)
3379 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3380 my $author = clogp_authline $useclogp;
3381 my $cversion = getfield $useclogp, 'Version';
3383 my $mcf = dgit_privdir()."/mergecommit";
3384 open MC, ">", $mcf or die "$mcf $!";
3385 print MC <<END or confess $!;
3389 my @parents = grep { $_->{Commit} } @mergeinputs;
3390 @parents = reverse @parents if $compat_info->{ReverseParents};
3391 print MC <<END or confess $! foreach @parents;
3395 print MC <<END or confess $!;
3401 if (defined $compat_info->{Message}) {
3402 print MC $compat_info->{Message} or confess $!;
3404 print MC f_ <<END, $package, $cversion, $csuite or confess $!;
3405 Record %s (%s) in archive suite %s
3409 my $message_add_info = sub {
3411 my $mversion = mergeinfo_version $mi;
3412 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3416 $message_add_info->($mergeinputs[0]);
3417 print MC __ <<END or confess $!;
3418 should be treated as descended from
3420 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3423 close MC or confess $!;
3424 $hash = make_commit $mcf;
3426 $hash = $mergeinputs[0]{Commit};
3428 printdebug "fetch hash=$hash\n";
3431 my ($lasth, $what) = @_;
3432 return unless $lasth;
3433 confess "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3436 $chkff->($lastpush_hash, __ 'dgit repo server tip (last push)')
3438 $chkff->($lastfetch_hash, __ 'local tracking tip (last fetch)');
3440 fetch_from_archive_record_1($hash);
3442 if (defined $skew_warning_vsn) {
3443 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3444 my $gotclogp = commit_getclogp($hash);
3445 my $got_vsn = getfield $gotclogp, 'Version';
3446 printdebug "SKEW CHECK GOT $got_vsn\n";
3447 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3448 print STDERR f_ <<END, $skew_warning_vsn, $got_vsn or confess $!;
3450 Warning: archive skew detected. Using the available version:
3451 Archive allegedly contains %s
3452 We were able to obtain only %s
3458 if ($lastfetch_hash ne $hash) {
3459 fetch_from_archive_record_2($hash);
3462 lrfetchref_used lrfetchref();
3464 check_gitattrs($hash, __ "fetched source tree");
3466 unshift @end, $del_lrfetchrefs;
3470 sub set_local_git_config ($$) {
3472 runcmd @git, qw(config), $k, $v;
3475 sub setup_mergechangelogs (;$) {
3477 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3479 my $driver = 'dpkg-mergechangelogs';
3480 my $cb = "merge.$driver";
3481 confess unless defined $maindir;
3482 my $attrs = "$maindir_gitcommon/info/attributes";
3483 ensuredir "$maindir_gitcommon/info";
3485 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3486 if (!open ATTRS, "<", $attrs) {
3487 $!==ENOENT or die "$attrs: $!";
3491 next if m{^debian/changelog\s};
3492 print NATTRS $_, "\n" or confess $!;
3494 ATTRS->error and confess $!;
3497 print NATTRS "debian/changelog merge=$driver\n" or confess $!;
3500 set_local_git_config "$cb.name", __ 'debian/changelog merge driver';
3501 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3503 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3506 sub setup_useremail (;$) {
3508 return unless $always || access_cfg_bool(1, 'setup-useremail');
3511 my ($k, $envvar) = @_;
3512 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3513 return unless defined $v;
3514 set_local_git_config "user.$k", $v;
3517 $setup->('email', 'DEBEMAIL');
3518 $setup->('name', 'DEBFULLNAME');
3521 sub ensure_setup_existing_tree () {
3522 my $k = "remote.$remotename.skipdefaultupdate";
3523 my $c = git_get_config $k;
3524 return if defined $c;
3525 set_local_git_config $k, 'true';
3528 sub open_main_gitattrs () {
3529 confess 'internal error no maindir' unless defined $maindir;
3530 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3532 or die "open $maindir_gitcommon/info/attributes: $!";
3536 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3538 sub is_gitattrs_setup () {
3541 # 1: gitattributes set up and should be left alone
3543 # 0: there is a dgit-defuse-attrs but it needs fixing
3544 # undef: there is none
3545 my $gai = open_main_gitattrs();
3546 return 0 unless $gai;
3548 next unless m{$gitattrs_ourmacro_re};
3549 return 1 if m{\s-working-tree-encoding\s};
3550 printdebug "is_gitattrs_setup: found old macro\n";
3553 $gai->error and confess $!;
3554 printdebug "is_gitattrs_setup: found nothing\n";
3558 sub setup_gitattrs (;$) {
3560 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3562 my $already = is_gitattrs_setup();
3565 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3566 not doing further gitattributes setup
3570 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3571 my $af = "$maindir_gitcommon/info/attributes";
3572 ensuredir "$maindir_gitcommon/info";
3574 open GAO, "> $af.new" or confess $!;
3575 print GAO <<END, __ <<ENDT or confess $! unless defined $already;
3579 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3581 my $gai = open_main_gitattrs();
3584 if (m{$gitattrs_ourmacro_re}) {
3585 die unless defined $already;
3589 print GAO $_, "\n" or confess $!;
3591 $gai->error and confess $!;
3593 close GAO or confess $!;
3594 rename "$af.new", "$af" or fail f_ "install %s: %s", $af, $!;
3597 sub setup_new_tree () {
3598 setup_mergechangelogs();
3603 sub check_gitattrs ($$) {
3604 my ($treeish, $what) = @_;
3606 return if is_gitattrs_setup;
3609 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3611 my $gafl = new IO::File;
3612 open $gafl, "-|", @cmd or confess $!;
3615 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3617 next unless m{(?:^|/)\.gitattributes$};
3619 # oh dear, found one
3620 print STDERR f_ <<END, $what;
3621 dgit: warning: %s contains .gitattributes
3622 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3627 # tree contains no .gitattributes files
3628 $?=0; $!=0; close $gafl or failedcmd @cmd;
3632 sub multisuite_suite_child ($$$) {
3633 my ($tsuite, $mergeinputs, $fn) = @_;
3634 # in child, sets things up, calls $fn->(), and returns undef
3635 # in parent, returns canonical suite name for $tsuite
3636 my $canonsuitefh = IO::File::new_tmpfile;
3637 my $pid = fork // confess $!;
3641 $us .= " [$isuite]";
3642 $debugprefix .= " ";
3643 progress f_ "fetching %s...", $tsuite;
3644 canonicalise_suite();
3645 print $canonsuitefh $csuite, "\n" or confess $!;
3646 close $canonsuitefh or confess $!;
3650 waitpid $pid,0 == $pid or confess $!;
3651 fail f_ "failed to obtain %s: %s", $tsuite, waitstatusmsg()
3653 seek $canonsuitefh,0,0 or confess $!;
3654 local $csuite = <$canonsuitefh>;
3655 confess $! unless defined $csuite && chomp $csuite;
3657 printdebug "multisuite $tsuite missing\n";
3660 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3661 push @$mergeinputs, {
3668 sub fork_for_multisuite ($) {
3669 my ($before_fetch_merge) = @_;
3670 # if nothing unusual, just returns ''
3673 # returns 0 to caller in child, to do first of the specified suites
3674 # in child, $csuite is not yet set
3676 # returns 1 to caller in parent, to finish up anything needed after
3677 # in parent, $csuite is set to canonicalised portmanteau
3679 my $org_isuite = $isuite;
3680 my @suites = split /\,/, $isuite;
3681 return '' unless @suites > 1;
3682 printdebug "fork_for_multisuite: @suites\n";
3686 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3688 return 0 unless defined $cbasesuite;
3690 fail f_ "package %s missing in (base suite) %s", $package, $cbasesuite
3691 unless @mergeinputs;
3693 my @csuites = ($cbasesuite);
3695 $before_fetch_merge->();
3697 foreach my $tsuite (@suites[1..$#suites]) {
3698 $tsuite =~ s/^-/$cbasesuite-/;
3699 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3706 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3707 push @csuites, $csubsuite;
3710 foreach my $mi (@mergeinputs) {
3711 my $ref = git_get_ref $mi->{Ref};
3712 die "$mi->{Ref} ?" unless length $ref;
3713 $mi->{Commit} = $ref;
3716 $csuite = join ",", @csuites;
3718 my $previous = git_get_ref lrref;
3720 unshift @mergeinputs, {
3721 Commit => $previous,
3722 Info => (__ "local combined tracking branch"),
3724 "archive seems to have rewound: local tracking branch is ahead!"),
3728 foreach my $ix (0..$#mergeinputs) {
3729 $mergeinputs[$ix]{Index} = $ix;
3732 @mergeinputs = sort {
3733 -version_compare(mergeinfo_version $a,
3734 mergeinfo_version $b) # highest version first
3736 $a->{Index} <=> $b->{Index}; # earliest in spec first
3742 foreach my $mi (@mergeinputs) {
3743 printdebug "multisuite merge check $mi->{Info}\n";
3744 foreach my $previous (@needed) {
3745 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3746 printdebug "multisuite merge un-needed $previous->{Info}\n";
3750 printdebug "multisuite merge this-needed\n";
3751 $mi->{Character} = '+';
3754 $needed[0]{Character} = '*';
3756 my $output = $needed[0]{Commit};
3759 printdebug "multisuite merge nontrivial\n";
3760 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3762 my $commit = "tree $tree\n";
3763 my $msg = f_ "Combine archive branches %s [dgit]\n\n".
3764 "Input branches:\n",
3767 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3768 printdebug "multisuite merge include $mi->{Info}\n";
3769 $mi->{Character} //= ' ';
3770 $commit .= "parent $mi->{Commit}\n";
3771 $msg .= sprintf " %s %-25s %s\n",
3773 (mergeinfo_version $mi),
3776 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3777 $msg .= __ "\nKey\n".
3778 " * marks the highest version branch, which choose to use\n".
3779 " + marks each branch which was not already an ancestor\n\n";
3781 "[dgit multi-suite $csuite]\n";
3783 "author $authline\n".
3784 "committer $authline\n\n";
3785 $output = make_commit_text $commit.$msg;
3786 printdebug "multisuite merge generated $output\n";
3789 fetch_from_archive_record_1($output);
3790 fetch_from_archive_record_2($output);
3792 progress f_ "calculated combined tracking suite %s", $csuite;
3797 sub clone_set_head () {
3798 open H, "> .git/HEAD" or confess $!;
3799 print H "ref: ".lref()."\n" or confess $!;
3800 close H or confess $!;
3802 sub clone_finish ($) {
3804 runcmd @git, qw(reset --hard), lrref();
3805 runcmd qw(bash -ec), <<'END';
3807 git ls-tree -r --name-only -z HEAD | \
3808 xargs -0r touch -h -r . --
3810 printdone f_ "ready for work in %s", $dstdir;
3814 # in multisuite, returns twice!
3815 # once in parent after first suite fetched,
3816 # and then again in child after everything is finished
3818 badusage __ "dry run makes no sense with clone" unless act_local();
3820 my $multi_fetched = fork_for_multisuite(sub {
3821 printdebug "multi clone before fetch merge\n";
3825 if ($multi_fetched) {
3826 printdebug "multi clone after fetch merge\n";
3828 clone_finish($dstdir);
3831 printdebug "clone main body\n";
3833 mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
3837 canonicalise_suite();
3838 my $hasgit = check_for_git();
3840 runcmd @git, qw(init -q);
3844 my $giturl = access_giturl(1);
3845 if (defined $giturl) {
3846 runcmd @git, qw(remote add), 'origin', $giturl;
3849 progress __ "fetching existing git history";
3851 runcmd_ordryrun_local @git, qw(fetch origin);
3853 progress __ "starting new git history";
3855 fetch_from_archive() or no_such_package;
3856 my $vcsgiturl = $dsc->{'Vcs-Git'};
3857 if (length $vcsgiturl) {
3858 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3859 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3861 clone_finish($dstdir);
3865 canonicalise_suite();
3866 if (check_for_git()) {
3869 fetch_from_archive() or no_such_package();
3871 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3872 if (length $vcsgiturl and
3873 (grep { $csuite eq $_ }
3875 cfg 'dgit.vcs-git.suites')) {
3876 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3877 if (defined $current && $current ne $vcsgiturl) {
3878 print STDERR f_ <<END, $csuite;
3879 FYI: Vcs-Git in %s has different url to your vcs-git remote.
3880 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3884 printdone f_ "fetched into %s", lrref();
3888 my $multi_fetched = fork_for_multisuite(sub { });
3889 fetch_one() unless $multi_fetched; # parent
3890 finish 0 if $multi_fetched eq '0'; # child
3895 runcmd_ordryrun_local @git, qw(merge -m),
3896 (f_ "Merge from %s [dgit]", $csuite),
3898 printdone f_ "fetched to %s and merged into HEAD", lrref();
3901 sub check_not_dirty () {
3902 my @forbid = qw(local-options local-patch-header);
3903 @forbid = map { "debian/source/$_" } @forbid;
3904 foreach my $f (@forbid) {
3905 if (stat_exists $f) {
3906 fail f_ "git tree contains %s", $f;
3910 my @cmd = (@git, qw(status -uall --ignored --porcelain));
3911 push @cmd, qw(debian/source/format debian/source/options);
3914 my $bad = cmdoutput @cmd;
3917 "you have uncommitted changes to critical files, cannot continue:\n").
3921 return if $includedirty;
3923 git_check_unmodified();
3926 sub commit_admin ($) {
3929 runcmd_ordryrun_local @git, qw(commit -m), $m;
3932 sub quiltify_nofix_bail ($$) {
3933 my ($headinfo, $xinfo) = @_;
3934 if ($quilt_mode eq 'nofix') {
3936 "quilt fixup required but quilt mode is \`nofix'\n".
3937 "HEAD commit%s differs from tree implied by debian/patches%s",
3942 sub commit_quilty_patch () {
3943 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3945 foreach my $l (split /\n/, $output) {
3946 next unless $l =~ m/\S/;
3947 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3951 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3953 progress __ "nothing quilty to commit, ok.";
3956 quiltify_nofix_bail "", __ " (wanted to commit patch update)";
3957 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3958 runcmd_ordryrun_local @git, qw(add -f), @adds;
3959 commit_admin +(__ <<ENDT).<<END
3960 Commit Debian 3.0 (quilt) metadata
3963 [dgit ($our_version) quilt-fixup]
3967 sub get_source_format () {
3969 if (open F, "debian/source/options") {
3973 s/\s+$//; # ignore missing final newline
3975 my ($k, $v) = ($`, $'); #');
3976 $v =~ s/^"(.*)"$/$1/;
3982 F->error and confess $!;
3985 confess $! unless $!==&ENOENT;
3988 if (!open F, "debian/source/format") {
3989 confess $! unless $!==&ENOENT;
3993 F->error and confess $!;
3995 return ($_, \%options);
3998 sub madformat_wantfixup ($) {
4000 return 0 unless $format eq '3.0 (quilt)';
4001 our $quilt_mode_warned;
4002 if ($quilt_mode eq 'nocheck') {
4003 progress f_ "Not doing any fixup of \`%s'".
4004 " due to ----no-quilt-fixup or --quilt=nocheck", $format
4005 unless $quilt_mode_warned++;
4008 progress f_ "Format \`%s', need to check/update patch stack", $format
4009 unless $quilt_mode_warned++;
4013 sub maybe_split_brain_save ($$$) {
4014 my ($headref, $dgitview, $msg) = @_;
4015 # => message fragment "$saved" describing disposition of $dgitview
4016 # (used inside parens, in the English texts)
4017 my $save = $internal_object_save{'dgit-view'};
4018 return f_ "commit id %s", $dgitview unless defined $save;
4019 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
4021 "dgit --dgit-view-save $msg HEAD=$headref",
4024 return f_ "and left in %s", $save;
4027 # An "infopair" is a tuple [ $thing, $what ]
4028 # (often $thing is a commit hash; $what is a description)
4030 sub infopair_cond_equal ($$) {
4032 $x->[0] eq $y->[0] or fail <<END;
4033 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
4037 sub infopair_lrf_tag_lookup ($$) {
4038 my ($tagnames, $what) = @_;
4039 # $tagname may be an array ref
4040 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
4041 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
4042 foreach my $tagname (@tagnames) {
4043 my $lrefname = lrfetchrefs."/tags/$tagname";
4044 my $tagobj = $lrfetchrefs_f{$lrefname};
4045 next unless defined $tagobj;
4046 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
4047 return [ git_rev_parse($tagobj), $what ];
4049 fail @tagnames==1 ? (f_ <<END, $what, "@tagnames")
4050 Wanted tag %s (%s) on dgit server, but not found
4052 : (f_ <<END, $what, "@tagnames");
4053 Wanted tag %s (one of: %s) on dgit server, but not found
4057 sub infopair_cond_ff ($$) {
4058 my ($anc,$desc) = @_;
4059 is_fast_fwd($anc->[0], $desc->[0]) or
4060 fail f_ <<END, $anc->[1], $anc->[0], $desc->[1], $desc->[0];
4061 %s (%s) .. %s (%s) is not fast forward
4065 sub pseudomerge_version_check ($$) {
4066 my ($clogp, $archive_hash) = @_;
4068 my $arch_clogp = commit_getclogp $archive_hash;
4069 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
4070 __ 'version currently in archive' ];
4071 if (defined $overwrite_version) {
4072 if (length $overwrite_version) {
4073 infopair_cond_equal([ $overwrite_version,
4074 '--overwrite= version' ],
4077 my $v = $i_arch_v->[0];
4079 "Checking package changelog for archive version %s ...", $v;
4082 my @xa = ("-f$v", "-t$v");
4083 my $vclogp = parsechangelog @xa;
4086 [ (getfield $vclogp, $fn),
4087 (f_ "%s field from dpkg-parsechangelog %s",
4090 my $cv = $gf->('Version');
4091 infopair_cond_equal($i_arch_v, $cv);
4092 $cd = $gf->('Distribution');
4095 $@ =~ s/^dgit: //gm;
4097 f_ "Perhaps debian/changelog does not mention %s ?", $v;
4099 fail f_ <<END, $cd->[1], $cd->[0], $v
4101 Your tree seems to based on earlier (not uploaded) %s.
4103 if $cd->[0] =~ m/UNRELEASED/;
4107 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
4111 sub pseudomerge_make_commit ($$$$ $$) {
4112 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
4113 $msg_cmd, $msg_msg) = @_;
4114 progress f_ "Declaring that HEAD includes all changes in %s...",
4117 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
4118 my $authline = clogp_authline $clogp;
4122 !defined $overwrite_version ? ""
4123 : !length $overwrite_version ? " --overwrite"
4124 : " --overwrite=".$overwrite_version;
4126 # Contributing parent is the first parent - that makes
4127 # git rev-list --first-parent DTRT.
4128 my $pmf = dgit_privdir()."/pseudomerge";
4129 open MC, ">", $pmf or die "$pmf $!";
4130 print MC <<END or confess $!;
4133 parent $archive_hash
4141 close MC or confess $!;
4143 return make_commit($pmf);
4146 sub splitbrain_pseudomerge ($$$$) {
4147 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4148 # => $merged_dgitview
4149 printdebug "splitbrain_pseudomerge...\n";
4151 # We: debian/PREVIOUS HEAD($maintview)
4152 # expect: o ----------------- o
4155 # a/d/PREVIOUS $dgitview
4158 # we do: `------------------ o
4162 return $dgitview unless defined $archive_hash;
4163 return $dgitview if deliberately_not_fast_forward();
4165 printdebug "splitbrain_pseudomerge...\n";
4167 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4169 if (!defined $overwrite_version) {
4170 progress __ "Checking that HEAD includes all changes in archive...";
4173 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4175 if (defined $overwrite_version) {
4177 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4178 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14,
4179 __ "maintainer view tag");
4180 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4181 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, __ "dgit view tag");
4182 my $i_archive = [ $archive_hash, __ "current archive contents" ];
4184 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4186 infopair_cond_equal($i_dgit, $i_archive);
4187 infopair_cond_ff($i_dep14, $i_dgit);
4188 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4191 $@ =~ s/^\n//; chomp $@;
4192 print STDERR <<END.(__ <<ENDT);
4195 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4200 my $arch_v = $i_arch_v->[0];
4201 my $r = pseudomerge_make_commit
4202 $clogp, $dgitview, $archive_hash, $i_arch_v,
4203 "dgit --quilt=$quilt_mode",
4204 (defined $overwrite_version
4205 ? f_ "Declare fast forward from %s\n", $arch_v
4206 : f_ "Make fast forward from %s\n", $arch_v);
4208 maybe_split_brain_save $maintview, $r, "pseudomerge";
4210 progress f_ "Made pseudo-merge of %s into dgit view.", $arch_v;
4214 sub plain_overwrite_pseudomerge ($$$) {
4215 my ($clogp, $head, $archive_hash) = @_;
4217 printdebug "plain_overwrite_pseudomerge...";
4219 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4221 return $head if is_fast_fwd $archive_hash, $head;
4223 my $m = f_ "Declare fast forward from %s", $i_arch_v->[0];
4225 my $r = pseudomerge_make_commit
4226 $clogp, $head, $archive_hash, $i_arch_v,
4229 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4231 progress f_ "Make pseudo-merge of %s into your HEAD.", $i_arch_v->[0];
4235 sub push_parse_changelog ($) {
4238 my $clogp = Dpkg::Control::Hash->new();
4239 $clogp->load($clogpfn) or die;
4241 my $clogpackage = getfield $clogp, 'Source';
4242 $package //= $clogpackage;
4243 fail f_ "-p specified %s but changelog specified %s",
4244 $package, $clogpackage
4245 unless $package eq $clogpackage;
4246 my $cversion = getfield $clogp, 'Version';
4248 if (!$we_are_initiator) {
4249 # rpush initiator can't do this because it doesn't have $isuite yet
4250 my $tag = debiantag($cversion, access_nomdistro);
4251 runcmd @git, qw(check-ref-format), $tag;
4254 my $dscfn = dscfn($cversion);
4256 return ($clogp, $cversion, $dscfn);
4259 sub push_parse_dsc ($$$) {
4260 my ($dscfn,$dscfnwhat, $cversion) = @_;
4261 $dsc = parsecontrol($dscfn,$dscfnwhat);
4262 my $dversion = getfield $dsc, 'Version';
4263 my $dscpackage = getfield $dsc, 'Source';
4264 ($dscpackage eq $package && $dversion eq $cversion) or
4265 fail f_ "%s is for %s %s but debian/changelog is for %s %s",
4266 $dscfn, $dscpackage, $dversion,
4267 $package, $cversion;
4270 sub push_tagwants ($$$$) {
4271 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4274 TagFn => \&debiantag,
4279 if (defined $maintviewhead) {
4281 TagFn => \&debiantag_maintview,
4282 Objid => $maintviewhead,
4283 TfSuffix => '-maintview',
4286 } elsif ($dodep14tag eq 'no' ? 0
4287 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4288 : $dodep14tag eq 'always'
4289 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4290 --dep14tag-always (or equivalent in config) means server must support
4291 both "new" and "maint" tag formats, but config says it doesn't.
4293 : die "$dodep14tag ?") {
4295 TagFn => \&debiantag_maintview,
4297 TfSuffix => '-dgit',
4301 foreach my $tw (@tagwants) {
4302 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4303 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4305 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4309 sub push_mktags ($$ $$ $) {
4311 $changesfile,$changesfilewhat,
4314 die unless $tagwants->[0]{View} eq 'dgit';
4316 my $declaredistro = access_nomdistro();
4317 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4318 $dsc->{$ourdscfield[0]} = join " ",
4319 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4321 $dsc->save("$dscfn.tmp") or confess $!;
4323 my $changes = parsecontrol($changesfile,$changesfilewhat);
4324 foreach my $field (qw(Source Distribution Version)) {
4325 $changes->{$field} eq $clogp->{$field} or
4326 fail f_ "changes field %s \`%s' does not match changelog \`%s'",
4327 $field, $changes->{$field}, $clogp->{$field};
4330 my $cversion = getfield $clogp, 'Version';
4331 my $clogsuite = getfield $clogp, 'Distribution';
4333 # We make the git tag by hand because (a) that makes it easier
4334 # to control the "tagger" (b) we can do remote signing
4335 my $authline = clogp_authline $clogp;
4336 my $delibs = join(" ", "",@deliberatelies);
4340 my $tfn = $tw->{Tfn};
4341 my $head = $tw->{Objid};
4342 my $tag = $tw->{Tag};
4344 open TO, '>', $tfn->('.tmp') or confess $!;
4345 print TO <<END or confess $!;
4352 if ($tw->{View} eq 'dgit') {
4353 print TO f_ <<ENDT, $package, $cversion, $clogsuite, $csuite
4354 %s release %s for %s (%s) [dgit]
4357 print TO <<END or confess $!;
4358 [dgit distro=$declaredistro$delibs]
4360 foreach my $ref (sort keys %previously) {
4361 print TO <<END or confess $!;
4362 [dgit previously:$ref=$previously{$ref}]
4365 } elsif ($tw->{View} eq 'maint') {
4366 print TO f_ <<END, $package, $cversion, $clogsuite, $csuite,
4367 %s release %s for %s (%s)
4368 (maintainer view tag generated by dgit --quilt=%s)
4373 confess Dumper($tw)."?";
4376 close TO or confess $!;
4378 my $tagobjfn = $tfn->('.tmp');
4380 if (!defined $keyid) {
4381 $keyid = access_cfg('keyid','RETURN-UNDEF');
4383 if (!defined $keyid) {
4384 $keyid = getfield $clogp, 'Maintainer';
4386 unlink $tfn->('.tmp.asc') or $!==&ENOENT or confess $!;
4387 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4388 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4389 push @sign_cmd, $tfn->('.tmp');
4390 runcmd_ordryrun @sign_cmd;
4392 $tagobjfn = $tfn->('.signed.tmp');
4393 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4394 $tfn->('.tmp'), $tfn->('.tmp.asc');
4400 my @r = map { $mktag->($_); } @$tagwants;
4404 sub sign_changes ($) {
4405 my ($changesfile) = @_;
4407 my @debsign_cmd = @debsign;
4408 push @debsign_cmd, "-k$keyid" if defined $keyid;
4409 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4410 push @debsign_cmd, $changesfile;
4411 runcmd_ordryrun @debsign_cmd;
4416 printdebug "actually entering push\n";
4418 supplementary_message(__ <<'END');
4419 Push failed, while checking state of the archive.
4420 You can retry the push, after fixing the problem, if you like.
4422 if (check_for_git()) {
4425 my $archive_hash = fetch_from_archive();
4426 if (!$archive_hash) {
4428 fail __ "package appears to be new in this suite;".
4429 " if this is intentional, use --new";
4432 supplementary_message(__ <<'END');
4433 Push failed, while preparing your push.
4434 You can retry the push, after fixing the problem, if you like.
4437 need_tagformat 'new', "quilt mode $quilt_mode"
4438 if quiltmode_splitbrain;
4442 access_giturl(); # check that success is vaguely likely
4443 rpush_handle_protovsn_bothends() if $we_are_initiator;
4446 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4447 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4449 responder_send_file('parsed-changelog', $clogpfn);
4451 my ($clogp, $cversion, $dscfn) =
4452 push_parse_changelog("$clogpfn");
4454 my $dscpath = "$buildproductsdir/$dscfn";
4455 stat_exists $dscpath or
4456 fail f_ "looked for .dsc %s, but %s; maybe you forgot to build",
4459 responder_send_file('dsc', $dscpath);
4461 push_parse_dsc($dscpath, $dscfn, $cversion);
4463 my $format = getfield $dsc, 'Format';
4464 printdebug "format $format\n";
4466 my $symref = git_get_symref();
4467 my $actualhead = git_rev_parse('HEAD');
4469 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4470 if (quiltmode_splitbrain()) {
4471 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4472 fail f_ <<END, $ffq_prev, $quilt_mode;
4473 Branch is managed by git-debrebase (%s
4474 exists), but quilt mode (%s) implies a split view.
4475 Pass the right --quilt option or adjust your git config.
4476 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4479 runcmd_ordryrun_local @git_debrebase, 'stitch';
4480 $actualhead = git_rev_parse('HEAD');
4483 my $dgithead = $actualhead;
4484 my $maintviewhead = undef;
4486 my $upstreamversion = upstreamversion $clogp->{Version};
4488 if (madformat_wantfixup($format)) {
4489 # user might have not used dgit build, so maybe do this now:
4490 if (quiltmode_splitbrain()) {
4491 changedir $playground;
4492 quilt_make_fake_dsc($upstreamversion);
4494 ($dgithead, $cachekey) =
4495 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4496 $dgithead or fail f_
4497 "--quilt=%s but no cached dgit view:
4498 perhaps HEAD changed since dgit build[-source] ?",
4501 $dgithead = splitbrain_pseudomerge($clogp,
4502 $actualhead, $dgithead,
4504 $maintviewhead = $actualhead;
4506 prep_ud(); # so _only_subdir() works, below
4508 commit_quilty_patch();
4512 if (defined $overwrite_version && !defined $maintviewhead
4514 $dgithead = plain_overwrite_pseudomerge($clogp,
4522 if ($archive_hash) {
4523 if (is_fast_fwd($archive_hash, $dgithead)) {
4525 } elsif (deliberately_not_fast_forward) {
4528 fail __ "dgit push: HEAD is not a descendant".
4529 " of the archive's version.\n".
4530 "To overwrite the archive's contents,".
4531 " pass --overwrite[=VERSION].\n".
4532 "To rewind history, if permitted by the archive,".
4533 " use --deliberately-not-fast-forward.";
4537 changedir $playground;
4538 progress f_ "checking that %s corresponds to HEAD", $dscfn;
4539 runcmd qw(dpkg-source -x --),
4540 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4541 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4542 check_for_vendor_patches() if madformat($dsc->{format});
4544 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4545 debugcmd "+",@diffcmd;
4547 my $r = system @diffcmd;
4550 my $referent = $split_brain ? $dgithead : 'HEAD';
4551 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4554 my $raw = cmdoutput @git,
4555 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4557 foreach (split /\0/, $raw) {
4558 if (defined $changed) {
4559 push @mode_changes, "$changed: $_\n" if $changed;
4562 } elsif (m/^:0+ 0+ /) {
4564 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4565 $changed = "Mode change from $1 to $2"
4570 if (@mode_changes) {
4571 fail +(f_ <<ENDT, $dscfn).<<END
4572 HEAD specifies a different tree to %s:
4576 .(join '', @mode_changes)
4577 .(f_ <<ENDT, $tree, $referent);
4578 There is a problem with your source tree (see dgit(7) for some hints).
4579 To see a full diff, run git diff %s %s
4583 fail +(f_ <<ENDT, $dscfn).<<END.(f_ <<ENDT, $tree, $referent);
4584 HEAD specifies a different tree to %s:
4588 Perhaps you forgot to build. Or perhaps there is a problem with your
4589 source tree (see dgit(7) for some hints). To see a full diff, run
4596 if (!$changesfile) {
4597 my $pat = changespat $cversion;
4598 my @cs = glob "$buildproductsdir/$pat";
4599 fail f_ "failed to find unique changes file".
4600 " (looked for %s in %s);".
4601 " perhaps you need to use dgit -C",
4602 $pat, $buildproductsdir
4604 ($changesfile) = @cs;
4606 $changesfile = "$buildproductsdir/$changesfile";
4609 # Check that changes and .dsc agree enough
4610 $changesfile =~ m{[^/]*$};
4611 my $changes = parsecontrol($changesfile,$&);
4612 files_compare_inputs($dsc, $changes)
4613 unless forceing [qw(dsc-changes-mismatch)];
4615 # Check whether this is a source only upload
4616 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4617 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4618 if ($sourceonlypolicy eq 'ok') {
4619 } elsif ($sourceonlypolicy eq 'always') {
4620 forceable_fail [qw(uploading-binaries)],
4621 __ "uploading binaries, although distro policy is source only"
4623 } elsif ($sourceonlypolicy eq 'never') {
4624 forceable_fail [qw(uploading-source-only)],
4625 __ "source-only upload, although distro policy requires .debs"
4627 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4628 forceable_fail [qw(uploading-source-only)],
4629 f_ "source-only upload, even though package is entirely NEW\n".
4630 "(this is contrary to policy in %s)",
4634 && !(archive_query('package_not_wholly_new', $package) // 1);
4636 badcfg f_ "unknown source-only-uploads policy \`%s'",
4640 # Perhaps adjust .dsc to contain right set of origs
4641 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4643 unless forceing [qw(changes-origs-exactly)];
4645 # Checks complete, we're going to try and go ahead:
4647 responder_send_file('changes',$changesfile);
4648 responder_send_command("param head $dgithead");
4649 responder_send_command("param csuite $csuite");
4650 responder_send_command("param isuite $isuite");
4651 responder_send_command("param tagformat $tagformat");
4652 if (defined $maintviewhead) {
4653 confess "internal error (protovsn=$protovsn)"
4654 if defined $protovsn and $protovsn < 4;
4655 responder_send_command("param maint-view $maintviewhead");
4658 # Perhaps send buildinfo(s) for signing
4659 my $changes_files = getfield $changes, 'Files';
4660 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4661 foreach my $bi (@buildinfos) {
4662 responder_send_command("param buildinfo-filename $bi");
4663 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4666 if (deliberately_not_fast_forward) {
4667 git_for_each_ref(lrfetchrefs, sub {
4668 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4669 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4670 responder_send_command("previously $rrefname=$objid");
4671 $previously{$rrefname} = $objid;
4675 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4676 dgit_privdir()."/tag");
4679 supplementary_message(__ <<'END');
4680 Push failed, while signing the tag.
4681 You can retry the push, after fixing the problem, if you like.
4683 # If we manage to sign but fail to record it anywhere, it's fine.
4684 if ($we_are_responder) {
4685 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4686 responder_receive_files('signed-tag', @tagobjfns);
4688 @tagobjfns = push_mktags($clogp,$dscpath,
4689 $changesfile,$changesfile,
4692 supplementary_message(__ <<'END');
4693 Push failed, *after* signing the tag.
4694 If you want to try again, you should use a new version number.
4697 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4699 foreach my $tw (@tagwants) {
4700 my $tag = $tw->{Tag};
4701 my $tagobjfn = $tw->{TagObjFn};
4703 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4704 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4705 runcmd_ordryrun_local
4706 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4709 supplementary_message(__ <<'END');
4710 Push failed, while updating the remote git repository - see messages above.
4711 If you want to try again, you should use a new version number.
4713 if (!check_for_git()) {
4714 create_remote_git_repo();
4717 my @pushrefs = $forceflag.$dgithead.":".rrref();
4718 foreach my $tw (@tagwants) {
4719 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4722 runcmd_ordryrun @git,
4723 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4724 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4726 supplementary_message(__ <<'END');
4727 Push failed, while obtaining signatures on the .changes and .dsc.
4728 If it was just that the signature failed, you may try again by using
4729 debsign by hand to sign the changes file (see the command dgit tried,
4730 above), and then dput that changes file to complete the upload.
4731 If you need to change the package, you must use a new version number.
4733 if ($we_are_responder) {
4734 my $dryrunsuffix = act_local() ? "" : ".tmp";
4735 my @rfiles = ($dscpath, $changesfile);
4736 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4737 responder_receive_files('signed-dsc-changes',
4738 map { "$_$dryrunsuffix" } @rfiles);
4741 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4743 progress f_ "[new .dsc left in %s.tmp]", $dscpath;
4745 sign_changes $changesfile;
4748 supplementary_message(f_ <<END, $changesfile);
4749 Push failed, while uploading package(s) to the archive server.
4750 You can retry the upload of exactly these same files with dput of:
4752 If that .changes file is broken, you will need to use a new version
4753 number for your next attempt at the upload.
4755 my $host = access_cfg('upload-host','RETURN-UNDEF');
4756 my @hostarg = defined($host) ? ($host,) : ();
4757 runcmd_ordryrun @dput, @hostarg, $changesfile;
4758 printdone f_ "pushed and uploaded %s", $cversion;
4760 supplementary_message('');
4761 responder_send_command("complete");
4765 not_necessarily_a_tree();
4770 badusage __ "-p is not allowed with clone; specify as argument instead"
4771 if defined $package;
4774 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4775 ($package,$isuite) = @ARGV;
4776 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4777 ($package,$dstdir) = @ARGV;
4778 } elsif (@ARGV==3) {
4779 ($package,$isuite,$dstdir) = @ARGV;
4781 badusage __ "incorrect arguments to dgit clone";
4785 $dstdir ||= "$package";
4786 if (stat_exists $dstdir) {
4787 fail f_ "%s already exists", $dstdir;
4791 if ($rmonerror && !$dryrun_level) {
4792 $cwd_remove= getcwd();
4794 return unless defined $cwd_remove;
4795 if (!chdir "$cwd_remove") {
4796 return if $!==&ENOENT;
4797 confess "chdir $cwd_remove: $!";
4799 printdebug "clone rmonerror removing $dstdir\n";
4801 rmtree($dstdir) or fail f_ "remove %s: %s\n", $dstdir, $!;
4802 } elsif (grep { $! == $_ }
4803 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4805 print STDERR f_ "check whether to remove %s: %s\n",
4812 $cwd_remove = undef;
4815 sub branchsuite () {
4816 my $branch = git_get_symref();
4817 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4824 sub package_from_d_control () {
4825 if (!defined $package) {
4826 my $sourcep = parsecontrol('debian/control','debian/control');
4827 $package = getfield $sourcep, 'Source';
4831 sub fetchpullargs () {
4832 package_from_d_control();
4834 $isuite = branchsuite();
4836 my $clogp = parsechangelog();
4837 my $clogsuite = getfield $clogp, 'Distribution';
4838 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4840 } elsif (@ARGV==1) {
4843 badusage __ "incorrect arguments to dgit fetch or dgit pull";
4857 if (quiltmode_splitbrain()) {
4858 my ($format, $fopts) = get_source_format();
4859 madformat($format) and fail f_ <<END, $quilt_mode
4860 dgit pull not yet supported in split view mode (--quilt=%s)
4868 package_from_d_control();
4869 @ARGV==1 or badusage __ "dgit checkout needs a suite argument";
4873 foreach my $canon (qw(0 1)) {
4878 canonicalise_suite();
4880 if (length git_get_ref lref()) {
4881 # local branch already exists, yay
4884 if (!length git_get_ref lrref()) {
4892 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4895 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4896 "dgit checkout $isuite";
4897 runcmd (@git, qw(checkout), lbranch());
4900 sub cmd_update_vcs_git () {
4902 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4903 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4905 ($specsuite) = (@ARGV);
4910 if ($ARGV[0] eq '-') {
4912 } elsif ($ARGV[0] eq '-') {
4917 package_from_d_control();
4919 if ($specsuite eq '.') {
4920 $ctrl = parsecontrol 'debian/control', 'debian/control';
4922 $isuite = $specsuite;
4926 my $url = getfield $ctrl, 'Vcs-Git';
4929 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4930 if (!defined $orgurl) {
4931 print STDERR f_ "setting up vcs-git: %s\n", $url;
4932 @cmd = (@git, qw(remote add vcs-git), $url);
4933 } elsif ($orgurl eq $url) {
4934 print STDERR f_ "vcs git already configured: %s\n", $url;
4936 print STDERR f_ "changing vcs-git url to: %s\n", $url;
4937 @cmd = (@git, qw(remote set-url vcs-git), $url);
4939 runcmd_ordryrun_local @cmd;
4941 print f_ "fetching (%s)\n", "@ARGV";
4942 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4948 build_or_push_prep_early();
4953 } elsif (@ARGV==1) {
4954 ($specsuite) = (@ARGV);
4956 badusage f_ "incorrect arguments to dgit %s", $subcommand;
4959 local ($package) = $existing_package; # this is a hack
4960 canonicalise_suite();
4962 canonicalise_suite();
4964 if (defined $specsuite &&
4965 $specsuite ne $isuite &&
4966 $specsuite ne $csuite) {
4967 fail f_ "dgit %s: changelog specifies %s (%s)".
4968 " but command line specifies %s",
4969 $subcommand, $isuite, $csuite, $specsuite;
4978 #---------- remote commands' implementation ----------
4980 sub pre_remote_push_build_host {
4981 my ($nrargs) = shift @ARGV;
4982 my (@rargs) = @ARGV[0..$nrargs-1];
4983 @ARGV = @ARGV[$nrargs..$#ARGV];
4985 my ($dir,$vsnwant) = @rargs;
4986 # vsnwant is a comma-separated list; we report which we have
4987 # chosen in our ready response (so other end can tell if they
4990 $we_are_responder = 1;
4991 $us .= " (build host)";
4993 open PI, "<&STDIN" or confess $!;
4994 open STDIN, "/dev/null" or confess $!;
4995 open PO, ">&STDOUT" or confess $!;
4997 open STDOUT, ">&STDERR" or confess $!;
5001 ($protovsn) = grep {
5002 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
5003 } @rpushprotovsn_support;
5005 fail f_ "build host has dgit rpush protocol versions %s".
5006 " but invocation host has %s",
5007 (join ",", @rpushprotovsn_support), $vsnwant
5008 unless defined $protovsn;
5012 sub cmd_remote_push_build_host {
5013 responder_send_command("dgit-remote-push-ready $protovsn");
5017 sub pre_remote_push_responder { pre_remote_push_build_host(); }
5018 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
5019 # ... for compatibility with proto vsn.1 dgit (just so that user gets
5020 # a good error message)
5022 sub rpush_handle_protovsn_bothends () {
5023 if ($protovsn < 4) {
5024 need_tagformat 'old', "rpush negotiated protocol $protovsn";
5033 my $report = i_child_report();
5034 if (defined $report) {
5035 printdebug "($report)\n";
5036 } elsif ($i_child_pid) {
5037 printdebug "(killing build host child $i_child_pid)\n";
5038 kill 15, $i_child_pid;
5040 if (defined $i_tmp && !defined $initiator_tempdir) {
5042 eval { rmtree $i_tmp; };
5047 return unless forkcheck_mainprocess();
5052 my ($base,$selector,@args) = @_;
5053 $selector =~ s/\-/_/g;
5054 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
5058 not_necessarily_a_tree();
5063 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
5071 push @rargs, join ",", @rpushprotovsn_support;
5074 push @rdgit, @ropts;
5075 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
5077 my @cmd = (@ssh, $host, shellquote @rdgit);
5080 $we_are_initiator=1;
5082 if (defined $initiator_tempdir) {
5083 rmtree $initiator_tempdir;
5084 mkdir $initiator_tempdir, 0700
5085 or fail f_ "create %s: %s", $initiator_tempdir, $!;
5086 $i_tmp = $initiator_tempdir;
5090 $i_child_pid = open2(\*RO, \*RI, @cmd);
5092 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
5093 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
5094 $supplementary_message = '' unless $protovsn >= 3;
5097 my ($icmd,$iargs) = initiator_expect {
5098 m/^(\S+)(?: (.*))?$/;
5101 i_method "i_resp", $icmd, $iargs;
5105 sub i_resp_progress ($) {
5107 my $msg = protocol_read_bytes \*RO, $rhs;
5111 sub i_resp_supplementary_message ($) {
5113 $supplementary_message = protocol_read_bytes \*RO, $rhs;
5116 sub i_resp_complete {
5117 my $pid = $i_child_pid;
5118 $i_child_pid = undef; # prevents killing some other process with same pid
5119 printdebug "waiting for build host child $pid...\n";
5120 my $got = waitpid $pid, 0;
5121 confess $! unless $got == $pid;
5122 fail f_ "build host child failed: %s", waitstatusmsg() if $?;
5125 printdebug __ "all done\n";
5129 sub i_resp_file ($) {
5131 my $localname = i_method "i_localname", $keyword;
5132 my $localpath = "$i_tmp/$localname";
5133 stat_exists $localpath and
5134 badproto \*RO, f_ "file %s (%s) twice", $keyword, $localpath;
5135 protocol_receive_file \*RO, $localpath;
5136 i_method "i_file", $keyword;
5141 sub i_resp_param ($) {
5142 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, __ "bad param spec";
5146 sub i_resp_previously ($) {
5147 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
5148 or badproto \*RO, __ "bad previously spec";
5149 my $r = system qw(git check-ref-format), $1;
5150 confess "bad previously ref spec ($r)" if $r;
5151 $previously{$1} = $2;
5156 sub i_resp_want ($) {
5158 die "$keyword ?" if $i_wanted{$keyword}++;
5160 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5161 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5162 die unless $isuite =~ m/^$suite_re$/;
5165 rpush_handle_protovsn_bothends();
5167 fail f_ "rpush negotiated protocol version %s".
5168 " which does not support quilt mode %s",
5169 $protovsn, $quilt_mode
5170 if quiltmode_splitbrain;
5172 my @localpaths = i_method "i_want", $keyword;
5173 printdebug "[[ $keyword @localpaths\n";
5174 foreach my $localpath (@localpaths) {
5175 protocol_send_file \*RI, $localpath;
5177 print RI "files-end\n" or confess $!;
5180 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5182 sub i_localname_parsed_changelog {
5183 return "remote-changelog.822";
5185 sub i_file_parsed_changelog {
5186 ($i_clogp, $i_version, $i_dscfn) =
5187 push_parse_changelog "$i_tmp/remote-changelog.822";
5188 die if $i_dscfn =~ m#/|^\W#;
5191 sub i_localname_dsc {
5192 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5197 sub i_localname_buildinfo ($) {
5198 my $bi = $i_param{'buildinfo-filename'};
5199 defined $bi or badproto \*RO, "buildinfo before filename";
5200 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5201 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5202 or badproto \*RO, "improper buildinfo filename";
5205 sub i_file_buildinfo {
5206 my $bi = $i_param{'buildinfo-filename'};
5207 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5208 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5209 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5210 files_compare_inputs($bd, $ch);
5211 (getfield $bd, $_) eq (getfield $ch, $_) or
5212 fail f_ "buildinfo mismatch in field %s", $_
5213 foreach qw(Source Version);
5214 !defined $bd->{$_} or
5215 fail f_ "buildinfo contains forbidden field %s", $_
5216 foreach qw(Changes Changed-by Distribution);
5218 push @i_buildinfos, $bi;
5219 delete $i_param{'buildinfo-filename'};
5222 sub i_localname_changes {
5223 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5224 $i_changesfn = $i_dscfn;
5225 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5226 return $i_changesfn;
5228 sub i_file_changes { }
5230 sub i_want_signed_tag {
5231 printdebug Dumper(\%i_param, $i_dscfn);
5232 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5233 && defined $i_param{'csuite'}
5234 or badproto \*RO, "premature desire for signed-tag";
5235 my $head = $i_param{'head'};
5236 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5238 my $maintview = $i_param{'maint-view'};
5239 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5242 if ($protovsn >= 4) {
5243 my $p = $i_param{'tagformat'} // '<undef>';
5245 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5248 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5250 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5252 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5255 push_mktags $i_clogp, $i_dscfn,
5256 $i_changesfn, (__ 'remote changes file'),
5260 sub i_want_signed_dsc_changes {
5261 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5262 sign_changes $i_changesfn;
5263 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5266 #---------- building etc. ----------
5272 #----- `3.0 (quilt)' handling -----
5274 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5276 sub quiltify_dpkg_commit ($$$;$) {
5277 my ($patchname,$author,$msg, $xinfo) = @_;
5280 mkpath '.git/dgit'; # we are in playtree
5281 my $descfn = ".git/dgit/quilt-description.tmp";
5282 open O, '>', $descfn or confess "$descfn: $!";
5283 $msg =~ s/\n+/\n\n/;
5284 print O <<END or confess $!;
5286 ${xinfo}Subject: $msg
5290 close O or confess $!;
5293 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5294 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5295 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5296 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5300 sub quiltify_trees_differ ($$;$$$) {
5301 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5302 # returns true iff the two tree objects differ other than in debian/
5303 # with $finegrained,
5304 # returns bitmask 01 - differ in upstream files except .gitignore
5305 # 02 - differ in .gitignore
5306 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5307 # is set for each modified .gitignore filename $fn
5308 # if $unrepres is defined, array ref to which is appeneded
5309 # a list of unrepresentable changes (removals of upstream files
5312 my @cmd = (@git, qw(diff-tree -z --no-renames));
5313 push @cmd, qw(--name-only) unless $unrepres;
5314 push @cmd, qw(-r) if $finegrained || $unrepres;
5316 my $diffs= cmdoutput @cmd;
5319 foreach my $f (split /\0/, $diffs) {
5320 if ($unrepres && !@lmodes) {
5321 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5324 my ($oldmode,$newmode) = @lmodes;
5327 next if $f =~ m#^debian(?:/.*)?$#s;
5331 die __ "not a plain file or symlink\n"
5332 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5333 $oldmode =~ m/^(?:10|12)\d{4}$/;
5334 if ($oldmode =~ m/[^0]/ &&
5335 $newmode =~ m/[^0]/) {
5336 # both old and new files exist
5337 die __ "mode or type changed\n" if $oldmode ne $newmode;
5338 die __ "modified symlink\n" unless $newmode =~ m/^10/;
5339 } elsif ($oldmode =~ m/[^0]/) {
5341 die __ "deletion of symlink\n"
5342 unless $oldmode =~ m/^10/;
5345 die __ "creation with non-default mode\n"
5346 unless $newmode =~ m/^100644$/ or
5347 $newmode =~ m/^120000$/;
5351 local $/="\n"; chomp $@;
5352 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5356 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5357 $r |= $isignore ? 02 : 01;
5358 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5360 printdebug "quiltify_trees_differ $x $y => $r\n";
5364 sub quiltify_tree_sentinelfiles ($) {
5365 # lists the `sentinel' files present in the tree
5367 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5368 qw(-- debian/rules debian/control);
5373 sub quiltify_splitbrain_needed () {
5374 if (!$split_brain) {
5375 progress __ "dgit view: changes are required...";
5376 runcmd @git, qw(checkout -q -b dgit-view);
5381 sub quiltify_splitbrain ($$$$$$$) {
5382 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5383 $editedignores, $cachekey) = @_;
5384 my $gitignore_special = 1;
5385 if ($quilt_mode !~ m/gbp|dpm/) {
5386 # treat .gitignore just like any other upstream file
5387 $diffbits = { %$diffbits };
5388 $_ = !!$_ foreach values %$diffbits;
5389 $gitignore_special = 0;
5391 # We would like any commits we generate to be reproducible
5392 my @authline = clogp_authline($clogp);
5393 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5394 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5395 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5396 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5397 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5398 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5400 my $fulldiffhint = sub {
5402 my $cmd = "git diff $x $y -- :/ ':!debian'";
5403 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5404 return f_ "\nFor full diff showing the problem(s), type:\n %s\n",
5408 if ($quilt_mode =~ m/gbp|unapplied/ &&
5409 ($diffbits->{O2H} & 01)) {
5411 "--quilt=%s specified, implying patches-unapplied git tree\n".
5412 " but git tree differs from orig in upstream files.",
5414 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5415 if (!stat_exists "debian/patches") {
5417 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5421 if ($quilt_mode =~ m/dpm/ &&
5422 ($diffbits->{H2A} & 01)) {
5423 fail +(f_ <<END, $quilt_mode). $fulldiffhint->($oldtiptree,'HEAD');
5424 --quilt=%s specified, implying patches-applied git tree
5425 but git tree differs from result of applying debian/patches to upstream
5428 if ($quilt_mode =~ m/gbp|unapplied/ &&
5429 ($diffbits->{O2A} & 01)) { # some patches
5430 quiltify_splitbrain_needed();
5431 progress __ "dgit view: creating patches-applied version using gbp pq";
5432 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5433 # gbp pq import creates a fresh branch; push back to dgit-view
5434 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5435 runcmd @git, qw(checkout -q dgit-view);
5437 if ($quilt_mode =~ m/gbp|dpm/ &&
5438 ($diffbits->{O2A} & 02)) {
5439 fail f_ <<END, $quilt_mode;
5440 --quilt=%s specified, implying that HEAD is for use with a
5441 tool which does not create patches for changes to upstream
5442 .gitignores: but, such patches exist in debian/patches.
5445 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5446 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5447 quiltify_splitbrain_needed();
5449 "dgit view: creating patch to represent .gitignore changes";
5450 ensuredir "debian/patches";
5451 my $gipatch = "debian/patches/auto-gitignore";
5452 open GIPATCH, ">>", "$gipatch" or confess "$gipatch: $!";
5453 stat GIPATCH or confess "$gipatch: $!";
5454 fail f_ "%s already exists; but want to create it".
5455 " to record .gitignore changes",
5458 print GIPATCH +(__ <<END).<<ENDU or die "$gipatch: $!";
5459 Subject: Update .gitignore from Debian packaging branch
5461 The Debian packaging git branch contains these updates to the upstream
5462 .gitignore file(s). This patch is autogenerated, to provide these
5463 updates to users of the official Debian archive view of the package.
5466 [dgit ($our_version) update-gitignore]
5469 close GIPATCH or die "$gipatch: $!";
5470 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5471 $unapplied, $headref, "--", sort keys %$editedignores;
5472 open SERIES, "+>>", "debian/patches/series" or confess $!;
5473 defined seek SERIES, -1, 2 or $!==EINVAL or confess $!;
5475 defined read SERIES, $newline, 1 or confess $!;
5476 print SERIES "\n" or confess $! unless $newline eq "\n";
5477 print SERIES "auto-gitignore\n" or confess $!;
5478 close SERIES or die $!;
5479 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5480 commit_admin +(__ <<END).<<ENDU
5481 Commit patch to update .gitignore
5484 [dgit ($our_version) update-gitignore-quilt-fixup]
5488 my $dgitview = git_rev_parse 'HEAD';
5491 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5493 changedir "$playground/work";
5495 my $saved = maybe_split_brain_save $headref, $dgitview, __ "converted";
5496 progress f_ "dgit view: created (%s)", $saved;
5499 sub quiltify ($$$$) {
5500 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5502 # Quilt patchification algorithm
5504 # We search backwards through the history of the main tree's HEAD
5505 # (T) looking for a start commit S whose tree object is identical
5506 # to to the patch tip tree (ie the tree corresponding to the
5507 # current dpkg-committed patch series). For these purposes
5508 # `identical' disregards anything in debian/ - this wrinkle is
5509 # necessary because dpkg-source treates debian/ specially.
5511 # We can only traverse edges where at most one of the ancestors'
5512 # trees differs (in changes outside in debian/). And we cannot
5513 # handle edges which change .pc/ or debian/patches. To avoid
5514 # going down a rathole we avoid traversing edges which introduce
5515 # debian/rules or debian/control. And we set a limit on the
5516 # number of edges we are willing to look at.
5518 # If we succeed, we walk forwards again. For each traversed edge
5519 # PC (with P parent, C child) (starting with P=S and ending with
5520 # C=T) to we do this:
5522 # - dpkg-source --commit with a patch name and message derived from C
5523 # After traversing PT, we git commit the changes which
5524 # should be contained within debian/patches.
5526 # The search for the path S..T is breadth-first. We maintain a
5527 # todo list containing search nodes. A search node identifies a
5528 # commit, and looks something like this:
5530 # Commit => $git_commit_id,
5531 # Child => $c, # or undef if P=T
5532 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5533 # Nontrivial => true iff $p..$c has relevant changes
5540 my %considered; # saves being exponential on some weird graphs
5542 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5545 my ($search,$whynot) = @_;
5546 printdebug " search NOT $search->{Commit} $whynot\n";
5547 $search->{Whynot} = $whynot;
5548 push @nots, $search;
5549 no warnings qw(exiting);
5558 my $c = shift @todo;
5559 next if $considered{$c->{Commit}}++;
5561 $not->($c, __ "maximum search space exceeded") if --$max_work <= 0;
5563 printdebug "quiltify investigate $c->{Commit}\n";
5566 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5567 printdebug " search finished hooray!\n";
5572 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5573 if ($quilt_mode eq 'smash') {
5574 printdebug " search quitting smash\n";
5578 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5579 $not->($c, f_ "has %s not %s", $c_sentinels, $t_sentinels)
5580 if $c_sentinels ne $t_sentinels;
5582 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5583 $commitdata =~ m/\n\n/;
5585 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5586 @parents = map { { Commit => $_, Child => $c } } @parents;
5588 $not->($c, __ "root commit") if !@parents;
5590 foreach my $p (@parents) {
5591 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5593 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5594 $not->($c, f_ "merge (%s nontrivial parents)", $ndiffers)
5597 foreach my $p (@parents) {
5598 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5600 my @cmd= (@git, qw(diff-tree -r --name-only),
5601 $p->{Commit},$c->{Commit},
5602 qw(-- debian/patches .pc debian/source/format));
5603 my $patchstackchange = cmdoutput @cmd;
5604 if (length $patchstackchange) {
5605 $patchstackchange =~ s/\n/,/g;
5606 $not->($p, f_ "changed %s", $patchstackchange);
5609 printdebug " search queue P=$p->{Commit} ",
5610 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5616 printdebug "quiltify want to smash\n";
5619 my $x = $_[0]{Commit};
5620 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5623 if ($quilt_mode eq 'linear') {
5625 "\n%s: error: quilt fixup cannot be linear. Stopped at:\n",
5627 my $all_gdr = !!@nots;
5628 foreach my $notp (@nots) {
5629 my $c = $notp->{Child};
5630 my $cprange = $abbrev->($notp);
5631 $cprange .= "..".$abbrev->($c) if $c;
5632 print STDERR f_ "%s: %s: %s\n",
5633 $us, $cprange, $notp->{Whynot};
5634 $all_gdr &&= $notp->{Child} &&
5635 (git_cat_file $notp->{Child}{Commit}, 'commit')
5636 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5640 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5642 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5644 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5645 } elsif ($quilt_mode eq 'smash') {
5646 } elsif ($quilt_mode eq 'auto') {
5647 progress __ "quilt fixup cannot be linear, smashing...";
5649 confess "$quilt_mode ?";
5652 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5653 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5655 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5657 quiltify_dpkg_commit "auto-$version-$target-$time",
5658 (getfield $clogp, 'Maintainer'),
5659 (f_ "Automatically generated patch (%s)\n".
5660 "Last (up to) %s git changes, FYI:\n\n",
5661 $clogp->{Version}, $ncommits).
5666 progress __ "quiltify linearisation planning successful, executing...";
5668 for (my $p = $sref_S;
5669 my $c = $p->{Child};
5671 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5672 next unless $p->{Nontrivial};
5674 my $cc = $c->{Commit};
5676 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5677 $commitdata =~ m/\n\n/ or die "$c ?";
5680 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5683 my $commitdate = cmdoutput
5684 @git, qw(log -n1 --pretty=format:%aD), $cc;
5686 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5688 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5695 my $gbp_check_suitable = sub {
5700 die __ "contains unexpected slashes\n" if m{//} || m{/$};
5701 die __ "contains leading punctuation\n" if m{^\W} || m{/\W};
5702 die __ "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5703 die __ "is series file\n" if m{$series_filename_re}o;
5704 die __ "too long\n" if length > 200;
5706 return $_ unless $@;
5708 "quiltifying commit %s: ignoring/dropping Gbp-Pq %s: %s",
5713 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5715 (\S+) \s* \n //ixm) {
5716 $patchname = $gbp_check_suitable->($1, 'Name');
5718 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5720 (\S+) \s* \n //ixm) {
5721 $patchdir = $gbp_check_suitable->($1, 'Topic');
5726 if (!defined $patchname) {
5727 $patchname = $title;
5728 $patchname =~ s/[.:]$//;
5731 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5732 my $translitname = $converter->convert($patchname);
5733 die unless defined $translitname;
5734 $patchname = $translitname;
5737 +(f_ "dgit: patch title transliteration error: %s", $@)
5739 $patchname =~ y/ A-Z/-a-z/;
5740 $patchname =~ y/-a-z0-9_.+=~//cd;
5741 $patchname =~ s/^\W/x-$&/;
5742 $patchname = substr($patchname,0,40);
5743 $patchname .= ".patch";
5745 if (!defined $patchdir) {
5748 if (length $patchdir) {
5749 $patchname = "$patchdir/$patchname";
5751 if ($patchname =~ m{^(.*)/}) {
5752 mkpath "debian/patches/$1";
5757 stat "debian/patches/$patchname$index";
5759 $!==ENOENT or confess "$patchname$index $!";
5761 runcmd @git, qw(checkout -q), $cc;
5763 # We use the tip's changelog so that dpkg-source doesn't
5764 # produce complaining messages from dpkg-parsechangelog. None
5765 # of the information dpkg-source gets from the changelog is
5766 # actually relevant - it gets put into the original message
5767 # which dpkg-source provides our stunt editor, and then
5769 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5771 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5772 "Date: $commitdate\n".
5773 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5775 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5778 runcmd @git, qw(checkout -q master);
5781 sub build_maybe_quilt_fixup () {
5782 my ($format,$fopts) = get_source_format;
5783 return unless madformat_wantfixup $format;
5786 check_for_vendor_patches();
5788 if (quiltmode_splitbrain) {
5789 fail <<END unless access_cfg_tagformats_can_splitbrain;
5790 quilt mode $quilt_mode requires split view so server needs to support
5791 both "new" and "maint" tag formats, but config says it doesn't.
5795 my $clogp = parsechangelog();
5796 my $headref = git_rev_parse('HEAD');
5797 my $symref = git_get_symref();
5799 if ($quilt_mode eq 'linear'
5800 && !$fopts->{'single-debian-patch'}
5801 && branch_is_gdr($headref)) {
5802 # This is much faster. It also makes patches that gdr
5803 # likes better for future updates without laundering.
5805 # However, it can fail in some casses where we would
5806 # succeed: if there are existing patches, which correspond
5807 # to a prefix of the branch, but are not in gbp/gdr
5808 # format, gdr will fail (exiting status 7), but we might
5809 # be able to figure out where to start linearising. That
5810 # will be slower so hopefully there's not much to do.
5811 my @cmd = (@git_debrebase,
5812 qw(--noop-ok -funclean-mixed -funclean-ordering
5813 make-patches --quiet-would-amend));
5814 # We tolerate soe snags that gdr wouldn't, by default.
5820 and not ($? == 7*256 or
5821 $? == -1 && $!==ENOENT);
5825 $headref = git_rev_parse('HEAD');
5829 changedir $playground;
5831 my $upstreamversion = upstreamversion $version;
5833 if ($fopts->{'single-debian-patch'}) {
5834 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5836 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5840 runcmd_ordryrun_local
5841 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5844 sub unpack_playtree_mkwork ($) {
5847 mkdir "work" or confess $!;
5849 mktree_in_ud_here();
5850 runcmd @git, qw(reset -q --hard), $headref;
5853 sub unpack_playtree_linkorigs ($$) {
5854 my ($upstreamversion, $fn) = @_;
5855 # calls $fn->($leafname);
5857 my $bpd_abs = bpd_abs();
5859 dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
5861 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5862 while ($!=0, defined(my $leaf = readdir QFD)) {
5863 my $f = bpd_abs()."/".$leaf;
5865 local ($debuglevel) = $debuglevel-1;
5866 printdebug "QF linkorigs bpd $leaf, $f ?\n";
5868 next unless is_orig_file_of_vsn $leaf, $upstreamversion;
5869 printdebug "QF linkorigs $leaf, $f Y\n";
5870 link_ltarget $f, $leaf or die "$leaf $!";
5873 die "$buildproductsdir: $!" if $!;
5877 sub quilt_fixup_delete_pc () {
5878 runcmd @git, qw(rm -rqf .pc);
5879 commit_admin +(__ <<END).<<ENDU
5880 Commit removal of .pc (quilt series tracking data)
5883 [dgit ($our_version) upgrade quilt-remove-pc]
5887 sub quilt_fixup_singlepatch ($$$) {
5888 my ($clogp, $headref, $upstreamversion) = @_;
5890 progress __ "starting quiltify (single-debian-patch)";
5892 # dpkg-source --commit generates new patches even if
5893 # single-debian-patch is in debian/source/options. In order to
5894 # get it to generate debian/patches/debian-changes, it is
5895 # necessary to build the source package.
5897 unpack_playtree_linkorigs($upstreamversion, sub { });
5898 unpack_playtree_mkwork($headref);
5900 rmtree("debian/patches");
5902 runcmd @dpkgsource, qw(-b .);
5904 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5905 rename srcfn("$upstreamversion", "/debian/patches"),
5906 "work/debian/patches"
5908 or confess "install d/patches: $!";
5911 commit_quilty_patch();
5914 sub quilt_make_fake_dsc ($) {
5915 my ($upstreamversion) = @_;
5917 my $fakeversion="$upstreamversion-~~DGITFAKE";
5919 my $fakedsc=new IO::File 'fake.dsc', '>' or confess $!;
5920 print $fakedsc <<END or confess $!;
5923 Version: $fakeversion
5927 my $dscaddfile=sub {
5930 my $md = new Digest::MD5;
5932 my $fh = new IO::File $leaf, '<' or die "$leaf $!";
5933 stat $fh or confess $!;
5937 print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess $!;
5940 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5942 my @files=qw(debian/source/format debian/rules
5943 debian/control debian/changelog);
5944 foreach my $maybe (qw(debian/patches debian/source/options
5945 debian/tests/control)) {
5946 next unless stat_exists "$maindir/$maybe";
5947 push @files, $maybe;
5950 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5951 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5953 $dscaddfile->($debtar);
5954 close $fakedsc or confess $!;
5957 sub quilt_fakedsc2unapplied ($$) {
5958 my ($headref, $upstreamversion) = @_;
5959 # must be run in the playground
5960 # quilt_make_fake_dsc must have been called
5963 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5965 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5966 rename $fakexdir, "fake" or die "$fakexdir $!";
5970 remove_stray_gits(__ "source package");
5971 mktree_in_ud_here();
5975 rmtree 'debian'; # git checkout commitish paths does not delete!
5976 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5977 my $unapplied=git_add_write_tree();
5978 printdebug "fake orig tree object $unapplied\n";
5982 sub quilt_check_splitbrain_cache ($$) {
5983 my ($headref, $upstreamversion) = @_;
5984 # Called only if we are in (potentially) split brain mode.
5985 # Called in playground.
5986 # Computes the cache key and looks in the cache.
5987 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5989 my $splitbrain_cachekey;
5992 "dgit: split brain (separate dgit view) may be needed (--quilt=%s).",
5994 # we look in the reflog of dgit-intern/quilt-cache
5995 # we look for an entry whose message is the key for the cache lookup
5996 my @cachekey = (qw(dgit), $our_version);
5997 push @cachekey, $upstreamversion;
5998 push @cachekey, $quilt_mode;
5999 push @cachekey, $headref;
6001 push @cachekey, hashfile('fake.dsc');
6003 my $srcshash = Digest::SHA->new(256);
6004 my %sfs = ( %INC, '$0(dgit)' => $0 );
6005 foreach my $sfk (sort keys %sfs) {
6006 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
6007 $srcshash->add($sfk," ");
6008 $srcshash->add(hashfile($sfs{$sfk}));
6009 $srcshash->add("\n");
6011 push @cachekey, $srcshash->hexdigest();
6012 $splitbrain_cachekey = "@cachekey";
6014 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
6016 my $cachehit = reflog_cache_lookup
6017 "refs/$splitbraincache", $splitbrain_cachekey;
6020 unpack_playtree_mkwork($headref);
6021 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
6022 if ($cachehit ne $headref) {
6023 progress f_ "dgit view: found cached (%s)", $saved;
6024 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
6026 return ($cachehit, $splitbrain_cachekey);
6028 progress __ "dgit view: found cached, no changes required";
6029 return ($headref, $splitbrain_cachekey);
6032 printdebug "splitbrain cache miss\n";
6033 return (undef, $splitbrain_cachekey);
6036 sub quilt_fixup_multipatch ($$$) {
6037 my ($clogp, $headref, $upstreamversion) = @_;
6039 progress f_ "examining quilt state (multiple patches, %s mode)",
6043 # - honour any existing .pc in case it has any strangeness
6044 # - determine the git commit corresponding to the tip of
6045 # the patch stack (if there is one)
6046 # - if there is such a git commit, convert each subsequent
6047 # git commit into a quilt patch with dpkg-source --commit
6048 # - otherwise convert all the differences in the tree into
6049 # a single git commit
6053 # Our git tree doesn't necessarily contain .pc. (Some versions of
6054 # dgit would include the .pc in the git tree.) If there isn't
6055 # one, we need to generate one by unpacking the patches that we
6058 # We first look for a .pc in the git tree. If there is one, we
6059 # will use it. (This is not the normal case.)
6061 # Otherwise need to regenerate .pc so that dpkg-source --commit
6062 # can work. We do this as follows:
6063 # 1. Collect all relevant .orig from parent directory
6064 # 2. Generate a debian.tar.gz out of
6065 # debian/{patches,rules,source/format,source/options}
6066 # 3. Generate a fake .dsc containing just these fields:
6067 # Format Source Version Files
6068 # 4. Extract the fake .dsc
6069 # Now the fake .dsc has a .pc directory.
6070 # (In fact we do this in every case, because in future we will
6071 # want to search for a good base commit for generating patches.)
6073 # Then we can actually do the dpkg-source --commit
6074 # 1. Make a new working tree with the same object
6075 # store as our main tree and check out the main
6077 # 2. Copy .pc from the fake's extraction, if necessary
6078 # 3. Run dpkg-source --commit
6079 # 4. If the result has changes to debian/, then
6080 # - git add them them
6081 # - git add .pc if we had a .pc in-tree
6083 # 5. If we had a .pc in-tree, delete it, and git commit
6084 # 6. Back in the main tree, fast forward to the new HEAD
6086 # Another situation we may have to cope with is gbp-style
6087 # patches-unapplied trees.
6089 # We would want to detect these, so we know to escape into
6090 # quilt_fixup_gbp. However, this is in general not possible.
6091 # Consider a package with a one patch which the dgit user reverts
6092 # (with git revert or the moral equivalent).
6094 # That is indistinguishable in contents from a patches-unapplied
6095 # tree. And looking at the history to distinguish them is not
6096 # useful because the user might have made a confusing-looking git
6097 # history structure (which ought to produce an error if dgit can't
6098 # cope, not a silent reintroduction of an unwanted patch).
6100 # So gbp users will have to pass an option. But we can usually
6101 # detect their failure to do so: if the tree is not a clean
6102 # patches-applied tree, quilt linearisation fails, but the tree
6103 # _is_ a clean patches-unapplied tree, we can suggest that maybe
6104 # they want --quilt=unapplied.
6106 # To help detect this, when we are extracting the fake dsc, we
6107 # first extract it with --skip-patches, and then apply the patches
6108 # afterwards with dpkg-source --before-build. That lets us save a
6109 # tree object corresponding to .origs.
6111 my $splitbrain_cachekey;
6113 quilt_make_fake_dsc($upstreamversion);
6115 if (quiltmode_splitbrain()) {
6117 ($cachehit, $splitbrain_cachekey) =
6118 quilt_check_splitbrain_cache($headref, $upstreamversion);
6119 return if $cachehit;
6121 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
6125 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
6127 if (system @bbcmd) {
6128 failedcmd @bbcmd if $? < 0;
6130 failed to apply your git tree's patch stack (from debian/patches/) to
6131 the corresponding upstream tarball(s). Your source tree and .orig
6132 are probably too inconsistent. dgit can only fix up certain kinds of
6133 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
6139 unpack_playtree_mkwork($headref);
6142 if (stat_exists ".pc") {
6144 progress __ "Tree already contains .pc - will use it then delete it.";
6147 rename '../fake/.pc','.pc' or confess $!;
6150 changedir '../fake';
6152 my $oldtiptree=git_add_write_tree();
6153 printdebug "fake o+d/p tree object $unapplied\n";
6154 changedir '../work';
6157 # We calculate some guesswork now about what kind of tree this might
6158 # be. This is mostly for error reporting.
6164 # O = orig, without patches applied
6165 # A = "applied", ie orig with H's debian/patches applied
6166 O2H => quiltify_trees_differ($unapplied,$headref, 1,
6167 \%editedignores, \@unrepres),
6168 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
6169 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
6173 foreach my $bits (qw(01 02)) {
6174 foreach my $v (qw(O2H O2A H2A)) {
6175 push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
6178 printdebug "differences \@dl @dl.\n";
6181 "%s: base trees orig=%.20s o+d/p=%.20s",
6182 $us, $unapplied, $oldtiptree;
6184 "%s: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6185 "%s: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6186 $us, $dl[0], $dl[1], $dl[3], $dl[4],
6187 $us, $dl[2], $dl[5];
6190 print STDERR f_ "dgit: cannot represent change: %s: %s\n",
6193 forceable_fail [qw(unrepresentable)], __ <<END;
6194 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6199 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6200 push @failsuggestion, [ 'unapplied', __
6201 "This might be a patches-unapplied branch." ];
6202 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6203 push @failsuggestion, [ 'applied', __
6204 "This might be a patches-applied branch." ];
6206 push @failsuggestion, [ 'quilt-mode', __
6207 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6209 push @failsuggestion, [ 'gitattrs', __
6210 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6211 if stat_exists '.gitattributes';
6213 push @failsuggestion, [ 'origs', __
6214 "Maybe orig tarball(s) are not identical to git representation?" ];
6216 if (quiltmode_splitbrain()) {
6217 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6218 $diffbits, \%editedignores,
6219 $splitbrain_cachekey);
6223 progress f_ "starting quiltify (multiple patches, %s mode)", $quilt_mode;
6224 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6226 if (!open P, '>>', ".pc/applied-patches") {
6227 $!==&ENOENT or confess $!;
6232 commit_quilty_patch();
6234 if ($mustdeletepc) {
6235 quilt_fixup_delete_pc();
6239 sub quilt_fixup_editor () {
6240 my $descfn = $ENV{$fakeeditorenv};
6241 my $editing = $ARGV[$#ARGV];
6242 open I1, '<', $descfn or confess "$descfn: $!";
6243 open I2, '<', $editing or confess "$editing: $!";
6244 unlink $editing or confess "$editing: $!";
6245 open O, '>', $editing or confess "$editing: $!";
6246 while (<I1>) { print O or confess $!; } I1->error and confess $!;
6249 $copying ||= m/^\-\-\- /;
6250 next unless $copying;
6251 print O or confess $!;
6253 I2->error and confess $!;
6258 sub maybe_apply_patches_dirtily () {
6259 return unless $quilt_mode =~ m/gbp|unapplied/;
6260 print STDERR __ <<END or confess $!;
6262 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6263 dgit: Have to apply the patches - making the tree dirty.
6264 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6267 $patches_applied_dirtily = 01;
6268 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6269 runcmd qw(dpkg-source --before-build .);
6272 sub maybe_unapply_patches_again () {
6273 progress __ "dgit: Unapplying patches again to tidy up the tree."
6274 if $patches_applied_dirtily;
6275 runcmd qw(dpkg-source --after-build .)
6276 if $patches_applied_dirtily & 01;
6278 if $patches_applied_dirtily & 02;
6279 $patches_applied_dirtily = 0;
6282 #----- other building -----
6284 sub clean_tree_check_git ($$$) {
6285 my ($honour_ignores, $message, $ignmessage) = @_;
6286 my @cmd = (@git, qw(clean -dn));
6287 push @cmd, qw(-x) unless $honour_ignores;
6288 my $leftovers = cmdoutput @cmd;
6289 if (length $leftovers) {
6290 print STDERR $leftovers, "\n" or confess $!;
6291 $message .= $ignmessage if $honour_ignores;
6296 sub clean_tree_check_git_wd ($) {
6298 return if $cleanmode =~ m{no-check};
6299 return if $patches_applied_dirtily; # yuk
6300 clean_tree_check_git +($cleanmode !~ m{all-check}),
6301 $message, "\n".__ <<END;
6302 If this is just missing .gitignore entries, use a different clean
6303 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
6304 or --clean=git (-wg/-wgf) to use \`git clean' instead.
6308 sub clean_tree_check () {
6309 # This function needs to not care about modified but tracked files.
6310 # That was done by check_not_dirty, and by now we may have run
6311 # the rules clean target which might modify tracked files (!)
6312 if ($cleanmode =~ m{^check}) {
6313 clean_tree_check_git +($cleanmode =~ m{ignores}), __
6314 "tree contains uncommitted files and --clean=check specified", '';
6315 } elsif ($cleanmode =~ m{^dpkg-source}) {
6316 clean_tree_check_git_wd __
6317 "tree contains uncommitted files (NB dgit didn't run rules clean)";
6318 } elsif ($cleanmode =~ m{^git}) {
6319 clean_tree_check_git 1, __
6320 "tree contains uncommited, untracked, unignored files\n".
6321 "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
6322 } elsif ($cleanmode eq 'none') {
6324 confess "$cleanmode ?";
6329 # We always clean the tree ourselves, rather than leave it to the
6330 # builder (dpkg-source, or soemthing which calls dpkg-source).
6331 if ($cleanmode =~ m{^dpkg-source}) {
6332 my @cmd = @dpkgbuildpackage;
6333 push @cmd, qw(-d) if $cleanmode =~ m{^dpkg-source-d};
6334 push @cmd, qw(-T clean);
6335 maybe_apply_patches_dirtily();
6336 runcmd_ordryrun_local @cmd;
6337 clean_tree_check_git_wd __
6338 "tree contains uncommitted files (after running rules clean)";
6339 } elsif ($cleanmode =~ m{^git(?!-)}) {
6340 runcmd_ordryrun_local @git, qw(clean -xdf);
6341 } elsif ($cleanmode =~ m{^git-ff}) {
6342 runcmd_ordryrun_local @git, qw(clean -xdff);
6343 } elsif ($cleanmode =~ m{^check}) {
6345 } elsif ($cleanmode eq 'none') {
6347 confess "$cleanmode ?";
6352 badusage __ "clean takes no additional arguments" if @ARGV;
6355 maybe_unapply_patches_again();
6358 # return values from massage_dbp_args are one or both of these flags
6359 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6360 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6362 sub build_or_push_prep_early () {
6363 our $build_or_push_prep_early_done //= 0;
6364 return if $build_or_push_prep_early_done++;
6365 badusage f_ "-p is not allowed with dgit %s", $subcommand
6366 if defined $package;
6367 my $clogp = parsechangelog();
6368 $isuite = getfield $clogp, 'Distribution';
6369 $package = getfield $clogp, 'Source';
6370 $version = getfield $clogp, 'Version';
6371 $dscfn = dscfn($version);
6374 sub build_prep_early () {
6375 build_or_push_prep_early();
6380 sub build_prep ($) {
6384 if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
6385 # Clean the tree because we're going to use the contents of
6386 # $maindir. (We trying to include dirty changes in the source
6387 # package, or we are running the builder in $maindir.)
6388 || $cleanmode =~ m{always}) {
6389 # Or because the user asked us to.
6392 # We don't actually need to do anything in $maindir, but we
6393 # should do some kind of cleanliness check because (i) the
6394 # user may have forgotten a `git add', and (ii) if the user
6395 # said -wc we should still do the check.
6398 build_maybe_quilt_fixup();
6400 my $pat = changespat $version;
6401 foreach my $f (glob "$buildproductsdir/$pat") {
6404 fail f_ "remove old changes file %s: %s", $f, $!;
6406 progress f_ "would remove %s", $f;
6412 sub changesopts_initial () {
6413 my @opts =@changesopts[1..$#changesopts];
6416 sub changesopts_version () {
6417 if (!defined $changes_since_version) {
6420 @vsns = archive_query('archive_query');
6421 my @quirk = access_quirk();
6422 if ($quirk[0] eq 'backports') {
6423 local $isuite = $quirk[2];
6425 canonicalise_suite();
6426 push @vsns, archive_query('archive_query');
6432 "archive query failed (queried because --since-version not specified)";
6435 @vsns = map { $_->[0] } @vsns;
6436 @vsns = sort { -version_compare($a, $b) } @vsns;
6437 $changes_since_version = $vsns[0];
6438 progress f_ "changelog will contain changes since %s", $vsns[0];
6440 $changes_since_version = '_';
6441 progress __ "package seems new, not specifying -v<version>";
6444 if ($changes_since_version ne '_') {
6445 return ("-v$changes_since_version");
6451 sub changesopts () {
6452 return (changesopts_initial(), changesopts_version());
6455 sub massage_dbp_args ($;$) {
6456 my ($cmd,$xargs) = @_;
6457 # Since we split the source build out so we can do strange things
6458 # to it, massage the arguments to dpkg-buildpackage so that the
6459 # main build doessn't build source (or add an argument to stop it
6460 # building source by default).
6461 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6462 # -nc has the side effect of specifying -b if nothing else specified
6463 # and some combinations of -S, -b, et al, are errors, rather than
6464 # later simply overriding earlie. So we need to:
6465 # - search the command line for these options
6466 # - pick the last one
6467 # - perhaps add our own as a default
6468 # - perhaps adjust it to the corresponding non-source-building version
6470 foreach my $l ($cmd, $xargs) {
6472 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6475 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6476 my $r = WANTSRC_BUILDER;
6477 printdebug "massage split $dmode.\n";
6478 if ($dmode =~ s/^--build=//) {
6480 my @d = split /,/, $dmode;
6481 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6482 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6483 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6484 fail __ "Wanted to build nothing!" unless $r;
6485 $dmode = '--build='. join ',', grep m/./, @d;
6488 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6489 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6490 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6493 printdebug "massage done $r $dmode.\n";
6495 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6501 my $wasdir = must_getcwd();
6502 changedir $buildproductsdir;
6507 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6508 sub postbuild_mergechanges ($) {
6509 my ($msg_if_onlyone) = @_;
6510 # If there is only one .changes file, fail with $msg_if_onlyone,
6511 # or if that is undef, be a no-op.
6512 # Returns the changes file to report to the user.
6513 my $pat = changespat $version;
6514 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6515 @changesfiles = sort {
6516 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6520 if (@changesfiles==1) {
6521 fail +(f_ <<END, "@changesfiles").$msg_if_onlyone
6522 only one changes file from build (%s)
6524 if defined $msg_if_onlyone;
6525 $result = $changesfiles[0];
6526 } elsif (@changesfiles==2) {
6527 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6528 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6529 fail f_ "%s found in binaries changes file %s", $l, $binchanges
6532 runcmd_ordryrun_local @mergechanges, @changesfiles;
6533 my $multichanges = changespat $version,'multi';
6535 stat_exists $multichanges or fail f_
6536 "%s unexpectedly not created by build", $multichanges;
6537 foreach my $cf (glob $pat) {
6538 next if $cf eq $multichanges;
6539 rename "$cf", "$cf.inmulti" or fail f_
6540 "install new changes %s\{,.inmulti}: %s", $cf, $!;
6543 $result = $multichanges;
6545 fail f_ "wrong number of different changes files (%s)",
6548 printdone f_ "build successful, results in %s\n", $result
6552 sub midbuild_checkchanges () {
6553 my $pat = changespat $version;
6554 return if $rmchanges;
6555 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6557 $_ ne changespat $version,'source' and
6558 $_ ne changespat $version,'multi'
6560 fail +(f_ <<END, $pat, "@unwanted")
6561 changes files other than source matching %s already present; building would result in ambiguity about the intended results.
6562 Suggest you delete %s.
6567 sub midbuild_checkchanges_vanilla ($) {
6569 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6572 sub postbuild_mergechanges_vanilla ($) {
6574 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6576 postbuild_mergechanges(undef);
6579 printdone __ "build successful\n";
6585 $buildproductsdir eq '..' or print STDERR +(f_ <<END, $us, $us);
6586 %s: warning: build-products-dir set, but not supported by dpkg-buildpackage
6587 %s: warning: build-products-dir will be ignored; files will go to ..
6589 $buildproductsdir = '..';
6590 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6591 my $wantsrc = massage_dbp_args \@dbp;
6592 build_prep($wantsrc);
6593 if ($wantsrc & WANTSRC_SOURCE) {
6595 midbuild_checkchanges_vanilla $wantsrc;
6597 if ($wantsrc & WANTSRC_BUILDER) {
6598 push @dbp, changesopts_version();
6599 maybe_apply_patches_dirtily();
6600 runcmd_ordryrun_local @dbp;
6602 maybe_unapply_patches_again();
6603 postbuild_mergechanges_vanilla $wantsrc;
6607 $quilt_mode //= 'gbp';
6613 # gbp can make .origs out of thin air. In my tests it does this
6614 # even for a 1.0 format package, with no origs present. So I
6615 # guess it keys off just the version number. We don't know
6616 # exactly what .origs ought to exist, but let's assume that we
6617 # should run gbp if: the version has an upstream part and the main
6619 my $upstreamversion = upstreamversion $version;
6620 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6621 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6623 if ($gbp_make_orig) {
6625 $cleanmode = 'none'; # don't do it again
6628 my @dbp = @dpkgbuildpackage;
6630 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6632 if (!length $gbp_build[0]) {
6633 if (length executable_on_path('git-buildpackage')) {
6634 $gbp_build[0] = qw(git-buildpackage);
6636 $gbp_build[0] = 'gbp buildpackage';
6639 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6641 push @cmd, (qw(-us -uc --git-no-sign-tags),
6642 "--git-builder=".(shellquote @dbp));
6644 if ($gbp_make_orig) {
6645 my $priv = dgit_privdir();
6646 my $ok = "$priv/origs-gen-ok";
6647 unlink $ok or $!==&ENOENT or confess $!;
6648 my @origs_cmd = @cmd;
6649 push @origs_cmd, qw(--git-cleaner=true);
6650 push @origs_cmd, "--git-prebuild=".
6651 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6652 push @origs_cmd, @ARGV;
6654 debugcmd @origs_cmd;
6656 do { local $!; stat_exists $ok; }
6657 or failedcmd @origs_cmd;
6659 dryrun_report @origs_cmd;
6663 build_prep($wantsrc);
6664 if ($wantsrc & WANTSRC_SOURCE) {
6666 midbuild_checkchanges_vanilla $wantsrc;
6668 push @cmd, '--git-cleaner=true';
6670 maybe_unapply_patches_again();
6671 if ($wantsrc & WANTSRC_BUILDER) {
6672 push @cmd, changesopts();
6673 runcmd_ordryrun_local @cmd, @ARGV;
6675 postbuild_mergechanges_vanilla $wantsrc;
6677 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6679 sub building_source_in_playtree {
6680 # If $includedirty, we have to build the source package from the
6681 # working tree, not a playtree, so that uncommitted changes are
6682 # included (copying or hardlinking them into the playtree could
6685 # Note that if we are building a source package in split brain
6686 # mode we do not support including uncommitted changes, because
6687 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6688 # building a source package)) => !$includedirty
6689 return !$includedirty;
6693 $sourcechanges = changespat $version,'source';
6695 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6696 or fail f_ "remove %s: %s", $sourcechanges, $!;
6698 my @cmd = (@dpkgsource, qw(-b --));
6700 if (building_source_in_playtree()) {
6702 my $headref = git_rev_parse('HEAD');
6703 # If we are in split brain, there is already a playtree with
6704 # the thing we should package into a .dsc (thanks to quilt
6705 # fixup). If not, make a playtree
6706 prep_ud() unless $split_brain;
6707 changedir $playground;
6708 unless ($split_brain) {
6709 my $upstreamversion = upstreamversion $version;
6710 unpack_playtree_linkorigs($upstreamversion, sub { });
6711 unpack_playtree_mkwork($headref);
6715 $leafdir = basename $maindir;
6717 if ($buildproductsdir ne '..') {
6718 # Well, we are going to run dpkg-source -b which consumes
6719 # origs from .. and generates output there. To make this
6720 # work when the bpd is not .. , we would have to (i) link
6721 # origs from bpd to .. , (ii) check for files that
6722 # dpkg-source -b would/might overwrite, and afterwards
6723 # (iii) move all the outputs back to the bpd (iv) except
6724 # for the origs which should be deleted from .. if they
6725 # weren't there beforehand. And if there is an error and
6726 # we don't run to completion we would necessarily leave a
6727 # mess. This is too much. The real way to fix this
6728 # is for dpkg-source to have bpd support.
6729 confess unless $includedirty;
6731 "--include-dirty not supported with --build-products-dir, sorry";
6736 runcmd_ordryrun_local @cmd, $leafdir;
6739 runcmd_ordryrun_local qw(sh -ec),
6740 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6741 @dpkggenchanges, qw(-S), changesopts();
6744 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6745 $dsc = parsecontrol($dscfn, "source package");
6749 printdebug " renaming ($why) $l\n";
6750 rename_link_xf 0, "$l", bpd_abs()."/$l"
6751 or fail f_ "put in place new built file (%s): %s", $l, $@;
6753 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6754 $l =~ m/\S+$/ or next;
6757 $mv->('dsc', $dscfn);
6758 $mv->('changes', $sourcechanges);
6763 sub cmd_build_source {
6764 badusage __ "build-source takes no additional arguments" if @ARGV;
6765 build_prep(WANTSRC_SOURCE);
6767 maybe_unapply_patches_again();
6768 printdone f_ "source built, results in %s and %s",
6769 $dscfn, $sourcechanges;
6772 sub cmd_push_source {
6775 "dgit push-source: --include-dirty/--ignore-dirty does not make".
6776 "sense with push-source!"
6778 build_maybe_quilt_fixup();
6780 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6781 __ "source changes file");
6782 unless (test_source_only_changes($changes)) {
6783 fail __ "user-specified changes file is not source-only";
6786 # Building a source package is very fast, so just do it
6788 confess "er, patches are applied dirtily but shouldn't be.."
6789 if $patches_applied_dirtily;
6790 $changesfile = $sourcechanges;
6795 sub binary_builder {
6796 my ($bbuilder, $pbmc_msg, @args) = @_;
6797 build_prep(WANTSRC_SOURCE);
6799 midbuild_checkchanges();
6802 stat_exists $dscfn or fail f_
6803 "%s (in build products dir): %s", $dscfn, $!;
6804 stat_exists $sourcechanges or fail f_
6805 "%s (in build products dir): %s", $sourcechanges, $!;
6807 runcmd_ordryrun_local @$bbuilder, @args;
6809 maybe_unapply_patches_again();
6811 postbuild_mergechanges($pbmc_msg);
6817 binary_builder(\@sbuild, (__ <<END), qw(-d), $isuite, @ARGV, $dscfn);
6818 perhaps you need to pass -A ? (sbuild's default is to build only
6819 arch-specific binaries; dgit 1.4 used to override that.)
6824 my ($pbuilder) = @_;
6826 # @ARGV is allowed to contain only things that should be passed to
6827 # pbuilder under debbuildopts; just massage those
6828 my $wantsrc = massage_dbp_args \@ARGV;
6830 "you asked for a builder but your debbuildopts didn't ask for".
6831 " any binaries -- is this really what you meant?"
6832 unless $wantsrc & WANTSRC_BUILDER;
6834 "we must build a .dsc to pass to the builder but your debbuiltopts".
6835 " forbids the building of a source package; cannot continue"
6836 unless $wantsrc & WANTSRC_SOURCE;
6837 # We do not want to include the verb "build" in @pbuilder because
6838 # the user can customise @pbuilder and they shouldn't be required
6839 # to include "build" in their customised value. However, if the
6840 # user passes any additional args to pbuilder using the dgit
6841 # option --pbuilder:foo, such args need to come after the "build"
6842 # verb. opts_opt_multi_cmd does all of that.
6843 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6844 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6849 pbuilder(\@pbuilder);
6852 sub cmd_cowbuilder {
6853 pbuilder(\@cowbuilder);
6856 sub cmd_quilt_fixup {
6857 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6860 build_maybe_quilt_fixup();
6863 sub cmd_print_unapplied_treeish {
6864 badusage __ "incorrect arguments to dgit print-unapplied-treeish"
6866 my $headref = git_rev_parse('HEAD');
6867 my $clogp = commit_getclogp $headref;
6868 $package = getfield $clogp, 'Source';
6869 $version = getfield $clogp, 'Version';
6870 $isuite = getfield $clogp, 'Distribution';
6871 $csuite = $isuite; # we want this to be offline!
6875 changedir $playground;
6876 my $uv = upstreamversion $version;
6877 quilt_make_fake_dsc($uv);
6878 my $u = quilt_fakedsc2unapplied($headref, $uv);
6879 print $u, "\n" or confess $!;
6882 sub import_dsc_result {
6883 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6884 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6886 check_gitattrs($newhash, __ "source tree");
6888 progress f_ "dgit: import-dsc: %s", $what_msg;
6891 sub cmd_import_dsc {
6895 last unless $ARGV[0] =~ m/^-/;
6898 if (m/^--require-valid-signature$/) {
6901 badusage f_ "unknown dgit import-dsc sub-option \`%s'", $_;
6905 badusage __ "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH"
6907 my ($dscfn, $dstbranch) = @ARGV;
6909 badusage __ "dry run makes no sense with import-dsc"
6912 my $force = $dstbranch =~ s/^\+// ? +1 :
6913 $dstbranch =~ s/^\.\.// ? -1 :
6915 my $info = $force ? " $&" : '';
6916 $info = "$dscfn$info";
6918 my $specbranch = $dstbranch;
6919 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6920 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6922 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6923 my $chead = cmdoutput_errok @symcmd;
6924 defined $chead or $?==256 or failedcmd @symcmd;
6926 fail f_ "%s is checked out - will not update it", $dstbranch
6927 if defined $chead and $chead eq $dstbranch;
6929 my $oldhash = git_get_ref $dstbranch;
6931 open D, "<", $dscfn or fail f_ "open import .dsc (%s): %s", $dscfn, $!;
6932 $dscdata = do { local $/ = undef; <D>; };
6933 D->error and fail f_ "read %s: %s", $dscfn, $!;
6936 # we don't normally need this so import it here
6937 use Dpkg::Source::Package;
6938 my $dp = new Dpkg::Source::Package filename => $dscfn,
6939 require_valid_signature => $needsig;
6941 local $SIG{__WARN__} = sub {
6943 return unless $needsig;
6944 fail __ "import-dsc signature check failed";
6946 if (!$dp->is_signed()) {
6947 warn f_ "%s: warning: importing unsigned .dsc\n", $us;
6949 my $r = $dp->check_signature();
6950 confess "->check_signature => $r" if $needsig && $r;
6956 $package = getfield $dsc, 'Source';
6958 parse_dsc_field($dsc, __ "Dgit metadata in .dsc")
6959 unless forceing [qw(import-dsc-with-dgit-field)];
6960 parse_dsc_field_def_dsc_distro();
6962 $isuite = 'DGIT-IMPORT-DSC';
6963 $idistro //= $dsc_distro;
6967 if (defined $dsc_hash) {
6969 "dgit: import-dsc of .dsc with Dgit field, using git hash";
6970 resolve_dsc_field_commit undef, undef;
6972 if (defined $dsc_hash) {
6973 my @cmd = (qw(sh -ec),
6974 "echo $dsc_hash | git cat-file --batch-check");
6975 my $objgot = cmdoutput @cmd;
6976 if ($objgot =~ m#^\w+ missing\b#) {
6977 fail f_ <<END, $dsc_hash
6978 .dsc contains Dgit field referring to object %s
6979 Your git tree does not have that object. Try `git fetch' from a
6980 plausible server (browse.dgit.d.o? salsa?), and try the import-dsc again.
6983 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6985 progress __ "Not fast forward, forced update.";
6987 fail f_ "Not fast forward to %s", $dsc_hash;
6990 import_dsc_result $dstbranch, $dsc_hash,
6991 "dgit import-dsc (Dgit): $info",
6992 f_ "updated git ref %s", $dstbranch;
6996 fail f_ <<END, $dstbranch, $specbranch, $specbranch
6997 Branch %s already exists
6998 Specify ..%s for a pseudo-merge, binding in existing history
6999 Specify +%s to overwrite, discarding existing history
7001 if $oldhash && !$force;
7003 my @dfi = dsc_files_info();
7004 foreach my $fi (@dfi) {
7005 my $f = $fi->{Filename};
7006 my $here = "$buildproductsdir/$f";
7009 fail f_ "lstat %s works but stat gives %s !", $here, $!;
7011 fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
7013 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
7015 } elsif ($dscfn =~ m#^/#) {
7019 "cannot import %s which seems to be inside working tree!",
7022 $there =~ s#/+[^/]+$## or fail f_
7023 "import %s requires .../%s, but it does not exist",
7026 my $test = $there =~ m{^/} ? $there : "../$there";
7027 stat $test or fail f_
7028 "import %s requires %s, but: %s", $dscfn, $test, $!;
7029 symlink $there, $here or fail f_
7030 "symlink %s to %s: %s", $there, $here, $!;
7031 progress f_ "made symlink %s -> %s", $here, $there;
7032 # print STDERR Dumper($fi);
7034 my @mergeinputs = generate_commits_from_dsc();
7035 die unless @mergeinputs == 1;
7037 my $newhash = $mergeinputs[0]{Commit};
7042 "Import, forced update - synthetic orphan git history.";
7043 } elsif ($force < 0) {
7044 progress __ "Import, merging.";
7045 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
7046 my $version = getfield $dsc, 'Version';
7047 my $clogp = commit_getclogp $newhash;
7048 my $authline = clogp_authline $clogp;
7049 $newhash = make_commit_text <<ENDU
7057 .(f_ <<END, $package, $version, $dstbranch);
7058 Merge %s (%s) import into %s
7061 die; # caught earlier
7065 import_dsc_result $dstbranch, $newhash,
7066 "dgit import-dsc: $info",
7067 f_ "results are in git ref %s", $dstbranch;
7070 sub pre_archive_api_query () {
7071 not_necessarily_a_tree();
7073 sub cmd_archive_api_query {
7074 badusage __ "need only 1 subpath argument" unless @ARGV==1;
7075 my ($subpath) = @ARGV;
7076 local $isuite = 'DGIT-API-QUERY-CMD';
7077 my @cmd = archive_api_query_cmd($subpath);
7080 exec @cmd or fail f_ "exec curl: %s\n", $!;
7083 sub repos_server_url () {
7084 $package = '_dgit-repos-server';
7085 local $access_forpush = 1;
7086 local $isuite = 'DGIT-REPOS-SERVER';
7087 my $url = access_giturl();
7090 sub pre_clone_dgit_repos_server () {
7091 not_necessarily_a_tree();
7093 sub cmd_clone_dgit_repos_server {
7094 badusage __ "need destination argument" unless @ARGV==1;
7095 my ($destdir) = @ARGV;
7096 my $url = repos_server_url();
7097 my @cmd = (@git, qw(clone), $url, $destdir);
7099 exec @cmd or fail f_ "exec git clone: %s\n", $!;
7102 sub pre_print_dgit_repos_server_source_url () {
7103 not_necessarily_a_tree();
7105 sub cmd_print_dgit_repos_server_source_url {
7107 "no arguments allowed to dgit print-dgit-repos-server-source-url"
7109 my $url = repos_server_url();
7110 print $url, "\n" or confess $!;
7113 sub pre_print_dpkg_source_ignores {
7114 not_necessarily_a_tree();
7116 sub cmd_print_dpkg_source_ignores {
7118 "no arguments allowed to dgit print-dpkg-source-ignores"
7120 print "@dpkg_source_ignores\n" or confess $!;
7123 sub cmd_setup_mergechangelogs {
7124 badusage __ "no arguments allowed to dgit setup-mergechangelogs"
7126 local $isuite = 'DGIT-SETUP-TREE';
7127 setup_mergechangelogs(1);
7130 sub cmd_setup_useremail {
7131 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7132 local $isuite = 'DGIT-SETUP-TREE';
7136 sub cmd_setup_gitattributes {
7137 badusage __ "no arguments allowed to dgit setup-useremail" if @ARGV;
7138 local $isuite = 'DGIT-SETUP-TREE';
7142 sub cmd_setup_new_tree {
7143 badusage __ "no arguments allowed to dgit setup-tree" if @ARGV;
7144 local $isuite = 'DGIT-SETUP-TREE';
7148 #---------- argument parsing and main program ----------
7151 print "dgit version $our_version\n" or confess $!;
7155 our (%valopts_long, %valopts_short);
7156 our (%funcopts_long);
7158 our (@modeopt_cfgs);
7160 sub defvalopt ($$$$) {
7161 my ($long,$short,$val_re,$how) = @_;
7162 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
7163 $valopts_long{$long} = $oi;
7164 $valopts_short{$short} = $oi;
7165 # $how subref should:
7166 # do whatever assignemnt or thing it likes with $_[0]
7167 # if the option should not be passed on to remote, @rvalopts=()
7168 # or $how can be a scalar ref, meaning simply assign the value
7171 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
7172 defvalopt '--distro', '-d', '.+', \$idistro;
7173 defvalopt '', '-k', '.+', \$keyid;
7174 defvalopt '--existing-package','', '.*', \$existing_package;
7175 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
7176 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
7177 defvalopt '--package', '-p', $package_re, \$package;
7178 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
7180 defvalopt '', '-C', '.+', sub {
7181 ($changesfile) = (@_);
7182 if ($changesfile =~ s#^(.*)/##) {
7183 $buildproductsdir = $1;
7187 defvalopt '--initiator-tempdir','','.*', sub {
7188 ($initiator_tempdir) = (@_);
7189 $initiator_tempdir =~ m#^/# or
7190 badusage __ "--initiator-tempdir must be used specify an".
7191 " absolute, not relative, directory."
7194 sub defoptmodes ($@) {
7195 my ($varref, $cfgkey, $default, %optmap) = @_;
7197 while (my ($opt,$val) = each %optmap) {
7198 $funcopts_long{$opt} = sub { $$varref = $val; };
7199 $permit{$val} = $val;
7201 push @modeopt_cfgs, {
7204 Default => $default,
7209 defoptmodes \$dodep14tag, qw( dep14tag want
7212 --always-dep14tag always );
7217 if (defined $ENV{'DGIT_SSH'}) {
7218 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
7219 } elsif (defined $ENV{'GIT_SSH'}) {
7220 @ssh = ($ENV{'GIT_SSH'});
7228 if (!defined $val) {
7229 badusage f_ "%s needs a value", $what unless @ARGV;
7231 push @rvalopts, $val;
7233 badusage f_ "bad value \`%s' for %s", $val, $what unless
7234 $val =~ m/^$oi->{Re}$(?!\n)/s;
7235 my $how = $oi->{How};
7236 if (ref($how) eq 'SCALAR') {
7241 push @ropts, @rvalopts;
7245 last unless $ARGV[0] =~ m/^-/;
7249 if (m/^--dry-run$/) {
7252 } elsif (m/^--damp-run$/) {
7255 } elsif (m/^--no-sign$/) {
7258 } elsif (m/^--help$/) {
7260 } elsif (m/^--version$/) {
7262 } elsif (m/^--new$/) {
7265 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
7266 ($om = $opts_opt_map{$1}) &&
7270 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
7271 !$opts_opt_cmdonly{$1} &&
7272 ($om = $opts_opt_map{$1})) {
7275 } elsif (m/^--([-0-9a-z]+)\!:(.*)/s &&
7276 !$opts_opt_cmdonly{$1} &&
7277 ($om = $opts_opt_map{$1})) {
7279 my $cmd = shift @$om;
7280 @$om = ($cmd, grep { $_ ne $2 } @$om);
7281 } elsif (m/^--(gbp|dpm)$/s) {
7282 push @ropts, "--quilt=$1";
7284 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7287 } elsif (m/^--no-quilt-fixup$/s) {
7289 $quilt_mode = 'nocheck';
7290 } elsif (m/^--no-rm-on-error$/s) {
7293 } elsif (m/^--no-chase-dsc-distro$/s) {
7295 $chase_dsc_distro = 0;
7296 } elsif (m/^--overwrite$/s) {
7298 $overwrite_version = '';
7299 } elsif (m/^--overwrite=(.+)$/s) {
7301 $overwrite_version = $1;
7302 } elsif (m/^--delayed=(\d+)$/s) {
7305 } elsif (my ($k,$v) =
7306 m/^--save-(dgit-view)=(.+)$/s ||
7307 m/^--(dgit-view)-save=(.+)$/s
7310 $v =~ s#^(?!refs/)#refs/heads/#;
7311 $internal_object_save{$k} = $v;
7312 } elsif (m/^--(no-)?rm-old-changes$/s) {
7315 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7317 push @deliberatelies, $&;
7318 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7322 } elsif (m/^--force-/) {
7324 f_ "%s: warning: ignoring unknown force option %s\n",
7327 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7328 # undocumented, for testing
7330 $tagformat_want = [ $1, 'command line', 1 ];
7331 # 1 menas overrides distro configuration
7332 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7333 # undocumented, for testing
7335 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7336 # ^ it's supposed to be an array ref
7337 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7338 $val = $2 ? $' : undef; #';
7339 $valopt->($oi->{Long});
7340 } elsif ($funcopts_long{$_}) {
7342 $funcopts_long{$_}();
7344 badusage f_ "unknown long option \`%s'", $_;
7351 } elsif (s/^-L/-/) {
7354 } elsif (s/^-h/-/) {
7356 } elsif (s/^-D/-/) {
7360 } elsif (s/^-N/-/) {
7365 push @changesopts, $_;
7367 } elsif (s/^-wn$//s) {
7369 $cleanmode = 'none';
7370 } elsif (s/^-wg(f?)(a?)$//s) {
7373 $cleanmode .= '-ff' if $1;
7374 $cleanmode .= ',always' if $2;
7375 } elsif (s/^-wd(d?)([na]?)$//s) {
7377 $cleanmode = 'dpkg-source';
7378 $cleanmode .= '-d' if $1;
7379 $cleanmode .= ',no-check' if $2 eq 'n';
7380 $cleanmode .= ',all-check' if $2 eq 'a';
7381 } elsif (s/^-wc$//s) {
7383 $cleanmode = 'check';
7384 } elsif (s/^-wci$//s) {
7386 $cleanmode = 'check,ignores';
7387 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7388 push @git, '-c', $&;
7389 $gitcfgs{cmdline}{$1} = [ $2 ];
7390 } elsif (s/^-c([^=]+)$//s) {
7391 push @git, '-c', $&;
7392 $gitcfgs{cmdline}{$1} = [ 'true' ];
7393 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7395 $val = undef unless length $val;
7396 $valopt->($oi->{Short});
7399 badusage f_ "unknown short option \`%s'", $_;
7406 sub check_env_sanity () {
7407 my $blocked = new POSIX::SigSet;
7408 sigprocmask SIG_UNBLOCK, $blocked, $blocked or confess $!;
7411 foreach my $name (qw(PIPE CHLD)) {
7412 my $signame = "SIG$name";
7413 my $signum = eval "POSIX::$signame" // die;
7414 die f_ "%s is set to something other than SIG_DFL\n",
7416 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7417 $blocked->ismember($signum) and
7418 die f_ "%s is blocked\n", $signame;
7424 On entry to dgit, %s
7425 This is a bug produced by something in your execution environment.
7431 sub parseopts_late_defaults () {
7432 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7433 if defined $idistro;
7434 $isuite //= cfg('dgit.default.default-suite');
7436 foreach my $k (keys %opts_opt_map) {
7437 my $om = $opts_opt_map{$k};
7439 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7441 badcfg f_ "cannot set command for %s", $k
7442 unless length $om->[0];
7446 foreach my $c (access_cfg_cfgs("opts-$k")) {
7448 map { $_ ? @$_ : () }
7449 map { $gitcfgs{$_}{$c} }
7450 reverse @gitcfgsources;
7451 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7452 "\n" if $debuglevel >= 4;
7454 badcfg f_ "cannot configure options for %s", $k
7455 if $opts_opt_cmdonly{$k};
7456 my $insertpos = $opts_cfg_insertpos{$k};
7457 @$om = ( @$om[0..$insertpos-1],
7459 @$om[$insertpos..$#$om] );
7463 if (!defined $rmchanges) {
7464 local $access_forpush;
7465 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7468 if (!defined $quilt_mode) {
7469 local $access_forpush;
7470 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7471 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7473 $quilt_mode =~ m/^($quilt_modes_re)$/
7474 or badcfg f_ "unknown quilt-mode \`%s'", $quilt_mode;
7478 foreach my $moc (@modeopt_cfgs) {
7479 local $access_forpush;
7480 my $vr = $moc->{Var};
7481 next if defined $$vr;
7482 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7483 my $v = $moc->{Vals}{$$vr};
7484 badcfg f_ "unknown %s setting \`%s'", $moc->{Key}, $$vr
7489 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7490 if $split_brain && $includedirty;
7492 if (!defined $cleanmode) {
7493 local $access_forpush;
7494 $cleanmode = access_cfg('clean-mode-newer', 'RETURN-UNDEF');
7495 $cleanmode = undef if $cleanmode && $cleanmode !~ m/^$cleanmode_re$/;
7497 $cleanmode //= access_cfg('clean-mode', 'RETURN-UNDEF');
7498 $cleanmode //= 'dpkg-source';
7500 badcfg f_ "unknown clean-mode \`%s'", $cleanmode unless
7501 $cleanmode =~ m/$cleanmode_re/;
7504 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7505 $buildproductsdir //= '..';
7506 $bpd_glob = $buildproductsdir;
7507 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7510 setlocale(LC_MESSAGES, "");
7513 if ($ENV{$fakeeditorenv}) {
7515 quilt_fixup_editor();
7521 print STDERR __ "DRY RUN ONLY\n" if $dryrun_level > 1;
7522 print STDERR __ "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7523 if $dryrun_level == 1;
7525 print STDERR __ $helpmsg or confess $!;
7528 $cmd = $subcommand = shift @ARGV;
7531 my $pre_fn = ${*::}{"pre_$cmd"};
7532 $pre_fn->() if $pre_fn;
7534 if ($invoked_in_git_tree) {
7535 changedir_git_toplevel();
7540 my $fn = ${*::}{"cmd_$cmd"};
7541 $fn or badusage f_ "unknown operation %s", $cmd;