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;
26 use Debian::Dgit qw(:DEFAULT :playground);
32 use Dpkg::Control::Hash;
34 use File::Temp qw(tempdir);
37 use Dpkg::Compression;
38 use Dpkg::Compression::Process;
43 use List::MoreUtils qw(pairwise);
44 use Text::Glob qw(match_glob);
45 use Fcntl qw(:DEFAULT :flock);
50 our $our_version = 'UNRELEASED'; ###substituted###
51 our $absurdity = undef; ###substituted###
53 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
64 our $dryrun_level = 0;
66 our $buildproductsdir;
69 our $includedirty = 0;
73 our $existing_package = 'dpkg';
75 our $changes_since_version;
77 our $overwrite_version; # undef: not specified; '': check changelog
79 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
81 our %internal_object_save;
82 our $we_are_responder;
83 our $we_are_initiator;
84 our $initiator_tempdir;
85 our $patches_applied_dirtily = 00;
89 our $chase_dsc_distro=1;
91 our %forceopts = map { $_=>0 }
92 qw(unrepresentable unsupported-source-format
93 dsc-changes-mismatch changes-origs-exactly
94 uploading-binaries uploading-source-only
95 import-gitapply-absurd
96 import-gitapply-no-absurd
97 import-dsc-with-dgit-field);
99 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
101 our $suite_re = '[-+.0-9a-z]+';
102 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
104 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
105 our $splitbraincache = 'dgit-intern/quilt-cache';
106 our $rewritemap = 'dgit-rewrite/map';
108 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
110 our (@git) = qw(git);
111 our (@dget) = qw(dget);
112 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
113 our (@dput) = qw(dput);
114 our (@debsign) = qw(debsign);
115 our (@gpg) = qw(gpg);
116 our (@sbuild) = (qw(sbuild --no-source));
118 our (@dgit) = qw(dgit);
119 our (@git_debrebase) = qw(git-debrebase);
120 our (@aptget) = qw(apt-get);
121 our (@aptcache) = qw(apt-cache);
122 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
123 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
124 our (@dpkggenchanges) = qw(dpkg-genchanges);
125 our (@mergechanges) = qw(mergechanges -f);
126 our (@gbp_build) = ('');
127 our (@gbp_pq) = ('gbp pq');
128 our (@changesopts) = ('');
129 our (@pbuilder) = ("sudo -E pbuilder");
130 our (@cowbuilder) = ("sudo -E cowbuilder");
132 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
135 'debsign' => \@debsign,
137 'sbuild' => \@sbuild,
141 'git-debrebase' => \@git_debrebase,
142 'apt-get' => \@aptget,
143 'apt-cache' => \@aptcache,
144 'dpkg-source' => \@dpkgsource,
145 'dpkg-buildpackage' => \@dpkgbuildpackage,
146 'dpkg-genchanges' => \@dpkggenchanges,
147 'gbp-build' => \@gbp_build,
148 'gbp-pq' => \@gbp_pq,
149 'ch' => \@changesopts,
150 'mergechanges' => \@mergechanges,
151 'pbuilder' => \@pbuilder,
152 'cowbuilder' => \@cowbuilder);
154 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
155 our %opts_cfg_insertpos = map {
157 scalar @{ $opts_opt_map{$_} }
158 } keys %opts_opt_map;
160 sub parseopts_late_defaults();
161 sub setup_gitattrs(;$);
162 sub check_gitattrs($$);
169 our $supplementary_message = '';
170 our $split_brain = 0;
174 return unless forkcheck_mainprocess();
175 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
178 our $remotename = 'dgit';
179 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
183 if (!defined $absurdity) {
185 $absurdity =~ s{/[^/]+$}{/absurd} or die;
189 my ($v,$distro) = @_;
190 return $tagformatfn->($v, $distro);
193 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
195 sub lbranch () { return "$branchprefix/$csuite"; }
196 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
197 sub lref () { return "refs/heads/".lbranch(); }
198 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
199 sub rrref () { return server_ref($csuite); }
202 my ($vsn, $sfx) = @_;
203 return &source_file_leafname($package, $vsn, $sfx);
205 sub is_orig_file_of_vsn ($$) {
206 my ($f, $upstreamvsn) = @_;
207 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
212 return srcfn($vsn,".dsc");
215 sub changespat ($;$) {
216 my ($vsn, $arch) = @_;
217 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
226 return unless forkcheck_mainprocess();
227 foreach my $f (@end) {
229 print STDERR "$us: cleanup: $@" if length $@;
233 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
235 sub forceable_fail ($$) {
236 my ($forceoptsl, $msg) = @_;
237 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
238 print STDERR "warning: overriding problem due to --force:\n". $msg;
242 my ($forceoptsl) = @_;
243 my @got = grep { $forceopts{$_} } @$forceoptsl;
244 return 0 unless @got;
246 "warning: skipping checks or functionality due to --force-$got[0]\n";
249 sub no_such_package () {
250 print STDERR "$us: package $package does not exist in suite $isuite\n";
254 sub deliberately ($) {
256 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
259 sub deliberately_not_fast_forward () {
260 foreach (qw(not-fast-forward fresh-repo)) {
261 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
265 sub quiltmode_splitbrain () {
266 $quilt_mode =~ m/gbp|dpm|unapplied/;
269 sub opts_opt_multi_cmd {
272 push @cmd, split /\s+/, shift @_;
279 return opts_opt_multi_cmd [], @gbp_pq;
282 sub dgit_privdir () {
283 our $dgit_privdir_made //= ensure_a_playground 'dgit';
287 my $r = $buildproductsdir;
288 $r = "$maindir/$r" unless $r =~ m{^/};
292 sub get_tree_of_commit ($) {
293 my ($commitish) = @_;
294 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
295 $cdata =~ m/\n\n/; $cdata = $`;
296 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
300 sub branch_gdr_info ($$) {
301 my ($symref, $head) = @_;
302 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
303 gdr_ffq_prev_branchinfo($symref);
304 return () unless $status eq 'branch';
305 $ffq_prev = git_get_ref $ffq_prev;
306 $gdrlast = git_get_ref $gdrlast;
307 $gdrlast &&= is_fast_fwd $gdrlast, $head;
308 return ($ffq_prev, $gdrlast);
311 sub branch_is_gdr_unstitched_ff ($$$) {
312 my ($symref, $head, $ancestor) = @_;
313 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
314 return 0 unless $ffq_prev;
315 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
319 sub branch_is_gdr ($) {
321 # This is quite like git-debrebase's keycommits.
322 # We have our own implementation because:
323 # - our algorighm can do fewer tests so is faster
324 # - it saves testing to see if gdr is installed
326 # NB we use this jsut for deciding whether to run gdr make-patches
327 # Before reusing this algorithm for somthing else, its
328 # suitability should be reconsidered.
331 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
332 printdebug "branch_is_gdr $head...\n";
333 my $get_patches = sub {
334 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
337 my $tip_patches = $get_patches->($head);
340 my $cdata = git_cat_file $walk, 'commit';
341 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
342 if ($msg =~ m{^\[git-debrebase\ (
343 anchor | changelog | make-patches |
344 merged-breakwater | pseudomerge
346 # no need to analyse this - it's sufficient
347 # (gdr classifications: Anchor, MergedBreakwaters)
348 # (made by gdr: Pseudomerge, Changelog)
349 printdebug "branch_is_gdr $walk gdr $1 YES\n";
352 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
354 my $walk_tree = get_tree_of_commit $walk;
355 foreach my $p (@parents) {
356 my $p_tree = get_tree_of_commit $p;
357 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
358 # (gdr classification: Pseudomerge; not made by gdr)
359 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
365 # some other non-gdr merge
366 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
367 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
371 # (gdr classification: ?)
372 printdebug "branch_is_gdr $walk ?-octopus NO\n";
375 if ($get_patches->($walk) ne $tip_patches) {
376 # Our parent added, removed, or edited patches, and wasn't
377 # a gdr make-patches commit. gdr make-patches probably
378 # won't do that well, then.
379 # (gdr classification of parent: AddPatches or ?)
380 printdebug "branch_is_gdr $walk ?-patches NO\n";
383 if ($tip_patches eq '' and
384 !defined git_cat_file "$walk:debian") {
385 # (gdr classification of parent: BreakwaterStart
386 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
389 # (gdr classification: Upstream Packaging Mixed Changelog)
390 printdebug "branch_is_gdr $walk plain\n"
396 #---------- remote protocol support, common ----------
398 # remote push initiator/responder protocol:
399 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
400 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
401 # < dgit-remote-push-ready <actual-proto-vsn>
408 # > supplementary-message NBYTES # $protovsn >= 3
413 # > file parsed-changelog
414 # [indicates that output of dpkg-parsechangelog follows]
415 # > data-block NBYTES
416 # > [NBYTES bytes of data (no newline)]
417 # [maybe some more blocks]
426 # > param head DGIT-VIEW-HEAD
427 # > param csuite SUITE
428 # > param tagformat old|new
429 # > param maint-view MAINT-VIEW-HEAD
431 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
432 # > file buildinfo # for buildinfos to sign
434 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
435 # # goes into tag, for replay prevention
438 # [indicates that signed tag is wanted]
439 # < data-block NBYTES
440 # < [NBYTES bytes of data (no newline)]
441 # [maybe some more blocks]
445 # > want signed-dsc-changes
446 # < data-block NBYTES [transfer of signed dsc]
448 # < data-block NBYTES [transfer of signed changes]
450 # < data-block NBYTES [transfer of each signed buildinfo
451 # [etc] same number and order as "file buildinfo"]
459 sub i_child_report () {
460 # Sees if our child has died, and reap it if so. Returns a string
461 # describing how it died if it failed, or undef otherwise.
462 return undef unless $i_child_pid;
463 my $got = waitpid $i_child_pid, WNOHANG;
464 return undef if $got <= 0;
465 die unless $got == $i_child_pid;
466 $i_child_pid = undef;
467 return undef unless $?;
468 return "build host child ".waitstatusmsg();
473 fail "connection lost: $!" if $fh->error;
474 fail "protocol violation; $m not expected";
477 sub badproto_badread ($$) {
479 fail "connection lost: $!" if $!;
480 my $report = i_child_report();
481 fail $report if defined $report;
482 badproto $fh, "eof (reading $wh)";
485 sub protocol_expect (&$) {
486 my ($match, $fh) = @_;
489 defined && chomp or badproto_badread $fh, "protocol message";
497 badproto $fh, "\`$_'";
500 sub protocol_send_file ($$) {
501 my ($fh, $ourfn) = @_;
502 open PF, "<", $ourfn or die "$ourfn: $!";
505 my $got = read PF, $d, 65536;
506 die "$ourfn: $!" unless defined $got;
508 print $fh "data-block ".length($d)."\n" or die $!;
509 print $fh $d or die $!;
511 PF->error and die "$ourfn $!";
512 print $fh "data-end\n" or die $!;
516 sub protocol_read_bytes ($$) {
517 my ($fh, $nbytes) = @_;
518 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
520 my $got = read $fh, $d, $nbytes;
521 $got==$nbytes or badproto_badread $fh, "data block";
525 sub protocol_receive_file ($$) {
526 my ($fh, $ourfn) = @_;
527 printdebug "() $ourfn\n";
528 open PF, ">", $ourfn or die "$ourfn: $!";
530 my ($y,$l) = protocol_expect {
531 m/^data-block (.*)$/ ? (1,$1) :
532 m/^data-end$/ ? (0,) :
536 my $d = protocol_read_bytes $fh, $l;
537 print PF $d or die $!;
542 #---------- remote protocol support, responder ----------
544 sub responder_send_command ($) {
546 return unless $we_are_responder;
547 # called even without $we_are_responder
548 printdebug ">> $command\n";
549 print PO $command, "\n" or die $!;
552 sub responder_send_file ($$) {
553 my ($keyword, $ourfn) = @_;
554 return unless $we_are_responder;
555 printdebug "]] $keyword $ourfn\n";
556 responder_send_command "file $keyword";
557 protocol_send_file \*PO, $ourfn;
560 sub responder_receive_files ($@) {
561 my ($keyword, @ourfns) = @_;
562 die unless $we_are_responder;
563 printdebug "[[ $keyword @ourfns\n";
564 responder_send_command "want $keyword";
565 foreach my $fn (@ourfns) {
566 protocol_receive_file \*PI, $fn;
569 protocol_expect { m/^files-end$/ } \*PI;
572 #---------- remote protocol support, initiator ----------
574 sub initiator_expect (&) {
576 protocol_expect { &$match } \*RO;
579 #---------- end remote code ----------
582 if ($we_are_responder) {
584 responder_send_command "progress ".length($m) or die $!;
585 print PO $m or die $!;
595 $ua = LWP::UserAgent->new();
599 progress "downloading $what...";
600 my $r = $ua->get(@_) or die $!;
601 return undef if $r->code == 404;
602 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
603 return $r->decoded_content(charset => 'none');
606 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
608 sub act_local () { return $dryrun_level <= 1; }
609 sub act_scary () { return !$dryrun_level; }
612 if (!$dryrun_level) {
613 progress "$us ok: @_";
615 progress "would be ok: @_ (but dry run only)";
620 printcmd(\*STDERR,$debugprefix."#",@_);
623 sub runcmd_ordryrun {
631 sub runcmd_ordryrun_local {
639 our $helpmsg = <<END;
641 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
642 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
643 dgit [dgit-opts] build [dpkg-buildpackage-opts]
644 dgit [dgit-opts] sbuild [sbuild-opts]
645 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
646 dgit [dgit-opts] push [dgit-opts] [suite]
647 dgit [dgit-opts] push-source [dgit-opts] [suite]
648 dgit [dgit-opts] rpush build-host:build-dir ...
649 important dgit options:
650 -k<keyid> sign tag and package with <keyid> instead of default
651 --dry-run -n do not change anything, but go through the motions
652 --damp-run -L like --dry-run but make local changes, without signing
653 --new -N allow introducing a new package
654 --debug -D increase debug level
655 -c<name>=<value> set git config option (used directly by dgit too)
658 our $later_warning_msg = <<END;
659 Perhaps the upload is stuck in incoming. Using the version from git.
663 print STDERR "$us: @_\n", $helpmsg or die $!;
668 @ARGV or badusage "too few arguments";
669 return scalar shift @ARGV;
673 not_necessarily_a_tree();
676 print $helpmsg or die $!;
680 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
682 our %defcfg = ('dgit.default.distro' => 'debian',
683 'dgit.default.default-suite' => 'unstable',
684 'dgit.default.old-dsc-distro' => 'debian',
685 'dgit-suite.*-security.distro' => 'debian-security',
686 'dgit.default.username' => '',
687 'dgit.default.archive-query-default-component' => 'main',
688 'dgit.default.ssh' => 'ssh',
689 'dgit.default.archive-query' => 'madison:',
690 'dgit.default.sshpsql-dbname' => 'service=projectb',
691 'dgit.default.aptget-components' => 'main',
692 'dgit.default.dgit-tag-format' => 'new,old,maint',
693 'dgit.default.source-only-uploads' => 'ok',
694 'dgit.dsc-url-proto-ok.http' => 'true',
695 'dgit.dsc-url-proto-ok.https' => 'true',
696 'dgit.dsc-url-proto-ok.git' => 'true',
697 'dgit.vcs-git.suites', => 'sid', # ;-separated
698 'dgit.default.dsc-url-proto-ok' => 'false',
699 # old means "repo server accepts pushes with old dgit tags"
700 # new means "repo server accepts pushes with new dgit tags"
701 # maint means "repo server accepts split brain pushes"
702 # hist means "repo server may have old pushes without new tag"
703 # ("hist" is implied by "old")
704 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
705 'dgit-distro.debian.git-check' => 'url',
706 'dgit-distro.debian.git-check-suffix' => '/info/refs',
707 'dgit-distro.debian.new-private-pushers' => 't',
708 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
709 'dgit-distro.debian/push.git-url' => '',
710 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
711 'dgit-distro.debian/push.git-user-force' => 'dgit',
712 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
713 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
714 'dgit-distro.debian/push.git-create' => 'true',
715 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
716 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
717 # 'dgit-distro.debian.archive-query-tls-key',
718 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
719 # ^ this does not work because curl is broken nowadays
720 # Fixing #790093 properly will involve providing providing the key
721 # in some pacagke and maybe updating these paths.
723 # 'dgit-distro.debian.archive-query-tls-curl-args',
724 # '--ca-path=/etc/ssl/ca-debian',
725 # ^ this is a workaround but works (only) on DSA-administered machines
726 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
727 'dgit-distro.debian.git-url-suffix' => '',
728 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
729 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
730 'dgit-distro.debian-security.archive-query' => 'aptget:',
731 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
732 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
733 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
734 'dgit-distro.debian-security.nominal-distro' => 'debian',
735 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
736 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
737 'dgit-distro.ubuntu.git-check' => 'false',
738 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
739 'dgit-distro.test-dummy.ssh' => "$td/ssh",
740 'dgit-distro.test-dummy.username' => "alice",
741 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
742 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
743 'dgit-distro.test-dummy.git-url' => "$td/git",
744 'dgit-distro.test-dummy.git-host' => "git",
745 'dgit-distro.test-dummy.git-path' => "$td/git",
746 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
747 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
748 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
749 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
753 our @gitcfgsources = qw(cmdline local global system);
754 our $invoked_in_git_tree = 1;
756 sub git_slurp_config () {
757 # This algoritm is a bit subtle, but this is needed so that for
758 # options which we want to be single-valued, we allow the
759 # different config sources to override properly. See #835858.
760 foreach my $src (@gitcfgsources) {
761 next if $src eq 'cmdline';
762 # we do this ourselves since git doesn't handle it
764 $gitcfgs{$src} = git_slurp_config_src $src;
768 sub git_get_config ($) {
770 foreach my $src (@gitcfgsources) {
771 my $l = $gitcfgs{$src}{$c};
772 confess "internal error ($l $c)" if $l && !ref $l;
773 printdebug"C $c ".(defined $l ?
774 join " ", map { messagequote "'$_'" } @$l :
778 @$l==1 or badcfg "multiple values for $c".
779 " (in $src git config)" if @$l > 1;
787 return undef if $c =~ /RETURN-UNDEF/;
788 printdebug "C? $c\n" if $debuglevel >= 5;
789 my $v = git_get_config($c);
790 return $v if defined $v;
791 my $dv = $defcfg{$c};
793 printdebug "CD $c $dv\n" if $debuglevel >= 4;
797 badcfg "need value for one of: @_\n".
798 "$us: distro or suite appears not to be (properly) supported";
801 sub not_necessarily_a_tree () {
802 # needs to be called from pre_*
803 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
804 $invoked_in_git_tree = 0;
807 sub access_basedistro__noalias () {
808 if (defined $idistro) {
811 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
812 return $def if defined $def;
813 foreach my $src (@gitcfgsources, 'internal') {
814 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
816 foreach my $k (keys %$kl) {
817 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
819 next unless match_glob $dpat, $isuite;
823 return cfg("dgit.default.distro");
827 sub access_basedistro () {
828 my $noalias = access_basedistro__noalias();
829 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
830 return $canon // $noalias;
833 sub access_nomdistro () {
834 my $base = access_basedistro();
835 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
836 $r =~ m/^$distro_re$/ or badcfg
837 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
841 sub access_quirk () {
842 # returns (quirk name, distro to use instead or undef, quirk-specific info)
843 my $basedistro = access_basedistro();
844 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
846 if (defined $backports_quirk) {
847 my $re = $backports_quirk;
848 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
850 $re =~ s/\%/([-0-9a-z_]+)/
851 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
852 if ($isuite =~ m/^$re$/) {
853 return ('backports',"$basedistro-backports",$1);
856 return ('none',undef);
861 sub parse_cfg_bool ($$$) {
862 my ($what,$def,$v) = @_;
865 $v =~ m/^[ty1]/ ? 1 :
866 $v =~ m/^[fn0]/ ? 0 :
867 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
870 sub access_forpush_config () {
871 my $d = access_basedistro();
875 parse_cfg_bool('new-private-pushers', 0,
876 cfg("dgit-distro.$d.new-private-pushers",
879 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
882 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
883 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
884 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
885 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
888 sub access_forpush () {
889 $access_forpush //= access_forpush_config();
890 return $access_forpush;
894 confess 'internal error '.Dumper($access_forpush)," ?" if
895 defined $access_forpush and !$access_forpush;
896 badcfg "pushing but distro is configured readonly"
897 if access_forpush_config() eq '0';
899 $supplementary_message = <<'END' unless $we_are_responder;
900 Push failed, before we got started.
901 You can retry the push, after fixing the problem, if you like.
903 parseopts_late_defaults();
907 parseopts_late_defaults();
910 sub supplementary_message ($) {
912 if (!$we_are_responder) {
913 $supplementary_message = $msg;
915 } elsif ($protovsn >= 3) {
916 responder_send_command "supplementary-message ".length($msg)
918 print PO $msg or die $!;
922 sub access_distros () {
923 # Returns list of distros to try, in order
926 # 0. `instead of' distro name(s) we have been pointed to
927 # 1. the access_quirk distro, if any
928 # 2a. the user's specified distro, or failing that } basedistro
929 # 2b. the distro calculated from the suite }
930 my @l = access_basedistro();
932 my (undef,$quirkdistro) = access_quirk();
933 unshift @l, $quirkdistro;
934 unshift @l, $instead_distro;
935 @l = grep { defined } @l;
937 push @l, access_nomdistro();
939 if (access_forpush()) {
940 @l = map { ("$_/push", $_) } @l;
945 sub access_cfg_cfgs (@) {
948 # The nesting of these loops determines the search order. We put
949 # the key loop on the outside so that we search all the distros
950 # for each key, before going on to the next key. That means that
951 # if access_cfg is called with a more specific, and then a less
952 # specific, key, an earlier distro can override the less specific
953 # without necessarily overriding any more specific keys. (If the
954 # distro wants to override the more specific keys it can simply do
955 # so; whereas if we did the loop the other way around, it would be
956 # impossible to for an earlier distro to override a less specific
957 # key but not the more specific ones without restating the unknown
958 # values of the more specific keys.
961 # We have to deal with RETURN-UNDEF specially, so that we don't
962 # terminate the search prematurely.
964 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
967 foreach my $d (access_distros()) {
968 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
970 push @cfgs, map { "dgit.default.$_" } @realkeys;
977 my (@cfgs) = access_cfg_cfgs(@keys);
978 my $value = cfg(@cfgs);
982 sub access_cfg_bool ($$) {
983 my ($def, @keys) = @_;
984 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
987 sub string_to_ssh ($) {
989 if ($spec =~ m/\s/) {
990 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
996 sub access_cfg_ssh () {
997 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
998 if (!defined $gitssh) {
1001 return string_to_ssh $gitssh;
1005 sub access_runeinfo ($) {
1007 return ": dgit ".access_basedistro()." $info ;";
1010 sub access_someuserhost ($) {
1012 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1013 defined($user) && length($user) or
1014 $user = access_cfg("$some-user",'username');
1015 my $host = access_cfg("$some-host");
1016 return length($user) ? "$user\@$host" : $host;
1019 sub access_gituserhost () {
1020 return access_someuserhost('git');
1023 sub access_giturl (;$) {
1024 my ($optional) = @_;
1025 my $url = access_cfg('git-url','RETURN-UNDEF');
1028 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1029 return undef unless defined $proto;
1032 access_gituserhost().
1033 access_cfg('git-path');
1035 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1038 return "$url/$package$suffix";
1041 sub commit_getclogp ($) {
1042 # Returns the parsed changelog hashref for a particular commit
1044 our %commit_getclogp_memo;
1045 my $memo = $commit_getclogp_memo{$objid};
1046 return $memo if $memo;
1048 my $mclog = dgit_privdir()."clog";
1049 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1050 "$objid:debian/changelog";
1051 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1054 sub parse_dscdata () {
1055 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1056 printdebug Dumper($dscdata) if $debuglevel>1;
1057 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1058 printdebug Dumper($dsc) if $debuglevel>1;
1063 sub archive_query ($;@) {
1064 my ($method) = shift @_;
1065 fail "this operation does not support multiple comma-separated suites"
1067 my $query = access_cfg('archive-query','RETURN-UNDEF');
1068 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1071 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1074 sub archive_query_prepend_mirror {
1075 my $m = access_cfg('mirror');
1076 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1079 sub pool_dsc_subpath ($$) {
1080 my ($vsn,$component) = @_; # $package is implict arg
1081 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1082 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1085 sub cfg_apply_map ($$$) {
1086 my ($varref, $what, $mapspec) = @_;
1087 return unless $mapspec;
1089 printdebug "config $what EVAL{ $mapspec; }\n";
1091 eval "package Dgit::Config; $mapspec;";
1096 #---------- `ftpmasterapi' archive query method (nascent) ----------
1098 sub archive_api_query_cmd ($) {
1100 my @cmd = (@curl, qw(-sS));
1101 my $url = access_cfg('archive-query-url');
1102 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1104 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1105 foreach my $key (split /\:/, $keys) {
1106 $key =~ s/\%HOST\%/$host/g;
1108 fail "for $url: stat $key: $!" unless $!==ENOENT;
1111 fail "config requested specific TLS key but do not know".
1112 " how to get curl to use exactly that EE key ($key)";
1113 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1114 # # Sadly the above line does not work because of changes
1115 # # to gnutls. The real fix for #790093 may involve
1116 # # new curl options.
1119 # Fixing #790093 properly will involve providing a value
1120 # for this on clients.
1121 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1122 push @cmd, split / /, $kargs if defined $kargs;
1124 push @cmd, $url.$subpath;
1128 sub api_query ($$;$) {
1130 my ($data, $subpath, $ok404) = @_;
1131 badcfg "ftpmasterapi archive query method takes no data part"
1133 my @cmd = archive_api_query_cmd($subpath);
1134 my $url = $cmd[$#cmd];
1135 push @cmd, qw(-w %{http_code});
1136 my $json = cmdoutput @cmd;
1137 unless ($json =~ s/\d+\d+\d$//) {
1138 failedcmd_report_cmd undef, @cmd;
1139 fail "curl failed to print 3-digit HTTP code";
1142 return undef if $code eq '404' && $ok404;
1143 fail "fetch of $url gave HTTP code $code"
1144 unless $url =~ m#^file://# or $code =~ m/^2/;
1145 return decode_json($json);
1148 sub canonicalise_suite_ftpmasterapi {
1149 my ($proto,$data) = @_;
1150 my $suites = api_query($data, 'suites');
1152 foreach my $entry (@$suites) {
1154 my $v = $entry->{$_};
1155 defined $v && $v eq $isuite;
1156 } qw(codename name);
1157 push @matched, $entry;
1159 fail "unknown suite $isuite, maybe -d would help" unless @matched;
1162 @matched==1 or die "multiple matches for suite $isuite\n";
1163 $cn = "$matched[0]{codename}";
1164 defined $cn or die "suite $isuite info has no codename\n";
1165 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1167 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1172 sub archive_query_ftpmasterapi {
1173 my ($proto,$data) = @_;
1174 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1176 my $digester = Digest::SHA->new(256);
1177 foreach my $entry (@$info) {
1179 my $vsn = "$entry->{version}";
1180 my ($ok,$msg) = version_check $vsn;
1181 die "bad version: $msg\n" unless $ok;
1182 my $component = "$entry->{component}";
1183 $component =~ m/^$component_re$/ or die "bad component";
1184 my $filename = "$entry->{filename}";
1185 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1186 or die "bad filename";
1187 my $sha256sum = "$entry->{sha256sum}";
1188 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1189 push @rows, [ $vsn, "/pool/$component/$filename",
1190 $digester, $sha256sum ];
1192 die "bad ftpmaster api response: $@\n".Dumper($entry)
1195 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1196 return archive_query_prepend_mirror @rows;
1199 sub file_in_archive_ftpmasterapi {
1200 my ($proto,$data,$filename) = @_;
1201 my $pat = $filename;
1204 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1205 my $info = api_query($data, "file_in_archive/$pat", 1);
1208 sub package_not_wholly_new_ftpmasterapi {
1209 my ($proto,$data,$pkg) = @_;
1210 my $info = api_query($data,"madison?package=${pkg}&f=json");
1214 #---------- `aptget' archive query method ----------
1217 our $aptget_releasefile;
1218 our $aptget_configpath;
1220 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1221 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1223 sub aptget_cache_clean {
1224 runcmd_ordryrun_local qw(sh -ec),
1225 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1229 sub aptget_lock_acquire () {
1230 my $lockfile = "$aptget_base/lock";
1231 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1232 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1235 sub aptget_prep ($) {
1237 return if defined $aptget_base;
1239 badcfg "aptget archive query method takes no data part"
1242 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1245 ensuredir "$cache/dgit";
1247 access_cfg('aptget-cachekey','RETURN-UNDEF')
1248 // access_nomdistro();
1250 $aptget_base = "$cache/dgit/aptget";
1251 ensuredir $aptget_base;
1253 my $quoted_base = $aptget_base;
1254 die "$quoted_base contains bad chars, cannot continue"
1255 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1257 ensuredir $aptget_base;
1259 aptget_lock_acquire();
1261 aptget_cache_clean();
1263 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1264 my $sourceslist = "source.list#$cachekey";
1266 my $aptsuites = $isuite;
1267 cfg_apply_map(\$aptsuites, 'suite map',
1268 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1270 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1271 printf SRCS "deb-src %s %s %s\n",
1272 access_cfg('mirror'),
1274 access_cfg('aptget-components')
1277 ensuredir "$aptget_base/cache";
1278 ensuredir "$aptget_base/lists";
1280 open CONF, ">", $aptget_configpath or die $!;
1282 Debug::NoLocking "true";
1283 APT::Get::List-Cleanup "false";
1284 #clear APT::Update::Post-Invoke-Success;
1285 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1286 Dir::State::Lists "$quoted_base/lists";
1287 Dir::Etc::preferences "$quoted_base/preferences";
1288 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1289 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1292 foreach my $key (qw(
1295 Dir::Cache::Archives
1296 Dir::Etc::SourceParts
1297 Dir::Etc::preferencesparts
1299 ensuredir "$aptget_base/$key";
1300 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1303 my $oldatime = (time // die $!) - 1;
1304 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1305 next unless stat_exists $oldlist;
1306 my ($mtime) = (stat _)[9];
1307 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1310 runcmd_ordryrun_local aptget_aptget(), qw(update);
1313 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1314 next unless stat_exists $oldlist;
1315 my ($atime) = (stat _)[8];
1316 next if $atime == $oldatime;
1317 push @releasefiles, $oldlist;
1319 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1320 @releasefiles = @inreleasefiles if @inreleasefiles;
1321 if (!@releasefiles) {
1323 apt seemed to not to update dgit's cached Release files for $isuite.
1325 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1328 die "apt updated too many Release files (@releasefiles), erk"
1329 unless @releasefiles == 1;
1331 ($aptget_releasefile) = @releasefiles;
1334 sub canonicalise_suite_aptget {
1335 my ($proto,$data) = @_;
1338 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1340 foreach my $name (qw(Codename Suite)) {
1341 my $val = $release->{$name};
1343 printdebug "release file $name: $val\n";
1344 $val =~ m/^$suite_re$/o or fail
1345 "Release file ($aptget_releasefile) specifies intolerable $name";
1346 cfg_apply_map(\$val, 'suite rmap',
1347 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1354 sub archive_query_aptget {
1355 my ($proto,$data) = @_;
1358 ensuredir "$aptget_base/source";
1359 foreach my $old (<$aptget_base/source/*.dsc>) {
1360 unlink $old or die "$old: $!";
1363 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1364 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1365 # avoids apt-get source failing with ambiguous error code
1367 runcmd_ordryrun_local
1368 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1369 aptget_aptget(), qw(--download-only --only-source source), $package;
1371 my @dscs = <$aptget_base/source/*.dsc>;
1372 fail "apt-get source did not produce a .dsc" unless @dscs;
1373 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1375 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1378 my $uri = "file://". uri_escape $dscs[0];
1379 $uri =~ s{\%2f}{/}gi;
1380 return [ (getfield $pre_dsc, 'Version'), $uri ];
1383 sub file_in_archive_aptget () { return undef; }
1384 sub package_not_wholly_new_aptget () { return undef; }
1386 #---------- `dummyapicat' archive query method ----------
1388 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1389 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1391 sub dummycatapi_run_in_mirror ($@) {
1392 # runs $fn with FIA open onto rune
1393 my ($rune, $argl, $fn) = @_;
1395 my $mirror = access_cfg('mirror');
1396 $mirror =~ s#^file://#/# or die "$mirror ?";
1397 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1398 qw(x), $mirror, @$argl);
1399 debugcmd "-|", @cmd;
1400 open FIA, "-|", @cmd or die $!;
1402 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1406 sub file_in_archive_dummycatapi ($$$) {
1407 my ($proto,$data,$filename) = @_;
1409 dummycatapi_run_in_mirror '
1410 find -name "$1" -print0 |
1412 ', [$filename], sub {
1415 printdebug "| $_\n";
1416 m/^(\w+) (\S+)$/ or die "$_ ?";
1417 push @out, { sha256sum => $1, filename => $2 };
1423 sub package_not_wholly_new_dummycatapi {
1424 my ($proto,$data,$pkg) = @_;
1425 dummycatapi_run_in_mirror "
1426 find -name ${pkg}_*.dsc
1433 #---------- `madison' archive query method ----------
1435 sub archive_query_madison {
1436 return archive_query_prepend_mirror
1437 map { [ @$_[0..1] ] } madison_get_parse(@_);
1440 sub madison_get_parse {
1441 my ($proto,$data) = @_;
1442 die unless $proto eq 'madison';
1443 if (!length $data) {
1444 $data= access_cfg('madison-distro','RETURN-UNDEF');
1445 $data //= access_basedistro();
1447 $rmad{$proto,$data,$package} ||= cmdoutput
1448 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1449 my $rmad = $rmad{$proto,$data,$package};
1452 foreach my $l (split /\n/, $rmad) {
1453 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1454 \s*( [^ \t|]+ )\s* \|
1455 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1456 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1457 $1 eq $package or die "$rmad $package ?";
1464 $component = access_cfg('archive-query-default-component');
1466 $5 eq 'source' or die "$rmad ?";
1467 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1469 return sort { -version_compare($a->[0],$b->[0]); } @out;
1472 sub canonicalise_suite_madison {
1473 # madison canonicalises for us
1474 my @r = madison_get_parse(@_);
1476 "unable to canonicalise suite using package $package".
1477 " which does not appear to exist in suite $isuite;".
1478 " --existing-package may help";
1482 sub file_in_archive_madison { return undef; }
1483 sub package_not_wholly_new_madison { return undef; }
1485 #---------- `sshpsql' archive query method ----------
1488 my ($data,$runeinfo,$sql) = @_;
1489 if (!length $data) {
1490 $data= access_someuserhost('sshpsql').':'.
1491 access_cfg('sshpsql-dbname');
1493 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1494 my ($userhost,$dbname) = ($`,$'); #';
1496 my @cmd = (access_cfg_ssh, $userhost,
1497 access_runeinfo("ssh-psql $runeinfo").
1498 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1499 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1501 open P, "-|", @cmd or die $!;
1504 printdebug(">|$_|\n");
1507 $!=0; $?=0; close P or failedcmd @cmd;
1509 my $nrows = pop @rows;
1510 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1511 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1512 @rows = map { [ split /\|/, $_ ] } @rows;
1513 my $ncols = scalar @{ shift @rows };
1514 die if grep { scalar @$_ != $ncols } @rows;
1518 sub sql_injection_check {
1519 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1522 sub archive_query_sshpsql ($$) {
1523 my ($proto,$data) = @_;
1524 sql_injection_check $isuite, $package;
1525 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1526 SELECT source.version, component.name, files.filename, files.sha256sum
1528 JOIN src_associations ON source.id = src_associations.source
1529 JOIN suite ON suite.id = src_associations.suite
1530 JOIN dsc_files ON dsc_files.source = source.id
1531 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1532 JOIN component ON component.id = files_archive_map.component_id
1533 JOIN files ON files.id = dsc_files.file
1534 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1535 AND source.source='$package'
1536 AND files.filename LIKE '%.dsc';
1538 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1539 my $digester = Digest::SHA->new(256);
1541 my ($vsn,$component,$filename,$sha256sum) = @$_;
1542 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1544 return archive_query_prepend_mirror @rows;
1547 sub canonicalise_suite_sshpsql ($$) {
1548 my ($proto,$data) = @_;
1549 sql_injection_check $isuite;
1550 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1551 SELECT suite.codename
1552 FROM suite where suite_name='$isuite' or codename='$isuite';
1554 @rows = map { $_->[0] } @rows;
1555 fail "unknown suite $isuite" unless @rows;
1556 die "ambiguous $isuite: @rows ?" if @rows>1;
1560 sub file_in_archive_sshpsql ($$$) { return undef; }
1561 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1563 #---------- `dummycat' archive query method ----------
1565 sub canonicalise_suite_dummycat ($$) {
1566 my ($proto,$data) = @_;
1567 my $dpath = "$data/suite.$isuite";
1568 if (!open C, "<", $dpath) {
1569 $!==ENOENT or die "$dpath: $!";
1570 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1574 chomp or die "$dpath: $!";
1576 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1580 sub archive_query_dummycat ($$) {
1581 my ($proto,$data) = @_;
1582 canonicalise_suite();
1583 my $dpath = "$data/package.$csuite.$package";
1584 if (!open C, "<", $dpath) {
1585 $!==ENOENT or die "$dpath: $!";
1586 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1594 printdebug "dummycat query $csuite $package $dpath | $_\n";
1595 my @row = split /\s+/, $_;
1596 @row==2 or die "$dpath: $_ ?";
1599 C->error and die "$dpath: $!";
1601 return archive_query_prepend_mirror
1602 sort { -version_compare($a->[0],$b->[0]); } @rows;
1605 sub file_in_archive_dummycat () { return undef; }
1606 sub package_not_wholly_new_dummycat () { return undef; }
1608 #---------- tag format handling ----------
1610 sub access_cfg_tagformats () {
1611 split /\,/, access_cfg('dgit-tag-format');
1614 sub access_cfg_tagformats_can_splitbrain () {
1615 my %y = map { $_ => 1 } access_cfg_tagformats;
1616 foreach my $needtf (qw(new maint)) {
1617 next if $y{$needtf};
1623 sub need_tagformat ($$) {
1624 my ($fmt, $why) = @_;
1625 fail "need to use tag format $fmt ($why) but also need".
1626 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1627 " - no way to proceed"
1628 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1629 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1632 sub select_tagformat () {
1634 return if $tagformatfn && !$tagformat_want;
1635 die 'bug' if $tagformatfn && $tagformat_want;
1636 # ... $tagformat_want assigned after previous select_tagformat
1638 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1639 printdebug "select_tagformat supported @supported\n";
1641 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1642 printdebug "select_tagformat specified @$tagformat_want\n";
1644 my ($fmt,$why,$override) = @$tagformat_want;
1646 fail "target distro supports tag formats @supported".
1647 " but have to use $fmt ($why)"
1649 or grep { $_ eq $fmt } @supported;
1651 $tagformat_want = undef;
1653 $tagformatfn = ${*::}{"debiantag_$fmt"};
1655 fail "trying to use unknown tag format \`$fmt' ($why) !"
1656 unless $tagformatfn;
1659 #---------- archive query entrypoints and rest of program ----------
1661 sub canonicalise_suite () {
1662 return if defined $csuite;
1663 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1664 $csuite = archive_query('canonicalise_suite');
1665 if ($isuite ne $csuite) {
1666 progress "canonical suite name for $isuite is $csuite";
1668 progress "canonical suite name is $csuite";
1672 sub get_archive_dsc () {
1673 canonicalise_suite();
1674 my @vsns = archive_query('archive_query');
1675 foreach my $vinfo (@vsns) {
1676 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1677 $dscurl = $vsn_dscurl;
1678 $dscdata = url_get($dscurl);
1680 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1685 $digester->add($dscdata);
1686 my $got = $digester->hexdigest();
1688 fail "$dscurl has hash $got but".
1689 " archive told us to expect $digest";
1692 my $fmt = getfield $dsc, 'Format';
1693 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1694 "unsupported source format $fmt, sorry";
1696 $dsc_checked = !!$digester;
1697 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1701 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1704 sub check_for_git ();
1705 sub check_for_git () {
1707 my $how = access_cfg('git-check');
1708 if ($how eq 'ssh-cmd') {
1710 (access_cfg_ssh, access_gituserhost(),
1711 access_runeinfo("git-check $package").
1712 " set -e; cd ".access_cfg('git-path').";".
1713 " if test -d $package.git; then echo 1; else echo 0; fi");
1714 my $r= cmdoutput @cmd;
1715 if (defined $r and $r =~ m/^divert (\w+)$/) {
1717 my ($usedistro,) = access_distros();
1718 # NB that if we are pushing, $usedistro will be $distro/push
1719 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1720 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1721 progress "diverting to $divert (using config for $instead_distro)";
1722 return check_for_git();
1724 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1726 } elsif ($how eq 'url') {
1727 my $prefix = access_cfg('git-check-url','git-url');
1728 my $suffix = access_cfg('git-check-suffix','git-suffix',
1729 'RETURN-UNDEF') // '.git';
1730 my $url = "$prefix/$package$suffix";
1731 my @cmd = (@curl, qw(-sS -I), $url);
1732 my $result = cmdoutput @cmd;
1733 $result =~ s/^\S+ 200 .*\n\r?\n//;
1734 # curl -sS -I with https_proxy prints
1735 # HTTP/1.0 200 Connection established
1736 $result =~ m/^\S+ (404|200) /s or
1737 fail "unexpected results from git check query - ".
1738 Dumper($prefix, $result);
1740 if ($code eq '404') {
1742 } elsif ($code eq '200') {
1747 } elsif ($how eq 'true') {
1749 } elsif ($how eq 'false') {
1752 badcfg "unknown git-check \`$how'";
1756 sub create_remote_git_repo () {
1757 my $how = access_cfg('git-create');
1758 if ($how eq 'ssh-cmd') {
1760 (access_cfg_ssh, access_gituserhost(),
1761 access_runeinfo("git-create $package").
1762 "set -e; cd ".access_cfg('git-path').";".
1763 " cp -a _template $package.git");
1764 } elsif ($how eq 'true') {
1767 badcfg "unknown git-create \`$how'";
1771 our ($dsc_hash,$lastpush_mergeinput);
1772 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1776 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1777 $playground = fresh_playground 'dgit/unpack';
1780 sub mktree_in_ud_here () {
1781 playtree_setup $gitcfgs{local};
1784 sub git_write_tree () {
1785 my $tree = cmdoutput @git, qw(write-tree);
1786 $tree =~ m/^\w+$/ or die "$tree ?";
1790 sub git_add_write_tree () {
1791 runcmd @git, qw(add -Af .);
1792 return git_write_tree();
1795 sub remove_stray_gits ($) {
1797 my @gitscmd = qw(find -name .git -prune -print0);
1798 debugcmd "|",@gitscmd;
1799 open GITS, "-|", @gitscmd or die $!;
1804 print STDERR "$us: warning: removing from $what: ",
1805 (messagequote $_), "\n";
1809 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1812 sub mktree_in_ud_from_only_subdir ($;$) {
1813 my ($what,$raw) = @_;
1814 # changes into the subdir
1817 die "expected one subdir but found @dirs ?" unless @dirs==1;
1818 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1822 remove_stray_gits($what);
1823 mktree_in_ud_here();
1825 my ($format, $fopts) = get_source_format();
1826 if (madformat($format)) {
1831 my $tree=git_add_write_tree();
1832 return ($tree,$dir);
1835 our @files_csum_info_fields =
1836 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1837 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1838 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1840 sub dsc_files_info () {
1841 foreach my $csumi (@files_csum_info_fields) {
1842 my ($fname, $module, $method) = @$csumi;
1843 my $field = $dsc->{$fname};
1844 next unless defined $field;
1845 eval "use $module; 1;" or die $@;
1847 foreach (split /\n/, $field) {
1849 m/^(\w+) (\d+) (\S+)$/ or
1850 fail "could not parse .dsc $fname line \`$_'";
1851 my $digester = eval "$module"."->$method;" or die $@;
1856 Digester => $digester,
1861 fail "missing any supported Checksums-* or Files field in ".
1862 $dsc->get_option('name');
1866 map { $_->{Filename} } dsc_files_info();
1869 sub files_compare_inputs (@) {
1874 my $showinputs = sub {
1875 return join "; ", map { $_->get_option('name') } @$inputs;
1878 foreach my $in (@$inputs) {
1880 my $in_name = $in->get_option('name');
1882 printdebug "files_compare_inputs $in_name\n";
1884 foreach my $csumi (@files_csum_info_fields) {
1885 my ($fname) = @$csumi;
1886 printdebug "files_compare_inputs $in_name $fname\n";
1888 my $field = $in->{$fname};
1889 next unless defined $field;
1892 foreach (split /\n/, $field) {
1895 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1896 fail "could not parse $in_name $fname line \`$_'";
1898 printdebug "files_compare_inputs $in_name $fname $f\n";
1902 my $re = \ $record{$f}{$fname};
1904 $fchecked{$f}{$in_name} = 1;
1906 fail "hash or size of $f varies in $fname fields".
1907 " (between: ".$showinputs->().")";
1912 @files = sort @files;
1913 $expected_files //= \@files;
1914 "@$expected_files" eq "@files" or
1915 fail "file list in $in_name varies between hash fields!";
1918 fail "$in_name has no files list field(s)";
1920 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1923 grep { keys %$_ == @$inputs-1 } values %fchecked
1924 or fail "no file appears in all file lists".
1925 " (looked in: ".$showinputs->().")";
1928 sub is_orig_file_in_dsc ($$) {
1929 my ($f, $dsc_files_info) = @_;
1930 return 0 if @$dsc_files_info <= 1;
1931 # One file means no origs, and the filename doesn't have a "what
1932 # part of dsc" component. (Consider versions ending `.orig'.)
1933 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1937 # This function determines whether a .changes file is source-only from
1938 # the point of view of dak. Thus, it permits *_source.buildinfo
1941 # It does not, however, permit any other buildinfo files. After a
1942 # source-only upload, the buildds will try to upload files like
1943 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1944 # named like this in their (otherwise) source-only upload, the uploads
1945 # of the buildd can be rejected by dak. Fixing the resultant
1946 # situation can require manual intervention. So we block such
1947 # .buildinfo files when the user tells us to perform a source-only
1948 # upload (such as when using the push-source subcommand with the -C
1949 # option, which calls this function).
1951 # Note, though, that when dgit is told to prepare a source-only
1952 # upload, such as when subcommands like build-source and push-source
1953 # without -C are used, dgit has a more restrictive notion of
1954 # source-only .changes than dak: such uploads will never include
1955 # *_source.buildinfo files. This is because there is no use for such
1956 # files when using a tool like dgit to produce the source package, as
1957 # dgit ensures the source is identical to git HEAD.
1958 sub test_source_only_changes ($) {
1960 foreach my $l (split /\n/, getfield $changes, 'Files') {
1961 $l =~ m/\S+$/ or next;
1962 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1963 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1964 print "purportedly source-only changes polluted by $&\n";
1971 sub changes_update_origs_from_dsc ($$$$) {
1972 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1974 printdebug "checking origs needed ($upstreamvsn)...\n";
1975 $_ = getfield $changes, 'Files';
1976 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1977 fail "cannot find section/priority from .changes Files field";
1978 my $placementinfo = $1;
1980 printdebug "checking origs needed placement '$placementinfo'...\n";
1981 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1982 $l =~ m/\S+$/ or next;
1984 printdebug "origs $file | $l\n";
1985 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1986 printdebug "origs $file is_orig\n";
1987 my $have = archive_query('file_in_archive', $file);
1988 if (!defined $have) {
1990 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1996 printdebug "origs $file \$#\$have=$#$have\n";
1997 foreach my $h (@$have) {
2000 foreach my $csumi (@files_csum_info_fields) {
2001 my ($fname, $module, $method, $archivefield) = @$csumi;
2002 next unless defined $h->{$archivefield};
2003 $_ = $dsc->{$fname};
2004 next unless defined;
2005 m/^(\w+) .* \Q$file\E$/m or
2006 fail ".dsc $fname missing entry for $file";
2007 if ($h->{$archivefield} eq $1) {
2011 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
2014 die "$file ".Dumper($h)." ?!" if $same && @differ;
2017 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
2020 printdebug "origs $file f.same=$found_same".
2021 " #f._differ=$#found_differ\n";
2022 if (@found_differ && !$found_same) {
2024 "archive contains $file with different checksum",
2027 # Now we edit the changes file to add or remove it
2028 foreach my $csumi (@files_csum_info_fields) {
2029 my ($fname, $module, $method, $archivefield) = @$csumi;
2030 next unless defined $changes->{$fname};
2032 # in archive, delete from .changes if it's there
2033 $changed{$file} = "removed" if
2034 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2035 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2036 # not in archive, but it's here in the .changes
2038 my $dsc_data = getfield $dsc, $fname;
2039 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2041 $extra =~ s/ \d+ /$&$placementinfo /
2042 or die "$fname $extra >$dsc_data< ?"
2043 if $fname eq 'Files';
2044 $changes->{$fname} .= "\n". $extra;
2045 $changed{$file} = "added";
2050 foreach my $file (keys %changed) {
2052 "edited .changes for archive .orig contents: %s %s",
2053 $changed{$file}, $file;
2055 my $chtmp = "$changesfile.tmp";
2056 $changes->save($chtmp);
2058 rename $chtmp,$changesfile or die "$changesfile $!";
2060 progress "[new .changes left in $changesfile]";
2063 progress "$changesfile already has appropriate .orig(s) (if any)";
2067 sub make_commit ($) {
2069 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2072 sub clogp_authline ($) {
2074 my $author = getfield $clogp, 'Maintainer';
2075 if ($author =~ m/^[^"\@]+\,/) {
2076 # single entry Maintainer field with unquoted comma
2077 $author = ($& =~ y/,//rd).$'; # strip the comma
2079 # git wants a single author; any remaining commas in $author
2080 # are by now preceded by @ (or "). It seems safer to punt on
2081 # "..." for now rather than attempting to dequote or something.
2082 $author =~ s#,.*##ms unless $author =~ m/"/;
2083 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2084 my $authline = "$author $date";
2085 $authline =~ m/$git_authline_re/o or
2086 fail "unexpected commit author line format \`$authline'".
2087 " (was generated from changelog Maintainer field)";
2088 return ($1,$2,$3) if wantarray;
2092 sub vendor_patches_distro ($$) {
2093 my ($checkdistro, $what) = @_;
2094 return unless defined $checkdistro;
2096 my $series = "debian/patches/\L$checkdistro\E.series";
2097 printdebug "checking for vendor-specific $series ($what)\n";
2099 if (!open SERIES, "<", $series) {
2100 die "$series $!" unless $!==ENOENT;
2109 Unfortunately, this source package uses a feature of dpkg-source where
2110 the same source package unpacks to different source code on different
2111 distros. dgit cannot safely operate on such packages on affected
2112 distros, because the meaning of source packages is not stable.
2114 Please ask the distro/maintainer to remove the distro-specific series
2115 files and use a different technique (if necessary, uploading actually
2116 different packages, if different distros are supposed to have
2120 fail "Found active distro-specific series file for".
2121 " $checkdistro ($what): $series, cannot continue";
2123 die "$series $!" if SERIES->error;
2127 sub check_for_vendor_patches () {
2128 # This dpkg-source feature doesn't seem to be documented anywhere!
2129 # But it can be found in the changelog (reformatted):
2131 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2132 # Author: Raphael Hertzog <hertzog@debian.org>
2133 # Date: Sun Oct 3 09:36:48 2010 +0200
2135 # dpkg-source: correctly create .pc/.quilt_series with alternate
2138 # If you have debian/patches/ubuntu.series and you were
2139 # unpacking the source package on ubuntu, quilt was still
2140 # directed to debian/patches/series instead of
2141 # debian/patches/ubuntu.series.
2143 # debian/changelog | 3 +++
2144 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2145 # 2 files changed, 6 insertions(+), 1 deletion(-)
2148 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2149 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2150 "Dpkg::Vendor \`current vendor'");
2151 vendor_patches_distro(access_basedistro(),
2152 "(base) distro being accessed");
2153 vendor_patches_distro(access_nomdistro(),
2154 "(nominal) distro being accessed");
2157 sub generate_commits_from_dsc () {
2158 # See big comment in fetch_from_archive, below.
2159 # See also README.dsc-import.
2161 changedir $playground;
2163 my @dfi = dsc_files_info();
2164 foreach my $fi (@dfi) {
2165 my $f = $fi->{Filename};
2166 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2167 my $upper_f = (bpd_abs()."/$f");
2169 printdebug "considering reusing $f: ";
2171 if (link_ltarget "$upper_f,fetch", $f) {
2172 printdebug "linked (using ...,fetch).\n";
2173 } elsif ((printdebug "($!) "),
2175 fail "accessing $buildproductsdir/$f,fetch: $!";
2176 } elsif (link_ltarget $upper_f, $f) {
2177 printdebug "linked.\n";
2178 } elsif ((printdebug "($!) "),
2180 fail "accessing $buildproductsdir/$f: $!";
2182 printdebug "absent.\n";
2186 complete_file_from_dsc('.', $fi, \$refetched)
2189 printdebug "considering saving $f: ";
2191 if (link $f, $upper_f) {
2192 printdebug "linked.\n";
2193 } elsif ((printdebug "($!) "),
2195 fail "saving $buildproductsdir/$f: $!";
2196 } elsif (!$refetched) {
2197 printdebug "no need.\n";
2198 } elsif (link $f, "$upper_f,fetch") {
2199 printdebug "linked (using ...,fetch).\n";
2200 } elsif ((printdebug "($!) "),
2202 fail "saving $buildproductsdir/$f,fetch: $!";
2204 printdebug "cannot.\n";
2208 # We unpack and record the orig tarballs first, so that we only
2209 # need disk space for one private copy of the unpacked source.
2210 # But we can't make them into commits until we have the metadata
2211 # from the debian/changelog, so we record the tree objects now and
2212 # make them into commits later.
2214 my $upstreamv = upstreamversion $dsc->{version};
2215 my $orig_f_base = srcfn $upstreamv, '';
2217 foreach my $fi (@dfi) {
2218 # We actually import, and record as a commit, every tarball
2219 # (unless there is only one file, in which case there seems
2222 my $f = $fi->{Filename};
2223 printdebug "import considering $f ";
2224 (printdebug "only one dfi\n"), next if @dfi == 1;
2225 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2226 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2230 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2232 printdebug "Y ", (join ' ', map { $_//"(none)" }
2233 $compr_ext, $orig_f_part
2236 my $input = new IO::File $f, '<' or die "$f $!";
2240 if (defined $compr_ext) {
2242 Dpkg::Compression::compression_guess_from_filename $f;
2243 fail "Dpkg::Compression cannot handle file $f in source package"
2244 if defined $compr_ext && !defined $cname;
2246 new Dpkg::Compression::Process compression => $cname;
2247 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2248 my $compr_fh = new IO::Handle;
2249 my $compr_pid = open $compr_fh, "-|" // die $!;
2251 open STDIN, "<&", $input or die $!;
2253 die "dgit (child): exec $compr_cmd[0]: $!\n";
2258 rmtree "_unpack-tar";
2259 mkdir "_unpack-tar" or die $!;
2260 my @tarcmd = qw(tar -x -f -
2261 --no-same-owner --no-same-permissions
2262 --no-acls --no-xattrs --no-selinux);
2263 my $tar_pid = fork // die $!;
2265 chdir "_unpack-tar" or die $!;
2266 open STDIN, "<&", $input or die $!;
2268 die "dgit (child): exec $tarcmd[0]: $!";
2270 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2271 !$? or failedcmd @tarcmd;
2274 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2276 # finally, we have the results in "tarball", but maybe
2277 # with the wrong permissions
2279 runcmd qw(chmod -R +rwX _unpack-tar);
2280 changedir "_unpack-tar";
2281 remove_stray_gits($f);
2282 mktree_in_ud_here();
2284 my ($tree) = git_add_write_tree();
2285 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2286 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2288 printdebug "one subtree $1\n";
2290 printdebug "multiple subtrees\n";
2293 rmtree "_unpack-tar";
2295 my $ent = [ $f, $tree ];
2297 Orig => !!$orig_f_part,
2298 Sort => (!$orig_f_part ? 2 :
2299 $orig_f_part =~ m/-/g ? 1 :
2307 # put any without "_" first (spec is not clear whether files
2308 # are always in the usual order). Tarballs without "_" are
2309 # the main orig or the debian tarball.
2310 $a->{Sort} <=> $b->{Sort} or
2314 my $any_orig = grep { $_->{Orig} } @tartrees;
2316 my $dscfn = "$package.dsc";
2318 my $treeimporthow = 'package';
2320 open D, ">", $dscfn or die "$dscfn: $!";
2321 print D $dscdata or die "$dscfn: $!";
2322 close D or die "$dscfn: $!";
2323 my @cmd = qw(dpkg-source);
2324 push @cmd, '--no-check' if $dsc_checked;
2325 if (madformat $dsc->{format}) {
2326 push @cmd, '--skip-patches';
2327 $treeimporthow = 'unpatched';
2329 push @cmd, qw(-x --), $dscfn;
2332 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2333 if (madformat $dsc->{format}) {
2334 check_for_vendor_patches();
2338 if (madformat $dsc->{format}) {
2339 my @pcmd = qw(dpkg-source --before-build .);
2340 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2342 $dappliedtree = git_add_write_tree();
2345 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2349 printdebug "import clog search...\n";
2350 parsechangelog_loop \@clogcmd, "package changelog", sub {
2351 my ($thisstanza, $desc) = @_;
2352 no warnings qw(exiting);
2354 $clogp //= $thisstanza;
2356 printdebug "import clog $thisstanza->{version} $desc...\n";
2358 last if !$any_orig; # we don't need $r1clogp
2360 # We look for the first (most recent) changelog entry whose
2361 # version number is lower than the upstream version of this
2362 # package. Then the last (least recent) previous changelog
2363 # entry is treated as the one which introduced this upstream
2364 # version and used for the synthetic commits for the upstream
2367 # One might think that a more sophisticated algorithm would be
2368 # necessary. But: we do not want to scan the whole changelog
2369 # file. Stopping when we see an earlier version, which
2370 # necessarily then is an earlier upstream version, is the only
2371 # realistic way to do that. Then, either the earliest
2372 # changelog entry we have seen so far is indeed the earliest
2373 # upload of this upstream version; or there are only changelog
2374 # entries relating to later upstream versions (which is not
2375 # possible unless the changelog and .dsc disagree about the
2376 # version). Then it remains to choose between the physically
2377 # last entry in the file, and the one with the lowest version
2378 # number. If these are not the same, we guess that the
2379 # versions were created in a non-monotonic order rather than
2380 # that the changelog entries have been misordered.
2382 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2384 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2385 $r1clogp = $thisstanza;
2387 printdebug "import clog $r1clogp->{version} becomes r1\n";
2390 $clogp or fail "package changelog has no entries!";
2392 my $authline = clogp_authline $clogp;
2393 my $changes = getfield $clogp, 'Changes';
2394 $changes =~ s/^\n//; # Changes: \n
2395 my $cversion = getfield $clogp, 'Version';
2398 $r1clogp //= $clogp; # maybe there's only one entry;
2399 my $r1authline = clogp_authline $r1clogp;
2400 # Strictly, r1authline might now be wrong if it's going to be
2401 # unused because !$any_orig. Whatever.
2403 printdebug "import tartrees authline $authline\n";
2404 printdebug "import tartrees r1authline $r1authline\n";
2406 foreach my $tt (@tartrees) {
2407 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2409 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2412 committer $r1authline
2416 [dgit import orig $tt->{F}]
2424 [dgit import tarball $package $cversion $tt->{F}]
2429 printdebug "import main commit\n";
2431 open C, ">../commit.tmp" or die $!;
2432 print C <<END or die $!;
2435 print C <<END or die $! foreach @tartrees;
2438 print C <<END or die $!;
2444 [dgit import $treeimporthow $package $cversion]
2448 my $rawimport_hash = make_commit qw(../commit.tmp);
2450 if (madformat $dsc->{format}) {
2451 printdebug "import apply patches...\n";
2453 # regularise the state of the working tree so that
2454 # the checkout of $rawimport_hash works nicely.
2455 my $dappliedcommit = make_commit_text(<<END);
2462 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2464 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2466 # We need the answers to be reproducible
2467 my @authline = clogp_authline($clogp);
2468 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2469 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2470 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2471 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2472 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2473 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2475 my $path = $ENV{PATH} or die;
2477 # we use ../../gbp-pq-output, which (given that we are in
2478 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2481 foreach my $use_absurd (qw(0 1)) {
2482 runcmd @git, qw(checkout -q unpa);
2483 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2484 local $ENV{PATH} = $path;
2487 progress "warning: $@";
2488 $path = "$absurdity:$path";
2489 progress "$us: trying slow absurd-git-apply...";
2490 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2495 die "forbid absurd git-apply\n" if $use_absurd
2496 && forceing [qw(import-gitapply-no-absurd)];
2497 die "only absurd git-apply!\n" if !$use_absurd
2498 && forceing [qw(import-gitapply-absurd)];
2500 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2501 local $ENV{PATH} = $path if $use_absurd;
2503 my @showcmd = (gbp_pq, qw(import));
2504 my @realcmd = shell_cmd
2505 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2506 debugcmd "+",@realcmd;
2507 if (system @realcmd) {
2508 die +(shellquote @showcmd).
2510 failedcmd_waitstatus()."\n";
2513 my $gapplied = git_rev_parse('HEAD');
2514 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2515 $gappliedtree eq $dappliedtree or
2517 gbp-pq import and dpkg-source disagree!
2518 gbp-pq import gave commit $gapplied
2519 gbp-pq import gave tree $gappliedtree
2520 dpkg-source --before-build gave tree $dappliedtree
2522 $rawimport_hash = $gapplied;
2527 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2532 progress "synthesised git commit from .dsc $cversion";
2534 my $rawimport_mergeinput = {
2535 Commit => $rawimport_hash,
2536 Info => "Import of source package",
2538 my @output = ($rawimport_mergeinput);
2540 if ($lastpush_mergeinput) {
2541 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2542 my $oversion = getfield $oldclogp, 'Version';
2544 version_compare($oversion, $cversion);
2546 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2547 { Message => <<END, ReverseParents => 1 });
2548 Record $package ($cversion) in archive suite $csuite
2550 } elsif ($vcmp > 0) {
2551 print STDERR <<END or die $!;
2553 Version actually in archive: $cversion (older)
2554 Last version pushed with dgit: $oversion (newer or same)
2557 @output = $lastpush_mergeinput;
2559 # Same version. Use what's in the server git branch,
2560 # discarding our own import. (This could happen if the
2561 # server automatically imports all packages into git.)
2562 @output = $lastpush_mergeinput;
2570 sub complete_file_from_dsc ($$;$) {
2571 our ($dstdir, $fi, $refetched) = @_;
2572 # Ensures that we have, in $dstdir, the file $fi, with the correct
2573 # contents. (Downloading it from alongside $dscurl if necessary.)
2574 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2575 # and will set $$refetched=1 if it did so (or tried to).
2577 my $f = $fi->{Filename};
2578 my $tf = "$dstdir/$f";
2582 my $checkhash = sub {
2583 open F, "<", "$tf" or die "$tf: $!";
2584 $fi->{Digester}->reset();
2585 $fi->{Digester}->addfile(*F);
2586 F->error and die $!;
2587 $got = $fi->{Digester}->hexdigest();
2588 return $got eq $fi->{Hash};
2591 if (stat_exists $tf) {
2592 if ($checkhash->()) {
2593 progress "using existing $f";
2597 fail "file $f has hash $got but .dsc".
2598 " demands hash $fi->{Hash} ".
2599 "(perhaps you should delete this file?)";
2601 progress "need to fetch correct version of $f";
2602 unlink $tf or die "$tf $!";
2605 printdebug "$tf does not exist, need to fetch\n";
2609 $furl =~ s{/[^/]+$}{};
2611 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2612 die "$f ?" if $f =~ m#/#;
2613 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2614 return 0 if !act_local();
2617 fail "file $f has hash $got but .dsc".
2618 " demands hash $fi->{Hash} ".
2619 "(got wrong file from archive!)";
2624 sub ensure_we_have_orig () {
2625 my @dfi = dsc_files_info();
2626 foreach my $fi (@dfi) {
2627 my $f = $fi->{Filename};
2628 next unless is_orig_file_in_dsc($f, \@dfi);
2629 complete_file_from_dsc($buildproductsdir, $fi)
2634 #---------- git fetch ----------
2636 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2637 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2639 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2640 # locally fetched refs because they have unhelpful names and clutter
2641 # up gitk etc. So we track whether we have "used up" head ref (ie,
2642 # whether we have made another local ref which refers to this object).
2644 # (If we deleted them unconditionally, then we might end up
2645 # re-fetching the same git objects each time dgit fetch was run.)
2647 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2648 # in git_fetch_us to fetch the refs in question, and possibly a call
2649 # to lrfetchref_used.
2651 our (%lrfetchrefs_f, %lrfetchrefs_d);
2652 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2654 sub lrfetchref_used ($) {
2655 my ($fullrefname) = @_;
2656 my $objid = $lrfetchrefs_f{$fullrefname};
2657 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2660 sub git_lrfetch_sane {
2661 my ($url, $supplementary, @specs) = @_;
2662 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2663 # at least as regards @specs. Also leave the results in
2664 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2665 # able to clean these up.
2667 # With $supplementary==1, @specs must not contain wildcards
2668 # and we add to our previous fetches (non-atomically).
2670 # This is rather miserable:
2671 # When git fetch --prune is passed a fetchspec ending with a *,
2672 # it does a plausible thing. If there is no * then:
2673 # - it matches subpaths too, even if the supplied refspec
2674 # starts refs, and behaves completely madly if the source
2675 # has refs/refs/something. (See, for example, Debian #NNNN.)
2676 # - if there is no matching remote ref, it bombs out the whole
2678 # We want to fetch a fixed ref, and we don't know in advance
2679 # if it exists, so this is not suitable.
2681 # Our workaround is to use git ls-remote. git ls-remote has its
2682 # own qairks. Notably, it has the absurd multi-tail-matching
2683 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2684 # refs/refs/foo etc.
2686 # Also, we want an idempotent snapshot, but we have to make two
2687 # calls to the remote: one to git ls-remote and to git fetch. The
2688 # solution is use git ls-remote to obtain a target state, and
2689 # git fetch to try to generate it. If we don't manage to generate
2690 # the target state, we try again.
2692 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2694 my $specre = join '|', map {
2697 my $wildcard = $x =~ s/\\\*$/.*/;
2698 die if $wildcard && $supplementary;
2701 printdebug "git_lrfetch_sane specre=$specre\n";
2702 my $wanted_rref = sub {
2704 return m/^(?:$specre)$/;
2707 my $fetch_iteration = 0;
2710 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2711 if (++$fetch_iteration > 10) {
2712 fail "too many iterations trying to get sane fetch!";
2715 my @look = map { "refs/$_" } @specs;
2716 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2720 open GITLS, "-|", @lcmd or die $!;
2722 printdebug "=> ", $_;
2723 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2724 my ($objid,$rrefname) = ($1,$2);
2725 if (!$wanted_rref->($rrefname)) {
2727 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2731 $wantr{$rrefname} = $objid;
2734 close GITLS or failedcmd @lcmd;
2736 # OK, now %want is exactly what we want for refs in @specs
2738 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2739 "+refs/$_:".lrfetchrefs."/$_";
2742 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2744 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2745 runcmd_ordryrun_local @fcmd if @fspecs;
2747 if (!$supplementary) {
2748 %lrfetchrefs_f = ();
2752 git_for_each_ref(lrfetchrefs, sub {
2753 my ($objid,$objtype,$lrefname,$reftail) = @_;
2754 $lrfetchrefs_f{$lrefname} = $objid;
2755 $objgot{$objid} = 1;
2758 if ($supplementary) {
2762 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2763 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2764 if (!exists $wantr{$rrefname}) {
2765 if ($wanted_rref->($rrefname)) {
2767 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2771 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2774 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2775 delete $lrfetchrefs_f{$lrefname};
2779 foreach my $rrefname (sort keys %wantr) {
2780 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2781 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2782 my $want = $wantr{$rrefname};
2783 next if $got eq $want;
2784 if (!defined $objgot{$want}) {
2785 fail <<END unless act_local();
2786 --dry-run specified but we actually wanted the results of git fetch,
2787 so this is not going to work. Try running dgit fetch first,
2788 or using --damp-run instead of --dry-run.
2791 warning: git ls-remote suggests we want $lrefname
2792 warning: and it should refer to $want
2793 warning: but git fetch didn't fetch that object to any relevant ref.
2794 warning: This may be due to a race with someone updating the server.
2795 warning: Will try again...
2797 next FETCH_ITERATION;
2800 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2802 runcmd_ordryrun_local @git, qw(update-ref -m),
2803 "dgit fetch git fetch fixup", $lrefname, $want;
2804 $lrfetchrefs_f{$lrefname} = $want;
2809 if (defined $csuite) {
2810 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2811 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2812 my ($objid,$objtype,$lrefname,$reftail) = @_;
2813 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2814 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2818 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2819 Dumper(\%lrfetchrefs_f);
2822 sub git_fetch_us () {
2823 # Want to fetch only what we are going to use, unless
2824 # deliberately-not-ff, in which case we must fetch everything.
2826 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2828 (quiltmode_splitbrain
2829 ? (map { $_->('*',access_nomdistro) }
2830 \&debiantag_new, \&debiantag_maintview)
2831 : debiantags('*',access_nomdistro));
2832 push @specs, server_branch($csuite);
2833 push @specs, $rewritemap;
2834 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2836 my $url = access_giturl();
2837 git_lrfetch_sane $url, 0, @specs;
2840 my @tagpats = debiantags('*',access_nomdistro);
2842 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2843 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2844 printdebug "currently $fullrefname=$objid\n";
2845 $here{$fullrefname} = $objid;
2847 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2848 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2849 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2850 printdebug "offered $lref=$objid\n";
2851 if (!defined $here{$lref}) {
2852 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2853 runcmd_ordryrun_local @upd;
2854 lrfetchref_used $fullrefname;
2855 } elsif ($here{$lref} eq $objid) {
2856 lrfetchref_used $fullrefname;
2859 "Not updating $lref from $here{$lref} to $objid.\n";
2864 #---------- dsc and archive handling ----------
2866 sub mergeinfo_getclogp ($) {
2867 # Ensures thit $mi->{Clogp} exists and returns it
2869 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2872 sub mergeinfo_version ($) {
2873 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2876 sub fetch_from_archive_record_1 ($) {
2878 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2879 cmdoutput @git, qw(log -n2), $hash;
2880 # ... gives git a chance to complain if our commit is malformed
2883 sub fetch_from_archive_record_2 ($) {
2885 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2889 dryrun_report @upd_cmd;
2893 sub parse_dsc_field_def_dsc_distro () {
2894 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2895 dgit.default.distro);
2898 sub parse_dsc_field ($$) {
2899 my ($dsc, $what) = @_;
2901 foreach my $field (@ourdscfield) {
2902 $f = $dsc->{$field};
2907 progress "$what: NO git hash";
2908 parse_dsc_field_def_dsc_distro();
2909 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2910 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2911 progress "$what: specified git info ($dsc_distro)";
2912 $dsc_hint_tag = [ $dsc_hint_tag ];
2913 } elsif ($f =~ m/^\w+\s*$/) {
2915 parse_dsc_field_def_dsc_distro();
2916 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2918 progress "$what: specified git hash";
2920 fail "$what: invalid Dgit info";
2924 sub resolve_dsc_field_commit ($$) {
2925 my ($already_distro, $already_mapref) = @_;
2927 return unless defined $dsc_hash;
2930 defined $already_mapref &&
2931 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2932 ? $already_mapref : undef;
2936 my ($what, @fetch) = @_;
2938 local $idistro = $dsc_distro;
2939 my $lrf = lrfetchrefs;
2941 if (!$chase_dsc_distro) {
2943 "not chasing .dsc distro $dsc_distro: not fetching $what";
2948 ".dsc names distro $dsc_distro: fetching $what";
2950 my $url = access_giturl();
2951 if (!defined $url) {
2952 defined $dsc_hint_url or fail <<END;
2953 .dsc Dgit metadata is in context of distro $dsc_distro
2954 for which we have no configured url and .dsc provides no hint
2957 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2958 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2959 parse_cfg_bool "dsc-url-proto-ok", 'false',
2960 cfg("dgit.dsc-url-proto-ok.$proto",
2961 "dgit.default.dsc-url-proto-ok")
2963 .dsc Dgit metadata is in context of distro $dsc_distro
2964 for which we have no configured url;
2965 .dsc provides hinted url with protocol $proto which is unsafe.
2966 (can be overridden by config - consult documentation)
2968 $url = $dsc_hint_url;
2971 git_lrfetch_sane $url, 1, @fetch;
2976 my $rewrite_enable = do {
2977 local $idistro = $dsc_distro;
2978 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2981 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2982 if (!defined $mapref) {
2983 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2984 $mapref = $lrf.'/'.$rewritemap;
2986 my $rewritemapdata = git_cat_file $mapref.':map';
2987 if (defined $rewritemapdata
2988 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2990 "server's git history rewrite map contains a relevant entry!";
2993 if (defined $dsc_hash) {
2994 progress "using rewritten git hash in place of .dsc value";
2996 progress "server data says .dsc hash is to be disregarded";
3001 if (!defined git_cat_file $dsc_hash) {
3002 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3003 my $lrf = $do_fetch->("additional commits", @tags) &&
3004 defined git_cat_file $dsc_hash
3006 .dsc Dgit metadata requires commit $dsc_hash
3007 but we could not obtain that object anywhere.
3009 foreach my $t (@tags) {
3010 my $fullrefname = $lrf.'/'.$t;
3011 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3012 next unless $lrfetchrefs_f{$fullrefname};
3013 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3014 lrfetchref_used $fullrefname;
3019 sub fetch_from_archive () {
3020 ensure_setup_existing_tree();
3022 # Ensures that lrref() is what is actually in the archive, one way
3023 # or another, according to us - ie this client's
3024 # appropritaely-updated archive view. Also returns the commit id.
3025 # If there is nothing in the archive, leaves lrref alone and
3026 # returns undef. git_fetch_us must have already been called.
3030 parse_dsc_field($dsc, 'last upload to archive');
3031 resolve_dsc_field_commit access_basedistro,
3032 lrfetchrefs."/".$rewritemap
3034 progress "no version available from the archive";
3037 # If the archive's .dsc has a Dgit field, there are three
3038 # relevant git commitids we need to choose between and/or merge
3040 # 1. $dsc_hash: the Dgit field from the archive
3041 # 2. $lastpush_hash: the suite branch on the dgit git server
3042 # 3. $lastfetch_hash: our local tracking brach for the suite
3044 # These may all be distinct and need not be in any fast forward
3047 # If the dsc was pushed to this suite, then the server suite
3048 # branch will have been updated; but it might have been pushed to
3049 # a different suite and copied by the archive. Conversely a more
3050 # recent version may have been pushed with dgit but not appeared
3051 # in the archive (yet).
3053 # $lastfetch_hash may be awkward because archive imports
3054 # (particularly, imports of Dgit-less .dscs) are performed only as
3055 # needed on individual clients, so different clients may perform a
3056 # different subset of them - and these imports are only made
3057 # public during push. So $lastfetch_hash may represent a set of
3058 # imports different to a subsequent upload by a different dgit
3061 # Our approach is as follows:
3063 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3064 # descendant of $dsc_hash, then it was pushed by a dgit user who
3065 # had based their work on $dsc_hash, so we should prefer it.
3066 # Otherwise, $dsc_hash was installed into this suite in the
3067 # archive other than by a dgit push, and (necessarily) after the
3068 # last dgit push into that suite (since a dgit push would have
3069 # been descended from the dgit server git branch); thus, in that
3070 # case, we prefer the archive's version (and produce a
3071 # pseudo-merge to overwrite the dgit server git branch).
3073 # (If there is no Dgit field in the archive's .dsc then
3074 # generate_commit_from_dsc uses the version numbers to decide
3075 # whether the suite branch or the archive is newer. If the suite
3076 # branch is newer it ignores the archive's .dsc; otherwise it
3077 # generates an import of the .dsc, and produces a pseudo-merge to
3078 # overwrite the suite branch with the archive contents.)
3080 # The outcome of that part of the algorithm is the `public view',
3081 # and is same for all dgit clients: it does not depend on any
3082 # unpublished history in the local tracking branch.
3084 # As between the public view and the local tracking branch: The
3085 # local tracking branch is only updated by dgit fetch, and
3086 # whenever dgit fetch runs it includes the public view in the
3087 # local tracking branch. Therefore if the public view is not
3088 # descended from the local tracking branch, the local tracking
3089 # branch must contain history which was imported from the archive
3090 # but never pushed; and, its tip is now out of date. So, we make
3091 # a pseudo-merge to overwrite the old imports and stitch the old
3094 # Finally: we do not necessarily reify the public view (as
3095 # described above). This is so that we do not end up stacking two
3096 # pseudo-merges. So what we actually do is figure out the inputs
3097 # to any public view pseudo-merge and put them in @mergeinputs.
3100 # $mergeinputs[]{Commit}
3101 # $mergeinputs[]{Info}
3102 # $mergeinputs[0] is the one whose tree we use
3103 # @mergeinputs is in the order we use in the actual commit)
3106 # $mergeinputs[]{Message} is a commit message to use
3107 # $mergeinputs[]{ReverseParents} if def specifies that parent
3108 # list should be in opposite order
3109 # Such an entry has no Commit or Info. It applies only when found
3110 # in the last entry. (This ugliness is to support making
3111 # identical imports to previous dgit versions.)
3113 my $lastpush_hash = git_get_ref(lrfetchref());
3114 printdebug "previous reference hash=$lastpush_hash\n";
3115 $lastpush_mergeinput = $lastpush_hash && {
3116 Commit => $lastpush_hash,
3117 Info => "dgit suite branch on dgit git server",
3120 my $lastfetch_hash = git_get_ref(lrref());
3121 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3122 my $lastfetch_mergeinput = $lastfetch_hash && {
3123 Commit => $lastfetch_hash,
3124 Info => "dgit client's archive history view",
3127 my $dsc_mergeinput = $dsc_hash && {
3128 Commit => $dsc_hash,
3129 Info => "Dgit field in .dsc from archive",
3133 my $del_lrfetchrefs = sub {
3136 printdebug "del_lrfetchrefs...\n";
3137 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3138 my $objid = $lrfetchrefs_d{$fullrefname};
3139 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3141 $gur ||= new IO::Handle;
3142 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3144 printf $gur "delete %s %s\n", $fullrefname, $objid;
3147 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3151 if (defined $dsc_hash) {
3152 ensure_we_have_orig();
3153 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3154 @mergeinputs = $dsc_mergeinput
3155 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3156 print STDERR <<END or die $!;
3158 Git commit in archive is behind the last version allegedly pushed/uploaded.
3159 Commit referred to by archive: $dsc_hash
3160 Last version pushed with dgit: $lastpush_hash
3163 @mergeinputs = ($lastpush_mergeinput);
3165 # Archive has .dsc which is not a descendant of the last dgit
3166 # push. This can happen if the archive moves .dscs about.
3167 # Just follow its lead.
3168 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3169 progress "archive .dsc names newer git commit";
3170 @mergeinputs = ($dsc_mergeinput);
3172 progress "archive .dsc names other git commit, fixing up";
3173 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3177 @mergeinputs = generate_commits_from_dsc();
3178 # We have just done an import. Now, our import algorithm might
3179 # have been improved. But even so we do not want to generate
3180 # a new different import of the same package. So if the
3181 # version numbers are the same, just use our existing version.
3182 # If the version numbers are different, the archive has changed
3183 # (perhaps, rewound).
3184 if ($lastfetch_mergeinput &&
3185 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3186 (mergeinfo_version $mergeinputs[0]) )) {
3187 @mergeinputs = ($lastfetch_mergeinput);
3189 } elsif ($lastpush_hash) {
3190 # only in git, not in the archive yet
3191 @mergeinputs = ($lastpush_mergeinput);
3192 print STDERR <<END or die $!;
3194 Package not found in the archive, but has allegedly been pushed using dgit.
3198 printdebug "nothing found!\n";
3199 if (defined $skew_warning_vsn) {
3200 print STDERR <<END or die $!;
3202 Warning: relevant archive skew detected.
3203 Archive allegedly contains $skew_warning_vsn
3204 But we were not able to obtain any version from the archive or git.
3208 unshift @end, $del_lrfetchrefs;
3212 if ($lastfetch_hash &&
3214 my $h = $_->{Commit};
3215 $h and is_fast_fwd($lastfetch_hash, $h);
3216 # If true, one of the existing parents of this commit
3217 # is a descendant of the $lastfetch_hash, so we'll
3218 # be ff from that automatically.
3222 push @mergeinputs, $lastfetch_mergeinput;
3225 printdebug "fetch mergeinfos:\n";
3226 foreach my $mi (@mergeinputs) {
3228 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3230 printdebug sprintf " ReverseParents=%d Message=%s",
3231 $mi->{ReverseParents}, $mi->{Message};
3235 my $compat_info= pop @mergeinputs
3236 if $mergeinputs[$#mergeinputs]{Message};
3238 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3241 if (@mergeinputs > 1) {
3243 my $tree_commit = $mergeinputs[0]{Commit};
3245 my $tree = get_tree_of_commit $tree_commit;;
3247 # We use the changelog author of the package in question the
3248 # author of this pseudo-merge. This is (roughly) correct if
3249 # this commit is simply representing aa non-dgit upload.
3250 # (Roughly because it does not record sponsorship - but we
3251 # don't have sponsorship info because that's in the .changes,
3252 # which isn't in the archivw.)
3254 # But, it might be that we are representing archive history
3255 # updates (including in-archive copies). These are not really
3256 # the responsibility of the person who created the .dsc, but
3257 # there is no-one whose name we should better use. (The
3258 # author of the .dsc-named commit is clearly worse.)
3260 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3261 my $author = clogp_authline $useclogp;
3262 my $cversion = getfield $useclogp, 'Version';
3264 my $mcf = dgit_privdir()."/mergecommit";
3265 open MC, ">", $mcf or die "$mcf $!";
3266 print MC <<END or die $!;
3270 my @parents = grep { $_->{Commit} } @mergeinputs;
3271 @parents = reverse @parents if $compat_info->{ReverseParents};
3272 print MC <<END or die $! foreach @parents;
3276 print MC <<END or die $!;
3282 if (defined $compat_info->{Message}) {
3283 print MC $compat_info->{Message} or die $!;
3285 print MC <<END or die $!;
3286 Record $package ($cversion) in archive suite $csuite
3290 my $message_add_info = sub {
3292 my $mversion = mergeinfo_version $mi;
3293 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3297 $message_add_info->($mergeinputs[0]);
3298 print MC <<END or die $!;
3299 should be treated as descended from
3301 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3305 $hash = make_commit $mcf;
3307 $hash = $mergeinputs[0]{Commit};
3309 printdebug "fetch hash=$hash\n";
3312 my ($lasth, $what) = @_;
3313 return unless $lasth;
3314 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3317 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3319 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3321 fetch_from_archive_record_1($hash);
3323 if (defined $skew_warning_vsn) {
3324 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3325 my $gotclogp = commit_getclogp($hash);
3326 my $got_vsn = getfield $gotclogp, 'Version';
3327 printdebug "SKEW CHECK GOT $got_vsn\n";
3328 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3329 print STDERR <<END or die $!;
3331 Warning: archive skew detected. Using the available version:
3332 Archive allegedly contains $skew_warning_vsn
3333 We were able to obtain only $got_vsn
3339 if ($lastfetch_hash ne $hash) {
3340 fetch_from_archive_record_2($hash);
3343 lrfetchref_used lrfetchref();
3345 check_gitattrs($hash, "fetched source tree");
3347 unshift @end, $del_lrfetchrefs;
3351 sub set_local_git_config ($$) {
3353 runcmd @git, qw(config), $k, $v;
3356 sub setup_mergechangelogs (;$) {
3358 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3360 my $driver = 'dpkg-mergechangelogs';
3361 my $cb = "merge.$driver";
3362 confess unless defined $maindir;
3363 my $attrs = "$maindir_gitcommon/info/attributes";
3364 ensuredir "$maindir_gitcommon/info";
3366 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3367 if (!open ATTRS, "<", $attrs) {
3368 $!==ENOENT or die "$attrs: $!";
3372 next if m{^debian/changelog\s};
3373 print NATTRS $_, "\n" or die $!;
3375 ATTRS->error and die $!;
3378 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3381 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3382 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3384 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3387 sub setup_useremail (;$) {
3389 return unless $always || access_cfg_bool(1, 'setup-useremail');
3392 my ($k, $envvar) = @_;
3393 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3394 return unless defined $v;
3395 set_local_git_config "user.$k", $v;
3398 $setup->('email', 'DEBEMAIL');
3399 $setup->('name', 'DEBFULLNAME');
3402 sub ensure_setup_existing_tree () {
3403 my $k = "remote.$remotename.skipdefaultupdate";
3404 my $c = git_get_config $k;
3405 return if defined $c;
3406 set_local_git_config $k, 'true';
3409 sub open_main_gitattrs () {
3410 confess 'internal error no maindir' unless defined $maindir;
3411 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3413 or die "open $maindir_gitcommon/info/attributes: $!";
3417 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3419 sub is_gitattrs_setup () {
3422 # 1: gitattributes set up and should be left alone
3424 # 0: there is a dgit-defuse-attrs but it needs fixing
3425 # undef: there is none
3426 my $gai = open_main_gitattrs();
3427 return 0 unless $gai;
3429 next unless m{$gitattrs_ourmacro_re};
3430 return 1 if m{\s-working-tree-encoding\s};
3431 printdebug "is_gitattrs_setup: found old macro\n";
3434 $gai->error and die $!;
3435 printdebug "is_gitattrs_setup: found nothing\n";
3439 sub setup_gitattrs (;$) {
3441 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3443 my $already = is_gitattrs_setup();
3446 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3447 not doing further gitattributes setup
3451 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3452 my $af = "$maindir_gitcommon/info/attributes";
3453 ensuredir "$maindir_gitcommon/info";
3455 open GAO, "> $af.new" or die $!;
3456 print GAO <<END or die $! unless defined $already;
3459 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3461 my $gai = open_main_gitattrs();
3464 if (m{$gitattrs_ourmacro_re}) {
3465 die unless defined $already;
3469 print GAO $_, "\n" or die $!;
3471 $gai->error and die $!;
3473 close GAO or die $!;
3474 rename "$af.new", "$af" or die "install $af: $!";
3477 sub setup_new_tree () {
3478 setup_mergechangelogs();
3483 sub check_gitattrs ($$) {
3484 my ($treeish, $what) = @_;
3486 return if is_gitattrs_setup;
3489 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3491 my $gafl = new IO::File;
3492 open $gafl, "-|", @cmd or die $!;
3495 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3497 next unless m{(?:^|/)\.gitattributes$};
3499 # oh dear, found one
3501 dgit: warning: $what contains .gitattributes
3502 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3507 # tree contains no .gitattributes files
3508 $?=0; $!=0; close $gafl or failedcmd @cmd;
3512 sub multisuite_suite_child ($$$) {
3513 my ($tsuite, $mergeinputs, $fn) = @_;
3514 # in child, sets things up, calls $fn->(), and returns undef
3515 # in parent, returns canonical suite name for $tsuite
3516 my $canonsuitefh = IO::File::new_tmpfile;
3517 my $pid = fork // die $!;
3521 $us .= " [$isuite]";
3522 $debugprefix .= " ";
3523 progress "fetching $tsuite...";
3524 canonicalise_suite();
3525 print $canonsuitefh $csuite, "\n" or die $!;
3526 close $canonsuitefh or die $!;
3530 waitpid $pid,0 == $pid or die $!;
3531 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3532 seek $canonsuitefh,0,0 or die $!;
3533 local $csuite = <$canonsuitefh>;
3534 die $! unless defined $csuite && chomp $csuite;
3536 printdebug "multisuite $tsuite missing\n";
3539 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3540 push @$mergeinputs, {
3547 sub fork_for_multisuite ($) {
3548 my ($before_fetch_merge) = @_;
3549 # if nothing unusual, just returns ''
3552 # returns 0 to caller in child, to do first of the specified suites
3553 # in child, $csuite is not yet set
3555 # returns 1 to caller in parent, to finish up anything needed after
3556 # in parent, $csuite is set to canonicalised portmanteau
3558 my $org_isuite = $isuite;
3559 my @suites = split /\,/, $isuite;
3560 return '' unless @suites > 1;
3561 printdebug "fork_for_multisuite: @suites\n";
3565 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3567 return 0 unless defined $cbasesuite;
3569 fail "package $package missing in (base suite) $cbasesuite"
3570 unless @mergeinputs;
3572 my @csuites = ($cbasesuite);
3574 $before_fetch_merge->();
3576 foreach my $tsuite (@suites[1..$#suites]) {
3577 $tsuite =~ s/^-/$cbasesuite-/;
3578 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3585 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3586 push @csuites, $csubsuite;
3589 foreach my $mi (@mergeinputs) {
3590 my $ref = git_get_ref $mi->{Ref};
3591 die "$mi->{Ref} ?" unless length $ref;
3592 $mi->{Commit} = $ref;
3595 $csuite = join ",", @csuites;
3597 my $previous = git_get_ref lrref;
3599 unshift @mergeinputs, {
3600 Commit => $previous,
3601 Info => "local combined tracking branch",
3603 "archive seems to have rewound: local tracking branch is ahead!",
3607 foreach my $ix (0..$#mergeinputs) {
3608 $mergeinputs[$ix]{Index} = $ix;
3611 @mergeinputs = sort {
3612 -version_compare(mergeinfo_version $a,
3613 mergeinfo_version $b) # highest version first
3615 $a->{Index} <=> $b->{Index}; # earliest in spec first
3621 foreach my $mi (@mergeinputs) {
3622 printdebug "multisuite merge check $mi->{Info}\n";
3623 foreach my $previous (@needed) {
3624 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3625 printdebug "multisuite merge un-needed $previous->{Info}\n";
3629 printdebug "multisuite merge this-needed\n";
3630 $mi->{Character} = '+';
3633 $needed[0]{Character} = '*';
3635 my $output = $needed[0]{Commit};
3638 printdebug "multisuite merge nontrivial\n";
3639 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3641 my $commit = "tree $tree\n";
3642 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3643 "Input branches:\n";
3645 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3646 printdebug "multisuite merge include $mi->{Info}\n";
3647 $mi->{Character} //= ' ';
3648 $commit .= "parent $mi->{Commit}\n";
3649 $msg .= sprintf " %s %-25s %s\n",
3651 (mergeinfo_version $mi),
3654 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3656 " * marks the highest version branch, which choose to use\n".
3657 " + marks each branch which was not already an ancestor\n\n".
3658 "[dgit multi-suite $csuite]\n";
3660 "author $authline\n".
3661 "committer $authline\n\n";
3662 $output = make_commit_text $commit.$msg;
3663 printdebug "multisuite merge generated $output\n";
3666 fetch_from_archive_record_1($output);
3667 fetch_from_archive_record_2($output);
3669 progress "calculated combined tracking suite $csuite";
3674 sub clone_set_head () {
3675 open H, "> .git/HEAD" or die $!;
3676 print H "ref: ".lref()."\n" or die $!;
3679 sub clone_finish ($) {
3681 runcmd @git, qw(reset --hard), lrref();
3682 runcmd qw(bash -ec), <<'END';
3684 git ls-tree -r --name-only -z HEAD | \
3685 xargs -0r touch -h -r . --
3687 printdone "ready for work in $dstdir";
3691 # in multisuite, returns twice!
3692 # once in parent after first suite fetched,
3693 # and then again in child after everything is finished
3695 badusage "dry run makes no sense with clone" unless act_local();
3697 my $multi_fetched = fork_for_multisuite(sub {
3698 printdebug "multi clone before fetch merge\n";
3702 if ($multi_fetched) {
3703 printdebug "multi clone after fetch merge\n";
3705 clone_finish($dstdir);
3708 printdebug "clone main body\n";
3710 canonicalise_suite();
3711 my $hasgit = check_for_git();
3712 mkdir $dstdir or fail "create \`$dstdir': $!";
3714 runcmd @git, qw(init -q);
3718 my $giturl = access_giturl(1);
3719 if (defined $giturl) {
3720 runcmd @git, qw(remote add), 'origin', $giturl;
3723 progress "fetching existing git history";
3725 runcmd_ordryrun_local @git, qw(fetch origin);
3727 progress "starting new git history";
3729 fetch_from_archive() or no_such_package;
3730 my $vcsgiturl = $dsc->{'Vcs-Git'};
3731 if (length $vcsgiturl) {
3732 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3733 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3735 clone_finish($dstdir);
3739 canonicalise_suite();
3740 if (check_for_git()) {
3743 fetch_from_archive() or no_such_package();
3745 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3746 if (length $vcsgiturl and
3747 (grep { $csuite eq $_ }
3749 cfg 'dgit.vcs-git.suites')) {
3750 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3751 if (defined $current && $current ne $vcsgiturl) {
3753 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3754 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3758 printdone "fetched into ".lrref();
3762 my $multi_fetched = fork_for_multisuite(sub { });
3763 fetch_one() unless $multi_fetched; # parent
3764 finish 0 if $multi_fetched eq '0'; # child
3769 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3771 printdone "fetched to ".lrref()." and merged into HEAD";
3774 sub check_not_dirty () {
3775 foreach my $f (qw(local-options local-patch-header)) {
3776 if (stat_exists "debian/source/$f") {
3777 fail "git tree contains debian/source/$f";
3781 return if $includedirty;
3783 git_check_unmodified();
3786 sub commit_admin ($) {
3789 runcmd_ordryrun_local @git, qw(commit -m), $m;
3792 sub quiltify_nofix_bail ($$) {
3793 my ($headinfo, $xinfo) = @_;
3794 if ($quilt_mode eq 'nofix') {
3795 fail "quilt fixup required but quilt mode is \`nofix'\n".
3796 "HEAD commit".$headinfo." differs from tree implied by ".
3797 " debian/patches".$xinfo;
3801 sub commit_quilty_patch () {
3802 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3804 foreach my $l (split /\n/, $output) {
3805 next unless $l =~ m/\S/;
3806 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3810 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3812 progress "nothing quilty to commit, ok.";
3815 quiltify_nofix_bail "", " (wanted to commit patch update)";
3816 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3817 runcmd_ordryrun_local @git, qw(add -f), @adds;
3819 Commit Debian 3.0 (quilt) metadata
3821 [dgit ($our_version) quilt-fixup]
3825 sub get_source_format () {
3827 if (open F, "debian/source/options") {
3831 s/\s+$//; # ignore missing final newline
3833 my ($k, $v) = ($`, $'); #');
3834 $v =~ s/^"(.*)"$/$1/;
3840 F->error and die $!;
3843 die $! unless $!==&ENOENT;
3846 if (!open F, "debian/source/format") {
3847 die $! unless $!==&ENOENT;
3851 F->error and die $!;
3853 return ($_, \%options);
3856 sub madformat_wantfixup ($) {
3858 return 0 unless $format eq '3.0 (quilt)';
3859 our $quilt_mode_warned;
3860 if ($quilt_mode eq 'nocheck') {
3861 progress "Not doing any fixup of \`$format' due to".
3862 " ----no-quilt-fixup or --quilt=nocheck"
3863 unless $quilt_mode_warned++;
3866 progress "Format \`$format', need to check/update patch stack"
3867 unless $quilt_mode_warned++;
3871 sub maybe_split_brain_save ($$$) {
3872 my ($headref, $dgitview, $msg) = @_;
3873 # => message fragment "$saved" describing disposition of $dgitview
3874 my $save = $internal_object_save{'dgit-view'};
3875 return "commit id $dgitview" unless defined $save;
3876 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3878 "dgit --dgit-view-save $msg HEAD=$headref",
3881 return "and left in $save";
3884 # An "infopair" is a tuple [ $thing, $what ]
3885 # (often $thing is a commit hash; $what is a description)
3887 sub infopair_cond_equal ($$) {
3889 $x->[0] eq $y->[0] or fail <<END;
3890 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3894 sub infopair_lrf_tag_lookup ($$) {
3895 my ($tagnames, $what) = @_;
3896 # $tagname may be an array ref
3897 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3898 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3899 foreach my $tagname (@tagnames) {
3900 my $lrefname = lrfetchrefs."/tags/$tagname";
3901 my $tagobj = $lrfetchrefs_f{$lrefname};
3902 next unless defined $tagobj;
3903 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3904 return [ git_rev_parse($tagobj), $what ];
3906 fail @tagnames==1 ? <<END : <<END;
3907 Wanted tag $what (@tagnames) on dgit server, but not found
3909 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3913 sub infopair_cond_ff ($$) {
3914 my ($anc,$desc) = @_;
3915 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3916 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3920 sub pseudomerge_version_check ($$) {
3921 my ($clogp, $archive_hash) = @_;
3923 my $arch_clogp = commit_getclogp $archive_hash;
3924 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3925 'version currently in archive' ];
3926 if (defined $overwrite_version) {
3927 if (length $overwrite_version) {
3928 infopair_cond_equal([ $overwrite_version,
3929 '--overwrite= version' ],
3932 my $v = $i_arch_v->[0];
3933 progress "Checking package changelog for archive version $v ...";
3936 my @xa = ("-f$v", "-t$v");
3937 my $vclogp = parsechangelog @xa;
3940 [ (getfield $vclogp, $fn),
3941 "$fn field from dpkg-parsechangelog @xa" ];
3943 my $cv = $gf->('Version');
3944 infopair_cond_equal($i_arch_v, $cv);
3945 $cd = $gf->('Distribution');
3948 $@ =~ s/^dgit: //gm;
3950 "Perhaps debian/changelog does not mention $v ?";
3952 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3953 $cd->[1] is $cd->[0]
3954 Your tree seems to based on earlier (not uploaded) $v.
3959 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3963 sub pseudomerge_make_commit ($$$$ $$) {
3964 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3965 $msg_cmd, $msg_msg) = @_;
3966 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3968 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3969 my $authline = clogp_authline $clogp;
3973 !defined $overwrite_version ? ""
3974 : !length $overwrite_version ? " --overwrite"
3975 : " --overwrite=".$overwrite_version;
3977 # Contributing parent is the first parent - that makes
3978 # git rev-list --first-parent DTRT.
3979 my $pmf = dgit_privdir()."/pseudomerge";
3980 open MC, ">", $pmf or die "$pmf $!";
3981 print MC <<END or die $!;
3984 parent $archive_hash
3994 return make_commit($pmf);
3997 sub splitbrain_pseudomerge ($$$$) {
3998 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3999 # => $merged_dgitview
4000 printdebug "splitbrain_pseudomerge...\n";
4002 # We: debian/PREVIOUS HEAD($maintview)
4003 # expect: o ----------------- o
4006 # a/d/PREVIOUS $dgitview
4009 # we do: `------------------ o
4013 return $dgitview unless defined $archive_hash;
4014 return $dgitview if deliberately_not_fast_forward();
4016 printdebug "splitbrain_pseudomerge...\n";
4018 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4020 if (!defined $overwrite_version) {
4021 progress "Checking that HEAD inciudes all changes in archive...";
4024 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4026 if (defined $overwrite_version) {
4028 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4029 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
4030 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4031 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
4032 my $i_archive = [ $archive_hash, "current archive contents" ];
4034 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4036 infopair_cond_equal($i_dgit, $i_archive);
4037 infopair_cond_ff($i_dep14, $i_dgit);
4038 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4041 $@ =~ s/^\n//; chomp $@;
4044 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4049 my $r = pseudomerge_make_commit
4050 $clogp, $dgitview, $archive_hash, $i_arch_v,
4051 "dgit --quilt=$quilt_mode",
4052 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4053 Declare fast forward from $i_arch_v->[0]
4055 Make fast forward from $i_arch_v->[0]
4058 maybe_split_brain_save $maintview, $r, "pseudomerge";
4060 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4064 sub plain_overwrite_pseudomerge ($$$) {
4065 my ($clogp, $head, $archive_hash) = @_;
4067 printdebug "plain_overwrite_pseudomerge...";
4069 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4071 return $head if is_fast_fwd $archive_hash, $head;
4073 my $m = "Declare fast forward from $i_arch_v->[0]";
4075 my $r = pseudomerge_make_commit
4076 $clogp, $head, $archive_hash, $i_arch_v,
4079 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4081 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4085 sub push_parse_changelog ($) {
4088 my $clogp = Dpkg::Control::Hash->new();
4089 $clogp->load($clogpfn) or die;
4091 my $clogpackage = getfield $clogp, 'Source';
4092 $package //= $clogpackage;
4093 fail "-p specified $package but changelog specified $clogpackage"
4094 unless $package eq $clogpackage;
4095 my $cversion = getfield $clogp, 'Version';
4097 if (!$we_are_initiator) {
4098 # rpush initiator can't do this because it doesn't have $isuite yet
4099 my $tag = debiantag($cversion, access_nomdistro);
4100 runcmd @git, qw(check-ref-format), $tag;
4103 my $dscfn = dscfn($cversion);
4105 return ($clogp, $cversion, $dscfn);
4108 sub push_parse_dsc ($$$) {
4109 my ($dscfn,$dscfnwhat, $cversion) = @_;
4110 $dsc = parsecontrol($dscfn,$dscfnwhat);
4111 my $dversion = getfield $dsc, 'Version';
4112 my $dscpackage = getfield $dsc, 'Source';
4113 ($dscpackage eq $package && $dversion eq $cversion) or
4114 fail "$dscfn is for $dscpackage $dversion".
4115 " but debian/changelog is for $package $cversion";
4118 sub push_tagwants ($$$$) {
4119 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4122 TagFn => \&debiantag,
4127 if (defined $maintviewhead) {
4129 TagFn => \&debiantag_maintview,
4130 Objid => $maintviewhead,
4131 TfSuffix => '-maintview',
4134 } elsif ($dodep14tag eq 'no' ? 0
4135 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4136 : $dodep14tag eq 'always'
4137 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4138 --dep14tag-always (or equivalent in config) means server must support
4139 both "new" and "maint" tag formats, but config says it doesn't.
4141 : die "$dodep14tag ?") {
4143 TagFn => \&debiantag_maintview,
4145 TfSuffix => '-dgit',
4149 foreach my $tw (@tagwants) {
4150 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4151 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4153 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4157 sub push_mktags ($$ $$ $) {
4159 $changesfile,$changesfilewhat,
4162 die unless $tagwants->[0]{View} eq 'dgit';
4164 my $declaredistro = access_nomdistro();
4165 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4166 $dsc->{$ourdscfield[0]} = join " ",
4167 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4169 $dsc->save("$dscfn.tmp") or die $!;
4171 my $changes = parsecontrol($changesfile,$changesfilewhat);
4172 foreach my $field (qw(Source Distribution Version)) {
4173 $changes->{$field} eq $clogp->{$field} or
4174 fail "changes field $field \`$changes->{$field}'".
4175 " does not match changelog \`$clogp->{$field}'";
4178 my $cversion = getfield $clogp, 'Version';
4179 my $clogsuite = getfield $clogp, 'Distribution';
4181 # We make the git tag by hand because (a) that makes it easier
4182 # to control the "tagger" (b) we can do remote signing
4183 my $authline = clogp_authline $clogp;
4184 my $delibs = join(" ", "",@deliberatelies);
4188 my $tfn = $tw->{Tfn};
4189 my $head = $tw->{Objid};
4190 my $tag = $tw->{Tag};
4192 open TO, '>', $tfn->('.tmp') or die $!;
4193 print TO <<END or die $!;
4200 if ($tw->{View} eq 'dgit') {
4201 print TO <<END or die $!;
4202 $package release $cversion for $clogsuite ($csuite) [dgit]
4203 [dgit distro=$declaredistro$delibs]
4205 foreach my $ref (sort keys %previously) {
4206 print TO <<END or die $!;
4207 [dgit previously:$ref=$previously{$ref}]
4210 } elsif ($tw->{View} eq 'maint') {
4211 print TO <<END or die $!;
4212 $package release $cversion for $clogsuite ($csuite)
4213 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4216 die Dumper($tw)."?";
4221 my $tagobjfn = $tfn->('.tmp');
4223 if (!defined $keyid) {
4224 $keyid = access_cfg('keyid','RETURN-UNDEF');
4226 if (!defined $keyid) {
4227 $keyid = getfield $clogp, 'Maintainer';
4229 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4230 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4231 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4232 push @sign_cmd, $tfn->('.tmp');
4233 runcmd_ordryrun @sign_cmd;
4235 $tagobjfn = $tfn->('.signed.tmp');
4236 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4237 $tfn->('.tmp'), $tfn->('.tmp.asc');
4243 my @r = map { $mktag->($_); } @$tagwants;
4247 sub sign_changes ($) {
4248 my ($changesfile) = @_;
4250 my @debsign_cmd = @debsign;
4251 push @debsign_cmd, "-k$keyid" if defined $keyid;
4252 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4253 push @debsign_cmd, $changesfile;
4254 runcmd_ordryrun @debsign_cmd;
4259 printdebug "actually entering push\n";
4261 supplementary_message(<<'END');
4262 Push failed, while checking state of the archive.
4263 You can retry the push, after fixing the problem, if you like.
4265 if (check_for_git()) {
4268 my $archive_hash = fetch_from_archive();
4269 if (!$archive_hash) {
4271 fail "package appears to be new in this suite;".
4272 " if this is intentional, use --new";
4275 supplementary_message(<<'END');
4276 Push failed, while preparing your push.
4277 You can retry the push, after fixing the problem, if you like.
4280 need_tagformat 'new', "quilt mode $quilt_mode"
4281 if quiltmode_splitbrain;
4285 access_giturl(); # check that success is vaguely likely
4286 rpush_handle_protovsn_bothends() if $we_are_initiator;
4289 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4290 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4292 responder_send_file('parsed-changelog', $clogpfn);
4294 my ($clogp, $cversion, $dscfn) =
4295 push_parse_changelog("$clogpfn");
4297 my $dscpath = "$buildproductsdir/$dscfn";
4298 stat_exists $dscpath or
4299 fail "looked for .dsc $dscpath, but $!;".
4300 " maybe you forgot to build";
4302 responder_send_file('dsc', $dscpath);
4304 push_parse_dsc($dscpath, $dscfn, $cversion);
4306 my $format = getfield $dsc, 'Format';
4307 printdebug "format $format\n";
4309 my $symref = git_get_symref();
4310 my $actualhead = git_rev_parse('HEAD');
4312 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4313 if (quiltmode_splitbrain()) {
4314 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4316 Branch is managed by git-debrebase ($ffq_prev
4317 exists), but quilt mode ($quilt_mode) implies a split view.
4318 Pass the right --quilt option or adjust your git config.
4319 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4322 runcmd_ordryrun_local @git_debrebase, 'stitch';
4323 $actualhead = git_rev_parse('HEAD');
4326 my $dgithead = $actualhead;
4327 my $maintviewhead = undef;
4329 my $upstreamversion = upstreamversion $clogp->{Version};
4331 if (madformat_wantfixup($format)) {
4332 # user might have not used dgit build, so maybe do this now:
4333 if (quiltmode_splitbrain()) {
4334 changedir $playground;
4335 quilt_make_fake_dsc($upstreamversion);
4337 ($dgithead, $cachekey) =
4338 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4340 "--quilt=$quilt_mode but no cached dgit view:
4341 perhaps HEAD changed since dgit build[-source] ?";
4343 $dgithead = splitbrain_pseudomerge($clogp,
4344 $actualhead, $dgithead,
4346 $maintviewhead = $actualhead;
4348 prep_ud(); # so _only_subdir() works, below
4350 commit_quilty_patch();
4354 if (defined $overwrite_version && !defined $maintviewhead
4356 $dgithead = plain_overwrite_pseudomerge($clogp,
4364 if ($archive_hash) {
4365 if (is_fast_fwd($archive_hash, $dgithead)) {
4367 } elsif (deliberately_not_fast_forward) {
4370 fail "dgit push: HEAD is not a descendant".
4371 " of the archive's version.\n".
4372 "To overwrite the archive's contents,".
4373 " pass --overwrite[=VERSION].\n".
4374 "To rewind history, if permitted by the archive,".
4375 " use --deliberately-not-fast-forward.";
4379 changedir $playground;
4380 progress "checking that $dscfn corresponds to HEAD";
4381 runcmd qw(dpkg-source -x --),
4382 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4383 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4384 check_for_vendor_patches() if madformat($dsc->{format});
4386 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4387 debugcmd "+",@diffcmd;
4389 my $r = system @diffcmd;
4392 my $referent = $split_brain ? $dgithead : 'HEAD';
4393 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4396 my $raw = cmdoutput @git,
4397 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4399 foreach (split /\0/, $raw) {
4400 if (defined $changed) {
4401 push @mode_changes, "$changed: $_\n" if $changed;
4404 } elsif (m/^:0+ 0+ /) {
4406 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4407 $changed = "Mode change from $1 to $2"
4412 if (@mode_changes) {
4413 fail <<END.(join '', @mode_changes).<<END;
4414 HEAD specifies a different tree to $dscfn:
4417 There is a problem with your source tree (see dgit(7) for some hints).
4418 To see a full diff, run git diff $tree $referent
4423 HEAD specifies a different tree to $dscfn:
4425 Perhaps you forgot to build. Or perhaps there is a problem with your
4426 source tree (see dgit(7) for some hints). To see a full diff, run
4427 git diff $tree $referent
4433 if (!$changesfile) {
4434 my $pat = changespat $cversion;
4435 my @cs = glob "$buildproductsdir/$pat";
4436 fail "failed to find unique changes file".
4437 " (looked for $pat in $buildproductsdir);".
4438 " perhaps you need to use dgit -C"
4440 ($changesfile) = @cs;
4442 $changesfile = "$buildproductsdir/$changesfile";
4445 # Check that changes and .dsc agree enough
4446 $changesfile =~ m{[^/]*$};
4447 my $changes = parsecontrol($changesfile,$&);
4448 files_compare_inputs($dsc, $changes)
4449 unless forceing [qw(dsc-changes-mismatch)];
4451 # Check whether this is a source only upload
4452 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4453 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4454 if ($sourceonlypolicy eq 'ok') {
4455 } elsif ($sourceonlypolicy eq 'always') {
4456 forceable_fail [qw(uploading-binaries)],
4457 "uploading binaries, although distroy policy is source only"
4459 } elsif ($sourceonlypolicy eq 'never') {
4460 forceable_fail [qw(uploading-source-only)],
4461 "source-only upload, although distroy policy requires .debs"
4463 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4464 forceable_fail [qw(uploading-source-only)],
4465 "source-only upload, even though package is entirely NEW\n".
4466 "(this is contrary to policy in ".(access_nomdistro()).")"
4469 && !(archive_query('package_not_wholly_new', $package) // 1);
4471 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4474 # Perhaps adjust .dsc to contain right set of origs
4475 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4477 unless forceing [qw(changes-origs-exactly)];
4479 # Checks complete, we're going to try and go ahead:
4481 responder_send_file('changes',$changesfile);
4482 responder_send_command("param head $dgithead");
4483 responder_send_command("param csuite $csuite");
4484 responder_send_command("param isuite $isuite");
4485 responder_send_command("param tagformat $tagformat");
4486 if (defined $maintviewhead) {
4487 confess "internal error (protovsn=$protovsn)"
4488 if defined $protovsn and $protovsn < 4;
4489 responder_send_command("param maint-view $maintviewhead");
4492 # Perhaps send buildinfo(s) for signing
4493 my $changes_files = getfield $changes, 'Files';
4494 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4495 foreach my $bi (@buildinfos) {
4496 responder_send_command("param buildinfo-filename $bi");
4497 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4500 if (deliberately_not_fast_forward) {
4501 git_for_each_ref(lrfetchrefs, sub {
4502 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4503 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4504 responder_send_command("previously $rrefname=$objid");
4505 $previously{$rrefname} = $objid;
4509 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4510 dgit_privdir()."/tag");
4513 supplementary_message(<<'END');
4514 Push failed, while signing the tag.
4515 You can retry the push, after fixing the problem, if you like.
4517 # If we manage to sign but fail to record it anywhere, it's fine.
4518 if ($we_are_responder) {
4519 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4520 responder_receive_files('signed-tag', @tagobjfns);
4522 @tagobjfns = push_mktags($clogp,$dscpath,
4523 $changesfile,$changesfile,
4526 supplementary_message(<<'END');
4527 Push failed, *after* signing the tag.
4528 If you want to try again, you should use a new version number.
4531 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4533 foreach my $tw (@tagwants) {
4534 my $tag = $tw->{Tag};
4535 my $tagobjfn = $tw->{TagObjFn};
4537 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4538 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4539 runcmd_ordryrun_local
4540 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4543 supplementary_message(<<'END');
4544 Push failed, while updating the remote git repository - see messages above.
4545 If you want to try again, you should use a new version number.
4547 if (!check_for_git()) {
4548 create_remote_git_repo();
4551 my @pushrefs = $forceflag.$dgithead.":".rrref();
4552 foreach my $tw (@tagwants) {
4553 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4556 runcmd_ordryrun @git,
4557 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4558 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4560 supplementary_message(<<'END');
4561 Push failed, while obtaining signatures on the .changes and .dsc.
4562 If it was just that the signature failed, you may try again by using
4563 debsign by hand to sign the changes file (see the command dgit tried,
4564 above), and then dput that changes file to complete the upload.
4565 If you need to change the package, you must use a new version number.
4567 if ($we_are_responder) {
4568 my $dryrunsuffix = act_local() ? "" : ".tmp";
4569 my @rfiles = ($dscpath, $changesfile);
4570 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4571 responder_receive_files('signed-dsc-changes',
4572 map { "$_$dryrunsuffix" } @rfiles);
4575 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4577 progress "[new .dsc left in $dscpath.tmp]";
4579 sign_changes $changesfile;
4582 supplementary_message(<<END);
4583 Push failed, while uploading package(s) to the archive server.
4584 You can retry the upload of exactly these same files with dput of:
4586 If that .changes file is broken, you will need to use a new version
4587 number for your next attempt at the upload.
4589 my $host = access_cfg('upload-host','RETURN-UNDEF');
4590 my @hostarg = defined($host) ? ($host,) : ();
4591 runcmd_ordryrun @dput, @hostarg, $changesfile;
4592 printdone "pushed and uploaded $cversion";
4594 supplementary_message('');
4595 responder_send_command("complete");
4599 not_necessarily_a_tree();
4604 badusage "-p is not allowed with clone; specify as argument instead"
4605 if defined $package;
4608 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4609 ($package,$isuite) = @ARGV;
4610 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4611 ($package,$dstdir) = @ARGV;
4612 } elsif (@ARGV==3) {
4613 ($package,$isuite,$dstdir) = @ARGV;
4615 badusage "incorrect arguments to dgit clone";
4619 $dstdir ||= "$package";
4620 if (stat_exists $dstdir) {
4621 fail "$dstdir already exists";
4625 if ($rmonerror && !$dryrun_level) {
4626 $cwd_remove= getcwd();
4628 return unless defined $cwd_remove;
4629 if (!chdir "$cwd_remove") {
4630 return if $!==&ENOENT;
4631 die "chdir $cwd_remove: $!";
4633 printdebug "clone rmonerror removing $dstdir\n";
4635 rmtree($dstdir) or die "remove $dstdir: $!\n";
4636 } elsif (grep { $! == $_ }
4637 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4639 print STDERR "check whether to remove $dstdir: $!\n";
4645 $cwd_remove = undef;
4648 sub branchsuite () {
4649 my $branch = git_get_symref();
4650 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4657 sub package_from_d_control () {
4658 if (!defined $package) {
4659 my $sourcep = parsecontrol('debian/control','debian/control');
4660 $package = getfield $sourcep, 'Source';
4664 sub fetchpullargs () {
4665 package_from_d_control();
4667 $isuite = branchsuite();
4669 my $clogp = parsechangelog();
4670 my $clogsuite = getfield $clogp, 'Distribution';
4671 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4673 } elsif (@ARGV==1) {
4676 badusage "incorrect arguments to dgit fetch or dgit pull";
4690 if (quiltmode_splitbrain()) {
4691 my ($format, $fopts) = get_source_format();
4692 madformat($format) and fail <<END
4693 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4701 package_from_d_control();
4702 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4706 foreach my $canon (qw(0 1)) {
4711 canonicalise_suite();
4713 if (length git_get_ref lref()) {
4714 # local branch already exists, yay
4717 if (!length git_get_ref lrref()) {
4725 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4728 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4729 "dgit checkout $isuite";
4730 runcmd (@git, qw(checkout), lbranch());
4733 sub cmd_update_vcs_git () {
4735 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4736 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4738 ($specsuite) = (@ARGV);
4743 if ($ARGV[0] eq '-') {
4745 } elsif ($ARGV[0] eq '-') {
4750 package_from_d_control();
4752 if ($specsuite eq '.') {
4753 $ctrl = parsecontrol 'debian/control', 'debian/control';
4755 $isuite = $specsuite;
4759 my $url = getfield $ctrl, 'Vcs-Git';
4762 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4763 if (!defined $orgurl) {
4764 print STDERR "setting up vcs-git: $url\n";
4765 @cmd = (@git, qw(remote add vcs-git), $url);
4766 } elsif ($orgurl eq $url) {
4767 print STDERR "vcs git already configured: $url\n";
4769 print STDERR "changing vcs-git url to: $url\n";
4770 @cmd = (@git, qw(remote set-url vcs-git), $url);
4772 runcmd_ordryrun_local @cmd;
4774 print "fetching (@ARGV)\n";
4775 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4781 build_or_push_prep_early();
4786 } elsif (@ARGV==1) {
4787 ($specsuite) = (@ARGV);
4789 badusage "incorrect arguments to dgit $subcommand";
4792 local ($package) = $existing_package; # this is a hack
4793 canonicalise_suite();
4795 canonicalise_suite();
4797 if (defined $specsuite &&
4798 $specsuite ne $isuite &&
4799 $specsuite ne $csuite) {
4800 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4801 " but command line specifies $specsuite";
4810 #---------- remote commands' implementation ----------
4812 sub pre_remote_push_build_host {
4813 my ($nrargs) = shift @ARGV;
4814 my (@rargs) = @ARGV[0..$nrargs-1];
4815 @ARGV = @ARGV[$nrargs..$#ARGV];
4817 my ($dir,$vsnwant) = @rargs;
4818 # vsnwant is a comma-separated list; we report which we have
4819 # chosen in our ready response (so other end can tell if they
4822 $we_are_responder = 1;
4823 $us .= " (build host)";
4825 open PI, "<&STDIN" or die $!;
4826 open STDIN, "/dev/null" or die $!;
4827 open PO, ">&STDOUT" or die $!;
4829 open STDOUT, ">&STDERR" or die $!;
4833 ($protovsn) = grep {
4834 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4835 } @rpushprotovsn_support;
4837 fail "build host has dgit rpush protocol versions ".
4838 (join ",", @rpushprotovsn_support).
4839 " but invocation host has $vsnwant"
4840 unless defined $protovsn;
4844 sub cmd_remote_push_build_host {
4845 responder_send_command("dgit-remote-push-ready $protovsn");
4849 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4850 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4851 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4852 # a good error message)
4854 sub rpush_handle_protovsn_bothends () {
4855 if ($protovsn < 4) {
4856 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4865 my $report = i_child_report();
4866 if (defined $report) {
4867 printdebug "($report)\n";
4868 } elsif ($i_child_pid) {
4869 printdebug "(killing build host child $i_child_pid)\n";
4870 kill 15, $i_child_pid;
4872 if (defined $i_tmp && !defined $initiator_tempdir) {
4874 eval { rmtree $i_tmp; };
4879 return unless forkcheck_mainprocess();
4884 my ($base,$selector,@args) = @_;
4885 $selector =~ s/\-/_/g;
4886 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4890 not_necessarily_a_tree();
4895 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4903 push @rargs, join ",", @rpushprotovsn_support;
4906 push @rdgit, @ropts;
4907 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4909 my @cmd = (@ssh, $host, shellquote @rdgit);
4912 $we_are_initiator=1;
4914 if (defined $initiator_tempdir) {
4915 rmtree $initiator_tempdir;
4916 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4917 $i_tmp = $initiator_tempdir;
4921 $i_child_pid = open2(\*RO, \*RI, @cmd);
4923 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4924 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4925 $supplementary_message = '' unless $protovsn >= 3;
4928 my ($icmd,$iargs) = initiator_expect {
4929 m/^(\S+)(?: (.*))?$/;
4932 i_method "i_resp", $icmd, $iargs;
4936 sub i_resp_progress ($) {
4938 my $msg = protocol_read_bytes \*RO, $rhs;
4942 sub i_resp_supplementary_message ($) {
4944 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4947 sub i_resp_complete {
4948 my $pid = $i_child_pid;
4949 $i_child_pid = undef; # prevents killing some other process with same pid
4950 printdebug "waiting for build host child $pid...\n";
4951 my $got = waitpid $pid, 0;
4952 die $! unless $got == $pid;
4953 die "build host child failed $?" if $?;
4956 printdebug "all done\n";
4960 sub i_resp_file ($) {
4962 my $localname = i_method "i_localname", $keyword;
4963 my $localpath = "$i_tmp/$localname";
4964 stat_exists $localpath and
4965 badproto \*RO, "file $keyword ($localpath) twice";
4966 protocol_receive_file \*RO, $localpath;
4967 i_method "i_file", $keyword;
4972 sub i_resp_param ($) {
4973 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4977 sub i_resp_previously ($) {
4978 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4979 or badproto \*RO, "bad previously spec";
4980 my $r = system qw(git check-ref-format), $1;
4981 die "bad previously ref spec ($r)" if $r;
4982 $previously{$1} = $2;
4987 sub i_resp_want ($) {
4989 die "$keyword ?" if $i_wanted{$keyword}++;
4991 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4992 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4993 die unless $isuite =~ m/^$suite_re$/;
4996 rpush_handle_protovsn_bothends();
4998 fail "rpush negotiated protocol version $protovsn".
4999 " which does not support quilt mode $quilt_mode"
5000 if quiltmode_splitbrain;
5002 my @localpaths = i_method "i_want", $keyword;
5003 printdebug "[[ $keyword @localpaths\n";
5004 foreach my $localpath (@localpaths) {
5005 protocol_send_file \*RI, $localpath;
5007 print RI "files-end\n" or die $!;
5010 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5012 sub i_localname_parsed_changelog {
5013 return "remote-changelog.822";
5015 sub i_file_parsed_changelog {
5016 ($i_clogp, $i_version, $i_dscfn) =
5017 push_parse_changelog "$i_tmp/remote-changelog.822";
5018 die if $i_dscfn =~ m#/|^\W#;
5021 sub i_localname_dsc {
5022 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5027 sub i_localname_buildinfo ($) {
5028 my $bi = $i_param{'buildinfo-filename'};
5029 defined $bi or badproto \*RO, "buildinfo before filename";
5030 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5031 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5032 or badproto \*RO, "improper buildinfo filename";
5035 sub i_file_buildinfo {
5036 my $bi = $i_param{'buildinfo-filename'};
5037 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5038 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5039 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5040 files_compare_inputs($bd, $ch);
5041 (getfield $bd, $_) eq (getfield $ch, $_) or
5042 fail "buildinfo mismatch $_"
5043 foreach qw(Source Version);
5044 !defined $bd->{$_} or
5045 fail "buildinfo contains $_"
5046 foreach qw(Changes Changed-by Distribution);
5048 push @i_buildinfos, $bi;
5049 delete $i_param{'buildinfo-filename'};
5052 sub i_localname_changes {
5053 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5054 $i_changesfn = $i_dscfn;
5055 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5056 return $i_changesfn;
5058 sub i_file_changes { }
5060 sub i_want_signed_tag {
5061 printdebug Dumper(\%i_param, $i_dscfn);
5062 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5063 && defined $i_param{'csuite'}
5064 or badproto \*RO, "premature desire for signed-tag";
5065 my $head = $i_param{'head'};
5066 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5068 my $maintview = $i_param{'maint-view'};
5069 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5072 if ($protovsn >= 4) {
5073 my $p = $i_param{'tagformat'} // '<undef>';
5075 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5078 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5080 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5082 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5085 push_mktags $i_clogp, $i_dscfn,
5086 $i_changesfn, 'remote changes',
5090 sub i_want_signed_dsc_changes {
5091 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5092 sign_changes $i_changesfn;
5093 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5096 #---------- building etc. ----------
5102 #----- `3.0 (quilt)' handling -----
5104 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5106 sub quiltify_dpkg_commit ($$$;$) {
5107 my ($patchname,$author,$msg, $xinfo) = @_;
5110 mkpath '.git/dgit'; # we are in playtree
5111 my $descfn = ".git/dgit/quilt-description.tmp";
5112 open O, '>', $descfn or die "$descfn: $!";
5113 $msg =~ s/\n+/\n\n/;
5114 print O <<END or die $!;
5116 ${xinfo}Subject: $msg
5123 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5124 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5125 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5126 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5130 sub quiltify_trees_differ ($$;$$$) {
5131 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5132 # returns true iff the two tree objects differ other than in debian/
5133 # with $finegrained,
5134 # returns bitmask 01 - differ in upstream files except .gitignore
5135 # 02 - differ in .gitignore
5136 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5137 # is set for each modified .gitignore filename $fn
5138 # if $unrepres is defined, array ref to which is appeneded
5139 # a list of unrepresentable changes (removals of upstream files
5142 my @cmd = (@git, qw(diff-tree -z --no-renames));
5143 push @cmd, qw(--name-only) unless $unrepres;
5144 push @cmd, qw(-r) if $finegrained || $unrepres;
5146 my $diffs= cmdoutput @cmd;
5149 foreach my $f (split /\0/, $diffs) {
5150 if ($unrepres && !@lmodes) {
5151 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5154 my ($oldmode,$newmode) = @lmodes;
5157 next if $f =~ m#^debian(?:/.*)?$#s;
5161 die "not a plain file or symlink\n"
5162 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5163 $oldmode =~ m/^(?:10|12)\d{4}$/;
5164 if ($oldmode =~ m/[^0]/ &&
5165 $newmode =~ m/[^0]/) {
5166 # both old and new files exist
5167 die "mode or type changed\n" if $oldmode ne $newmode;
5168 die "modified symlink\n" unless $newmode =~ m/^10/;
5169 } elsif ($oldmode =~ m/[^0]/) {
5171 die "deletion of symlink\n"
5172 unless $oldmode =~ m/^10/;
5175 die "creation with non-default mode\n"
5176 unless $newmode =~ m/^100644$/ or
5177 $newmode =~ m/^120000$/;
5181 local $/="\n"; chomp $@;
5182 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5186 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5187 $r |= $isignore ? 02 : 01;
5188 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5190 printdebug "quiltify_trees_differ $x $y => $r\n";
5194 sub quiltify_tree_sentinelfiles ($) {
5195 # lists the `sentinel' files present in the tree
5197 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5198 qw(-- debian/rules debian/control);
5203 sub quiltify_splitbrain_needed () {
5204 if (!$split_brain) {
5205 progress "dgit view: changes are required...";
5206 runcmd @git, qw(checkout -q -b dgit-view);
5211 sub quiltify_splitbrain ($$$$$$$) {
5212 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5213 $editedignores, $cachekey) = @_;
5214 my $gitignore_special = 1;
5215 if ($quilt_mode !~ m/gbp|dpm/) {
5216 # treat .gitignore just like any other upstream file
5217 $diffbits = { %$diffbits };
5218 $_ = !!$_ foreach values %$diffbits;
5219 $gitignore_special = 0;
5221 # We would like any commits we generate to be reproducible
5222 my @authline = clogp_authline($clogp);
5223 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5224 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5225 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5226 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5227 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5228 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5230 my $fulldiffhint = sub {
5232 my $cmd = "git diff $x $y -- :/ ':!debian'";
5233 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5234 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5237 if ($quilt_mode =~ m/gbp|unapplied/ &&
5238 ($diffbits->{O2H} & 01)) {
5240 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5241 " but git tree differs from orig in upstream files.";
5242 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5243 if (!stat_exists "debian/patches") {
5245 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5249 if ($quilt_mode =~ m/dpm/ &&
5250 ($diffbits->{H2A} & 01)) {
5251 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5252 --quilt=$quilt_mode specified, implying patches-applied git tree
5253 but git tree differs from result of applying debian/patches to upstream
5256 if ($quilt_mode =~ m/gbp|unapplied/ &&
5257 ($diffbits->{O2A} & 01)) { # some patches
5258 quiltify_splitbrain_needed();
5259 progress "dgit view: creating patches-applied version using gbp pq";
5260 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5261 # gbp pq import creates a fresh branch; push back to dgit-view
5262 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5263 runcmd @git, qw(checkout -q dgit-view);
5265 if ($quilt_mode =~ m/gbp|dpm/ &&
5266 ($diffbits->{O2A} & 02)) {
5268 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5269 tool which does not create patches for changes to upstream
5270 .gitignores: but, such patches exist in debian/patches.
5273 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5274 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5275 quiltify_splitbrain_needed();
5276 progress "dgit view: creating patch to represent .gitignore changes";
5277 ensuredir "debian/patches";
5278 my $gipatch = "debian/patches/auto-gitignore";
5279 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5280 stat GIPATCH or die "$gipatch: $!";
5281 fail "$gipatch already exists; but want to create it".
5282 " to record .gitignore changes" if (stat _)[7];
5283 print GIPATCH <<END or die "$gipatch: $!";
5284 Subject: Update .gitignore from Debian packaging branch
5286 The Debian packaging git branch contains these updates to the upstream
5287 .gitignore file(s). This patch is autogenerated, to provide these
5288 updates to users of the official Debian archive view of the package.
5290 [dgit ($our_version) update-gitignore]
5293 close GIPATCH or die "$gipatch: $!";
5294 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5295 $unapplied, $headref, "--", sort keys %$editedignores;
5296 open SERIES, "+>>", "debian/patches/series" or die $!;
5297 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5299 defined read SERIES, $newline, 1 or die $!;
5300 print SERIES "\n" or die $! unless $newline eq "\n";
5301 print SERIES "auto-gitignore\n" or die $!;
5302 close SERIES or die $!;
5303 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5305 Commit patch to update .gitignore
5307 [dgit ($our_version) update-gitignore-quilt-fixup]
5311 my $dgitview = git_rev_parse 'HEAD';
5314 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5316 changedir "$playground/work";
5318 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5319 progress "dgit view: created ($saved)";
5322 sub quiltify ($$$$) {
5323 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5325 # Quilt patchification algorithm
5327 # We search backwards through the history of the main tree's HEAD
5328 # (T) looking for a start commit S whose tree object is identical
5329 # to to the patch tip tree (ie the tree corresponding to the
5330 # current dpkg-committed patch series). For these purposes
5331 # `identical' disregards anything in debian/ - this wrinkle is
5332 # necessary because dpkg-source treates debian/ specially.
5334 # We can only traverse edges where at most one of the ancestors'
5335 # trees differs (in changes outside in debian/). And we cannot
5336 # handle edges which change .pc/ or debian/patches. To avoid
5337 # going down a rathole we avoid traversing edges which introduce
5338 # debian/rules or debian/control. And we set a limit on the
5339 # number of edges we are willing to look at.
5341 # If we succeed, we walk forwards again. For each traversed edge
5342 # PC (with P parent, C child) (starting with P=S and ending with
5343 # C=T) to we do this:
5345 # - dpkg-source --commit with a patch name and message derived from C
5346 # After traversing PT, we git commit the changes which
5347 # should be contained within debian/patches.
5349 # The search for the path S..T is breadth-first. We maintain a
5350 # todo list containing search nodes. A search node identifies a
5351 # commit, and looks something like this:
5353 # Commit => $git_commit_id,
5354 # Child => $c, # or undef if P=T
5355 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5356 # Nontrivial => true iff $p..$c has relevant changes
5363 my %considered; # saves being exponential on some weird graphs
5365 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5368 my ($search,$whynot) = @_;
5369 printdebug " search NOT $search->{Commit} $whynot\n";
5370 $search->{Whynot} = $whynot;
5371 push @nots, $search;
5372 no warnings qw(exiting);
5381 my $c = shift @todo;
5382 next if $considered{$c->{Commit}}++;
5384 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5386 printdebug "quiltify investigate $c->{Commit}\n";
5389 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5390 printdebug " search finished hooray!\n";
5395 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5396 if ($quilt_mode eq 'smash') {
5397 printdebug " search quitting smash\n";
5401 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5402 $not->($c, "has $c_sentinels not $t_sentinels")
5403 if $c_sentinels ne $t_sentinels;
5405 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5406 $commitdata =~ m/\n\n/;
5408 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5409 @parents = map { { Commit => $_, Child => $c } } @parents;
5411 $not->($c, "root commit") if !@parents;
5413 foreach my $p (@parents) {
5414 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5416 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5417 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5419 foreach my $p (@parents) {
5420 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5422 my @cmd= (@git, qw(diff-tree -r --name-only),
5423 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5424 my $patchstackchange = cmdoutput @cmd;
5425 if (length $patchstackchange) {
5426 $patchstackchange =~ s/\n/,/g;
5427 $not->($p, "changed $patchstackchange");
5430 printdebug " search queue P=$p->{Commit} ",
5431 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5437 printdebug "quiltify want to smash\n";
5440 my $x = $_[0]{Commit};
5441 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5444 my $reportnot = sub {
5446 my $s = $abbrev->($notp);
5447 my $c = $notp->{Child};
5448 $s .= "..".$abbrev->($c) if $c;
5449 $s .= ": ".$notp->{Whynot};
5452 if ($quilt_mode eq 'linear') {
5453 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5454 my $all_gdr = !!@nots;
5455 foreach my $notp (@nots) {
5456 print STDERR "$us: ", $reportnot->($notp), "\n";
5457 $all_gdr &&= $notp->{Child} &&
5458 (git_cat_file $notp->{Child}{Commit}, 'commit')
5459 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5463 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5465 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5467 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5468 } elsif ($quilt_mode eq 'smash') {
5469 } elsif ($quilt_mode eq 'auto') {
5470 progress "quilt fixup cannot be linear, smashing...";
5472 die "$quilt_mode ?";
5475 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5476 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5478 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5480 quiltify_dpkg_commit "auto-$version-$target-$time",
5481 (getfield $clogp, 'Maintainer'),
5482 "Automatically generated patch ($clogp->{Version})\n".
5483 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5487 progress "quiltify linearisation planning successful, executing...";
5489 for (my $p = $sref_S;
5490 my $c = $p->{Child};
5492 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5493 next unless $p->{Nontrivial};
5495 my $cc = $c->{Commit};
5497 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5498 $commitdata =~ m/\n\n/ or die "$c ?";
5501 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5504 my $commitdate = cmdoutput
5505 @git, qw(log -n1 --pretty=format:%aD), $cc;
5507 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5509 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5516 my $gbp_check_suitable = sub {
5521 die "contains unexpected slashes\n" if m{//} || m{/$};
5522 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5523 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5524 die "is series file\n" if m{$series_filename_re}o;
5525 die "too long" if length > 200;
5527 return $_ unless $@;
5528 print STDERR "quiltifying commit $cc:".
5529 " ignoring/dropping Gbp-Pq $what: $@";
5533 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5535 (\S+) \s* \n //ixm) {
5536 $patchname = $gbp_check_suitable->($1, 'Name');
5538 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5540 (\S+) \s* \n //ixm) {
5541 $patchdir = $gbp_check_suitable->($1, 'Topic');
5546 if (!defined $patchname) {
5547 $patchname = $title;
5548 $patchname =~ s/[.:]$//;
5551 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5552 my $translitname = $converter->convert($patchname);
5553 die unless defined $translitname;
5554 $patchname = $translitname;
5557 "dgit: patch title transliteration error: $@"
5559 $patchname =~ y/ A-Z/-a-z/;
5560 $patchname =~ y/-a-z0-9_.+=~//cd;
5561 $patchname =~ s/^\W/x-$&/;
5562 $patchname = substr($patchname,0,40);
5563 $patchname .= ".patch";
5565 if (!defined $patchdir) {
5568 if (length $patchdir) {
5569 $patchname = "$patchdir/$patchname";
5571 if ($patchname =~ m{^(.*)/}) {
5572 mkpath "debian/patches/$1";
5577 stat "debian/patches/$patchname$index";
5579 $!==ENOENT or die "$patchname$index $!";
5581 runcmd @git, qw(checkout -q), $cc;
5583 # We use the tip's changelog so that dpkg-source doesn't
5584 # produce complaining messages from dpkg-parsechangelog. None
5585 # of the information dpkg-source gets from the changelog is
5586 # actually relevant - it gets put into the original message
5587 # which dpkg-source provides our stunt editor, and then
5589 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5591 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5592 "Date: $commitdate\n".
5593 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5595 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5598 runcmd @git, qw(checkout -q master);
5601 sub build_maybe_quilt_fixup () {
5602 my ($format,$fopts) = get_source_format;
5603 return unless madformat_wantfixup $format;
5606 check_for_vendor_patches();
5608 if (quiltmode_splitbrain) {
5609 fail <<END unless access_cfg_tagformats_can_splitbrain;
5610 quilt mode $quilt_mode requires split view so server needs to support
5611 both "new" and "maint" tag formats, but config says it doesn't.
5615 my $clogp = parsechangelog();
5616 my $headref = git_rev_parse('HEAD');
5617 my $symref = git_get_symref();
5619 if ($quilt_mode eq 'linear'
5620 && !$fopts->{'single-debian-patch'}
5621 && branch_is_gdr($headref)) {
5622 # This is much faster. It also makes patches that gdr
5623 # likes better for future updates without laundering.
5625 # However, it can fail in some casses where we would
5626 # succeed: if there are existing patches, which correspond
5627 # to a prefix of the branch, but are not in gbp/gdr
5628 # format, gdr will fail (exiting status 7), but we might
5629 # be able to figure out where to start linearising. That
5630 # will be slower so hopefully there's not much to do.
5631 my @cmd = (@git_debrebase,
5632 qw(--noop-ok -funclean-mixed -funclean-ordering
5633 make-patches --quiet-would-amend));
5634 # We tolerate soe snags that gdr wouldn't, by default.
5638 failedcmd @cmd if system @cmd and $?!=7*256;
5642 $headref = git_rev_parse('HEAD');
5646 changedir $playground;
5648 my $upstreamversion = upstreamversion $version;
5650 if ($fopts->{'single-debian-patch'}) {
5651 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5653 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5657 runcmd_ordryrun_local
5658 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5661 sub unpack_playtree_mkwork ($) {
5664 mkdir "work" or die $!;
5666 mktree_in_ud_here();
5667 runcmd @git, qw(reset -q --hard), $headref;
5670 sub unpack_playtree_linkorigs ($$) {
5671 my ($upstreamversion, $fn) = @_;
5672 # calls $fn->($leafname);
5674 my $bpd_abs = bpd_abs();
5675 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5676 while ($!=0, defined(my $b = readdir QFD)) {
5677 my $f = bpd_abs()."/".$b;
5679 local ($debuglevel) = $debuglevel-1;
5680 printdebug "QF linkorigs $b, $f ?\n";
5682 next unless is_orig_file_of_vsn $b, $upstreamversion;
5683 printdebug "QF linkorigs $b, $f Y\n";
5684 link_ltarget $f, $b or die "$b $!";
5687 die "$buildproductsdir: $!" if $!;
5691 sub quilt_fixup_delete_pc () {
5692 runcmd @git, qw(rm -rqf .pc);
5694 Commit removal of .pc (quilt series tracking data)
5696 [dgit ($our_version) upgrade quilt-remove-pc]
5700 sub quilt_fixup_singlepatch ($$$) {
5701 my ($clogp, $headref, $upstreamversion) = @_;
5703 progress "starting quiltify (single-debian-patch)";
5705 # dpkg-source --commit generates new patches even if
5706 # single-debian-patch is in debian/source/options. In order to
5707 # get it to generate debian/patches/debian-changes, it is
5708 # necessary to build the source package.
5710 unpack_playtree_linkorigs($upstreamversion, sub { });
5711 unpack_playtree_mkwork($headref);
5713 rmtree("debian/patches");
5715 runcmd @dpkgsource, qw(-b .);
5717 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5718 rename srcfn("$upstreamversion", "/debian/patches"),
5719 "work/debian/patches";
5722 commit_quilty_patch();
5725 sub quilt_make_fake_dsc ($) {
5726 my ($upstreamversion) = @_;
5728 my $fakeversion="$upstreamversion-~~DGITFAKE";
5730 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5731 print $fakedsc <<END or die $!;
5734 Version: $fakeversion
5738 my $dscaddfile=sub {
5741 my $md = new Digest::MD5;
5743 my $fh = new IO::File $b, '<' or die "$b $!";
5748 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5751 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5753 my @files=qw(debian/source/format debian/rules
5754 debian/control debian/changelog);
5755 foreach my $maybe (qw(debian/patches debian/source/options
5756 debian/tests/control)) {
5757 next unless stat_exists "$maindir/$maybe";
5758 push @files, $maybe;
5761 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5762 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5764 $dscaddfile->($debtar);
5765 close $fakedsc or die $!;
5768 sub quilt_fakedsc2unapplied ($$) {
5769 my ($headref, $upstreamversion) = @_;
5770 # must be run in the playground
5771 # quilt_make_fake_dsc must have been called
5774 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5776 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5777 rename $fakexdir, "fake" or die "$fakexdir $!";
5781 remove_stray_gits("source package");
5782 mktree_in_ud_here();
5786 rmtree 'debian'; # git checkout commitish paths does not delete!
5787 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5788 my $unapplied=git_add_write_tree();
5789 printdebug "fake orig tree object $unapplied\n";
5793 sub quilt_check_splitbrain_cache ($$) {
5794 my ($headref, $upstreamversion) = @_;
5795 # Called only if we are in (potentially) split brain mode.
5796 # Called in playground.
5797 # Computes the cache key and looks in the cache.
5798 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5800 my $splitbrain_cachekey;
5803 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5804 # we look in the reflog of dgit-intern/quilt-cache
5805 # we look for an entry whose message is the key for the cache lookup
5806 my @cachekey = (qw(dgit), $our_version);
5807 push @cachekey, $upstreamversion;
5808 push @cachekey, $quilt_mode;
5809 push @cachekey, $headref;
5811 push @cachekey, hashfile('fake.dsc');
5813 my $srcshash = Digest::SHA->new(256);
5814 my %sfs = ( %INC, '$0(dgit)' => $0 );
5815 foreach my $sfk (sort keys %sfs) {
5816 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5817 $srcshash->add($sfk," ");
5818 $srcshash->add(hashfile($sfs{$sfk}));
5819 $srcshash->add("\n");
5821 push @cachekey, $srcshash->hexdigest();
5822 $splitbrain_cachekey = "@cachekey";
5824 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5826 my $cachehit = reflog_cache_lookup
5827 "refs/$splitbraincache", $splitbrain_cachekey;
5830 unpack_playtree_mkwork($headref);
5831 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5832 if ($cachehit ne $headref) {
5833 progress "dgit view: found cached ($saved)";
5834 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5836 return ($cachehit, $splitbrain_cachekey);
5838 progress "dgit view: found cached, no changes required";
5839 return ($headref, $splitbrain_cachekey);
5842 printdebug "splitbrain cache miss\n";
5843 return (undef, $splitbrain_cachekey);
5846 sub quilt_fixup_multipatch ($$$) {
5847 my ($clogp, $headref, $upstreamversion) = @_;
5849 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5852 # - honour any existing .pc in case it has any strangeness
5853 # - determine the git commit corresponding to the tip of
5854 # the patch stack (if there is one)
5855 # - if there is such a git commit, convert each subsequent
5856 # git commit into a quilt patch with dpkg-source --commit
5857 # - otherwise convert all the differences in the tree into
5858 # a single git commit
5862 # Our git tree doesn't necessarily contain .pc. (Some versions of
5863 # dgit would include the .pc in the git tree.) If there isn't
5864 # one, we need to generate one by unpacking the patches that we
5867 # We first look for a .pc in the git tree. If there is one, we
5868 # will use it. (This is not the normal case.)
5870 # Otherwise need to regenerate .pc so that dpkg-source --commit
5871 # can work. We do this as follows:
5872 # 1. Collect all relevant .orig from parent directory
5873 # 2. Generate a debian.tar.gz out of
5874 # debian/{patches,rules,source/format,source/options}
5875 # 3. Generate a fake .dsc containing just these fields:
5876 # Format Source Version Files
5877 # 4. Extract the fake .dsc
5878 # Now the fake .dsc has a .pc directory.
5879 # (In fact we do this in every case, because in future we will
5880 # want to search for a good base commit for generating patches.)
5882 # Then we can actually do the dpkg-source --commit
5883 # 1. Make a new working tree with the same object
5884 # store as our main tree and check out the main
5886 # 2. Copy .pc from the fake's extraction, if necessary
5887 # 3. Run dpkg-source --commit
5888 # 4. If the result has changes to debian/, then
5889 # - git add them them
5890 # - git add .pc if we had a .pc in-tree
5892 # 5. If we had a .pc in-tree, delete it, and git commit
5893 # 6. Back in the main tree, fast forward to the new HEAD
5895 # Another situation we may have to cope with is gbp-style
5896 # patches-unapplied trees.
5898 # We would want to detect these, so we know to escape into
5899 # quilt_fixup_gbp. However, this is in general not possible.
5900 # Consider a package with a one patch which the dgit user reverts
5901 # (with git revert or the moral equivalent).
5903 # That is indistinguishable in contents from a patches-unapplied
5904 # tree. And looking at the history to distinguish them is not
5905 # useful because the user might have made a confusing-looking git
5906 # history structure (which ought to produce an error if dgit can't
5907 # cope, not a silent reintroduction of an unwanted patch).
5909 # So gbp users will have to pass an option. But we can usually
5910 # detect their failure to do so: if the tree is not a clean
5911 # patches-applied tree, quilt linearisation fails, but the tree
5912 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5913 # they want --quilt=unapplied.
5915 # To help detect this, when we are extracting the fake dsc, we
5916 # first extract it with --skip-patches, and then apply the patches
5917 # afterwards with dpkg-source --before-build. That lets us save a
5918 # tree object corresponding to .origs.
5920 my $splitbrain_cachekey;
5922 quilt_make_fake_dsc($upstreamversion);
5924 if (quiltmode_splitbrain()) {
5926 ($cachehit, $splitbrain_cachekey) =
5927 quilt_check_splitbrain_cache($headref, $upstreamversion);
5928 return if $cachehit;
5930 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
5934 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5936 if (system @bbcmd) {
5937 failedcmd @bbcmd if $? < 0;
5939 failed to apply your git tree's patch stack (from debian/patches/) to
5940 the corresponding upstream tarball(s). Your source tree and .orig
5941 are probably too inconsistent. dgit can only fix up certain kinds of
5942 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5948 unpack_playtree_mkwork($headref);
5951 if (stat_exists ".pc") {
5953 progress "Tree already contains .pc - will use it then delete it.";
5956 rename '../fake/.pc','.pc' or die $!;
5959 changedir '../fake';
5961 my $oldtiptree=git_add_write_tree();
5962 printdebug "fake o+d/p tree object $unapplied\n";
5963 changedir '../work';
5966 # We calculate some guesswork now about what kind of tree this might
5967 # be. This is mostly for error reporting.
5973 # O = orig, without patches applied
5974 # A = "applied", ie orig with H's debian/patches applied
5975 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5976 \%editedignores, \@unrepres),
5977 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5978 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5982 foreach my $b (qw(01 02)) {
5983 foreach my $v (qw(O2H O2A H2A)) {
5984 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5987 printdebug "differences \@dl @dl.\n";
5990 "$us: base trees orig=%.20s o+d/p=%.20s",
5991 $unapplied, $oldtiptree;
5993 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5994 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5995 $dl[0], $dl[1], $dl[3], $dl[4],
5999 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
6001 forceable_fail [qw(unrepresentable)], <<END;
6002 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6007 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6008 push @failsuggestion, [ 'unapplied',
6009 "This might be a patches-unapplied branch." ];
6010 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6011 push @failsuggestion, [ 'applied',
6012 "This might be a patches-applied branch." ];
6014 push @failsuggestion, [ 'quilt-mode',
6015 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6017 push @failsuggestion, [ 'gitattrs',
6018 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6019 if stat_exists '.gitattributes';
6021 push @failsuggestion, [ 'origs',
6022 "Maybe orig tarball(s) are not identical to git representation?" ];
6024 if (quiltmode_splitbrain()) {
6025 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6026 $diffbits, \%editedignores,
6027 $splitbrain_cachekey);
6031 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6032 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6034 if (!open P, '>>', ".pc/applied-patches") {
6035 $!==&ENOENT or die $!;
6040 commit_quilty_patch();
6042 if ($mustdeletepc) {
6043 quilt_fixup_delete_pc();
6047 sub quilt_fixup_editor () {
6048 my $descfn = $ENV{$fakeeditorenv};
6049 my $editing = $ARGV[$#ARGV];
6050 open I1, '<', $descfn or die "$descfn: $!";
6051 open I2, '<', $editing or die "$editing: $!";
6052 unlink $editing or die "$editing: $!";
6053 open O, '>', $editing or die "$editing: $!";
6054 while (<I1>) { print O or die $!; } I1->error and die $!;
6057 $copying ||= m/^\-\-\- /;
6058 next unless $copying;
6061 I2->error and die $!;
6066 sub maybe_apply_patches_dirtily () {
6067 return unless $quilt_mode =~ m/gbp|unapplied/;
6068 print STDERR <<END or die $!;
6070 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6071 dgit: Have to apply the patches - making the tree dirty.
6072 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6075 $patches_applied_dirtily = 01;
6076 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6077 runcmd qw(dpkg-source --before-build .);
6080 sub maybe_unapply_patches_again () {
6081 progress "dgit: Unapplying patches again to tidy up the tree."
6082 if $patches_applied_dirtily;
6083 runcmd qw(dpkg-source --after-build .)
6084 if $patches_applied_dirtily & 01;
6086 if $patches_applied_dirtily & 02;
6087 $patches_applied_dirtily = 0;
6090 #----- other building -----
6092 our $clean_using_builder;
6093 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6094 # clean the tree before building (perhaps invoked indirectly by
6095 # whatever we are using to run the build), rather than separately
6096 # and explicitly by us.
6099 return if $clean_using_builder;
6100 if ($cleanmode eq 'dpkg-source') {
6101 maybe_apply_patches_dirtily();
6102 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6103 } elsif ($cleanmode eq 'dpkg-source-d') {
6104 maybe_apply_patches_dirtily();
6105 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6106 } elsif ($cleanmode eq 'git') {
6107 runcmd_ordryrun_local @git, qw(clean -xdf);
6108 } elsif ($cleanmode eq 'git-ff') {
6109 runcmd_ordryrun_local @git, qw(clean -xdff);
6110 } elsif ($cleanmode eq 'check') {
6111 my $leftovers = cmdoutput @git, qw(clean -xdn);
6112 if (length $leftovers) {
6113 print STDERR $leftovers, "\n" or die $!;
6114 fail "tree contains uncommitted files and --clean=check specified";
6116 } elsif ($cleanmode eq 'none') {
6123 badusage "clean takes no additional arguments" if @ARGV;
6126 maybe_unapply_patches_again();
6129 # return values from massage_dbp_args are one or both of these flags
6130 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6131 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6133 sub build_or_push_prep_early () {
6134 our $build_or_push_prep_early_done //= 0;
6135 return if $build_or_push_prep_early_done++;
6136 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6137 my $clogp = parsechangelog();
6138 $isuite = getfield $clogp, 'Distribution';
6139 $package = getfield $clogp, 'Source';
6140 $version = getfield $clogp, 'Version';
6141 $dscfn = dscfn($version);
6144 sub build_prep_early () {
6145 build_or_push_prep_early();
6150 sub build_prep ($) {
6153 # clean the tree if we're trying to include dirty changes in the
6154 # source package, or we are running the builder in $maindir
6155 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6156 build_maybe_quilt_fixup();
6158 my $pat = changespat $version;
6159 foreach my $f (glob "$buildproductsdir/$pat") {
6161 unlink $f or fail "remove old changes file $f: $!";
6163 progress "would remove $f";
6169 sub changesopts_initial () {
6170 my @opts =@changesopts[1..$#changesopts];
6173 sub changesopts_version () {
6174 if (!defined $changes_since_version) {
6177 @vsns = archive_query('archive_query');
6178 my @quirk = access_quirk();
6179 if ($quirk[0] eq 'backports') {
6180 local $isuite = $quirk[2];
6182 canonicalise_suite();
6183 push @vsns, archive_query('archive_query');
6189 "archive query failed (queried because --since-version not specified)";
6192 @vsns = map { $_->[0] } @vsns;
6193 @vsns = sort { -version_compare($a, $b) } @vsns;
6194 $changes_since_version = $vsns[0];
6195 progress "changelog will contain changes since $vsns[0]";
6197 $changes_since_version = '_';
6198 progress "package seems new, not specifying -v<version>";
6201 if ($changes_since_version ne '_') {
6202 return ("-v$changes_since_version");
6208 sub changesopts () {
6209 return (changesopts_initial(), changesopts_version());
6212 sub massage_dbp_args ($;$) {
6213 my ($cmd,$xargs) = @_;
6214 # Since we split the source build out so we can do strange things
6215 # to it, massage the arguments to dpkg-buildpackage so that the
6216 # main build doessn't build source (or add an argument to stop it
6217 # building source by default).
6218 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6219 # -nc has the side effect of specifying -b if nothing else specified
6220 # and some combinations of -S, -b, et al, are errors, rather than
6221 # later simply overriding earlie. So we need to:
6222 # - search the command line for these options
6223 # - pick the last one
6224 # - perhaps add our own as a default
6225 # - perhaps adjust it to the corresponding non-source-building version
6227 foreach my $l ($cmd, $xargs) {
6229 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6232 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6233 my $r = WANTSRC_BUILDER;
6234 printdebug "massage split $dmode.\n";
6235 if ($dmode =~ s/^--build=//) {
6237 my @d = split /,/, $dmode;
6238 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6239 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6240 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6241 fail "Wanted to build nothing!" unless $r;
6242 $dmode = '--build='. join ',', grep m/./, @d;
6245 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6246 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6247 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6250 printdebug "massage done $r $dmode.\n";
6252 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6258 my $wasdir = must_getcwd();
6259 changedir $buildproductsdir;
6264 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6265 sub postbuild_mergechanges ($) {
6266 my ($msg_if_onlyone) = @_;
6267 # If there is only one .changes file, fail with $msg_if_onlyone,
6268 # or if that is undef, be a no-op.
6269 # Returns the changes file to report to the user.
6270 my $pat = changespat $version;
6271 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6272 @changesfiles = sort {
6273 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6277 if (@changesfiles==1) {
6278 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6279 only one changes file from build (@changesfiles)
6281 $result = $changesfiles[0];
6282 } elsif (@changesfiles==2) {
6283 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6284 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6285 fail "$l found in binaries changes file $binchanges"
6288 runcmd_ordryrun_local @mergechanges, @changesfiles;
6289 my $multichanges = changespat $version,'multi';
6291 stat_exists $multichanges or fail "$multichanges: $!";
6292 foreach my $cf (glob $pat) {
6293 next if $cf eq $multichanges;
6294 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6297 $result = $multichanges;
6299 fail "wrong number of different changes files (@changesfiles)";
6301 printdone "build successful, results in $result\n" or die $!;
6304 sub midbuild_checkchanges () {
6305 my $pat = changespat $version;
6306 return if $rmchanges;
6307 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6309 $_ ne changespat $version,'source' and
6310 $_ ne changespat $version,'multi'
6313 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6314 Suggest you delete @unwanted.
6319 sub midbuild_checkchanges_vanilla ($) {
6321 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6324 sub postbuild_mergechanges_vanilla ($) {
6326 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6328 postbuild_mergechanges(undef);
6331 printdone "build successful\n";
6337 $buildproductsdir eq '..' or print STDERR <<END;
6338 $us: warning: build-products-dir set, but not supported by dpkg-buildpackage
6339 $us: warning: build-products-dir will be ignored; files will go to ..
6341 $buildproductsdir = '..';
6342 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6343 my $wantsrc = massage_dbp_args \@dbp;
6344 build_prep($wantsrc);
6345 if ($wantsrc & WANTSRC_SOURCE) {
6347 midbuild_checkchanges_vanilla $wantsrc;
6349 if ($wantsrc & WANTSRC_BUILDER) {
6350 push @dbp, changesopts_version();
6351 maybe_apply_patches_dirtily();
6352 runcmd_ordryrun_local @dbp;
6354 maybe_unapply_patches_again();
6355 postbuild_mergechanges_vanilla $wantsrc;
6359 $quilt_mode //= 'gbp';
6365 # gbp can make .origs out of thin air. In my tests it does this
6366 # even for a 1.0 format package, with no origs present. So I
6367 # guess it keys off just the version number. We don't know
6368 # exactly what .origs ought to exist, but let's assume that we
6369 # should run gbp if: the version has an upstream part and the main
6371 my $upstreamversion = upstreamversion $version;
6372 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6373 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6375 if ($gbp_make_orig) {
6377 $cleanmode = 'none'; # don't do it again
6380 my @dbp = @dpkgbuildpackage;
6382 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6384 if (!length $gbp_build[0]) {
6385 if (length executable_on_path('git-buildpackage')) {
6386 $gbp_build[0] = qw(git-buildpackage);
6388 $gbp_build[0] = 'gbp buildpackage';
6391 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6393 push @cmd, (qw(-us -uc --git-no-sign-tags),
6394 "--git-builder=".(shellquote @dbp));
6396 if ($gbp_make_orig) {
6397 my $priv = dgit_privdir();
6398 my $ok = "$priv/origs-gen-ok";
6399 unlink $ok or $!==&ENOENT or die $!;
6400 my @origs_cmd = @cmd;
6401 push @origs_cmd, qw(--git-cleaner=true);
6402 push @origs_cmd, "--git-prebuild=".
6403 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6404 push @origs_cmd, @ARGV;
6406 debugcmd @origs_cmd;
6408 do { local $!; stat_exists $ok; }
6409 or failedcmd @origs_cmd;
6411 dryrun_report @origs_cmd;
6415 build_prep($wantsrc);
6416 if ($wantsrc & WANTSRC_SOURCE) {
6418 midbuild_checkchanges_vanilla $wantsrc;
6420 if (!$clean_using_builder) {
6421 push @cmd, '--git-cleaner=true';
6424 maybe_unapply_patches_again();
6425 if ($wantsrc & WANTSRC_BUILDER) {
6426 push @cmd, changesopts();
6427 runcmd_ordryrun_local @cmd, @ARGV;
6429 postbuild_mergechanges_vanilla $wantsrc;
6431 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6433 sub building_source_in_playtree {
6434 # If $includedirty, we have to build the source package from the
6435 # working tree, not a playtree, so that uncommitted changes are
6436 # included (copying or hardlinking them into the playtree could
6439 # Note that if we are building a source package in split brain
6440 # mode we do not support including uncommitted changes, because
6441 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6442 # building a source package)) => !$includedirty
6443 return !$includedirty;
6447 $sourcechanges = changespat $version,'source';
6449 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6450 or fail "remove $sourcechanges: $!";
6452 my @cmd = (@dpkgsource, qw(-b --));
6454 if (building_source_in_playtree()) {
6456 my $headref = git_rev_parse('HEAD');
6457 # If we are in split brain, there is already a playtree with
6458 # the thing we should package into a .dsc (thanks to quilt
6459 # fixup). If not, make a playtree
6460 prep_ud() unless $split_brain;
6461 changedir $playground;
6462 unless ($split_brain) {
6463 my $upstreamversion = upstreamversion $version;
6464 unpack_playtree_linkorigs($upstreamversion, sub { });
6465 unpack_playtree_mkwork($headref);
6469 $leafdir = basename $maindir;
6472 runcmd_ordryrun_local @cmd, $leafdir;
6475 runcmd_ordryrun_local qw(sh -ec),
6476 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6477 @dpkggenchanges, qw(-S), changesopts();
6480 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6481 $dsc = parsecontrol($dscfn, "source package");
6485 printdebug " renaming ($why) $l\n";
6486 rename "$l", bpd_abs()."/$l"
6487 or fail "put in place new built file ($l): $!";
6489 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6490 $l =~ m/\S+$/ or next;
6493 $mv->('dsc', $dscfn);
6494 $mv->('changes', $sourcechanges);
6499 sub cmd_build_source {
6500 badusage "build-source takes no additional arguments" if @ARGV;
6501 build_prep(WANTSRC_SOURCE);
6503 maybe_unapply_patches_again();
6504 printdone "source built, results in $dscfn and $sourcechanges";
6507 sub cmd_push_source {
6509 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6510 "sense with push-source!" if $includedirty;
6511 build_maybe_quilt_fixup();
6513 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6514 "source changes file");
6515 unless (test_source_only_changes($changes)) {
6516 fail "user-specified changes file is not source-only";
6519 # Building a source package is very fast, so just do it
6521 die "er, patches are applied dirtily but shouldn't be.."
6522 if $patches_applied_dirtily;
6523 $changesfile = $sourcechanges;
6528 sub binary_builder {
6529 my ($bbuilder, $pbmc_msg, @args) = @_;
6530 build_prep(WANTSRC_SOURCE);
6532 midbuild_checkchanges();
6535 stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
6536 stat_exists $sourcechanges
6537 or fail "$sourcechanges (in build products dir): $!";
6539 runcmd_ordryrun_local @$bbuilder, @args;
6541 maybe_unapply_patches_again();
6543 postbuild_mergechanges($pbmc_msg);
6549 binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
6550 perhaps you need to pass -A ? (sbuild's default is to build only
6551 arch-specific binaries; dgit 1.4 used to override that.)
6556 my ($pbuilder) = @_;
6558 # @ARGV is allowed to contain only things that should be passed to
6559 # pbuilder under debbuildopts; just massage those
6560 my $wantsrc = massage_dbp_args \@ARGV;
6561 fail "you asked for a builder but your debbuildopts didn't ask for".
6562 " any binaries -- is this really what you meant?"
6563 unless $wantsrc & WANTSRC_BUILDER;
6564 fail "we must build a .dsc to pass to the builder but your debbuiltopts".
6565 " forbids the building of a source package; cannot continue"
6566 unless $wantsrc & WANTSRC_SOURCE;
6567 # We do not want to include the verb "build" in @pbuilder because
6568 # the user can customise @pbuilder and they shouldn't be required
6569 # to include "build" in their customised value. However, if the
6570 # user passes any additional args to pbuilder using the dgit
6571 # option --pbuilder:foo, such args need to come after the "build"
6572 # verb. opts_opt_multi_cmd does all of that.
6573 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6574 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6579 pbuilder(\@pbuilder);
6582 sub cmd_cowbuilder {
6583 pbuilder(\@cowbuilder);
6586 sub cmd_quilt_fixup {
6587 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6590 build_maybe_quilt_fixup();
6593 sub cmd_print_unapplied_treeish {
6594 badusage "incorrect arguments to dgit print-unapplied-treeish" if @ARGV;
6595 my $headref = git_rev_parse('HEAD');
6596 my $clogp = commit_getclogp $headref;
6597 $package = getfield $clogp, 'Source';
6598 $version = getfield $clogp, 'Version';
6599 $isuite = getfield $clogp, 'Distribution';
6600 $csuite = $isuite; # we want this to be offline!
6604 changedir $playground;
6605 my $uv = upstreamversion $version;
6606 quilt_make_fake_dsc($uv);
6607 my $u = quilt_fakedsc2unapplied($headref, $uv);
6608 print $u, "\n" or die $!;
6611 sub import_dsc_result {
6612 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6613 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6615 check_gitattrs($newhash, "source tree");
6617 progress "dgit: import-dsc: $what_msg";
6620 sub cmd_import_dsc {
6624 last unless $ARGV[0] =~ m/^-/;
6627 if (m/^--require-valid-signature$/) {
6630 badusage "unknown dgit import-dsc sub-option \`$_'";
6634 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6635 my ($dscfn, $dstbranch) = @ARGV;
6637 badusage "dry run makes no sense with import-dsc" unless act_local();
6639 my $force = $dstbranch =~ s/^\+// ? +1 :
6640 $dstbranch =~ s/^\.\.// ? -1 :
6642 my $info = $force ? " $&" : '';
6643 $info = "$dscfn$info";
6645 my $specbranch = $dstbranch;
6646 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6647 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6649 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6650 my $chead = cmdoutput_errok @symcmd;
6651 defined $chead or $?==256 or failedcmd @symcmd;
6653 fail "$dstbranch is checked out - will not update it"
6654 if defined $chead and $chead eq $dstbranch;
6656 my $oldhash = git_get_ref $dstbranch;
6658 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6659 $dscdata = do { local $/ = undef; <D>; };
6660 D->error and fail "read $dscfn: $!";
6663 # we don't normally need this so import it here
6664 use Dpkg::Source::Package;
6665 my $dp = new Dpkg::Source::Package filename => $dscfn,
6666 require_valid_signature => $needsig;
6668 local $SIG{__WARN__} = sub {
6670 return unless $needsig;
6671 fail "import-dsc signature check failed";
6673 if (!$dp->is_signed()) {
6674 warn "$us: warning: importing unsigned .dsc\n";
6676 my $r = $dp->check_signature();
6677 die "->check_signature => $r" if $needsig && $r;
6683 $package = getfield $dsc, 'Source';
6685 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6686 unless forceing [qw(import-dsc-with-dgit-field)];
6687 parse_dsc_field_def_dsc_distro();
6689 $isuite = 'DGIT-IMPORT-DSC';
6690 $idistro //= $dsc_distro;
6694 if (defined $dsc_hash) {
6695 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6696 resolve_dsc_field_commit undef, undef;
6698 if (defined $dsc_hash) {
6699 my @cmd = (qw(sh -ec),
6700 "echo $dsc_hash | git cat-file --batch-check");
6701 my $objgot = cmdoutput @cmd;
6702 if ($objgot =~ m#^\w+ missing\b#) {
6704 .dsc contains Dgit field referring to object $dsc_hash
6705 Your git tree does not have that object. Try `git fetch' from a
6706 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6709 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6711 progress "Not fast forward, forced update.";
6713 fail "Not fast forward to $dsc_hash";
6716 import_dsc_result $dstbranch, $dsc_hash,
6717 "dgit import-dsc (Dgit): $info",
6718 "updated git ref $dstbranch";
6723 Branch $dstbranch already exists
6724 Specify ..$specbranch for a pseudo-merge, binding in existing history
6725 Specify +$specbranch to overwrite, discarding existing history
6727 if $oldhash && !$force;
6729 my @dfi = dsc_files_info();
6730 foreach my $fi (@dfi) {
6731 my $f = $fi->{Filename};
6732 my $here = "$buildproductsdir/$f";
6735 fail "lstat $here works but stat gives $! !";
6737 fail "stat $here: $!" unless $! == ENOENT;
6739 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6741 } elsif ($dscfn =~ m#^/#) {
6744 fail "cannot import $dscfn which seems to be inside working tree!";
6746 $there =~ s#/+[^/]+$## or
6747 fail "import $dscfn requires ../$f, but it does not exist";
6749 my $test = $there =~ m{^/} ? $there : "../$there";
6750 stat $test or fail "import $dscfn requires $test, but: $!";
6751 symlink $there, $here or fail "symlink $there to $here: $!";
6752 progress "made symlink $here -> $there";
6753 # print STDERR Dumper($fi);
6755 my @mergeinputs = generate_commits_from_dsc();
6756 die unless @mergeinputs == 1;
6758 my $newhash = $mergeinputs[0]{Commit};
6762 progress "Import, forced update - synthetic orphan git history.";
6763 } elsif ($force < 0) {
6764 progress "Import, merging.";
6765 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6766 my $version = getfield $dsc, 'Version';
6767 my $clogp = commit_getclogp $newhash;
6768 my $authline = clogp_authline $clogp;
6769 $newhash = make_commit_text <<END;
6776 Merge $package ($version) import into $dstbranch
6779 die; # caught earlier
6783 import_dsc_result $dstbranch, $newhash,
6784 "dgit import-dsc: $info",
6785 "results are in in git ref $dstbranch";
6788 sub pre_archive_api_query () {
6789 not_necessarily_a_tree();
6791 sub cmd_archive_api_query {
6792 badusage "need only 1 subpath argument" unless @ARGV==1;
6793 my ($subpath) = @ARGV;
6794 local $isuite = 'DGIT-API-QUERY-CMD';
6795 my @cmd = archive_api_query_cmd($subpath);
6798 exec @cmd or fail "exec curl: $!\n";
6801 sub repos_server_url () {
6802 $package = '_dgit-repos-server';
6803 local $access_forpush = 1;
6804 local $isuite = 'DGIT-REPOS-SERVER';
6805 my $url = access_giturl();
6808 sub pre_clone_dgit_repos_server () {
6809 not_necessarily_a_tree();
6811 sub cmd_clone_dgit_repos_server {
6812 badusage "need destination argument" unless @ARGV==1;
6813 my ($destdir) = @ARGV;
6814 my $url = repos_server_url();
6815 my @cmd = (@git, qw(clone), $url, $destdir);
6817 exec @cmd or fail "exec git clone: $!\n";
6820 sub pre_print_dgit_repos_server_source_url () {
6821 not_necessarily_a_tree();
6823 sub cmd_print_dgit_repos_server_source_url {
6824 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6826 my $url = repos_server_url();
6827 print $url, "\n" or die $!;
6830 sub pre_print_dpkg_source_ignores {
6831 not_necessarily_a_tree();
6833 sub cmd_print_dpkg_source_ignores {
6834 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6836 print "@dpkg_source_ignores\n" or die $!;
6839 sub cmd_setup_mergechangelogs {
6840 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6841 local $isuite = 'DGIT-SETUP-TREE';
6842 setup_mergechangelogs(1);
6845 sub cmd_setup_useremail {
6846 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6847 local $isuite = 'DGIT-SETUP-TREE';
6851 sub cmd_setup_gitattributes {
6852 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6853 local $isuite = 'DGIT-SETUP-TREE';
6857 sub cmd_setup_new_tree {
6858 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6859 local $isuite = 'DGIT-SETUP-TREE';
6863 #---------- argument parsing and main program ----------
6866 print "dgit version $our_version\n" or die $!;
6870 our (%valopts_long, %valopts_short);
6871 our (%funcopts_long);
6873 our (@modeopt_cfgs);
6875 sub defvalopt ($$$$) {
6876 my ($long,$short,$val_re,$how) = @_;
6877 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6878 $valopts_long{$long} = $oi;
6879 $valopts_short{$short} = $oi;
6880 # $how subref should:
6881 # do whatever assignemnt or thing it likes with $_[0]
6882 # if the option should not be passed on to remote, @rvalopts=()
6883 # or $how can be a scalar ref, meaning simply assign the value
6886 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6887 defvalopt '--distro', '-d', '.+', \$idistro;
6888 defvalopt '', '-k', '.+', \$keyid;
6889 defvalopt '--existing-package','', '.*', \$existing_package;
6890 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6891 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6892 defvalopt '--package', '-p', $package_re, \$package;
6893 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6895 defvalopt '', '-C', '.+', sub {
6896 ($changesfile) = (@_);
6897 if ($changesfile =~ s#^(.*)/##) {
6898 $buildproductsdir = $1;
6902 defvalopt '--initiator-tempdir','','.*', sub {
6903 ($initiator_tempdir) = (@_);
6904 $initiator_tempdir =~ m#^/# or
6905 badusage "--initiator-tempdir must be used specify an".
6906 " absolute, not relative, directory."
6909 sub defoptmodes ($@) {
6910 my ($varref, $cfgkey, $default, %optmap) = @_;
6912 while (my ($opt,$val) = each %optmap) {
6913 $funcopts_long{$opt} = sub { $$varref = $val; };
6914 $permit{$val} = $val;
6916 push @modeopt_cfgs, {
6919 Default => $default,
6924 defoptmodes \$dodep14tag, qw( dep14tag want
6927 --always-dep14tag always );
6932 if (defined $ENV{'DGIT_SSH'}) {
6933 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6934 } elsif (defined $ENV{'GIT_SSH'}) {
6935 @ssh = ($ENV{'GIT_SSH'});
6943 if (!defined $val) {
6944 badusage "$what needs a value" unless @ARGV;
6946 push @rvalopts, $val;
6948 badusage "bad value \`$val' for $what" unless
6949 $val =~ m/^$oi->{Re}$(?!\n)/s;
6950 my $how = $oi->{How};
6951 if (ref($how) eq 'SCALAR') {
6956 push @ropts, @rvalopts;
6960 last unless $ARGV[0] =~ m/^-/;
6964 if (m/^--dry-run$/) {
6967 } elsif (m/^--damp-run$/) {
6970 } elsif (m/^--no-sign$/) {
6973 } elsif (m/^--help$/) {
6975 } elsif (m/^--version$/) {
6977 } elsif (m/^--new$/) {
6980 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6981 ($om = $opts_opt_map{$1}) &&
6985 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6986 !$opts_opt_cmdonly{$1} &&
6987 ($om = $opts_opt_map{$1})) {
6990 } elsif (m/^--(gbp|dpm)$/s) {
6991 push @ropts, "--quilt=$1";
6993 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6996 } elsif (m/^--no-quilt-fixup$/s) {
6998 $quilt_mode = 'nocheck';
6999 } elsif (m/^--no-rm-on-error$/s) {
7002 } elsif (m/^--no-chase-dsc-distro$/s) {
7004 $chase_dsc_distro = 0;
7005 } elsif (m/^--overwrite$/s) {
7007 $overwrite_version = '';
7008 } elsif (m/^--overwrite=(.+)$/s) {
7010 $overwrite_version = $1;
7011 } elsif (m/^--delayed=(\d+)$/s) {
7014 } elsif (my ($k,$v) =
7015 m/^--save-(dgit-view)=(.+)$/s ||
7016 m/^--(dgit-view)-save=(.+)$/s
7019 $v =~ s#^(?!refs/)#refs/heads/#;
7020 $internal_object_save{$k} = $v;
7021 } elsif (m/^--(no-)?rm-old-changes$/s) {
7024 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7026 push @deliberatelies, $&;
7027 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7031 } elsif (m/^--force-/) {
7033 "$us: warning: ignoring unknown force option $_\n";
7035 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7036 # undocumented, for testing
7038 $tagformat_want = [ $1, 'command line', 1 ];
7039 # 1 menas overrides distro configuration
7040 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7041 # undocumented, for testing
7043 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7044 # ^ it's supposed to be an array ref
7045 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7046 $val = $2 ? $' : undef; #';
7047 $valopt->($oi->{Long});
7048 } elsif ($funcopts_long{$_}) {
7050 $funcopts_long{$_}();
7052 badusage "unknown long option \`$_'";
7059 } elsif (s/^-L/-/) {
7062 } elsif (s/^-h/-/) {
7064 } elsif (s/^-D/-/) {
7068 } elsif (s/^-N/-/) {
7073 push @changesopts, $_;
7075 } elsif (s/^-wn$//s) {
7077 $cleanmode = 'none';
7078 } elsif (s/^-wg$//s) {
7081 } elsif (s/^-wgf$//s) {
7083 $cleanmode = 'git-ff';
7084 } elsif (s/^-wd$//s) {
7086 $cleanmode = 'dpkg-source';
7087 } elsif (s/^-wdd$//s) {
7089 $cleanmode = 'dpkg-source-d';
7090 } elsif (s/^-wc$//s) {
7092 $cleanmode = 'check';
7093 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7094 push @git, '-c', $&;
7095 $gitcfgs{cmdline}{$1} = [ $2 ];
7096 } elsif (s/^-c([^=]+)$//s) {
7097 push @git, '-c', $&;
7098 $gitcfgs{cmdline}{$1} = [ 'true' ];
7099 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7101 $val = undef unless length $val;
7102 $valopt->($oi->{Short});
7105 badusage "unknown short option \`$_'";
7112 sub check_env_sanity () {
7113 my $blocked = new POSIX::SigSet;
7114 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7117 foreach my $name (qw(PIPE CHLD)) {
7118 my $signame = "SIG$name";
7119 my $signum = eval "POSIX::$signame" // die;
7120 die "$signame is set to something other than SIG_DFL\n"
7121 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7122 $blocked->ismember($signum) and
7123 die "$signame is blocked\n";
7129 On entry to dgit, $@
7130 This is a bug produced by something in in your execution environment.
7136 sub parseopts_late_defaults () {
7137 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7138 if defined $idistro;
7139 $isuite //= cfg('dgit.default.default-suite');
7141 foreach my $k (keys %opts_opt_map) {
7142 my $om = $opts_opt_map{$k};
7144 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7146 badcfg "cannot set command for $k"
7147 unless length $om->[0];
7151 foreach my $c (access_cfg_cfgs("opts-$k")) {
7153 map { $_ ? @$_ : () }
7154 map { $gitcfgs{$_}{$c} }
7155 reverse @gitcfgsources;
7156 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7157 "\n" if $debuglevel >= 4;
7159 badcfg "cannot configure options for $k"
7160 if $opts_opt_cmdonly{$k};
7161 my $insertpos = $opts_cfg_insertpos{$k};
7162 @$om = ( @$om[0..$insertpos-1],
7164 @$om[$insertpos..$#$om] );
7168 if (!defined $rmchanges) {
7169 local $access_forpush;
7170 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7173 if (!defined $quilt_mode) {
7174 local $access_forpush;
7175 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7176 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7178 $quilt_mode =~ m/^($quilt_modes_re)$/
7179 or badcfg "unknown quilt-mode \`$quilt_mode'";
7183 foreach my $moc (@modeopt_cfgs) {
7184 local $access_forpush;
7185 my $vr = $moc->{Var};
7186 next if defined $$vr;
7187 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7188 my $v = $moc->{Vals}{$$vr};
7189 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7193 fail "dgit: --include-dirty is not supported in split view quilt mode"
7194 if $split_brain && $includedirty;
7196 if (!defined $cleanmode) {
7197 local $access_forpush;
7198 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7199 $cleanmode //= 'dpkg-source';
7201 badcfg "unknown clean-mode \`$cleanmode'" unless
7202 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7205 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7206 $buildproductsdir //= '..';
7207 $bpd_glob = $buildproductsdir;
7208 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7211 if ($ENV{$fakeeditorenv}) {
7213 quilt_fixup_editor();
7219 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7220 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7221 if $dryrun_level == 1;
7223 print STDERR $helpmsg or die $!;
7226 $cmd = $subcommand = shift @ARGV;
7229 my $pre_fn = ${*::}{"pre_$cmd"};
7230 $pre_fn->() if $pre_fn;
7232 record_maindir if $invoked_in_git_tree;
7235 my $fn = ${*::}{"cmd_$cmd"};
7236 $fn or badusage "unknown operation $cmd";