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);
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 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
327 printdebug "branch_is_gdr $head...\n";
328 my $get_patches = sub {
329 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
332 my $tip_patches = $get_patches->($head);
335 my $cdata = git_cat_file $walk, 'commit';
336 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
337 if ($msg =~ m{^\[git-debrebase\ (
338 anchor | changelog | make-patches |
339 merged-breakwater | pseudomerge
341 # no need to analyse this - it's sufficient
342 # (gdr classifications: Anchor, MergedBreakwaters)
343 # (made by gdr: Pseudomerge, Changelog)
344 printdebug "branch_is_gdr $walk gdr $1 YES\n";
347 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
349 my $walk_tree = get_tree_of_commit $walk;
350 foreach my $p (@parents) {
351 my $p_tree = get_tree_of_commit $p;
352 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
353 # (gdr classification: Pseudomerge; not made by gdr)
354 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
360 # some other non-gdr merge
361 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
362 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
366 # (gdr classification: ?)
367 printdebug "branch_is_gdr $walk ?-octopus NO\n";
370 if ($get_patches->($walk) ne $tip_patches) {
371 # Our parent added, removed, or edited patches, and wasn't
372 # a gdr make-patches commit. gdr make-patches probably
373 # won't do that well, then.
374 # (gdr classification of parent: AddPatches or ?)
375 printdebug "branch_is_gdr $walk ?-patches NO\n";
378 if ($tip_patches eq '' and
379 !defined git_cat_file "$walk:debian") {
380 # (gdr classification of parent: BreakwaterStart
381 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
384 # (gdr classification: Upstream Packaging Mixed Changelog)
385 printdebug "branch_is_gdr $walk plain\n"
391 #---------- remote protocol support, common ----------
393 # remote push initiator/responder protocol:
394 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
395 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
396 # < dgit-remote-push-ready <actual-proto-vsn>
403 # > supplementary-message NBYTES # $protovsn >= 3
408 # > file parsed-changelog
409 # [indicates that output of dpkg-parsechangelog follows]
410 # > data-block NBYTES
411 # > [NBYTES bytes of data (no newline)]
412 # [maybe some more blocks]
421 # > param head DGIT-VIEW-HEAD
422 # > param csuite SUITE
423 # > param tagformat old|new
424 # > param maint-view MAINT-VIEW-HEAD
426 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
427 # > file buildinfo # for buildinfos to sign
429 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
430 # # goes into tag, for replay prevention
433 # [indicates that signed tag is wanted]
434 # < data-block NBYTES
435 # < [NBYTES bytes of data (no newline)]
436 # [maybe some more blocks]
440 # > want signed-dsc-changes
441 # < data-block NBYTES [transfer of signed dsc]
443 # < data-block NBYTES [transfer of signed changes]
445 # < data-block NBYTES [transfer of each signed buildinfo
446 # [etc] same number and order as "file buildinfo"]
454 sub i_child_report () {
455 # Sees if our child has died, and reap it if so. Returns a string
456 # describing how it died if it failed, or undef otherwise.
457 return undef unless $i_child_pid;
458 my $got = waitpid $i_child_pid, WNOHANG;
459 return undef if $got <= 0;
460 die unless $got == $i_child_pid;
461 $i_child_pid = undef;
462 return undef unless $?;
463 return "build host child ".waitstatusmsg();
468 fail "connection lost: $!" if $fh->error;
469 fail "protocol violation; $m not expected";
472 sub badproto_badread ($$) {
474 fail "connection lost: $!" if $!;
475 my $report = i_child_report();
476 fail $report if defined $report;
477 badproto $fh, "eof (reading $wh)";
480 sub protocol_expect (&$) {
481 my ($match, $fh) = @_;
484 defined && chomp or badproto_badread $fh, "protocol message";
492 badproto $fh, "\`$_'";
495 sub protocol_send_file ($$) {
496 my ($fh, $ourfn) = @_;
497 open PF, "<", $ourfn or die "$ourfn: $!";
500 my $got = read PF, $d, 65536;
501 die "$ourfn: $!" unless defined $got;
503 print $fh "data-block ".length($d)."\n" or die $!;
504 print $fh $d or die $!;
506 PF->error and die "$ourfn $!";
507 print $fh "data-end\n" or die $!;
511 sub protocol_read_bytes ($$) {
512 my ($fh, $nbytes) = @_;
513 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
515 my $got = read $fh, $d, $nbytes;
516 $got==$nbytes or badproto_badread $fh, "data block";
520 sub protocol_receive_file ($$) {
521 my ($fh, $ourfn) = @_;
522 printdebug "() $ourfn\n";
523 open PF, ">", $ourfn or die "$ourfn: $!";
525 my ($y,$l) = protocol_expect {
526 m/^data-block (.*)$/ ? (1,$1) :
527 m/^data-end$/ ? (0,) :
531 my $d = protocol_read_bytes $fh, $l;
532 print PF $d or die $!;
537 #---------- remote protocol support, responder ----------
539 sub responder_send_command ($) {
541 return unless $we_are_responder;
542 # called even without $we_are_responder
543 printdebug ">> $command\n";
544 print PO $command, "\n" or die $!;
547 sub responder_send_file ($$) {
548 my ($keyword, $ourfn) = @_;
549 return unless $we_are_responder;
550 printdebug "]] $keyword $ourfn\n";
551 responder_send_command "file $keyword";
552 protocol_send_file \*PO, $ourfn;
555 sub responder_receive_files ($@) {
556 my ($keyword, @ourfns) = @_;
557 die unless $we_are_responder;
558 printdebug "[[ $keyword @ourfns\n";
559 responder_send_command "want $keyword";
560 foreach my $fn (@ourfns) {
561 protocol_receive_file \*PI, $fn;
564 protocol_expect { m/^files-end$/ } \*PI;
567 #---------- remote protocol support, initiator ----------
569 sub initiator_expect (&) {
571 protocol_expect { &$match } \*RO;
574 #---------- end remote code ----------
577 if ($we_are_responder) {
579 responder_send_command "progress ".length($m) or die $!;
580 print PO $m or die $!;
590 $ua = LWP::UserAgent->new();
594 progress "downloading $what...";
595 my $r = $ua->get(@_) or die $!;
596 return undef if $r->code == 404;
597 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
598 return $r->decoded_content(charset => 'none');
601 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
603 sub act_local () { return $dryrun_level <= 1; }
604 sub act_scary () { return !$dryrun_level; }
607 if (!$dryrun_level) {
608 progress "$us ok: @_";
610 progress "would be ok: @_ (but dry run only)";
615 printcmd(\*STDERR,$debugprefix."#",@_);
618 sub runcmd_ordryrun {
626 sub runcmd_ordryrun_local {
634 our $helpmsg = <<END;
636 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
637 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
638 dgit [dgit-opts] build [dpkg-buildpackage-opts]
639 dgit [dgit-opts] sbuild [sbuild-opts]
640 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
641 dgit [dgit-opts] push [dgit-opts] [suite]
642 dgit [dgit-opts] push-source [dgit-opts] [suite]
643 dgit [dgit-opts] rpush build-host:build-dir ...
644 important dgit options:
645 -k<keyid> sign tag and package with <keyid> instead of default
646 --dry-run -n do not change anything, but go through the motions
647 --damp-run -L like --dry-run but make local changes, without signing
648 --new -N allow introducing a new package
649 --debug -D increase debug level
650 -c<name>=<value> set git config option (used directly by dgit too)
653 our $later_warning_msg = <<END;
654 Perhaps the upload is stuck in incoming. Using the version from git.
658 print STDERR "$us: @_\n", $helpmsg or die $!;
663 @ARGV or badusage "too few arguments";
664 return scalar shift @ARGV;
668 not_necessarily_a_tree();
671 print $helpmsg or die $!;
675 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
677 our %defcfg = ('dgit.default.distro' => 'debian',
678 'dgit.default.default-suite' => 'unstable',
679 'dgit.default.old-dsc-distro' => 'debian',
680 'dgit-suite.*-security.distro' => 'debian-security',
681 'dgit.default.username' => '',
682 'dgit.default.archive-query-default-component' => 'main',
683 'dgit.default.ssh' => 'ssh',
684 'dgit.default.archive-query' => 'madison:',
685 'dgit.default.sshpsql-dbname' => 'service=projectb',
686 'dgit.default.aptget-components' => 'main',
687 'dgit.default.dgit-tag-format' => 'new,old,maint',
688 'dgit.default.source-only-uploads' => 'ok',
689 'dgit.dsc-url-proto-ok.http' => 'true',
690 'dgit.dsc-url-proto-ok.https' => 'true',
691 'dgit.dsc-url-proto-ok.git' => 'true',
692 'dgit.vcs-git.suites', => 'sid', # ;-separated
693 'dgit.default.dsc-url-proto-ok' => 'false',
694 # old means "repo server accepts pushes with old dgit tags"
695 # new means "repo server accepts pushes with new dgit tags"
696 # maint means "repo server accepts split brain pushes"
697 # hist means "repo server may have old pushes without new tag"
698 # ("hist" is implied by "old")
699 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
700 'dgit-distro.debian.git-check' => 'url',
701 'dgit-distro.debian.git-check-suffix' => '/info/refs',
702 'dgit-distro.debian.new-private-pushers' => 't',
703 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
704 'dgit-distro.debian/push.git-url' => '',
705 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
706 'dgit-distro.debian/push.git-user-force' => 'dgit',
707 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
708 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
709 'dgit-distro.debian/push.git-create' => 'true',
710 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
711 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
712 # 'dgit-distro.debian.archive-query-tls-key',
713 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
714 # ^ this does not work because curl is broken nowadays
715 # Fixing #790093 properly will involve providing providing the key
716 # in some pacagke and maybe updating these paths.
718 # 'dgit-distro.debian.archive-query-tls-curl-args',
719 # '--ca-path=/etc/ssl/ca-debian',
720 # ^ this is a workaround but works (only) on DSA-administered machines
721 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
722 'dgit-distro.debian.git-url-suffix' => '',
723 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
724 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
725 'dgit-distro.debian-security.archive-query' => 'aptget:',
726 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
727 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
728 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
729 'dgit-distro.debian-security.nominal-distro' => 'debian',
730 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
731 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
732 'dgit-distro.ubuntu.git-check' => 'false',
733 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
734 'dgit-distro.test-dummy.ssh' => "$td/ssh",
735 'dgit-distro.test-dummy.username' => "alice",
736 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
737 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
738 'dgit-distro.test-dummy.git-url' => "$td/git",
739 'dgit-distro.test-dummy.git-host' => "git",
740 'dgit-distro.test-dummy.git-path' => "$td/git",
741 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
742 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
743 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
744 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
748 our @gitcfgsources = qw(cmdline local global system);
749 our $invoked_in_git_tree = 1;
751 sub git_slurp_config () {
752 # This algoritm is a bit subtle, but this is needed so that for
753 # options which we want to be single-valued, we allow the
754 # different config sources to override properly. See #835858.
755 foreach my $src (@gitcfgsources) {
756 next if $src eq 'cmdline';
757 # we do this ourselves since git doesn't handle it
759 $gitcfgs{$src} = git_slurp_config_src $src;
763 sub git_get_config ($) {
765 foreach my $src (@gitcfgsources) {
766 my $l = $gitcfgs{$src}{$c};
767 confess "internal error ($l $c)" if $l && !ref $l;
768 printdebug"C $c ".(defined $l ?
769 join " ", map { messagequote "'$_'" } @$l :
773 @$l==1 or badcfg "multiple values for $c".
774 " (in $src git config)" if @$l > 1;
782 return undef if $c =~ /RETURN-UNDEF/;
783 printdebug "C? $c\n" if $debuglevel >= 5;
784 my $v = git_get_config($c);
785 return $v if defined $v;
786 my $dv = $defcfg{$c};
788 printdebug "CD $c $dv\n" if $debuglevel >= 4;
792 badcfg "need value for one of: @_\n".
793 "$us: distro or suite appears not to be (properly) supported";
796 sub not_necessarily_a_tree () {
797 # needs to be called from pre_*
798 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
799 $invoked_in_git_tree = 0;
802 sub access_basedistro__noalias () {
803 if (defined $idistro) {
806 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
807 return $def if defined $def;
808 foreach my $src (@gitcfgsources, 'internal') {
809 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
811 foreach my $k (keys %$kl) {
812 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
814 next unless match_glob $dpat, $isuite;
818 return cfg("dgit.default.distro");
822 sub access_basedistro () {
823 my $noalias = access_basedistro__noalias();
824 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
825 return $canon // $noalias;
828 sub access_nomdistro () {
829 my $base = access_basedistro();
830 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
831 $r =~ m/^$distro_re$/ or badcfg
832 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
836 sub access_quirk () {
837 # returns (quirk name, distro to use instead or undef, quirk-specific info)
838 my $basedistro = access_basedistro();
839 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
841 if (defined $backports_quirk) {
842 my $re = $backports_quirk;
843 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
845 $re =~ s/\%/([-0-9a-z_]+)/
846 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
847 if ($isuite =~ m/^$re$/) {
848 return ('backports',"$basedistro-backports",$1);
851 return ('none',undef);
856 sub parse_cfg_bool ($$$) {
857 my ($what,$def,$v) = @_;
860 $v =~ m/^[ty1]/ ? 1 :
861 $v =~ m/^[fn0]/ ? 0 :
862 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
865 sub access_forpush_config () {
866 my $d = access_basedistro();
870 parse_cfg_bool('new-private-pushers', 0,
871 cfg("dgit-distro.$d.new-private-pushers",
874 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
877 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
878 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
879 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
880 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
883 sub access_forpush () {
884 $access_forpush //= access_forpush_config();
885 return $access_forpush;
889 confess 'internal error '.Dumper($access_forpush)," ?" if
890 defined $access_forpush and !$access_forpush;
891 badcfg "pushing but distro is configured readonly"
892 if access_forpush_config() eq '0';
894 $supplementary_message = <<'END' unless $we_are_responder;
895 Push failed, before we got started.
896 You can retry the push, after fixing the problem, if you like.
898 parseopts_late_defaults();
902 parseopts_late_defaults();
905 sub supplementary_message ($) {
907 if (!$we_are_responder) {
908 $supplementary_message = $msg;
910 } elsif ($protovsn >= 3) {
911 responder_send_command "supplementary-message ".length($msg)
913 print PO $msg or die $!;
917 sub access_distros () {
918 # Returns list of distros to try, in order
921 # 0. `instead of' distro name(s) we have been pointed to
922 # 1. the access_quirk distro, if any
923 # 2a. the user's specified distro, or failing that } basedistro
924 # 2b. the distro calculated from the suite }
925 my @l = access_basedistro();
927 my (undef,$quirkdistro) = access_quirk();
928 unshift @l, $quirkdistro;
929 unshift @l, $instead_distro;
930 @l = grep { defined } @l;
932 push @l, access_nomdistro();
934 if (access_forpush()) {
935 @l = map { ("$_/push", $_) } @l;
940 sub access_cfg_cfgs (@) {
943 # The nesting of these loops determines the search order. We put
944 # the key loop on the outside so that we search all the distros
945 # for each key, before going on to the next key. That means that
946 # if access_cfg is called with a more specific, and then a less
947 # specific, key, an earlier distro can override the less specific
948 # without necessarily overriding any more specific keys. (If the
949 # distro wants to override the more specific keys it can simply do
950 # so; whereas if we did the loop the other way around, it would be
951 # impossible to for an earlier distro to override a less specific
952 # key but not the more specific ones without restating the unknown
953 # values of the more specific keys.
956 # We have to deal with RETURN-UNDEF specially, so that we don't
957 # terminate the search prematurely.
959 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
962 foreach my $d (access_distros()) {
963 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
965 push @cfgs, map { "dgit.default.$_" } @realkeys;
972 my (@cfgs) = access_cfg_cfgs(@keys);
973 my $value = cfg(@cfgs);
977 sub access_cfg_bool ($$) {
978 my ($def, @keys) = @_;
979 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
982 sub string_to_ssh ($) {
984 if ($spec =~ m/\s/) {
985 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
991 sub access_cfg_ssh () {
992 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
993 if (!defined $gitssh) {
996 return string_to_ssh $gitssh;
1000 sub access_runeinfo ($) {
1002 return ": dgit ".access_basedistro()." $info ;";
1005 sub access_someuserhost ($) {
1007 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1008 defined($user) && length($user) or
1009 $user = access_cfg("$some-user",'username');
1010 my $host = access_cfg("$some-host");
1011 return length($user) ? "$user\@$host" : $host;
1014 sub access_gituserhost () {
1015 return access_someuserhost('git');
1018 sub access_giturl (;$) {
1019 my ($optional) = @_;
1020 my $url = access_cfg('git-url','RETURN-UNDEF');
1023 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1024 return undef unless defined $proto;
1027 access_gituserhost().
1028 access_cfg('git-path');
1030 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1033 return "$url/$package$suffix";
1036 sub commit_getclogp ($) {
1037 # Returns the parsed changelog hashref for a particular commit
1039 our %commit_getclogp_memo;
1040 my $memo = $commit_getclogp_memo{$objid};
1041 return $memo if $memo;
1043 my $mclog = dgit_privdir()."clog";
1044 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1045 "$objid:debian/changelog";
1046 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1049 sub parse_dscdata () {
1050 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1051 printdebug Dumper($dscdata) if $debuglevel>1;
1052 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1053 printdebug Dumper($dsc) if $debuglevel>1;
1058 sub archive_query ($;@) {
1059 my ($method) = shift @_;
1060 fail "this operation does not support multiple comma-separated suites"
1062 my $query = access_cfg('archive-query','RETURN-UNDEF');
1063 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1066 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1069 sub archive_query_prepend_mirror {
1070 my $m = access_cfg('mirror');
1071 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1074 sub pool_dsc_subpath ($$) {
1075 my ($vsn,$component) = @_; # $package is implict arg
1076 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1077 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1080 sub cfg_apply_map ($$$) {
1081 my ($varref, $what, $mapspec) = @_;
1082 return unless $mapspec;
1084 printdebug "config $what EVAL{ $mapspec; }\n";
1086 eval "package Dgit::Config; $mapspec;";
1091 #---------- `ftpmasterapi' archive query method (nascent) ----------
1093 sub archive_api_query_cmd ($) {
1095 my @cmd = (@curl, qw(-sS));
1096 my $url = access_cfg('archive-query-url');
1097 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1099 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1100 foreach my $key (split /\:/, $keys) {
1101 $key =~ s/\%HOST\%/$host/g;
1103 fail "for $url: stat $key: $!" unless $!==ENOENT;
1106 fail "config requested specific TLS key but do not know".
1107 " how to get curl to use exactly that EE key ($key)";
1108 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1109 # # Sadly the above line does not work because of changes
1110 # # to gnutls. The real fix for #790093 may involve
1111 # # new curl options.
1114 # Fixing #790093 properly will involve providing a value
1115 # for this on clients.
1116 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1117 push @cmd, split / /, $kargs if defined $kargs;
1119 push @cmd, $url.$subpath;
1123 sub api_query ($$;$) {
1125 my ($data, $subpath, $ok404) = @_;
1126 badcfg "ftpmasterapi archive query method takes no data part"
1128 my @cmd = archive_api_query_cmd($subpath);
1129 my $url = $cmd[$#cmd];
1130 push @cmd, qw(-w %{http_code});
1131 my $json = cmdoutput @cmd;
1132 unless ($json =~ s/\d+\d+\d$//) {
1133 failedcmd_report_cmd undef, @cmd;
1134 fail "curl failed to print 3-digit HTTP code";
1137 return undef if $code eq '404' && $ok404;
1138 fail "fetch of $url gave HTTP code $code"
1139 unless $url =~ m#^file://# or $code =~ m/^2/;
1140 return decode_json($json);
1143 sub canonicalise_suite_ftpmasterapi {
1144 my ($proto,$data) = @_;
1145 my $suites = api_query($data, 'suites');
1147 foreach my $entry (@$suites) {
1149 my $v = $entry->{$_};
1150 defined $v && $v eq $isuite;
1151 } qw(codename name);
1152 push @matched, $entry;
1154 fail "unknown suite $isuite, maybe -d would help" unless @matched;
1157 @matched==1 or die "multiple matches for suite $isuite\n";
1158 $cn = "$matched[0]{codename}";
1159 defined $cn or die "suite $isuite info has no codename\n";
1160 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1162 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1167 sub archive_query_ftpmasterapi {
1168 my ($proto,$data) = @_;
1169 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1171 my $digester = Digest::SHA->new(256);
1172 foreach my $entry (@$info) {
1174 my $vsn = "$entry->{version}";
1175 my ($ok,$msg) = version_check $vsn;
1176 die "bad version: $msg\n" unless $ok;
1177 my $component = "$entry->{component}";
1178 $component =~ m/^$component_re$/ or die "bad component";
1179 my $filename = "$entry->{filename}";
1180 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1181 or die "bad filename";
1182 my $sha256sum = "$entry->{sha256sum}";
1183 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1184 push @rows, [ $vsn, "/pool/$component/$filename",
1185 $digester, $sha256sum ];
1187 die "bad ftpmaster api response: $@\n".Dumper($entry)
1190 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1191 return archive_query_prepend_mirror @rows;
1194 sub file_in_archive_ftpmasterapi {
1195 my ($proto,$data,$filename) = @_;
1196 my $pat = $filename;
1199 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1200 my $info = api_query($data, "file_in_archive/$pat", 1);
1203 sub package_not_wholly_new_ftpmasterapi {
1204 my ($proto,$data,$pkg) = @_;
1205 my $info = api_query($data,"madison?package=${pkg}&f=json");
1209 #---------- `aptget' archive query method ----------
1212 our $aptget_releasefile;
1213 our $aptget_configpath;
1215 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1216 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1218 sub aptget_cache_clean {
1219 runcmd_ordryrun_local qw(sh -ec),
1220 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1224 sub aptget_lock_acquire () {
1225 my $lockfile = "$aptget_base/lock";
1226 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1227 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1230 sub aptget_prep ($) {
1232 return if defined $aptget_base;
1234 badcfg "aptget archive query method takes no data part"
1237 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1240 ensuredir "$cache/dgit";
1242 access_cfg('aptget-cachekey','RETURN-UNDEF')
1243 // access_nomdistro();
1245 $aptget_base = "$cache/dgit/aptget";
1246 ensuredir $aptget_base;
1248 my $quoted_base = $aptget_base;
1249 die "$quoted_base contains bad chars, cannot continue"
1250 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1252 ensuredir $aptget_base;
1254 aptget_lock_acquire();
1256 aptget_cache_clean();
1258 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1259 my $sourceslist = "source.list#$cachekey";
1261 my $aptsuites = $isuite;
1262 cfg_apply_map(\$aptsuites, 'suite map',
1263 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1265 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1266 printf SRCS "deb-src %s %s %s\n",
1267 access_cfg('mirror'),
1269 access_cfg('aptget-components')
1272 ensuredir "$aptget_base/cache";
1273 ensuredir "$aptget_base/lists";
1275 open CONF, ">", $aptget_configpath or die $!;
1277 Debug::NoLocking "true";
1278 APT::Get::List-Cleanup "false";
1279 #clear APT::Update::Post-Invoke-Success;
1280 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1281 Dir::State::Lists "$quoted_base/lists";
1282 Dir::Etc::preferences "$quoted_base/preferences";
1283 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1284 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1287 foreach my $key (qw(
1290 Dir::Cache::Archives
1291 Dir::Etc::SourceParts
1292 Dir::Etc::preferencesparts
1294 ensuredir "$aptget_base/$key";
1295 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1298 my $oldatime = (time // die $!) - 1;
1299 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1300 next unless stat_exists $oldlist;
1301 my ($mtime) = (stat _)[9];
1302 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1305 runcmd_ordryrun_local aptget_aptget(), qw(update);
1308 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1309 next unless stat_exists $oldlist;
1310 my ($atime) = (stat _)[8];
1311 next if $atime == $oldatime;
1312 push @releasefiles, $oldlist;
1314 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1315 @releasefiles = @inreleasefiles if @inreleasefiles;
1316 if (!@releasefiles) {
1318 apt seemed to not to update dgit's cached Release files for $isuite.
1320 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1323 die "apt updated too many Release files (@releasefiles), erk"
1324 unless @releasefiles == 1;
1326 ($aptget_releasefile) = @releasefiles;
1329 sub canonicalise_suite_aptget {
1330 my ($proto,$data) = @_;
1333 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1335 foreach my $name (qw(Codename Suite)) {
1336 my $val = $release->{$name};
1338 printdebug "release file $name: $val\n";
1339 $val =~ m/^$suite_re$/o or fail
1340 "Release file ($aptget_releasefile) specifies intolerable $name";
1341 cfg_apply_map(\$val, 'suite rmap',
1342 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1349 sub archive_query_aptget {
1350 my ($proto,$data) = @_;
1353 ensuredir "$aptget_base/source";
1354 foreach my $old (<$aptget_base/source/*.dsc>) {
1355 unlink $old or die "$old: $!";
1358 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1359 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1360 # avoids apt-get source failing with ambiguous error code
1362 runcmd_ordryrun_local
1363 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1364 aptget_aptget(), qw(--download-only --only-source source), $package;
1366 my @dscs = <$aptget_base/source/*.dsc>;
1367 fail "apt-get source did not produce a .dsc" unless @dscs;
1368 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1370 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1373 my $uri = "file://". uri_escape $dscs[0];
1374 $uri =~ s{\%2f}{/}gi;
1375 return [ (getfield $pre_dsc, 'Version'), $uri ];
1378 sub file_in_archive_aptget () { return undef; }
1379 sub package_not_wholly_new_aptget () { return undef; }
1381 #---------- `dummyapicat' archive query method ----------
1383 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1384 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1386 sub dummycatapi_run_in_mirror ($@) {
1387 # runs $fn with FIA open onto rune
1388 my ($rune, $argl, $fn) = @_;
1390 my $mirror = access_cfg('mirror');
1391 $mirror =~ s#^file://#/# or die "$mirror ?";
1392 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1393 qw(x), $mirror, @$argl);
1394 debugcmd "-|", @cmd;
1395 open FIA, "-|", @cmd or die $!;
1397 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1401 sub file_in_archive_dummycatapi ($$$) {
1402 my ($proto,$data,$filename) = @_;
1404 dummycatapi_run_in_mirror '
1405 find -name "$1" -print0 |
1407 ', [$filename], sub {
1410 printdebug "| $_\n";
1411 m/^(\w+) (\S+)$/ or die "$_ ?";
1412 push @out, { sha256sum => $1, filename => $2 };
1418 sub package_not_wholly_new_dummycatapi {
1419 my ($proto,$data,$pkg) = @_;
1420 dummycatapi_run_in_mirror "
1421 find -name ${pkg}_*.dsc
1428 #---------- `madison' archive query method ----------
1430 sub archive_query_madison {
1431 return archive_query_prepend_mirror
1432 map { [ @$_[0..1] ] } madison_get_parse(@_);
1435 sub madison_get_parse {
1436 my ($proto,$data) = @_;
1437 die unless $proto eq 'madison';
1438 if (!length $data) {
1439 $data= access_cfg('madison-distro','RETURN-UNDEF');
1440 $data //= access_basedistro();
1442 $rmad{$proto,$data,$package} ||= cmdoutput
1443 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1444 my $rmad = $rmad{$proto,$data,$package};
1447 foreach my $l (split /\n/, $rmad) {
1448 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1449 \s*( [^ \t|]+ )\s* \|
1450 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1451 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1452 $1 eq $package or die "$rmad $package ?";
1459 $component = access_cfg('archive-query-default-component');
1461 $5 eq 'source' or die "$rmad ?";
1462 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1464 return sort { -version_compare($a->[0],$b->[0]); } @out;
1467 sub canonicalise_suite_madison {
1468 # madison canonicalises for us
1469 my @r = madison_get_parse(@_);
1471 "unable to canonicalise suite using package $package".
1472 " which does not appear to exist in suite $isuite;".
1473 " --existing-package may help";
1477 sub file_in_archive_madison { return undef; }
1478 sub package_not_wholly_new_madison { return undef; }
1480 #---------- `sshpsql' archive query method ----------
1483 my ($data,$runeinfo,$sql) = @_;
1484 if (!length $data) {
1485 $data= access_someuserhost('sshpsql').':'.
1486 access_cfg('sshpsql-dbname');
1488 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1489 my ($userhost,$dbname) = ($`,$'); #';
1491 my @cmd = (access_cfg_ssh, $userhost,
1492 access_runeinfo("ssh-psql $runeinfo").
1493 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1494 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1496 open P, "-|", @cmd or die $!;
1499 printdebug(">|$_|\n");
1502 $!=0; $?=0; close P or failedcmd @cmd;
1504 my $nrows = pop @rows;
1505 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1506 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1507 @rows = map { [ split /\|/, $_ ] } @rows;
1508 my $ncols = scalar @{ shift @rows };
1509 die if grep { scalar @$_ != $ncols } @rows;
1513 sub sql_injection_check {
1514 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1517 sub archive_query_sshpsql ($$) {
1518 my ($proto,$data) = @_;
1519 sql_injection_check $isuite, $package;
1520 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1521 SELECT source.version, component.name, files.filename, files.sha256sum
1523 JOIN src_associations ON source.id = src_associations.source
1524 JOIN suite ON suite.id = src_associations.suite
1525 JOIN dsc_files ON dsc_files.source = source.id
1526 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1527 JOIN component ON component.id = files_archive_map.component_id
1528 JOIN files ON files.id = dsc_files.file
1529 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1530 AND source.source='$package'
1531 AND files.filename LIKE '%.dsc';
1533 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1534 my $digester = Digest::SHA->new(256);
1536 my ($vsn,$component,$filename,$sha256sum) = @$_;
1537 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1539 return archive_query_prepend_mirror @rows;
1542 sub canonicalise_suite_sshpsql ($$) {
1543 my ($proto,$data) = @_;
1544 sql_injection_check $isuite;
1545 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1546 SELECT suite.codename
1547 FROM suite where suite_name='$isuite' or codename='$isuite';
1549 @rows = map { $_->[0] } @rows;
1550 fail "unknown suite $isuite" unless @rows;
1551 die "ambiguous $isuite: @rows ?" if @rows>1;
1555 sub file_in_archive_sshpsql ($$$) { return undef; }
1556 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1558 #---------- `dummycat' archive query method ----------
1560 sub canonicalise_suite_dummycat ($$) {
1561 my ($proto,$data) = @_;
1562 my $dpath = "$data/suite.$isuite";
1563 if (!open C, "<", $dpath) {
1564 $!==ENOENT or die "$dpath: $!";
1565 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1569 chomp or die "$dpath: $!";
1571 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1575 sub archive_query_dummycat ($$) {
1576 my ($proto,$data) = @_;
1577 canonicalise_suite();
1578 my $dpath = "$data/package.$csuite.$package";
1579 if (!open C, "<", $dpath) {
1580 $!==ENOENT or die "$dpath: $!";
1581 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1589 printdebug "dummycat query $csuite $package $dpath | $_\n";
1590 my @row = split /\s+/, $_;
1591 @row==2 or die "$dpath: $_ ?";
1594 C->error and die "$dpath: $!";
1596 return archive_query_prepend_mirror
1597 sort { -version_compare($a->[0],$b->[0]); } @rows;
1600 sub file_in_archive_dummycat () { return undef; }
1601 sub package_not_wholly_new_dummycat () { return undef; }
1603 #---------- tag format handling ----------
1605 sub access_cfg_tagformats () {
1606 split /\,/, access_cfg('dgit-tag-format');
1609 sub access_cfg_tagformats_can_splitbrain () {
1610 my %y = map { $_ => 1 } access_cfg_tagformats;
1611 foreach my $needtf (qw(new maint)) {
1612 next if $y{$needtf};
1618 sub need_tagformat ($$) {
1619 my ($fmt, $why) = @_;
1620 fail "need to use tag format $fmt ($why) but also need".
1621 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1622 " - no way to proceed"
1623 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1624 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1627 sub select_tagformat () {
1629 return if $tagformatfn && !$tagformat_want;
1630 die 'bug' if $tagformatfn && $tagformat_want;
1631 # ... $tagformat_want assigned after previous select_tagformat
1633 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1634 printdebug "select_tagformat supported @supported\n";
1636 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1637 printdebug "select_tagformat specified @$tagformat_want\n";
1639 my ($fmt,$why,$override) = @$tagformat_want;
1641 fail "target distro supports tag formats @supported".
1642 " but have to use $fmt ($why)"
1644 or grep { $_ eq $fmt } @supported;
1646 $tagformat_want = undef;
1648 $tagformatfn = ${*::}{"debiantag_$fmt"};
1650 fail "trying to use unknown tag format \`$fmt' ($why) !"
1651 unless $tagformatfn;
1654 #---------- archive query entrypoints and rest of program ----------
1656 sub canonicalise_suite () {
1657 return if defined $csuite;
1658 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1659 $csuite = archive_query('canonicalise_suite');
1660 if ($isuite ne $csuite) {
1661 progress "canonical suite name for $isuite is $csuite";
1663 progress "canonical suite name is $csuite";
1667 sub get_archive_dsc () {
1668 canonicalise_suite();
1669 my @vsns = archive_query('archive_query');
1670 foreach my $vinfo (@vsns) {
1671 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1672 $dscurl = $vsn_dscurl;
1673 $dscdata = url_get($dscurl);
1675 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1680 $digester->add($dscdata);
1681 my $got = $digester->hexdigest();
1683 fail "$dscurl has hash $got but".
1684 " archive told us to expect $digest";
1687 my $fmt = getfield $dsc, 'Format';
1688 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1689 "unsupported source format $fmt, sorry";
1691 $dsc_checked = !!$digester;
1692 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1696 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1699 sub check_for_git ();
1700 sub check_for_git () {
1702 my $how = access_cfg('git-check');
1703 if ($how eq 'ssh-cmd') {
1705 (access_cfg_ssh, access_gituserhost(),
1706 access_runeinfo("git-check $package").
1707 " set -e; cd ".access_cfg('git-path').";".
1708 " if test -d $package.git; then echo 1; else echo 0; fi");
1709 my $r= cmdoutput @cmd;
1710 if (defined $r and $r =~ m/^divert (\w+)$/) {
1712 my ($usedistro,) = access_distros();
1713 # NB that if we are pushing, $usedistro will be $distro/push
1714 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1715 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1716 progress "diverting to $divert (using config for $instead_distro)";
1717 return check_for_git();
1719 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1721 } elsif ($how eq 'url') {
1722 my $prefix = access_cfg('git-check-url','git-url');
1723 my $suffix = access_cfg('git-check-suffix','git-suffix',
1724 'RETURN-UNDEF') // '.git';
1725 my $url = "$prefix/$package$suffix";
1726 my @cmd = (@curl, qw(-sS -I), $url);
1727 my $result = cmdoutput @cmd;
1728 $result =~ s/^\S+ 200 .*\n\r?\n//;
1729 # curl -sS -I with https_proxy prints
1730 # HTTP/1.0 200 Connection established
1731 $result =~ m/^\S+ (404|200) /s or
1732 fail "unexpected results from git check query - ".
1733 Dumper($prefix, $result);
1735 if ($code eq '404') {
1737 } elsif ($code eq '200') {
1742 } elsif ($how eq 'true') {
1744 } elsif ($how eq 'false') {
1747 badcfg "unknown git-check \`$how'";
1751 sub create_remote_git_repo () {
1752 my $how = access_cfg('git-create');
1753 if ($how eq 'ssh-cmd') {
1755 (access_cfg_ssh, access_gituserhost(),
1756 access_runeinfo("git-create $package").
1757 "set -e; cd ".access_cfg('git-path').";".
1758 " cp -a _template $package.git");
1759 } elsif ($how eq 'true') {
1762 badcfg "unknown git-create \`$how'";
1766 our ($dsc_hash,$lastpush_mergeinput);
1767 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1771 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1772 $playground = fresh_playground 'dgit/unpack';
1775 sub mktree_in_ud_here () {
1776 playtree_setup $gitcfgs{local};
1779 sub git_write_tree () {
1780 my $tree = cmdoutput @git, qw(write-tree);
1781 $tree =~ m/^\w+$/ or die "$tree ?";
1785 sub git_add_write_tree () {
1786 runcmd @git, qw(add -Af .);
1787 return git_write_tree();
1790 sub remove_stray_gits ($) {
1792 my @gitscmd = qw(find -name .git -prune -print0);
1793 debugcmd "|",@gitscmd;
1794 open GITS, "-|", @gitscmd or die $!;
1799 print STDERR "$us: warning: removing from $what: ",
1800 (messagequote $_), "\n";
1804 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1807 sub mktree_in_ud_from_only_subdir ($;$) {
1808 my ($what,$raw) = @_;
1809 # changes into the subdir
1812 die "expected one subdir but found @dirs ?" unless @dirs==1;
1813 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1817 remove_stray_gits($what);
1818 mktree_in_ud_here();
1820 my ($format, $fopts) = get_source_format();
1821 if (madformat($format)) {
1826 my $tree=git_add_write_tree();
1827 return ($tree,$dir);
1830 our @files_csum_info_fields =
1831 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1832 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1833 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1835 sub dsc_files_info () {
1836 foreach my $csumi (@files_csum_info_fields) {
1837 my ($fname, $module, $method) = @$csumi;
1838 my $field = $dsc->{$fname};
1839 next unless defined $field;
1840 eval "use $module; 1;" or die $@;
1842 foreach (split /\n/, $field) {
1844 m/^(\w+) (\d+) (\S+)$/ or
1845 fail "could not parse .dsc $fname line \`$_'";
1846 my $digester = eval "$module"."->$method;" or die $@;
1851 Digester => $digester,
1856 fail "missing any supported Checksums-* or Files field in ".
1857 $dsc->get_option('name');
1861 map { $_->{Filename} } dsc_files_info();
1864 sub files_compare_inputs (@) {
1869 my $showinputs = sub {
1870 return join "; ", map { $_->get_option('name') } @$inputs;
1873 foreach my $in (@$inputs) {
1875 my $in_name = $in->get_option('name');
1877 printdebug "files_compare_inputs $in_name\n";
1879 foreach my $csumi (@files_csum_info_fields) {
1880 my ($fname) = @$csumi;
1881 printdebug "files_compare_inputs $in_name $fname\n";
1883 my $field = $in->{$fname};
1884 next unless defined $field;
1887 foreach (split /\n/, $field) {
1890 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1891 fail "could not parse $in_name $fname line \`$_'";
1893 printdebug "files_compare_inputs $in_name $fname $f\n";
1897 my $re = \ $record{$f}{$fname};
1899 $fchecked{$f}{$in_name} = 1;
1901 fail "hash or size of $f varies in $fname fields".
1902 " (between: ".$showinputs->().")";
1907 @files = sort @files;
1908 $expected_files //= \@files;
1909 "@$expected_files" eq "@files" or
1910 fail "file list in $in_name varies between hash fields!";
1913 fail "$in_name has no files list field(s)";
1915 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1918 grep { keys %$_ == @$inputs-1 } values %fchecked
1919 or fail "no file appears in all file lists".
1920 " (looked in: ".$showinputs->().")";
1923 sub is_orig_file_in_dsc ($$) {
1924 my ($f, $dsc_files_info) = @_;
1925 return 0 if @$dsc_files_info <= 1;
1926 # One file means no origs, and the filename doesn't have a "what
1927 # part of dsc" component. (Consider versions ending `.orig'.)
1928 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1932 # This function determines whether a .changes file is source-only from
1933 # the point of view of dak. Thus, it permits *_source.buildinfo
1936 # It does not, however, permit any other buildinfo files. After a
1937 # source-only upload, the buildds will try to upload files like
1938 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1939 # named like this in their (otherwise) source-only upload, the uploads
1940 # of the buildd can be rejected by dak. Fixing the resultant
1941 # situation can require manual intervention. So we block such
1942 # .buildinfo files when the user tells us to perform a source-only
1943 # upload (such as when using the push-source subcommand with the -C
1944 # option, which calls this function).
1946 # Note, though, that when dgit is told to prepare a source-only
1947 # upload, such as when subcommands like build-source and push-source
1948 # without -C are used, dgit has a more restrictive notion of
1949 # source-only .changes than dak: such uploads will never include
1950 # *_source.buildinfo files. This is because there is no use for such
1951 # files when using a tool like dgit to produce the source package, as
1952 # dgit ensures the source is identical to git HEAD.
1953 sub test_source_only_changes ($) {
1955 foreach my $l (split /\n/, getfield $changes, 'Files') {
1956 $l =~ m/\S+$/ or next;
1957 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1958 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1959 print "purportedly source-only changes polluted by $&\n";
1966 sub changes_update_origs_from_dsc ($$$$) {
1967 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1969 printdebug "checking origs needed ($upstreamvsn)...\n";
1970 $_ = getfield $changes, 'Files';
1971 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1972 fail "cannot find section/priority from .changes Files field";
1973 my $placementinfo = $1;
1975 printdebug "checking origs needed placement '$placementinfo'...\n";
1976 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1977 $l =~ m/\S+$/ or next;
1979 printdebug "origs $file | $l\n";
1980 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1981 printdebug "origs $file is_orig\n";
1982 my $have = archive_query('file_in_archive', $file);
1983 if (!defined $have) {
1985 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1991 printdebug "origs $file \$#\$have=$#$have\n";
1992 foreach my $h (@$have) {
1995 foreach my $csumi (@files_csum_info_fields) {
1996 my ($fname, $module, $method, $archivefield) = @$csumi;
1997 next unless defined $h->{$archivefield};
1998 $_ = $dsc->{$fname};
1999 next unless defined;
2000 m/^(\w+) .* \Q$file\E$/m or
2001 fail ".dsc $fname missing entry for $file";
2002 if ($h->{$archivefield} eq $1) {
2006 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
2009 die "$file ".Dumper($h)." ?!" if $same && @differ;
2012 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
2015 printdebug "origs $file f.same=$found_same".
2016 " #f._differ=$#found_differ\n";
2017 if (@found_differ && !$found_same) {
2019 "archive contains $file with different checksum",
2022 # Now we edit the changes file to add or remove it
2023 foreach my $csumi (@files_csum_info_fields) {
2024 my ($fname, $module, $method, $archivefield) = @$csumi;
2025 next unless defined $changes->{$fname};
2027 # in archive, delete from .changes if it's there
2028 $changed{$file} = "removed" if
2029 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2030 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2031 # not in archive, but it's here in the .changes
2033 my $dsc_data = getfield $dsc, $fname;
2034 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2036 $extra =~ s/ \d+ /$&$placementinfo /
2037 or die "$fname $extra >$dsc_data< ?"
2038 if $fname eq 'Files';
2039 $changes->{$fname} .= "\n". $extra;
2040 $changed{$file} = "added";
2045 foreach my $file (keys %changed) {
2047 "edited .changes for archive .orig contents: %s %s",
2048 $changed{$file}, $file;
2050 my $chtmp = "$changesfile.tmp";
2051 $changes->save($chtmp);
2053 rename $chtmp,$changesfile or die "$changesfile $!";
2055 progress "[new .changes left in $changesfile]";
2058 progress "$changesfile already has appropriate .orig(s) (if any)";
2062 sub make_commit ($) {
2064 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2067 sub clogp_authline ($) {
2069 my $author = getfield $clogp, 'Maintainer';
2070 if ($author =~ m/^[^"\@]+\,/) {
2071 # single entry Maintainer field with unquoted comma
2072 $author = ($& =~ y/,//rd).$'; # strip the comma
2074 # git wants a single author; any remaining commas in $author
2075 # are by now preceded by @ (or "). It seems safer to punt on
2076 # "..." for now rather than attempting to dequote or something.
2077 $author =~ s#,.*##ms unless $author =~ m/"/;
2078 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2079 my $authline = "$author $date";
2080 $authline =~ m/$git_authline_re/o or
2081 fail "unexpected commit author line format \`$authline'".
2082 " (was generated from changelog Maintainer field)";
2083 return ($1,$2,$3) if wantarray;
2087 sub vendor_patches_distro ($$) {
2088 my ($checkdistro, $what) = @_;
2089 return unless defined $checkdistro;
2091 my $series = "debian/patches/\L$checkdistro\E.series";
2092 printdebug "checking for vendor-specific $series ($what)\n";
2094 if (!open SERIES, "<", $series) {
2095 die "$series $!" unless $!==ENOENT;
2104 Unfortunately, this source package uses a feature of dpkg-source where
2105 the same source package unpacks to different source code on different
2106 distros. dgit cannot safely operate on such packages on affected
2107 distros, because the meaning of source packages is not stable.
2109 Please ask the distro/maintainer to remove the distro-specific series
2110 files and use a different technique (if necessary, uploading actually
2111 different packages, if different distros are supposed to have
2115 fail "Found active distro-specific series file for".
2116 " $checkdistro ($what): $series, cannot continue";
2118 die "$series $!" if SERIES->error;
2122 sub check_for_vendor_patches () {
2123 # This dpkg-source feature doesn't seem to be documented anywhere!
2124 # But it can be found in the changelog (reformatted):
2126 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2127 # Author: Raphael Hertzog <hertzog@debian.org>
2128 # Date: Sun Oct 3 09:36:48 2010 +0200
2130 # dpkg-source: correctly create .pc/.quilt_series with alternate
2133 # If you have debian/patches/ubuntu.series and you were
2134 # unpacking the source package on ubuntu, quilt was still
2135 # directed to debian/patches/series instead of
2136 # debian/patches/ubuntu.series.
2138 # debian/changelog | 3 +++
2139 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2140 # 2 files changed, 6 insertions(+), 1 deletion(-)
2143 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2144 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2145 "Dpkg::Vendor \`current vendor'");
2146 vendor_patches_distro(access_basedistro(),
2147 "(base) distro being accessed");
2148 vendor_patches_distro(access_nomdistro(),
2149 "(nominal) distro being accessed");
2152 sub generate_commits_from_dsc () {
2153 # See big comment in fetch_from_archive, below.
2154 # See also README.dsc-import.
2156 changedir $playground;
2158 my @dfi = dsc_files_info();
2159 foreach my $fi (@dfi) {
2160 my $f = $fi->{Filename};
2161 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2162 my $upper_f = (bpd_abs()."/$f");
2164 printdebug "considering reusing $f: ";
2166 if (link_ltarget "$upper_f,fetch", $f) {
2167 printdebug "linked (using ...,fetch).\n";
2168 } elsif ((printdebug "($!) "),
2170 fail "accessing $buildproductsdir/$f,fetch: $!";
2171 } elsif (link_ltarget $upper_f, $f) {
2172 printdebug "linked.\n";
2173 } elsif ((printdebug "($!) "),
2175 fail "accessing $buildproductsdir/$f: $!";
2177 printdebug "absent.\n";
2181 complete_file_from_dsc('.', $fi, \$refetched)
2184 printdebug "considering saving $f: ";
2186 if (link $f, $upper_f) {
2187 printdebug "linked.\n";
2188 } elsif ((printdebug "($!) "),
2190 fail "saving $buildproductsdir/$f: $!";
2191 } elsif (!$refetched) {
2192 printdebug "no need.\n";
2193 } elsif (link $f, "$upper_f,fetch") {
2194 printdebug "linked (using ...,fetch).\n";
2195 } elsif ((printdebug "($!) "),
2197 fail "saving $buildproductsdir/$f,fetch: $!";
2199 printdebug "cannot.\n";
2203 # We unpack and record the orig tarballs first, so that we only
2204 # need disk space for one private copy of the unpacked source.
2205 # But we can't make them into commits until we have the metadata
2206 # from the debian/changelog, so we record the tree objects now and
2207 # make them into commits later.
2209 my $upstreamv = upstreamversion $dsc->{version};
2210 my $orig_f_base = srcfn $upstreamv, '';
2212 foreach my $fi (@dfi) {
2213 # We actually import, and record as a commit, every tarball
2214 # (unless there is only one file, in which case there seems
2217 my $f = $fi->{Filename};
2218 printdebug "import considering $f ";
2219 (printdebug "only one dfi\n"), next if @dfi == 1;
2220 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2221 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2225 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2227 printdebug "Y ", (join ' ', map { $_//"(none)" }
2228 $compr_ext, $orig_f_part
2231 my $input = new IO::File $f, '<' or die "$f $!";
2235 if (defined $compr_ext) {
2237 Dpkg::Compression::compression_guess_from_filename $f;
2238 fail "Dpkg::Compression cannot handle file $f in source package"
2239 if defined $compr_ext && !defined $cname;
2241 new Dpkg::Compression::Process compression => $cname;
2242 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2243 my $compr_fh = new IO::Handle;
2244 my $compr_pid = open $compr_fh, "-|" // die $!;
2246 open STDIN, "<&", $input or die $!;
2248 die "dgit (child): exec $compr_cmd[0]: $!\n";
2253 rmtree "_unpack-tar";
2254 mkdir "_unpack-tar" or die $!;
2255 my @tarcmd = qw(tar -x -f -
2256 --no-same-owner --no-same-permissions
2257 --no-acls --no-xattrs --no-selinux);
2258 my $tar_pid = fork // die $!;
2260 chdir "_unpack-tar" or die $!;
2261 open STDIN, "<&", $input or die $!;
2263 die "dgit (child): exec $tarcmd[0]: $!";
2265 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2266 !$? or failedcmd @tarcmd;
2269 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2271 # finally, we have the results in "tarball", but maybe
2272 # with the wrong permissions
2274 runcmd qw(chmod -R +rwX _unpack-tar);
2275 changedir "_unpack-tar";
2276 remove_stray_gits($f);
2277 mktree_in_ud_here();
2279 my ($tree) = git_add_write_tree();
2280 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2281 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2283 printdebug "one subtree $1\n";
2285 printdebug "multiple subtrees\n";
2288 rmtree "_unpack-tar";
2290 my $ent = [ $f, $tree ];
2292 Orig => !!$orig_f_part,
2293 Sort => (!$orig_f_part ? 2 :
2294 $orig_f_part =~ m/-/g ? 1 :
2302 # put any without "_" first (spec is not clear whether files
2303 # are always in the usual order). Tarballs without "_" are
2304 # the main orig or the debian tarball.
2305 $a->{Sort} <=> $b->{Sort} or
2309 my $any_orig = grep { $_->{Orig} } @tartrees;
2311 my $dscfn = "$package.dsc";
2313 my $treeimporthow = 'package';
2315 open D, ">", $dscfn or die "$dscfn: $!";
2316 print D $dscdata or die "$dscfn: $!";
2317 close D or die "$dscfn: $!";
2318 my @cmd = qw(dpkg-source);
2319 push @cmd, '--no-check' if $dsc_checked;
2320 if (madformat $dsc->{format}) {
2321 push @cmd, '--skip-patches';
2322 $treeimporthow = 'unpatched';
2324 push @cmd, qw(-x --), $dscfn;
2327 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2328 if (madformat $dsc->{format}) {
2329 check_for_vendor_patches();
2333 if (madformat $dsc->{format}) {
2334 my @pcmd = qw(dpkg-source --before-build .);
2335 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2337 $dappliedtree = git_add_write_tree();
2340 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2344 printdebug "import clog search...\n";
2345 parsechangelog_loop \@clogcmd, "package changelog", sub {
2346 my ($thisstanza, $desc) = @_;
2347 no warnings qw(exiting);
2349 $clogp //= $thisstanza;
2351 printdebug "import clog $thisstanza->{version} $desc...\n";
2353 last if !$any_orig; # we don't need $r1clogp
2355 # We look for the first (most recent) changelog entry whose
2356 # version number is lower than the upstream version of this
2357 # package. Then the last (least recent) previous changelog
2358 # entry is treated as the one which introduced this upstream
2359 # version and used for the synthetic commits for the upstream
2362 # One might think that a more sophisticated algorithm would be
2363 # necessary. But: we do not want to scan the whole changelog
2364 # file. Stopping when we see an earlier version, which
2365 # necessarily then is an earlier upstream version, is the only
2366 # realistic way to do that. Then, either the earliest
2367 # changelog entry we have seen so far is indeed the earliest
2368 # upload of this upstream version; or there are only changelog
2369 # entries relating to later upstream versions (which is not
2370 # possible unless the changelog and .dsc disagree about the
2371 # version). Then it remains to choose between the physically
2372 # last entry in the file, and the one with the lowest version
2373 # number. If these are not the same, we guess that the
2374 # versions were created in a non-monotonic order rather than
2375 # that the changelog entries have been misordered.
2377 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2379 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2380 $r1clogp = $thisstanza;
2382 printdebug "import clog $r1clogp->{version} becomes r1\n";
2385 $clogp or fail "package changelog has no entries!";
2387 my $authline = clogp_authline $clogp;
2388 my $changes = getfield $clogp, 'Changes';
2389 $changes =~ s/^\n//; # Changes: \n
2390 my $cversion = getfield $clogp, 'Version';
2393 $r1clogp //= $clogp; # maybe there's only one entry;
2394 my $r1authline = clogp_authline $r1clogp;
2395 # Strictly, r1authline might now be wrong if it's going to be
2396 # unused because !$any_orig. Whatever.
2398 printdebug "import tartrees authline $authline\n";
2399 printdebug "import tartrees r1authline $r1authline\n";
2401 foreach my $tt (@tartrees) {
2402 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2404 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2407 committer $r1authline
2411 [dgit import orig $tt->{F}]
2419 [dgit import tarball $package $cversion $tt->{F}]
2424 printdebug "import main commit\n";
2426 open C, ">../commit.tmp" or die $!;
2427 print C <<END or die $!;
2430 print C <<END or die $! foreach @tartrees;
2433 print C <<END or die $!;
2439 [dgit import $treeimporthow $package $cversion]
2443 my $rawimport_hash = make_commit qw(../commit.tmp);
2445 if (madformat $dsc->{format}) {
2446 printdebug "import apply patches...\n";
2448 # regularise the state of the working tree so that
2449 # the checkout of $rawimport_hash works nicely.
2450 my $dappliedcommit = make_commit_text(<<END);
2457 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2459 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2461 # We need the answers to be reproducible
2462 my @authline = clogp_authline($clogp);
2463 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2464 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2465 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2466 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2467 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2468 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2470 my $path = $ENV{PATH} or die;
2472 # we use ../../gbp-pq-output, which (given that we are in
2473 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2476 foreach my $use_absurd (qw(0 1)) {
2477 runcmd @git, qw(checkout -q unpa);
2478 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2479 local $ENV{PATH} = $path;
2482 progress "warning: $@";
2483 $path = "$absurdity:$path";
2484 progress "$us: trying slow absurd-git-apply...";
2485 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2490 die "forbid absurd git-apply\n" if $use_absurd
2491 && forceing [qw(import-gitapply-no-absurd)];
2492 die "only absurd git-apply!\n" if !$use_absurd
2493 && forceing [qw(import-gitapply-absurd)];
2495 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2496 local $ENV{PATH} = $path if $use_absurd;
2498 my @showcmd = (gbp_pq, qw(import));
2499 my @realcmd = shell_cmd
2500 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2501 debugcmd "+",@realcmd;
2502 if (system @realcmd) {
2503 die +(shellquote @showcmd).
2505 failedcmd_waitstatus()."\n";
2508 my $gapplied = git_rev_parse('HEAD');
2509 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2510 $gappliedtree eq $dappliedtree or
2512 gbp-pq import and dpkg-source disagree!
2513 gbp-pq import gave commit $gapplied
2514 gbp-pq import gave tree $gappliedtree
2515 dpkg-source --before-build gave tree $dappliedtree
2517 $rawimport_hash = $gapplied;
2522 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2527 progress "synthesised git commit from .dsc $cversion";
2529 my $rawimport_mergeinput = {
2530 Commit => $rawimport_hash,
2531 Info => "Import of source package",
2533 my @output = ($rawimport_mergeinput);
2535 if ($lastpush_mergeinput) {
2536 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2537 my $oversion = getfield $oldclogp, 'Version';
2539 version_compare($oversion, $cversion);
2541 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2542 { Message => <<END, ReverseParents => 1 });
2543 Record $package ($cversion) in archive suite $csuite
2545 } elsif ($vcmp > 0) {
2546 print STDERR <<END or die $!;
2548 Version actually in archive: $cversion (older)
2549 Last version pushed with dgit: $oversion (newer or same)
2552 @output = $lastpush_mergeinput;
2554 # Same version. Use what's in the server git branch,
2555 # discarding our own import. (This could happen if the
2556 # server automatically imports all packages into git.)
2557 @output = $lastpush_mergeinput;
2565 sub complete_file_from_dsc ($$;$) {
2566 our ($dstdir, $fi, $refetched) = @_;
2567 # Ensures that we have, in $dstdir, the file $fi, with the correct
2568 # contents. (Downloading it from alongside $dscurl if necessary.)
2569 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2570 # and will set $$refetched=1 if it did so (or tried to).
2572 my $f = $fi->{Filename};
2573 my $tf = "$dstdir/$f";
2577 my $checkhash = sub {
2578 open F, "<", "$tf" or die "$tf: $!";
2579 $fi->{Digester}->reset();
2580 $fi->{Digester}->addfile(*F);
2581 F->error and die $!;
2582 $got = $fi->{Digester}->hexdigest();
2583 return $got eq $fi->{Hash};
2586 if (stat_exists $tf) {
2587 if ($checkhash->()) {
2588 progress "using existing $f";
2592 fail "file $f has hash $got but .dsc".
2593 " demands hash $fi->{Hash} ".
2594 "(perhaps you should delete this file?)";
2596 progress "need to fetch correct version of $f";
2597 unlink $tf or die "$tf $!";
2600 printdebug "$tf does not exist, need to fetch\n";
2604 $furl =~ s{/[^/]+$}{};
2606 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2607 die "$f ?" if $f =~ m#/#;
2608 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2609 return 0 if !act_local();
2612 fail "file $f has hash $got but .dsc".
2613 " demands hash $fi->{Hash} ".
2614 "(got wrong file from archive!)";
2619 sub ensure_we_have_orig () {
2620 my @dfi = dsc_files_info();
2621 foreach my $fi (@dfi) {
2622 my $f = $fi->{Filename};
2623 next unless is_orig_file_in_dsc($f, \@dfi);
2624 complete_file_from_dsc($buildproductsdir, $fi)
2629 #---------- git fetch ----------
2631 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2632 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2634 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2635 # locally fetched refs because they have unhelpful names and clutter
2636 # up gitk etc. So we track whether we have "used up" head ref (ie,
2637 # whether we have made another local ref which refers to this object).
2639 # (If we deleted them unconditionally, then we might end up
2640 # re-fetching the same git objects each time dgit fetch was run.)
2642 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2643 # in git_fetch_us to fetch the refs in question, and possibly a call
2644 # to lrfetchref_used.
2646 our (%lrfetchrefs_f, %lrfetchrefs_d);
2647 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2649 sub lrfetchref_used ($) {
2650 my ($fullrefname) = @_;
2651 my $objid = $lrfetchrefs_f{$fullrefname};
2652 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2655 sub git_lrfetch_sane {
2656 my ($url, $supplementary, @specs) = @_;
2657 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2658 # at least as regards @specs. Also leave the results in
2659 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2660 # able to clean these up.
2662 # With $supplementary==1, @specs must not contain wildcards
2663 # and we add to our previous fetches (non-atomically).
2665 # This is rather miserable:
2666 # When git fetch --prune is passed a fetchspec ending with a *,
2667 # it does a plausible thing. If there is no * then:
2668 # - it matches subpaths too, even if the supplied refspec
2669 # starts refs, and behaves completely madly if the source
2670 # has refs/refs/something. (See, for example, Debian #NNNN.)
2671 # - if there is no matching remote ref, it bombs out the whole
2673 # We want to fetch a fixed ref, and we don't know in advance
2674 # if it exists, so this is not suitable.
2676 # Our workaround is to use git ls-remote. git ls-remote has its
2677 # own qairks. Notably, it has the absurd multi-tail-matching
2678 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2679 # refs/refs/foo etc.
2681 # Also, we want an idempotent snapshot, but we have to make two
2682 # calls to the remote: one to git ls-remote and to git fetch. The
2683 # solution is use git ls-remote to obtain a target state, and
2684 # git fetch to try to generate it. If we don't manage to generate
2685 # the target state, we try again.
2687 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2689 my $specre = join '|', map {
2692 my $wildcard = $x =~ s/\\\*$/.*/;
2693 die if $wildcard && $supplementary;
2696 printdebug "git_lrfetch_sane specre=$specre\n";
2697 my $wanted_rref = sub {
2699 return m/^(?:$specre)$/;
2702 my $fetch_iteration = 0;
2705 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2706 if (++$fetch_iteration > 10) {
2707 fail "too many iterations trying to get sane fetch!";
2710 my @look = map { "refs/$_" } @specs;
2711 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2715 open GITLS, "-|", @lcmd or die $!;
2717 printdebug "=> ", $_;
2718 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2719 my ($objid,$rrefname) = ($1,$2);
2720 if (!$wanted_rref->($rrefname)) {
2722 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2726 $wantr{$rrefname} = $objid;
2729 close GITLS or failedcmd @lcmd;
2731 # OK, now %want is exactly what we want for refs in @specs
2733 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2734 "+refs/$_:".lrfetchrefs."/$_";
2737 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2739 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2740 runcmd_ordryrun_local @fcmd if @fspecs;
2742 if (!$supplementary) {
2743 %lrfetchrefs_f = ();
2747 git_for_each_ref(lrfetchrefs, sub {
2748 my ($objid,$objtype,$lrefname,$reftail) = @_;
2749 $lrfetchrefs_f{$lrefname} = $objid;
2750 $objgot{$objid} = 1;
2753 if ($supplementary) {
2757 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2758 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2759 if (!exists $wantr{$rrefname}) {
2760 if ($wanted_rref->($rrefname)) {
2762 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2766 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2769 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2770 delete $lrfetchrefs_f{$lrefname};
2774 foreach my $rrefname (sort keys %wantr) {
2775 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2776 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2777 my $want = $wantr{$rrefname};
2778 next if $got eq $want;
2779 if (!defined $objgot{$want}) {
2780 fail <<END unless act_local();
2781 --dry-run specified but we actually wanted the results of git fetch,
2782 so this is not going to work. Try running dgit fetch first,
2783 or using --damp-run instead of --dry-run.
2786 warning: git ls-remote suggests we want $lrefname
2787 warning: and it should refer to $want
2788 warning: but git fetch didn't fetch that object to any relevant ref.
2789 warning: This may be due to a race with someone updating the server.
2790 warning: Will try again...
2792 next FETCH_ITERATION;
2795 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2797 runcmd_ordryrun_local @git, qw(update-ref -m),
2798 "dgit fetch git fetch fixup", $lrefname, $want;
2799 $lrfetchrefs_f{$lrefname} = $want;
2804 if (defined $csuite) {
2805 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2806 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2807 my ($objid,$objtype,$lrefname,$reftail) = @_;
2808 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2809 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2813 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2814 Dumper(\%lrfetchrefs_f);
2817 sub git_fetch_us () {
2818 # Want to fetch only what we are going to use, unless
2819 # deliberately-not-ff, in which case we must fetch everything.
2821 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2823 (quiltmode_splitbrain
2824 ? (map { $_->('*',access_nomdistro) }
2825 \&debiantag_new, \&debiantag_maintview)
2826 : debiantags('*',access_nomdistro));
2827 push @specs, server_branch($csuite);
2828 push @specs, $rewritemap;
2829 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2831 my $url = access_giturl();
2832 git_lrfetch_sane $url, 0, @specs;
2835 my @tagpats = debiantags('*',access_nomdistro);
2837 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2838 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2839 printdebug "currently $fullrefname=$objid\n";
2840 $here{$fullrefname} = $objid;
2842 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2843 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2844 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2845 printdebug "offered $lref=$objid\n";
2846 if (!defined $here{$lref}) {
2847 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2848 runcmd_ordryrun_local @upd;
2849 lrfetchref_used $fullrefname;
2850 } elsif ($here{$lref} eq $objid) {
2851 lrfetchref_used $fullrefname;
2854 "Not updating $lref from $here{$lref} to $objid.\n";
2859 #---------- dsc and archive handling ----------
2861 sub mergeinfo_getclogp ($) {
2862 # Ensures thit $mi->{Clogp} exists and returns it
2864 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2867 sub mergeinfo_version ($) {
2868 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2871 sub fetch_from_archive_record_1 ($) {
2873 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2874 cmdoutput @git, qw(log -n2), $hash;
2875 # ... gives git a chance to complain if our commit is malformed
2878 sub fetch_from_archive_record_2 ($) {
2880 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2884 dryrun_report @upd_cmd;
2888 sub parse_dsc_field_def_dsc_distro () {
2889 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2890 dgit.default.distro);
2893 sub parse_dsc_field ($$) {
2894 my ($dsc, $what) = @_;
2896 foreach my $field (@ourdscfield) {
2897 $f = $dsc->{$field};
2902 progress "$what: NO git hash";
2903 parse_dsc_field_def_dsc_distro();
2904 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2905 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2906 progress "$what: specified git info ($dsc_distro)";
2907 $dsc_hint_tag = [ $dsc_hint_tag ];
2908 } elsif ($f =~ m/^\w+\s*$/) {
2910 parse_dsc_field_def_dsc_distro();
2911 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2913 progress "$what: specified git hash";
2915 fail "$what: invalid Dgit info";
2919 sub resolve_dsc_field_commit ($$) {
2920 my ($already_distro, $already_mapref) = @_;
2922 return unless defined $dsc_hash;
2925 defined $already_mapref &&
2926 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2927 ? $already_mapref : undef;
2931 my ($what, @fetch) = @_;
2933 local $idistro = $dsc_distro;
2934 my $lrf = lrfetchrefs;
2936 if (!$chase_dsc_distro) {
2938 "not chasing .dsc distro $dsc_distro: not fetching $what";
2943 ".dsc names distro $dsc_distro: fetching $what";
2945 my $url = access_giturl();
2946 if (!defined $url) {
2947 defined $dsc_hint_url or fail <<END;
2948 .dsc Dgit metadata is in context of distro $dsc_distro
2949 for which we have no configured url and .dsc provides no hint
2952 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2953 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2954 parse_cfg_bool "dsc-url-proto-ok", 'false',
2955 cfg("dgit.dsc-url-proto-ok.$proto",
2956 "dgit.default.dsc-url-proto-ok")
2958 .dsc Dgit metadata is in context of distro $dsc_distro
2959 for which we have no configured url;
2960 .dsc provides hinted url with protocol $proto which is unsafe.
2961 (can be overridden by config - consult documentation)
2963 $url = $dsc_hint_url;
2966 git_lrfetch_sane $url, 1, @fetch;
2971 my $rewrite_enable = do {
2972 local $idistro = $dsc_distro;
2973 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2976 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2977 if (!defined $mapref) {
2978 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2979 $mapref = $lrf.'/'.$rewritemap;
2981 my $rewritemapdata = git_cat_file $mapref.':map';
2982 if (defined $rewritemapdata
2983 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2985 "server's git history rewrite map contains a relevant entry!";
2988 if (defined $dsc_hash) {
2989 progress "using rewritten git hash in place of .dsc value";
2991 progress "server data says .dsc hash is to be disregarded";
2996 if (!defined git_cat_file $dsc_hash) {
2997 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2998 my $lrf = $do_fetch->("additional commits", @tags) &&
2999 defined git_cat_file $dsc_hash
3001 .dsc Dgit metadata requires commit $dsc_hash
3002 but we could not obtain that object anywhere.
3004 foreach my $t (@tags) {
3005 my $fullrefname = $lrf.'/'.$t;
3006 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3007 next unless $lrfetchrefs_f{$fullrefname};
3008 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3009 lrfetchref_used $fullrefname;
3014 sub fetch_from_archive () {
3015 ensure_setup_existing_tree();
3017 # Ensures that lrref() is what is actually in the archive, one way
3018 # or another, according to us - ie this client's
3019 # appropritaely-updated archive view. Also returns the commit id.
3020 # If there is nothing in the archive, leaves lrref alone and
3021 # returns undef. git_fetch_us must have already been called.
3025 parse_dsc_field($dsc, 'last upload to archive');
3026 resolve_dsc_field_commit access_basedistro,
3027 lrfetchrefs."/".$rewritemap
3029 progress "no version available from the archive";
3032 # If the archive's .dsc has a Dgit field, there are three
3033 # relevant git commitids we need to choose between and/or merge
3035 # 1. $dsc_hash: the Dgit field from the archive
3036 # 2. $lastpush_hash: the suite branch on the dgit git server
3037 # 3. $lastfetch_hash: our local tracking brach for the suite
3039 # These may all be distinct and need not be in any fast forward
3042 # If the dsc was pushed to this suite, then the server suite
3043 # branch will have been updated; but it might have been pushed to
3044 # a different suite and copied by the archive. Conversely a more
3045 # recent version may have been pushed with dgit but not appeared
3046 # in the archive (yet).
3048 # $lastfetch_hash may be awkward because archive imports
3049 # (particularly, imports of Dgit-less .dscs) are performed only as
3050 # needed on individual clients, so different clients may perform a
3051 # different subset of them - and these imports are only made
3052 # public during push. So $lastfetch_hash may represent a set of
3053 # imports different to a subsequent upload by a different dgit
3056 # Our approach is as follows:
3058 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3059 # descendant of $dsc_hash, then it was pushed by a dgit user who
3060 # had based their work on $dsc_hash, so we should prefer it.
3061 # Otherwise, $dsc_hash was installed into this suite in the
3062 # archive other than by a dgit push, and (necessarily) after the
3063 # last dgit push into that suite (since a dgit push would have
3064 # been descended from the dgit server git branch); thus, in that
3065 # case, we prefer the archive's version (and produce a
3066 # pseudo-merge to overwrite the dgit server git branch).
3068 # (If there is no Dgit field in the archive's .dsc then
3069 # generate_commit_from_dsc uses the version numbers to decide
3070 # whether the suite branch or the archive is newer. If the suite
3071 # branch is newer it ignores the archive's .dsc; otherwise it
3072 # generates an import of the .dsc, and produces a pseudo-merge to
3073 # overwrite the suite branch with the archive contents.)
3075 # The outcome of that part of the algorithm is the `public view',
3076 # and is same for all dgit clients: it does not depend on any
3077 # unpublished history in the local tracking branch.
3079 # As between the public view and the local tracking branch: The
3080 # local tracking branch is only updated by dgit fetch, and
3081 # whenever dgit fetch runs it includes the public view in the
3082 # local tracking branch. Therefore if the public view is not
3083 # descended from the local tracking branch, the local tracking
3084 # branch must contain history which was imported from the archive
3085 # but never pushed; and, its tip is now out of date. So, we make
3086 # a pseudo-merge to overwrite the old imports and stitch the old
3089 # Finally: we do not necessarily reify the public view (as
3090 # described above). This is so that we do not end up stacking two
3091 # pseudo-merges. So what we actually do is figure out the inputs
3092 # to any public view pseudo-merge and put them in @mergeinputs.
3095 # $mergeinputs[]{Commit}
3096 # $mergeinputs[]{Info}
3097 # $mergeinputs[0] is the one whose tree we use
3098 # @mergeinputs is in the order we use in the actual commit)
3101 # $mergeinputs[]{Message} is a commit message to use
3102 # $mergeinputs[]{ReverseParents} if def specifies that parent
3103 # list should be in opposite order
3104 # Such an entry has no Commit or Info. It applies only when found
3105 # in the last entry. (This ugliness is to support making
3106 # identical imports to previous dgit versions.)
3108 my $lastpush_hash = git_get_ref(lrfetchref());
3109 printdebug "previous reference hash=$lastpush_hash\n";
3110 $lastpush_mergeinput = $lastpush_hash && {
3111 Commit => $lastpush_hash,
3112 Info => "dgit suite branch on dgit git server",
3115 my $lastfetch_hash = git_get_ref(lrref());
3116 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3117 my $lastfetch_mergeinput = $lastfetch_hash && {
3118 Commit => $lastfetch_hash,
3119 Info => "dgit client's archive history view",
3122 my $dsc_mergeinput = $dsc_hash && {
3123 Commit => $dsc_hash,
3124 Info => "Dgit field in .dsc from archive",
3128 my $del_lrfetchrefs = sub {
3131 printdebug "del_lrfetchrefs...\n";
3132 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3133 my $objid = $lrfetchrefs_d{$fullrefname};
3134 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3136 $gur ||= new IO::Handle;
3137 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3139 printf $gur "delete %s %s\n", $fullrefname, $objid;
3142 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3146 if (defined $dsc_hash) {
3147 ensure_we_have_orig();
3148 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3149 @mergeinputs = $dsc_mergeinput
3150 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3151 print STDERR <<END or die $!;
3153 Git commit in archive is behind the last version allegedly pushed/uploaded.
3154 Commit referred to by archive: $dsc_hash
3155 Last version pushed with dgit: $lastpush_hash
3158 @mergeinputs = ($lastpush_mergeinput);
3160 # Archive has .dsc which is not a descendant of the last dgit
3161 # push. This can happen if the archive moves .dscs about.
3162 # Just follow its lead.
3163 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3164 progress "archive .dsc names newer git commit";
3165 @mergeinputs = ($dsc_mergeinput);
3167 progress "archive .dsc names other git commit, fixing up";
3168 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3172 @mergeinputs = generate_commits_from_dsc();
3173 # We have just done an import. Now, our import algorithm might
3174 # have been improved. But even so we do not want to generate
3175 # a new different import of the same package. So if the
3176 # version numbers are the same, just use our existing version.
3177 # If the version numbers are different, the archive has changed
3178 # (perhaps, rewound).
3179 if ($lastfetch_mergeinput &&
3180 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3181 (mergeinfo_version $mergeinputs[0]) )) {
3182 @mergeinputs = ($lastfetch_mergeinput);
3184 } elsif ($lastpush_hash) {
3185 # only in git, not in the archive yet
3186 @mergeinputs = ($lastpush_mergeinput);
3187 print STDERR <<END or die $!;
3189 Package not found in the archive, but has allegedly been pushed using dgit.
3193 printdebug "nothing found!\n";
3194 if (defined $skew_warning_vsn) {
3195 print STDERR <<END or die $!;
3197 Warning: relevant archive skew detected.
3198 Archive allegedly contains $skew_warning_vsn
3199 But we were not able to obtain any version from the archive or git.
3203 unshift @end, $del_lrfetchrefs;
3207 if ($lastfetch_hash &&
3209 my $h = $_->{Commit};
3210 $h and is_fast_fwd($lastfetch_hash, $h);
3211 # If true, one of the existing parents of this commit
3212 # is a descendant of the $lastfetch_hash, so we'll
3213 # be ff from that automatically.
3217 push @mergeinputs, $lastfetch_mergeinput;
3220 printdebug "fetch mergeinfos:\n";
3221 foreach my $mi (@mergeinputs) {
3223 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3225 printdebug sprintf " ReverseParents=%d Message=%s",
3226 $mi->{ReverseParents}, $mi->{Message};
3230 my $compat_info= pop @mergeinputs
3231 if $mergeinputs[$#mergeinputs]{Message};
3233 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3236 if (@mergeinputs > 1) {
3238 my $tree_commit = $mergeinputs[0]{Commit};
3240 my $tree = get_tree_of_commit $tree_commit;;
3242 # We use the changelog author of the package in question the
3243 # author of this pseudo-merge. This is (roughly) correct if
3244 # this commit is simply representing aa non-dgit upload.
3245 # (Roughly because it does not record sponsorship - but we
3246 # don't have sponsorship info because that's in the .changes,
3247 # which isn't in the archivw.)
3249 # But, it might be that we are representing archive history
3250 # updates (including in-archive copies). These are not really
3251 # the responsibility of the person who created the .dsc, but
3252 # there is no-one whose name we should better use. (The
3253 # author of the .dsc-named commit is clearly worse.)
3255 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3256 my $author = clogp_authline $useclogp;
3257 my $cversion = getfield $useclogp, 'Version';
3259 my $mcf = dgit_privdir()."/mergecommit";
3260 open MC, ">", $mcf or die "$mcf $!";
3261 print MC <<END or die $!;
3265 my @parents = grep { $_->{Commit} } @mergeinputs;
3266 @parents = reverse @parents if $compat_info->{ReverseParents};
3267 print MC <<END or die $! foreach @parents;
3271 print MC <<END or die $!;
3277 if (defined $compat_info->{Message}) {
3278 print MC $compat_info->{Message} or die $!;
3280 print MC <<END or die $!;
3281 Record $package ($cversion) in archive suite $csuite
3285 my $message_add_info = sub {
3287 my $mversion = mergeinfo_version $mi;
3288 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3292 $message_add_info->($mergeinputs[0]);
3293 print MC <<END or die $!;
3294 should be treated as descended from
3296 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3300 $hash = make_commit $mcf;
3302 $hash = $mergeinputs[0]{Commit};
3304 printdebug "fetch hash=$hash\n";
3307 my ($lasth, $what) = @_;
3308 return unless $lasth;
3309 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3312 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3314 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3316 fetch_from_archive_record_1($hash);
3318 if (defined $skew_warning_vsn) {
3319 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3320 my $gotclogp = commit_getclogp($hash);
3321 my $got_vsn = getfield $gotclogp, 'Version';
3322 printdebug "SKEW CHECK GOT $got_vsn\n";
3323 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3324 print STDERR <<END or die $!;
3326 Warning: archive skew detected. Using the available version:
3327 Archive allegedly contains $skew_warning_vsn
3328 We were able to obtain only $got_vsn
3334 if ($lastfetch_hash ne $hash) {
3335 fetch_from_archive_record_2($hash);
3338 lrfetchref_used lrfetchref();
3340 check_gitattrs($hash, "fetched source tree");
3342 unshift @end, $del_lrfetchrefs;
3346 sub set_local_git_config ($$) {
3348 runcmd @git, qw(config), $k, $v;
3351 sub setup_mergechangelogs (;$) {
3353 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3355 my $driver = 'dpkg-mergechangelogs';
3356 my $cb = "merge.$driver";
3357 confess unless defined $maindir;
3358 my $attrs = "$maindir_gitcommon/info/attributes";
3359 ensuredir "$maindir_gitcommon/info";
3361 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3362 if (!open ATTRS, "<", $attrs) {
3363 $!==ENOENT or die "$attrs: $!";
3367 next if m{^debian/changelog\s};
3368 print NATTRS $_, "\n" or die $!;
3370 ATTRS->error and die $!;
3373 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3376 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3377 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3379 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3382 sub setup_useremail (;$) {
3384 return unless $always || access_cfg_bool(1, 'setup-useremail');
3387 my ($k, $envvar) = @_;
3388 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3389 return unless defined $v;
3390 set_local_git_config "user.$k", $v;
3393 $setup->('email', 'DEBEMAIL');
3394 $setup->('name', 'DEBFULLNAME');
3397 sub ensure_setup_existing_tree () {
3398 my $k = "remote.$remotename.skipdefaultupdate";
3399 my $c = git_get_config $k;
3400 return if defined $c;
3401 set_local_git_config $k, 'true';
3404 sub open_main_gitattrs () {
3405 confess 'internal error no maindir' unless defined $maindir;
3406 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3408 or die "open $maindir_gitcommon/info/attributes: $!";
3412 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3414 sub is_gitattrs_setup () {
3417 # 1: gitattributes set up and should be left alone
3419 # 0: there is a dgit-defuse-attrs but it needs fixing
3420 # undef: there is none
3421 my $gai = open_main_gitattrs();
3422 return 0 unless $gai;
3424 next unless m{$gitattrs_ourmacro_re};
3425 return 1 if m{\s-working-tree-encoding\s};
3426 printdebug "is_gitattrs_setup: found old macro\n";
3429 $gai->error and die $!;
3430 printdebug "is_gitattrs_setup: found nothing\n";
3434 sub setup_gitattrs (;$) {
3436 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3438 my $already = is_gitattrs_setup();
3441 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3442 not doing further gitattributes setup
3446 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3447 my $af = "$maindir_gitcommon/info/attributes";
3448 ensuredir "$maindir_gitcommon/info";
3450 open GAO, "> $af.new" or die $!;
3451 print GAO <<END or die $! unless defined $already;
3454 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3456 my $gai = open_main_gitattrs();
3459 if (m{$gitattrs_ourmacro_re}) {
3460 die unless defined $already;
3464 print GAO $_, "\n" or die $!;
3466 $gai->error and die $!;
3468 close GAO or die $!;
3469 rename "$af.new", "$af" or die "install $af: $!";
3472 sub setup_new_tree () {
3473 setup_mergechangelogs();
3478 sub check_gitattrs ($$) {
3479 my ($treeish, $what) = @_;
3481 return if is_gitattrs_setup;
3484 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3486 my $gafl = new IO::File;
3487 open $gafl, "-|", @cmd or die $!;
3490 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3492 next unless m{(?:^|/)\.gitattributes$};
3494 # oh dear, found one
3496 dgit: warning: $what contains .gitattributes
3497 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3502 # tree contains no .gitattributes files
3503 $?=0; $!=0; close $gafl or failedcmd @cmd;
3507 sub multisuite_suite_child ($$$) {
3508 my ($tsuite, $mergeinputs, $fn) = @_;
3509 # in child, sets things up, calls $fn->(), and returns undef
3510 # in parent, returns canonical suite name for $tsuite
3511 my $canonsuitefh = IO::File::new_tmpfile;
3512 my $pid = fork // die $!;
3516 $us .= " [$isuite]";
3517 $debugprefix .= " ";
3518 progress "fetching $tsuite...";
3519 canonicalise_suite();
3520 print $canonsuitefh $csuite, "\n" or die $!;
3521 close $canonsuitefh or die $!;
3525 waitpid $pid,0 == $pid or die $!;
3526 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3527 seek $canonsuitefh,0,0 or die $!;
3528 local $csuite = <$canonsuitefh>;
3529 die $! unless defined $csuite && chomp $csuite;
3531 printdebug "multisuite $tsuite missing\n";
3534 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3535 push @$mergeinputs, {
3542 sub fork_for_multisuite ($) {
3543 my ($before_fetch_merge) = @_;
3544 # if nothing unusual, just returns ''
3547 # returns 0 to caller in child, to do first of the specified suites
3548 # in child, $csuite is not yet set
3550 # returns 1 to caller in parent, to finish up anything needed after
3551 # in parent, $csuite is set to canonicalised portmanteau
3553 my $org_isuite = $isuite;
3554 my @suites = split /\,/, $isuite;
3555 return '' unless @suites > 1;
3556 printdebug "fork_for_multisuite: @suites\n";
3560 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3562 return 0 unless defined $cbasesuite;
3564 fail "package $package missing in (base suite) $cbasesuite"
3565 unless @mergeinputs;
3567 my @csuites = ($cbasesuite);
3569 $before_fetch_merge->();
3571 foreach my $tsuite (@suites[1..$#suites]) {
3572 $tsuite =~ s/^-/$cbasesuite-/;
3573 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3580 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3581 push @csuites, $csubsuite;
3584 foreach my $mi (@mergeinputs) {
3585 my $ref = git_get_ref $mi->{Ref};
3586 die "$mi->{Ref} ?" unless length $ref;
3587 $mi->{Commit} = $ref;
3590 $csuite = join ",", @csuites;
3592 my $previous = git_get_ref lrref;
3594 unshift @mergeinputs, {
3595 Commit => $previous,
3596 Info => "local combined tracking branch",
3598 "archive seems to have rewound: local tracking branch is ahead!",
3602 foreach my $ix (0..$#mergeinputs) {
3603 $mergeinputs[$ix]{Index} = $ix;
3606 @mergeinputs = sort {
3607 -version_compare(mergeinfo_version $a,
3608 mergeinfo_version $b) # highest version first
3610 $a->{Index} <=> $b->{Index}; # earliest in spec first
3616 foreach my $mi (@mergeinputs) {
3617 printdebug "multisuite merge check $mi->{Info}\n";
3618 foreach my $previous (@needed) {
3619 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3620 printdebug "multisuite merge un-needed $previous->{Info}\n";
3624 printdebug "multisuite merge this-needed\n";
3625 $mi->{Character} = '+';
3628 $needed[0]{Character} = '*';
3630 my $output = $needed[0]{Commit};
3633 printdebug "multisuite merge nontrivial\n";
3634 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3636 my $commit = "tree $tree\n";
3637 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3638 "Input branches:\n";
3640 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3641 printdebug "multisuite merge include $mi->{Info}\n";
3642 $mi->{Character} //= ' ';
3643 $commit .= "parent $mi->{Commit}\n";
3644 $msg .= sprintf " %s %-25s %s\n",
3646 (mergeinfo_version $mi),
3649 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3651 " * marks the highest version branch, which choose to use\n".
3652 " + marks each branch which was not already an ancestor\n\n".
3653 "[dgit multi-suite $csuite]\n";
3655 "author $authline\n".
3656 "committer $authline\n\n";
3657 $output = make_commit_text $commit.$msg;
3658 printdebug "multisuite merge generated $output\n";
3661 fetch_from_archive_record_1($output);
3662 fetch_from_archive_record_2($output);
3664 progress "calculated combined tracking suite $csuite";
3669 sub clone_set_head () {
3670 open H, "> .git/HEAD" or die $!;
3671 print H "ref: ".lref()."\n" or die $!;
3674 sub clone_finish ($) {
3676 runcmd @git, qw(reset --hard), lrref();
3677 runcmd qw(bash -ec), <<'END';
3679 git ls-tree -r --name-only -z HEAD | \
3680 xargs -0r touch -h -r . --
3682 printdone "ready for work in $dstdir";
3686 # in multisuite, returns twice!
3687 # once in parent after first suite fetched,
3688 # and then again in child after everything is finished
3690 badusage "dry run makes no sense with clone" unless act_local();
3692 my $multi_fetched = fork_for_multisuite(sub {
3693 printdebug "multi clone before fetch merge\n";
3697 if ($multi_fetched) {
3698 printdebug "multi clone after fetch merge\n";
3700 clone_finish($dstdir);
3703 printdebug "clone main body\n";
3705 canonicalise_suite();
3706 my $hasgit = check_for_git();
3707 mkdir $dstdir or fail "create \`$dstdir': $!";
3709 runcmd @git, qw(init -q);
3713 my $giturl = access_giturl(1);
3714 if (defined $giturl) {
3715 runcmd @git, qw(remote add), 'origin', $giturl;
3718 progress "fetching existing git history";
3720 runcmd_ordryrun_local @git, qw(fetch origin);
3722 progress "starting new git history";
3724 fetch_from_archive() or no_such_package;
3725 my $vcsgiturl = $dsc->{'Vcs-Git'};
3726 if (length $vcsgiturl) {
3727 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3728 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3730 clone_finish($dstdir);
3734 canonicalise_suite();
3735 if (check_for_git()) {
3738 fetch_from_archive() or no_such_package();
3740 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3741 if (length $vcsgiturl and
3742 (grep { $csuite eq $_ }
3744 cfg 'dgit.vcs-git.suites')) {
3745 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3746 if (defined $current && $current ne $vcsgiturl) {
3748 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3749 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3753 printdone "fetched into ".lrref();
3757 my $multi_fetched = fork_for_multisuite(sub { });
3758 fetch_one() unless $multi_fetched; # parent
3759 finish 0 if $multi_fetched eq '0'; # child
3764 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3766 printdone "fetched to ".lrref()." and merged into HEAD";
3769 sub check_not_dirty () {
3770 foreach my $f (qw(local-options local-patch-header)) {
3771 if (stat_exists "debian/source/$f") {
3772 fail "git tree contains debian/source/$f";
3776 return if $includedirty;
3778 git_check_unmodified();
3781 sub commit_admin ($) {
3784 runcmd_ordryrun_local @git, qw(commit -m), $m;
3787 sub quiltify_nofix_bail ($$) {
3788 my ($headinfo, $xinfo) = @_;
3789 if ($quilt_mode eq 'nofix') {
3790 fail "quilt fixup required but quilt mode is \`nofix'\n".
3791 "HEAD commit".$headinfo." differs from tree implied by ".
3792 " debian/patches".$xinfo;
3796 sub commit_quilty_patch () {
3797 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3799 foreach my $l (split /\n/, $output) {
3800 next unless $l =~ m/\S/;
3801 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3805 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3807 progress "nothing quilty to commit, ok.";
3810 quiltify_nofix_bail "", " (wanted to commit patch update)";
3811 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3812 runcmd_ordryrun_local @git, qw(add -f), @adds;
3814 Commit Debian 3.0 (quilt) metadata
3816 [dgit ($our_version) quilt-fixup]
3820 sub get_source_format () {
3822 if (open F, "debian/source/options") {
3826 s/\s+$//; # ignore missing final newline
3828 my ($k, $v) = ($`, $'); #');
3829 $v =~ s/^"(.*)"$/$1/;
3835 F->error and die $!;
3838 die $! unless $!==&ENOENT;
3841 if (!open F, "debian/source/format") {
3842 die $! unless $!==&ENOENT;
3846 F->error and die $!;
3848 return ($_, \%options);
3851 sub madformat_wantfixup ($) {
3853 return 0 unless $format eq '3.0 (quilt)';
3854 our $quilt_mode_warned;
3855 if ($quilt_mode eq 'nocheck') {
3856 progress "Not doing any fixup of \`$format' due to".
3857 " ----no-quilt-fixup or --quilt=nocheck"
3858 unless $quilt_mode_warned++;
3861 progress "Format \`$format', need to check/update patch stack"
3862 unless $quilt_mode_warned++;
3866 sub maybe_split_brain_save ($$$) {
3867 my ($headref, $dgitview, $msg) = @_;
3868 # => message fragment "$saved" describing disposition of $dgitview
3869 my $save = $internal_object_save{'dgit-view'};
3870 return "commit id $dgitview" unless defined $save;
3871 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3873 "dgit --dgit-view-save $msg HEAD=$headref",
3876 return "and left in $save";
3879 # An "infopair" is a tuple [ $thing, $what ]
3880 # (often $thing is a commit hash; $what is a description)
3882 sub infopair_cond_equal ($$) {
3884 $x->[0] eq $y->[0] or fail <<END;
3885 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3889 sub infopair_lrf_tag_lookup ($$) {
3890 my ($tagnames, $what) = @_;
3891 # $tagname may be an array ref
3892 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3893 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3894 foreach my $tagname (@tagnames) {
3895 my $lrefname = lrfetchrefs."/tags/$tagname";
3896 my $tagobj = $lrfetchrefs_f{$lrefname};
3897 next unless defined $tagobj;
3898 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3899 return [ git_rev_parse($tagobj), $what ];
3901 fail @tagnames==1 ? <<END : <<END;
3902 Wanted tag $what (@tagnames) on dgit server, but not found
3904 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3908 sub infopair_cond_ff ($$) {
3909 my ($anc,$desc) = @_;
3910 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3911 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3915 sub pseudomerge_version_check ($$) {
3916 my ($clogp, $archive_hash) = @_;
3918 my $arch_clogp = commit_getclogp $archive_hash;
3919 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3920 'version currently in archive' ];
3921 if (defined $overwrite_version) {
3922 if (length $overwrite_version) {
3923 infopair_cond_equal([ $overwrite_version,
3924 '--overwrite= version' ],
3927 my $v = $i_arch_v->[0];
3928 progress "Checking package changelog for archive version $v ...";
3931 my @xa = ("-f$v", "-t$v");
3932 my $vclogp = parsechangelog @xa;
3935 [ (getfield $vclogp, $fn),
3936 "$fn field from dpkg-parsechangelog @xa" ];
3938 my $cv = $gf->('Version');
3939 infopair_cond_equal($i_arch_v, $cv);
3940 $cd = $gf->('Distribution');
3943 $@ =~ s/^dgit: //gm;
3945 "Perhaps debian/changelog does not mention $v ?";
3947 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3948 $cd->[1] is $cd->[0]
3949 Your tree seems to based on earlier (not uploaded) $v.
3954 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3958 sub pseudomerge_make_commit ($$$$ $$) {
3959 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3960 $msg_cmd, $msg_msg) = @_;
3961 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3963 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3964 my $authline = clogp_authline $clogp;
3968 !defined $overwrite_version ? ""
3969 : !length $overwrite_version ? " --overwrite"
3970 : " --overwrite=".$overwrite_version;
3972 # Contributing parent is the first parent - that makes
3973 # git rev-list --first-parent DTRT.
3974 my $pmf = dgit_privdir()."/pseudomerge";
3975 open MC, ">", $pmf or die "$pmf $!";
3976 print MC <<END or die $!;
3979 parent $archive_hash
3989 return make_commit($pmf);
3992 sub splitbrain_pseudomerge ($$$$) {
3993 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3994 # => $merged_dgitview
3995 printdebug "splitbrain_pseudomerge...\n";
3997 # We: debian/PREVIOUS HEAD($maintview)
3998 # expect: o ----------------- o
4001 # a/d/PREVIOUS $dgitview
4004 # we do: `------------------ o
4008 return $dgitview unless defined $archive_hash;
4009 return $dgitview if deliberately_not_fast_forward();
4011 printdebug "splitbrain_pseudomerge...\n";
4013 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4015 if (!defined $overwrite_version) {
4016 progress "Checking that HEAD inciudes all changes in archive...";
4019 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4021 if (defined $overwrite_version) {
4023 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4024 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
4025 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4026 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
4027 my $i_archive = [ $archive_hash, "current archive contents" ];
4029 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4031 infopair_cond_equal($i_dgit, $i_archive);
4032 infopair_cond_ff($i_dep14, $i_dgit);
4033 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4036 $@ =~ s/^\n//; chomp $@;
4039 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4044 my $r = pseudomerge_make_commit
4045 $clogp, $dgitview, $archive_hash, $i_arch_v,
4046 "dgit --quilt=$quilt_mode",
4047 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4048 Declare fast forward from $i_arch_v->[0]
4050 Make fast forward from $i_arch_v->[0]
4053 maybe_split_brain_save $maintview, $r, "pseudomerge";
4055 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4059 sub plain_overwrite_pseudomerge ($$$) {
4060 my ($clogp, $head, $archive_hash) = @_;
4062 printdebug "plain_overwrite_pseudomerge...";
4064 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4066 return $head if is_fast_fwd $archive_hash, $head;
4068 my $m = "Declare fast forward from $i_arch_v->[0]";
4070 my $r = pseudomerge_make_commit
4071 $clogp, $head, $archive_hash, $i_arch_v,
4074 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4076 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4080 sub push_parse_changelog ($) {
4083 my $clogp = Dpkg::Control::Hash->new();
4084 $clogp->load($clogpfn) or die;
4086 my $clogpackage = getfield $clogp, 'Source';
4087 $package //= $clogpackage;
4088 fail "-p specified $package but changelog specified $clogpackage"
4089 unless $package eq $clogpackage;
4090 my $cversion = getfield $clogp, 'Version';
4092 if (!$we_are_initiator) {
4093 # rpush initiator can't do this because it doesn't have $isuite yet
4094 my $tag = debiantag($cversion, access_nomdistro);
4095 runcmd @git, qw(check-ref-format), $tag;
4098 my $dscfn = dscfn($cversion);
4100 return ($clogp, $cversion, $dscfn);
4103 sub push_parse_dsc ($$$) {
4104 my ($dscfn,$dscfnwhat, $cversion) = @_;
4105 $dsc = parsecontrol($dscfn,$dscfnwhat);
4106 my $dversion = getfield $dsc, 'Version';
4107 my $dscpackage = getfield $dsc, 'Source';
4108 ($dscpackage eq $package && $dversion eq $cversion) or
4109 fail "$dscfn is for $dscpackage $dversion".
4110 " but debian/changelog is for $package $cversion";
4113 sub push_tagwants ($$$$) {
4114 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4117 TagFn => \&debiantag,
4122 if (defined $maintviewhead) {
4124 TagFn => \&debiantag_maintview,
4125 Objid => $maintviewhead,
4126 TfSuffix => '-maintview',
4129 } elsif ($dodep14tag eq 'no' ? 0
4130 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4131 : $dodep14tag eq 'always'
4132 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4133 --dep14tag-always (or equivalent in config) means server must support
4134 both "new" and "maint" tag formats, but config says it doesn't.
4136 : die "$dodep14tag ?") {
4138 TagFn => \&debiantag_maintview,
4140 TfSuffix => '-dgit',
4144 foreach my $tw (@tagwants) {
4145 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4146 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4148 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4152 sub push_mktags ($$ $$ $) {
4154 $changesfile,$changesfilewhat,
4157 die unless $tagwants->[0]{View} eq 'dgit';
4159 my $declaredistro = access_nomdistro();
4160 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4161 $dsc->{$ourdscfield[0]} = join " ",
4162 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4164 $dsc->save("$dscfn.tmp") or die $!;
4166 my $changes = parsecontrol($changesfile,$changesfilewhat);
4167 foreach my $field (qw(Source Distribution Version)) {
4168 $changes->{$field} eq $clogp->{$field} or
4169 fail "changes field $field \`$changes->{$field}'".
4170 " does not match changelog \`$clogp->{$field}'";
4173 my $cversion = getfield $clogp, 'Version';
4174 my $clogsuite = getfield $clogp, 'Distribution';
4176 # We make the git tag by hand because (a) that makes it easier
4177 # to control the "tagger" (b) we can do remote signing
4178 my $authline = clogp_authline $clogp;
4179 my $delibs = join(" ", "",@deliberatelies);
4183 my $tfn = $tw->{Tfn};
4184 my $head = $tw->{Objid};
4185 my $tag = $tw->{Tag};
4187 open TO, '>', $tfn->('.tmp') or die $!;
4188 print TO <<END or die $!;
4195 if ($tw->{View} eq 'dgit') {
4196 print TO <<END or die $!;
4197 $package release $cversion for $clogsuite ($csuite) [dgit]
4198 [dgit distro=$declaredistro$delibs]
4200 foreach my $ref (sort keys %previously) {
4201 print TO <<END or die $!;
4202 [dgit previously:$ref=$previously{$ref}]
4205 } elsif ($tw->{View} eq 'maint') {
4206 print TO <<END or die $!;
4207 $package release $cversion for $clogsuite ($csuite)
4208 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4211 die Dumper($tw)."?";
4216 my $tagobjfn = $tfn->('.tmp');
4218 if (!defined $keyid) {
4219 $keyid = access_cfg('keyid','RETURN-UNDEF');
4221 if (!defined $keyid) {
4222 $keyid = getfield $clogp, 'Maintainer';
4224 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4225 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4226 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4227 push @sign_cmd, $tfn->('.tmp');
4228 runcmd_ordryrun @sign_cmd;
4230 $tagobjfn = $tfn->('.signed.tmp');
4231 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4232 $tfn->('.tmp'), $tfn->('.tmp.asc');
4238 my @r = map { $mktag->($_); } @$tagwants;
4242 sub sign_changes ($) {
4243 my ($changesfile) = @_;
4245 my @debsign_cmd = @debsign;
4246 push @debsign_cmd, "-k$keyid" if defined $keyid;
4247 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4248 push @debsign_cmd, $changesfile;
4249 runcmd_ordryrun @debsign_cmd;
4254 printdebug "actually entering push\n";
4256 supplementary_message(<<'END');
4257 Push failed, while checking state of the archive.
4258 You can retry the push, after fixing the problem, if you like.
4260 if (check_for_git()) {
4263 my $archive_hash = fetch_from_archive();
4264 if (!$archive_hash) {
4266 fail "package appears to be new in this suite;".
4267 " if this is intentional, use --new";
4270 supplementary_message(<<'END');
4271 Push failed, while preparing your push.
4272 You can retry the push, after fixing the problem, if you like.
4275 need_tagformat 'new', "quilt mode $quilt_mode"
4276 if quiltmode_splitbrain;
4280 access_giturl(); # check that success is vaguely likely
4281 rpush_handle_protovsn_bothends() if $we_are_initiator;
4284 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4285 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4287 responder_send_file('parsed-changelog', $clogpfn);
4289 my ($clogp, $cversion, $dscfn) =
4290 push_parse_changelog("$clogpfn");
4292 my $dscpath = "$buildproductsdir/$dscfn";
4293 stat_exists $dscpath or
4294 fail "looked for .dsc $dscpath, but $!;".
4295 " maybe you forgot to build";
4297 responder_send_file('dsc', $dscpath);
4299 push_parse_dsc($dscpath, $dscfn, $cversion);
4301 my $format = getfield $dsc, 'Format';
4302 printdebug "format $format\n";
4304 my $symref = git_get_symref();
4305 my $actualhead = git_rev_parse('HEAD');
4307 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4308 if (quiltmode_splitbrain()) {
4309 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4311 Branch is managed by git-debrebase ($ffq_prev
4312 exists), but quilt mode ($quilt_mode) implies a split view.
4313 Pass the right --quilt option or adjust your git config.
4314 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4317 runcmd_ordryrun_local @git_debrebase, 'stitch';
4318 $actualhead = git_rev_parse('HEAD');
4321 my $dgithead = $actualhead;
4322 my $maintviewhead = undef;
4324 my $upstreamversion = upstreamversion $clogp->{Version};
4326 if (madformat_wantfixup($format)) {
4327 # user might have not used dgit build, so maybe do this now:
4328 if (quiltmode_splitbrain()) {
4329 changedir $playground;
4330 quilt_make_fake_dsc($upstreamversion);
4332 ($dgithead, $cachekey) =
4333 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4335 "--quilt=$quilt_mode but no cached dgit view:
4336 perhaps HEAD changed since dgit build[-source] ?";
4338 $dgithead = splitbrain_pseudomerge($clogp,
4339 $actualhead, $dgithead,
4341 $maintviewhead = $actualhead;
4343 prep_ud(); # so _only_subdir() works, below
4345 commit_quilty_patch();
4349 if (defined $overwrite_version && !defined $maintviewhead
4351 $dgithead = plain_overwrite_pseudomerge($clogp,
4359 if ($archive_hash) {
4360 if (is_fast_fwd($archive_hash, $dgithead)) {
4362 } elsif (deliberately_not_fast_forward) {
4365 fail "dgit push: HEAD is not a descendant".
4366 " of the archive's version.\n".
4367 "To overwrite the archive's contents,".
4368 " pass --overwrite[=VERSION].\n".
4369 "To rewind history, if permitted by the archive,".
4370 " use --deliberately-not-fast-forward.";
4374 changedir $playground;
4375 progress "checking that $dscfn corresponds to HEAD";
4376 runcmd qw(dpkg-source -x --),
4377 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4378 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4379 check_for_vendor_patches() if madformat($dsc->{format});
4381 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4382 debugcmd "+",@diffcmd;
4384 my $r = system @diffcmd;
4387 my $referent = $split_brain ? $dgithead : 'HEAD';
4388 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4391 my $raw = cmdoutput @git,
4392 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4394 foreach (split /\0/, $raw) {
4395 if (defined $changed) {
4396 push @mode_changes, "$changed: $_\n" if $changed;
4399 } elsif (m/^:0+ 0+ /) {
4401 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4402 $changed = "Mode change from $1 to $2"
4407 if (@mode_changes) {
4408 fail <<END.(join '', @mode_changes).<<END;
4409 HEAD specifies a different tree to $dscfn:
4412 There is a problem with your source tree (see dgit(7) for some hints).
4413 To see a full diff, run git diff $tree $referent
4418 HEAD specifies a different tree to $dscfn:
4420 Perhaps you forgot to build. Or perhaps there is a problem with your
4421 source tree (see dgit(7) for some hints). To see a full diff, run
4422 git diff $tree $referent
4428 if (!$changesfile) {
4429 my $pat = changespat $cversion;
4430 my @cs = glob "$buildproductsdir/$pat";
4431 fail "failed to find unique changes file".
4432 " (looked for $pat in $buildproductsdir);".
4433 " perhaps you need to use dgit -C"
4435 ($changesfile) = @cs;
4437 $changesfile = "$buildproductsdir/$changesfile";
4440 # Check that changes and .dsc agree enough
4441 $changesfile =~ m{[^/]*$};
4442 my $changes = parsecontrol($changesfile,$&);
4443 files_compare_inputs($dsc, $changes)
4444 unless forceing [qw(dsc-changes-mismatch)];
4446 # Check whether this is a source only upload
4447 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4448 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4449 if ($sourceonlypolicy eq 'ok') {
4450 } elsif ($sourceonlypolicy eq 'always') {
4451 forceable_fail [qw(uploading-binaries)],
4452 "uploading binaries, although distroy policy is source only"
4454 } elsif ($sourceonlypolicy eq 'never') {
4455 forceable_fail [qw(uploading-source-only)],
4456 "source-only upload, although distroy policy requires .debs"
4458 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4459 forceable_fail [qw(uploading-source-only)],
4460 "source-only upload, even though package is entirely NEW\n".
4461 "(this is contrary to policy in ".(access_nomdistro()).")"
4464 && !(archive_query('package_not_wholly_new', $package) // 1);
4466 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4469 # Perhaps adjust .dsc to contain right set of origs
4470 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4472 unless forceing [qw(changes-origs-exactly)];
4474 # Checks complete, we're going to try and go ahead:
4476 responder_send_file('changes',$changesfile);
4477 responder_send_command("param head $dgithead");
4478 responder_send_command("param csuite $csuite");
4479 responder_send_command("param isuite $isuite");
4480 responder_send_command("param tagformat $tagformat");
4481 if (defined $maintviewhead) {
4482 confess "internal error (protovsn=$protovsn)"
4483 if defined $protovsn and $protovsn < 4;
4484 responder_send_command("param maint-view $maintviewhead");
4487 # Perhaps send buildinfo(s) for signing
4488 my $changes_files = getfield $changes, 'Files';
4489 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4490 foreach my $bi (@buildinfos) {
4491 responder_send_command("param buildinfo-filename $bi");
4492 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4495 if (deliberately_not_fast_forward) {
4496 git_for_each_ref(lrfetchrefs, sub {
4497 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4498 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4499 responder_send_command("previously $rrefname=$objid");
4500 $previously{$rrefname} = $objid;
4504 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4505 dgit_privdir()."/tag");
4508 supplementary_message(<<'END');
4509 Push failed, while signing the tag.
4510 You can retry the push, after fixing the problem, if you like.
4512 # If we manage to sign but fail to record it anywhere, it's fine.
4513 if ($we_are_responder) {
4514 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4515 responder_receive_files('signed-tag', @tagobjfns);
4517 @tagobjfns = push_mktags($clogp,$dscpath,
4518 $changesfile,$changesfile,
4521 supplementary_message(<<'END');
4522 Push failed, *after* signing the tag.
4523 If you want to try again, you should use a new version number.
4526 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4528 foreach my $tw (@tagwants) {
4529 my $tag = $tw->{Tag};
4530 my $tagobjfn = $tw->{TagObjFn};
4532 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4533 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4534 runcmd_ordryrun_local
4535 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4538 supplementary_message(<<'END');
4539 Push failed, while updating the remote git repository - see messages above.
4540 If you want to try again, you should use a new version number.
4542 if (!check_for_git()) {
4543 create_remote_git_repo();
4546 my @pushrefs = $forceflag.$dgithead.":".rrref();
4547 foreach my $tw (@tagwants) {
4548 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4551 runcmd_ordryrun @git,
4552 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4553 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4555 supplementary_message(<<'END');
4556 Push failed, while obtaining signatures on the .changes and .dsc.
4557 If it was just that the signature failed, you may try again by using
4558 debsign by hand to sign the changes file (see the command dgit tried,
4559 above), and then dput that changes file to complete the upload.
4560 If you need to change the package, you must use a new version number.
4562 if ($we_are_responder) {
4563 my $dryrunsuffix = act_local() ? "" : ".tmp";
4564 my @rfiles = ($dscpath, $changesfile);
4565 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4566 responder_receive_files('signed-dsc-changes',
4567 map { "$_$dryrunsuffix" } @rfiles);
4570 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4572 progress "[new .dsc left in $dscpath.tmp]";
4574 sign_changes $changesfile;
4577 supplementary_message(<<END);
4578 Push failed, while uploading package(s) to the archive server.
4579 You can retry the upload of exactly these same files with dput of:
4581 If that .changes file is broken, you will need to use a new version
4582 number for your next attempt at the upload.
4584 my $host = access_cfg('upload-host','RETURN-UNDEF');
4585 my @hostarg = defined($host) ? ($host,) : ();
4586 runcmd_ordryrun @dput, @hostarg, $changesfile;
4587 printdone "pushed and uploaded $cversion";
4589 supplementary_message('');
4590 responder_send_command("complete");
4594 not_necessarily_a_tree();
4599 badusage "-p is not allowed with clone; specify as argument instead"
4600 if defined $package;
4603 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4604 ($package,$isuite) = @ARGV;
4605 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4606 ($package,$dstdir) = @ARGV;
4607 } elsif (@ARGV==3) {
4608 ($package,$isuite,$dstdir) = @ARGV;
4610 badusage "incorrect arguments to dgit clone";
4614 $dstdir ||= "$package";
4615 if (stat_exists $dstdir) {
4616 fail "$dstdir already exists";
4620 if ($rmonerror && !$dryrun_level) {
4621 $cwd_remove= getcwd();
4623 return unless defined $cwd_remove;
4624 if (!chdir "$cwd_remove") {
4625 return if $!==&ENOENT;
4626 die "chdir $cwd_remove: $!";
4628 printdebug "clone rmonerror removing $dstdir\n";
4630 rmtree($dstdir) or die "remove $dstdir: $!\n";
4631 } elsif (grep { $! == $_ }
4632 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4634 print STDERR "check whether to remove $dstdir: $!\n";
4640 $cwd_remove = undef;
4643 sub branchsuite () {
4644 my $branch = git_get_symref();
4645 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4652 sub package_from_d_control () {
4653 if (!defined $package) {
4654 my $sourcep = parsecontrol('debian/control','debian/control');
4655 $package = getfield $sourcep, 'Source';
4659 sub fetchpullargs () {
4660 package_from_d_control();
4662 $isuite = branchsuite();
4664 my $clogp = parsechangelog();
4665 my $clogsuite = getfield $clogp, 'Distribution';
4666 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4668 } elsif (@ARGV==1) {
4671 badusage "incorrect arguments to dgit fetch or dgit pull";
4685 if (quiltmode_splitbrain()) {
4686 my ($format, $fopts) = get_source_format();
4687 madformat($format) and fail <<END
4688 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4696 package_from_d_control();
4697 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4701 foreach my $canon (qw(0 1)) {
4706 canonicalise_suite();
4708 if (length git_get_ref lref()) {
4709 # local branch already exists, yay
4712 if (!length git_get_ref lrref()) {
4720 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4723 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4724 "dgit checkout $isuite";
4725 runcmd (@git, qw(checkout), lbranch());
4728 sub cmd_update_vcs_git () {
4730 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4731 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4733 ($specsuite) = (@ARGV);
4738 if ($ARGV[0] eq '-') {
4740 } elsif ($ARGV[0] eq '-') {
4745 package_from_d_control();
4747 if ($specsuite eq '.') {
4748 $ctrl = parsecontrol 'debian/control', 'debian/control';
4750 $isuite = $specsuite;
4754 my $url = getfield $ctrl, 'Vcs-Git';
4757 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4758 if (!defined $orgurl) {
4759 print STDERR "setting up vcs-git: $url\n";
4760 @cmd = (@git, qw(remote add vcs-git), $url);
4761 } elsif ($orgurl eq $url) {
4762 print STDERR "vcs git already configured: $url\n";
4764 print STDERR "changing vcs-git url to: $url\n";
4765 @cmd = (@git, qw(remote set-url vcs-git), $url);
4767 runcmd_ordryrun_local @cmd;
4769 print "fetching (@ARGV)\n";
4770 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4776 build_or_push_prep_early();
4781 } elsif (@ARGV==1) {
4782 ($specsuite) = (@ARGV);
4784 badusage "incorrect arguments to dgit $subcommand";
4787 local ($package) = $existing_package; # this is a hack
4788 canonicalise_suite();
4790 canonicalise_suite();
4792 if (defined $specsuite &&
4793 $specsuite ne $isuite &&
4794 $specsuite ne $csuite) {
4795 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4796 " but command line specifies $specsuite";
4805 #---------- remote commands' implementation ----------
4807 sub pre_remote_push_build_host {
4808 my ($nrargs) = shift @ARGV;
4809 my (@rargs) = @ARGV[0..$nrargs-1];
4810 @ARGV = @ARGV[$nrargs..$#ARGV];
4812 my ($dir,$vsnwant) = @rargs;
4813 # vsnwant is a comma-separated list; we report which we have
4814 # chosen in our ready response (so other end can tell if they
4817 $we_are_responder = 1;
4818 $us .= " (build host)";
4820 open PI, "<&STDIN" or die $!;
4821 open STDIN, "/dev/null" or die $!;
4822 open PO, ">&STDOUT" or die $!;
4824 open STDOUT, ">&STDERR" or die $!;
4828 ($protovsn) = grep {
4829 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4830 } @rpushprotovsn_support;
4832 fail "build host has dgit rpush protocol versions ".
4833 (join ",", @rpushprotovsn_support).
4834 " but invocation host has $vsnwant"
4835 unless defined $protovsn;
4839 sub cmd_remote_push_build_host {
4840 responder_send_command("dgit-remote-push-ready $protovsn");
4844 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4845 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4846 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4847 # a good error message)
4849 sub rpush_handle_protovsn_bothends () {
4850 if ($protovsn < 4) {
4851 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4860 my $report = i_child_report();
4861 if (defined $report) {
4862 printdebug "($report)\n";
4863 } elsif ($i_child_pid) {
4864 printdebug "(killing build host child $i_child_pid)\n";
4865 kill 15, $i_child_pid;
4867 if (defined $i_tmp && !defined $initiator_tempdir) {
4869 eval { rmtree $i_tmp; };
4874 return unless forkcheck_mainprocess();
4879 my ($base,$selector,@args) = @_;
4880 $selector =~ s/\-/_/g;
4881 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4885 not_necessarily_a_tree();
4890 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4898 push @rargs, join ",", @rpushprotovsn_support;
4901 push @rdgit, @ropts;
4902 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4904 my @cmd = (@ssh, $host, shellquote @rdgit);
4907 $we_are_initiator=1;
4909 if (defined $initiator_tempdir) {
4910 rmtree $initiator_tempdir;
4911 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4912 $i_tmp = $initiator_tempdir;
4916 $i_child_pid = open2(\*RO, \*RI, @cmd);
4918 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4919 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4920 $supplementary_message = '' unless $protovsn >= 3;
4923 my ($icmd,$iargs) = initiator_expect {
4924 m/^(\S+)(?: (.*))?$/;
4927 i_method "i_resp", $icmd, $iargs;
4931 sub i_resp_progress ($) {
4933 my $msg = protocol_read_bytes \*RO, $rhs;
4937 sub i_resp_supplementary_message ($) {
4939 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4942 sub i_resp_complete {
4943 my $pid = $i_child_pid;
4944 $i_child_pid = undef; # prevents killing some other process with same pid
4945 printdebug "waiting for build host child $pid...\n";
4946 my $got = waitpid $pid, 0;
4947 die $! unless $got == $pid;
4948 die "build host child failed $?" if $?;
4951 printdebug "all done\n";
4955 sub i_resp_file ($) {
4957 my $localname = i_method "i_localname", $keyword;
4958 my $localpath = "$i_tmp/$localname";
4959 stat_exists $localpath and
4960 badproto \*RO, "file $keyword ($localpath) twice";
4961 protocol_receive_file \*RO, $localpath;
4962 i_method "i_file", $keyword;
4967 sub i_resp_param ($) {
4968 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4972 sub i_resp_previously ($) {
4973 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4974 or badproto \*RO, "bad previously spec";
4975 my $r = system qw(git check-ref-format), $1;
4976 die "bad previously ref spec ($r)" if $r;
4977 $previously{$1} = $2;
4982 sub i_resp_want ($) {
4984 die "$keyword ?" if $i_wanted{$keyword}++;
4986 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4987 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4988 die unless $isuite =~ m/^$suite_re$/;
4991 rpush_handle_protovsn_bothends();
4993 fail "rpush negotiated protocol version $protovsn".
4994 " which does not support quilt mode $quilt_mode"
4995 if quiltmode_splitbrain;
4997 my @localpaths = i_method "i_want", $keyword;
4998 printdebug "[[ $keyword @localpaths\n";
4999 foreach my $localpath (@localpaths) {
5000 protocol_send_file \*RI, $localpath;
5002 print RI "files-end\n" or die $!;
5005 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5007 sub i_localname_parsed_changelog {
5008 return "remote-changelog.822";
5010 sub i_file_parsed_changelog {
5011 ($i_clogp, $i_version, $i_dscfn) =
5012 push_parse_changelog "$i_tmp/remote-changelog.822";
5013 die if $i_dscfn =~ m#/|^\W#;
5016 sub i_localname_dsc {
5017 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5022 sub i_localname_buildinfo ($) {
5023 my $bi = $i_param{'buildinfo-filename'};
5024 defined $bi or badproto \*RO, "buildinfo before filename";
5025 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5026 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5027 or badproto \*RO, "improper buildinfo filename";
5030 sub i_file_buildinfo {
5031 my $bi = $i_param{'buildinfo-filename'};
5032 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5033 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5034 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5035 files_compare_inputs($bd, $ch);
5036 (getfield $bd, $_) eq (getfield $ch, $_) or
5037 fail "buildinfo mismatch $_"
5038 foreach qw(Source Version);
5039 !defined $bd->{$_} or
5040 fail "buildinfo contains $_"
5041 foreach qw(Changes Changed-by Distribution);
5043 push @i_buildinfos, $bi;
5044 delete $i_param{'buildinfo-filename'};
5047 sub i_localname_changes {
5048 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5049 $i_changesfn = $i_dscfn;
5050 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5051 return $i_changesfn;
5053 sub i_file_changes { }
5055 sub i_want_signed_tag {
5056 printdebug Dumper(\%i_param, $i_dscfn);
5057 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5058 && defined $i_param{'csuite'}
5059 or badproto \*RO, "premature desire for signed-tag";
5060 my $head = $i_param{'head'};
5061 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5063 my $maintview = $i_param{'maint-view'};
5064 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5067 if ($protovsn >= 4) {
5068 my $p = $i_param{'tagformat'} // '<undef>';
5070 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5073 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5075 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5077 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5080 push_mktags $i_clogp, $i_dscfn,
5081 $i_changesfn, 'remote changes',
5085 sub i_want_signed_dsc_changes {
5086 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5087 sign_changes $i_changesfn;
5088 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5091 #---------- building etc. ----------
5097 #----- `3.0 (quilt)' handling -----
5099 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5101 sub quiltify_dpkg_commit ($$$;$) {
5102 my ($patchname,$author,$msg, $xinfo) = @_;
5105 mkpath '.git/dgit'; # we are in playtree
5106 my $descfn = ".git/dgit/quilt-description.tmp";
5107 open O, '>', $descfn or die "$descfn: $!";
5108 $msg =~ s/\n+/\n\n/;
5109 print O <<END or die $!;
5111 ${xinfo}Subject: $msg
5118 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5119 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5120 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5121 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5125 sub quiltify_trees_differ ($$;$$$) {
5126 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5127 # returns true iff the two tree objects differ other than in debian/
5128 # with $finegrained,
5129 # returns bitmask 01 - differ in upstream files except .gitignore
5130 # 02 - differ in .gitignore
5131 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5132 # is set for each modified .gitignore filename $fn
5133 # if $unrepres is defined, array ref to which is appeneded
5134 # a list of unrepresentable changes (removals of upstream files
5137 my @cmd = (@git, qw(diff-tree -z --no-renames));
5138 push @cmd, qw(--name-only) unless $unrepres;
5139 push @cmd, qw(-r) if $finegrained || $unrepres;
5141 my $diffs= cmdoutput @cmd;
5144 foreach my $f (split /\0/, $diffs) {
5145 if ($unrepres && !@lmodes) {
5146 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5149 my ($oldmode,$newmode) = @lmodes;
5152 next if $f =~ m#^debian(?:/.*)?$#s;
5156 die "not a plain file or symlink\n"
5157 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5158 $oldmode =~ m/^(?:10|12)\d{4}$/;
5159 if ($oldmode =~ m/[^0]/ &&
5160 $newmode =~ m/[^0]/) {
5161 # both old and new files exist
5162 die "mode or type changed\n" if $oldmode ne $newmode;
5163 die "modified symlink\n" unless $newmode =~ m/^10/;
5164 } elsif ($oldmode =~ m/[^0]/) {
5166 die "deletion of symlink\n"
5167 unless $oldmode =~ m/^10/;
5170 die "creation with non-default mode\n"
5171 unless $newmode =~ m/^100644$/ or
5172 $newmode =~ m/^120000$/;
5176 local $/="\n"; chomp $@;
5177 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5181 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5182 $r |= $isignore ? 02 : 01;
5183 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5185 printdebug "quiltify_trees_differ $x $y => $r\n";
5189 sub quiltify_tree_sentinelfiles ($) {
5190 # lists the `sentinel' files present in the tree
5192 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5193 qw(-- debian/rules debian/control);
5198 sub quiltify_splitbrain_needed () {
5199 if (!$split_brain) {
5200 progress "dgit view: changes are required...";
5201 runcmd @git, qw(checkout -q -b dgit-view);
5206 sub quiltify_splitbrain ($$$$$$$) {
5207 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5208 $editedignores, $cachekey) = @_;
5209 my $gitignore_special = 1;
5210 if ($quilt_mode !~ m/gbp|dpm/) {
5211 # treat .gitignore just like any other upstream file
5212 $diffbits = { %$diffbits };
5213 $_ = !!$_ foreach values %$diffbits;
5214 $gitignore_special = 0;
5216 # We would like any commits we generate to be reproducible
5217 my @authline = clogp_authline($clogp);
5218 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5219 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5220 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5221 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5222 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5223 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5225 my $fulldiffhint = sub {
5227 my $cmd = "git diff $x $y -- :/ ':!debian'";
5228 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5229 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5232 if ($quilt_mode =~ m/gbp|unapplied/ &&
5233 ($diffbits->{O2H} & 01)) {
5235 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5236 " but git tree differs from orig in upstream files.";
5237 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5238 if (!stat_exists "debian/patches") {
5240 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5244 if ($quilt_mode =~ m/dpm/ &&
5245 ($diffbits->{H2A} & 01)) {
5246 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5247 --quilt=$quilt_mode specified, implying patches-applied git tree
5248 but git tree differs from result of applying debian/patches to upstream
5251 if ($quilt_mode =~ m/gbp|unapplied/ &&
5252 ($diffbits->{O2A} & 01)) { # some patches
5253 quiltify_splitbrain_needed();
5254 progress "dgit view: creating patches-applied version using gbp pq";
5255 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5256 # gbp pq import creates a fresh branch; push back to dgit-view
5257 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5258 runcmd @git, qw(checkout -q dgit-view);
5260 if ($quilt_mode =~ m/gbp|dpm/ &&
5261 ($diffbits->{O2A} & 02)) {
5263 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5264 tool which does not create patches for changes to upstream
5265 .gitignores: but, such patches exist in debian/patches.
5268 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5269 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5270 quiltify_splitbrain_needed();
5271 progress "dgit view: creating patch to represent .gitignore changes";
5272 ensuredir "debian/patches";
5273 my $gipatch = "debian/patches/auto-gitignore";
5274 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5275 stat GIPATCH or die "$gipatch: $!";
5276 fail "$gipatch already exists; but want to create it".
5277 " to record .gitignore changes" if (stat _)[7];
5278 print GIPATCH <<END or die "$gipatch: $!";
5279 Subject: Update .gitignore from Debian packaging branch
5281 The Debian packaging git branch contains these updates to the upstream
5282 .gitignore file(s). This patch is autogenerated, to provide these
5283 updates to users of the official Debian archive view of the package.
5285 [dgit ($our_version) update-gitignore]
5288 close GIPATCH or die "$gipatch: $!";
5289 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5290 $unapplied, $headref, "--", sort keys %$editedignores;
5291 open SERIES, "+>>", "debian/patches/series" or die $!;
5292 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5294 defined read SERIES, $newline, 1 or die $!;
5295 print SERIES "\n" or die $! unless $newline eq "\n";
5296 print SERIES "auto-gitignore\n" or die $!;
5297 close SERIES or die $!;
5298 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5300 Commit patch to update .gitignore
5302 [dgit ($our_version) update-gitignore-quilt-fixup]
5306 my $dgitview = git_rev_parse 'HEAD';
5309 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5311 changedir "$playground/work";
5313 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5314 progress "dgit view: created ($saved)";
5317 sub quiltify ($$$$) {
5318 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5320 # Quilt patchification algorithm
5322 # We search backwards through the history of the main tree's HEAD
5323 # (T) looking for a start commit S whose tree object is identical
5324 # to to the patch tip tree (ie the tree corresponding to the
5325 # current dpkg-committed patch series). For these purposes
5326 # `identical' disregards anything in debian/ - this wrinkle is
5327 # necessary because dpkg-source treates debian/ specially.
5329 # We can only traverse edges where at most one of the ancestors'
5330 # trees differs (in changes outside in debian/). And we cannot
5331 # handle edges which change .pc/ or debian/patches. To avoid
5332 # going down a rathole we avoid traversing edges which introduce
5333 # debian/rules or debian/control. And we set a limit on the
5334 # number of edges we are willing to look at.
5336 # If we succeed, we walk forwards again. For each traversed edge
5337 # PC (with P parent, C child) (starting with P=S and ending with
5338 # C=T) to we do this:
5340 # - dpkg-source --commit with a patch name and message derived from C
5341 # After traversing PT, we git commit the changes which
5342 # should be contained within debian/patches.
5344 # The search for the path S..T is breadth-first. We maintain a
5345 # todo list containing search nodes. A search node identifies a
5346 # commit, and looks something like this:
5348 # Commit => $git_commit_id,
5349 # Child => $c, # or undef if P=T
5350 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5351 # Nontrivial => true iff $p..$c has relevant changes
5358 my %considered; # saves being exponential on some weird graphs
5360 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5363 my ($search,$whynot) = @_;
5364 printdebug " search NOT $search->{Commit} $whynot\n";
5365 $search->{Whynot} = $whynot;
5366 push @nots, $search;
5367 no warnings qw(exiting);
5376 my $c = shift @todo;
5377 next if $considered{$c->{Commit}}++;
5379 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5381 printdebug "quiltify investigate $c->{Commit}\n";
5384 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5385 printdebug " search finished hooray!\n";
5390 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5391 if ($quilt_mode eq 'smash') {
5392 printdebug " search quitting smash\n";
5396 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5397 $not->($c, "has $c_sentinels not $t_sentinels")
5398 if $c_sentinels ne $t_sentinels;
5400 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5401 $commitdata =~ m/\n\n/;
5403 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5404 @parents = map { { Commit => $_, Child => $c } } @parents;
5406 $not->($c, "root commit") if !@parents;
5408 foreach my $p (@parents) {
5409 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5411 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5412 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5414 foreach my $p (@parents) {
5415 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5417 my @cmd= (@git, qw(diff-tree -r --name-only),
5418 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5419 my $patchstackchange = cmdoutput @cmd;
5420 if (length $patchstackchange) {
5421 $patchstackchange =~ s/\n/,/g;
5422 $not->($p, "changed $patchstackchange");
5425 printdebug " search queue P=$p->{Commit} ",
5426 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5432 printdebug "quiltify want to smash\n";
5435 my $x = $_[0]{Commit};
5436 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5439 my $reportnot = sub {
5441 my $s = $abbrev->($notp);
5442 my $c = $notp->{Child};
5443 $s .= "..".$abbrev->($c) if $c;
5444 $s .= ": ".$notp->{Whynot};
5447 if ($quilt_mode eq 'linear') {
5448 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5449 my $all_gdr = !!@nots;
5450 foreach my $notp (@nots) {
5451 print STDERR "$us: ", $reportnot->($notp), "\n";
5452 $all_gdr &&= $notp->{Child} &&
5453 (git_cat_file $notp->{Child}{Commit}, 'commit')
5454 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5458 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5460 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5462 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5463 } elsif ($quilt_mode eq 'smash') {
5464 } elsif ($quilt_mode eq 'auto') {
5465 progress "quilt fixup cannot be linear, smashing...";
5467 die "$quilt_mode ?";
5470 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5471 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5473 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5475 quiltify_dpkg_commit "auto-$version-$target-$time",
5476 (getfield $clogp, 'Maintainer'),
5477 "Automatically generated patch ($clogp->{Version})\n".
5478 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5482 progress "quiltify linearisation planning successful, executing...";
5484 for (my $p = $sref_S;
5485 my $c = $p->{Child};
5487 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5488 next unless $p->{Nontrivial};
5490 my $cc = $c->{Commit};
5492 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5493 $commitdata =~ m/\n\n/ or die "$c ?";
5496 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5499 my $commitdate = cmdoutput
5500 @git, qw(log -n1 --pretty=format:%aD), $cc;
5502 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5504 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5511 my $gbp_check_suitable = sub {
5516 die "contains unexpected slashes\n" if m{//} || m{/$};
5517 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5518 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5519 die "is series file\n" if m{$series_filename_re}o;
5520 die "too long" if length > 200;
5522 return $_ unless $@;
5523 print STDERR "quiltifying commit $cc:".
5524 " ignoring/dropping Gbp-Pq $what: $@";
5528 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5530 (\S+) \s* \n //ixm) {
5531 $patchname = $gbp_check_suitable->($1, 'Name');
5533 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5535 (\S+) \s* \n //ixm) {
5536 $patchdir = $gbp_check_suitable->($1, 'Topic');
5541 if (!defined $patchname) {
5542 $patchname = $title;
5543 $patchname =~ s/[.:]$//;
5546 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5547 my $translitname = $converter->convert($patchname);
5548 die unless defined $translitname;
5549 $patchname = $translitname;
5552 "dgit: patch title transliteration error: $@"
5554 $patchname =~ y/ A-Z/-a-z/;
5555 $patchname =~ y/-a-z0-9_.+=~//cd;
5556 $patchname =~ s/^\W/x-$&/;
5557 $patchname = substr($patchname,0,40);
5558 $patchname .= ".patch";
5560 if (!defined $patchdir) {
5563 if (length $patchdir) {
5564 $patchname = "$patchdir/$patchname";
5566 if ($patchname =~ m{^(.*)/}) {
5567 mkpath "debian/patches/$1";
5572 stat "debian/patches/$patchname$index";
5574 $!==ENOENT or die "$patchname$index $!";
5576 runcmd @git, qw(checkout -q), $cc;
5578 # We use the tip's changelog so that dpkg-source doesn't
5579 # produce complaining messages from dpkg-parsechangelog. None
5580 # of the information dpkg-source gets from the changelog is
5581 # actually relevant - it gets put into the original message
5582 # which dpkg-source provides our stunt editor, and then
5584 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5586 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5587 "Date: $commitdate\n".
5588 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5590 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5593 runcmd @git, qw(checkout -q master);
5596 sub build_maybe_quilt_fixup () {
5597 my ($format,$fopts) = get_source_format;
5598 return unless madformat_wantfixup $format;
5601 check_for_vendor_patches();
5603 if (quiltmode_splitbrain) {
5604 fail <<END unless access_cfg_tagformats_can_splitbrain;
5605 quilt mode $quilt_mode requires split view so server needs to support
5606 both "new" and "maint" tag formats, but config says it doesn't.
5610 my $clogp = parsechangelog();
5611 my $headref = git_rev_parse('HEAD');
5612 my $symref = git_get_symref();
5614 if ($quilt_mode eq 'linear'
5615 && !$fopts->{'single-debian-patch'}
5616 && branch_is_gdr($headref)) {
5617 # This is much faster. It also makes patches that gdr
5618 # likes better for future updates without laundering.
5620 # However, it can fail in some casses where we would
5621 # succeed: if there are existing patches, which correspond
5622 # to a prefix of the branch, but are not in gbp/gdr
5623 # format, gdr will fail (exiting status 7), but we might
5624 # be able to figure out where to start linearising. That
5625 # will be slower so hopefully there's not much to do.
5626 my @cmd = (@git_debrebase,
5627 qw(--noop-ok -funclean-mixed -funclean-ordering
5628 make-patches --quiet-would-amend));
5629 # We tolerate soe snags that gdr wouldn't, by default.
5633 failedcmd @cmd if system @cmd and $?!=7*256;
5637 $headref = git_rev_parse('HEAD');
5641 changedir $playground;
5643 my $upstreamversion = upstreamversion $version;
5645 if ($fopts->{'single-debian-patch'}) {
5646 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5648 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5652 runcmd_ordryrun_local
5653 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5656 sub unpack_playtree_mkwork ($) {
5659 mkdir "work" or die $!;
5661 mktree_in_ud_here();
5662 runcmd @git, qw(reset -q --hard), $headref;
5665 sub unpack_playtree_linkorigs ($$) {
5666 my ($upstreamversion, $fn) = @_;
5667 # calls $fn->($leafname);
5669 my $bpd_abs = bpd_abs();
5670 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5671 while ($!=0, defined(my $b = readdir QFD)) {
5672 my $f = bpd_abs()."/".$b;
5674 local ($debuglevel) = $debuglevel-1;
5675 printdebug "QF linkorigs $b, $f ?\n";
5677 next unless is_orig_file_of_vsn $b, $upstreamversion;
5678 printdebug "QF linkorigs $b, $f Y\n";
5679 link_ltarget $f, $b or die "$b $!";
5682 die "$buildproductsdir: $!" if $!;
5686 sub quilt_fixup_delete_pc () {
5687 runcmd @git, qw(rm -rqf .pc);
5689 Commit removal of .pc (quilt series tracking data)
5691 [dgit ($our_version) upgrade quilt-remove-pc]
5695 sub quilt_fixup_singlepatch ($$$) {
5696 my ($clogp, $headref, $upstreamversion) = @_;
5698 progress "starting quiltify (single-debian-patch)";
5700 # dpkg-source --commit generates new patches even if
5701 # single-debian-patch is in debian/source/options. In order to
5702 # get it to generate debian/patches/debian-changes, it is
5703 # necessary to build the source package.
5705 unpack_playtree_linkorigs($upstreamversion, sub { });
5706 unpack_playtree_mkwork($headref);
5708 rmtree("debian/patches");
5710 runcmd @dpkgsource, qw(-b .);
5712 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5713 rename srcfn("$upstreamversion", "/debian/patches"),
5714 "work/debian/patches";
5717 commit_quilty_patch();
5720 sub quilt_make_fake_dsc ($) {
5721 my ($upstreamversion) = @_;
5723 my $fakeversion="$upstreamversion-~~DGITFAKE";
5725 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5726 print $fakedsc <<END or die $!;
5729 Version: $fakeversion
5733 my $dscaddfile=sub {
5736 my $md = new Digest::MD5;
5738 my $fh = new IO::File $b, '<' or die "$b $!";
5743 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5746 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5748 my @files=qw(debian/source/format debian/rules
5749 debian/control debian/changelog);
5750 foreach my $maybe (qw(debian/patches debian/source/options
5751 debian/tests/control)) {
5752 next unless stat_exists "$maindir/$maybe";
5753 push @files, $maybe;
5756 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5757 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5759 $dscaddfile->($debtar);
5760 close $fakedsc or die $!;
5763 sub quilt_fakedsc2unapplied ($$) {
5764 my ($headref, $upstreamversion) = @_;
5765 # must be run in the playground
5766 # quilt_make_fake_dsc must have been called
5769 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5771 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5772 rename $fakexdir, "fake" or die "$fakexdir $!";
5776 remove_stray_gits("source package");
5777 mktree_in_ud_here();
5781 rmtree 'debian'; # git checkout commitish paths does not delete!
5782 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5783 my $unapplied=git_add_write_tree();
5784 printdebug "fake orig tree object $unapplied\n";
5788 sub quilt_check_splitbrain_cache ($$) {
5789 my ($headref, $upstreamversion) = @_;
5790 # Called only if we are in (potentially) split brain mode.
5791 # Called in playground.
5792 # Computes the cache key and looks in the cache.
5793 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5795 my $splitbrain_cachekey;
5798 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5799 # we look in the reflog of dgit-intern/quilt-cache
5800 # we look for an entry whose message is the key for the cache lookup
5801 my @cachekey = (qw(dgit), $our_version);
5802 push @cachekey, $upstreamversion;
5803 push @cachekey, $quilt_mode;
5804 push @cachekey, $headref;
5806 push @cachekey, hashfile('fake.dsc');
5808 my $srcshash = Digest::SHA->new(256);
5809 my %sfs = ( %INC, '$0(dgit)' => $0 );
5810 foreach my $sfk (sort keys %sfs) {
5811 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5812 $srcshash->add($sfk," ");
5813 $srcshash->add(hashfile($sfs{$sfk}));
5814 $srcshash->add("\n");
5816 push @cachekey, $srcshash->hexdigest();
5817 $splitbrain_cachekey = "@cachekey";
5819 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5821 my $cachehit = reflog_cache_lookup
5822 "refs/$splitbraincache", $splitbrain_cachekey;
5825 unpack_playtree_mkwork($headref);
5826 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5827 if ($cachehit ne $headref) {
5828 progress "dgit view: found cached ($saved)";
5829 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5831 return ($cachehit, $splitbrain_cachekey);
5833 progress "dgit view: found cached, no changes required";
5834 return ($headref, $splitbrain_cachekey);
5837 printdebug "splitbrain cache miss\n";
5838 return (undef, $splitbrain_cachekey);
5841 sub quilt_fixup_multipatch ($$$) {
5842 my ($clogp, $headref, $upstreamversion) = @_;
5844 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5847 # - honour any existing .pc in case it has any strangeness
5848 # - determine the git commit corresponding to the tip of
5849 # the patch stack (if there is one)
5850 # - if there is such a git commit, convert each subsequent
5851 # git commit into a quilt patch with dpkg-source --commit
5852 # - otherwise convert all the differences in the tree into
5853 # a single git commit
5857 # Our git tree doesn't necessarily contain .pc. (Some versions of
5858 # dgit would include the .pc in the git tree.) If there isn't
5859 # one, we need to generate one by unpacking the patches that we
5862 # We first look for a .pc in the git tree. If there is one, we
5863 # will use it. (This is not the normal case.)
5865 # Otherwise need to regenerate .pc so that dpkg-source --commit
5866 # can work. We do this as follows:
5867 # 1. Collect all relevant .orig from parent directory
5868 # 2. Generate a debian.tar.gz out of
5869 # debian/{patches,rules,source/format,source/options}
5870 # 3. Generate a fake .dsc containing just these fields:
5871 # Format Source Version Files
5872 # 4. Extract the fake .dsc
5873 # Now the fake .dsc has a .pc directory.
5874 # (In fact we do this in every case, because in future we will
5875 # want to search for a good base commit for generating patches.)
5877 # Then we can actually do the dpkg-source --commit
5878 # 1. Make a new working tree with the same object
5879 # store as our main tree and check out the main
5881 # 2. Copy .pc from the fake's extraction, if necessary
5882 # 3. Run dpkg-source --commit
5883 # 4. If the result has changes to debian/, then
5884 # - git add them them
5885 # - git add .pc if we had a .pc in-tree
5887 # 5. If we had a .pc in-tree, delete it, and git commit
5888 # 6. Back in the main tree, fast forward to the new HEAD
5890 # Another situation we may have to cope with is gbp-style
5891 # patches-unapplied trees.
5893 # We would want to detect these, so we know to escape into
5894 # quilt_fixup_gbp. However, this is in general not possible.
5895 # Consider a package with a one patch which the dgit user reverts
5896 # (with git revert or the moral equivalent).
5898 # That is indistinguishable in contents from a patches-unapplied
5899 # tree. And looking at the history to distinguish them is not
5900 # useful because the user might have made a confusing-looking git
5901 # history structure (which ought to produce an error if dgit can't
5902 # cope, not a silent reintroduction of an unwanted patch).
5904 # So gbp users will have to pass an option. But we can usually
5905 # detect their failure to do so: if the tree is not a clean
5906 # patches-applied tree, quilt linearisation fails, but the tree
5907 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5908 # they want --quilt=unapplied.
5910 # To help detect this, when we are extracting the fake dsc, we
5911 # first extract it with --skip-patches, and then apply the patches
5912 # afterwards with dpkg-source --before-build. That lets us save a
5913 # tree object corresponding to .origs.
5915 my $splitbrain_cachekey;
5917 quilt_make_fake_dsc($upstreamversion);
5919 if (quiltmode_splitbrain()) {
5921 ($cachehit, $splitbrain_cachekey) =
5922 quilt_check_splitbrain_cache($headref, $upstreamversion);
5923 return if $cachehit;
5925 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
5929 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5931 if (system @bbcmd) {
5932 failedcmd @bbcmd if $? < 0;
5934 failed to apply your git tree's patch stack (from debian/patches/) to
5935 the corresponding upstream tarball(s). Your source tree and .orig
5936 are probably too inconsistent. dgit can only fix up certain kinds of
5937 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5943 unpack_playtree_mkwork($headref);
5946 if (stat_exists ".pc") {
5948 progress "Tree already contains .pc - will use it then delete it.";
5951 rename '../fake/.pc','.pc' or die $!;
5954 changedir '../fake';
5956 my $oldtiptree=git_add_write_tree();
5957 printdebug "fake o+d/p tree object $unapplied\n";
5958 changedir '../work';
5961 # We calculate some guesswork now about what kind of tree this might
5962 # be. This is mostly for error reporting.
5968 # O = orig, without patches applied
5969 # A = "applied", ie orig with H's debian/patches applied
5970 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5971 \%editedignores, \@unrepres),
5972 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5973 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5977 foreach my $b (qw(01 02)) {
5978 foreach my $v (qw(O2H O2A H2A)) {
5979 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5982 printdebug "differences \@dl @dl.\n";
5985 "$us: base trees orig=%.20s o+d/p=%.20s",
5986 $unapplied, $oldtiptree;
5988 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5989 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5990 $dl[0], $dl[1], $dl[3], $dl[4],
5994 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5996 forceable_fail [qw(unrepresentable)], <<END;
5997 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6002 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6003 push @failsuggestion, [ 'unapplied',
6004 "This might be a patches-unapplied branch." ];
6005 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6006 push @failsuggestion, [ 'applied',
6007 "This might be a patches-applied branch." ];
6009 push @failsuggestion, [ 'quilt-mode',
6010 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6012 push @failsuggestion, [ 'gitattrs',
6013 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6014 if stat_exists '.gitattributes';
6016 push @failsuggestion, [ 'origs',
6017 "Maybe orig tarball(s) are not identical to git representation?" ];
6019 if (quiltmode_splitbrain()) {
6020 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6021 $diffbits, \%editedignores,
6022 $splitbrain_cachekey);
6026 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6027 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6029 if (!open P, '>>', ".pc/applied-patches") {
6030 $!==&ENOENT or die $!;
6035 commit_quilty_patch();
6037 if ($mustdeletepc) {
6038 quilt_fixup_delete_pc();
6042 sub quilt_fixup_editor () {
6043 my $descfn = $ENV{$fakeeditorenv};
6044 my $editing = $ARGV[$#ARGV];
6045 open I1, '<', $descfn or die "$descfn: $!";
6046 open I2, '<', $editing or die "$editing: $!";
6047 unlink $editing or die "$editing: $!";
6048 open O, '>', $editing or die "$editing: $!";
6049 while (<I1>) { print O or die $!; } I1->error and die $!;
6052 $copying ||= m/^\-\-\- /;
6053 next unless $copying;
6056 I2->error and die $!;
6061 sub maybe_apply_patches_dirtily () {
6062 return unless $quilt_mode =~ m/gbp|unapplied/;
6063 print STDERR <<END or die $!;
6065 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6066 dgit: Have to apply the patches - making the tree dirty.
6067 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6070 $patches_applied_dirtily = 01;
6071 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6072 runcmd qw(dpkg-source --before-build .);
6075 sub maybe_unapply_patches_again () {
6076 progress "dgit: Unapplying patches again to tidy up the tree."
6077 if $patches_applied_dirtily;
6078 runcmd qw(dpkg-source --after-build .)
6079 if $patches_applied_dirtily & 01;
6081 if $patches_applied_dirtily & 02;
6082 $patches_applied_dirtily = 0;
6085 #----- other building -----
6087 our $clean_using_builder;
6088 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6089 # clean the tree before building (perhaps invoked indirectly by
6090 # whatever we are using to run the build), rather than separately
6091 # and explicitly by us.
6094 return if $clean_using_builder;
6095 if ($cleanmode eq 'dpkg-source') {
6096 maybe_apply_patches_dirtily();
6097 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6098 } elsif ($cleanmode eq 'dpkg-source-d') {
6099 maybe_apply_patches_dirtily();
6100 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6101 } elsif ($cleanmode eq 'git') {
6102 runcmd_ordryrun_local @git, qw(clean -xdf);
6103 } elsif ($cleanmode eq 'git-ff') {
6104 runcmd_ordryrun_local @git, qw(clean -xdff);
6105 } elsif ($cleanmode eq 'check') {
6106 my $leftovers = cmdoutput @git, qw(clean -xdn);
6107 if (length $leftovers) {
6108 print STDERR $leftovers, "\n" or die $!;
6109 fail "tree contains uncommitted files and --clean=check specified";
6111 } elsif ($cleanmode eq 'none') {
6118 badusage "clean takes no additional arguments" if @ARGV;
6121 maybe_unapply_patches_again();
6124 # return values from massage_dbp_args are one or both of these flags
6125 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6126 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6128 sub build_or_push_prep_early () {
6129 our $build_or_push_prep_early_done //= 0;
6130 return if $build_or_push_prep_early_done++;
6131 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6132 my $clogp = parsechangelog();
6133 $isuite = getfield $clogp, 'Distribution';
6134 $package = getfield $clogp, 'Source';
6135 $version = getfield $clogp, 'Version';
6136 $dscfn = dscfn($version);
6139 sub build_prep_early () {
6140 build_or_push_prep_early();
6145 sub build_prep ($) {
6148 # clean the tree if we're trying to include dirty changes in the
6149 # source package, or we are running the builder in $maindir
6150 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6151 build_maybe_quilt_fixup();
6153 my $pat = changespat $version;
6154 foreach my $f (glob "$buildproductsdir/$pat") {
6156 unlink $f or fail "remove old changes file $f: $!";
6158 progress "would remove $f";
6164 sub changesopts_initial () {
6165 my @opts =@changesopts[1..$#changesopts];
6168 sub changesopts_version () {
6169 if (!defined $changes_since_version) {
6172 @vsns = archive_query('archive_query');
6173 my @quirk = access_quirk();
6174 if ($quirk[0] eq 'backports') {
6175 local $isuite = $quirk[2];
6177 canonicalise_suite();
6178 push @vsns, archive_query('archive_query');
6184 "archive query failed (queried because --since-version not specified)";
6187 @vsns = map { $_->[0] } @vsns;
6188 @vsns = sort { -version_compare($a, $b) } @vsns;
6189 $changes_since_version = $vsns[0];
6190 progress "changelog will contain changes since $vsns[0]";
6192 $changes_since_version = '_';
6193 progress "package seems new, not specifying -v<version>";
6196 if ($changes_since_version ne '_') {
6197 return ("-v$changes_since_version");
6203 sub changesopts () {
6204 return (changesopts_initial(), changesopts_version());
6207 sub massage_dbp_args ($;$) {
6208 my ($cmd,$xargs) = @_;
6209 # Since we split the source build out so we can do strange things
6210 # to it, massage the arguments to dpkg-buildpackage so that the
6211 # main build doessn't build source (or add an argument to stop it
6212 # building source by default).
6213 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6214 # -nc has the side effect of specifying -b if nothing else specified
6215 # and some combinations of -S, -b, et al, are errors, rather than
6216 # later simply overriding earlie. So we need to:
6217 # - search the command line for these options
6218 # - pick the last one
6219 # - perhaps add our own as a default
6220 # - perhaps adjust it to the corresponding non-source-building version
6222 foreach my $l ($cmd, $xargs) {
6224 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6227 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6228 my $r = WANTSRC_BUILDER;
6229 printdebug "massage split $dmode.\n";
6230 $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6231 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6232 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6234 printdebug "massage done $r $dmode.\n";
6236 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6242 my $wasdir = must_getcwd();
6243 changedir $buildproductsdir;
6248 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6249 sub postbuild_mergechanges ($) {
6250 my ($msg_if_onlyone) = @_;
6251 # If there is only one .changes file, fail with $msg_if_onlyone,
6252 # or if that is undef, be a no-op.
6253 # Returns the changes file to report to the user.
6254 my $pat = changespat $version;
6255 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6256 @changesfiles = sort {
6257 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6261 if (@changesfiles==1) {
6262 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6263 only one changes file from build (@changesfiles)
6265 $result = $changesfiles[0];
6266 } elsif (@changesfiles==2) {
6267 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6268 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6269 fail "$l found in binaries changes file $binchanges"
6272 runcmd_ordryrun_local @mergechanges, @changesfiles;
6273 my $multichanges = changespat $version,'multi';
6275 stat_exists $multichanges or fail "$multichanges: $!";
6276 foreach my $cf (glob $pat) {
6277 next if $cf eq $multichanges;
6278 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6281 $result = $multichanges;
6283 fail "wrong number of different changes files (@changesfiles)";
6285 printdone "build successful, results in $result\n" or die $!;
6288 sub midbuild_checkchanges () {
6289 my $pat = changespat $version;
6290 return if $rmchanges;
6291 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6293 $_ ne changespat $version,'source' and
6294 $_ ne changespat $version,'multi'
6297 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6298 Suggest you delete @unwanted.
6303 sub midbuild_checkchanges_vanilla ($) {
6305 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6308 sub postbuild_mergechanges_vanilla ($) {
6310 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6312 postbuild_mergechanges(undef);
6315 printdone "build successful\n";
6321 $buildproductsdir eq '..' or print STDERR <<END;
6322 $us: warning: build-products-dir set, but not supported by dgit build
6323 $us: warning: things may go wrong or files may go to the wrong place
6325 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6326 my $wantsrc = massage_dbp_args \@dbp;
6327 build_prep($wantsrc);
6328 if ($wantsrc & WANTSRC_SOURCE) {
6330 midbuild_checkchanges_vanilla $wantsrc;
6332 if ($wantsrc & WANTSRC_BUILDER) {
6333 push @dbp, changesopts_version();
6334 maybe_apply_patches_dirtily();
6335 runcmd_ordryrun_local @dbp;
6337 maybe_unapply_patches_again();
6338 postbuild_mergechanges_vanilla $wantsrc;
6342 $quilt_mode //= 'gbp';
6348 # gbp can make .origs out of thin air. In my tests it does this
6349 # even for a 1.0 format package, with no origs present. So I
6350 # guess it keys off just the version number. We don't know
6351 # exactly what .origs ought to exist, but let's assume that we
6352 # should run gbp if: the version has an upstream part and the main
6354 my $upstreamversion = upstreamversion $version;
6355 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6356 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6358 if ($gbp_make_orig) {
6360 $cleanmode = 'none'; # don't do it again
6363 my @dbp = @dpkgbuildpackage;
6365 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6367 if (!length $gbp_build[0]) {
6368 if (length executable_on_path('git-buildpackage')) {
6369 $gbp_build[0] = qw(git-buildpackage);
6371 $gbp_build[0] = 'gbp buildpackage';
6374 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6376 push @cmd, (qw(-us -uc --git-no-sign-tags),
6377 "--git-builder=".(shellquote @dbp));
6379 if ($gbp_make_orig) {
6380 my $priv = dgit_privdir();
6381 my $ok = "$priv/origs-gen-ok";
6382 unlink $ok or $!==&ENOENT or die $!;
6383 my @origs_cmd = @cmd;
6384 push @origs_cmd, qw(--git-cleaner=true);
6385 push @origs_cmd, "--git-prebuild=".
6386 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6387 push @origs_cmd, @ARGV;
6389 debugcmd @origs_cmd;
6391 do { local $!; stat_exists $ok; }
6392 or failedcmd @origs_cmd;
6394 dryrun_report @origs_cmd;
6398 build_prep($wantsrc);
6399 if ($wantsrc & WANTSRC_SOURCE) {
6401 midbuild_checkchanges_vanilla $wantsrc;
6403 if (!$clean_using_builder) {
6404 push @cmd, '--git-cleaner=true';
6407 maybe_unapply_patches_again();
6408 if ($wantsrc & WANTSRC_BUILDER) {
6409 push @cmd, changesopts();
6410 runcmd_ordryrun_local @cmd, @ARGV;
6412 postbuild_mergechanges_vanilla $wantsrc;
6414 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6416 sub building_source_in_playtree {
6417 # If $includedirty, we have to build the source package from the
6418 # working tree, not a playtree, so that uncommitted changes are
6419 # included (copying or hardlinking them into the playtree could
6422 # Note that if we are building a source package in split brain
6423 # mode we do not support including uncommitted changes, because
6424 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6425 # building a source package)) => !$includedirty
6426 return !$includedirty;
6430 $sourcechanges = changespat $version,'source';
6432 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6433 or fail "remove $sourcechanges: $!";
6435 my @cmd = (@dpkgsource, qw(-b --));
6437 if (building_source_in_playtree()) {
6439 my $headref = git_rev_parse('HEAD');
6440 # If we are in split brain, there is already a playtree with
6441 # the thing we should package into a .dsc (thanks to quilt
6442 # fixup). If not, make a playtree
6443 prep_ud() unless $split_brain;
6444 changedir $playground;
6445 unless ($split_brain) {
6446 my $upstreamversion = upstreamversion $version;
6447 unpack_playtree_linkorigs($upstreamversion, sub { });
6448 unpack_playtree_mkwork($headref);
6452 $leafdir = basename $maindir;
6455 runcmd_ordryrun_local @cmd, $leafdir;
6458 runcmd_ordryrun_local qw(sh -ec),
6459 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6460 @dpkggenchanges, qw(-S), changesopts();
6463 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6464 $dsc = parsecontrol($dscfn, "source package");
6468 printdebug " renaming ($why) $l\n";
6469 rename "$l", bpd_abs()."/$l"
6470 or fail "put in place new built file ($l): $!";
6472 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6473 $l =~ m/\S+$/ or next;
6476 $mv->('dsc', $dscfn);
6477 $mv->('changes', $sourcechanges);
6482 sub cmd_build_source {
6483 badusage "build-source takes no additional arguments" if @ARGV;
6484 build_prep(WANTSRC_SOURCE);
6486 maybe_unapply_patches_again();
6487 printdone "source built, results in $dscfn and $sourcechanges";
6490 sub cmd_push_source {
6492 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6493 "sense with push-source!" if $includedirty;
6494 build_maybe_quilt_fixup();
6496 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6497 "source changes file");
6498 unless (test_source_only_changes($changes)) {
6499 fail "user-specified changes file is not source-only";
6502 # Building a source package is very fast, so just do it
6504 die "er, patches are applied dirtily but shouldn't be.."
6505 if $patches_applied_dirtily;
6506 $changesfile = $sourcechanges;
6511 sub binary_builder {
6512 my ($bbuilder, $pbmc_msg, @args) = @_;
6513 build_prep(WANTSRC_SOURCE);
6515 midbuild_checkchanges();
6518 stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
6519 stat_exists $sourcechanges
6520 or fail "$sourcechanges (in build products dir): $!";
6522 runcmd_ordryrun_local @$bbuilder, @args;
6524 maybe_unapply_patches_again();
6526 postbuild_mergechanges($pbmc_msg);
6532 binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
6533 perhaps you need to pass -A ? (sbuild's default is to build only
6534 arch-specific binaries; dgit 1.4 used to override that.)
6539 my ($pbuilder) = @_;
6541 # @ARGV is allowed to contain only things that should be passed to
6542 # pbuilder under debbuildopts; just massage those
6543 my $wantsrc = massage_dbp_args \@ARGV;
6544 fail "you asked for a builder but your debbuildopts didn't ask for".
6545 " any binaries -- is this really what you meant?"
6546 unless $wantsrc & WANTSRC_BUILDER;
6547 fail "we must build a .dsc to pass to the builder but your debbuiltopts".
6548 " forbids the building of a source package; cannot continue"
6549 unless $wantsrc & WANTSRC_SOURCE;
6550 # We do not want to include the verb "build" in @pbuilder because
6551 # the user can customise @pbuilder and they shouldn't be required
6552 # to include "build" in their customised value. However, if the
6553 # user passes any additional args to pbuilder using the dgit
6554 # option --pbuilder:foo, such args need to come after the "build"
6555 # verb. opts_opt_multi_cmd does all of that.
6556 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6557 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6562 pbuilder(\@pbuilder);
6565 sub cmd_cowbuilder {
6566 pbuilder(\@cowbuilder);
6569 sub cmd_quilt_fixup {
6570 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6573 build_maybe_quilt_fixup();
6576 sub cmd_print_unapplied_treeish {
6577 badusage "incorrect arguments to dgit print-unapplied-treeish" if @ARGV;
6578 my $headref = git_rev_parse('HEAD');
6579 my $clogp = commit_getclogp $headref;
6580 $package = getfield $clogp, 'Source';
6581 $version = getfield $clogp, 'Version';
6582 $isuite = getfield $clogp, 'Distribution';
6583 $csuite = $isuite; # we want this to be offline!
6587 changedir $playground;
6588 my $uv = upstreamversion $version;
6589 quilt_make_fake_dsc($uv);
6590 my $u = quilt_fakedsc2unapplied($headref, $uv);
6591 print $u, "\n" or die $!;
6594 sub import_dsc_result {
6595 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6596 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6598 check_gitattrs($newhash, "source tree");
6600 progress "dgit: import-dsc: $what_msg";
6603 sub cmd_import_dsc {
6607 last unless $ARGV[0] =~ m/^-/;
6610 if (m/^--require-valid-signature$/) {
6613 badusage "unknown dgit import-dsc sub-option \`$_'";
6617 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6618 my ($dscfn, $dstbranch) = @ARGV;
6620 badusage "dry run makes no sense with import-dsc" unless act_local();
6622 my $force = $dstbranch =~ s/^\+// ? +1 :
6623 $dstbranch =~ s/^\.\.// ? -1 :
6625 my $info = $force ? " $&" : '';
6626 $info = "$dscfn$info";
6628 my $specbranch = $dstbranch;
6629 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6630 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6632 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6633 my $chead = cmdoutput_errok @symcmd;
6634 defined $chead or $?==256 or failedcmd @symcmd;
6636 fail "$dstbranch is checked out - will not update it"
6637 if defined $chead and $chead eq $dstbranch;
6639 my $oldhash = git_get_ref $dstbranch;
6641 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6642 $dscdata = do { local $/ = undef; <D>; };
6643 D->error and fail "read $dscfn: $!";
6646 # we don't normally need this so import it here
6647 use Dpkg::Source::Package;
6648 my $dp = new Dpkg::Source::Package filename => $dscfn,
6649 require_valid_signature => $needsig;
6651 local $SIG{__WARN__} = sub {
6653 return unless $needsig;
6654 fail "import-dsc signature check failed";
6656 if (!$dp->is_signed()) {
6657 warn "$us: warning: importing unsigned .dsc\n";
6659 my $r = $dp->check_signature();
6660 die "->check_signature => $r" if $needsig && $r;
6666 $package = getfield $dsc, 'Source';
6668 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6669 unless forceing [qw(import-dsc-with-dgit-field)];
6670 parse_dsc_field_def_dsc_distro();
6672 $isuite = 'DGIT-IMPORT-DSC';
6673 $idistro //= $dsc_distro;
6677 if (defined $dsc_hash) {
6678 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6679 resolve_dsc_field_commit undef, undef;
6681 if (defined $dsc_hash) {
6682 my @cmd = (qw(sh -ec),
6683 "echo $dsc_hash | git cat-file --batch-check");
6684 my $objgot = cmdoutput @cmd;
6685 if ($objgot =~ m#^\w+ missing\b#) {
6687 .dsc contains Dgit field referring to object $dsc_hash
6688 Your git tree does not have that object. Try `git fetch' from a
6689 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6692 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6694 progress "Not fast forward, forced update.";
6696 fail "Not fast forward to $dsc_hash";
6699 import_dsc_result $dstbranch, $dsc_hash,
6700 "dgit import-dsc (Dgit): $info",
6701 "updated git ref $dstbranch";
6706 Branch $dstbranch already exists
6707 Specify ..$specbranch for a pseudo-merge, binding in existing history
6708 Specify +$specbranch to overwrite, discarding existing history
6710 if $oldhash && !$force;
6712 my @dfi = dsc_files_info();
6713 foreach my $fi (@dfi) {
6714 my $f = $fi->{Filename};
6715 my $here = "$buildproductsdir/$f";
6718 fail "lstat $here works but stat gives $! !";
6720 fail "stat $here: $!" unless $! == ENOENT;
6722 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6724 } elsif ($dscfn =~ m#^/#) {
6727 fail "cannot import $dscfn which seems to be inside working tree!";
6729 $there =~ s#/+[^/]+$## or
6730 fail "import $dscfn requires ../$f, but it does not exist";
6732 my $test = $there =~ m{^/} ? $there : "../$there";
6733 stat $test or fail "import $dscfn requires $test, but: $!";
6734 symlink $there, $here or fail "symlink $there to $here: $!";
6735 progress "made symlink $here -> $there";
6736 # print STDERR Dumper($fi);
6738 my @mergeinputs = generate_commits_from_dsc();
6739 die unless @mergeinputs == 1;
6741 my $newhash = $mergeinputs[0]{Commit};
6745 progress "Import, forced update - synthetic orphan git history.";
6746 } elsif ($force < 0) {
6747 progress "Import, merging.";
6748 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6749 my $version = getfield $dsc, 'Version';
6750 my $clogp = commit_getclogp $newhash;
6751 my $authline = clogp_authline $clogp;
6752 $newhash = make_commit_text <<END;
6759 Merge $package ($version) import into $dstbranch
6762 die; # caught earlier
6766 import_dsc_result $dstbranch, $newhash,
6767 "dgit import-dsc: $info",
6768 "results are in in git ref $dstbranch";
6771 sub pre_archive_api_query () {
6772 not_necessarily_a_tree();
6774 sub cmd_archive_api_query {
6775 badusage "need only 1 subpath argument" unless @ARGV==1;
6776 my ($subpath) = @ARGV;
6777 local $isuite = 'DGIT-API-QUERY-CMD';
6778 my @cmd = archive_api_query_cmd($subpath);
6781 exec @cmd or fail "exec curl: $!\n";
6784 sub repos_server_url () {
6785 $package = '_dgit-repos-server';
6786 local $access_forpush = 1;
6787 local $isuite = 'DGIT-REPOS-SERVER';
6788 my $url = access_giturl();
6791 sub pre_clone_dgit_repos_server () {
6792 not_necessarily_a_tree();
6794 sub cmd_clone_dgit_repos_server {
6795 badusage "need destination argument" unless @ARGV==1;
6796 my ($destdir) = @ARGV;
6797 my $url = repos_server_url();
6798 my @cmd = (@git, qw(clone), $url, $destdir);
6800 exec @cmd or fail "exec git clone: $!\n";
6803 sub pre_print_dgit_repos_server_source_url () {
6804 not_necessarily_a_tree();
6806 sub cmd_print_dgit_repos_server_source_url {
6807 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6809 my $url = repos_server_url();
6810 print $url, "\n" or die $!;
6813 sub pre_print_dpkg_source_ignores {
6814 not_necessarily_a_tree();
6816 sub cmd_print_dpkg_source_ignores {
6817 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6819 print "@dpkg_source_ignores\n" or die $!;
6822 sub cmd_setup_mergechangelogs {
6823 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6824 local $isuite = 'DGIT-SETUP-TREE';
6825 setup_mergechangelogs(1);
6828 sub cmd_setup_useremail {
6829 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6830 local $isuite = 'DGIT-SETUP-TREE';
6834 sub cmd_setup_gitattributes {
6835 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6836 local $isuite = 'DGIT-SETUP-TREE';
6840 sub cmd_setup_new_tree {
6841 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6842 local $isuite = 'DGIT-SETUP-TREE';
6846 #---------- argument parsing and main program ----------
6849 print "dgit version $our_version\n" or die $!;
6853 our (%valopts_long, %valopts_short);
6854 our (%funcopts_long);
6856 our (@modeopt_cfgs);
6858 sub defvalopt ($$$$) {
6859 my ($long,$short,$val_re,$how) = @_;
6860 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6861 $valopts_long{$long} = $oi;
6862 $valopts_short{$short} = $oi;
6863 # $how subref should:
6864 # do whatever assignemnt or thing it likes with $_[0]
6865 # if the option should not be passed on to remote, @rvalopts=()
6866 # or $how can be a scalar ref, meaning simply assign the value
6869 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6870 defvalopt '--distro', '-d', '.+', \$idistro;
6871 defvalopt '', '-k', '.+', \$keyid;
6872 defvalopt '--existing-package','', '.*', \$existing_package;
6873 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6874 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6875 defvalopt '--package', '-p', $package_re, \$package;
6876 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6878 defvalopt '', '-C', '.+', sub {
6879 ($changesfile) = (@_);
6880 if ($changesfile =~ s#^(.*)/##) {
6881 $buildproductsdir = $1;
6885 defvalopt '--initiator-tempdir','','.*', sub {
6886 ($initiator_tempdir) = (@_);
6887 $initiator_tempdir =~ m#^/# or
6888 badusage "--initiator-tempdir must be used specify an".
6889 " absolute, not relative, directory."
6892 sub defoptmodes ($@) {
6893 my ($varref, $cfgkey, $default, %optmap) = @_;
6895 while (my ($opt,$val) = each %optmap) {
6896 $funcopts_long{$opt} = sub { $$varref = $val; };
6897 $permit{$val} = $val;
6899 push @modeopt_cfgs, {
6902 Default => $default,
6907 defoptmodes \$dodep14tag, qw( dep14tag want
6910 --always-dep14tag always );
6915 if (defined $ENV{'DGIT_SSH'}) {
6916 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6917 } elsif (defined $ENV{'GIT_SSH'}) {
6918 @ssh = ($ENV{'GIT_SSH'});
6926 if (!defined $val) {
6927 badusage "$what needs a value" unless @ARGV;
6929 push @rvalopts, $val;
6931 badusage "bad value \`$val' for $what" unless
6932 $val =~ m/^$oi->{Re}$(?!\n)/s;
6933 my $how = $oi->{How};
6934 if (ref($how) eq 'SCALAR') {
6939 push @ropts, @rvalopts;
6943 last unless $ARGV[0] =~ m/^-/;
6947 if (m/^--dry-run$/) {
6950 } elsif (m/^--damp-run$/) {
6953 } elsif (m/^--no-sign$/) {
6956 } elsif (m/^--help$/) {
6958 } elsif (m/^--version$/) {
6960 } elsif (m/^--new$/) {
6963 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6964 ($om = $opts_opt_map{$1}) &&
6968 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6969 !$opts_opt_cmdonly{$1} &&
6970 ($om = $opts_opt_map{$1})) {
6973 } elsif (m/^--(gbp|dpm)$/s) {
6974 push @ropts, "--quilt=$1";
6976 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6979 } elsif (m/^--no-quilt-fixup$/s) {
6981 $quilt_mode = 'nocheck';
6982 } elsif (m/^--no-rm-on-error$/s) {
6985 } elsif (m/^--no-chase-dsc-distro$/s) {
6987 $chase_dsc_distro = 0;
6988 } elsif (m/^--overwrite$/s) {
6990 $overwrite_version = '';
6991 } elsif (m/^--overwrite=(.+)$/s) {
6993 $overwrite_version = $1;
6994 } elsif (m/^--delayed=(\d+)$/s) {
6997 } elsif (my ($k,$v) =
6998 m/^--save-(dgit-view)=(.+)$/s ||
6999 m/^--(dgit-view)-save=(.+)$/s
7002 $v =~ s#^(?!refs/)#refs/heads/#;
7003 $internal_object_save{$k} = $v;
7004 } elsif (m/^--(no-)?rm-old-changes$/s) {
7007 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7009 push @deliberatelies, $&;
7010 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7014 } elsif (m/^--force-/) {
7016 "$us: warning: ignoring unknown force option $_\n";
7018 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7019 # undocumented, for testing
7021 $tagformat_want = [ $1, 'command line', 1 ];
7022 # 1 menas overrides distro configuration
7023 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7024 # undocumented, for testing
7026 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7027 # ^ it's supposed to be an array ref
7028 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7029 $val = $2 ? $' : undef; #';
7030 $valopt->($oi->{Long});
7031 } elsif ($funcopts_long{$_}) {
7033 $funcopts_long{$_}();
7035 badusage "unknown long option \`$_'";
7042 } elsif (s/^-L/-/) {
7045 } elsif (s/^-h/-/) {
7047 } elsif (s/^-D/-/) {
7051 } elsif (s/^-N/-/) {
7056 push @changesopts, $_;
7058 } elsif (s/^-wn$//s) {
7060 $cleanmode = 'none';
7061 } elsif (s/^-wg$//s) {
7064 } elsif (s/^-wgf$//s) {
7066 $cleanmode = 'git-ff';
7067 } elsif (s/^-wd$//s) {
7069 $cleanmode = 'dpkg-source';
7070 } elsif (s/^-wdd$//s) {
7072 $cleanmode = 'dpkg-source-d';
7073 } elsif (s/^-wc$//s) {
7075 $cleanmode = 'check';
7076 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7077 push @git, '-c', $&;
7078 $gitcfgs{cmdline}{$1} = [ $2 ];
7079 } elsif (s/^-c([^=]+)$//s) {
7080 push @git, '-c', $&;
7081 $gitcfgs{cmdline}{$1} = [ 'true' ];
7082 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7084 $val = undef unless length $val;
7085 $valopt->($oi->{Short});
7088 badusage "unknown short option \`$_'";
7095 sub check_env_sanity () {
7096 my $blocked = new POSIX::SigSet;
7097 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7100 foreach my $name (qw(PIPE CHLD)) {
7101 my $signame = "SIG$name";
7102 my $signum = eval "POSIX::$signame" // die;
7103 die "$signame is set to something other than SIG_DFL\n"
7104 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7105 $blocked->ismember($signum) and
7106 die "$signame is blocked\n";
7112 On entry to dgit, $@
7113 This is a bug produced by something in in your execution environment.
7119 sub parseopts_late_defaults () {
7120 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7121 if defined $idistro;
7122 $isuite //= cfg('dgit.default.default-suite');
7124 foreach my $k (keys %opts_opt_map) {
7125 my $om = $opts_opt_map{$k};
7127 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7129 badcfg "cannot set command for $k"
7130 unless length $om->[0];
7134 foreach my $c (access_cfg_cfgs("opts-$k")) {
7136 map { $_ ? @$_ : () }
7137 map { $gitcfgs{$_}{$c} }
7138 reverse @gitcfgsources;
7139 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7140 "\n" if $debuglevel >= 4;
7142 badcfg "cannot configure options for $k"
7143 if $opts_opt_cmdonly{$k};
7144 my $insertpos = $opts_cfg_insertpos{$k};
7145 @$om = ( @$om[0..$insertpos-1],
7147 @$om[$insertpos..$#$om] );
7151 if (!defined $rmchanges) {
7152 local $access_forpush;
7153 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7156 if (!defined $quilt_mode) {
7157 local $access_forpush;
7158 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7159 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7161 $quilt_mode =~ m/^($quilt_modes_re)$/
7162 or badcfg "unknown quilt-mode \`$quilt_mode'";
7166 foreach my $moc (@modeopt_cfgs) {
7167 local $access_forpush;
7168 my $vr = $moc->{Var};
7169 next if defined $$vr;
7170 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7171 my $v = $moc->{Vals}{$$vr};
7172 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7176 fail "dgit: --include-dirty is not supported in split view quilt mode"
7177 if $split_brain && $includedirty;
7179 if (!defined $cleanmode) {
7180 local $access_forpush;
7181 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7182 $cleanmode //= 'dpkg-source';
7184 badcfg "unknown clean-mode \`$cleanmode'" unless
7185 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7188 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7189 $buildproductsdir //= '..';
7190 $bpd_glob = $buildproductsdir;
7191 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7194 if ($ENV{$fakeeditorenv}) {
7196 quilt_fixup_editor();
7202 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7203 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7204 if $dryrun_level == 1;
7206 print STDERR $helpmsg or die $!;
7209 $cmd = $subcommand = shift @ARGV;
7212 my $pre_fn = ${*::}{"pre_$cmd"};
7213 $pre_fn->() if $pre_fn;
7215 record_maindir if $invoked_in_git_tree;
7218 my $fn = ${*::}{"cmd_$cmd"};
7219 $fn or badusage "unknown operation $cmd";