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 = 'dpkg-source(?:-d)?|git|git-ff|check|none';
106 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
107 our $splitbraincache = 'dgit-intern/quilt-cache';
108 our $rewritemap = 'dgit-rewrite/map';
110 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
112 our (@git) = qw(git);
113 our (@dget) = qw(dget);
114 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
115 our (@dput) = qw(dput);
116 our (@debsign) = qw(debsign);
117 our (@gpg) = qw(gpg);
118 our (@sbuild) = (qw(sbuild --no-source));
120 our (@dgit) = qw(dgit);
121 our (@git_debrebase) = qw(git-debrebase);
122 our (@aptget) = qw(apt-get);
123 our (@aptcache) = qw(apt-cache);
124 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
125 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
126 our (@dpkggenchanges) = qw(dpkg-genchanges);
127 our (@mergechanges) = qw(mergechanges -f);
128 our (@gbp_build) = ('');
129 our (@gbp_pq) = ('gbp pq');
130 our (@changesopts) = ('');
131 our (@pbuilder) = ("sudo -E pbuilder");
132 our (@cowbuilder) = ("sudo -E cowbuilder");
134 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
137 'debsign' => \@debsign,
139 'sbuild' => \@sbuild,
143 'git-debrebase' => \@git_debrebase,
144 'apt-get' => \@aptget,
145 'apt-cache' => \@aptcache,
146 'dpkg-source' => \@dpkgsource,
147 'dpkg-buildpackage' => \@dpkgbuildpackage,
148 'dpkg-genchanges' => \@dpkggenchanges,
149 'gbp-build' => \@gbp_build,
150 'gbp-pq' => \@gbp_pq,
151 'ch' => \@changesopts,
152 'mergechanges' => \@mergechanges,
153 'pbuilder' => \@pbuilder,
154 'cowbuilder' => \@cowbuilder);
156 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
157 our %opts_cfg_insertpos = map {
159 scalar @{ $opts_opt_map{$_} }
160 } keys %opts_opt_map;
162 sub parseopts_late_defaults();
163 sub setup_gitattrs(;$);
164 sub check_gitattrs($$);
171 our $supplementary_message = '';
172 our $split_brain = 0;
176 return unless forkcheck_mainprocess();
177 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
180 our $remotename = 'dgit';
181 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
185 if (!defined $absurdity) {
187 $absurdity =~ s{/[^/]+$}{/absurd} or die;
191 my ($v,$distro) = @_;
192 return $tagformatfn->($v, $distro);
195 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
197 sub lbranch () { return "$branchprefix/$csuite"; }
198 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
199 sub lref () { return "refs/heads/".lbranch(); }
200 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
201 sub rrref () { return server_ref($csuite); }
204 my ($vsn, $sfx) = @_;
205 return &source_file_leafname($package, $vsn, $sfx);
207 sub is_orig_file_of_vsn ($$) {
208 my ($f, $upstreamvsn) = @_;
209 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
214 return srcfn($vsn,".dsc");
217 sub changespat ($;$) {
218 my ($vsn, $arch) = @_;
219 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
228 return unless forkcheck_mainprocess();
229 foreach my $f (@end) {
231 print STDERR "$us: cleanup: $@" if length $@;
236 print STDERR f_ "%s: invalid configuration: %s\n", $us, "@_";
240 sub forceable_fail ($$) {
241 my ($forceoptsl, $msg) = @_;
242 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
243 print STDERR +(__ "warning: overriding problem due to --force:\n"). $msg;
247 my ($forceoptsl) = @_;
248 my @got = grep { $forceopts{$_} } @$forceoptsl;
249 return 0 unless @got;
251 "warning: skipping checks or functionality due to --force-%s\n",
255 sub no_such_package () {
256 print STDERR f_ "%s: package %s does not exist in suite %s\n",
257 $us, $package, $isuite;
261 sub deliberately ($) {
263 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
266 sub deliberately_not_fast_forward () {
267 foreach (qw(not-fast-forward fresh-repo)) {
268 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
272 sub quiltmode_splitbrain () {
273 $quilt_mode =~ m/gbp|dpm|unapplied/;
276 sub opts_opt_multi_cmd {
279 push @cmd, split /\s+/, shift @_;
286 return opts_opt_multi_cmd [], @gbp_pq;
289 sub dgit_privdir () {
290 our $dgit_privdir_made //= ensure_a_playground 'dgit';
294 my $r = $buildproductsdir;
295 $r = "$maindir/$r" unless $r =~ m{^/};
299 sub get_tree_of_commit ($) {
300 my ($commitish) = @_;
301 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
302 $cdata =~ m/\n\n/; $cdata = $`;
303 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
307 sub branch_gdr_info ($$) {
308 my ($symref, $head) = @_;
309 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
310 gdr_ffq_prev_branchinfo($symref);
311 return () unless $status eq 'branch';
312 $ffq_prev = git_get_ref $ffq_prev;
313 $gdrlast = git_get_ref $gdrlast;
314 $gdrlast &&= is_fast_fwd $gdrlast, $head;
315 return ($ffq_prev, $gdrlast);
318 sub branch_is_gdr_unstitched_ff ($$$) {
319 my ($symref, $head, $ancestor) = @_;
320 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
321 return 0 unless $ffq_prev;
322 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
326 sub branch_is_gdr ($) {
328 # This is quite like git-debrebase's keycommits.
329 # We have our own implementation because:
330 # - our algorighm can do fewer tests so is faster
331 # - it saves testing to see if gdr is installed
333 # NB we use this jsut for deciding whether to run gdr make-patches
334 # Before reusing this algorithm for somthing else, its
335 # suitability should be reconsidered.
338 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
339 printdebug "branch_is_gdr $head...\n";
340 my $get_patches = sub {
341 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
344 my $tip_patches = $get_patches->($head);
347 my $cdata = git_cat_file $walk, 'commit';
348 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
349 if ($msg =~ m{^\[git-debrebase\ (
350 anchor | changelog | make-patches |
351 merged-breakwater | pseudomerge
353 # no need to analyse this - it's sufficient
354 # (gdr classifications: Anchor, MergedBreakwaters)
355 # (made by gdr: Pseudomerge, Changelog)
356 printdebug "branch_is_gdr $walk gdr $1 YES\n";
359 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
361 my $walk_tree = get_tree_of_commit $walk;
362 foreach my $p (@parents) {
363 my $p_tree = get_tree_of_commit $p;
364 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
365 # (gdr classification: Pseudomerge; not made by gdr)
366 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
372 # some other non-gdr merge
373 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
374 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
378 # (gdr classification: ?)
379 printdebug "branch_is_gdr $walk ?-octopus NO\n";
382 if ($get_patches->($walk) ne $tip_patches) {
383 # Our parent added, removed, or edited patches, and wasn't
384 # a gdr make-patches commit. gdr make-patches probably
385 # won't do that well, then.
386 # (gdr classification of parent: AddPatches or ?)
387 printdebug "branch_is_gdr $walk ?-patches NO\n";
390 if ($tip_patches eq '' and
391 !defined git_cat_file "$walk:debian") {
392 # (gdr classification of parent: BreakwaterStart
393 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
396 # (gdr classification: Upstream Packaging Mixed Changelog)
397 printdebug "branch_is_gdr $walk plain\n"
403 #---------- remote protocol support, common ----------
405 # remote push initiator/responder protocol:
406 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
407 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
408 # < dgit-remote-push-ready <actual-proto-vsn>
415 # > supplementary-message NBYTES # $protovsn >= 3
420 # > file parsed-changelog
421 # [indicates that output of dpkg-parsechangelog follows]
422 # > data-block NBYTES
423 # > [NBYTES bytes of data (no newline)]
424 # [maybe some more blocks]
433 # > param head DGIT-VIEW-HEAD
434 # > param csuite SUITE
435 # > param tagformat old|new
436 # > param maint-view MAINT-VIEW-HEAD
438 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
439 # > file buildinfo # for buildinfos to sign
441 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
442 # # goes into tag, for replay prevention
445 # [indicates that signed tag is wanted]
446 # < data-block NBYTES
447 # < [NBYTES bytes of data (no newline)]
448 # [maybe some more blocks]
452 # > want signed-dsc-changes
453 # < data-block NBYTES [transfer of signed dsc]
455 # < data-block NBYTES [transfer of signed changes]
457 # < data-block NBYTES [transfer of each signed buildinfo
458 # [etc] same number and order as "file buildinfo"]
466 sub i_child_report () {
467 # Sees if our child has died, and reap it if so. Returns a string
468 # describing how it died if it failed, or undef otherwise.
469 return undef unless $i_child_pid;
470 my $got = waitpid $i_child_pid, WNOHANG;
471 return undef if $got <= 0;
472 die unless $got == $i_child_pid;
473 $i_child_pid = undef;
474 return undef unless $?;
475 return f_ "build host child %s", waitstatusmsg();
480 fail f_ "connection lost: %s", $! if $fh->error;
481 fail f_ "protocol violation; %s not expected", $m;
484 sub badproto_badread ($$) {
486 fail f_ "connection lost: %s", $! if $!;
487 my $report = i_child_report();
488 fail $report if defined $report;
489 badproto $fh, f_ "eof (reading %s)", $wh;
492 sub protocol_expect (&$) {
493 my ($match, $fh) = @_;
496 defined && chomp or badproto_badread $fh, "protocol message";
504 badproto $fh, "\`$_'";
507 sub protocol_send_file ($$) {
508 my ($fh, $ourfn) = @_;
509 open PF, "<", $ourfn or die "$ourfn: $!";
512 my $got = read PF, $d, 65536;
513 die "$ourfn: $!" unless defined $got;
515 print $fh "data-block ".length($d)."\n" or die $!;
516 print $fh $d or die $!;
518 PF->error and die "$ourfn $!";
519 print $fh "data-end\n" or die $!;
523 sub protocol_read_bytes ($$) {
524 my ($fh, $nbytes) = @_;
525 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
527 my $got = read $fh, $d, $nbytes;
528 $got==$nbytes or badproto_badread $fh, "data block";
532 sub protocol_receive_file ($$) {
533 my ($fh, $ourfn) = @_;
534 printdebug "() $ourfn\n";
535 open PF, ">", $ourfn or die "$ourfn: $!";
537 my ($y,$l) = protocol_expect {
538 m/^data-block (.*)$/ ? (1,$1) :
539 m/^data-end$/ ? (0,) :
543 my $d = protocol_read_bytes $fh, $l;
544 print PF $d or die $!;
549 #---------- remote protocol support, responder ----------
551 sub responder_send_command ($) {
553 return unless $we_are_responder;
554 # called even without $we_are_responder
555 printdebug ">> $command\n";
556 print PO $command, "\n" or die $!;
559 sub responder_send_file ($$) {
560 my ($keyword, $ourfn) = @_;
561 return unless $we_are_responder;
562 printdebug "]] $keyword $ourfn\n";
563 responder_send_command "file $keyword";
564 protocol_send_file \*PO, $ourfn;
567 sub responder_receive_files ($@) {
568 my ($keyword, @ourfns) = @_;
569 die unless $we_are_responder;
570 printdebug "[[ $keyword @ourfns\n";
571 responder_send_command "want $keyword";
572 foreach my $fn (@ourfns) {
573 protocol_receive_file \*PI, $fn;
576 protocol_expect { m/^files-end$/ } \*PI;
579 #---------- remote protocol support, initiator ----------
581 sub initiator_expect (&) {
583 protocol_expect { &$match } \*RO;
586 #---------- end remote code ----------
589 if ($we_are_responder) {
591 responder_send_command "progress ".length($m) or die $!;
592 print PO $m or die $!;
602 $ua = LWP::UserAgent->new();
606 progress "downloading $what...";
607 my $r = $ua->get(@_) or die $!;
608 return undef if $r->code == 404;
609 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
610 return $r->decoded_content(charset => 'none');
613 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
615 sub act_local () { return $dryrun_level <= 1; }
616 sub act_scary () { return !$dryrun_level; }
619 if (!$dryrun_level) {
620 progress "$us ok: @_";
622 progress "would be ok: @_ (but dry run only)";
627 printcmd(\*STDERR,$debugprefix."#",@_);
630 sub runcmd_ordryrun {
638 sub runcmd_ordryrun_local {
646 our $helpmsg = <<END;
648 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
649 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
650 dgit [dgit-opts] build [dpkg-buildpackage-opts]
651 dgit [dgit-opts] sbuild [sbuild-opts]
652 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
653 dgit [dgit-opts] push [dgit-opts] [suite]
654 dgit [dgit-opts] push-source [dgit-opts] [suite]
655 dgit [dgit-opts] rpush build-host:build-dir ...
656 important dgit options:
657 -k<keyid> sign tag and package with <keyid> instead of default
658 --dry-run -n do not change anything, but go through the motions
659 --damp-run -L like --dry-run but make local changes, without signing
660 --new -N allow introducing a new package
661 --debug -D increase debug level
662 -c<name>=<value> set git config option (used directly by dgit too)
665 our $later_warning_msg = <<END;
666 Perhaps the upload is stuck in incoming. Using the version from git.
670 print STDERR "$us: @_\n", $helpmsg or die $!;
675 @ARGV or badusage "too few arguments";
676 return scalar shift @ARGV;
680 not_necessarily_a_tree();
683 print $helpmsg or die $!;
687 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
689 our %defcfg = ('dgit.default.distro' => 'debian',
690 'dgit.default.default-suite' => 'unstable',
691 'dgit.default.old-dsc-distro' => 'debian',
692 'dgit-suite.*-security.distro' => 'debian-security',
693 'dgit.default.username' => '',
694 'dgit.default.archive-query-default-component' => 'main',
695 'dgit.default.ssh' => 'ssh',
696 'dgit.default.archive-query' => 'madison:',
697 'dgit.default.sshpsql-dbname' => 'service=projectb',
698 'dgit.default.aptget-components' => 'main',
699 'dgit.default.dgit-tag-format' => 'new,old,maint',
700 'dgit.default.source-only-uploads' => 'ok',
701 'dgit.dsc-url-proto-ok.http' => 'true',
702 'dgit.dsc-url-proto-ok.https' => 'true',
703 'dgit.dsc-url-proto-ok.git' => 'true',
704 'dgit.vcs-git.suites', => 'sid', # ;-separated
705 'dgit.default.dsc-url-proto-ok' => 'false',
706 # old means "repo server accepts pushes with old dgit tags"
707 # new means "repo server accepts pushes with new dgit tags"
708 # maint means "repo server accepts split brain pushes"
709 # hist means "repo server may have old pushes without new tag"
710 # ("hist" is implied by "old")
711 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
712 'dgit-distro.debian.git-check' => 'url',
713 'dgit-distro.debian.git-check-suffix' => '/info/refs',
714 'dgit-distro.debian.new-private-pushers' => 't',
715 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
716 'dgit-distro.debian/push.git-url' => '',
717 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
718 'dgit-distro.debian/push.git-user-force' => 'dgit',
719 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
720 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
721 'dgit-distro.debian/push.git-create' => 'true',
722 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
723 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
724 # 'dgit-distro.debian.archive-query-tls-key',
725 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
726 # ^ this does not work because curl is broken nowadays
727 # Fixing #790093 properly will involve providing providing the key
728 # in some pacagke and maybe updating these paths.
730 # 'dgit-distro.debian.archive-query-tls-curl-args',
731 # '--ca-path=/etc/ssl/ca-debian',
732 # ^ this is a workaround but works (only) on DSA-administered machines
733 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
734 'dgit-distro.debian.git-url-suffix' => '',
735 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
736 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
737 'dgit-distro.debian-security.archive-query' => 'aptget:',
738 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
739 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
740 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
741 'dgit-distro.debian-security.nominal-distro' => 'debian',
742 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
743 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
744 'dgit-distro.ubuntu.git-check' => 'false',
745 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
746 'dgit-distro.test-dummy.ssh' => "$td/ssh",
747 'dgit-distro.test-dummy.username' => "alice",
748 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
749 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
750 'dgit-distro.test-dummy.git-url' => "$td/git",
751 'dgit-distro.test-dummy.git-host' => "git",
752 'dgit-distro.test-dummy.git-path' => "$td/git",
753 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
754 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
755 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
756 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
760 our @gitcfgsources = qw(cmdline local global system);
761 our $invoked_in_git_tree = 1;
763 sub git_slurp_config () {
764 # This algoritm is a bit subtle, but this is needed so that for
765 # options which we want to be single-valued, we allow the
766 # different config sources to override properly. See #835858.
767 foreach my $src (@gitcfgsources) {
768 next if $src eq 'cmdline';
769 # we do this ourselves since git doesn't handle it
771 $gitcfgs{$src} = git_slurp_config_src $src;
775 sub git_get_config ($) {
777 foreach my $src (@gitcfgsources) {
778 my $l = $gitcfgs{$src}{$c};
779 confess "internal error ($l $c)" if $l && !ref $l;
780 printdebug"C $c ".(defined $l ?
781 join " ", map { messagequote "'$_'" } @$l :
785 @$l==1 or badcfg "multiple values for $c".
786 " (in $src git config)" if @$l > 1;
794 return undef if $c =~ /RETURN-UNDEF/;
795 printdebug "C? $c\n" if $debuglevel >= 5;
796 my $v = git_get_config($c);
797 return $v if defined $v;
798 my $dv = $defcfg{$c};
800 printdebug "CD $c $dv\n" if $debuglevel >= 4;
804 badcfg "need value for one of: @_\n".
805 "$us: distro or suite appears not to be (properly) supported";
808 sub not_necessarily_a_tree () {
809 # needs to be called from pre_*
810 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
811 $invoked_in_git_tree = 0;
814 sub access_basedistro__noalias () {
815 if (defined $idistro) {
818 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
819 return $def if defined $def;
820 foreach my $src (@gitcfgsources, 'internal') {
821 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
823 foreach my $k (keys %$kl) {
824 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
826 next unless match_glob $dpat, $isuite;
830 return cfg("dgit.default.distro");
834 sub access_basedistro () {
835 my $noalias = access_basedistro__noalias();
836 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
837 return $canon // $noalias;
840 sub access_nomdistro () {
841 my $base = access_basedistro();
842 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
843 $r =~ m/^$distro_re$/ or badcfg
844 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
848 sub access_quirk () {
849 # returns (quirk name, distro to use instead or undef, quirk-specific info)
850 my $basedistro = access_basedistro();
851 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
853 if (defined $backports_quirk) {
854 my $re = $backports_quirk;
855 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
857 $re =~ s/\%/([-0-9a-z_]+)/
858 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
859 if ($isuite =~ m/^$re$/) {
860 return ('backports',"$basedistro-backports",$1);
863 return ('none',undef);
868 sub parse_cfg_bool ($$$) {
869 my ($what,$def,$v) = @_;
872 $v =~ m/^[ty1]/ ? 1 :
873 $v =~ m/^[fn0]/ ? 0 :
874 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
877 sub access_forpush_config () {
878 my $d = access_basedistro();
882 parse_cfg_bool('new-private-pushers', 0,
883 cfg("dgit-distro.$d.new-private-pushers",
886 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
889 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
890 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
891 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
892 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
895 sub access_forpush () {
896 $access_forpush //= access_forpush_config();
897 return $access_forpush;
901 confess 'internal error '.Dumper($access_forpush)," ?" if
902 defined $access_forpush and !$access_forpush;
903 badcfg "pushing but distro is configured readonly"
904 if access_forpush_config() eq '0';
906 $supplementary_message = <<'END' unless $we_are_responder;
907 Push failed, before we got started.
908 You can retry the push, after fixing the problem, if you like.
910 parseopts_late_defaults();
914 parseopts_late_defaults();
917 sub supplementary_message ($) {
919 if (!$we_are_responder) {
920 $supplementary_message = $msg;
922 } elsif ($protovsn >= 3) {
923 responder_send_command "supplementary-message ".length($msg)
925 print PO $msg or die $!;
929 sub access_distros () {
930 # Returns list of distros to try, in order
933 # 0. `instead of' distro name(s) we have been pointed to
934 # 1. the access_quirk distro, if any
935 # 2a. the user's specified distro, or failing that } basedistro
936 # 2b. the distro calculated from the suite }
937 my @l = access_basedistro();
939 my (undef,$quirkdistro) = access_quirk();
940 unshift @l, $quirkdistro;
941 unshift @l, $instead_distro;
942 @l = grep { defined } @l;
944 push @l, access_nomdistro();
946 if (access_forpush()) {
947 @l = map { ("$_/push", $_) } @l;
952 sub access_cfg_cfgs (@) {
955 # The nesting of these loops determines the search order. We put
956 # the key loop on the outside so that we search all the distros
957 # for each key, before going on to the next key. That means that
958 # if access_cfg is called with a more specific, and then a less
959 # specific, key, an earlier distro can override the less specific
960 # without necessarily overriding any more specific keys. (If the
961 # distro wants to override the more specific keys it can simply do
962 # so; whereas if we did the loop the other way around, it would be
963 # impossible to for an earlier distro to override a less specific
964 # key but not the more specific ones without restating the unknown
965 # values of the more specific keys.
968 # We have to deal with RETURN-UNDEF specially, so that we don't
969 # terminate the search prematurely.
971 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
974 foreach my $d (access_distros()) {
975 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
977 push @cfgs, map { "dgit.default.$_" } @realkeys;
984 my (@cfgs) = access_cfg_cfgs(@keys);
985 my $value = cfg(@cfgs);
989 sub access_cfg_bool ($$) {
990 my ($def, @keys) = @_;
991 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
994 sub string_to_ssh ($) {
996 if ($spec =~ m/\s/) {
997 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
1003 sub access_cfg_ssh () {
1004 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1005 if (!defined $gitssh) {
1008 return string_to_ssh $gitssh;
1012 sub access_runeinfo ($) {
1014 return ": dgit ".access_basedistro()." $info ;";
1017 sub access_someuserhost ($) {
1019 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1020 defined($user) && length($user) or
1021 $user = access_cfg("$some-user",'username');
1022 my $host = access_cfg("$some-host");
1023 return length($user) ? "$user\@$host" : $host;
1026 sub access_gituserhost () {
1027 return access_someuserhost('git');
1030 sub access_giturl (;$) {
1031 my ($optional) = @_;
1032 my $url = access_cfg('git-url','RETURN-UNDEF');
1035 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1036 return undef unless defined $proto;
1039 access_gituserhost().
1040 access_cfg('git-path');
1042 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1045 return "$url/$package$suffix";
1048 sub commit_getclogp ($) {
1049 # Returns the parsed changelog hashref for a particular commit
1051 our %commit_getclogp_memo;
1052 my $memo = $commit_getclogp_memo{$objid};
1053 return $memo if $memo;
1055 my $mclog = dgit_privdir()."clog";
1056 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1057 "$objid:debian/changelog";
1058 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1061 sub parse_dscdata () {
1062 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1063 printdebug Dumper($dscdata) if $debuglevel>1;
1064 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1065 printdebug Dumper($dsc) if $debuglevel>1;
1070 sub archive_query ($;@) {
1071 my ($method) = shift @_;
1072 fail "this operation does not support multiple comma-separated suites"
1074 my $query = access_cfg('archive-query','RETURN-UNDEF');
1075 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1078 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1081 sub archive_query_prepend_mirror {
1082 my $m = access_cfg('mirror');
1083 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1086 sub pool_dsc_subpath ($$) {
1087 my ($vsn,$component) = @_; # $package is implict arg
1088 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1089 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1092 sub cfg_apply_map ($$$) {
1093 my ($varref, $what, $mapspec) = @_;
1094 return unless $mapspec;
1096 printdebug "config $what EVAL{ $mapspec; }\n";
1098 eval "package Dgit::Config; $mapspec;";
1103 #---------- `ftpmasterapi' archive query method (nascent) ----------
1105 sub archive_api_query_cmd ($) {
1107 my @cmd = (@curl, qw(-sS));
1108 my $url = access_cfg('archive-query-url');
1109 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1111 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1112 foreach my $key (split /\:/, $keys) {
1113 $key =~ s/\%HOST\%/$host/g;
1115 fail "for $url: stat $key: $!" unless $!==ENOENT;
1118 fail "config requested specific TLS key but do not know".
1119 " how to get curl to use exactly that EE key ($key)";
1120 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1121 # # Sadly the above line does not work because of changes
1122 # # to gnutls. The real fix for #790093 may involve
1123 # # new curl options.
1126 # Fixing #790093 properly will involve providing a value
1127 # for this on clients.
1128 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1129 push @cmd, split / /, $kargs if defined $kargs;
1131 push @cmd, $url.$subpath;
1135 sub api_query ($$;$) {
1137 my ($data, $subpath, $ok404) = @_;
1138 badcfg "ftpmasterapi archive query method takes no data part"
1140 my @cmd = archive_api_query_cmd($subpath);
1141 my $url = $cmd[$#cmd];
1142 push @cmd, qw(-w %{http_code});
1143 my $json = cmdoutput @cmd;
1144 unless ($json =~ s/\d+\d+\d$//) {
1145 failedcmd_report_cmd undef, @cmd;
1146 fail "curl failed to print 3-digit HTTP code";
1149 return undef if $code eq '404' && $ok404;
1150 fail "fetch of $url gave HTTP code $code"
1151 unless $url =~ m#^file://# or $code =~ m/^2/;
1152 return decode_json($json);
1155 sub canonicalise_suite_ftpmasterapi {
1156 my ($proto,$data) = @_;
1157 my $suites = api_query($data, 'suites');
1159 foreach my $entry (@$suites) {
1161 my $v = $entry->{$_};
1162 defined $v && $v eq $isuite;
1163 } qw(codename name);
1164 push @matched, $entry;
1166 fail "unknown suite $isuite, maybe -d would help" unless @matched;
1169 @matched==1 or die "multiple matches for suite $isuite\n";
1170 $cn = "$matched[0]{codename}";
1171 defined $cn or die "suite $isuite info has no codename\n";
1172 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1174 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1179 sub archive_query_ftpmasterapi {
1180 my ($proto,$data) = @_;
1181 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1183 my $digester = Digest::SHA->new(256);
1184 foreach my $entry (@$info) {
1186 my $vsn = "$entry->{version}";
1187 my ($ok,$msg) = version_check $vsn;
1188 die "bad version: $msg\n" unless $ok;
1189 my $component = "$entry->{component}";
1190 $component =~ m/^$component_re$/ or die "bad component";
1191 my $filename = "$entry->{filename}";
1192 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1193 or die "bad filename";
1194 my $sha256sum = "$entry->{sha256sum}";
1195 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1196 push @rows, [ $vsn, "/pool/$component/$filename",
1197 $digester, $sha256sum ];
1199 die "bad ftpmaster api response: $@\n".Dumper($entry)
1202 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1203 return archive_query_prepend_mirror @rows;
1206 sub file_in_archive_ftpmasterapi {
1207 my ($proto,$data,$filename) = @_;
1208 my $pat = $filename;
1211 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1212 my $info = api_query($data, "file_in_archive/$pat", 1);
1215 sub package_not_wholly_new_ftpmasterapi {
1216 my ($proto,$data,$pkg) = @_;
1217 my $info = api_query($data,"madison?package=${pkg}&f=json");
1221 #---------- `aptget' archive query method ----------
1224 our $aptget_releasefile;
1225 our $aptget_configpath;
1227 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1228 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1230 sub aptget_cache_clean {
1231 runcmd_ordryrun_local qw(sh -ec),
1232 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1236 sub aptget_lock_acquire () {
1237 my $lockfile = "$aptget_base/lock";
1238 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1239 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1242 sub aptget_prep ($) {
1244 return if defined $aptget_base;
1246 badcfg "aptget archive query method takes no data part"
1249 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1252 ensuredir "$cache/dgit";
1254 access_cfg('aptget-cachekey','RETURN-UNDEF')
1255 // access_nomdistro();
1257 $aptget_base = "$cache/dgit/aptget";
1258 ensuredir $aptget_base;
1260 my $quoted_base = $aptget_base;
1261 die "$quoted_base contains bad chars, cannot continue"
1262 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1264 ensuredir $aptget_base;
1266 aptget_lock_acquire();
1268 aptget_cache_clean();
1270 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1271 my $sourceslist = "source.list#$cachekey";
1273 my $aptsuites = $isuite;
1274 cfg_apply_map(\$aptsuites, 'suite map',
1275 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1277 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1278 printf SRCS "deb-src %s %s %s\n",
1279 access_cfg('mirror'),
1281 access_cfg('aptget-components')
1284 ensuredir "$aptget_base/cache";
1285 ensuredir "$aptget_base/lists";
1287 open CONF, ">", $aptget_configpath or die $!;
1289 Debug::NoLocking "true";
1290 APT::Get::List-Cleanup "false";
1291 #clear APT::Update::Post-Invoke-Success;
1292 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1293 Dir::State::Lists "$quoted_base/lists";
1294 Dir::Etc::preferences "$quoted_base/preferences";
1295 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1296 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1299 foreach my $key (qw(
1302 Dir::Cache::Archives
1303 Dir::Etc::SourceParts
1304 Dir::Etc::preferencesparts
1306 ensuredir "$aptget_base/$key";
1307 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1310 my $oldatime = (time // die $!) - 1;
1311 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1312 next unless stat_exists $oldlist;
1313 my ($mtime) = (stat _)[9];
1314 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1317 runcmd_ordryrun_local aptget_aptget(), qw(update);
1320 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1321 next unless stat_exists $oldlist;
1322 my ($atime) = (stat _)[8];
1323 next if $atime == $oldatime;
1324 push @releasefiles, $oldlist;
1326 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1327 @releasefiles = @inreleasefiles if @inreleasefiles;
1328 if (!@releasefiles) {
1330 apt seemed to not to update dgit's cached Release files for $isuite.
1332 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1335 die "apt updated too many Release files (@releasefiles), erk"
1336 unless @releasefiles == 1;
1338 ($aptget_releasefile) = @releasefiles;
1341 sub canonicalise_suite_aptget {
1342 my ($proto,$data) = @_;
1345 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1347 foreach my $name (qw(Codename Suite)) {
1348 my $val = $release->{$name};
1350 printdebug "release file $name: $val\n";
1351 $val =~ m/^$suite_re$/o or fail
1352 "Release file ($aptget_releasefile) specifies intolerable $name";
1353 cfg_apply_map(\$val, 'suite rmap',
1354 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1361 sub archive_query_aptget {
1362 my ($proto,$data) = @_;
1365 ensuredir "$aptget_base/source";
1366 foreach my $old (<$aptget_base/source/*.dsc>) {
1367 unlink $old or die "$old: $!";
1370 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1371 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1372 # avoids apt-get source failing with ambiguous error code
1374 runcmd_ordryrun_local
1375 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1376 aptget_aptget(), qw(--download-only --only-source source), $package;
1378 my @dscs = <$aptget_base/source/*.dsc>;
1379 fail "apt-get source did not produce a .dsc" unless @dscs;
1380 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1382 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1385 my $uri = "file://". uri_escape $dscs[0];
1386 $uri =~ s{\%2f}{/}gi;
1387 return [ (getfield $pre_dsc, 'Version'), $uri ];
1390 sub file_in_archive_aptget () { return undef; }
1391 sub package_not_wholly_new_aptget () { return undef; }
1393 #---------- `dummyapicat' archive query method ----------
1395 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1396 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1398 sub dummycatapi_run_in_mirror ($@) {
1399 # runs $fn with FIA open onto rune
1400 my ($rune, $argl, $fn) = @_;
1402 my $mirror = access_cfg('mirror');
1403 $mirror =~ s#^file://#/# or die "$mirror ?";
1404 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1405 qw(x), $mirror, @$argl);
1406 debugcmd "-|", @cmd;
1407 open FIA, "-|", @cmd or die $!;
1409 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1413 sub file_in_archive_dummycatapi ($$$) {
1414 my ($proto,$data,$filename) = @_;
1416 dummycatapi_run_in_mirror '
1417 find -name "$1" -print0 |
1419 ', [$filename], sub {
1422 printdebug "| $_\n";
1423 m/^(\w+) (\S+)$/ or die "$_ ?";
1424 push @out, { sha256sum => $1, filename => $2 };
1430 sub package_not_wholly_new_dummycatapi {
1431 my ($proto,$data,$pkg) = @_;
1432 dummycatapi_run_in_mirror "
1433 find -name ${pkg}_*.dsc
1440 #---------- `madison' archive query method ----------
1442 sub archive_query_madison {
1443 return archive_query_prepend_mirror
1444 map { [ @$_[0..1] ] } madison_get_parse(@_);
1447 sub madison_get_parse {
1448 my ($proto,$data) = @_;
1449 die unless $proto eq 'madison';
1450 if (!length $data) {
1451 $data= access_cfg('madison-distro','RETURN-UNDEF');
1452 $data //= access_basedistro();
1454 $rmad{$proto,$data,$package} ||= cmdoutput
1455 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1456 my $rmad = $rmad{$proto,$data,$package};
1459 foreach my $l (split /\n/, $rmad) {
1460 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1461 \s*( [^ \t|]+ )\s* \|
1462 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1463 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1464 $1 eq $package or die "$rmad $package ?";
1471 $component = access_cfg('archive-query-default-component');
1473 $5 eq 'source' or die "$rmad ?";
1474 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1476 return sort { -version_compare($a->[0],$b->[0]); } @out;
1479 sub canonicalise_suite_madison {
1480 # madison canonicalises for us
1481 my @r = madison_get_parse(@_);
1483 "unable to canonicalise suite using package %s".
1484 " which does not appear to exist in suite %s;".
1485 " --existing-package may help",
1490 sub file_in_archive_madison { return undef; }
1491 sub package_not_wholly_new_madison { return undef; }
1493 #---------- `sshpsql' archive query method ----------
1496 my ($data,$runeinfo,$sql) = @_;
1497 if (!length $data) {
1498 $data= access_someuserhost('sshpsql').':'.
1499 access_cfg('sshpsql-dbname');
1501 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1502 my ($userhost,$dbname) = ($`,$'); #';
1504 my @cmd = (access_cfg_ssh, $userhost,
1505 access_runeinfo("ssh-psql $runeinfo").
1506 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1507 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1509 open P, "-|", @cmd or die $!;
1512 printdebug(">|$_|\n");
1515 $!=0; $?=0; close P or failedcmd @cmd;
1517 my $nrows = pop @rows;
1518 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1519 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1520 @rows = map { [ split /\|/, $_ ] } @rows;
1521 my $ncols = scalar @{ shift @rows };
1522 die if grep { scalar @$_ != $ncols } @rows;
1526 sub sql_injection_check {
1527 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1530 sub archive_query_sshpsql ($$) {
1531 my ($proto,$data) = @_;
1532 sql_injection_check $isuite, $package;
1533 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1534 SELECT source.version, component.name, files.filename, files.sha256sum
1536 JOIN src_associations ON source.id = src_associations.source
1537 JOIN suite ON suite.id = src_associations.suite
1538 JOIN dsc_files ON dsc_files.source = source.id
1539 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1540 JOIN component ON component.id = files_archive_map.component_id
1541 JOIN files ON files.id = dsc_files.file
1542 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1543 AND source.source='$package'
1544 AND files.filename LIKE '%.dsc';
1546 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1547 my $digester = Digest::SHA->new(256);
1549 my ($vsn,$component,$filename,$sha256sum) = @$_;
1550 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1552 return archive_query_prepend_mirror @rows;
1555 sub canonicalise_suite_sshpsql ($$) {
1556 my ($proto,$data) = @_;
1557 sql_injection_check $isuite;
1558 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1559 SELECT suite.codename
1560 FROM suite where suite_name='$isuite' or codename='$isuite';
1562 @rows = map { $_->[0] } @rows;
1563 fail "unknown suite $isuite" unless @rows;
1564 die "ambiguous $isuite: @rows ?" if @rows>1;
1568 sub file_in_archive_sshpsql ($$$) { return undef; }
1569 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1571 #---------- `dummycat' archive query method ----------
1573 sub canonicalise_suite_dummycat ($$) {
1574 my ($proto,$data) = @_;
1575 my $dpath = "$data/suite.$isuite";
1576 if (!open C, "<", $dpath) {
1577 $!==ENOENT or die "$dpath: $!";
1578 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1582 chomp or die "$dpath: $!";
1584 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1588 sub archive_query_dummycat ($$) {
1589 my ($proto,$data) = @_;
1590 canonicalise_suite();
1591 my $dpath = "$data/package.$csuite.$package";
1592 if (!open C, "<", $dpath) {
1593 $!==ENOENT or die "$dpath: $!";
1594 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1602 printdebug "dummycat query $csuite $package $dpath | $_\n";
1603 my @row = split /\s+/, $_;
1604 @row==2 or die "$dpath: $_ ?";
1607 C->error and die "$dpath: $!";
1609 return archive_query_prepend_mirror
1610 sort { -version_compare($a->[0],$b->[0]); } @rows;
1613 sub file_in_archive_dummycat () { return undef; }
1614 sub package_not_wholly_new_dummycat () { return undef; }
1616 #---------- tag format handling ----------
1618 sub access_cfg_tagformats () {
1619 split /\,/, access_cfg('dgit-tag-format');
1622 sub access_cfg_tagformats_can_splitbrain () {
1623 my %y = map { $_ => 1 } access_cfg_tagformats;
1624 foreach my $needtf (qw(new maint)) {
1625 next if $y{$needtf};
1631 sub need_tagformat ($$) {
1632 my ($fmt, $why) = @_;
1633 fail "need to use tag format $fmt ($why) but also need".
1634 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1635 " - no way to proceed"
1636 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1637 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1640 sub select_tagformat () {
1642 return if $tagformatfn && !$tagformat_want;
1643 die 'bug' if $tagformatfn && $tagformat_want;
1644 # ... $tagformat_want assigned after previous select_tagformat
1646 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1647 printdebug "select_tagformat supported @supported\n";
1649 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1650 printdebug "select_tagformat specified @$tagformat_want\n";
1652 my ($fmt,$why,$override) = @$tagformat_want;
1654 fail "target distro supports tag formats @supported".
1655 " but have to use $fmt ($why)"
1657 or grep { $_ eq $fmt } @supported;
1659 $tagformat_want = undef;
1661 $tagformatfn = ${*::}{"debiantag_$fmt"};
1663 fail "trying to use unknown tag format \`$fmt' ($why) !"
1664 unless $tagformatfn;
1667 #---------- archive query entrypoints and rest of program ----------
1669 sub canonicalise_suite () {
1670 return if defined $csuite;
1671 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1672 $csuite = archive_query('canonicalise_suite');
1673 if ($isuite ne $csuite) {
1674 progress "canonical suite name for $isuite is $csuite";
1676 progress "canonical suite name is $csuite";
1680 sub get_archive_dsc () {
1681 canonicalise_suite();
1682 my @vsns = archive_query('archive_query');
1683 foreach my $vinfo (@vsns) {
1684 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1685 $dscurl = $vsn_dscurl;
1686 $dscdata = url_get($dscurl);
1688 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1693 $digester->add($dscdata);
1694 my $got = $digester->hexdigest();
1696 fail "$dscurl has hash $got but".
1697 " archive told us to expect $digest";
1700 my $fmt = getfield $dsc, 'Format';
1701 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1702 "unsupported source format $fmt, sorry";
1704 $dsc_checked = !!$digester;
1705 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1709 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1712 sub check_for_git ();
1713 sub check_for_git () {
1715 my $how = access_cfg('git-check');
1716 if ($how eq 'ssh-cmd') {
1718 (access_cfg_ssh, access_gituserhost(),
1719 access_runeinfo("git-check $package").
1720 " set -e; cd ".access_cfg('git-path').";".
1721 " if test -d $package.git; then echo 1; else echo 0; fi");
1722 my $r= cmdoutput @cmd;
1723 if (defined $r and $r =~ m/^divert (\w+)$/) {
1725 my ($usedistro,) = access_distros();
1726 # NB that if we are pushing, $usedistro will be $distro/push
1727 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1728 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1729 progress "diverting to $divert (using config for $instead_distro)";
1730 return check_for_git();
1732 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1734 } elsif ($how eq 'url') {
1735 my $prefix = access_cfg('git-check-url','git-url');
1736 my $suffix = access_cfg('git-check-suffix','git-suffix',
1737 'RETURN-UNDEF') // '.git';
1738 my $url = "$prefix/$package$suffix";
1739 my @cmd = (@curl, qw(-sS -I), $url);
1740 my $result = cmdoutput @cmd;
1741 $result =~ s/^\S+ 200 .*\n\r?\n//;
1742 # curl -sS -I with https_proxy prints
1743 # HTTP/1.0 200 Connection established
1744 $result =~ m/^\S+ (404|200) /s or
1745 fail "unexpected results from git check query - ".
1746 Dumper($prefix, $result);
1748 if ($code eq '404') {
1750 } elsif ($code eq '200') {
1755 } elsif ($how eq 'true') {
1757 } elsif ($how eq 'false') {
1760 badcfg "unknown git-check \`$how'";
1764 sub create_remote_git_repo () {
1765 my $how = access_cfg('git-create');
1766 if ($how eq 'ssh-cmd') {
1768 (access_cfg_ssh, access_gituserhost(),
1769 access_runeinfo("git-create $package").
1770 "set -e; cd ".access_cfg('git-path').";".
1771 " cp -a _template $package.git");
1772 } elsif ($how eq 'true') {
1775 badcfg "unknown git-create \`$how'";
1779 our ($dsc_hash,$lastpush_mergeinput);
1780 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1784 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1785 $playground = fresh_playground 'dgit/unpack';
1788 sub mktree_in_ud_here () {
1789 playtree_setup $gitcfgs{local};
1792 sub git_write_tree () {
1793 my $tree = cmdoutput @git, qw(write-tree);
1794 $tree =~ m/^\w+$/ or die "$tree ?";
1798 sub git_add_write_tree () {
1799 runcmd @git, qw(add -Af .);
1800 return git_write_tree();
1803 sub remove_stray_gits ($) {
1805 my @gitscmd = qw(find -name .git -prune -print0);
1806 debugcmd "|",@gitscmd;
1807 open GITS, "-|", @gitscmd or die $!;
1812 print STDERR "$us: warning: removing from $what: ",
1813 (messagequote $_), "\n";
1817 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1820 sub mktree_in_ud_from_only_subdir ($;$) {
1821 my ($what,$raw) = @_;
1822 # changes into the subdir
1825 die "expected one subdir but found @dirs ?" unless @dirs==1;
1826 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1830 remove_stray_gits($what);
1831 mktree_in_ud_here();
1833 my ($format, $fopts) = get_source_format();
1834 if (madformat($format)) {
1839 my $tree=git_add_write_tree();
1840 return ($tree,$dir);
1843 our @files_csum_info_fields =
1844 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1845 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1846 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1848 sub dsc_files_info () {
1849 foreach my $csumi (@files_csum_info_fields) {
1850 my ($fname, $module, $method) = @$csumi;
1851 my $field = $dsc->{$fname};
1852 next unless defined $field;
1853 eval "use $module; 1;" or die $@;
1855 foreach (split /\n/, $field) {
1857 m/^(\w+) (\d+) (\S+)$/ or
1858 fail "could not parse .dsc $fname line \`$_'";
1859 my $digester = eval "$module"."->$method;" or die $@;
1864 Digester => $digester,
1869 fail "missing any supported Checksums-* or Files field in ".
1870 $dsc->get_option('name');
1874 map { $_->{Filename} } dsc_files_info();
1877 sub files_compare_inputs (@) {
1882 my $showinputs = sub {
1883 return join "; ", map { $_->get_option('name') } @$inputs;
1886 foreach my $in (@$inputs) {
1888 my $in_name = $in->get_option('name');
1890 printdebug "files_compare_inputs $in_name\n";
1892 foreach my $csumi (@files_csum_info_fields) {
1893 my ($fname) = @$csumi;
1894 printdebug "files_compare_inputs $in_name $fname\n";
1896 my $field = $in->{$fname};
1897 next unless defined $field;
1900 foreach (split /\n/, $field) {
1903 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1904 fail "could not parse $in_name $fname line \`$_'";
1906 printdebug "files_compare_inputs $in_name $fname $f\n";
1910 my $re = \ $record{$f}{$fname};
1912 $fchecked{$f}{$in_name} = 1;
1914 fail "hash or size of $f varies in $fname fields".
1915 " (between: ".$showinputs->().")";
1920 @files = sort @files;
1921 $expected_files //= \@files;
1922 "@$expected_files" eq "@files" or
1923 fail "file list in $in_name varies between hash fields!";
1926 fail "$in_name has no files list field(s)";
1928 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1931 grep { keys %$_ == @$inputs-1 } values %fchecked
1932 or fail "no file appears in all file lists".
1933 " (looked in: ".$showinputs->().")";
1936 sub is_orig_file_in_dsc ($$) {
1937 my ($f, $dsc_files_info) = @_;
1938 return 0 if @$dsc_files_info <= 1;
1939 # One file means no origs, and the filename doesn't have a "what
1940 # part of dsc" component. (Consider versions ending `.orig'.)
1941 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1945 # This function determines whether a .changes file is source-only from
1946 # the point of view of dak. Thus, it permits *_source.buildinfo
1949 # It does not, however, permit any other buildinfo files. After a
1950 # source-only upload, the buildds will try to upload files like
1951 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1952 # named like this in their (otherwise) source-only upload, the uploads
1953 # of the buildd can be rejected by dak. Fixing the resultant
1954 # situation can require manual intervention. So we block such
1955 # .buildinfo files when the user tells us to perform a source-only
1956 # upload (such as when using the push-source subcommand with the -C
1957 # option, which calls this function).
1959 # Note, though, that when dgit is told to prepare a source-only
1960 # upload, such as when subcommands like build-source and push-source
1961 # without -C are used, dgit has a more restrictive notion of
1962 # source-only .changes than dak: such uploads will never include
1963 # *_source.buildinfo files. This is because there is no use for such
1964 # files when using a tool like dgit to produce the source package, as
1965 # dgit ensures the source is identical to git HEAD.
1966 sub test_source_only_changes ($) {
1968 foreach my $l (split /\n/, getfield $changes, 'Files') {
1969 $l =~ m/\S+$/ or next;
1970 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1971 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1972 print "purportedly source-only changes polluted by $&\n";
1979 sub changes_update_origs_from_dsc ($$$$) {
1980 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1982 printdebug "checking origs needed ($upstreamvsn)...\n";
1983 $_ = getfield $changes, 'Files';
1984 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1985 fail "cannot find section/priority from .changes Files field";
1986 my $placementinfo = $1;
1988 printdebug "checking origs needed placement '$placementinfo'...\n";
1989 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1990 $l =~ m/\S+$/ or next;
1992 printdebug "origs $file | $l\n";
1993 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1994 printdebug "origs $file is_orig\n";
1995 my $have = archive_query('file_in_archive', $file);
1996 if (!defined $have) {
1998 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
2004 printdebug "origs $file \$#\$have=$#$have\n";
2005 foreach my $h (@$have) {
2008 foreach my $csumi (@files_csum_info_fields) {
2009 my ($fname, $module, $method, $archivefield) = @$csumi;
2010 next unless defined $h->{$archivefield};
2011 $_ = $dsc->{$fname};
2012 next unless defined;
2013 m/^(\w+) .* \Q$file\E$/m or
2014 fail ".dsc $fname missing entry for $file";
2015 if ($h->{$archivefield} eq $1) {
2019 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
2022 die "$file ".Dumper($h)." ?!" if $same && @differ;
2025 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
2028 printdebug "origs $file f.same=$found_same".
2029 " #f._differ=$#found_differ\n";
2030 if (@found_differ && !$found_same) {
2032 "archive contains $file with different checksum",
2035 # Now we edit the changes file to add or remove it
2036 foreach my $csumi (@files_csum_info_fields) {
2037 my ($fname, $module, $method, $archivefield) = @$csumi;
2038 next unless defined $changes->{$fname};
2040 # in archive, delete from .changes if it's there
2041 $changed{$file} = "removed" if
2042 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2043 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2044 # not in archive, but it's here in the .changes
2046 my $dsc_data = getfield $dsc, $fname;
2047 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2049 $extra =~ s/ \d+ /$&$placementinfo /
2050 or die "$fname $extra >$dsc_data< ?"
2051 if $fname eq 'Files';
2052 $changes->{$fname} .= "\n". $extra;
2053 $changed{$file} = "added";
2058 foreach my $file (keys %changed) {
2060 "edited .changes for archive .orig contents: %s %s",
2061 $changed{$file}, $file;
2063 my $chtmp = "$changesfile.tmp";
2064 $changes->save($chtmp);
2066 rename $chtmp,$changesfile or die "$changesfile $!";
2068 progress "[new .changes left in $changesfile]";
2071 progress "$changesfile already has appropriate .orig(s) (if any)";
2075 sub make_commit ($) {
2077 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2080 sub clogp_authline ($) {
2082 my $author = getfield $clogp, 'Maintainer';
2083 if ($author =~ m/^[^"\@]+\,/) {
2084 # single entry Maintainer field with unquoted comma
2085 $author = ($& =~ y/,//rd).$'; # strip the comma
2087 # git wants a single author; any remaining commas in $author
2088 # are by now preceded by @ (or "). It seems safer to punt on
2089 # "..." for now rather than attempting to dequote or something.
2090 $author =~ s#,.*##ms unless $author =~ m/"/;
2091 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2092 my $authline = "$author $date";
2093 $authline =~ m/$git_authline_re/o or
2094 fail "unexpected commit author line format \`$authline'".
2095 " (was generated from changelog Maintainer field)";
2096 return ($1,$2,$3) if wantarray;
2100 sub vendor_patches_distro ($$) {
2101 my ($checkdistro, $what) = @_;
2102 return unless defined $checkdistro;
2104 my $series = "debian/patches/\L$checkdistro\E.series";
2105 printdebug "checking for vendor-specific $series ($what)\n";
2107 if (!open SERIES, "<", $series) {
2108 die "$series $!" unless $!==ENOENT;
2117 Unfortunately, this source package uses a feature of dpkg-source where
2118 the same source package unpacks to different source code on different
2119 distros. dgit cannot safely operate on such packages on affected
2120 distros, because the meaning of source packages is not stable.
2122 Please ask the distro/maintainer to remove the distro-specific series
2123 files and use a different technique (if necessary, uploading actually
2124 different packages, if different distros are supposed to have
2128 fail "Found active distro-specific series file for".
2129 " $checkdistro ($what): $series, cannot continue";
2131 die "$series $!" if SERIES->error;
2135 sub check_for_vendor_patches () {
2136 # This dpkg-source feature doesn't seem to be documented anywhere!
2137 # But it can be found in the changelog (reformatted):
2139 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2140 # Author: Raphael Hertzog <hertzog@debian.org>
2141 # Date: Sun Oct 3 09:36:48 2010 +0200
2143 # dpkg-source: correctly create .pc/.quilt_series with alternate
2146 # If you have debian/patches/ubuntu.series and you were
2147 # unpacking the source package on ubuntu, quilt was still
2148 # directed to debian/patches/series instead of
2149 # debian/patches/ubuntu.series.
2151 # debian/changelog | 3 +++
2152 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2153 # 2 files changed, 6 insertions(+), 1 deletion(-)
2156 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2157 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2158 "Dpkg::Vendor \`current vendor'");
2159 vendor_patches_distro(access_basedistro(),
2160 "(base) distro being accessed");
2161 vendor_patches_distro(access_nomdistro(),
2162 "(nominal) distro being accessed");
2165 sub generate_commits_from_dsc () {
2166 # See big comment in fetch_from_archive, below.
2167 # See also README.dsc-import.
2169 changedir $playground;
2171 my @dfi = dsc_files_info();
2172 foreach my $fi (@dfi) {
2173 my $f = $fi->{Filename};
2174 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2175 my $upper_f = (bpd_abs()."/$f");
2177 printdebug "considering reusing $f: ";
2179 if (link_ltarget "$upper_f,fetch", $f) {
2180 printdebug "linked (using ...,fetch).\n";
2181 } elsif ((printdebug "($!) "),
2183 fail "accessing $buildproductsdir/$f,fetch: $!";
2184 } elsif (link_ltarget $upper_f, $f) {
2185 printdebug "linked.\n";
2186 } elsif ((printdebug "($!) "),
2188 fail "accessing $buildproductsdir/$f: $!";
2190 printdebug "absent.\n";
2194 complete_file_from_dsc('.', $fi, \$refetched)
2197 printdebug "considering saving $f: ";
2199 if (link $f, $upper_f) {
2200 printdebug "linked.\n";
2201 } elsif ((printdebug "($!) "),
2203 fail "saving $buildproductsdir/$f: $!";
2204 } elsif (!$refetched) {
2205 printdebug "no need.\n";
2206 } elsif (link $f, "$upper_f,fetch") {
2207 printdebug "linked (using ...,fetch).\n";
2208 } elsif ((printdebug "($!) "),
2210 fail "saving $buildproductsdir/$f,fetch: $!";
2212 printdebug "cannot.\n";
2216 # We unpack and record the orig tarballs first, so that we only
2217 # need disk space for one private copy of the unpacked source.
2218 # But we can't make them into commits until we have the metadata
2219 # from the debian/changelog, so we record the tree objects now and
2220 # make them into commits later.
2222 my $upstreamv = upstreamversion $dsc->{version};
2223 my $orig_f_base = srcfn $upstreamv, '';
2225 foreach my $fi (@dfi) {
2226 # We actually import, and record as a commit, every tarball
2227 # (unless there is only one file, in which case there seems
2230 my $f = $fi->{Filename};
2231 printdebug "import considering $f ";
2232 (printdebug "only one dfi\n"), next if @dfi == 1;
2233 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2234 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2238 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2240 printdebug "Y ", (join ' ', map { $_//"(none)" }
2241 $compr_ext, $orig_f_part
2244 my $input = new IO::File $f, '<' or die "$f $!";
2248 if (defined $compr_ext) {
2250 Dpkg::Compression::compression_guess_from_filename $f;
2251 fail "Dpkg::Compression cannot handle file $f in source package"
2252 if defined $compr_ext && !defined $cname;
2254 new Dpkg::Compression::Process compression => $cname;
2255 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2256 my $compr_fh = new IO::Handle;
2257 my $compr_pid = open $compr_fh, "-|" // die $!;
2259 open STDIN, "<&", $input or die $!;
2261 die "dgit (child): exec $compr_cmd[0]: $!\n";
2266 rmtree "_unpack-tar";
2267 mkdir "_unpack-tar" or die $!;
2268 my @tarcmd = qw(tar -x -f -
2269 --no-same-owner --no-same-permissions
2270 --no-acls --no-xattrs --no-selinux);
2271 my $tar_pid = fork // die $!;
2273 chdir "_unpack-tar" or die $!;
2274 open STDIN, "<&", $input or die $!;
2276 die "dgit (child): exec $tarcmd[0]: $!";
2278 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2279 !$? or failedcmd @tarcmd;
2282 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2284 # finally, we have the results in "tarball", but maybe
2285 # with the wrong permissions
2287 runcmd qw(chmod -R +rwX _unpack-tar);
2288 changedir "_unpack-tar";
2289 remove_stray_gits($f);
2290 mktree_in_ud_here();
2292 my ($tree) = git_add_write_tree();
2293 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2294 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2296 printdebug "one subtree $1\n";
2298 printdebug "multiple subtrees\n";
2301 rmtree "_unpack-tar";
2303 my $ent = [ $f, $tree ];
2305 Orig => !!$orig_f_part,
2306 Sort => (!$orig_f_part ? 2 :
2307 $orig_f_part =~ m/-/g ? 1 :
2315 # put any without "_" first (spec is not clear whether files
2316 # are always in the usual order). Tarballs without "_" are
2317 # the main orig or the debian tarball.
2318 $a->{Sort} <=> $b->{Sort} or
2322 my $any_orig = grep { $_->{Orig} } @tartrees;
2324 my $dscfn = "$package.dsc";
2326 my $treeimporthow = 'package';
2328 open D, ">", $dscfn or die "$dscfn: $!";
2329 print D $dscdata or die "$dscfn: $!";
2330 close D or die "$dscfn: $!";
2331 my @cmd = qw(dpkg-source);
2332 push @cmd, '--no-check' if $dsc_checked;
2333 if (madformat $dsc->{format}) {
2334 push @cmd, '--skip-patches';
2335 $treeimporthow = 'unpatched';
2337 push @cmd, qw(-x --), $dscfn;
2340 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2341 if (madformat $dsc->{format}) {
2342 check_for_vendor_patches();
2346 if (madformat $dsc->{format}) {
2347 my @pcmd = qw(dpkg-source --before-build .);
2348 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2350 $dappliedtree = git_add_write_tree();
2353 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2357 printdebug "import clog search...\n";
2358 parsechangelog_loop \@clogcmd, "package changelog", sub {
2359 my ($thisstanza, $desc) = @_;
2360 no warnings qw(exiting);
2362 $clogp //= $thisstanza;
2364 printdebug "import clog $thisstanza->{version} $desc...\n";
2366 last if !$any_orig; # we don't need $r1clogp
2368 # We look for the first (most recent) changelog entry whose
2369 # version number is lower than the upstream version of this
2370 # package. Then the last (least recent) previous changelog
2371 # entry is treated as the one which introduced this upstream
2372 # version and used for the synthetic commits for the upstream
2375 # One might think that a more sophisticated algorithm would be
2376 # necessary. But: we do not want to scan the whole changelog
2377 # file. Stopping when we see an earlier version, which
2378 # necessarily then is an earlier upstream version, is the only
2379 # realistic way to do that. Then, either the earliest
2380 # changelog entry we have seen so far is indeed the earliest
2381 # upload of this upstream version; or there are only changelog
2382 # entries relating to later upstream versions (which is not
2383 # possible unless the changelog and .dsc disagree about the
2384 # version). Then it remains to choose between the physically
2385 # last entry in the file, and the one with the lowest version
2386 # number. If these are not the same, we guess that the
2387 # versions were created in a non-monotonic order rather than
2388 # that the changelog entries have been misordered.
2390 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2392 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2393 $r1clogp = $thisstanza;
2395 printdebug "import clog $r1clogp->{version} becomes r1\n";
2398 $clogp or fail "package changelog has no entries!";
2400 my $authline = clogp_authline $clogp;
2401 my $changes = getfield $clogp, 'Changes';
2402 $changes =~ s/^\n//; # Changes: \n
2403 my $cversion = getfield $clogp, 'Version';
2406 $r1clogp //= $clogp; # maybe there's only one entry;
2407 my $r1authline = clogp_authline $r1clogp;
2408 # Strictly, r1authline might now be wrong if it's going to be
2409 # unused because !$any_orig. Whatever.
2411 printdebug "import tartrees authline $authline\n";
2412 printdebug "import tartrees r1authline $r1authline\n";
2414 foreach my $tt (@tartrees) {
2415 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2417 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2420 committer $r1authline
2424 [dgit import orig $tt->{F}]
2432 [dgit import tarball $package $cversion $tt->{F}]
2437 printdebug "import main commit\n";
2439 open C, ">../commit.tmp" or die $!;
2440 print C <<END or die $!;
2443 print C <<END or die $! foreach @tartrees;
2446 print C <<END or die $!;
2452 [dgit import $treeimporthow $package $cversion]
2456 my $rawimport_hash = make_commit qw(../commit.tmp);
2458 if (madformat $dsc->{format}) {
2459 printdebug "import apply patches...\n";
2461 # regularise the state of the working tree so that
2462 # the checkout of $rawimport_hash works nicely.
2463 my $dappliedcommit = make_commit_text(<<END);
2470 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2472 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2474 # We need the answers to be reproducible
2475 my @authline = clogp_authline($clogp);
2476 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2477 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2478 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2479 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2480 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2481 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2483 my $path = $ENV{PATH} or die;
2485 # we use ../../gbp-pq-output, which (given that we are in
2486 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2489 foreach my $use_absurd (qw(0 1)) {
2490 runcmd @git, qw(checkout -q unpa);
2491 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2492 local $ENV{PATH} = $path;
2495 progress "warning: $@";
2496 $path = "$absurdity:$path";
2497 progress "$us: trying slow absurd-git-apply...";
2498 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2503 die "forbid absurd git-apply\n" if $use_absurd
2504 && forceing [qw(import-gitapply-no-absurd)];
2505 die "only absurd git-apply!\n" if !$use_absurd
2506 && forceing [qw(import-gitapply-absurd)];
2508 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2509 local $ENV{PATH} = $path if $use_absurd;
2511 my @showcmd = (gbp_pq, qw(import));
2512 my @realcmd = shell_cmd
2513 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2514 debugcmd "+",@realcmd;
2515 if (system @realcmd) {
2516 die +(shellquote @showcmd).
2518 failedcmd_waitstatus()."\n";
2521 my $gapplied = git_rev_parse('HEAD');
2522 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2523 $gappliedtree eq $dappliedtree or
2525 gbp-pq import and dpkg-source disagree!
2526 gbp-pq import gave commit $gapplied
2527 gbp-pq import gave tree $gappliedtree
2528 dpkg-source --before-build gave tree $dappliedtree
2530 $rawimport_hash = $gapplied;
2535 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2540 progress "synthesised git commit from .dsc $cversion";
2542 my $rawimport_mergeinput = {
2543 Commit => $rawimport_hash,
2544 Info => "Import of source package",
2546 my @output = ($rawimport_mergeinput);
2548 if ($lastpush_mergeinput) {
2549 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2550 my $oversion = getfield $oldclogp, 'Version';
2552 version_compare($oversion, $cversion);
2554 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2555 { Message => <<END, ReverseParents => 1 });
2556 Record $package ($cversion) in archive suite $csuite
2558 } elsif ($vcmp > 0) {
2559 print STDERR <<END or die $!;
2561 Version actually in archive: $cversion (older)
2562 Last version pushed with dgit: $oversion (newer or same)
2565 @output = $lastpush_mergeinput;
2567 # Same version. Use what's in the server git branch,
2568 # discarding our own import. (This could happen if the
2569 # server automatically imports all packages into git.)
2570 @output = $lastpush_mergeinput;
2578 sub complete_file_from_dsc ($$;$) {
2579 our ($dstdir, $fi, $refetched) = @_;
2580 # Ensures that we have, in $dstdir, the file $fi, with the correct
2581 # contents. (Downloading it from alongside $dscurl if necessary.)
2582 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2583 # and will set $$refetched=1 if it did so (or tried to).
2585 my $f = $fi->{Filename};
2586 my $tf = "$dstdir/$f";
2590 my $checkhash = sub {
2591 open F, "<", "$tf" or die "$tf: $!";
2592 $fi->{Digester}->reset();
2593 $fi->{Digester}->addfile(*F);
2594 F->error and die $!;
2595 $got = $fi->{Digester}->hexdigest();
2596 return $got eq $fi->{Hash};
2599 if (stat_exists $tf) {
2600 if ($checkhash->()) {
2601 progress "using existing $f";
2605 fail "file $f has hash $got but .dsc".
2606 " demands hash $fi->{Hash} ".
2607 "(perhaps you should delete this file?)";
2609 progress "need to fetch correct version of $f";
2610 unlink $tf or die "$tf $!";
2613 printdebug "$tf does not exist, need to fetch\n";
2617 $furl =~ s{/[^/]+$}{};
2619 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2620 die "$f ?" if $f =~ m#/#;
2621 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2622 return 0 if !act_local();
2625 fail "file $f has hash $got but .dsc".
2626 " demands hash $fi->{Hash} ".
2627 "(got wrong file from archive!)";
2632 sub ensure_we_have_orig () {
2633 my @dfi = dsc_files_info();
2634 foreach my $fi (@dfi) {
2635 my $f = $fi->{Filename};
2636 next unless is_orig_file_in_dsc($f, \@dfi);
2637 complete_file_from_dsc($buildproductsdir, $fi)
2642 #---------- git fetch ----------
2644 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2645 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2647 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2648 # locally fetched refs because they have unhelpful names and clutter
2649 # up gitk etc. So we track whether we have "used up" head ref (ie,
2650 # whether we have made another local ref which refers to this object).
2652 # (If we deleted them unconditionally, then we might end up
2653 # re-fetching the same git objects each time dgit fetch was run.)
2655 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2656 # in git_fetch_us to fetch the refs in question, and possibly a call
2657 # to lrfetchref_used.
2659 our (%lrfetchrefs_f, %lrfetchrefs_d);
2660 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2662 sub lrfetchref_used ($) {
2663 my ($fullrefname) = @_;
2664 my $objid = $lrfetchrefs_f{$fullrefname};
2665 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2668 sub git_lrfetch_sane {
2669 my ($url, $supplementary, @specs) = @_;
2670 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2671 # at least as regards @specs. Also leave the results in
2672 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2673 # able to clean these up.
2675 # With $supplementary==1, @specs must not contain wildcards
2676 # and we add to our previous fetches (non-atomically).
2678 # This is rather miserable:
2679 # When git fetch --prune is passed a fetchspec ending with a *,
2680 # it does a plausible thing. If there is no * then:
2681 # - it matches subpaths too, even if the supplied refspec
2682 # starts refs, and behaves completely madly if the source
2683 # has refs/refs/something. (See, for example, Debian #NNNN.)
2684 # - if there is no matching remote ref, it bombs out the whole
2686 # We want to fetch a fixed ref, and we don't know in advance
2687 # if it exists, so this is not suitable.
2689 # Our workaround is to use git ls-remote. git ls-remote has its
2690 # own qairks. Notably, it has the absurd multi-tail-matching
2691 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2692 # refs/refs/foo etc.
2694 # Also, we want an idempotent snapshot, but we have to make two
2695 # calls to the remote: one to git ls-remote and to git fetch. The
2696 # solution is use git ls-remote to obtain a target state, and
2697 # git fetch to try to generate it. If we don't manage to generate
2698 # the target state, we try again.
2700 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2702 my $specre = join '|', map {
2705 my $wildcard = $x =~ s/\\\*$/.*/;
2706 die if $wildcard && $supplementary;
2709 printdebug "git_lrfetch_sane specre=$specre\n";
2710 my $wanted_rref = sub {
2712 return m/^(?:$specre)$/;
2715 my $fetch_iteration = 0;
2718 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2719 if (++$fetch_iteration > 10) {
2720 fail "too many iterations trying to get sane fetch!";
2723 my @look = map { "refs/$_" } @specs;
2724 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2728 open GITLS, "-|", @lcmd or die $!;
2730 printdebug "=> ", $_;
2731 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2732 my ($objid,$rrefname) = ($1,$2);
2733 if (!$wanted_rref->($rrefname)) {
2735 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2739 $wantr{$rrefname} = $objid;
2742 close GITLS or failedcmd @lcmd;
2744 # OK, now %want is exactly what we want for refs in @specs
2746 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2747 "+refs/$_:".lrfetchrefs."/$_";
2750 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2752 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2753 runcmd_ordryrun_local @fcmd if @fspecs;
2755 if (!$supplementary) {
2756 %lrfetchrefs_f = ();
2760 git_for_each_ref(lrfetchrefs, sub {
2761 my ($objid,$objtype,$lrefname,$reftail) = @_;
2762 $lrfetchrefs_f{$lrefname} = $objid;
2763 $objgot{$objid} = 1;
2766 if ($supplementary) {
2770 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2771 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2772 if (!exists $wantr{$rrefname}) {
2773 if ($wanted_rref->($rrefname)) {
2775 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2779 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2782 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2783 delete $lrfetchrefs_f{$lrefname};
2787 foreach my $rrefname (sort keys %wantr) {
2788 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2789 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2790 my $want = $wantr{$rrefname};
2791 next if $got eq $want;
2792 if (!defined $objgot{$want}) {
2793 fail <<END unless act_local();
2794 --dry-run specified but we actually wanted the results of git fetch,
2795 so this is not going to work. Try running dgit fetch first,
2796 or using --damp-run instead of --dry-run.
2799 warning: git ls-remote suggests we want $lrefname
2800 warning: and it should refer to $want
2801 warning: but git fetch didn't fetch that object to any relevant ref.
2802 warning: This may be due to a race with someone updating the server.
2803 warning: Will try again...
2805 next FETCH_ITERATION;
2808 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2810 runcmd_ordryrun_local @git, qw(update-ref -m),
2811 "dgit fetch git fetch fixup", $lrefname, $want;
2812 $lrfetchrefs_f{$lrefname} = $want;
2817 if (defined $csuite) {
2818 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2819 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2820 my ($objid,$objtype,$lrefname,$reftail) = @_;
2821 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2822 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2826 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2827 Dumper(\%lrfetchrefs_f);
2830 sub git_fetch_us () {
2831 # Want to fetch only what we are going to use, unless
2832 # deliberately-not-ff, in which case we must fetch everything.
2834 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2836 (quiltmode_splitbrain
2837 ? (map { $_->('*',access_nomdistro) }
2838 \&debiantag_new, \&debiantag_maintview)
2839 : debiantags('*',access_nomdistro));
2840 push @specs, server_branch($csuite);
2841 push @specs, $rewritemap;
2842 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2844 my $url = access_giturl();
2845 git_lrfetch_sane $url, 0, @specs;
2848 my @tagpats = debiantags('*',access_nomdistro);
2850 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2851 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2852 printdebug "currently $fullrefname=$objid\n";
2853 $here{$fullrefname} = $objid;
2855 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2856 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2857 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2858 printdebug "offered $lref=$objid\n";
2859 if (!defined $here{$lref}) {
2860 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2861 runcmd_ordryrun_local @upd;
2862 lrfetchref_used $fullrefname;
2863 } elsif ($here{$lref} eq $objid) {
2864 lrfetchref_used $fullrefname;
2867 "Not updating $lref from $here{$lref} to $objid.\n";
2872 #---------- dsc and archive handling ----------
2874 sub mergeinfo_getclogp ($) {
2875 # Ensures thit $mi->{Clogp} exists and returns it
2877 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2880 sub mergeinfo_version ($) {
2881 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2884 sub fetch_from_archive_record_1 ($) {
2886 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2887 cmdoutput @git, qw(log -n2), $hash;
2888 # ... gives git a chance to complain if our commit is malformed
2891 sub fetch_from_archive_record_2 ($) {
2893 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2897 dryrun_report @upd_cmd;
2901 sub parse_dsc_field_def_dsc_distro () {
2902 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2903 dgit.default.distro);
2906 sub parse_dsc_field ($$) {
2907 my ($dsc, $what) = @_;
2909 foreach my $field (@ourdscfield) {
2910 $f = $dsc->{$field};
2915 progress "$what: NO git hash";
2916 parse_dsc_field_def_dsc_distro();
2917 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2918 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2919 progress "$what: specified git info ($dsc_distro)";
2920 $dsc_hint_tag = [ $dsc_hint_tag ];
2921 } elsif ($f =~ m/^\w+\s*$/) {
2923 parse_dsc_field_def_dsc_distro();
2924 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2926 progress "$what: specified git hash";
2928 fail "$what: invalid Dgit info";
2932 sub resolve_dsc_field_commit ($$) {
2933 my ($already_distro, $already_mapref) = @_;
2935 return unless defined $dsc_hash;
2938 defined $already_mapref &&
2939 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2940 ? $already_mapref : undef;
2944 my ($what, @fetch) = @_;
2946 local $idistro = $dsc_distro;
2947 my $lrf = lrfetchrefs;
2949 if (!$chase_dsc_distro) {
2951 "not chasing .dsc distro $dsc_distro: not fetching $what";
2956 ".dsc names distro $dsc_distro: fetching $what";
2958 my $url = access_giturl();
2959 if (!defined $url) {
2960 defined $dsc_hint_url or fail <<END;
2961 .dsc Dgit metadata is in context of distro $dsc_distro
2962 for which we have no configured url and .dsc provides no hint
2965 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2966 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2967 parse_cfg_bool "dsc-url-proto-ok", 'false',
2968 cfg("dgit.dsc-url-proto-ok.$proto",
2969 "dgit.default.dsc-url-proto-ok")
2971 .dsc Dgit metadata is in context of distro $dsc_distro
2972 for which we have no configured url;
2973 .dsc provides hinted url with protocol $proto which is unsafe.
2974 (can be overridden by config - consult documentation)
2976 $url = $dsc_hint_url;
2979 git_lrfetch_sane $url, 1, @fetch;
2984 my $rewrite_enable = do {
2985 local $idistro = $dsc_distro;
2986 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2989 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2990 if (!defined $mapref) {
2991 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2992 $mapref = $lrf.'/'.$rewritemap;
2994 my $rewritemapdata = git_cat_file $mapref.':map';
2995 if (defined $rewritemapdata
2996 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2998 "server's git history rewrite map contains a relevant entry!";
3001 if (defined $dsc_hash) {
3002 progress "using rewritten git hash in place of .dsc value";
3004 progress "server data says .dsc hash is to be disregarded";
3009 if (!defined git_cat_file $dsc_hash) {
3010 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3011 my $lrf = $do_fetch->("additional commits", @tags) &&
3012 defined git_cat_file $dsc_hash
3014 .dsc Dgit metadata requires commit $dsc_hash
3015 but we could not obtain that object anywhere.
3017 foreach my $t (@tags) {
3018 my $fullrefname = $lrf.'/'.$t;
3019 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3020 next unless $lrfetchrefs_f{$fullrefname};
3021 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3022 lrfetchref_used $fullrefname;
3027 sub fetch_from_archive () {
3028 ensure_setup_existing_tree();
3030 # Ensures that lrref() is what is actually in the archive, one way
3031 # or another, according to us - ie this client's
3032 # appropritaely-updated archive view. Also returns the commit id.
3033 # If there is nothing in the archive, leaves lrref alone and
3034 # returns undef. git_fetch_us must have already been called.
3038 parse_dsc_field($dsc, 'last upload to archive');
3039 resolve_dsc_field_commit access_basedistro,
3040 lrfetchrefs."/".$rewritemap
3042 progress "no version available from the archive";
3045 # If the archive's .dsc has a Dgit field, there are three
3046 # relevant git commitids we need to choose between and/or merge
3048 # 1. $dsc_hash: the Dgit field from the archive
3049 # 2. $lastpush_hash: the suite branch on the dgit git server
3050 # 3. $lastfetch_hash: our local tracking brach for the suite
3052 # These may all be distinct and need not be in any fast forward
3055 # If the dsc was pushed to this suite, then the server suite
3056 # branch will have been updated; but it might have been pushed to
3057 # a different suite and copied by the archive. Conversely a more
3058 # recent version may have been pushed with dgit but not appeared
3059 # in the archive (yet).
3061 # $lastfetch_hash may be awkward because archive imports
3062 # (particularly, imports of Dgit-less .dscs) are performed only as
3063 # needed on individual clients, so different clients may perform a
3064 # different subset of them - and these imports are only made
3065 # public during push. So $lastfetch_hash may represent a set of
3066 # imports different to a subsequent upload by a different dgit
3069 # Our approach is as follows:
3071 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3072 # descendant of $dsc_hash, then it was pushed by a dgit user who
3073 # had based their work on $dsc_hash, so we should prefer it.
3074 # Otherwise, $dsc_hash was installed into this suite in the
3075 # archive other than by a dgit push, and (necessarily) after the
3076 # last dgit push into that suite (since a dgit push would have
3077 # been descended from the dgit server git branch); thus, in that
3078 # case, we prefer the archive's version (and produce a
3079 # pseudo-merge to overwrite the dgit server git branch).
3081 # (If there is no Dgit field in the archive's .dsc then
3082 # generate_commit_from_dsc uses the version numbers to decide
3083 # whether the suite branch or the archive is newer. If the suite
3084 # branch is newer it ignores the archive's .dsc; otherwise it
3085 # generates an import of the .dsc, and produces a pseudo-merge to
3086 # overwrite the suite branch with the archive contents.)
3088 # The outcome of that part of the algorithm is the `public view',
3089 # and is same for all dgit clients: it does not depend on any
3090 # unpublished history in the local tracking branch.
3092 # As between the public view and the local tracking branch: The
3093 # local tracking branch is only updated by dgit fetch, and
3094 # whenever dgit fetch runs it includes the public view in the
3095 # local tracking branch. Therefore if the public view is not
3096 # descended from the local tracking branch, the local tracking
3097 # branch must contain history which was imported from the archive
3098 # but never pushed; and, its tip is now out of date. So, we make
3099 # a pseudo-merge to overwrite the old imports and stitch the old
3102 # Finally: we do not necessarily reify the public view (as
3103 # described above). This is so that we do not end up stacking two
3104 # pseudo-merges. So what we actually do is figure out the inputs
3105 # to any public view pseudo-merge and put them in @mergeinputs.
3108 # $mergeinputs[]{Commit}
3109 # $mergeinputs[]{Info}
3110 # $mergeinputs[0] is the one whose tree we use
3111 # @mergeinputs is in the order we use in the actual commit)
3114 # $mergeinputs[]{Message} is a commit message to use
3115 # $mergeinputs[]{ReverseParents} if def specifies that parent
3116 # list should be in opposite order
3117 # Such an entry has no Commit or Info. It applies only when found
3118 # in the last entry. (This ugliness is to support making
3119 # identical imports to previous dgit versions.)
3121 my $lastpush_hash = git_get_ref(lrfetchref());
3122 printdebug "previous reference hash=$lastpush_hash\n";
3123 $lastpush_mergeinput = $lastpush_hash && {
3124 Commit => $lastpush_hash,
3125 Info => "dgit suite branch on dgit git server",
3128 my $lastfetch_hash = git_get_ref(lrref());
3129 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3130 my $lastfetch_mergeinput = $lastfetch_hash && {
3131 Commit => $lastfetch_hash,
3132 Info => "dgit client's archive history view",
3135 my $dsc_mergeinput = $dsc_hash && {
3136 Commit => $dsc_hash,
3137 Info => "Dgit field in .dsc from archive",
3141 my $del_lrfetchrefs = sub {
3144 printdebug "del_lrfetchrefs...\n";
3145 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3146 my $objid = $lrfetchrefs_d{$fullrefname};
3147 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3149 $gur ||= new IO::Handle;
3150 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3152 printf $gur "delete %s %s\n", $fullrefname, $objid;
3155 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3159 if (defined $dsc_hash) {
3160 ensure_we_have_orig();
3161 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3162 @mergeinputs = $dsc_mergeinput
3163 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3164 print STDERR <<END or die $!;
3166 Git commit in archive is behind the last version allegedly pushed/uploaded.
3167 Commit referred to by archive: $dsc_hash
3168 Last version pushed with dgit: $lastpush_hash
3171 @mergeinputs = ($lastpush_mergeinput);
3173 # Archive has .dsc which is not a descendant of the last dgit
3174 # push. This can happen if the archive moves .dscs about.
3175 # Just follow its lead.
3176 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3177 progress "archive .dsc names newer git commit";
3178 @mergeinputs = ($dsc_mergeinput);
3180 progress "archive .dsc names other git commit, fixing up";
3181 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3185 @mergeinputs = generate_commits_from_dsc();
3186 # We have just done an import. Now, our import algorithm might
3187 # have been improved. But even so we do not want to generate
3188 # a new different import of the same package. So if the
3189 # version numbers are the same, just use our existing version.
3190 # If the version numbers are different, the archive has changed
3191 # (perhaps, rewound).
3192 if ($lastfetch_mergeinput &&
3193 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3194 (mergeinfo_version $mergeinputs[0]) )) {
3195 @mergeinputs = ($lastfetch_mergeinput);
3197 } elsif ($lastpush_hash) {
3198 # only in git, not in the archive yet
3199 @mergeinputs = ($lastpush_mergeinput);
3200 print STDERR <<END or die $!;
3202 Package not found in the archive, but has allegedly been pushed using dgit.
3206 printdebug "nothing found!\n";
3207 if (defined $skew_warning_vsn) {
3208 print STDERR <<END or die $!;
3210 Warning: relevant archive skew detected.
3211 Archive allegedly contains $skew_warning_vsn
3212 But we were not able to obtain any version from the archive or git.
3216 unshift @end, $del_lrfetchrefs;
3220 if ($lastfetch_hash &&
3222 my $h = $_->{Commit};
3223 $h and is_fast_fwd($lastfetch_hash, $h);
3224 # If true, one of the existing parents of this commit
3225 # is a descendant of the $lastfetch_hash, so we'll
3226 # be ff from that automatically.
3230 push @mergeinputs, $lastfetch_mergeinput;
3233 printdebug "fetch mergeinfos:\n";
3234 foreach my $mi (@mergeinputs) {
3236 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3238 printdebug sprintf " ReverseParents=%d Message=%s",
3239 $mi->{ReverseParents}, $mi->{Message};
3243 my $compat_info= pop @mergeinputs
3244 if $mergeinputs[$#mergeinputs]{Message};
3246 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3249 if (@mergeinputs > 1) {
3251 my $tree_commit = $mergeinputs[0]{Commit};
3253 my $tree = get_tree_of_commit $tree_commit;;
3255 # We use the changelog author of the package in question the
3256 # author of this pseudo-merge. This is (roughly) correct if
3257 # this commit is simply representing aa non-dgit upload.
3258 # (Roughly because it does not record sponsorship - but we
3259 # don't have sponsorship info because that's in the .changes,
3260 # which isn't in the archivw.)
3262 # But, it might be that we are representing archive history
3263 # updates (including in-archive copies). These are not really
3264 # the responsibility of the person who created the .dsc, but
3265 # there is no-one whose name we should better use. (The
3266 # author of the .dsc-named commit is clearly worse.)
3268 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3269 my $author = clogp_authline $useclogp;
3270 my $cversion = getfield $useclogp, 'Version';
3272 my $mcf = dgit_privdir()."/mergecommit";
3273 open MC, ">", $mcf or die "$mcf $!";
3274 print MC <<END or die $!;
3278 my @parents = grep { $_->{Commit} } @mergeinputs;
3279 @parents = reverse @parents if $compat_info->{ReverseParents};
3280 print MC <<END or die $! foreach @parents;
3284 print MC <<END or die $!;
3290 if (defined $compat_info->{Message}) {
3291 print MC $compat_info->{Message} or die $!;
3293 print MC <<END or die $!;
3294 Record $package ($cversion) in archive suite $csuite
3298 my $message_add_info = sub {
3300 my $mversion = mergeinfo_version $mi;
3301 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3305 $message_add_info->($mergeinputs[0]);
3306 print MC <<END or die $!;
3307 should be treated as descended from
3309 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3313 $hash = make_commit $mcf;
3315 $hash = $mergeinputs[0]{Commit};
3317 printdebug "fetch hash=$hash\n";
3320 my ($lasth, $what) = @_;
3321 return unless $lasth;
3322 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3325 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3327 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3329 fetch_from_archive_record_1($hash);
3331 if (defined $skew_warning_vsn) {
3332 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3333 my $gotclogp = commit_getclogp($hash);
3334 my $got_vsn = getfield $gotclogp, 'Version';
3335 printdebug "SKEW CHECK GOT $got_vsn\n";
3336 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3337 print STDERR <<END or die $!;
3339 Warning: archive skew detected. Using the available version:
3340 Archive allegedly contains $skew_warning_vsn
3341 We were able to obtain only $got_vsn
3347 if ($lastfetch_hash ne $hash) {
3348 fetch_from_archive_record_2($hash);
3351 lrfetchref_used lrfetchref();
3353 check_gitattrs($hash, "fetched source tree");
3355 unshift @end, $del_lrfetchrefs;
3359 sub set_local_git_config ($$) {
3361 runcmd @git, qw(config), $k, $v;
3364 sub setup_mergechangelogs (;$) {
3366 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3368 my $driver = 'dpkg-mergechangelogs';
3369 my $cb = "merge.$driver";
3370 confess unless defined $maindir;
3371 my $attrs = "$maindir_gitcommon/info/attributes";
3372 ensuredir "$maindir_gitcommon/info";
3374 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3375 if (!open ATTRS, "<", $attrs) {
3376 $!==ENOENT or die "$attrs: $!";
3380 next if m{^debian/changelog\s};
3381 print NATTRS $_, "\n" or die $!;
3383 ATTRS->error and die $!;
3386 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3389 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3390 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3392 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3395 sub setup_useremail (;$) {
3397 return unless $always || access_cfg_bool(1, 'setup-useremail');
3400 my ($k, $envvar) = @_;
3401 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3402 return unless defined $v;
3403 set_local_git_config "user.$k", $v;
3406 $setup->('email', 'DEBEMAIL');
3407 $setup->('name', 'DEBFULLNAME');
3410 sub ensure_setup_existing_tree () {
3411 my $k = "remote.$remotename.skipdefaultupdate";
3412 my $c = git_get_config $k;
3413 return if defined $c;
3414 set_local_git_config $k, 'true';
3417 sub open_main_gitattrs () {
3418 confess 'internal error no maindir' unless defined $maindir;
3419 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3421 or die "open $maindir_gitcommon/info/attributes: $!";
3425 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3427 sub is_gitattrs_setup () {
3430 # 1: gitattributes set up and should be left alone
3432 # 0: there is a dgit-defuse-attrs but it needs fixing
3433 # undef: there is none
3434 my $gai = open_main_gitattrs();
3435 return 0 unless $gai;
3437 next unless m{$gitattrs_ourmacro_re};
3438 return 1 if m{\s-working-tree-encoding\s};
3439 printdebug "is_gitattrs_setup: found old macro\n";
3442 $gai->error and die $!;
3443 printdebug "is_gitattrs_setup: found nothing\n";
3447 sub setup_gitattrs (;$) {
3449 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3451 my $already = is_gitattrs_setup();
3454 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3455 not doing further gitattributes setup
3459 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3460 my $af = "$maindir_gitcommon/info/attributes";
3461 ensuredir "$maindir_gitcommon/info";
3463 open GAO, "> $af.new" or die $!;
3464 print GAO <<END or die $! unless defined $already;
3467 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3469 my $gai = open_main_gitattrs();
3472 if (m{$gitattrs_ourmacro_re}) {
3473 die unless defined $already;
3477 print GAO $_, "\n" or die $!;
3479 $gai->error and die $!;
3481 close GAO or die $!;
3482 rename "$af.new", "$af" or die "install $af: $!";
3485 sub setup_new_tree () {
3486 setup_mergechangelogs();
3491 sub check_gitattrs ($$) {
3492 my ($treeish, $what) = @_;
3494 return if is_gitattrs_setup;
3497 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3499 my $gafl = new IO::File;
3500 open $gafl, "-|", @cmd or die $!;
3503 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3505 next unless m{(?:^|/)\.gitattributes$};
3507 # oh dear, found one
3509 dgit: warning: $what contains .gitattributes
3510 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3515 # tree contains no .gitattributes files
3516 $?=0; $!=0; close $gafl or failedcmd @cmd;
3520 sub multisuite_suite_child ($$$) {
3521 my ($tsuite, $mergeinputs, $fn) = @_;
3522 # in child, sets things up, calls $fn->(), and returns undef
3523 # in parent, returns canonical suite name for $tsuite
3524 my $canonsuitefh = IO::File::new_tmpfile;
3525 my $pid = fork // die $!;
3529 $us .= " [$isuite]";
3530 $debugprefix .= " ";
3531 progress "fetching $tsuite...";
3532 canonicalise_suite();
3533 print $canonsuitefh $csuite, "\n" or die $!;
3534 close $canonsuitefh or die $!;
3538 waitpid $pid,0 == $pid or die $!;
3539 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3540 seek $canonsuitefh,0,0 or die $!;
3541 local $csuite = <$canonsuitefh>;
3542 die $! unless defined $csuite && chomp $csuite;
3544 printdebug "multisuite $tsuite missing\n";
3547 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3548 push @$mergeinputs, {
3555 sub fork_for_multisuite ($) {
3556 my ($before_fetch_merge) = @_;
3557 # if nothing unusual, just returns ''
3560 # returns 0 to caller in child, to do first of the specified suites
3561 # in child, $csuite is not yet set
3563 # returns 1 to caller in parent, to finish up anything needed after
3564 # in parent, $csuite is set to canonicalised portmanteau
3566 my $org_isuite = $isuite;
3567 my @suites = split /\,/, $isuite;
3568 return '' unless @suites > 1;
3569 printdebug "fork_for_multisuite: @suites\n";
3573 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3575 return 0 unless defined $cbasesuite;
3577 fail "package $package missing in (base suite) $cbasesuite"
3578 unless @mergeinputs;
3580 my @csuites = ($cbasesuite);
3582 $before_fetch_merge->();
3584 foreach my $tsuite (@suites[1..$#suites]) {
3585 $tsuite =~ s/^-/$cbasesuite-/;
3586 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3593 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3594 push @csuites, $csubsuite;
3597 foreach my $mi (@mergeinputs) {
3598 my $ref = git_get_ref $mi->{Ref};
3599 die "$mi->{Ref} ?" unless length $ref;
3600 $mi->{Commit} = $ref;
3603 $csuite = join ",", @csuites;
3605 my $previous = git_get_ref lrref;
3607 unshift @mergeinputs, {
3608 Commit => $previous,
3609 Info => "local combined tracking branch",
3611 "archive seems to have rewound: local tracking branch is ahead!",
3615 foreach my $ix (0..$#mergeinputs) {
3616 $mergeinputs[$ix]{Index} = $ix;
3619 @mergeinputs = sort {
3620 -version_compare(mergeinfo_version $a,
3621 mergeinfo_version $b) # highest version first
3623 $a->{Index} <=> $b->{Index}; # earliest in spec first
3629 foreach my $mi (@mergeinputs) {
3630 printdebug "multisuite merge check $mi->{Info}\n";
3631 foreach my $previous (@needed) {
3632 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3633 printdebug "multisuite merge un-needed $previous->{Info}\n";
3637 printdebug "multisuite merge this-needed\n";
3638 $mi->{Character} = '+';
3641 $needed[0]{Character} = '*';
3643 my $output = $needed[0]{Commit};
3646 printdebug "multisuite merge nontrivial\n";
3647 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3649 my $commit = "tree $tree\n";
3650 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3651 "Input branches:\n";
3653 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3654 printdebug "multisuite merge include $mi->{Info}\n";
3655 $mi->{Character} //= ' ';
3656 $commit .= "parent $mi->{Commit}\n";
3657 $msg .= sprintf " %s %-25s %s\n",
3659 (mergeinfo_version $mi),
3662 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3664 " * marks the highest version branch, which choose to use\n".
3665 " + marks each branch which was not already an ancestor\n\n".
3666 "[dgit multi-suite $csuite]\n";
3668 "author $authline\n".
3669 "committer $authline\n\n";
3670 $output = make_commit_text $commit.$msg;
3671 printdebug "multisuite merge generated $output\n";
3674 fetch_from_archive_record_1($output);
3675 fetch_from_archive_record_2($output);
3677 progress "calculated combined tracking suite $csuite";
3682 sub clone_set_head () {
3683 open H, "> .git/HEAD" or die $!;
3684 print H "ref: ".lref()."\n" or die $!;
3687 sub clone_finish ($) {
3689 runcmd @git, qw(reset --hard), lrref();
3690 runcmd qw(bash -ec), <<'END';
3692 git ls-tree -r --name-only -z HEAD | \
3693 xargs -0r touch -h -r . --
3695 printdone "ready for work in $dstdir";
3699 # in multisuite, returns twice!
3700 # once in parent after first suite fetched,
3701 # and then again in child after everything is finished
3703 badusage "dry run makes no sense with clone" unless act_local();
3705 my $multi_fetched = fork_for_multisuite(sub {
3706 printdebug "multi clone before fetch merge\n";
3710 if ($multi_fetched) {
3711 printdebug "multi clone after fetch merge\n";
3713 clone_finish($dstdir);
3716 printdebug "clone main body\n";
3718 canonicalise_suite();
3719 my $hasgit = check_for_git();
3720 mkdir $dstdir or fail "create \`$dstdir': $!";
3722 runcmd @git, qw(init -q);
3726 my $giturl = access_giturl(1);
3727 if (defined $giturl) {
3728 runcmd @git, qw(remote add), 'origin', $giturl;
3731 progress "fetching existing git history";
3733 runcmd_ordryrun_local @git, qw(fetch origin);
3735 progress "starting new git history";
3737 fetch_from_archive() or no_such_package;
3738 my $vcsgiturl = $dsc->{'Vcs-Git'};
3739 if (length $vcsgiturl) {
3740 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3741 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3743 clone_finish($dstdir);
3747 canonicalise_suite();
3748 if (check_for_git()) {
3751 fetch_from_archive() or no_such_package();
3753 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3754 if (length $vcsgiturl and
3755 (grep { $csuite eq $_ }
3757 cfg 'dgit.vcs-git.suites')) {
3758 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3759 if (defined $current && $current ne $vcsgiturl) {
3761 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3762 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3766 printdone "fetched into ".lrref();
3770 my $multi_fetched = fork_for_multisuite(sub { });
3771 fetch_one() unless $multi_fetched; # parent
3772 finish 0 if $multi_fetched eq '0'; # child
3777 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3779 printdone "fetched to ".lrref()." and merged into HEAD";
3782 sub check_not_dirty () {
3783 foreach my $f (qw(local-options local-patch-header)) {
3784 if (stat_exists "debian/source/$f") {
3785 fail "git tree contains debian/source/$f";
3789 return if $includedirty;
3791 git_check_unmodified();
3794 sub commit_admin ($) {
3797 runcmd_ordryrun_local @git, qw(commit -m), $m;
3800 sub quiltify_nofix_bail ($$) {
3801 my ($headinfo, $xinfo) = @_;
3802 if ($quilt_mode eq 'nofix') {
3803 fail "quilt fixup required but quilt mode is \`nofix'\n".
3804 "HEAD commit".$headinfo." differs from tree implied by ".
3805 " debian/patches".$xinfo;
3809 sub commit_quilty_patch () {
3810 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3812 foreach my $l (split /\n/, $output) {
3813 next unless $l =~ m/\S/;
3814 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3818 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3820 progress "nothing quilty to commit, ok.";
3823 quiltify_nofix_bail "", " (wanted to commit patch update)";
3824 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3825 runcmd_ordryrun_local @git, qw(add -f), @adds;
3827 Commit Debian 3.0 (quilt) metadata
3829 [dgit ($our_version) quilt-fixup]
3833 sub get_source_format () {
3835 if (open F, "debian/source/options") {
3839 s/\s+$//; # ignore missing final newline
3841 my ($k, $v) = ($`, $'); #');
3842 $v =~ s/^"(.*)"$/$1/;
3848 F->error and die $!;
3851 die $! unless $!==&ENOENT;
3854 if (!open F, "debian/source/format") {
3855 die $! unless $!==&ENOENT;
3859 F->error and die $!;
3861 return ($_, \%options);
3864 sub madformat_wantfixup ($) {
3866 return 0 unless $format eq '3.0 (quilt)';
3867 our $quilt_mode_warned;
3868 if ($quilt_mode eq 'nocheck') {
3869 progress "Not doing any fixup of \`$format' due to".
3870 " ----no-quilt-fixup or --quilt=nocheck"
3871 unless $quilt_mode_warned++;
3874 progress "Format \`$format', need to check/update patch stack"
3875 unless $quilt_mode_warned++;
3879 sub maybe_split_brain_save ($$$) {
3880 my ($headref, $dgitview, $msg) = @_;
3881 # => message fragment "$saved" describing disposition of $dgitview
3882 my $save = $internal_object_save{'dgit-view'};
3883 return "commit id $dgitview" unless defined $save;
3884 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3886 "dgit --dgit-view-save $msg HEAD=$headref",
3889 return "and left in $save";
3892 # An "infopair" is a tuple [ $thing, $what ]
3893 # (often $thing is a commit hash; $what is a description)
3895 sub infopair_cond_equal ($$) {
3897 $x->[0] eq $y->[0] or fail <<END;
3898 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3902 sub infopair_lrf_tag_lookup ($$) {
3903 my ($tagnames, $what) = @_;
3904 # $tagname may be an array ref
3905 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3906 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3907 foreach my $tagname (@tagnames) {
3908 my $lrefname = lrfetchrefs."/tags/$tagname";
3909 my $tagobj = $lrfetchrefs_f{$lrefname};
3910 next unless defined $tagobj;
3911 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3912 return [ git_rev_parse($tagobj), $what ];
3914 fail @tagnames==1 ? <<END : <<END;
3915 Wanted tag $what (@tagnames) on dgit server, but not found
3917 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3921 sub infopair_cond_ff ($$) {
3922 my ($anc,$desc) = @_;
3923 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3924 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3928 sub pseudomerge_version_check ($$) {
3929 my ($clogp, $archive_hash) = @_;
3931 my $arch_clogp = commit_getclogp $archive_hash;
3932 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3933 'version currently in archive' ];
3934 if (defined $overwrite_version) {
3935 if (length $overwrite_version) {
3936 infopair_cond_equal([ $overwrite_version,
3937 '--overwrite= version' ],
3940 my $v = $i_arch_v->[0];
3941 progress "Checking package changelog for archive version $v ...";
3944 my @xa = ("-f$v", "-t$v");
3945 my $vclogp = parsechangelog @xa;
3948 [ (getfield $vclogp, $fn),
3949 "$fn field from dpkg-parsechangelog @xa" ];
3951 my $cv = $gf->('Version');
3952 infopair_cond_equal($i_arch_v, $cv);
3953 $cd = $gf->('Distribution');
3956 $@ =~ s/^dgit: //gm;
3958 "Perhaps debian/changelog does not mention $v ?";
3960 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3961 $cd->[1] is $cd->[0]
3962 Your tree seems to based on earlier (not uploaded) $v.
3967 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3971 sub pseudomerge_make_commit ($$$$ $$) {
3972 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3973 $msg_cmd, $msg_msg) = @_;
3974 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3976 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3977 my $authline = clogp_authline $clogp;
3981 !defined $overwrite_version ? ""
3982 : !length $overwrite_version ? " --overwrite"
3983 : " --overwrite=".$overwrite_version;
3985 # Contributing parent is the first parent - that makes
3986 # git rev-list --first-parent DTRT.
3987 my $pmf = dgit_privdir()."/pseudomerge";
3988 open MC, ">", $pmf or die "$pmf $!";
3989 print MC <<END or die $!;
3992 parent $archive_hash
4002 return make_commit($pmf);
4005 sub splitbrain_pseudomerge ($$$$) {
4006 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4007 # => $merged_dgitview
4008 printdebug "splitbrain_pseudomerge...\n";
4010 # We: debian/PREVIOUS HEAD($maintview)
4011 # expect: o ----------------- o
4014 # a/d/PREVIOUS $dgitview
4017 # we do: `------------------ o
4021 return $dgitview unless defined $archive_hash;
4022 return $dgitview if deliberately_not_fast_forward();
4024 printdebug "splitbrain_pseudomerge...\n";
4026 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4028 if (!defined $overwrite_version) {
4029 progress "Checking that HEAD inciudes all changes in archive...";
4032 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4034 if (defined $overwrite_version) {
4036 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4037 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
4038 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4039 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
4040 my $i_archive = [ $archive_hash, "current archive contents" ];
4042 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4044 infopair_cond_equal($i_dgit, $i_archive);
4045 infopair_cond_ff($i_dep14, $i_dgit);
4046 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4049 $@ =~ s/^\n//; chomp $@;
4052 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4057 my $r = pseudomerge_make_commit
4058 $clogp, $dgitview, $archive_hash, $i_arch_v,
4059 "dgit --quilt=$quilt_mode",
4060 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4061 Declare fast forward from $i_arch_v->[0]
4063 Make fast forward from $i_arch_v->[0]
4066 maybe_split_brain_save $maintview, $r, "pseudomerge";
4068 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4072 sub plain_overwrite_pseudomerge ($$$) {
4073 my ($clogp, $head, $archive_hash) = @_;
4075 printdebug "plain_overwrite_pseudomerge...";
4077 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4079 return $head if is_fast_fwd $archive_hash, $head;
4081 my $m = "Declare fast forward from $i_arch_v->[0]";
4083 my $r = pseudomerge_make_commit
4084 $clogp, $head, $archive_hash, $i_arch_v,
4087 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4089 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4093 sub push_parse_changelog ($) {
4096 my $clogp = Dpkg::Control::Hash->new();
4097 $clogp->load($clogpfn) or die;
4099 my $clogpackage = getfield $clogp, 'Source';
4100 $package //= $clogpackage;
4101 fail "-p specified $package but changelog specified $clogpackage"
4102 unless $package eq $clogpackage;
4103 my $cversion = getfield $clogp, 'Version';
4105 if (!$we_are_initiator) {
4106 # rpush initiator can't do this because it doesn't have $isuite yet
4107 my $tag = debiantag($cversion, access_nomdistro);
4108 runcmd @git, qw(check-ref-format), $tag;
4111 my $dscfn = dscfn($cversion);
4113 return ($clogp, $cversion, $dscfn);
4116 sub push_parse_dsc ($$$) {
4117 my ($dscfn,$dscfnwhat, $cversion) = @_;
4118 $dsc = parsecontrol($dscfn,$dscfnwhat);
4119 my $dversion = getfield $dsc, 'Version';
4120 my $dscpackage = getfield $dsc, 'Source';
4121 ($dscpackage eq $package && $dversion eq $cversion) or
4122 fail "$dscfn is for $dscpackage $dversion".
4123 " but debian/changelog is for $package $cversion";
4126 sub push_tagwants ($$$$) {
4127 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4130 TagFn => \&debiantag,
4135 if (defined $maintviewhead) {
4137 TagFn => \&debiantag_maintview,
4138 Objid => $maintviewhead,
4139 TfSuffix => '-maintview',
4142 } elsif ($dodep14tag eq 'no' ? 0
4143 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4144 : $dodep14tag eq 'always'
4145 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4146 --dep14tag-always (or equivalent in config) means server must support
4147 both "new" and "maint" tag formats, but config says it doesn't.
4149 : die "$dodep14tag ?") {
4151 TagFn => \&debiantag_maintview,
4153 TfSuffix => '-dgit',
4157 foreach my $tw (@tagwants) {
4158 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4159 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4161 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4165 sub push_mktags ($$ $$ $) {
4167 $changesfile,$changesfilewhat,
4170 die unless $tagwants->[0]{View} eq 'dgit';
4172 my $declaredistro = access_nomdistro();
4173 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4174 $dsc->{$ourdscfield[0]} = join " ",
4175 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4177 $dsc->save("$dscfn.tmp") or die $!;
4179 my $changes = parsecontrol($changesfile,$changesfilewhat);
4180 foreach my $field (qw(Source Distribution Version)) {
4181 $changes->{$field} eq $clogp->{$field} or
4182 fail "changes field $field \`$changes->{$field}'".
4183 " does not match changelog \`$clogp->{$field}'";
4186 my $cversion = getfield $clogp, 'Version';
4187 my $clogsuite = getfield $clogp, 'Distribution';
4189 # We make the git tag by hand because (a) that makes it easier
4190 # to control the "tagger" (b) we can do remote signing
4191 my $authline = clogp_authline $clogp;
4192 my $delibs = join(" ", "",@deliberatelies);
4196 my $tfn = $tw->{Tfn};
4197 my $head = $tw->{Objid};
4198 my $tag = $tw->{Tag};
4200 open TO, '>', $tfn->('.tmp') or die $!;
4201 print TO <<END or die $!;
4208 if ($tw->{View} eq 'dgit') {
4209 print TO <<END or die $!;
4210 $package release $cversion for $clogsuite ($csuite) [dgit]
4211 [dgit distro=$declaredistro$delibs]
4213 foreach my $ref (sort keys %previously) {
4214 print TO <<END or die $!;
4215 [dgit previously:$ref=$previously{$ref}]
4218 } elsif ($tw->{View} eq 'maint') {
4219 print TO <<END or die $!;
4220 $package release $cversion for $clogsuite ($csuite)
4221 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4224 die Dumper($tw)."?";
4229 my $tagobjfn = $tfn->('.tmp');
4231 if (!defined $keyid) {
4232 $keyid = access_cfg('keyid','RETURN-UNDEF');
4234 if (!defined $keyid) {
4235 $keyid = getfield $clogp, 'Maintainer';
4237 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4238 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4239 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4240 push @sign_cmd, $tfn->('.tmp');
4241 runcmd_ordryrun @sign_cmd;
4243 $tagobjfn = $tfn->('.signed.tmp');
4244 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4245 $tfn->('.tmp'), $tfn->('.tmp.asc');
4251 my @r = map { $mktag->($_); } @$tagwants;
4255 sub sign_changes ($) {
4256 my ($changesfile) = @_;
4258 my @debsign_cmd = @debsign;
4259 push @debsign_cmd, "-k$keyid" if defined $keyid;
4260 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4261 push @debsign_cmd, $changesfile;
4262 runcmd_ordryrun @debsign_cmd;
4267 printdebug "actually entering push\n";
4269 supplementary_message(<<'END');
4270 Push failed, while checking state of the archive.
4271 You can retry the push, after fixing the problem, if you like.
4273 if (check_for_git()) {
4276 my $archive_hash = fetch_from_archive();
4277 if (!$archive_hash) {
4279 fail "package appears to be new in this suite;".
4280 " if this is intentional, use --new";
4283 supplementary_message(<<'END');
4284 Push failed, while preparing your push.
4285 You can retry the push, after fixing the problem, if you like.
4288 need_tagformat 'new', "quilt mode $quilt_mode"
4289 if quiltmode_splitbrain;
4293 access_giturl(); # check that success is vaguely likely
4294 rpush_handle_protovsn_bothends() if $we_are_initiator;
4297 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4298 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4300 responder_send_file('parsed-changelog', $clogpfn);
4302 my ($clogp, $cversion, $dscfn) =
4303 push_parse_changelog("$clogpfn");
4305 my $dscpath = "$buildproductsdir/$dscfn";
4306 stat_exists $dscpath or
4307 fail "looked for .dsc $dscpath, but $!;".
4308 " maybe you forgot to build";
4310 responder_send_file('dsc', $dscpath);
4312 push_parse_dsc($dscpath, $dscfn, $cversion);
4314 my $format = getfield $dsc, 'Format';
4315 printdebug "format $format\n";
4317 my $symref = git_get_symref();
4318 my $actualhead = git_rev_parse('HEAD');
4320 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4321 if (quiltmode_splitbrain()) {
4322 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4324 Branch is managed by git-debrebase ($ffq_prev
4325 exists), but quilt mode ($quilt_mode) implies a split view.
4326 Pass the right --quilt option or adjust your git config.
4327 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4330 runcmd_ordryrun_local @git_debrebase, 'stitch';
4331 $actualhead = git_rev_parse('HEAD');
4334 my $dgithead = $actualhead;
4335 my $maintviewhead = undef;
4337 my $upstreamversion = upstreamversion $clogp->{Version};
4339 if (madformat_wantfixup($format)) {
4340 # user might have not used dgit build, so maybe do this now:
4341 if (quiltmode_splitbrain()) {
4342 changedir $playground;
4343 quilt_make_fake_dsc($upstreamversion);
4345 ($dgithead, $cachekey) =
4346 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4348 "--quilt=$quilt_mode but no cached dgit view:
4349 perhaps HEAD changed since dgit build[-source] ?";
4351 $dgithead = splitbrain_pseudomerge($clogp,
4352 $actualhead, $dgithead,
4354 $maintviewhead = $actualhead;
4356 prep_ud(); # so _only_subdir() works, below
4358 commit_quilty_patch();
4362 if (defined $overwrite_version && !defined $maintviewhead
4364 $dgithead = plain_overwrite_pseudomerge($clogp,
4372 if ($archive_hash) {
4373 if (is_fast_fwd($archive_hash, $dgithead)) {
4375 } elsif (deliberately_not_fast_forward) {
4378 fail "dgit push: HEAD is not a descendant".
4379 " of the archive's version.\n".
4380 "To overwrite the archive's contents,".
4381 " pass --overwrite[=VERSION].\n".
4382 "To rewind history, if permitted by the archive,".
4383 " use --deliberately-not-fast-forward.";
4387 changedir $playground;
4388 progress "checking that $dscfn corresponds to HEAD";
4389 runcmd qw(dpkg-source -x --),
4390 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4391 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4392 check_for_vendor_patches() if madformat($dsc->{format});
4394 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4395 debugcmd "+",@diffcmd;
4397 my $r = system @diffcmd;
4400 my $referent = $split_brain ? $dgithead : 'HEAD';
4401 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4404 my $raw = cmdoutput @git,
4405 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4407 foreach (split /\0/, $raw) {
4408 if (defined $changed) {
4409 push @mode_changes, "$changed: $_\n" if $changed;
4412 } elsif (m/^:0+ 0+ /) {
4414 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4415 $changed = "Mode change from $1 to $2"
4420 if (@mode_changes) {
4421 fail <<END.(join '', @mode_changes).<<END;
4422 HEAD specifies a different tree to $dscfn:
4425 There is a problem with your source tree (see dgit(7) for some hints).
4426 To see a full diff, run git diff $tree $referent
4431 HEAD specifies a different tree to $dscfn:
4433 Perhaps you forgot to build. Or perhaps there is a problem with your
4434 source tree (see dgit(7) for some hints). To see a full diff, run
4435 git diff $tree $referent
4441 if (!$changesfile) {
4442 my $pat = changespat $cversion;
4443 my @cs = glob "$buildproductsdir/$pat";
4444 fail "failed to find unique changes file".
4445 " (looked for $pat in $buildproductsdir);".
4446 " perhaps you need to use dgit -C"
4448 ($changesfile) = @cs;
4450 $changesfile = "$buildproductsdir/$changesfile";
4453 # Check that changes and .dsc agree enough
4454 $changesfile =~ m{[^/]*$};
4455 my $changes = parsecontrol($changesfile,$&);
4456 files_compare_inputs($dsc, $changes)
4457 unless forceing [qw(dsc-changes-mismatch)];
4459 # Check whether this is a source only upload
4460 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4461 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4462 if ($sourceonlypolicy eq 'ok') {
4463 } elsif ($sourceonlypolicy eq 'always') {
4464 forceable_fail [qw(uploading-binaries)],
4465 "uploading binaries, although distroy policy is source only"
4467 } elsif ($sourceonlypolicy eq 'never') {
4468 forceable_fail [qw(uploading-source-only)],
4469 "source-only upload, although distroy policy requires .debs"
4471 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4472 forceable_fail [qw(uploading-source-only)],
4473 "source-only upload, even though package is entirely NEW\n".
4474 "(this is contrary to policy in ".(access_nomdistro()).")"
4477 && !(archive_query('package_not_wholly_new', $package) // 1);
4479 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4482 # Perhaps adjust .dsc to contain right set of origs
4483 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4485 unless forceing [qw(changes-origs-exactly)];
4487 # Checks complete, we're going to try and go ahead:
4489 responder_send_file('changes',$changesfile);
4490 responder_send_command("param head $dgithead");
4491 responder_send_command("param csuite $csuite");
4492 responder_send_command("param isuite $isuite");
4493 responder_send_command("param tagformat $tagformat");
4494 if (defined $maintviewhead) {
4495 confess "internal error (protovsn=$protovsn)"
4496 if defined $protovsn and $protovsn < 4;
4497 responder_send_command("param maint-view $maintviewhead");
4500 # Perhaps send buildinfo(s) for signing
4501 my $changes_files = getfield $changes, 'Files';
4502 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4503 foreach my $bi (@buildinfos) {
4504 responder_send_command("param buildinfo-filename $bi");
4505 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4508 if (deliberately_not_fast_forward) {
4509 git_for_each_ref(lrfetchrefs, sub {
4510 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4511 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4512 responder_send_command("previously $rrefname=$objid");
4513 $previously{$rrefname} = $objid;
4517 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4518 dgit_privdir()."/tag");
4521 supplementary_message(<<'END');
4522 Push failed, while signing the tag.
4523 You can retry the push, after fixing the problem, if you like.
4525 # If we manage to sign but fail to record it anywhere, it's fine.
4526 if ($we_are_responder) {
4527 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4528 responder_receive_files('signed-tag', @tagobjfns);
4530 @tagobjfns = push_mktags($clogp,$dscpath,
4531 $changesfile,$changesfile,
4534 supplementary_message(<<'END');
4535 Push failed, *after* signing the tag.
4536 If you want to try again, you should use a new version number.
4539 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4541 foreach my $tw (@tagwants) {
4542 my $tag = $tw->{Tag};
4543 my $tagobjfn = $tw->{TagObjFn};
4545 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4546 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4547 runcmd_ordryrun_local
4548 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4551 supplementary_message(<<'END');
4552 Push failed, while updating the remote git repository - see messages above.
4553 If you want to try again, you should use a new version number.
4555 if (!check_for_git()) {
4556 create_remote_git_repo();
4559 my @pushrefs = $forceflag.$dgithead.":".rrref();
4560 foreach my $tw (@tagwants) {
4561 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4564 runcmd_ordryrun @git,
4565 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4566 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4568 supplementary_message(<<'END');
4569 Push failed, while obtaining signatures on the .changes and .dsc.
4570 If it was just that the signature failed, you may try again by using
4571 debsign by hand to sign the changes file (see the command dgit tried,
4572 above), and then dput that changes file to complete the upload.
4573 If you need to change the package, you must use a new version number.
4575 if ($we_are_responder) {
4576 my $dryrunsuffix = act_local() ? "" : ".tmp";
4577 my @rfiles = ($dscpath, $changesfile);
4578 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4579 responder_receive_files('signed-dsc-changes',
4580 map { "$_$dryrunsuffix" } @rfiles);
4583 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4585 progress "[new .dsc left in $dscpath.tmp]";
4587 sign_changes $changesfile;
4590 supplementary_message(<<END);
4591 Push failed, while uploading package(s) to the archive server.
4592 You can retry the upload of exactly these same files with dput of:
4594 If that .changes file is broken, you will need to use a new version
4595 number for your next attempt at the upload.
4597 my $host = access_cfg('upload-host','RETURN-UNDEF');
4598 my @hostarg = defined($host) ? ($host,) : ();
4599 runcmd_ordryrun @dput, @hostarg, $changesfile;
4600 printdone "pushed and uploaded $cversion";
4602 supplementary_message('');
4603 responder_send_command("complete");
4607 not_necessarily_a_tree();
4612 badusage "-p is not allowed with clone; specify as argument instead"
4613 if defined $package;
4616 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4617 ($package,$isuite) = @ARGV;
4618 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4619 ($package,$dstdir) = @ARGV;
4620 } elsif (@ARGV==3) {
4621 ($package,$isuite,$dstdir) = @ARGV;
4623 badusage "incorrect arguments to dgit clone";
4627 $dstdir ||= "$package";
4628 if (stat_exists $dstdir) {
4629 fail "$dstdir already exists";
4633 if ($rmonerror && !$dryrun_level) {
4634 $cwd_remove= getcwd();
4636 return unless defined $cwd_remove;
4637 if (!chdir "$cwd_remove") {
4638 return if $!==&ENOENT;
4639 die "chdir $cwd_remove: $!";
4641 printdebug "clone rmonerror removing $dstdir\n";
4643 rmtree($dstdir) or die "remove $dstdir: $!\n";
4644 } elsif (grep { $! == $_ }
4645 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4647 print STDERR "check whether to remove $dstdir: $!\n";
4653 $cwd_remove = undef;
4656 sub branchsuite () {
4657 my $branch = git_get_symref();
4658 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4665 sub package_from_d_control () {
4666 if (!defined $package) {
4667 my $sourcep = parsecontrol('debian/control','debian/control');
4668 $package = getfield $sourcep, 'Source';
4672 sub fetchpullargs () {
4673 package_from_d_control();
4675 $isuite = branchsuite();
4677 my $clogp = parsechangelog();
4678 my $clogsuite = getfield $clogp, 'Distribution';
4679 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4681 } elsif (@ARGV==1) {
4684 badusage "incorrect arguments to dgit fetch or dgit pull";
4698 if (quiltmode_splitbrain()) {
4699 my ($format, $fopts) = get_source_format();
4700 madformat($format) and fail <<END
4701 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4709 package_from_d_control();
4710 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4714 foreach my $canon (qw(0 1)) {
4719 canonicalise_suite();
4721 if (length git_get_ref lref()) {
4722 # local branch already exists, yay
4725 if (!length git_get_ref lrref()) {
4733 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4736 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4737 "dgit checkout $isuite";
4738 runcmd (@git, qw(checkout), lbranch());
4741 sub cmd_update_vcs_git () {
4743 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4744 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4746 ($specsuite) = (@ARGV);
4751 if ($ARGV[0] eq '-') {
4753 } elsif ($ARGV[0] eq '-') {
4758 package_from_d_control();
4760 if ($specsuite eq '.') {
4761 $ctrl = parsecontrol 'debian/control', 'debian/control';
4763 $isuite = $specsuite;
4767 my $url = getfield $ctrl, 'Vcs-Git';
4770 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4771 if (!defined $orgurl) {
4772 print STDERR "setting up vcs-git: $url\n";
4773 @cmd = (@git, qw(remote add vcs-git), $url);
4774 } elsif ($orgurl eq $url) {
4775 print STDERR "vcs git already configured: $url\n";
4777 print STDERR "changing vcs-git url to: $url\n";
4778 @cmd = (@git, qw(remote set-url vcs-git), $url);
4780 runcmd_ordryrun_local @cmd;
4782 print "fetching (@ARGV)\n";
4783 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4789 build_or_push_prep_early();
4794 } elsif (@ARGV==1) {
4795 ($specsuite) = (@ARGV);
4797 badusage "incorrect arguments to dgit $subcommand";
4800 local ($package) = $existing_package; # this is a hack
4801 canonicalise_suite();
4803 canonicalise_suite();
4805 if (defined $specsuite &&
4806 $specsuite ne $isuite &&
4807 $specsuite ne $csuite) {
4808 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4809 " but command line specifies $specsuite";
4818 #---------- remote commands' implementation ----------
4820 sub pre_remote_push_build_host {
4821 my ($nrargs) = shift @ARGV;
4822 my (@rargs) = @ARGV[0..$nrargs-1];
4823 @ARGV = @ARGV[$nrargs..$#ARGV];
4825 my ($dir,$vsnwant) = @rargs;
4826 # vsnwant is a comma-separated list; we report which we have
4827 # chosen in our ready response (so other end can tell if they
4830 $we_are_responder = 1;
4831 $us .= " (build host)";
4833 open PI, "<&STDIN" or die $!;
4834 open STDIN, "/dev/null" or die $!;
4835 open PO, ">&STDOUT" or die $!;
4837 open STDOUT, ">&STDERR" or die $!;
4841 ($protovsn) = grep {
4842 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4843 } @rpushprotovsn_support;
4845 fail "build host has dgit rpush protocol versions ".
4846 (join ",", @rpushprotovsn_support).
4847 " but invocation host has $vsnwant"
4848 unless defined $protovsn;
4852 sub cmd_remote_push_build_host {
4853 responder_send_command("dgit-remote-push-ready $protovsn");
4857 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4858 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4859 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4860 # a good error message)
4862 sub rpush_handle_protovsn_bothends () {
4863 if ($protovsn < 4) {
4864 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4873 my $report = i_child_report();
4874 if (defined $report) {
4875 printdebug "($report)\n";
4876 } elsif ($i_child_pid) {
4877 printdebug "(killing build host child $i_child_pid)\n";
4878 kill 15, $i_child_pid;
4880 if (defined $i_tmp && !defined $initiator_tempdir) {
4882 eval { rmtree $i_tmp; };
4887 return unless forkcheck_mainprocess();
4892 my ($base,$selector,@args) = @_;
4893 $selector =~ s/\-/_/g;
4894 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4898 not_necessarily_a_tree();
4903 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4911 push @rargs, join ",", @rpushprotovsn_support;
4914 push @rdgit, @ropts;
4915 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4917 my @cmd = (@ssh, $host, shellquote @rdgit);
4920 $we_are_initiator=1;
4922 if (defined $initiator_tempdir) {
4923 rmtree $initiator_tempdir;
4924 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4925 $i_tmp = $initiator_tempdir;
4929 $i_child_pid = open2(\*RO, \*RI, @cmd);
4931 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4932 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4933 $supplementary_message = '' unless $protovsn >= 3;
4936 my ($icmd,$iargs) = initiator_expect {
4937 m/^(\S+)(?: (.*))?$/;
4940 i_method "i_resp", $icmd, $iargs;
4944 sub i_resp_progress ($) {
4946 my $msg = protocol_read_bytes \*RO, $rhs;
4950 sub i_resp_supplementary_message ($) {
4952 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4955 sub i_resp_complete {
4956 my $pid = $i_child_pid;
4957 $i_child_pid = undef; # prevents killing some other process with same pid
4958 printdebug "waiting for build host child $pid...\n";
4959 my $got = waitpid $pid, 0;
4960 die $! unless $got == $pid;
4961 die "build host child failed $?" if $?;
4964 printdebug "all done\n";
4968 sub i_resp_file ($) {
4970 my $localname = i_method "i_localname", $keyword;
4971 my $localpath = "$i_tmp/$localname";
4972 stat_exists $localpath and
4973 badproto \*RO, "file $keyword ($localpath) twice";
4974 protocol_receive_file \*RO, $localpath;
4975 i_method "i_file", $keyword;
4980 sub i_resp_param ($) {
4981 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4985 sub i_resp_previously ($) {
4986 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4987 or badproto \*RO, "bad previously spec";
4988 my $r = system qw(git check-ref-format), $1;
4989 die "bad previously ref spec ($r)" if $r;
4990 $previously{$1} = $2;
4995 sub i_resp_want ($) {
4997 die "$keyword ?" if $i_wanted{$keyword}++;
4999 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
5000 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
5001 die unless $isuite =~ m/^$suite_re$/;
5004 rpush_handle_protovsn_bothends();
5006 fail "rpush negotiated protocol version $protovsn".
5007 " which does not support quilt mode $quilt_mode"
5008 if quiltmode_splitbrain;
5010 my @localpaths = i_method "i_want", $keyword;
5011 printdebug "[[ $keyword @localpaths\n";
5012 foreach my $localpath (@localpaths) {
5013 protocol_send_file \*RI, $localpath;
5015 print RI "files-end\n" or die $!;
5018 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5020 sub i_localname_parsed_changelog {
5021 return "remote-changelog.822";
5023 sub i_file_parsed_changelog {
5024 ($i_clogp, $i_version, $i_dscfn) =
5025 push_parse_changelog "$i_tmp/remote-changelog.822";
5026 die if $i_dscfn =~ m#/|^\W#;
5029 sub i_localname_dsc {
5030 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5035 sub i_localname_buildinfo ($) {
5036 my $bi = $i_param{'buildinfo-filename'};
5037 defined $bi or badproto \*RO, "buildinfo before filename";
5038 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5039 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5040 or badproto \*RO, "improper buildinfo filename";
5043 sub i_file_buildinfo {
5044 my $bi = $i_param{'buildinfo-filename'};
5045 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5046 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5047 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5048 files_compare_inputs($bd, $ch);
5049 (getfield $bd, $_) eq (getfield $ch, $_) or
5050 fail "buildinfo mismatch $_"
5051 foreach qw(Source Version);
5052 !defined $bd->{$_} or
5053 fail "buildinfo contains $_"
5054 foreach qw(Changes Changed-by Distribution);
5056 push @i_buildinfos, $bi;
5057 delete $i_param{'buildinfo-filename'};
5060 sub i_localname_changes {
5061 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5062 $i_changesfn = $i_dscfn;
5063 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5064 return $i_changesfn;
5066 sub i_file_changes { }
5068 sub i_want_signed_tag {
5069 printdebug Dumper(\%i_param, $i_dscfn);
5070 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5071 && defined $i_param{'csuite'}
5072 or badproto \*RO, "premature desire for signed-tag";
5073 my $head = $i_param{'head'};
5074 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5076 my $maintview = $i_param{'maint-view'};
5077 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5080 if ($protovsn >= 4) {
5081 my $p = $i_param{'tagformat'} // '<undef>';
5083 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5086 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5088 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5090 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5093 push_mktags $i_clogp, $i_dscfn,
5094 $i_changesfn, 'remote changes',
5098 sub i_want_signed_dsc_changes {
5099 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5100 sign_changes $i_changesfn;
5101 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5104 #---------- building etc. ----------
5110 #----- `3.0 (quilt)' handling -----
5112 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5114 sub quiltify_dpkg_commit ($$$;$) {
5115 my ($patchname,$author,$msg, $xinfo) = @_;
5118 mkpath '.git/dgit'; # we are in playtree
5119 my $descfn = ".git/dgit/quilt-description.tmp";
5120 open O, '>', $descfn or die "$descfn: $!";
5121 $msg =~ s/\n+/\n\n/;
5122 print O <<END or die $!;
5124 ${xinfo}Subject: $msg
5131 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5132 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5133 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5134 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5138 sub quiltify_trees_differ ($$;$$$) {
5139 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5140 # returns true iff the two tree objects differ other than in debian/
5141 # with $finegrained,
5142 # returns bitmask 01 - differ in upstream files except .gitignore
5143 # 02 - differ in .gitignore
5144 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5145 # is set for each modified .gitignore filename $fn
5146 # if $unrepres is defined, array ref to which is appeneded
5147 # a list of unrepresentable changes (removals of upstream files
5150 my @cmd = (@git, qw(diff-tree -z --no-renames));
5151 push @cmd, qw(--name-only) unless $unrepres;
5152 push @cmd, qw(-r) if $finegrained || $unrepres;
5154 my $diffs= cmdoutput @cmd;
5157 foreach my $f (split /\0/, $diffs) {
5158 if ($unrepres && !@lmodes) {
5159 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5162 my ($oldmode,$newmode) = @lmodes;
5165 next if $f =~ m#^debian(?:/.*)?$#s;
5169 die "not a plain file or symlink\n"
5170 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5171 $oldmode =~ m/^(?:10|12)\d{4}$/;
5172 if ($oldmode =~ m/[^0]/ &&
5173 $newmode =~ m/[^0]/) {
5174 # both old and new files exist
5175 die "mode or type changed\n" if $oldmode ne $newmode;
5176 die "modified symlink\n" unless $newmode =~ m/^10/;
5177 } elsif ($oldmode =~ m/[^0]/) {
5179 die "deletion of symlink\n"
5180 unless $oldmode =~ m/^10/;
5183 die "creation with non-default mode\n"
5184 unless $newmode =~ m/^100644$/ or
5185 $newmode =~ m/^120000$/;
5189 local $/="\n"; chomp $@;
5190 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5194 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5195 $r |= $isignore ? 02 : 01;
5196 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5198 printdebug "quiltify_trees_differ $x $y => $r\n";
5202 sub quiltify_tree_sentinelfiles ($) {
5203 # lists the `sentinel' files present in the tree
5205 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5206 qw(-- debian/rules debian/control);
5211 sub quiltify_splitbrain_needed () {
5212 if (!$split_brain) {
5213 progress "dgit view: changes are required...";
5214 runcmd @git, qw(checkout -q -b dgit-view);
5219 sub quiltify_splitbrain ($$$$$$$) {
5220 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5221 $editedignores, $cachekey) = @_;
5222 my $gitignore_special = 1;
5223 if ($quilt_mode !~ m/gbp|dpm/) {
5224 # treat .gitignore just like any other upstream file
5225 $diffbits = { %$diffbits };
5226 $_ = !!$_ foreach values %$diffbits;
5227 $gitignore_special = 0;
5229 # We would like any commits we generate to be reproducible
5230 my @authline = clogp_authline($clogp);
5231 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5232 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5233 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5234 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5235 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5236 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5238 my $fulldiffhint = sub {
5240 my $cmd = "git diff $x $y -- :/ ':!debian'";
5241 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5242 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5245 if ($quilt_mode =~ m/gbp|unapplied/ &&
5246 ($diffbits->{O2H} & 01)) {
5248 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5249 " but git tree differs from orig in upstream files.";
5250 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5251 if (!stat_exists "debian/patches") {
5253 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5257 if ($quilt_mode =~ m/dpm/ &&
5258 ($diffbits->{H2A} & 01)) {
5259 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5260 --quilt=$quilt_mode specified, implying patches-applied git tree
5261 but git tree differs from result of applying debian/patches to upstream
5264 if ($quilt_mode =~ m/gbp|unapplied/ &&
5265 ($diffbits->{O2A} & 01)) { # some patches
5266 quiltify_splitbrain_needed();
5267 progress "dgit view: creating patches-applied version using gbp pq";
5268 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5269 # gbp pq import creates a fresh branch; push back to dgit-view
5270 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5271 runcmd @git, qw(checkout -q dgit-view);
5273 if ($quilt_mode =~ m/gbp|dpm/ &&
5274 ($diffbits->{O2A} & 02)) {
5276 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5277 tool which does not create patches for changes to upstream
5278 .gitignores: but, such patches exist in debian/patches.
5281 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5282 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5283 quiltify_splitbrain_needed();
5284 progress "dgit view: creating patch to represent .gitignore changes";
5285 ensuredir "debian/patches";
5286 my $gipatch = "debian/patches/auto-gitignore";
5287 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5288 stat GIPATCH or die "$gipatch: $!";
5289 fail "$gipatch already exists; but want to create it".
5290 " to record .gitignore changes" if (stat _)[7];
5291 print GIPATCH <<END or die "$gipatch: $!";
5292 Subject: Update .gitignore from Debian packaging branch
5294 The Debian packaging git branch contains these updates to the upstream
5295 .gitignore file(s). This patch is autogenerated, to provide these
5296 updates to users of the official Debian archive view of the package.
5298 [dgit ($our_version) update-gitignore]
5301 close GIPATCH or die "$gipatch: $!";
5302 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5303 $unapplied, $headref, "--", sort keys %$editedignores;
5304 open SERIES, "+>>", "debian/patches/series" or die $!;
5305 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5307 defined read SERIES, $newline, 1 or die $!;
5308 print SERIES "\n" or die $! unless $newline eq "\n";
5309 print SERIES "auto-gitignore\n" or die $!;
5310 close SERIES or die $!;
5311 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5313 Commit patch to update .gitignore
5315 [dgit ($our_version) update-gitignore-quilt-fixup]
5319 my $dgitview = git_rev_parse 'HEAD';
5322 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5324 changedir "$playground/work";
5326 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5327 progress "dgit view: created ($saved)";
5330 sub quiltify ($$$$) {
5331 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5333 # Quilt patchification algorithm
5335 # We search backwards through the history of the main tree's HEAD
5336 # (T) looking for a start commit S whose tree object is identical
5337 # to to the patch tip tree (ie the tree corresponding to the
5338 # current dpkg-committed patch series). For these purposes
5339 # `identical' disregards anything in debian/ - this wrinkle is
5340 # necessary because dpkg-source treates debian/ specially.
5342 # We can only traverse edges where at most one of the ancestors'
5343 # trees differs (in changes outside in debian/). And we cannot
5344 # handle edges which change .pc/ or debian/patches. To avoid
5345 # going down a rathole we avoid traversing edges which introduce
5346 # debian/rules or debian/control. And we set a limit on the
5347 # number of edges we are willing to look at.
5349 # If we succeed, we walk forwards again. For each traversed edge
5350 # PC (with P parent, C child) (starting with P=S and ending with
5351 # C=T) to we do this:
5353 # - dpkg-source --commit with a patch name and message derived from C
5354 # After traversing PT, we git commit the changes which
5355 # should be contained within debian/patches.
5357 # The search for the path S..T is breadth-first. We maintain a
5358 # todo list containing search nodes. A search node identifies a
5359 # commit, and looks something like this:
5361 # Commit => $git_commit_id,
5362 # Child => $c, # or undef if P=T
5363 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5364 # Nontrivial => true iff $p..$c has relevant changes
5371 my %considered; # saves being exponential on some weird graphs
5373 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5376 my ($search,$whynot) = @_;
5377 printdebug " search NOT $search->{Commit} $whynot\n";
5378 $search->{Whynot} = $whynot;
5379 push @nots, $search;
5380 no warnings qw(exiting);
5389 my $c = shift @todo;
5390 next if $considered{$c->{Commit}}++;
5392 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5394 printdebug "quiltify investigate $c->{Commit}\n";
5397 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5398 printdebug " search finished hooray!\n";
5403 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5404 if ($quilt_mode eq 'smash') {
5405 printdebug " search quitting smash\n";
5409 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5410 $not->($c, "has $c_sentinels not $t_sentinels")
5411 if $c_sentinels ne $t_sentinels;
5413 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5414 $commitdata =~ m/\n\n/;
5416 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5417 @parents = map { { Commit => $_, Child => $c } } @parents;
5419 $not->($c, "root commit") if !@parents;
5421 foreach my $p (@parents) {
5422 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5424 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5425 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5427 foreach my $p (@parents) {
5428 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5430 my @cmd= (@git, qw(diff-tree -r --name-only),
5431 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5432 my $patchstackchange = cmdoutput @cmd;
5433 if (length $patchstackchange) {
5434 $patchstackchange =~ s/\n/,/g;
5435 $not->($p, "changed $patchstackchange");
5438 printdebug " search queue P=$p->{Commit} ",
5439 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5445 printdebug "quiltify want to smash\n";
5448 my $x = $_[0]{Commit};
5449 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5452 my $reportnot = sub {
5454 my $s = $abbrev->($notp);
5455 my $c = $notp->{Child};
5456 $s .= "..".$abbrev->($c) if $c;
5457 $s .= ": ".$notp->{Whynot};
5460 if ($quilt_mode eq 'linear') {
5461 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5462 my $all_gdr = !!@nots;
5463 foreach my $notp (@nots) {
5464 print STDERR "$us: ", $reportnot->($notp), "\n";
5465 $all_gdr &&= $notp->{Child} &&
5466 (git_cat_file $notp->{Child}{Commit}, 'commit')
5467 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5471 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5473 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5475 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5476 } elsif ($quilt_mode eq 'smash') {
5477 } elsif ($quilt_mode eq 'auto') {
5478 progress "quilt fixup cannot be linear, smashing...";
5480 die "$quilt_mode ?";
5483 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5484 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5486 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5488 quiltify_dpkg_commit "auto-$version-$target-$time",
5489 (getfield $clogp, 'Maintainer'),
5490 "Automatically generated patch ($clogp->{Version})\n".
5491 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5495 progress "quiltify linearisation planning successful, executing...";
5497 for (my $p = $sref_S;
5498 my $c = $p->{Child};
5500 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5501 next unless $p->{Nontrivial};
5503 my $cc = $c->{Commit};
5505 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5506 $commitdata =~ m/\n\n/ or die "$c ?";
5509 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5512 my $commitdate = cmdoutput
5513 @git, qw(log -n1 --pretty=format:%aD), $cc;
5515 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5517 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5524 my $gbp_check_suitable = sub {
5529 die "contains unexpected slashes\n" if m{//} || m{/$};
5530 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5531 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5532 die "is series file\n" if m{$series_filename_re}o;
5533 die "too long" if length > 200;
5535 return $_ unless $@;
5536 print STDERR "quiltifying commit $cc:".
5537 " ignoring/dropping Gbp-Pq $what: $@";
5541 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5543 (\S+) \s* \n //ixm) {
5544 $patchname = $gbp_check_suitable->($1, 'Name');
5546 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5548 (\S+) \s* \n //ixm) {
5549 $patchdir = $gbp_check_suitable->($1, 'Topic');
5554 if (!defined $patchname) {
5555 $patchname = $title;
5556 $patchname =~ s/[.:]$//;
5559 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5560 my $translitname = $converter->convert($patchname);
5561 die unless defined $translitname;
5562 $patchname = $translitname;
5565 "dgit: patch title transliteration error: $@"
5567 $patchname =~ y/ A-Z/-a-z/;
5568 $patchname =~ y/-a-z0-9_.+=~//cd;
5569 $patchname =~ s/^\W/x-$&/;
5570 $patchname = substr($patchname,0,40);
5571 $patchname .= ".patch";
5573 if (!defined $patchdir) {
5576 if (length $patchdir) {
5577 $patchname = "$patchdir/$patchname";
5579 if ($patchname =~ m{^(.*)/}) {
5580 mkpath "debian/patches/$1";
5585 stat "debian/patches/$patchname$index";
5587 $!==ENOENT or die "$patchname$index $!";
5589 runcmd @git, qw(checkout -q), $cc;
5591 # We use the tip's changelog so that dpkg-source doesn't
5592 # produce complaining messages from dpkg-parsechangelog. None
5593 # of the information dpkg-source gets from the changelog is
5594 # actually relevant - it gets put into the original message
5595 # which dpkg-source provides our stunt editor, and then
5597 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5599 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5600 "Date: $commitdate\n".
5601 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5603 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5606 runcmd @git, qw(checkout -q master);
5609 sub build_maybe_quilt_fixup () {
5610 my ($format,$fopts) = get_source_format;
5611 return unless madformat_wantfixup $format;
5614 check_for_vendor_patches();
5616 if (quiltmode_splitbrain) {
5617 fail <<END unless access_cfg_tagformats_can_splitbrain;
5618 quilt mode $quilt_mode requires split view so server needs to support
5619 both "new" and "maint" tag formats, but config says it doesn't.
5623 my $clogp = parsechangelog();
5624 my $headref = git_rev_parse('HEAD');
5625 my $symref = git_get_symref();
5627 if ($quilt_mode eq 'linear'
5628 && !$fopts->{'single-debian-patch'}
5629 && branch_is_gdr($headref)) {
5630 # This is much faster. It also makes patches that gdr
5631 # likes better for future updates without laundering.
5633 # However, it can fail in some casses where we would
5634 # succeed: if there are existing patches, which correspond
5635 # to a prefix of the branch, but are not in gbp/gdr
5636 # format, gdr will fail (exiting status 7), but we might
5637 # be able to figure out where to start linearising. That
5638 # will be slower so hopefully there's not much to do.
5639 my @cmd = (@git_debrebase,
5640 qw(--noop-ok -funclean-mixed -funclean-ordering
5641 make-patches --quiet-would-amend));
5642 # We tolerate soe snags that gdr wouldn't, by default.
5646 failedcmd @cmd if system @cmd and $?!=7*256;
5650 $headref = git_rev_parse('HEAD');
5654 changedir $playground;
5656 my $upstreamversion = upstreamversion $version;
5658 if ($fopts->{'single-debian-patch'}) {
5659 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5661 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5665 runcmd_ordryrun_local
5666 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5669 sub unpack_playtree_mkwork ($) {
5672 mkdir "work" or die $!;
5674 mktree_in_ud_here();
5675 runcmd @git, qw(reset -q --hard), $headref;
5678 sub unpack_playtree_linkorigs ($$) {
5679 my ($upstreamversion, $fn) = @_;
5680 # calls $fn->($leafname);
5682 my $bpd_abs = bpd_abs();
5683 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5684 while ($!=0, defined(my $b = readdir QFD)) {
5685 my $f = bpd_abs()."/".$b;
5687 local ($debuglevel) = $debuglevel-1;
5688 printdebug "QF linkorigs $b, $f ?\n";
5690 next unless is_orig_file_of_vsn $b, $upstreamversion;
5691 printdebug "QF linkorigs $b, $f Y\n";
5692 link_ltarget $f, $b or die "$b $!";
5695 die "$buildproductsdir: $!" if $!;
5699 sub quilt_fixup_delete_pc () {
5700 runcmd @git, qw(rm -rqf .pc);
5702 Commit removal of .pc (quilt series tracking data)
5704 [dgit ($our_version) upgrade quilt-remove-pc]
5708 sub quilt_fixup_singlepatch ($$$) {
5709 my ($clogp, $headref, $upstreamversion) = @_;
5711 progress "starting quiltify (single-debian-patch)";
5713 # dpkg-source --commit generates new patches even if
5714 # single-debian-patch is in debian/source/options. In order to
5715 # get it to generate debian/patches/debian-changes, it is
5716 # necessary to build the source package.
5718 unpack_playtree_linkorigs($upstreamversion, sub { });
5719 unpack_playtree_mkwork($headref);
5721 rmtree("debian/patches");
5723 runcmd @dpkgsource, qw(-b .);
5725 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5726 rename srcfn("$upstreamversion", "/debian/patches"),
5727 "work/debian/patches";
5730 commit_quilty_patch();
5733 sub quilt_make_fake_dsc ($) {
5734 my ($upstreamversion) = @_;
5736 my $fakeversion="$upstreamversion-~~DGITFAKE";
5738 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5739 print $fakedsc <<END or die $!;
5742 Version: $fakeversion
5746 my $dscaddfile=sub {
5749 my $md = new Digest::MD5;
5751 my $fh = new IO::File $b, '<' or die "$b $!";
5756 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5759 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5761 my @files=qw(debian/source/format debian/rules
5762 debian/control debian/changelog);
5763 foreach my $maybe (qw(debian/patches debian/source/options
5764 debian/tests/control)) {
5765 next unless stat_exists "$maindir/$maybe";
5766 push @files, $maybe;
5769 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5770 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5772 $dscaddfile->($debtar);
5773 close $fakedsc or die $!;
5776 sub quilt_fakedsc2unapplied ($$) {
5777 my ($headref, $upstreamversion) = @_;
5778 # must be run in the playground
5779 # quilt_make_fake_dsc must have been called
5782 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5784 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5785 rename $fakexdir, "fake" or die "$fakexdir $!";
5789 remove_stray_gits("source package");
5790 mktree_in_ud_here();
5794 rmtree 'debian'; # git checkout commitish paths does not delete!
5795 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5796 my $unapplied=git_add_write_tree();
5797 printdebug "fake orig tree object $unapplied\n";
5801 sub quilt_check_splitbrain_cache ($$) {
5802 my ($headref, $upstreamversion) = @_;
5803 # Called only if we are in (potentially) split brain mode.
5804 # Called in playground.
5805 # Computes the cache key and looks in the cache.
5806 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5808 my $splitbrain_cachekey;
5811 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5812 # we look in the reflog of dgit-intern/quilt-cache
5813 # we look for an entry whose message is the key for the cache lookup
5814 my @cachekey = (qw(dgit), $our_version);
5815 push @cachekey, $upstreamversion;
5816 push @cachekey, $quilt_mode;
5817 push @cachekey, $headref;
5819 push @cachekey, hashfile('fake.dsc');
5821 my $srcshash = Digest::SHA->new(256);
5822 my %sfs = ( %INC, '$0(dgit)' => $0 );
5823 foreach my $sfk (sort keys %sfs) {
5824 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5825 $srcshash->add($sfk," ");
5826 $srcshash->add(hashfile($sfs{$sfk}));
5827 $srcshash->add("\n");
5829 push @cachekey, $srcshash->hexdigest();
5830 $splitbrain_cachekey = "@cachekey";
5832 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5834 my $cachehit = reflog_cache_lookup
5835 "refs/$splitbraincache", $splitbrain_cachekey;
5838 unpack_playtree_mkwork($headref);
5839 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5840 if ($cachehit ne $headref) {
5841 progress "dgit view: found cached ($saved)";
5842 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5844 return ($cachehit, $splitbrain_cachekey);
5846 progress "dgit view: found cached, no changes required";
5847 return ($headref, $splitbrain_cachekey);
5850 printdebug "splitbrain cache miss\n";
5851 return (undef, $splitbrain_cachekey);
5854 sub quilt_fixup_multipatch ($$$) {
5855 my ($clogp, $headref, $upstreamversion) = @_;
5857 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5860 # - honour any existing .pc in case it has any strangeness
5861 # - determine the git commit corresponding to the tip of
5862 # the patch stack (if there is one)
5863 # - if there is such a git commit, convert each subsequent
5864 # git commit into a quilt patch with dpkg-source --commit
5865 # - otherwise convert all the differences in the tree into
5866 # a single git commit
5870 # Our git tree doesn't necessarily contain .pc. (Some versions of
5871 # dgit would include the .pc in the git tree.) If there isn't
5872 # one, we need to generate one by unpacking the patches that we
5875 # We first look for a .pc in the git tree. If there is one, we
5876 # will use it. (This is not the normal case.)
5878 # Otherwise need to regenerate .pc so that dpkg-source --commit
5879 # can work. We do this as follows:
5880 # 1. Collect all relevant .orig from parent directory
5881 # 2. Generate a debian.tar.gz out of
5882 # debian/{patches,rules,source/format,source/options}
5883 # 3. Generate a fake .dsc containing just these fields:
5884 # Format Source Version Files
5885 # 4. Extract the fake .dsc
5886 # Now the fake .dsc has a .pc directory.
5887 # (In fact we do this in every case, because in future we will
5888 # want to search for a good base commit for generating patches.)
5890 # Then we can actually do the dpkg-source --commit
5891 # 1. Make a new working tree with the same object
5892 # store as our main tree and check out the main
5894 # 2. Copy .pc from the fake's extraction, if necessary
5895 # 3. Run dpkg-source --commit
5896 # 4. If the result has changes to debian/, then
5897 # - git add them them
5898 # - git add .pc if we had a .pc in-tree
5900 # 5. If we had a .pc in-tree, delete it, and git commit
5901 # 6. Back in the main tree, fast forward to the new HEAD
5903 # Another situation we may have to cope with is gbp-style
5904 # patches-unapplied trees.
5906 # We would want to detect these, so we know to escape into
5907 # quilt_fixup_gbp. However, this is in general not possible.
5908 # Consider a package with a one patch which the dgit user reverts
5909 # (with git revert or the moral equivalent).
5911 # That is indistinguishable in contents from a patches-unapplied
5912 # tree. And looking at the history to distinguish them is not
5913 # useful because the user might have made a confusing-looking git
5914 # history structure (which ought to produce an error if dgit can't
5915 # cope, not a silent reintroduction of an unwanted patch).
5917 # So gbp users will have to pass an option. But we can usually
5918 # detect their failure to do so: if the tree is not a clean
5919 # patches-applied tree, quilt linearisation fails, but the tree
5920 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5921 # they want --quilt=unapplied.
5923 # To help detect this, when we are extracting the fake dsc, we
5924 # first extract it with --skip-patches, and then apply the patches
5925 # afterwards with dpkg-source --before-build. That lets us save a
5926 # tree object corresponding to .origs.
5928 my $splitbrain_cachekey;
5930 quilt_make_fake_dsc($upstreamversion);
5932 if (quiltmode_splitbrain()) {
5934 ($cachehit, $splitbrain_cachekey) =
5935 quilt_check_splitbrain_cache($headref, $upstreamversion);
5936 return if $cachehit;
5938 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
5942 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5944 if (system @bbcmd) {
5945 failedcmd @bbcmd if $? < 0;
5947 failed to apply your git tree's patch stack (from debian/patches/) to
5948 the corresponding upstream tarball(s). Your source tree and .orig
5949 are probably too inconsistent. dgit can only fix up certain kinds of
5950 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5956 unpack_playtree_mkwork($headref);
5959 if (stat_exists ".pc") {
5961 progress "Tree already contains .pc - will use it then delete it.";
5964 rename '../fake/.pc','.pc' or die $!;
5967 changedir '../fake';
5969 my $oldtiptree=git_add_write_tree();
5970 printdebug "fake o+d/p tree object $unapplied\n";
5971 changedir '../work';
5974 # We calculate some guesswork now about what kind of tree this might
5975 # be. This is mostly for error reporting.
5981 # O = orig, without patches applied
5982 # A = "applied", ie orig with H's debian/patches applied
5983 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5984 \%editedignores, \@unrepres),
5985 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5986 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5990 foreach my $b (qw(01 02)) {
5991 foreach my $v (qw(O2H O2A H2A)) {
5992 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5995 printdebug "differences \@dl @dl.\n";
5998 "$us: base trees orig=%.20s o+d/p=%.20s",
5999 $unapplied, $oldtiptree;
6001 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
6002 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
6003 $dl[0], $dl[1], $dl[3], $dl[4],
6007 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
6009 forceable_fail [qw(unrepresentable)], <<END;
6010 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6015 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6016 push @failsuggestion, [ 'unapplied',
6017 "This might be a patches-unapplied branch." ];
6018 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6019 push @failsuggestion, [ 'applied',
6020 "This might be a patches-applied branch." ];
6022 push @failsuggestion, [ 'quilt-mode',
6023 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6025 push @failsuggestion, [ 'gitattrs',
6026 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6027 if stat_exists '.gitattributes';
6029 push @failsuggestion, [ 'origs',
6030 "Maybe orig tarball(s) are not identical to git representation?" ];
6032 if (quiltmode_splitbrain()) {
6033 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6034 $diffbits, \%editedignores,
6035 $splitbrain_cachekey);
6039 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6040 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6042 if (!open P, '>>', ".pc/applied-patches") {
6043 $!==&ENOENT or die $!;
6048 commit_quilty_patch();
6050 if ($mustdeletepc) {
6051 quilt_fixup_delete_pc();
6055 sub quilt_fixup_editor () {
6056 my $descfn = $ENV{$fakeeditorenv};
6057 my $editing = $ARGV[$#ARGV];
6058 open I1, '<', $descfn or die "$descfn: $!";
6059 open I2, '<', $editing or die "$editing: $!";
6060 unlink $editing or die "$editing: $!";
6061 open O, '>', $editing or die "$editing: $!";
6062 while (<I1>) { print O or die $!; } I1->error and die $!;
6065 $copying ||= m/^\-\-\- /;
6066 next unless $copying;
6069 I2->error and die $!;
6074 sub maybe_apply_patches_dirtily () {
6075 return unless $quilt_mode =~ m/gbp|unapplied/;
6076 print STDERR <<END or die $!;
6078 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6079 dgit: Have to apply the patches - making the tree dirty.
6080 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6083 $patches_applied_dirtily = 01;
6084 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6085 runcmd qw(dpkg-source --before-build .);
6088 sub maybe_unapply_patches_again () {
6089 progress "dgit: Unapplying patches again to tidy up the tree."
6090 if $patches_applied_dirtily;
6091 runcmd qw(dpkg-source --after-build .)
6092 if $patches_applied_dirtily & 01;
6094 if $patches_applied_dirtily & 02;
6095 $patches_applied_dirtily = 0;
6098 #----- other building -----
6100 our $clean_using_builder;
6101 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6102 # clean the tree before building (perhaps invoked indirectly by
6103 # whatever we are using to run the build), rather than separately
6104 # and explicitly by us.
6107 return if $clean_using_builder;
6108 if ($cleanmode eq 'dpkg-source') {
6109 maybe_apply_patches_dirtily();
6110 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6111 } elsif ($cleanmode eq 'dpkg-source-d') {
6112 maybe_apply_patches_dirtily();
6113 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6114 } elsif ($cleanmode eq 'git') {
6115 runcmd_ordryrun_local @git, qw(clean -xdf);
6116 } elsif ($cleanmode eq 'git-ff') {
6117 runcmd_ordryrun_local @git, qw(clean -xdff);
6118 } elsif ($cleanmode eq 'check') {
6119 my $leftovers = cmdoutput @git, qw(clean -xdn);
6120 if (length $leftovers) {
6121 print STDERR $leftovers, "\n" or die $!;
6122 fail "tree contains uncommitted files and --clean=check specified";
6124 } elsif ($cleanmode eq 'none') {
6131 badusage "clean takes no additional arguments" if @ARGV;
6134 maybe_unapply_patches_again();
6137 # return values from massage_dbp_args are one or both of these flags
6138 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6139 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6141 sub build_or_push_prep_early () {
6142 our $build_or_push_prep_early_done //= 0;
6143 return if $build_or_push_prep_early_done++;
6144 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6145 my $clogp = parsechangelog();
6146 $isuite = getfield $clogp, 'Distribution';
6147 $package = getfield $clogp, 'Source';
6148 $version = getfield $clogp, 'Version';
6149 $dscfn = dscfn($version);
6152 sub build_prep_early () {
6153 build_or_push_prep_early();
6158 sub build_prep ($) {
6161 # clean the tree if we're trying to include dirty changes in the
6162 # source package, or we are running the builder in $maindir
6163 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6164 build_maybe_quilt_fixup();
6166 my $pat = changespat $version;
6167 foreach my $f (glob "$buildproductsdir/$pat") {
6169 unlink $f or fail "remove old changes file $f: $!";
6171 progress "would remove $f";
6177 sub changesopts_initial () {
6178 my @opts =@changesopts[1..$#changesopts];
6181 sub changesopts_version () {
6182 if (!defined $changes_since_version) {
6185 @vsns = archive_query('archive_query');
6186 my @quirk = access_quirk();
6187 if ($quirk[0] eq 'backports') {
6188 local $isuite = $quirk[2];
6190 canonicalise_suite();
6191 push @vsns, archive_query('archive_query');
6197 "archive query failed (queried because --since-version not specified)";
6200 @vsns = map { $_->[0] } @vsns;
6201 @vsns = sort { -version_compare($a, $b) } @vsns;
6202 $changes_since_version = $vsns[0];
6203 progress "changelog will contain changes since $vsns[0]";
6205 $changes_since_version = '_';
6206 progress "package seems new, not specifying -v<version>";
6209 if ($changes_since_version ne '_') {
6210 return ("-v$changes_since_version");
6216 sub changesopts () {
6217 return (changesopts_initial(), changesopts_version());
6220 sub massage_dbp_args ($;$) {
6221 my ($cmd,$xargs) = @_;
6222 # Since we split the source build out so we can do strange things
6223 # to it, massage the arguments to dpkg-buildpackage so that the
6224 # main build doessn't build source (or add an argument to stop it
6225 # building source by default).
6226 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6227 # -nc has the side effect of specifying -b if nothing else specified
6228 # and some combinations of -S, -b, et al, are errors, rather than
6229 # later simply overriding earlie. So we need to:
6230 # - search the command line for these options
6231 # - pick the last one
6232 # - perhaps add our own as a default
6233 # - perhaps adjust it to the corresponding non-source-building version
6235 foreach my $l ($cmd, $xargs) {
6237 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6240 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6241 my $r = WANTSRC_BUILDER;
6242 printdebug "massage split $dmode.\n";
6243 if ($dmode =~ s/^--build=//) {
6245 my @d = split /,/, $dmode;
6246 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6247 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6248 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6249 fail "Wanted to build nothing!" unless $r;
6250 $dmode = '--build='. join ',', grep m/./, @d;
6253 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6254 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6255 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6258 printdebug "massage done $r $dmode.\n";
6260 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6266 my $wasdir = must_getcwd();
6267 changedir $buildproductsdir;
6272 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6273 sub postbuild_mergechanges ($) {
6274 my ($msg_if_onlyone) = @_;
6275 # If there is only one .changes file, fail with $msg_if_onlyone,
6276 # or if that is undef, be a no-op.
6277 # Returns the changes file to report to the user.
6278 my $pat = changespat $version;
6279 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6280 @changesfiles = sort {
6281 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6285 if (@changesfiles==1) {
6286 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6287 only one changes file from build (@changesfiles)
6289 $result = $changesfiles[0];
6290 } elsif (@changesfiles==2) {
6291 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6292 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6293 fail "$l found in binaries changes file $binchanges"
6296 runcmd_ordryrun_local @mergechanges, @changesfiles;
6297 my $multichanges = changespat $version,'multi';
6299 stat_exists $multichanges or fail "$multichanges: $!";
6300 foreach my $cf (glob $pat) {
6301 next if $cf eq $multichanges;
6302 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6305 $result = $multichanges;
6307 fail "wrong number of different changes files (@changesfiles)";
6309 printdone "build successful, results in $result\n" or die $!;
6312 sub midbuild_checkchanges () {
6313 my $pat = changespat $version;
6314 return if $rmchanges;
6315 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6317 $_ ne changespat $version,'source' and
6318 $_ ne changespat $version,'multi'
6321 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6322 Suggest you delete @unwanted.
6327 sub midbuild_checkchanges_vanilla ($) {
6329 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6332 sub postbuild_mergechanges_vanilla ($) {
6334 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6336 postbuild_mergechanges(undef);
6339 printdone "build successful\n";
6345 $buildproductsdir eq '..' or print STDERR <<END;
6346 $us: warning: build-products-dir set, but not supported by dpkg-buildpackage
6347 $us: warning: build-products-dir will be ignored; files will go to ..
6349 $buildproductsdir = '..';
6350 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6351 my $wantsrc = massage_dbp_args \@dbp;
6352 build_prep($wantsrc);
6353 if ($wantsrc & WANTSRC_SOURCE) {
6355 midbuild_checkchanges_vanilla $wantsrc;
6357 if ($wantsrc & WANTSRC_BUILDER) {
6358 push @dbp, changesopts_version();
6359 maybe_apply_patches_dirtily();
6360 runcmd_ordryrun_local @dbp;
6362 maybe_unapply_patches_again();
6363 postbuild_mergechanges_vanilla $wantsrc;
6367 $quilt_mode //= 'gbp';
6373 # gbp can make .origs out of thin air. In my tests it does this
6374 # even for a 1.0 format package, with no origs present. So I
6375 # guess it keys off just the version number. We don't know
6376 # exactly what .origs ought to exist, but let's assume that we
6377 # should run gbp if: the version has an upstream part and the main
6379 my $upstreamversion = upstreamversion $version;
6380 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6381 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6383 if ($gbp_make_orig) {
6385 $cleanmode = 'none'; # don't do it again
6388 my @dbp = @dpkgbuildpackage;
6390 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6392 if (!length $gbp_build[0]) {
6393 if (length executable_on_path('git-buildpackage')) {
6394 $gbp_build[0] = qw(git-buildpackage);
6396 $gbp_build[0] = 'gbp buildpackage';
6399 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6401 push @cmd, (qw(-us -uc --git-no-sign-tags),
6402 "--git-builder=".(shellquote @dbp));
6404 if ($gbp_make_orig) {
6405 my $priv = dgit_privdir();
6406 my $ok = "$priv/origs-gen-ok";
6407 unlink $ok or $!==&ENOENT or die $!;
6408 my @origs_cmd = @cmd;
6409 push @origs_cmd, qw(--git-cleaner=true);
6410 push @origs_cmd, "--git-prebuild=".
6411 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6412 push @origs_cmd, @ARGV;
6414 debugcmd @origs_cmd;
6416 do { local $!; stat_exists $ok; }
6417 or failedcmd @origs_cmd;
6419 dryrun_report @origs_cmd;
6423 build_prep($wantsrc);
6424 if ($wantsrc & WANTSRC_SOURCE) {
6426 midbuild_checkchanges_vanilla $wantsrc;
6428 if (!$clean_using_builder) {
6429 push @cmd, '--git-cleaner=true';
6432 maybe_unapply_patches_again();
6433 if ($wantsrc & WANTSRC_BUILDER) {
6434 push @cmd, changesopts();
6435 runcmd_ordryrun_local @cmd, @ARGV;
6437 postbuild_mergechanges_vanilla $wantsrc;
6439 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6441 sub building_source_in_playtree {
6442 # If $includedirty, we have to build the source package from the
6443 # working tree, not a playtree, so that uncommitted changes are
6444 # included (copying or hardlinking them into the playtree could
6447 # Note that if we are building a source package in split brain
6448 # mode we do not support including uncommitted changes, because
6449 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6450 # building a source package)) => !$includedirty
6451 return !$includedirty;
6455 $sourcechanges = changespat $version,'source';
6457 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6458 or fail "remove $sourcechanges: $!";
6460 my @cmd = (@dpkgsource, qw(-b --));
6462 if (building_source_in_playtree()) {
6464 my $headref = git_rev_parse('HEAD');
6465 # If we are in split brain, there is already a playtree with
6466 # the thing we should package into a .dsc (thanks to quilt
6467 # fixup). If not, make a playtree
6468 prep_ud() unless $split_brain;
6469 changedir $playground;
6470 unless ($split_brain) {
6471 my $upstreamversion = upstreamversion $version;
6472 unpack_playtree_linkorigs($upstreamversion, sub { });
6473 unpack_playtree_mkwork($headref);
6477 $leafdir = basename $maindir;
6480 runcmd_ordryrun_local @cmd, $leafdir;
6483 runcmd_ordryrun_local qw(sh -ec),
6484 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6485 @dpkggenchanges, qw(-S), changesopts();
6488 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6489 $dsc = parsecontrol($dscfn, "source package");
6493 printdebug " renaming ($why) $l\n";
6494 rename "$l", bpd_abs()."/$l"
6495 or fail "put in place new built file ($l): $!";
6497 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6498 $l =~ m/\S+$/ or next;
6501 $mv->('dsc', $dscfn);
6502 $mv->('changes', $sourcechanges);
6507 sub cmd_build_source {
6508 badusage "build-source takes no additional arguments" if @ARGV;
6509 build_prep(WANTSRC_SOURCE);
6511 maybe_unapply_patches_again();
6512 printdone "source built, results in $dscfn and $sourcechanges";
6515 sub cmd_push_source {
6517 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6518 "sense with push-source!" if $includedirty;
6519 build_maybe_quilt_fixup();
6521 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6522 "source changes file");
6523 unless (test_source_only_changes($changes)) {
6524 fail "user-specified changes file is not source-only";
6527 # Building a source package is very fast, so just do it
6529 die "er, patches are applied dirtily but shouldn't be.."
6530 if $patches_applied_dirtily;
6531 $changesfile = $sourcechanges;
6536 sub binary_builder {
6537 my ($bbuilder, $pbmc_msg, @args) = @_;
6538 build_prep(WANTSRC_SOURCE);
6540 midbuild_checkchanges();
6543 stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
6544 stat_exists $sourcechanges
6545 or fail "$sourcechanges (in build products dir): $!";
6547 runcmd_ordryrun_local @$bbuilder, @args;
6549 maybe_unapply_patches_again();
6551 postbuild_mergechanges($pbmc_msg);
6557 binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
6558 perhaps you need to pass -A ? (sbuild's default is to build only
6559 arch-specific binaries; dgit 1.4 used to override that.)
6564 my ($pbuilder) = @_;
6566 # @ARGV is allowed to contain only things that should be passed to
6567 # pbuilder under debbuildopts; just massage those
6568 my $wantsrc = massage_dbp_args \@ARGV;
6569 fail "you asked for a builder but your debbuildopts didn't ask for".
6570 " any binaries -- is this really what you meant?"
6571 unless $wantsrc & WANTSRC_BUILDER;
6572 fail "we must build a .dsc to pass to the builder but your debbuiltopts".
6573 " forbids the building of a source package; cannot continue"
6574 unless $wantsrc & WANTSRC_SOURCE;
6575 # We do not want to include the verb "build" in @pbuilder because
6576 # the user can customise @pbuilder and they shouldn't be required
6577 # to include "build" in their customised value. However, if the
6578 # user passes any additional args to pbuilder using the dgit
6579 # option --pbuilder:foo, such args need to come after the "build"
6580 # verb. opts_opt_multi_cmd does all of that.
6581 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6582 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6587 pbuilder(\@pbuilder);
6590 sub cmd_cowbuilder {
6591 pbuilder(\@cowbuilder);
6594 sub cmd_quilt_fixup {
6595 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6598 build_maybe_quilt_fixup();
6601 sub cmd_print_unapplied_treeish {
6602 badusage "incorrect arguments to dgit print-unapplied-treeish" if @ARGV;
6603 my $headref = git_rev_parse('HEAD');
6604 my $clogp = commit_getclogp $headref;
6605 $package = getfield $clogp, 'Source';
6606 $version = getfield $clogp, 'Version';
6607 $isuite = getfield $clogp, 'Distribution';
6608 $csuite = $isuite; # we want this to be offline!
6612 changedir $playground;
6613 my $uv = upstreamversion $version;
6614 quilt_make_fake_dsc($uv);
6615 my $u = quilt_fakedsc2unapplied($headref, $uv);
6616 print $u, "\n" or die $!;
6619 sub import_dsc_result {
6620 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6621 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6623 check_gitattrs($newhash, "source tree");
6625 progress "dgit: import-dsc: $what_msg";
6628 sub cmd_import_dsc {
6632 last unless $ARGV[0] =~ m/^-/;
6635 if (m/^--require-valid-signature$/) {
6638 badusage "unknown dgit import-dsc sub-option \`$_'";
6642 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6643 my ($dscfn, $dstbranch) = @ARGV;
6645 badusage "dry run makes no sense with import-dsc" unless act_local();
6647 my $force = $dstbranch =~ s/^\+// ? +1 :
6648 $dstbranch =~ s/^\.\.// ? -1 :
6650 my $info = $force ? " $&" : '';
6651 $info = "$dscfn$info";
6653 my $specbranch = $dstbranch;
6654 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6655 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6657 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6658 my $chead = cmdoutput_errok @symcmd;
6659 defined $chead or $?==256 or failedcmd @symcmd;
6661 fail "$dstbranch is checked out - will not update it"
6662 if defined $chead and $chead eq $dstbranch;
6664 my $oldhash = git_get_ref $dstbranch;
6666 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6667 $dscdata = do { local $/ = undef; <D>; };
6668 D->error and fail "read $dscfn: $!";
6671 # we don't normally need this so import it here
6672 use Dpkg::Source::Package;
6673 my $dp = new Dpkg::Source::Package filename => $dscfn,
6674 require_valid_signature => $needsig;
6676 local $SIG{__WARN__} = sub {
6678 return unless $needsig;
6679 fail "import-dsc signature check failed";
6681 if (!$dp->is_signed()) {
6682 warn "$us: warning: importing unsigned .dsc\n";
6684 my $r = $dp->check_signature();
6685 die "->check_signature => $r" if $needsig && $r;
6691 $package = getfield $dsc, 'Source';
6693 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6694 unless forceing [qw(import-dsc-with-dgit-field)];
6695 parse_dsc_field_def_dsc_distro();
6697 $isuite = 'DGIT-IMPORT-DSC';
6698 $idistro //= $dsc_distro;
6702 if (defined $dsc_hash) {
6703 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6704 resolve_dsc_field_commit undef, undef;
6706 if (defined $dsc_hash) {
6707 my @cmd = (qw(sh -ec),
6708 "echo $dsc_hash | git cat-file --batch-check");
6709 my $objgot = cmdoutput @cmd;
6710 if ($objgot =~ m#^\w+ missing\b#) {
6712 .dsc contains Dgit field referring to object $dsc_hash
6713 Your git tree does not have that object. Try `git fetch' from a
6714 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6717 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6719 progress "Not fast forward, forced update.";
6721 fail "Not fast forward to $dsc_hash";
6724 import_dsc_result $dstbranch, $dsc_hash,
6725 "dgit import-dsc (Dgit): $info",
6726 "updated git ref $dstbranch";
6731 Branch $dstbranch already exists
6732 Specify ..$specbranch for a pseudo-merge, binding in existing history
6733 Specify +$specbranch to overwrite, discarding existing history
6735 if $oldhash && !$force;
6737 my @dfi = dsc_files_info();
6738 foreach my $fi (@dfi) {
6739 my $f = $fi->{Filename};
6740 my $here = "$buildproductsdir/$f";
6743 fail "lstat $here works but stat gives $! !";
6745 fail "stat $here: $!" unless $! == ENOENT;
6747 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6749 } elsif ($dscfn =~ m#^/#) {
6752 fail "cannot import $dscfn which seems to be inside working tree!";
6754 $there =~ s#/+[^/]+$## or
6755 fail "import $dscfn requires ../$f, but it does not exist";
6757 my $test = $there =~ m{^/} ? $there : "../$there";
6758 stat $test or fail "import $dscfn requires $test, but: $!";
6759 symlink $there, $here or fail "symlink $there to $here: $!";
6760 progress "made symlink $here -> $there";
6761 # print STDERR Dumper($fi);
6763 my @mergeinputs = generate_commits_from_dsc();
6764 die unless @mergeinputs == 1;
6766 my $newhash = $mergeinputs[0]{Commit};
6770 progress "Import, forced update - synthetic orphan git history.";
6771 } elsif ($force < 0) {
6772 progress "Import, merging.";
6773 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6774 my $version = getfield $dsc, 'Version';
6775 my $clogp = commit_getclogp $newhash;
6776 my $authline = clogp_authline $clogp;
6777 $newhash = make_commit_text <<END;
6784 Merge $package ($version) import into $dstbranch
6787 die; # caught earlier
6791 import_dsc_result $dstbranch, $newhash,
6792 "dgit import-dsc: $info",
6793 "results are in in git ref $dstbranch";
6796 sub pre_archive_api_query () {
6797 not_necessarily_a_tree();
6799 sub cmd_archive_api_query {
6800 badusage "need only 1 subpath argument" unless @ARGV==1;
6801 my ($subpath) = @ARGV;
6802 local $isuite = 'DGIT-API-QUERY-CMD';
6803 my @cmd = archive_api_query_cmd($subpath);
6806 exec @cmd or fail "exec curl: $!\n";
6809 sub repos_server_url () {
6810 $package = '_dgit-repos-server';
6811 local $access_forpush = 1;
6812 local $isuite = 'DGIT-REPOS-SERVER';
6813 my $url = access_giturl();
6816 sub pre_clone_dgit_repos_server () {
6817 not_necessarily_a_tree();
6819 sub cmd_clone_dgit_repos_server {
6820 badusage "need destination argument" unless @ARGV==1;
6821 my ($destdir) = @ARGV;
6822 my $url = repos_server_url();
6823 my @cmd = (@git, qw(clone), $url, $destdir);
6825 exec @cmd or fail "exec git clone: $!\n";
6828 sub pre_print_dgit_repos_server_source_url () {
6829 not_necessarily_a_tree();
6831 sub cmd_print_dgit_repos_server_source_url {
6832 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6834 my $url = repos_server_url();
6835 print $url, "\n" or die $!;
6838 sub pre_print_dpkg_source_ignores {
6839 not_necessarily_a_tree();
6841 sub cmd_print_dpkg_source_ignores {
6842 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6844 print "@dpkg_source_ignores\n" or die $!;
6847 sub cmd_setup_mergechangelogs {
6848 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6849 local $isuite = 'DGIT-SETUP-TREE';
6850 setup_mergechangelogs(1);
6853 sub cmd_setup_useremail {
6854 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6855 local $isuite = 'DGIT-SETUP-TREE';
6859 sub cmd_setup_gitattributes {
6860 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6861 local $isuite = 'DGIT-SETUP-TREE';
6865 sub cmd_setup_new_tree {
6866 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6867 local $isuite = 'DGIT-SETUP-TREE';
6871 #---------- argument parsing and main program ----------
6874 print "dgit version $our_version\n" or die $!;
6878 our (%valopts_long, %valopts_short);
6879 our (%funcopts_long);
6881 our (@modeopt_cfgs);
6883 sub defvalopt ($$$$) {
6884 my ($long,$short,$val_re,$how) = @_;
6885 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6886 $valopts_long{$long} = $oi;
6887 $valopts_short{$short} = $oi;
6888 # $how subref should:
6889 # do whatever assignemnt or thing it likes with $_[0]
6890 # if the option should not be passed on to remote, @rvalopts=()
6891 # or $how can be a scalar ref, meaning simply assign the value
6894 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6895 defvalopt '--distro', '-d', '.+', \$idistro;
6896 defvalopt '', '-k', '.+', \$keyid;
6897 defvalopt '--existing-package','', '.*', \$existing_package;
6898 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6899 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6900 defvalopt '--package', '-p', $package_re, \$package;
6901 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6903 defvalopt '', '-C', '.+', sub {
6904 ($changesfile) = (@_);
6905 if ($changesfile =~ s#^(.*)/##) {
6906 $buildproductsdir = $1;
6910 defvalopt '--initiator-tempdir','','.*', sub {
6911 ($initiator_tempdir) = (@_);
6912 $initiator_tempdir =~ m#^/# or
6913 badusage "--initiator-tempdir must be used specify an".
6914 " absolute, not relative, directory."
6917 sub defoptmodes ($@) {
6918 my ($varref, $cfgkey, $default, %optmap) = @_;
6920 while (my ($opt,$val) = each %optmap) {
6921 $funcopts_long{$opt} = sub { $$varref = $val; };
6922 $permit{$val} = $val;
6924 push @modeopt_cfgs, {
6927 Default => $default,
6932 defoptmodes \$dodep14tag, qw( dep14tag want
6935 --always-dep14tag always );
6940 if (defined $ENV{'DGIT_SSH'}) {
6941 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6942 } elsif (defined $ENV{'GIT_SSH'}) {
6943 @ssh = ($ENV{'GIT_SSH'});
6951 if (!defined $val) {
6952 badusage "$what needs a value" unless @ARGV;
6954 push @rvalopts, $val;
6956 badusage "bad value \`$val' for $what" unless
6957 $val =~ m/^$oi->{Re}$(?!\n)/s;
6958 my $how = $oi->{How};
6959 if (ref($how) eq 'SCALAR') {
6964 push @ropts, @rvalopts;
6968 last unless $ARGV[0] =~ m/^-/;
6972 if (m/^--dry-run$/) {
6975 } elsif (m/^--damp-run$/) {
6978 } elsif (m/^--no-sign$/) {
6981 } elsif (m/^--help$/) {
6983 } elsif (m/^--version$/) {
6985 } elsif (m/^--new$/) {
6988 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6989 ($om = $opts_opt_map{$1}) &&
6993 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6994 !$opts_opt_cmdonly{$1} &&
6995 ($om = $opts_opt_map{$1})) {
6998 } elsif (m/^--(gbp|dpm)$/s) {
6999 push @ropts, "--quilt=$1";
7001 } elsif (m/^--(?:ignore|include)-dirty$/s) {
7004 } elsif (m/^--no-quilt-fixup$/s) {
7006 $quilt_mode = 'nocheck';
7007 } elsif (m/^--no-rm-on-error$/s) {
7010 } elsif (m/^--no-chase-dsc-distro$/s) {
7012 $chase_dsc_distro = 0;
7013 } elsif (m/^--overwrite$/s) {
7015 $overwrite_version = '';
7016 } elsif (m/^--overwrite=(.+)$/s) {
7018 $overwrite_version = $1;
7019 } elsif (m/^--delayed=(\d+)$/s) {
7022 } elsif (my ($k,$v) =
7023 m/^--save-(dgit-view)=(.+)$/s ||
7024 m/^--(dgit-view)-save=(.+)$/s
7027 $v =~ s#^(?!refs/)#refs/heads/#;
7028 $internal_object_save{$k} = $v;
7029 } elsif (m/^--(no-)?rm-old-changes$/s) {
7032 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7034 push @deliberatelies, $&;
7035 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7039 } elsif (m/^--force-/) {
7041 "$us: warning: ignoring unknown force option $_\n";
7043 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7044 # undocumented, for testing
7046 $tagformat_want = [ $1, 'command line', 1 ];
7047 # 1 menas overrides distro configuration
7048 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7049 # undocumented, for testing
7051 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7052 # ^ it's supposed to be an array ref
7053 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7054 $val = $2 ? $' : undef; #';
7055 $valopt->($oi->{Long});
7056 } elsif ($funcopts_long{$_}) {
7058 $funcopts_long{$_}();
7060 badusage "unknown long option \`$_'";
7067 } elsif (s/^-L/-/) {
7070 } elsif (s/^-h/-/) {
7072 } elsif (s/^-D/-/) {
7076 } elsif (s/^-N/-/) {
7081 push @changesopts, $_;
7083 } elsif (s/^-wn$//s) {
7085 $cleanmode = 'none';
7086 } elsif (s/^-wg$//s) {
7089 } elsif (s/^-wgf$//s) {
7091 $cleanmode = 'git-ff';
7092 } elsif (s/^-wd$//s) {
7094 $cleanmode = 'dpkg-source';
7095 } elsif (s/^-wdd$//s) {
7097 $cleanmode = 'dpkg-source-d';
7098 } elsif (s/^-wc$//s) {
7100 $cleanmode = 'check';
7101 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7102 push @git, '-c', $&;
7103 $gitcfgs{cmdline}{$1} = [ $2 ];
7104 } elsif (s/^-c([^=]+)$//s) {
7105 push @git, '-c', $&;
7106 $gitcfgs{cmdline}{$1} = [ 'true' ];
7107 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7109 $val = undef unless length $val;
7110 $valopt->($oi->{Short});
7113 badusage "unknown short option \`$_'";
7120 sub check_env_sanity () {
7121 my $blocked = new POSIX::SigSet;
7122 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7125 foreach my $name (qw(PIPE CHLD)) {
7126 my $signame = "SIG$name";
7127 my $signum = eval "POSIX::$signame" // die;
7128 die "$signame is set to something other than SIG_DFL\n"
7129 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7130 $blocked->ismember($signum) and
7131 die "$signame is blocked\n";
7137 On entry to dgit, $@
7138 This is a bug produced by something in in your execution environment.
7144 sub parseopts_late_defaults () {
7145 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7146 if defined $idistro;
7147 $isuite //= cfg('dgit.default.default-suite');
7149 foreach my $k (keys %opts_opt_map) {
7150 my $om = $opts_opt_map{$k};
7152 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7154 badcfg "cannot set command for $k"
7155 unless length $om->[0];
7159 foreach my $c (access_cfg_cfgs("opts-$k")) {
7161 map { $_ ? @$_ : () }
7162 map { $gitcfgs{$_}{$c} }
7163 reverse @gitcfgsources;
7164 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7165 "\n" if $debuglevel >= 4;
7167 badcfg "cannot configure options for $k"
7168 if $opts_opt_cmdonly{$k};
7169 my $insertpos = $opts_cfg_insertpos{$k};
7170 @$om = ( @$om[0..$insertpos-1],
7172 @$om[$insertpos..$#$om] );
7176 if (!defined $rmchanges) {
7177 local $access_forpush;
7178 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7181 if (!defined $quilt_mode) {
7182 local $access_forpush;
7183 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7184 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7186 $quilt_mode =~ m/^($quilt_modes_re)$/
7187 or badcfg "unknown quilt-mode \`$quilt_mode'";
7191 foreach my $moc (@modeopt_cfgs) {
7192 local $access_forpush;
7193 my $vr = $moc->{Var};
7194 next if defined $$vr;
7195 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7196 my $v = $moc->{Vals}{$$vr};
7197 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7201 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7202 if $split_brain && $includedirty;
7204 if (!defined $cleanmode) {
7205 local $access_forpush;
7206 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7207 $cleanmode //= 'dpkg-source';
7209 badcfg "unknown clean-mode \`$cleanmode'" unless
7210 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7213 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7214 $buildproductsdir //= '..';
7215 $bpd_glob = $buildproductsdir;
7216 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7219 setlocale(LC_MESSAGES, "");
7222 if ($ENV{$fakeeditorenv}) {
7224 quilt_fixup_editor();
7230 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7231 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7232 if $dryrun_level == 1;
7234 print STDERR $helpmsg or die $!;
7237 $cmd = $subcommand = shift @ARGV;
7240 my $pre_fn = ${*::}{"pre_$cmd"};
7241 $pre_fn->() if $pre_fn;
7243 record_maindir if $invoked_in_git_tree;
7246 my $fn = ${*::}{"cmd_$cmd"};
7247 $fn or badusage "unknown operation $cmd";