3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2018 Ian Jackson
6 # Copyright (C)2017-2018 Sean Whitton
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
22 use Debian::Dgit::ExitStatus;
23 use Debian::Dgit::I18n;
27 use Debian::Dgit qw(:DEFAULT :playground);
33 use Dpkg::Control::Hash;
35 use File::Temp qw(tempdir);
38 use Dpkg::Compression;
39 use Dpkg::Compression::Process;
45 use List::MoreUtils qw(pairwise);
46 use Text::Glob qw(match_glob);
47 use Fcntl qw(:DEFAULT :flock);
52 our $our_version = 'UNRELEASED'; ###substituted###
53 our $absurdity = undef; ###substituted###
55 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
66 our $dryrun_level = 0;
68 our $buildproductsdir;
71 our $includedirty = 0;
75 our $existing_package = 'dpkg';
77 our $changes_since_version;
79 our $overwrite_version; # undef: not specified; '': check changelog
81 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
83 our %internal_object_save;
84 our $we_are_responder;
85 our $we_are_initiator;
86 our $initiator_tempdir;
87 our $patches_applied_dirtily = 00;
91 our $chase_dsc_distro=1;
93 our %forceopts = map { $_=>0 }
94 qw(unrepresentable unsupported-source-format
95 dsc-changes-mismatch changes-origs-exactly
96 uploading-binaries uploading-source-only
97 import-gitapply-absurd
98 import-gitapply-no-absurd
99 import-dsc-with-dgit-field);
101 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
103 our $suite_re = '[-+.0-9a-z]+';
104 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
106 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
107 our $splitbraincache = 'dgit-intern/quilt-cache';
108 our $rewritemap = 'dgit-rewrite/map';
110 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
112 our (@git) = qw(git);
113 our (@dget) = qw(dget);
114 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
115 our (@dput) = qw(dput);
116 our (@debsign) = qw(debsign);
117 our (@gpg) = qw(gpg);
118 our (@sbuild) = (qw(sbuild --no-source));
120 our (@dgit) = qw(dgit);
121 our (@git_debrebase) = qw(git-debrebase);
122 our (@aptget) = qw(apt-get);
123 our (@aptcache) = qw(apt-cache);
124 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
125 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
126 our (@dpkggenchanges) = qw(dpkg-genchanges);
127 our (@mergechanges) = qw(mergechanges -f);
128 our (@gbp_build) = ('');
129 our (@gbp_pq) = ('gbp pq');
130 our (@changesopts) = ('');
131 our (@pbuilder) = ("sudo -E pbuilder");
132 our (@cowbuilder) = ("sudo -E cowbuilder");
134 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
137 'debsign' => \@debsign,
139 'sbuild' => \@sbuild,
143 'git-debrebase' => \@git_debrebase,
144 'apt-get' => \@aptget,
145 'apt-cache' => \@aptcache,
146 'dpkg-source' => \@dpkgsource,
147 'dpkg-buildpackage' => \@dpkgbuildpackage,
148 'dpkg-genchanges' => \@dpkggenchanges,
149 'gbp-build' => \@gbp_build,
150 'gbp-pq' => \@gbp_pq,
151 'ch' => \@changesopts,
152 'mergechanges' => \@mergechanges,
153 'pbuilder' => \@pbuilder,
154 'cowbuilder' => \@cowbuilder);
156 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
157 our %opts_cfg_insertpos = map {
159 scalar @{ $opts_opt_map{$_} }
160 } keys %opts_opt_map;
162 sub parseopts_late_defaults();
163 sub setup_gitattrs(;$);
164 sub check_gitattrs($$);
171 our $supplementary_message = '';
172 our $split_brain = 0;
176 return unless forkcheck_mainprocess();
177 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
180 our $remotename = 'dgit';
181 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
185 if (!defined $absurdity) {
187 $absurdity =~ s{/[^/]+$}{/absurd} or die;
191 my ($v,$distro) = @_;
192 return $tagformatfn->($v, $distro);
195 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
197 sub lbranch () { return "$branchprefix/$csuite"; }
198 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
199 sub lref () { return "refs/heads/".lbranch(); }
200 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
201 sub rrref () { return server_ref($csuite); }
204 my ($vsn, $sfx) = @_;
205 return &source_file_leafname($package, $vsn, $sfx);
207 sub is_orig_file_of_vsn ($$) {
208 my ($f, $upstreamvsn) = @_;
209 return is_orig_file_of_p_v($f, $package, $upstreamvsn);
214 return srcfn($vsn,".dsc");
217 sub changespat ($;$) {
218 my ($vsn, $arch) = @_;
219 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
228 return unless forkcheck_mainprocess();
229 foreach my $f (@end) {
231 print STDERR "$us: cleanup: $@" if length $@;
235 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
237 sub forceable_fail ($$) {
238 my ($forceoptsl, $msg) = @_;
239 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
240 print STDERR "warning: overriding problem due to --force:\n". $msg;
244 my ($forceoptsl) = @_;
245 my @got = grep { $forceopts{$_} } @$forceoptsl;
246 return 0 unless @got;
248 "warning: skipping checks or functionality due to --force-$got[0]\n";
251 sub no_such_package () {
252 print STDERR "$us: package $package does not exist in suite $isuite\n";
256 sub deliberately ($) {
258 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
261 sub deliberately_not_fast_forward () {
262 foreach (qw(not-fast-forward fresh-repo)) {
263 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
267 sub quiltmode_splitbrain () {
268 $quilt_mode =~ m/gbp|dpm|unapplied/;
271 sub opts_opt_multi_cmd {
274 push @cmd, split /\s+/, shift @_;
281 return opts_opt_multi_cmd [], @gbp_pq;
284 sub dgit_privdir () {
285 our $dgit_privdir_made //= ensure_a_playground 'dgit';
289 my $r = $buildproductsdir;
290 $r = "$maindir/$r" unless $r =~ m{^/};
294 sub get_tree_of_commit ($) {
295 my ($commitish) = @_;
296 my $cdata = cmdoutput @git, qw(cat-file commit), $commitish;
297 $cdata =~ m/\n\n/; $cdata = $`;
298 $cdata =~ m/^tree (\w+)$/m or confess "cdata $cdata ?";
302 sub branch_gdr_info ($$) {
303 my ($symref, $head) = @_;
304 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
305 gdr_ffq_prev_branchinfo($symref);
306 return () unless $status eq 'branch';
307 $ffq_prev = git_get_ref $ffq_prev;
308 $gdrlast = git_get_ref $gdrlast;
309 $gdrlast &&= is_fast_fwd $gdrlast, $head;
310 return ($ffq_prev, $gdrlast);
313 sub branch_is_gdr_unstitched_ff ($$$) {
314 my ($symref, $head, $ancestor) = @_;
315 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
316 return 0 unless $ffq_prev;
317 return 0 unless !defined $ancestor or is_fast_fwd $ancestor, $ffq_prev;
321 sub branch_is_gdr ($) {
323 # This is quite like git-debrebase's keycommits.
324 # We have our own implementation because:
325 # - our algorighm can do fewer tests so is faster
326 # - it saves testing to see if gdr is installed
328 # NB we use this jsut for deciding whether to run gdr make-patches
329 # Before reusing this algorithm for somthing else, its
330 # suitability should be reconsidered.
333 local $Debian::Dgit::debugcmd_when_debuglevel = 3;
334 printdebug "branch_is_gdr $head...\n";
335 my $get_patches = sub {
336 my $t = git_cat_file "$_[0]:debian/patches", [qw(missing tree)];
339 my $tip_patches = $get_patches->($head);
342 my $cdata = git_cat_file $walk, 'commit';
343 my ($hdrs,$msg) = $cdata =~ m{\n\n} ? ($`,$') : ($cdata,'');
344 if ($msg =~ m{^\[git-debrebase\ (
345 anchor | changelog | make-patches |
346 merged-breakwater | pseudomerge
348 # no need to analyse this - it's sufficient
349 # (gdr classifications: Anchor, MergedBreakwaters)
350 # (made by gdr: Pseudomerge, Changelog)
351 printdebug "branch_is_gdr $walk gdr $1 YES\n";
354 my @parents = ($hdrs =~ m/^parent (\w+)$/gm);
356 my $walk_tree = get_tree_of_commit $walk;
357 foreach my $p (@parents) {
358 my $p_tree = get_tree_of_commit $p;
359 if ($p_tree eq $walk_tree) { # pseudomerge contriburor
360 # (gdr classification: Pseudomerge; not made by gdr)
361 printdebug "branch_is_gdr $walk unmarked pseudomerge\n"
367 # some other non-gdr merge
368 # (gdr classification: VanillaMerge, DgitImportUnpatched, ?)
369 printdebug "branch_is_gdr $walk ?-2-merge NO\n";
373 # (gdr classification: ?)
374 printdebug "branch_is_gdr $walk ?-octopus NO\n";
377 if ($get_patches->($walk) ne $tip_patches) {
378 # Our parent added, removed, or edited patches, and wasn't
379 # a gdr make-patches commit. gdr make-patches probably
380 # won't do that well, then.
381 # (gdr classification of parent: AddPatches or ?)
382 printdebug "branch_is_gdr $walk ?-patches NO\n";
385 if ($tip_patches eq '' and
386 !defined git_cat_file "$walk:debian") {
387 # (gdr classification of parent: BreakwaterStart
388 printdebug "branch_is_gdr $walk unmarked BreakwaterStart YES\n";
391 # (gdr classification: Upstream Packaging Mixed Changelog)
392 printdebug "branch_is_gdr $walk plain\n"
398 #---------- remote protocol support, common ----------
400 # remote push initiator/responder protocol:
401 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
402 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
403 # < dgit-remote-push-ready <actual-proto-vsn>
410 # > supplementary-message NBYTES # $protovsn >= 3
415 # > file parsed-changelog
416 # [indicates that output of dpkg-parsechangelog follows]
417 # > data-block NBYTES
418 # > [NBYTES bytes of data (no newline)]
419 # [maybe some more blocks]
428 # > param head DGIT-VIEW-HEAD
429 # > param csuite SUITE
430 # > param tagformat old|new
431 # > param maint-view MAINT-VIEW-HEAD
433 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
434 # > file buildinfo # for buildinfos to sign
436 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
437 # # goes into tag, for replay prevention
440 # [indicates that signed tag is wanted]
441 # < data-block NBYTES
442 # < [NBYTES bytes of data (no newline)]
443 # [maybe some more blocks]
447 # > want signed-dsc-changes
448 # < data-block NBYTES [transfer of signed dsc]
450 # < data-block NBYTES [transfer of signed changes]
452 # < data-block NBYTES [transfer of each signed buildinfo
453 # [etc] same number and order as "file buildinfo"]
461 sub i_child_report () {
462 # Sees if our child has died, and reap it if so. Returns a string
463 # describing how it died if it failed, or undef otherwise.
464 return undef unless $i_child_pid;
465 my $got = waitpid $i_child_pid, WNOHANG;
466 return undef if $got <= 0;
467 die unless $got == $i_child_pid;
468 $i_child_pid = undef;
469 return undef unless $?;
470 return "build host child ".waitstatusmsg();
475 fail "connection lost: $!" if $fh->error;
476 fail "protocol violation; $m not expected";
479 sub badproto_badread ($$) {
481 fail "connection lost: $!" if $!;
482 my $report = i_child_report();
483 fail $report if defined $report;
484 badproto $fh, "eof (reading $wh)";
487 sub protocol_expect (&$) {
488 my ($match, $fh) = @_;
491 defined && chomp or badproto_badread $fh, "protocol message";
499 badproto $fh, "\`$_'";
502 sub protocol_send_file ($$) {
503 my ($fh, $ourfn) = @_;
504 open PF, "<", $ourfn or die "$ourfn: $!";
507 my $got = read PF, $d, 65536;
508 die "$ourfn: $!" unless defined $got;
510 print $fh "data-block ".length($d)."\n" or die $!;
511 print $fh $d or die $!;
513 PF->error and die "$ourfn $!";
514 print $fh "data-end\n" or die $!;
518 sub protocol_read_bytes ($$) {
519 my ($fh, $nbytes) = @_;
520 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
522 my $got = read $fh, $d, $nbytes;
523 $got==$nbytes or badproto_badread $fh, "data block";
527 sub protocol_receive_file ($$) {
528 my ($fh, $ourfn) = @_;
529 printdebug "() $ourfn\n";
530 open PF, ">", $ourfn or die "$ourfn: $!";
532 my ($y,$l) = protocol_expect {
533 m/^data-block (.*)$/ ? (1,$1) :
534 m/^data-end$/ ? (0,) :
538 my $d = protocol_read_bytes $fh, $l;
539 print PF $d or die $!;
544 #---------- remote protocol support, responder ----------
546 sub responder_send_command ($) {
548 return unless $we_are_responder;
549 # called even without $we_are_responder
550 printdebug ">> $command\n";
551 print PO $command, "\n" or die $!;
554 sub responder_send_file ($$) {
555 my ($keyword, $ourfn) = @_;
556 return unless $we_are_responder;
557 printdebug "]] $keyword $ourfn\n";
558 responder_send_command "file $keyword";
559 protocol_send_file \*PO, $ourfn;
562 sub responder_receive_files ($@) {
563 my ($keyword, @ourfns) = @_;
564 die unless $we_are_responder;
565 printdebug "[[ $keyword @ourfns\n";
566 responder_send_command "want $keyword";
567 foreach my $fn (@ourfns) {
568 protocol_receive_file \*PI, $fn;
571 protocol_expect { m/^files-end$/ } \*PI;
574 #---------- remote protocol support, initiator ----------
576 sub initiator_expect (&) {
578 protocol_expect { &$match } \*RO;
581 #---------- end remote code ----------
584 if ($we_are_responder) {
586 responder_send_command "progress ".length($m) or die $!;
587 print PO $m or die $!;
597 $ua = LWP::UserAgent->new();
601 progress "downloading $what...";
602 my $r = $ua->get(@_) or die $!;
603 return undef if $r->code == 404;
604 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
605 return $r->decoded_content(charset => 'none');
608 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
610 sub act_local () { return $dryrun_level <= 1; }
611 sub act_scary () { return !$dryrun_level; }
614 if (!$dryrun_level) {
615 progress "$us ok: @_";
617 progress "would be ok: @_ (but dry run only)";
622 printcmd(\*STDERR,$debugprefix."#",@_);
625 sub runcmd_ordryrun {
633 sub runcmd_ordryrun_local {
641 our $helpmsg = <<END;
643 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
644 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
645 dgit [dgit-opts] build [dpkg-buildpackage-opts]
646 dgit [dgit-opts] sbuild [sbuild-opts]
647 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
648 dgit [dgit-opts] push [dgit-opts] [suite]
649 dgit [dgit-opts] push-source [dgit-opts] [suite]
650 dgit [dgit-opts] rpush build-host:build-dir ...
651 important dgit options:
652 -k<keyid> sign tag and package with <keyid> instead of default
653 --dry-run -n do not change anything, but go through the motions
654 --damp-run -L like --dry-run but make local changes, without signing
655 --new -N allow introducing a new package
656 --debug -D increase debug level
657 -c<name>=<value> set git config option (used directly by dgit too)
660 our $later_warning_msg = <<END;
661 Perhaps the upload is stuck in incoming. Using the version from git.
665 print STDERR "$us: @_\n", $helpmsg or die $!;
670 @ARGV or badusage "too few arguments";
671 return scalar shift @ARGV;
675 not_necessarily_a_tree();
678 print $helpmsg or die $!;
682 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
684 our %defcfg = ('dgit.default.distro' => 'debian',
685 'dgit.default.default-suite' => 'unstable',
686 'dgit.default.old-dsc-distro' => 'debian',
687 'dgit-suite.*-security.distro' => 'debian-security',
688 'dgit.default.username' => '',
689 'dgit.default.archive-query-default-component' => 'main',
690 'dgit.default.ssh' => 'ssh',
691 'dgit.default.archive-query' => 'madison:',
692 'dgit.default.sshpsql-dbname' => 'service=projectb',
693 'dgit.default.aptget-components' => 'main',
694 'dgit.default.dgit-tag-format' => 'new,old,maint',
695 'dgit.default.source-only-uploads' => 'ok',
696 'dgit.dsc-url-proto-ok.http' => 'true',
697 'dgit.dsc-url-proto-ok.https' => 'true',
698 'dgit.dsc-url-proto-ok.git' => 'true',
699 'dgit.vcs-git.suites', => 'sid', # ;-separated
700 'dgit.default.dsc-url-proto-ok' => 'false',
701 # old means "repo server accepts pushes with old dgit tags"
702 # new means "repo server accepts pushes with new dgit tags"
703 # maint means "repo server accepts split brain pushes"
704 # hist means "repo server may have old pushes without new tag"
705 # ("hist" is implied by "old")
706 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
707 'dgit-distro.debian.git-check' => 'url',
708 'dgit-distro.debian.git-check-suffix' => '/info/refs',
709 'dgit-distro.debian.new-private-pushers' => 't',
710 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
711 'dgit-distro.debian/push.git-url' => '',
712 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
713 'dgit-distro.debian/push.git-user-force' => 'dgit',
714 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
715 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
716 'dgit-distro.debian/push.git-create' => 'true',
717 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
718 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
719 # 'dgit-distro.debian.archive-query-tls-key',
720 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
721 # ^ this does not work because curl is broken nowadays
722 # Fixing #790093 properly will involve providing providing the key
723 # in some pacagke and maybe updating these paths.
725 # 'dgit-distro.debian.archive-query-tls-curl-args',
726 # '--ca-path=/etc/ssl/ca-debian',
727 # ^ this is a workaround but works (only) on DSA-administered machines
728 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
729 'dgit-distro.debian.git-url-suffix' => '',
730 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
731 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
732 'dgit-distro.debian-security.archive-query' => 'aptget:',
733 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
734 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
735 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
736 'dgit-distro.debian-security.nominal-distro' => 'debian',
737 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
738 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
739 'dgit-distro.ubuntu.git-check' => 'false',
740 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
741 'dgit-distro.test-dummy.ssh' => "$td/ssh",
742 'dgit-distro.test-dummy.username' => "alice",
743 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
744 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
745 'dgit-distro.test-dummy.git-url' => "$td/git",
746 'dgit-distro.test-dummy.git-host' => "git",
747 'dgit-distro.test-dummy.git-path' => "$td/git",
748 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
749 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
750 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
751 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
755 our @gitcfgsources = qw(cmdline local global system);
756 our $invoked_in_git_tree = 1;
758 sub git_slurp_config () {
759 # This algoritm is a bit subtle, but this is needed so that for
760 # options which we want to be single-valued, we allow the
761 # different config sources to override properly. See #835858.
762 foreach my $src (@gitcfgsources) {
763 next if $src eq 'cmdline';
764 # we do this ourselves since git doesn't handle it
766 $gitcfgs{$src} = git_slurp_config_src $src;
770 sub git_get_config ($) {
772 foreach my $src (@gitcfgsources) {
773 my $l = $gitcfgs{$src}{$c};
774 confess "internal error ($l $c)" if $l && !ref $l;
775 printdebug"C $c ".(defined $l ?
776 join " ", map { messagequote "'$_'" } @$l :
780 @$l==1 or badcfg "multiple values for $c".
781 " (in $src git config)" if @$l > 1;
789 return undef if $c =~ /RETURN-UNDEF/;
790 printdebug "C? $c\n" if $debuglevel >= 5;
791 my $v = git_get_config($c);
792 return $v if defined $v;
793 my $dv = $defcfg{$c};
795 printdebug "CD $c $dv\n" if $debuglevel >= 4;
799 badcfg "need value for one of: @_\n".
800 "$us: distro or suite appears not to be (properly) supported";
803 sub not_necessarily_a_tree () {
804 # needs to be called from pre_*
805 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
806 $invoked_in_git_tree = 0;
809 sub access_basedistro__noalias () {
810 if (defined $idistro) {
813 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
814 return $def if defined $def;
815 foreach my $src (@gitcfgsources, 'internal') {
816 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
818 foreach my $k (keys %$kl) {
819 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
821 next unless match_glob $dpat, $isuite;
825 return cfg("dgit.default.distro");
829 sub access_basedistro () {
830 my $noalias = access_basedistro__noalias();
831 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
832 return $canon // $noalias;
835 sub access_nomdistro () {
836 my $base = access_basedistro();
837 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
838 $r =~ m/^$distro_re$/ or badcfg
839 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
843 sub access_quirk () {
844 # returns (quirk name, distro to use instead or undef, quirk-specific info)
845 my $basedistro = access_basedistro();
846 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
848 if (defined $backports_quirk) {
849 my $re = $backports_quirk;
850 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
852 $re =~ s/\%/([-0-9a-z_]+)/
853 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
854 if ($isuite =~ m/^$re$/) {
855 return ('backports',"$basedistro-backports",$1);
858 return ('none',undef);
863 sub parse_cfg_bool ($$$) {
864 my ($what,$def,$v) = @_;
867 $v =~ m/^[ty1]/ ? 1 :
868 $v =~ m/^[fn0]/ ? 0 :
869 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
872 sub access_forpush_config () {
873 my $d = access_basedistro();
877 parse_cfg_bool('new-private-pushers', 0,
878 cfg("dgit-distro.$d.new-private-pushers",
881 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
884 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
885 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
886 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
887 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
890 sub access_forpush () {
891 $access_forpush //= access_forpush_config();
892 return $access_forpush;
896 confess 'internal error '.Dumper($access_forpush)," ?" if
897 defined $access_forpush and !$access_forpush;
898 badcfg "pushing but distro is configured readonly"
899 if access_forpush_config() eq '0';
901 $supplementary_message = <<'END' unless $we_are_responder;
902 Push failed, before we got started.
903 You can retry the push, after fixing the problem, if you like.
905 parseopts_late_defaults();
909 parseopts_late_defaults();
912 sub supplementary_message ($) {
914 if (!$we_are_responder) {
915 $supplementary_message = $msg;
917 } elsif ($protovsn >= 3) {
918 responder_send_command "supplementary-message ".length($msg)
920 print PO $msg or die $!;
924 sub access_distros () {
925 # Returns list of distros to try, in order
928 # 0. `instead of' distro name(s) we have been pointed to
929 # 1. the access_quirk distro, if any
930 # 2a. the user's specified distro, or failing that } basedistro
931 # 2b. the distro calculated from the suite }
932 my @l = access_basedistro();
934 my (undef,$quirkdistro) = access_quirk();
935 unshift @l, $quirkdistro;
936 unshift @l, $instead_distro;
937 @l = grep { defined } @l;
939 push @l, access_nomdistro();
941 if (access_forpush()) {
942 @l = map { ("$_/push", $_) } @l;
947 sub access_cfg_cfgs (@) {
950 # The nesting of these loops determines the search order. We put
951 # the key loop on the outside so that we search all the distros
952 # for each key, before going on to the next key. That means that
953 # if access_cfg is called with a more specific, and then a less
954 # specific, key, an earlier distro can override the less specific
955 # without necessarily overriding any more specific keys. (If the
956 # distro wants to override the more specific keys it can simply do
957 # so; whereas if we did the loop the other way around, it would be
958 # impossible to for an earlier distro to override a less specific
959 # key but not the more specific ones without restating the unknown
960 # values of the more specific keys.
963 # We have to deal with RETURN-UNDEF specially, so that we don't
964 # terminate the search prematurely.
966 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
969 foreach my $d (access_distros()) {
970 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
972 push @cfgs, map { "dgit.default.$_" } @realkeys;
979 my (@cfgs) = access_cfg_cfgs(@keys);
980 my $value = cfg(@cfgs);
984 sub access_cfg_bool ($$) {
985 my ($def, @keys) = @_;
986 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
989 sub string_to_ssh ($) {
991 if ($spec =~ m/\s/) {
992 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
998 sub access_cfg_ssh () {
999 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
1000 if (!defined $gitssh) {
1003 return string_to_ssh $gitssh;
1007 sub access_runeinfo ($) {
1009 return ": dgit ".access_basedistro()." $info ;";
1012 sub access_someuserhost ($) {
1014 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
1015 defined($user) && length($user) or
1016 $user = access_cfg("$some-user",'username');
1017 my $host = access_cfg("$some-host");
1018 return length($user) ? "$user\@$host" : $host;
1021 sub access_gituserhost () {
1022 return access_someuserhost('git');
1025 sub access_giturl (;$) {
1026 my ($optional) = @_;
1027 my $url = access_cfg('git-url','RETURN-UNDEF');
1030 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
1031 return undef unless defined $proto;
1034 access_gituserhost().
1035 access_cfg('git-path');
1037 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
1040 return "$url/$package$suffix";
1043 sub commit_getclogp ($) {
1044 # Returns the parsed changelog hashref for a particular commit
1046 our %commit_getclogp_memo;
1047 my $memo = $commit_getclogp_memo{$objid};
1048 return $memo if $memo;
1050 my $mclog = dgit_privdir()."clog";
1051 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1052 "$objid:debian/changelog";
1053 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1056 sub parse_dscdata () {
1057 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1058 printdebug Dumper($dscdata) if $debuglevel>1;
1059 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1060 printdebug Dumper($dsc) if $debuglevel>1;
1065 sub archive_query ($;@) {
1066 my ($method) = shift @_;
1067 fail "this operation does not support multiple comma-separated suites"
1069 my $query = access_cfg('archive-query','RETURN-UNDEF');
1070 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1073 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1076 sub archive_query_prepend_mirror {
1077 my $m = access_cfg('mirror');
1078 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1081 sub pool_dsc_subpath ($$) {
1082 my ($vsn,$component) = @_; # $package is implict arg
1083 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1084 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1087 sub cfg_apply_map ($$$) {
1088 my ($varref, $what, $mapspec) = @_;
1089 return unless $mapspec;
1091 printdebug "config $what EVAL{ $mapspec; }\n";
1093 eval "package Dgit::Config; $mapspec;";
1098 #---------- `ftpmasterapi' archive query method (nascent) ----------
1100 sub archive_api_query_cmd ($) {
1102 my @cmd = (@curl, qw(-sS));
1103 my $url = access_cfg('archive-query-url');
1104 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1106 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1107 foreach my $key (split /\:/, $keys) {
1108 $key =~ s/\%HOST\%/$host/g;
1110 fail "for $url: stat $key: $!" unless $!==ENOENT;
1113 fail "config requested specific TLS key but do not know".
1114 " how to get curl to use exactly that EE key ($key)";
1115 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1116 # # Sadly the above line does not work because of changes
1117 # # to gnutls. The real fix for #790093 may involve
1118 # # new curl options.
1121 # Fixing #790093 properly will involve providing a value
1122 # for this on clients.
1123 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1124 push @cmd, split / /, $kargs if defined $kargs;
1126 push @cmd, $url.$subpath;
1130 sub api_query ($$;$) {
1132 my ($data, $subpath, $ok404) = @_;
1133 badcfg "ftpmasterapi archive query method takes no data part"
1135 my @cmd = archive_api_query_cmd($subpath);
1136 my $url = $cmd[$#cmd];
1137 push @cmd, qw(-w %{http_code});
1138 my $json = cmdoutput @cmd;
1139 unless ($json =~ s/\d+\d+\d$//) {
1140 failedcmd_report_cmd undef, @cmd;
1141 fail "curl failed to print 3-digit HTTP code";
1144 return undef if $code eq '404' && $ok404;
1145 fail "fetch of $url gave HTTP code $code"
1146 unless $url =~ m#^file://# or $code =~ m/^2/;
1147 return decode_json($json);
1150 sub canonicalise_suite_ftpmasterapi {
1151 my ($proto,$data) = @_;
1152 my $suites = api_query($data, 'suites');
1154 foreach my $entry (@$suites) {
1156 my $v = $entry->{$_};
1157 defined $v && $v eq $isuite;
1158 } qw(codename name);
1159 push @matched, $entry;
1161 fail "unknown suite $isuite, maybe -d would help" unless @matched;
1164 @matched==1 or die "multiple matches for suite $isuite\n";
1165 $cn = "$matched[0]{codename}";
1166 defined $cn or die "suite $isuite info has no codename\n";
1167 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1169 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1174 sub archive_query_ftpmasterapi {
1175 my ($proto,$data) = @_;
1176 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1178 my $digester = Digest::SHA->new(256);
1179 foreach my $entry (@$info) {
1181 my $vsn = "$entry->{version}";
1182 my ($ok,$msg) = version_check $vsn;
1183 die "bad version: $msg\n" unless $ok;
1184 my $component = "$entry->{component}";
1185 $component =~ m/^$component_re$/ or die "bad component";
1186 my $filename = "$entry->{filename}";
1187 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1188 or die "bad filename";
1189 my $sha256sum = "$entry->{sha256sum}";
1190 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1191 push @rows, [ $vsn, "/pool/$component/$filename",
1192 $digester, $sha256sum ];
1194 die "bad ftpmaster api response: $@\n".Dumper($entry)
1197 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1198 return archive_query_prepend_mirror @rows;
1201 sub file_in_archive_ftpmasterapi {
1202 my ($proto,$data,$filename) = @_;
1203 my $pat = $filename;
1206 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1207 my $info = api_query($data, "file_in_archive/$pat", 1);
1210 sub package_not_wholly_new_ftpmasterapi {
1211 my ($proto,$data,$pkg) = @_;
1212 my $info = api_query($data,"madison?package=${pkg}&f=json");
1216 #---------- `aptget' archive query method ----------
1219 our $aptget_releasefile;
1220 our $aptget_configpath;
1222 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1223 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1225 sub aptget_cache_clean {
1226 runcmd_ordryrun_local qw(sh -ec),
1227 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1231 sub aptget_lock_acquire () {
1232 my $lockfile = "$aptget_base/lock";
1233 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1234 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1237 sub aptget_prep ($) {
1239 return if defined $aptget_base;
1241 badcfg "aptget archive query method takes no data part"
1244 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1247 ensuredir "$cache/dgit";
1249 access_cfg('aptget-cachekey','RETURN-UNDEF')
1250 // access_nomdistro();
1252 $aptget_base = "$cache/dgit/aptget";
1253 ensuredir $aptget_base;
1255 my $quoted_base = $aptget_base;
1256 die "$quoted_base contains bad chars, cannot continue"
1257 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1259 ensuredir $aptget_base;
1261 aptget_lock_acquire();
1263 aptget_cache_clean();
1265 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1266 my $sourceslist = "source.list#$cachekey";
1268 my $aptsuites = $isuite;
1269 cfg_apply_map(\$aptsuites, 'suite map',
1270 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1272 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1273 printf SRCS "deb-src %s %s %s\n",
1274 access_cfg('mirror'),
1276 access_cfg('aptget-components')
1279 ensuredir "$aptget_base/cache";
1280 ensuredir "$aptget_base/lists";
1282 open CONF, ">", $aptget_configpath or die $!;
1284 Debug::NoLocking "true";
1285 APT::Get::List-Cleanup "false";
1286 #clear APT::Update::Post-Invoke-Success;
1287 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1288 Dir::State::Lists "$quoted_base/lists";
1289 Dir::Etc::preferences "$quoted_base/preferences";
1290 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1291 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1294 foreach my $key (qw(
1297 Dir::Cache::Archives
1298 Dir::Etc::SourceParts
1299 Dir::Etc::preferencesparts
1301 ensuredir "$aptget_base/$key";
1302 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1305 my $oldatime = (time // die $!) - 1;
1306 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1307 next unless stat_exists $oldlist;
1308 my ($mtime) = (stat _)[9];
1309 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1312 runcmd_ordryrun_local aptget_aptget(), qw(update);
1315 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1316 next unless stat_exists $oldlist;
1317 my ($atime) = (stat _)[8];
1318 next if $atime == $oldatime;
1319 push @releasefiles, $oldlist;
1321 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1322 @releasefiles = @inreleasefiles if @inreleasefiles;
1323 if (!@releasefiles) {
1325 apt seemed to not to update dgit's cached Release files for $isuite.
1327 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1330 die "apt updated too many Release files (@releasefiles), erk"
1331 unless @releasefiles == 1;
1333 ($aptget_releasefile) = @releasefiles;
1336 sub canonicalise_suite_aptget {
1337 my ($proto,$data) = @_;
1340 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1342 foreach my $name (qw(Codename Suite)) {
1343 my $val = $release->{$name};
1345 printdebug "release file $name: $val\n";
1346 $val =~ m/^$suite_re$/o or fail
1347 "Release file ($aptget_releasefile) specifies intolerable $name";
1348 cfg_apply_map(\$val, 'suite rmap',
1349 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1356 sub archive_query_aptget {
1357 my ($proto,$data) = @_;
1360 ensuredir "$aptget_base/source";
1361 foreach my $old (<$aptget_base/source/*.dsc>) {
1362 unlink $old or die "$old: $!";
1365 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1366 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1367 # avoids apt-get source failing with ambiguous error code
1369 runcmd_ordryrun_local
1370 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1371 aptget_aptget(), qw(--download-only --only-source source), $package;
1373 my @dscs = <$aptget_base/source/*.dsc>;
1374 fail "apt-get source did not produce a .dsc" unless @dscs;
1375 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1377 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1380 my $uri = "file://". uri_escape $dscs[0];
1381 $uri =~ s{\%2f}{/}gi;
1382 return [ (getfield $pre_dsc, 'Version'), $uri ];
1385 sub file_in_archive_aptget () { return undef; }
1386 sub package_not_wholly_new_aptget () { return undef; }
1388 #---------- `dummyapicat' archive query method ----------
1390 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1391 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1393 sub dummycatapi_run_in_mirror ($@) {
1394 # runs $fn with FIA open onto rune
1395 my ($rune, $argl, $fn) = @_;
1397 my $mirror = access_cfg('mirror');
1398 $mirror =~ s#^file://#/# or die "$mirror ?";
1399 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1400 qw(x), $mirror, @$argl);
1401 debugcmd "-|", @cmd;
1402 open FIA, "-|", @cmd or die $!;
1404 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1408 sub file_in_archive_dummycatapi ($$$) {
1409 my ($proto,$data,$filename) = @_;
1411 dummycatapi_run_in_mirror '
1412 find -name "$1" -print0 |
1414 ', [$filename], sub {
1417 printdebug "| $_\n";
1418 m/^(\w+) (\S+)$/ or die "$_ ?";
1419 push @out, { sha256sum => $1, filename => $2 };
1425 sub package_not_wholly_new_dummycatapi {
1426 my ($proto,$data,$pkg) = @_;
1427 dummycatapi_run_in_mirror "
1428 find -name ${pkg}_*.dsc
1435 #---------- `madison' archive query method ----------
1437 sub archive_query_madison {
1438 return archive_query_prepend_mirror
1439 map { [ @$_[0..1] ] } madison_get_parse(@_);
1442 sub madison_get_parse {
1443 my ($proto,$data) = @_;
1444 die unless $proto eq 'madison';
1445 if (!length $data) {
1446 $data= access_cfg('madison-distro','RETURN-UNDEF');
1447 $data //= access_basedistro();
1449 $rmad{$proto,$data,$package} ||= cmdoutput
1450 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1451 my $rmad = $rmad{$proto,$data,$package};
1454 foreach my $l (split /\n/, $rmad) {
1455 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1456 \s*( [^ \t|]+ )\s* \|
1457 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1458 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1459 $1 eq $package or die "$rmad $package ?";
1466 $component = access_cfg('archive-query-default-component');
1468 $5 eq 'source' or die "$rmad ?";
1469 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1471 return sort { -version_compare($a->[0],$b->[0]); } @out;
1474 sub canonicalise_suite_madison {
1475 # madison canonicalises for us
1476 my @r = madison_get_parse(@_);
1478 "unable to canonicalise suite using package $package".
1479 " which does not appear to exist in suite $isuite;".
1480 " --existing-package may help";
1484 sub file_in_archive_madison { return undef; }
1485 sub package_not_wholly_new_madison { return undef; }
1487 #---------- `sshpsql' archive query method ----------
1490 my ($data,$runeinfo,$sql) = @_;
1491 if (!length $data) {
1492 $data= access_someuserhost('sshpsql').':'.
1493 access_cfg('sshpsql-dbname');
1495 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1496 my ($userhost,$dbname) = ($`,$'); #';
1498 my @cmd = (access_cfg_ssh, $userhost,
1499 access_runeinfo("ssh-psql $runeinfo").
1500 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1501 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1503 open P, "-|", @cmd or die $!;
1506 printdebug(">|$_|\n");
1509 $!=0; $?=0; close P or failedcmd @cmd;
1511 my $nrows = pop @rows;
1512 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1513 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1514 @rows = map { [ split /\|/, $_ ] } @rows;
1515 my $ncols = scalar @{ shift @rows };
1516 die if grep { scalar @$_ != $ncols } @rows;
1520 sub sql_injection_check {
1521 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1524 sub archive_query_sshpsql ($$) {
1525 my ($proto,$data) = @_;
1526 sql_injection_check $isuite, $package;
1527 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1528 SELECT source.version, component.name, files.filename, files.sha256sum
1530 JOIN src_associations ON source.id = src_associations.source
1531 JOIN suite ON suite.id = src_associations.suite
1532 JOIN dsc_files ON dsc_files.source = source.id
1533 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1534 JOIN component ON component.id = files_archive_map.component_id
1535 JOIN files ON files.id = dsc_files.file
1536 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1537 AND source.source='$package'
1538 AND files.filename LIKE '%.dsc';
1540 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1541 my $digester = Digest::SHA->new(256);
1543 my ($vsn,$component,$filename,$sha256sum) = @$_;
1544 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1546 return archive_query_prepend_mirror @rows;
1549 sub canonicalise_suite_sshpsql ($$) {
1550 my ($proto,$data) = @_;
1551 sql_injection_check $isuite;
1552 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1553 SELECT suite.codename
1554 FROM suite where suite_name='$isuite' or codename='$isuite';
1556 @rows = map { $_->[0] } @rows;
1557 fail "unknown suite $isuite" unless @rows;
1558 die "ambiguous $isuite: @rows ?" if @rows>1;
1562 sub file_in_archive_sshpsql ($$$) { return undef; }
1563 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1565 #---------- `dummycat' archive query method ----------
1567 sub canonicalise_suite_dummycat ($$) {
1568 my ($proto,$data) = @_;
1569 my $dpath = "$data/suite.$isuite";
1570 if (!open C, "<", $dpath) {
1571 $!==ENOENT or die "$dpath: $!";
1572 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1576 chomp or die "$dpath: $!";
1578 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1582 sub archive_query_dummycat ($$) {
1583 my ($proto,$data) = @_;
1584 canonicalise_suite();
1585 my $dpath = "$data/package.$csuite.$package";
1586 if (!open C, "<", $dpath) {
1587 $!==ENOENT or die "$dpath: $!";
1588 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1596 printdebug "dummycat query $csuite $package $dpath | $_\n";
1597 my @row = split /\s+/, $_;
1598 @row==2 or die "$dpath: $_ ?";
1601 C->error and die "$dpath: $!";
1603 return archive_query_prepend_mirror
1604 sort { -version_compare($a->[0],$b->[0]); } @rows;
1607 sub file_in_archive_dummycat () { return undef; }
1608 sub package_not_wholly_new_dummycat () { return undef; }
1610 #---------- tag format handling ----------
1612 sub access_cfg_tagformats () {
1613 split /\,/, access_cfg('dgit-tag-format');
1616 sub access_cfg_tagformats_can_splitbrain () {
1617 my %y = map { $_ => 1 } access_cfg_tagformats;
1618 foreach my $needtf (qw(new maint)) {
1619 next if $y{$needtf};
1625 sub need_tagformat ($$) {
1626 my ($fmt, $why) = @_;
1627 fail "need to use tag format $fmt ($why) but also need".
1628 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1629 " - no way to proceed"
1630 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1631 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1634 sub select_tagformat () {
1636 return if $tagformatfn && !$tagformat_want;
1637 die 'bug' if $tagformatfn && $tagformat_want;
1638 # ... $tagformat_want assigned after previous select_tagformat
1640 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1641 printdebug "select_tagformat supported @supported\n";
1643 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1644 printdebug "select_tagformat specified @$tagformat_want\n";
1646 my ($fmt,$why,$override) = @$tagformat_want;
1648 fail "target distro supports tag formats @supported".
1649 " but have to use $fmt ($why)"
1651 or grep { $_ eq $fmt } @supported;
1653 $tagformat_want = undef;
1655 $tagformatfn = ${*::}{"debiantag_$fmt"};
1657 fail "trying to use unknown tag format \`$fmt' ($why) !"
1658 unless $tagformatfn;
1661 #---------- archive query entrypoints and rest of program ----------
1663 sub canonicalise_suite () {
1664 return if defined $csuite;
1665 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1666 $csuite = archive_query('canonicalise_suite');
1667 if ($isuite ne $csuite) {
1668 progress "canonical suite name for $isuite is $csuite";
1670 progress "canonical suite name is $csuite";
1674 sub get_archive_dsc () {
1675 canonicalise_suite();
1676 my @vsns = archive_query('archive_query');
1677 foreach my $vinfo (@vsns) {
1678 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1679 $dscurl = $vsn_dscurl;
1680 $dscdata = url_get($dscurl);
1682 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1687 $digester->add($dscdata);
1688 my $got = $digester->hexdigest();
1690 fail "$dscurl has hash $got but".
1691 " archive told us to expect $digest";
1694 my $fmt = getfield $dsc, 'Format';
1695 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1696 "unsupported source format $fmt, sorry";
1698 $dsc_checked = !!$digester;
1699 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1703 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1706 sub check_for_git ();
1707 sub check_for_git () {
1709 my $how = access_cfg('git-check');
1710 if ($how eq 'ssh-cmd') {
1712 (access_cfg_ssh, access_gituserhost(),
1713 access_runeinfo("git-check $package").
1714 " set -e; cd ".access_cfg('git-path').";".
1715 " if test -d $package.git; then echo 1; else echo 0; fi");
1716 my $r= cmdoutput @cmd;
1717 if (defined $r and $r =~ m/^divert (\w+)$/) {
1719 my ($usedistro,) = access_distros();
1720 # NB that if we are pushing, $usedistro will be $distro/push
1721 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1722 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1723 progress "diverting to $divert (using config for $instead_distro)";
1724 return check_for_git();
1726 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1728 } elsif ($how eq 'url') {
1729 my $prefix = access_cfg('git-check-url','git-url');
1730 my $suffix = access_cfg('git-check-suffix','git-suffix',
1731 'RETURN-UNDEF') // '.git';
1732 my $url = "$prefix/$package$suffix";
1733 my @cmd = (@curl, qw(-sS -I), $url);
1734 my $result = cmdoutput @cmd;
1735 $result =~ s/^\S+ 200 .*\n\r?\n//;
1736 # curl -sS -I with https_proxy prints
1737 # HTTP/1.0 200 Connection established
1738 $result =~ m/^\S+ (404|200) /s or
1739 fail "unexpected results from git check query - ".
1740 Dumper($prefix, $result);
1742 if ($code eq '404') {
1744 } elsif ($code eq '200') {
1749 } elsif ($how eq 'true') {
1751 } elsif ($how eq 'false') {
1754 badcfg "unknown git-check \`$how'";
1758 sub create_remote_git_repo () {
1759 my $how = access_cfg('git-create');
1760 if ($how eq 'ssh-cmd') {
1762 (access_cfg_ssh, access_gituserhost(),
1763 access_runeinfo("git-create $package").
1764 "set -e; cd ".access_cfg('git-path').";".
1765 " cp -a _template $package.git");
1766 } elsif ($how eq 'true') {
1769 badcfg "unknown git-create \`$how'";
1773 our ($dsc_hash,$lastpush_mergeinput);
1774 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1778 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1779 $playground = fresh_playground 'dgit/unpack';
1782 sub mktree_in_ud_here () {
1783 playtree_setup $gitcfgs{local};
1786 sub git_write_tree () {
1787 my $tree = cmdoutput @git, qw(write-tree);
1788 $tree =~ m/^\w+$/ or die "$tree ?";
1792 sub git_add_write_tree () {
1793 runcmd @git, qw(add -Af .);
1794 return git_write_tree();
1797 sub remove_stray_gits ($) {
1799 my @gitscmd = qw(find -name .git -prune -print0);
1800 debugcmd "|",@gitscmd;
1801 open GITS, "-|", @gitscmd or die $!;
1806 print STDERR "$us: warning: removing from $what: ",
1807 (messagequote $_), "\n";
1811 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1814 sub mktree_in_ud_from_only_subdir ($;$) {
1815 my ($what,$raw) = @_;
1816 # changes into the subdir
1819 die "expected one subdir but found @dirs ?" unless @dirs==1;
1820 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1824 remove_stray_gits($what);
1825 mktree_in_ud_here();
1827 my ($format, $fopts) = get_source_format();
1828 if (madformat($format)) {
1833 my $tree=git_add_write_tree();
1834 return ($tree,$dir);
1837 our @files_csum_info_fields =
1838 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1839 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1840 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1842 sub dsc_files_info () {
1843 foreach my $csumi (@files_csum_info_fields) {
1844 my ($fname, $module, $method) = @$csumi;
1845 my $field = $dsc->{$fname};
1846 next unless defined $field;
1847 eval "use $module; 1;" or die $@;
1849 foreach (split /\n/, $field) {
1851 m/^(\w+) (\d+) (\S+)$/ or
1852 fail "could not parse .dsc $fname line \`$_'";
1853 my $digester = eval "$module"."->$method;" or die $@;
1858 Digester => $digester,
1863 fail "missing any supported Checksums-* or Files field in ".
1864 $dsc->get_option('name');
1868 map { $_->{Filename} } dsc_files_info();
1871 sub files_compare_inputs (@) {
1876 my $showinputs = sub {
1877 return join "; ", map { $_->get_option('name') } @$inputs;
1880 foreach my $in (@$inputs) {
1882 my $in_name = $in->get_option('name');
1884 printdebug "files_compare_inputs $in_name\n";
1886 foreach my $csumi (@files_csum_info_fields) {
1887 my ($fname) = @$csumi;
1888 printdebug "files_compare_inputs $in_name $fname\n";
1890 my $field = $in->{$fname};
1891 next unless defined $field;
1894 foreach (split /\n/, $field) {
1897 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1898 fail "could not parse $in_name $fname line \`$_'";
1900 printdebug "files_compare_inputs $in_name $fname $f\n";
1904 my $re = \ $record{$f}{$fname};
1906 $fchecked{$f}{$in_name} = 1;
1908 fail "hash or size of $f varies in $fname fields".
1909 " (between: ".$showinputs->().")";
1914 @files = sort @files;
1915 $expected_files //= \@files;
1916 "@$expected_files" eq "@files" or
1917 fail "file list in $in_name varies between hash fields!";
1920 fail "$in_name has no files list field(s)";
1922 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1925 grep { keys %$_ == @$inputs-1 } values %fchecked
1926 or fail "no file appears in all file lists".
1927 " (looked in: ".$showinputs->().")";
1930 sub is_orig_file_in_dsc ($$) {
1931 my ($f, $dsc_files_info) = @_;
1932 return 0 if @$dsc_files_info <= 1;
1933 # One file means no origs, and the filename doesn't have a "what
1934 # part of dsc" component. (Consider versions ending `.orig'.)
1935 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1939 # This function determines whether a .changes file is source-only from
1940 # the point of view of dak. Thus, it permits *_source.buildinfo
1943 # It does not, however, permit any other buildinfo files. After a
1944 # source-only upload, the buildds will try to upload files like
1945 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1946 # named like this in their (otherwise) source-only upload, the uploads
1947 # of the buildd can be rejected by dak. Fixing the resultant
1948 # situation can require manual intervention. So we block such
1949 # .buildinfo files when the user tells us to perform a source-only
1950 # upload (such as when using the push-source subcommand with the -C
1951 # option, which calls this function).
1953 # Note, though, that when dgit is told to prepare a source-only
1954 # upload, such as when subcommands like build-source and push-source
1955 # without -C are used, dgit has a more restrictive notion of
1956 # source-only .changes than dak: such uploads will never include
1957 # *_source.buildinfo files. This is because there is no use for such
1958 # files when using a tool like dgit to produce the source package, as
1959 # dgit ensures the source is identical to git HEAD.
1960 sub test_source_only_changes ($) {
1962 foreach my $l (split /\n/, getfield $changes, 'Files') {
1963 $l =~ m/\S+$/ or next;
1964 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1965 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1966 print "purportedly source-only changes polluted by $&\n";
1973 sub changes_update_origs_from_dsc ($$$$) {
1974 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1976 printdebug "checking origs needed ($upstreamvsn)...\n";
1977 $_ = getfield $changes, 'Files';
1978 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1979 fail "cannot find section/priority from .changes Files field";
1980 my $placementinfo = $1;
1982 printdebug "checking origs needed placement '$placementinfo'...\n";
1983 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1984 $l =~ m/\S+$/ or next;
1986 printdebug "origs $file | $l\n";
1987 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1988 printdebug "origs $file is_orig\n";
1989 my $have = archive_query('file_in_archive', $file);
1990 if (!defined $have) {
1992 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1998 printdebug "origs $file \$#\$have=$#$have\n";
1999 foreach my $h (@$have) {
2002 foreach my $csumi (@files_csum_info_fields) {
2003 my ($fname, $module, $method, $archivefield) = @$csumi;
2004 next unless defined $h->{$archivefield};
2005 $_ = $dsc->{$fname};
2006 next unless defined;
2007 m/^(\w+) .* \Q$file\E$/m or
2008 fail ".dsc $fname missing entry for $file";
2009 if ($h->{$archivefield} eq $1) {
2013 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
2016 die "$file ".Dumper($h)." ?!" if $same && @differ;
2019 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
2022 printdebug "origs $file f.same=$found_same".
2023 " #f._differ=$#found_differ\n";
2024 if (@found_differ && !$found_same) {
2026 "archive contains $file with different checksum",
2029 # Now we edit the changes file to add or remove it
2030 foreach my $csumi (@files_csum_info_fields) {
2031 my ($fname, $module, $method, $archivefield) = @$csumi;
2032 next unless defined $changes->{$fname};
2034 # in archive, delete from .changes if it's there
2035 $changed{$file} = "removed" if
2036 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2037 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2038 # not in archive, but it's here in the .changes
2040 my $dsc_data = getfield $dsc, $fname;
2041 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2043 $extra =~ s/ \d+ /$&$placementinfo /
2044 or die "$fname $extra >$dsc_data< ?"
2045 if $fname eq 'Files';
2046 $changes->{$fname} .= "\n". $extra;
2047 $changed{$file} = "added";
2052 foreach my $file (keys %changed) {
2054 "edited .changes for archive .orig contents: %s %s",
2055 $changed{$file}, $file;
2057 my $chtmp = "$changesfile.tmp";
2058 $changes->save($chtmp);
2060 rename $chtmp,$changesfile or die "$changesfile $!";
2062 progress "[new .changes left in $changesfile]";
2065 progress "$changesfile already has appropriate .orig(s) (if any)";
2069 sub make_commit ($) {
2071 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2074 sub clogp_authline ($) {
2076 my $author = getfield $clogp, 'Maintainer';
2077 if ($author =~ m/^[^"\@]+\,/) {
2078 # single entry Maintainer field with unquoted comma
2079 $author = ($& =~ y/,//rd).$'; # strip the comma
2081 # git wants a single author; any remaining commas in $author
2082 # are by now preceded by @ (or "). It seems safer to punt on
2083 # "..." for now rather than attempting to dequote or something.
2084 $author =~ s#,.*##ms unless $author =~ m/"/;
2085 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2086 my $authline = "$author $date";
2087 $authline =~ m/$git_authline_re/o or
2088 fail "unexpected commit author line format \`$authline'".
2089 " (was generated from changelog Maintainer field)";
2090 return ($1,$2,$3) if wantarray;
2094 sub vendor_patches_distro ($$) {
2095 my ($checkdistro, $what) = @_;
2096 return unless defined $checkdistro;
2098 my $series = "debian/patches/\L$checkdistro\E.series";
2099 printdebug "checking for vendor-specific $series ($what)\n";
2101 if (!open SERIES, "<", $series) {
2102 die "$series $!" unless $!==ENOENT;
2111 Unfortunately, this source package uses a feature of dpkg-source where
2112 the same source package unpacks to different source code on different
2113 distros. dgit cannot safely operate on such packages on affected
2114 distros, because the meaning of source packages is not stable.
2116 Please ask the distro/maintainer to remove the distro-specific series
2117 files and use a different technique (if necessary, uploading actually
2118 different packages, if different distros are supposed to have
2122 fail "Found active distro-specific series file for".
2123 " $checkdistro ($what): $series, cannot continue";
2125 die "$series $!" if SERIES->error;
2129 sub check_for_vendor_patches () {
2130 # This dpkg-source feature doesn't seem to be documented anywhere!
2131 # But it can be found in the changelog (reformatted):
2133 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2134 # Author: Raphael Hertzog <hertzog@debian.org>
2135 # Date: Sun Oct 3 09:36:48 2010 +0200
2137 # dpkg-source: correctly create .pc/.quilt_series with alternate
2140 # If you have debian/patches/ubuntu.series and you were
2141 # unpacking the source package on ubuntu, quilt was still
2142 # directed to debian/patches/series instead of
2143 # debian/patches/ubuntu.series.
2145 # debian/changelog | 3 +++
2146 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2147 # 2 files changed, 6 insertions(+), 1 deletion(-)
2150 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2151 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2152 "Dpkg::Vendor \`current vendor'");
2153 vendor_patches_distro(access_basedistro(),
2154 "(base) distro being accessed");
2155 vendor_patches_distro(access_nomdistro(),
2156 "(nominal) distro being accessed");
2159 sub generate_commits_from_dsc () {
2160 # See big comment in fetch_from_archive, below.
2161 # See also README.dsc-import.
2163 changedir $playground;
2165 my @dfi = dsc_files_info();
2166 foreach my $fi (@dfi) {
2167 my $f = $fi->{Filename};
2168 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2169 my $upper_f = (bpd_abs()."/$f");
2171 printdebug "considering reusing $f: ";
2173 if (link_ltarget "$upper_f,fetch", $f) {
2174 printdebug "linked (using ...,fetch).\n";
2175 } elsif ((printdebug "($!) "),
2177 fail "accessing $buildproductsdir/$f,fetch: $!";
2178 } elsif (link_ltarget $upper_f, $f) {
2179 printdebug "linked.\n";
2180 } elsif ((printdebug "($!) "),
2182 fail "accessing $buildproductsdir/$f: $!";
2184 printdebug "absent.\n";
2188 complete_file_from_dsc('.', $fi, \$refetched)
2191 printdebug "considering saving $f: ";
2193 if (link $f, $upper_f) {
2194 printdebug "linked.\n";
2195 } elsif ((printdebug "($!) "),
2197 fail "saving $buildproductsdir/$f: $!";
2198 } elsif (!$refetched) {
2199 printdebug "no need.\n";
2200 } elsif (link $f, "$upper_f,fetch") {
2201 printdebug "linked (using ...,fetch).\n";
2202 } elsif ((printdebug "($!) "),
2204 fail "saving $buildproductsdir/$f,fetch: $!";
2206 printdebug "cannot.\n";
2210 # We unpack and record the orig tarballs first, so that we only
2211 # need disk space for one private copy of the unpacked source.
2212 # But we can't make them into commits until we have the metadata
2213 # from the debian/changelog, so we record the tree objects now and
2214 # make them into commits later.
2216 my $upstreamv = upstreamversion $dsc->{version};
2217 my $orig_f_base = srcfn $upstreamv, '';
2219 foreach my $fi (@dfi) {
2220 # We actually import, and record as a commit, every tarball
2221 # (unless there is only one file, in which case there seems
2224 my $f = $fi->{Filename};
2225 printdebug "import considering $f ";
2226 (printdebug "only one dfi\n"), next if @dfi == 1;
2227 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2228 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2232 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2234 printdebug "Y ", (join ' ', map { $_//"(none)" }
2235 $compr_ext, $orig_f_part
2238 my $input = new IO::File $f, '<' or die "$f $!";
2242 if (defined $compr_ext) {
2244 Dpkg::Compression::compression_guess_from_filename $f;
2245 fail "Dpkg::Compression cannot handle file $f in source package"
2246 if defined $compr_ext && !defined $cname;
2248 new Dpkg::Compression::Process compression => $cname;
2249 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2250 my $compr_fh = new IO::Handle;
2251 my $compr_pid = open $compr_fh, "-|" // die $!;
2253 open STDIN, "<&", $input or die $!;
2255 die "dgit (child): exec $compr_cmd[0]: $!\n";
2260 rmtree "_unpack-tar";
2261 mkdir "_unpack-tar" or die $!;
2262 my @tarcmd = qw(tar -x -f -
2263 --no-same-owner --no-same-permissions
2264 --no-acls --no-xattrs --no-selinux);
2265 my $tar_pid = fork // die $!;
2267 chdir "_unpack-tar" or die $!;
2268 open STDIN, "<&", $input or die $!;
2270 die "dgit (child): exec $tarcmd[0]: $!";
2272 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2273 !$? or failedcmd @tarcmd;
2276 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2278 # finally, we have the results in "tarball", but maybe
2279 # with the wrong permissions
2281 runcmd qw(chmod -R +rwX _unpack-tar);
2282 changedir "_unpack-tar";
2283 remove_stray_gits($f);
2284 mktree_in_ud_here();
2286 my ($tree) = git_add_write_tree();
2287 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2288 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2290 printdebug "one subtree $1\n";
2292 printdebug "multiple subtrees\n";
2295 rmtree "_unpack-tar";
2297 my $ent = [ $f, $tree ];
2299 Orig => !!$orig_f_part,
2300 Sort => (!$orig_f_part ? 2 :
2301 $orig_f_part =~ m/-/g ? 1 :
2309 # put any without "_" first (spec is not clear whether files
2310 # are always in the usual order). Tarballs without "_" are
2311 # the main orig or the debian tarball.
2312 $a->{Sort} <=> $b->{Sort} or
2316 my $any_orig = grep { $_->{Orig} } @tartrees;
2318 my $dscfn = "$package.dsc";
2320 my $treeimporthow = 'package';
2322 open D, ">", $dscfn or die "$dscfn: $!";
2323 print D $dscdata or die "$dscfn: $!";
2324 close D or die "$dscfn: $!";
2325 my @cmd = qw(dpkg-source);
2326 push @cmd, '--no-check' if $dsc_checked;
2327 if (madformat $dsc->{format}) {
2328 push @cmd, '--skip-patches';
2329 $treeimporthow = 'unpatched';
2331 push @cmd, qw(-x --), $dscfn;
2334 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2335 if (madformat $dsc->{format}) {
2336 check_for_vendor_patches();
2340 if (madformat $dsc->{format}) {
2341 my @pcmd = qw(dpkg-source --before-build .);
2342 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2344 $dappliedtree = git_add_write_tree();
2347 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2351 printdebug "import clog search...\n";
2352 parsechangelog_loop \@clogcmd, "package changelog", sub {
2353 my ($thisstanza, $desc) = @_;
2354 no warnings qw(exiting);
2356 $clogp //= $thisstanza;
2358 printdebug "import clog $thisstanza->{version} $desc...\n";
2360 last if !$any_orig; # we don't need $r1clogp
2362 # We look for the first (most recent) changelog entry whose
2363 # version number is lower than the upstream version of this
2364 # package. Then the last (least recent) previous changelog
2365 # entry is treated as the one which introduced this upstream
2366 # version and used for the synthetic commits for the upstream
2369 # One might think that a more sophisticated algorithm would be
2370 # necessary. But: we do not want to scan the whole changelog
2371 # file. Stopping when we see an earlier version, which
2372 # necessarily then is an earlier upstream version, is the only
2373 # realistic way to do that. Then, either the earliest
2374 # changelog entry we have seen so far is indeed the earliest
2375 # upload of this upstream version; or there are only changelog
2376 # entries relating to later upstream versions (which is not
2377 # possible unless the changelog and .dsc disagree about the
2378 # version). Then it remains to choose between the physically
2379 # last entry in the file, and the one with the lowest version
2380 # number. If these are not the same, we guess that the
2381 # versions were created in a non-monotonic order rather than
2382 # that the changelog entries have been misordered.
2384 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2386 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2387 $r1clogp = $thisstanza;
2389 printdebug "import clog $r1clogp->{version} becomes r1\n";
2392 $clogp or fail "package changelog has no entries!";
2394 my $authline = clogp_authline $clogp;
2395 my $changes = getfield $clogp, 'Changes';
2396 $changes =~ s/^\n//; # Changes: \n
2397 my $cversion = getfield $clogp, 'Version';
2400 $r1clogp //= $clogp; # maybe there's only one entry;
2401 my $r1authline = clogp_authline $r1clogp;
2402 # Strictly, r1authline might now be wrong if it's going to be
2403 # unused because !$any_orig. Whatever.
2405 printdebug "import tartrees authline $authline\n";
2406 printdebug "import tartrees r1authline $r1authline\n";
2408 foreach my $tt (@tartrees) {
2409 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2411 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2414 committer $r1authline
2418 [dgit import orig $tt->{F}]
2426 [dgit import tarball $package $cversion $tt->{F}]
2431 printdebug "import main commit\n";
2433 open C, ">../commit.tmp" or die $!;
2434 print C <<END or die $!;
2437 print C <<END or die $! foreach @tartrees;
2440 print C <<END or die $!;
2446 [dgit import $treeimporthow $package $cversion]
2450 my $rawimport_hash = make_commit qw(../commit.tmp);
2452 if (madformat $dsc->{format}) {
2453 printdebug "import apply patches...\n";
2455 # regularise the state of the working tree so that
2456 # the checkout of $rawimport_hash works nicely.
2457 my $dappliedcommit = make_commit_text(<<END);
2464 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2466 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2468 # We need the answers to be reproducible
2469 my @authline = clogp_authline($clogp);
2470 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2471 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2472 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2473 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2474 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2475 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2477 my $path = $ENV{PATH} or die;
2479 # we use ../../gbp-pq-output, which (given that we are in
2480 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2483 foreach my $use_absurd (qw(0 1)) {
2484 runcmd @git, qw(checkout -q unpa);
2485 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2486 local $ENV{PATH} = $path;
2489 progress "warning: $@";
2490 $path = "$absurdity:$path";
2491 progress "$us: trying slow absurd-git-apply...";
2492 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2497 die "forbid absurd git-apply\n" if $use_absurd
2498 && forceing [qw(import-gitapply-no-absurd)];
2499 die "only absurd git-apply!\n" if !$use_absurd
2500 && forceing [qw(import-gitapply-absurd)];
2502 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2503 local $ENV{PATH} = $path if $use_absurd;
2505 my @showcmd = (gbp_pq, qw(import));
2506 my @realcmd = shell_cmd
2507 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2508 debugcmd "+",@realcmd;
2509 if (system @realcmd) {
2510 die +(shellquote @showcmd).
2512 failedcmd_waitstatus()."\n";
2515 my $gapplied = git_rev_parse('HEAD');
2516 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2517 $gappliedtree eq $dappliedtree or
2519 gbp-pq import and dpkg-source disagree!
2520 gbp-pq import gave commit $gapplied
2521 gbp-pq import gave tree $gappliedtree
2522 dpkg-source --before-build gave tree $dappliedtree
2524 $rawimport_hash = $gapplied;
2529 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2534 progress "synthesised git commit from .dsc $cversion";
2536 my $rawimport_mergeinput = {
2537 Commit => $rawimport_hash,
2538 Info => "Import of source package",
2540 my @output = ($rawimport_mergeinput);
2542 if ($lastpush_mergeinput) {
2543 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2544 my $oversion = getfield $oldclogp, 'Version';
2546 version_compare($oversion, $cversion);
2548 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2549 { Message => <<END, ReverseParents => 1 });
2550 Record $package ($cversion) in archive suite $csuite
2552 } elsif ($vcmp > 0) {
2553 print STDERR <<END or die $!;
2555 Version actually in archive: $cversion (older)
2556 Last version pushed with dgit: $oversion (newer or same)
2559 @output = $lastpush_mergeinput;
2561 # Same version. Use what's in the server git branch,
2562 # discarding our own import. (This could happen if the
2563 # server automatically imports all packages into git.)
2564 @output = $lastpush_mergeinput;
2572 sub complete_file_from_dsc ($$;$) {
2573 our ($dstdir, $fi, $refetched) = @_;
2574 # Ensures that we have, in $dstdir, the file $fi, with the correct
2575 # contents. (Downloading it from alongside $dscurl if necessary.)
2576 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2577 # and will set $$refetched=1 if it did so (or tried to).
2579 my $f = $fi->{Filename};
2580 my $tf = "$dstdir/$f";
2584 my $checkhash = sub {
2585 open F, "<", "$tf" or die "$tf: $!";
2586 $fi->{Digester}->reset();
2587 $fi->{Digester}->addfile(*F);
2588 F->error and die $!;
2589 $got = $fi->{Digester}->hexdigest();
2590 return $got eq $fi->{Hash};
2593 if (stat_exists $tf) {
2594 if ($checkhash->()) {
2595 progress "using existing $f";
2599 fail "file $f has hash $got but .dsc".
2600 " demands hash $fi->{Hash} ".
2601 "(perhaps you should delete this file?)";
2603 progress "need to fetch correct version of $f";
2604 unlink $tf or die "$tf $!";
2607 printdebug "$tf does not exist, need to fetch\n";
2611 $furl =~ s{/[^/]+$}{};
2613 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2614 die "$f ?" if $f =~ m#/#;
2615 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2616 return 0 if !act_local();
2619 fail "file $f has hash $got but .dsc".
2620 " demands hash $fi->{Hash} ".
2621 "(got wrong file from archive!)";
2626 sub ensure_we_have_orig () {
2627 my @dfi = dsc_files_info();
2628 foreach my $fi (@dfi) {
2629 my $f = $fi->{Filename};
2630 next unless is_orig_file_in_dsc($f, \@dfi);
2631 complete_file_from_dsc($buildproductsdir, $fi)
2636 #---------- git fetch ----------
2638 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2639 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2641 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2642 # locally fetched refs because they have unhelpful names and clutter
2643 # up gitk etc. So we track whether we have "used up" head ref (ie,
2644 # whether we have made another local ref which refers to this object).
2646 # (If we deleted them unconditionally, then we might end up
2647 # re-fetching the same git objects each time dgit fetch was run.)
2649 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2650 # in git_fetch_us to fetch the refs in question, and possibly a call
2651 # to lrfetchref_used.
2653 our (%lrfetchrefs_f, %lrfetchrefs_d);
2654 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2656 sub lrfetchref_used ($) {
2657 my ($fullrefname) = @_;
2658 my $objid = $lrfetchrefs_f{$fullrefname};
2659 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2662 sub git_lrfetch_sane {
2663 my ($url, $supplementary, @specs) = @_;
2664 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2665 # at least as regards @specs. Also leave the results in
2666 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2667 # able to clean these up.
2669 # With $supplementary==1, @specs must not contain wildcards
2670 # and we add to our previous fetches (non-atomically).
2672 # This is rather miserable:
2673 # When git fetch --prune is passed a fetchspec ending with a *,
2674 # it does a plausible thing. If there is no * then:
2675 # - it matches subpaths too, even if the supplied refspec
2676 # starts refs, and behaves completely madly if the source
2677 # has refs/refs/something. (See, for example, Debian #NNNN.)
2678 # - if there is no matching remote ref, it bombs out the whole
2680 # We want to fetch a fixed ref, and we don't know in advance
2681 # if it exists, so this is not suitable.
2683 # Our workaround is to use git ls-remote. git ls-remote has its
2684 # own qairks. Notably, it has the absurd multi-tail-matching
2685 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2686 # refs/refs/foo etc.
2688 # Also, we want an idempotent snapshot, but we have to make two
2689 # calls to the remote: one to git ls-remote and to git fetch. The
2690 # solution is use git ls-remote to obtain a target state, and
2691 # git fetch to try to generate it. If we don't manage to generate
2692 # the target state, we try again.
2694 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2696 my $specre = join '|', map {
2699 my $wildcard = $x =~ s/\\\*$/.*/;
2700 die if $wildcard && $supplementary;
2703 printdebug "git_lrfetch_sane specre=$specre\n";
2704 my $wanted_rref = sub {
2706 return m/^(?:$specre)$/;
2709 my $fetch_iteration = 0;
2712 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2713 if (++$fetch_iteration > 10) {
2714 fail "too many iterations trying to get sane fetch!";
2717 my @look = map { "refs/$_" } @specs;
2718 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2722 open GITLS, "-|", @lcmd or die $!;
2724 printdebug "=> ", $_;
2725 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2726 my ($objid,$rrefname) = ($1,$2);
2727 if (!$wanted_rref->($rrefname)) {
2729 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2733 $wantr{$rrefname} = $objid;
2736 close GITLS or failedcmd @lcmd;
2738 # OK, now %want is exactly what we want for refs in @specs
2740 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2741 "+refs/$_:".lrfetchrefs."/$_";
2744 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2746 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2747 runcmd_ordryrun_local @fcmd if @fspecs;
2749 if (!$supplementary) {
2750 %lrfetchrefs_f = ();
2754 git_for_each_ref(lrfetchrefs, sub {
2755 my ($objid,$objtype,$lrefname,$reftail) = @_;
2756 $lrfetchrefs_f{$lrefname} = $objid;
2757 $objgot{$objid} = 1;
2760 if ($supplementary) {
2764 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2765 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2766 if (!exists $wantr{$rrefname}) {
2767 if ($wanted_rref->($rrefname)) {
2769 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2773 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2776 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2777 delete $lrfetchrefs_f{$lrefname};
2781 foreach my $rrefname (sort keys %wantr) {
2782 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2783 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2784 my $want = $wantr{$rrefname};
2785 next if $got eq $want;
2786 if (!defined $objgot{$want}) {
2787 fail <<END unless act_local();
2788 --dry-run specified but we actually wanted the results of git fetch,
2789 so this is not going to work. Try running dgit fetch first,
2790 or using --damp-run instead of --dry-run.
2793 warning: git ls-remote suggests we want $lrefname
2794 warning: and it should refer to $want
2795 warning: but git fetch didn't fetch that object to any relevant ref.
2796 warning: This may be due to a race with someone updating the server.
2797 warning: Will try again...
2799 next FETCH_ITERATION;
2802 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2804 runcmd_ordryrun_local @git, qw(update-ref -m),
2805 "dgit fetch git fetch fixup", $lrefname, $want;
2806 $lrfetchrefs_f{$lrefname} = $want;
2811 if (defined $csuite) {
2812 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2813 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2814 my ($objid,$objtype,$lrefname,$reftail) = @_;
2815 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2816 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2820 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2821 Dumper(\%lrfetchrefs_f);
2824 sub git_fetch_us () {
2825 # Want to fetch only what we are going to use, unless
2826 # deliberately-not-ff, in which case we must fetch everything.
2828 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2830 (quiltmode_splitbrain
2831 ? (map { $_->('*',access_nomdistro) }
2832 \&debiantag_new, \&debiantag_maintview)
2833 : debiantags('*',access_nomdistro));
2834 push @specs, server_branch($csuite);
2835 push @specs, $rewritemap;
2836 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2838 my $url = access_giturl();
2839 git_lrfetch_sane $url, 0, @specs;
2842 my @tagpats = debiantags('*',access_nomdistro);
2844 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2845 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2846 printdebug "currently $fullrefname=$objid\n";
2847 $here{$fullrefname} = $objid;
2849 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2850 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2851 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2852 printdebug "offered $lref=$objid\n";
2853 if (!defined $here{$lref}) {
2854 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2855 runcmd_ordryrun_local @upd;
2856 lrfetchref_used $fullrefname;
2857 } elsif ($here{$lref} eq $objid) {
2858 lrfetchref_used $fullrefname;
2861 "Not updating $lref from $here{$lref} to $objid.\n";
2866 #---------- dsc and archive handling ----------
2868 sub mergeinfo_getclogp ($) {
2869 # Ensures thit $mi->{Clogp} exists and returns it
2871 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2874 sub mergeinfo_version ($) {
2875 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2878 sub fetch_from_archive_record_1 ($) {
2880 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2881 cmdoutput @git, qw(log -n2), $hash;
2882 # ... gives git a chance to complain if our commit is malformed
2885 sub fetch_from_archive_record_2 ($) {
2887 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2891 dryrun_report @upd_cmd;
2895 sub parse_dsc_field_def_dsc_distro () {
2896 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2897 dgit.default.distro);
2900 sub parse_dsc_field ($$) {
2901 my ($dsc, $what) = @_;
2903 foreach my $field (@ourdscfield) {
2904 $f = $dsc->{$field};
2909 progress "$what: NO git hash";
2910 parse_dsc_field_def_dsc_distro();
2911 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2912 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2913 progress "$what: specified git info ($dsc_distro)";
2914 $dsc_hint_tag = [ $dsc_hint_tag ];
2915 } elsif ($f =~ m/^\w+\s*$/) {
2917 parse_dsc_field_def_dsc_distro();
2918 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2920 progress "$what: specified git hash";
2922 fail "$what: invalid Dgit info";
2926 sub resolve_dsc_field_commit ($$) {
2927 my ($already_distro, $already_mapref) = @_;
2929 return unless defined $dsc_hash;
2932 defined $already_mapref &&
2933 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2934 ? $already_mapref : undef;
2938 my ($what, @fetch) = @_;
2940 local $idistro = $dsc_distro;
2941 my $lrf = lrfetchrefs;
2943 if (!$chase_dsc_distro) {
2945 "not chasing .dsc distro $dsc_distro: not fetching $what";
2950 ".dsc names distro $dsc_distro: fetching $what";
2952 my $url = access_giturl();
2953 if (!defined $url) {
2954 defined $dsc_hint_url or fail <<END;
2955 .dsc Dgit metadata is in context of distro $dsc_distro
2956 for which we have no configured url and .dsc provides no hint
2959 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2960 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2961 parse_cfg_bool "dsc-url-proto-ok", 'false',
2962 cfg("dgit.dsc-url-proto-ok.$proto",
2963 "dgit.default.dsc-url-proto-ok")
2965 .dsc Dgit metadata is in context of distro $dsc_distro
2966 for which we have no configured url;
2967 .dsc provides hinted url with protocol $proto which is unsafe.
2968 (can be overridden by config - consult documentation)
2970 $url = $dsc_hint_url;
2973 git_lrfetch_sane $url, 1, @fetch;
2978 my $rewrite_enable = do {
2979 local $idistro = $dsc_distro;
2980 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2983 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2984 if (!defined $mapref) {
2985 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2986 $mapref = $lrf.'/'.$rewritemap;
2988 my $rewritemapdata = git_cat_file $mapref.':map';
2989 if (defined $rewritemapdata
2990 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2992 "server's git history rewrite map contains a relevant entry!";
2995 if (defined $dsc_hash) {
2996 progress "using rewritten git hash in place of .dsc value";
2998 progress "server data says .dsc hash is to be disregarded";
3003 if (!defined git_cat_file $dsc_hash) {
3004 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3005 my $lrf = $do_fetch->("additional commits", @tags) &&
3006 defined git_cat_file $dsc_hash
3008 .dsc Dgit metadata requires commit $dsc_hash
3009 but we could not obtain that object anywhere.
3011 foreach my $t (@tags) {
3012 my $fullrefname = $lrf.'/'.$t;
3013 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3014 next unless $lrfetchrefs_f{$fullrefname};
3015 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3016 lrfetchref_used $fullrefname;
3021 sub fetch_from_archive () {
3022 ensure_setup_existing_tree();
3024 # Ensures that lrref() is what is actually in the archive, one way
3025 # or another, according to us - ie this client's
3026 # appropritaely-updated archive view. Also returns the commit id.
3027 # If there is nothing in the archive, leaves lrref alone and
3028 # returns undef. git_fetch_us must have already been called.
3032 parse_dsc_field($dsc, 'last upload to archive');
3033 resolve_dsc_field_commit access_basedistro,
3034 lrfetchrefs."/".$rewritemap
3036 progress "no version available from the archive";
3039 # If the archive's .dsc has a Dgit field, there are three
3040 # relevant git commitids we need to choose between and/or merge
3042 # 1. $dsc_hash: the Dgit field from the archive
3043 # 2. $lastpush_hash: the suite branch on the dgit git server
3044 # 3. $lastfetch_hash: our local tracking brach for the suite
3046 # These may all be distinct and need not be in any fast forward
3049 # If the dsc was pushed to this suite, then the server suite
3050 # branch will have been updated; but it might have been pushed to
3051 # a different suite and copied by the archive. Conversely a more
3052 # recent version may have been pushed with dgit but not appeared
3053 # in the archive (yet).
3055 # $lastfetch_hash may be awkward because archive imports
3056 # (particularly, imports of Dgit-less .dscs) are performed only as
3057 # needed on individual clients, so different clients may perform a
3058 # different subset of them - and these imports are only made
3059 # public during push. So $lastfetch_hash may represent a set of
3060 # imports different to a subsequent upload by a different dgit
3063 # Our approach is as follows:
3065 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3066 # descendant of $dsc_hash, then it was pushed by a dgit user who
3067 # had based their work on $dsc_hash, so we should prefer it.
3068 # Otherwise, $dsc_hash was installed into this suite in the
3069 # archive other than by a dgit push, and (necessarily) after the
3070 # last dgit push into that suite (since a dgit push would have
3071 # been descended from the dgit server git branch); thus, in that
3072 # case, we prefer the archive's version (and produce a
3073 # pseudo-merge to overwrite the dgit server git branch).
3075 # (If there is no Dgit field in the archive's .dsc then
3076 # generate_commit_from_dsc uses the version numbers to decide
3077 # whether the suite branch or the archive is newer. If the suite
3078 # branch is newer it ignores the archive's .dsc; otherwise it
3079 # generates an import of the .dsc, and produces a pseudo-merge to
3080 # overwrite the suite branch with the archive contents.)
3082 # The outcome of that part of the algorithm is the `public view',
3083 # and is same for all dgit clients: it does not depend on any
3084 # unpublished history in the local tracking branch.
3086 # As between the public view and the local tracking branch: The
3087 # local tracking branch is only updated by dgit fetch, and
3088 # whenever dgit fetch runs it includes the public view in the
3089 # local tracking branch. Therefore if the public view is not
3090 # descended from the local tracking branch, the local tracking
3091 # branch must contain history which was imported from the archive
3092 # but never pushed; and, its tip is now out of date. So, we make
3093 # a pseudo-merge to overwrite the old imports and stitch the old
3096 # Finally: we do not necessarily reify the public view (as
3097 # described above). This is so that we do not end up stacking two
3098 # pseudo-merges. So what we actually do is figure out the inputs
3099 # to any public view pseudo-merge and put them in @mergeinputs.
3102 # $mergeinputs[]{Commit}
3103 # $mergeinputs[]{Info}
3104 # $mergeinputs[0] is the one whose tree we use
3105 # @mergeinputs is in the order we use in the actual commit)
3108 # $mergeinputs[]{Message} is a commit message to use
3109 # $mergeinputs[]{ReverseParents} if def specifies that parent
3110 # list should be in opposite order
3111 # Such an entry has no Commit or Info. It applies only when found
3112 # in the last entry. (This ugliness is to support making
3113 # identical imports to previous dgit versions.)
3115 my $lastpush_hash = git_get_ref(lrfetchref());
3116 printdebug "previous reference hash=$lastpush_hash\n";
3117 $lastpush_mergeinput = $lastpush_hash && {
3118 Commit => $lastpush_hash,
3119 Info => "dgit suite branch on dgit git server",
3122 my $lastfetch_hash = git_get_ref(lrref());
3123 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3124 my $lastfetch_mergeinput = $lastfetch_hash && {
3125 Commit => $lastfetch_hash,
3126 Info => "dgit client's archive history view",
3129 my $dsc_mergeinput = $dsc_hash && {
3130 Commit => $dsc_hash,
3131 Info => "Dgit field in .dsc from archive",
3135 my $del_lrfetchrefs = sub {
3138 printdebug "del_lrfetchrefs...\n";
3139 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3140 my $objid = $lrfetchrefs_d{$fullrefname};
3141 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3143 $gur ||= new IO::Handle;
3144 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3146 printf $gur "delete %s %s\n", $fullrefname, $objid;
3149 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3153 if (defined $dsc_hash) {
3154 ensure_we_have_orig();
3155 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3156 @mergeinputs = $dsc_mergeinput
3157 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3158 print STDERR <<END or die $!;
3160 Git commit in archive is behind the last version allegedly pushed/uploaded.
3161 Commit referred to by archive: $dsc_hash
3162 Last version pushed with dgit: $lastpush_hash
3165 @mergeinputs = ($lastpush_mergeinput);
3167 # Archive has .dsc which is not a descendant of the last dgit
3168 # push. This can happen if the archive moves .dscs about.
3169 # Just follow its lead.
3170 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3171 progress "archive .dsc names newer git commit";
3172 @mergeinputs = ($dsc_mergeinput);
3174 progress "archive .dsc names other git commit, fixing up";
3175 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3179 @mergeinputs = generate_commits_from_dsc();
3180 # We have just done an import. Now, our import algorithm might
3181 # have been improved. But even so we do not want to generate
3182 # a new different import of the same package. So if the
3183 # version numbers are the same, just use our existing version.
3184 # If the version numbers are different, the archive has changed
3185 # (perhaps, rewound).
3186 if ($lastfetch_mergeinput &&
3187 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3188 (mergeinfo_version $mergeinputs[0]) )) {
3189 @mergeinputs = ($lastfetch_mergeinput);
3191 } elsif ($lastpush_hash) {
3192 # only in git, not in the archive yet
3193 @mergeinputs = ($lastpush_mergeinput);
3194 print STDERR <<END or die $!;
3196 Package not found in the archive, but has allegedly been pushed using dgit.
3200 printdebug "nothing found!\n";
3201 if (defined $skew_warning_vsn) {
3202 print STDERR <<END or die $!;
3204 Warning: relevant archive skew detected.
3205 Archive allegedly contains $skew_warning_vsn
3206 But we were not able to obtain any version from the archive or git.
3210 unshift @end, $del_lrfetchrefs;
3214 if ($lastfetch_hash &&
3216 my $h = $_->{Commit};
3217 $h and is_fast_fwd($lastfetch_hash, $h);
3218 # If true, one of the existing parents of this commit
3219 # is a descendant of the $lastfetch_hash, so we'll
3220 # be ff from that automatically.
3224 push @mergeinputs, $lastfetch_mergeinput;
3227 printdebug "fetch mergeinfos:\n";
3228 foreach my $mi (@mergeinputs) {
3230 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3232 printdebug sprintf " ReverseParents=%d Message=%s",
3233 $mi->{ReverseParents}, $mi->{Message};
3237 my $compat_info= pop @mergeinputs
3238 if $mergeinputs[$#mergeinputs]{Message};
3240 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3243 if (@mergeinputs > 1) {
3245 my $tree_commit = $mergeinputs[0]{Commit};
3247 my $tree = get_tree_of_commit $tree_commit;;
3249 # We use the changelog author of the package in question the
3250 # author of this pseudo-merge. This is (roughly) correct if
3251 # this commit is simply representing aa non-dgit upload.
3252 # (Roughly because it does not record sponsorship - but we
3253 # don't have sponsorship info because that's in the .changes,
3254 # which isn't in the archivw.)
3256 # But, it might be that we are representing archive history
3257 # updates (including in-archive copies). These are not really
3258 # the responsibility of the person who created the .dsc, but
3259 # there is no-one whose name we should better use. (The
3260 # author of the .dsc-named commit is clearly worse.)
3262 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3263 my $author = clogp_authline $useclogp;
3264 my $cversion = getfield $useclogp, 'Version';
3266 my $mcf = dgit_privdir()."/mergecommit";
3267 open MC, ">", $mcf or die "$mcf $!";
3268 print MC <<END or die $!;
3272 my @parents = grep { $_->{Commit} } @mergeinputs;
3273 @parents = reverse @parents if $compat_info->{ReverseParents};
3274 print MC <<END or die $! foreach @parents;
3278 print MC <<END or die $!;
3284 if (defined $compat_info->{Message}) {
3285 print MC $compat_info->{Message} or die $!;
3287 print MC <<END or die $!;
3288 Record $package ($cversion) in archive suite $csuite
3292 my $message_add_info = sub {
3294 my $mversion = mergeinfo_version $mi;
3295 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3299 $message_add_info->($mergeinputs[0]);
3300 print MC <<END or die $!;
3301 should be treated as descended from
3303 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3307 $hash = make_commit $mcf;
3309 $hash = $mergeinputs[0]{Commit};
3311 printdebug "fetch hash=$hash\n";
3314 my ($lasth, $what) = @_;
3315 return unless $lasth;
3316 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3319 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3321 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3323 fetch_from_archive_record_1($hash);
3325 if (defined $skew_warning_vsn) {
3326 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3327 my $gotclogp = commit_getclogp($hash);
3328 my $got_vsn = getfield $gotclogp, 'Version';
3329 printdebug "SKEW CHECK GOT $got_vsn\n";
3330 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3331 print STDERR <<END or die $!;
3333 Warning: archive skew detected. Using the available version:
3334 Archive allegedly contains $skew_warning_vsn
3335 We were able to obtain only $got_vsn
3341 if ($lastfetch_hash ne $hash) {
3342 fetch_from_archive_record_2($hash);
3345 lrfetchref_used lrfetchref();
3347 check_gitattrs($hash, "fetched source tree");
3349 unshift @end, $del_lrfetchrefs;
3353 sub set_local_git_config ($$) {
3355 runcmd @git, qw(config), $k, $v;
3358 sub setup_mergechangelogs (;$) {
3360 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3362 my $driver = 'dpkg-mergechangelogs';
3363 my $cb = "merge.$driver";
3364 confess unless defined $maindir;
3365 my $attrs = "$maindir_gitcommon/info/attributes";
3366 ensuredir "$maindir_gitcommon/info";
3368 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3369 if (!open ATTRS, "<", $attrs) {
3370 $!==ENOENT or die "$attrs: $!";
3374 next if m{^debian/changelog\s};
3375 print NATTRS $_, "\n" or die $!;
3377 ATTRS->error and die $!;
3380 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3383 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3384 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3386 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3389 sub setup_useremail (;$) {
3391 return unless $always || access_cfg_bool(1, 'setup-useremail');
3394 my ($k, $envvar) = @_;
3395 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3396 return unless defined $v;
3397 set_local_git_config "user.$k", $v;
3400 $setup->('email', 'DEBEMAIL');
3401 $setup->('name', 'DEBFULLNAME');
3404 sub ensure_setup_existing_tree () {
3405 my $k = "remote.$remotename.skipdefaultupdate";
3406 my $c = git_get_config $k;
3407 return if defined $c;
3408 set_local_git_config $k, 'true';
3411 sub open_main_gitattrs () {
3412 confess 'internal error no maindir' unless defined $maindir;
3413 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3415 or die "open $maindir_gitcommon/info/attributes: $!";
3419 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3421 sub is_gitattrs_setup () {
3424 # 1: gitattributes set up and should be left alone
3426 # 0: there is a dgit-defuse-attrs but it needs fixing
3427 # undef: there is none
3428 my $gai = open_main_gitattrs();
3429 return 0 unless $gai;
3431 next unless m{$gitattrs_ourmacro_re};
3432 return 1 if m{\s-working-tree-encoding\s};
3433 printdebug "is_gitattrs_setup: found old macro\n";
3436 $gai->error and die $!;
3437 printdebug "is_gitattrs_setup: found nothing\n";
3441 sub setup_gitattrs (;$) {
3443 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3445 my $already = is_gitattrs_setup();
3448 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3449 not doing further gitattributes setup
3453 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3454 my $af = "$maindir_gitcommon/info/attributes";
3455 ensuredir "$maindir_gitcommon/info";
3457 open GAO, "> $af.new" or die $!;
3458 print GAO <<END or die $! unless defined $already;
3461 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3463 my $gai = open_main_gitattrs();
3466 if (m{$gitattrs_ourmacro_re}) {
3467 die unless defined $already;
3471 print GAO $_, "\n" or die $!;
3473 $gai->error and die $!;
3475 close GAO or die $!;
3476 rename "$af.new", "$af" or die "install $af: $!";
3479 sub setup_new_tree () {
3480 setup_mergechangelogs();
3485 sub check_gitattrs ($$) {
3486 my ($treeish, $what) = @_;
3488 return if is_gitattrs_setup;
3491 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3493 my $gafl = new IO::File;
3494 open $gafl, "-|", @cmd or die $!;
3497 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3499 next unless m{(?:^|/)\.gitattributes$};
3501 # oh dear, found one
3503 dgit: warning: $what contains .gitattributes
3504 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3509 # tree contains no .gitattributes files
3510 $?=0; $!=0; close $gafl or failedcmd @cmd;
3514 sub multisuite_suite_child ($$$) {
3515 my ($tsuite, $mergeinputs, $fn) = @_;
3516 # in child, sets things up, calls $fn->(), and returns undef
3517 # in parent, returns canonical suite name for $tsuite
3518 my $canonsuitefh = IO::File::new_tmpfile;
3519 my $pid = fork // die $!;
3523 $us .= " [$isuite]";
3524 $debugprefix .= " ";
3525 progress "fetching $tsuite...";
3526 canonicalise_suite();
3527 print $canonsuitefh $csuite, "\n" or die $!;
3528 close $canonsuitefh or die $!;
3532 waitpid $pid,0 == $pid or die $!;
3533 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3534 seek $canonsuitefh,0,0 or die $!;
3535 local $csuite = <$canonsuitefh>;
3536 die $! unless defined $csuite && chomp $csuite;
3538 printdebug "multisuite $tsuite missing\n";
3541 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3542 push @$mergeinputs, {
3549 sub fork_for_multisuite ($) {
3550 my ($before_fetch_merge) = @_;
3551 # if nothing unusual, just returns ''
3554 # returns 0 to caller in child, to do first of the specified suites
3555 # in child, $csuite is not yet set
3557 # returns 1 to caller in parent, to finish up anything needed after
3558 # in parent, $csuite is set to canonicalised portmanteau
3560 my $org_isuite = $isuite;
3561 my @suites = split /\,/, $isuite;
3562 return '' unless @suites > 1;
3563 printdebug "fork_for_multisuite: @suites\n";
3567 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3569 return 0 unless defined $cbasesuite;
3571 fail "package $package missing in (base suite) $cbasesuite"
3572 unless @mergeinputs;
3574 my @csuites = ($cbasesuite);
3576 $before_fetch_merge->();
3578 foreach my $tsuite (@suites[1..$#suites]) {
3579 $tsuite =~ s/^-/$cbasesuite-/;
3580 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3587 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3588 push @csuites, $csubsuite;
3591 foreach my $mi (@mergeinputs) {
3592 my $ref = git_get_ref $mi->{Ref};
3593 die "$mi->{Ref} ?" unless length $ref;
3594 $mi->{Commit} = $ref;
3597 $csuite = join ",", @csuites;
3599 my $previous = git_get_ref lrref;
3601 unshift @mergeinputs, {
3602 Commit => $previous,
3603 Info => "local combined tracking branch",
3605 "archive seems to have rewound: local tracking branch is ahead!",
3609 foreach my $ix (0..$#mergeinputs) {
3610 $mergeinputs[$ix]{Index} = $ix;
3613 @mergeinputs = sort {
3614 -version_compare(mergeinfo_version $a,
3615 mergeinfo_version $b) # highest version first
3617 $a->{Index} <=> $b->{Index}; # earliest in spec first
3623 foreach my $mi (@mergeinputs) {
3624 printdebug "multisuite merge check $mi->{Info}\n";
3625 foreach my $previous (@needed) {
3626 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3627 printdebug "multisuite merge un-needed $previous->{Info}\n";
3631 printdebug "multisuite merge this-needed\n";
3632 $mi->{Character} = '+';
3635 $needed[0]{Character} = '*';
3637 my $output = $needed[0]{Commit};
3640 printdebug "multisuite merge nontrivial\n";
3641 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3643 my $commit = "tree $tree\n";
3644 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3645 "Input branches:\n";
3647 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3648 printdebug "multisuite merge include $mi->{Info}\n";
3649 $mi->{Character} //= ' ';
3650 $commit .= "parent $mi->{Commit}\n";
3651 $msg .= sprintf " %s %-25s %s\n",
3653 (mergeinfo_version $mi),
3656 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3658 " * marks the highest version branch, which choose to use\n".
3659 " + marks each branch which was not already an ancestor\n\n".
3660 "[dgit multi-suite $csuite]\n";
3662 "author $authline\n".
3663 "committer $authline\n\n";
3664 $output = make_commit_text $commit.$msg;
3665 printdebug "multisuite merge generated $output\n";
3668 fetch_from_archive_record_1($output);
3669 fetch_from_archive_record_2($output);
3671 progress "calculated combined tracking suite $csuite";
3676 sub clone_set_head () {
3677 open H, "> .git/HEAD" or die $!;
3678 print H "ref: ".lref()."\n" or die $!;
3681 sub clone_finish ($) {
3683 runcmd @git, qw(reset --hard), lrref();
3684 runcmd qw(bash -ec), <<'END';
3686 git ls-tree -r --name-only -z HEAD | \
3687 xargs -0r touch -h -r . --
3689 printdone "ready for work in $dstdir";
3693 # in multisuite, returns twice!
3694 # once in parent after first suite fetched,
3695 # and then again in child after everything is finished
3697 badusage "dry run makes no sense with clone" unless act_local();
3699 my $multi_fetched = fork_for_multisuite(sub {
3700 printdebug "multi clone before fetch merge\n";
3704 if ($multi_fetched) {
3705 printdebug "multi clone after fetch merge\n";
3707 clone_finish($dstdir);
3710 printdebug "clone main body\n";
3712 canonicalise_suite();
3713 my $hasgit = check_for_git();
3714 mkdir $dstdir or fail "create \`$dstdir': $!";
3716 runcmd @git, qw(init -q);
3720 my $giturl = access_giturl(1);
3721 if (defined $giturl) {
3722 runcmd @git, qw(remote add), 'origin', $giturl;
3725 progress "fetching existing git history";
3727 runcmd_ordryrun_local @git, qw(fetch origin);
3729 progress "starting new git history";
3731 fetch_from_archive() or no_such_package;
3732 my $vcsgiturl = $dsc->{'Vcs-Git'};
3733 if (length $vcsgiturl) {
3734 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3735 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3737 clone_finish($dstdir);
3741 canonicalise_suite();
3742 if (check_for_git()) {
3745 fetch_from_archive() or no_such_package();
3747 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3748 if (length $vcsgiturl and
3749 (grep { $csuite eq $_ }
3751 cfg 'dgit.vcs-git.suites')) {
3752 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3753 if (defined $current && $current ne $vcsgiturl) {
3755 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3756 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3760 printdone "fetched into ".lrref();
3764 my $multi_fetched = fork_for_multisuite(sub { });
3765 fetch_one() unless $multi_fetched; # parent
3766 finish 0 if $multi_fetched eq '0'; # child
3771 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3773 printdone "fetched to ".lrref()." and merged into HEAD";
3776 sub check_not_dirty () {
3777 foreach my $f (qw(local-options local-patch-header)) {
3778 if (stat_exists "debian/source/$f") {
3779 fail "git tree contains debian/source/$f";
3783 return if $includedirty;
3785 git_check_unmodified();
3788 sub commit_admin ($) {
3791 runcmd_ordryrun_local @git, qw(commit -m), $m;
3794 sub quiltify_nofix_bail ($$) {
3795 my ($headinfo, $xinfo) = @_;
3796 if ($quilt_mode eq 'nofix') {
3797 fail "quilt fixup required but quilt mode is \`nofix'\n".
3798 "HEAD commit".$headinfo." differs from tree implied by ".
3799 " debian/patches".$xinfo;
3803 sub commit_quilty_patch () {
3804 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3806 foreach my $l (split /\n/, $output) {
3807 next unless $l =~ m/\S/;
3808 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3812 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3814 progress "nothing quilty to commit, ok.";
3817 quiltify_nofix_bail "", " (wanted to commit patch update)";
3818 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3819 runcmd_ordryrun_local @git, qw(add -f), @adds;
3821 Commit Debian 3.0 (quilt) metadata
3823 [dgit ($our_version) quilt-fixup]
3827 sub get_source_format () {
3829 if (open F, "debian/source/options") {
3833 s/\s+$//; # ignore missing final newline
3835 my ($k, $v) = ($`, $'); #');
3836 $v =~ s/^"(.*)"$/$1/;
3842 F->error and die $!;
3845 die $! unless $!==&ENOENT;
3848 if (!open F, "debian/source/format") {
3849 die $! unless $!==&ENOENT;
3853 F->error and die $!;
3855 return ($_, \%options);
3858 sub madformat_wantfixup ($) {
3860 return 0 unless $format eq '3.0 (quilt)';
3861 our $quilt_mode_warned;
3862 if ($quilt_mode eq 'nocheck') {
3863 progress "Not doing any fixup of \`$format' due to".
3864 " ----no-quilt-fixup or --quilt=nocheck"
3865 unless $quilt_mode_warned++;
3868 progress "Format \`$format', need to check/update patch stack"
3869 unless $quilt_mode_warned++;
3873 sub maybe_split_brain_save ($$$) {
3874 my ($headref, $dgitview, $msg) = @_;
3875 # => message fragment "$saved" describing disposition of $dgitview
3876 my $save = $internal_object_save{'dgit-view'};
3877 return "commit id $dgitview" unless defined $save;
3878 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3880 "dgit --dgit-view-save $msg HEAD=$headref",
3883 return "and left in $save";
3886 # An "infopair" is a tuple [ $thing, $what ]
3887 # (often $thing is a commit hash; $what is a description)
3889 sub infopair_cond_equal ($$) {
3891 $x->[0] eq $y->[0] or fail <<END;
3892 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3896 sub infopair_lrf_tag_lookup ($$) {
3897 my ($tagnames, $what) = @_;
3898 # $tagname may be an array ref
3899 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3900 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3901 foreach my $tagname (@tagnames) {
3902 my $lrefname = lrfetchrefs."/tags/$tagname";
3903 my $tagobj = $lrfetchrefs_f{$lrefname};
3904 next unless defined $tagobj;
3905 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3906 return [ git_rev_parse($tagobj), $what ];
3908 fail @tagnames==1 ? <<END : <<END;
3909 Wanted tag $what (@tagnames) on dgit server, but not found
3911 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3915 sub infopair_cond_ff ($$) {
3916 my ($anc,$desc) = @_;
3917 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3918 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3922 sub pseudomerge_version_check ($$) {
3923 my ($clogp, $archive_hash) = @_;
3925 my $arch_clogp = commit_getclogp $archive_hash;
3926 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3927 'version currently in archive' ];
3928 if (defined $overwrite_version) {
3929 if (length $overwrite_version) {
3930 infopair_cond_equal([ $overwrite_version,
3931 '--overwrite= version' ],
3934 my $v = $i_arch_v->[0];
3935 progress "Checking package changelog for archive version $v ...";
3938 my @xa = ("-f$v", "-t$v");
3939 my $vclogp = parsechangelog @xa;
3942 [ (getfield $vclogp, $fn),
3943 "$fn field from dpkg-parsechangelog @xa" ];
3945 my $cv = $gf->('Version');
3946 infopair_cond_equal($i_arch_v, $cv);
3947 $cd = $gf->('Distribution');
3950 $@ =~ s/^dgit: //gm;
3952 "Perhaps debian/changelog does not mention $v ?";
3954 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3955 $cd->[1] is $cd->[0]
3956 Your tree seems to based on earlier (not uploaded) $v.
3961 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3965 sub pseudomerge_make_commit ($$$$ $$) {
3966 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3967 $msg_cmd, $msg_msg) = @_;
3968 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3970 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3971 my $authline = clogp_authline $clogp;
3975 !defined $overwrite_version ? ""
3976 : !length $overwrite_version ? " --overwrite"
3977 : " --overwrite=".$overwrite_version;
3979 # Contributing parent is the first parent - that makes
3980 # git rev-list --first-parent DTRT.
3981 my $pmf = dgit_privdir()."/pseudomerge";
3982 open MC, ">", $pmf or die "$pmf $!";
3983 print MC <<END or die $!;
3986 parent $archive_hash
3996 return make_commit($pmf);
3999 sub splitbrain_pseudomerge ($$$$) {
4000 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4001 # => $merged_dgitview
4002 printdebug "splitbrain_pseudomerge...\n";
4004 # We: debian/PREVIOUS HEAD($maintview)
4005 # expect: o ----------------- o
4008 # a/d/PREVIOUS $dgitview
4011 # we do: `------------------ o
4015 return $dgitview unless defined $archive_hash;
4016 return $dgitview if deliberately_not_fast_forward();
4018 printdebug "splitbrain_pseudomerge...\n";
4020 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4022 if (!defined $overwrite_version) {
4023 progress "Checking that HEAD inciudes all changes in archive...";
4026 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4028 if (defined $overwrite_version) {
4030 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4031 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
4032 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4033 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
4034 my $i_archive = [ $archive_hash, "current archive contents" ];
4036 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4038 infopair_cond_equal($i_dgit, $i_archive);
4039 infopair_cond_ff($i_dep14, $i_dgit);
4040 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4043 $@ =~ s/^\n//; chomp $@;
4046 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4051 my $r = pseudomerge_make_commit
4052 $clogp, $dgitview, $archive_hash, $i_arch_v,
4053 "dgit --quilt=$quilt_mode",
4054 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4055 Declare fast forward from $i_arch_v->[0]
4057 Make fast forward from $i_arch_v->[0]
4060 maybe_split_brain_save $maintview, $r, "pseudomerge";
4062 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4066 sub plain_overwrite_pseudomerge ($$$) {
4067 my ($clogp, $head, $archive_hash) = @_;
4069 printdebug "plain_overwrite_pseudomerge...";
4071 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4073 return $head if is_fast_fwd $archive_hash, $head;
4075 my $m = "Declare fast forward from $i_arch_v->[0]";
4077 my $r = pseudomerge_make_commit
4078 $clogp, $head, $archive_hash, $i_arch_v,
4081 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4083 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4087 sub push_parse_changelog ($) {
4090 my $clogp = Dpkg::Control::Hash->new();
4091 $clogp->load($clogpfn) or die;
4093 my $clogpackage = getfield $clogp, 'Source';
4094 $package //= $clogpackage;
4095 fail "-p specified $package but changelog specified $clogpackage"
4096 unless $package eq $clogpackage;
4097 my $cversion = getfield $clogp, 'Version';
4099 if (!$we_are_initiator) {
4100 # rpush initiator can't do this because it doesn't have $isuite yet
4101 my $tag = debiantag($cversion, access_nomdistro);
4102 runcmd @git, qw(check-ref-format), $tag;
4105 my $dscfn = dscfn($cversion);
4107 return ($clogp, $cversion, $dscfn);
4110 sub push_parse_dsc ($$$) {
4111 my ($dscfn,$dscfnwhat, $cversion) = @_;
4112 $dsc = parsecontrol($dscfn,$dscfnwhat);
4113 my $dversion = getfield $dsc, 'Version';
4114 my $dscpackage = getfield $dsc, 'Source';
4115 ($dscpackage eq $package && $dversion eq $cversion) or
4116 fail "$dscfn is for $dscpackage $dversion".
4117 " but debian/changelog is for $package $cversion";
4120 sub push_tagwants ($$$$) {
4121 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4124 TagFn => \&debiantag,
4129 if (defined $maintviewhead) {
4131 TagFn => \&debiantag_maintview,
4132 Objid => $maintviewhead,
4133 TfSuffix => '-maintview',
4136 } elsif ($dodep14tag eq 'no' ? 0
4137 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4138 : $dodep14tag eq 'always'
4139 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4140 --dep14tag-always (or equivalent in config) means server must support
4141 both "new" and "maint" tag formats, but config says it doesn't.
4143 : die "$dodep14tag ?") {
4145 TagFn => \&debiantag_maintview,
4147 TfSuffix => '-dgit',
4151 foreach my $tw (@tagwants) {
4152 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4153 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4155 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4159 sub push_mktags ($$ $$ $) {
4161 $changesfile,$changesfilewhat,
4164 die unless $tagwants->[0]{View} eq 'dgit';
4166 my $declaredistro = access_nomdistro();
4167 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4168 $dsc->{$ourdscfield[0]} = join " ",
4169 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4171 $dsc->save("$dscfn.tmp") or die $!;
4173 my $changes = parsecontrol($changesfile,$changesfilewhat);
4174 foreach my $field (qw(Source Distribution Version)) {
4175 $changes->{$field} eq $clogp->{$field} or
4176 fail "changes field $field \`$changes->{$field}'".
4177 " does not match changelog \`$clogp->{$field}'";
4180 my $cversion = getfield $clogp, 'Version';
4181 my $clogsuite = getfield $clogp, 'Distribution';
4183 # We make the git tag by hand because (a) that makes it easier
4184 # to control the "tagger" (b) we can do remote signing
4185 my $authline = clogp_authline $clogp;
4186 my $delibs = join(" ", "",@deliberatelies);
4190 my $tfn = $tw->{Tfn};
4191 my $head = $tw->{Objid};
4192 my $tag = $tw->{Tag};
4194 open TO, '>', $tfn->('.tmp') or die $!;
4195 print TO <<END or die $!;
4202 if ($tw->{View} eq 'dgit') {
4203 print TO <<END or die $!;
4204 $package release $cversion for $clogsuite ($csuite) [dgit]
4205 [dgit distro=$declaredistro$delibs]
4207 foreach my $ref (sort keys %previously) {
4208 print TO <<END or die $!;
4209 [dgit previously:$ref=$previously{$ref}]
4212 } elsif ($tw->{View} eq 'maint') {
4213 print TO <<END or die $!;
4214 $package release $cversion for $clogsuite ($csuite)
4215 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4218 die Dumper($tw)."?";
4223 my $tagobjfn = $tfn->('.tmp');
4225 if (!defined $keyid) {
4226 $keyid = access_cfg('keyid','RETURN-UNDEF');
4228 if (!defined $keyid) {
4229 $keyid = getfield $clogp, 'Maintainer';
4231 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4232 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4233 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4234 push @sign_cmd, $tfn->('.tmp');
4235 runcmd_ordryrun @sign_cmd;
4237 $tagobjfn = $tfn->('.signed.tmp');
4238 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4239 $tfn->('.tmp'), $tfn->('.tmp.asc');
4245 my @r = map { $mktag->($_); } @$tagwants;
4249 sub sign_changes ($) {
4250 my ($changesfile) = @_;
4252 my @debsign_cmd = @debsign;
4253 push @debsign_cmd, "-k$keyid" if defined $keyid;
4254 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4255 push @debsign_cmd, $changesfile;
4256 runcmd_ordryrun @debsign_cmd;
4261 printdebug "actually entering push\n";
4263 supplementary_message(<<'END');
4264 Push failed, while checking state of the archive.
4265 You can retry the push, after fixing the problem, if you like.
4267 if (check_for_git()) {
4270 my $archive_hash = fetch_from_archive();
4271 if (!$archive_hash) {
4273 fail "package appears to be new in this suite;".
4274 " if this is intentional, use --new";
4277 supplementary_message(<<'END');
4278 Push failed, while preparing your push.
4279 You can retry the push, after fixing the problem, if you like.
4282 need_tagformat 'new', "quilt mode $quilt_mode"
4283 if quiltmode_splitbrain;
4287 access_giturl(); # check that success is vaguely likely
4288 rpush_handle_protovsn_bothends() if $we_are_initiator;
4291 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4292 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4294 responder_send_file('parsed-changelog', $clogpfn);
4296 my ($clogp, $cversion, $dscfn) =
4297 push_parse_changelog("$clogpfn");
4299 my $dscpath = "$buildproductsdir/$dscfn";
4300 stat_exists $dscpath or
4301 fail "looked for .dsc $dscpath, but $!;".
4302 " maybe you forgot to build";
4304 responder_send_file('dsc', $dscpath);
4306 push_parse_dsc($dscpath, $dscfn, $cversion);
4308 my $format = getfield $dsc, 'Format';
4309 printdebug "format $format\n";
4311 my $symref = git_get_symref();
4312 my $actualhead = git_rev_parse('HEAD');
4314 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4315 if (quiltmode_splitbrain()) {
4316 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4318 Branch is managed by git-debrebase ($ffq_prev
4319 exists), but quilt mode ($quilt_mode) implies a split view.
4320 Pass the right --quilt option or adjust your git config.
4321 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4324 runcmd_ordryrun_local @git_debrebase, 'stitch';
4325 $actualhead = git_rev_parse('HEAD');
4328 my $dgithead = $actualhead;
4329 my $maintviewhead = undef;
4331 my $upstreamversion = upstreamversion $clogp->{Version};
4333 if (madformat_wantfixup($format)) {
4334 # user might have not used dgit build, so maybe do this now:
4335 if (quiltmode_splitbrain()) {
4336 changedir $playground;
4337 quilt_make_fake_dsc($upstreamversion);
4339 ($dgithead, $cachekey) =
4340 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4342 "--quilt=$quilt_mode but no cached dgit view:
4343 perhaps HEAD changed since dgit build[-source] ?";
4345 $dgithead = splitbrain_pseudomerge($clogp,
4346 $actualhead, $dgithead,
4348 $maintviewhead = $actualhead;
4350 prep_ud(); # so _only_subdir() works, below
4352 commit_quilty_patch();
4356 if (defined $overwrite_version && !defined $maintviewhead
4358 $dgithead = plain_overwrite_pseudomerge($clogp,
4366 if ($archive_hash) {
4367 if (is_fast_fwd($archive_hash, $dgithead)) {
4369 } elsif (deliberately_not_fast_forward) {
4372 fail "dgit push: HEAD is not a descendant".
4373 " of the archive's version.\n".
4374 "To overwrite the archive's contents,".
4375 " pass --overwrite[=VERSION].\n".
4376 "To rewind history, if permitted by the archive,".
4377 " use --deliberately-not-fast-forward.";
4381 changedir $playground;
4382 progress "checking that $dscfn corresponds to HEAD";
4383 runcmd qw(dpkg-source -x --),
4384 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4385 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4386 check_for_vendor_patches() if madformat($dsc->{format});
4388 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4389 debugcmd "+",@diffcmd;
4391 my $r = system @diffcmd;
4394 my $referent = $split_brain ? $dgithead : 'HEAD';
4395 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4398 my $raw = cmdoutput @git,
4399 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4401 foreach (split /\0/, $raw) {
4402 if (defined $changed) {
4403 push @mode_changes, "$changed: $_\n" if $changed;
4406 } elsif (m/^:0+ 0+ /) {
4408 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4409 $changed = "Mode change from $1 to $2"
4414 if (@mode_changes) {
4415 fail <<END.(join '', @mode_changes).<<END;
4416 HEAD specifies a different tree to $dscfn:
4419 There is a problem with your source tree (see dgit(7) for some hints).
4420 To see a full diff, run git diff $tree $referent
4425 HEAD specifies a different tree to $dscfn:
4427 Perhaps you forgot to build. Or perhaps there is a problem with your
4428 source tree (see dgit(7) for some hints). To see a full diff, run
4429 git diff $tree $referent
4435 if (!$changesfile) {
4436 my $pat = changespat $cversion;
4437 my @cs = glob "$buildproductsdir/$pat";
4438 fail "failed to find unique changes file".
4439 " (looked for $pat in $buildproductsdir);".
4440 " perhaps you need to use dgit -C"
4442 ($changesfile) = @cs;
4444 $changesfile = "$buildproductsdir/$changesfile";
4447 # Check that changes and .dsc agree enough
4448 $changesfile =~ m{[^/]*$};
4449 my $changes = parsecontrol($changesfile,$&);
4450 files_compare_inputs($dsc, $changes)
4451 unless forceing [qw(dsc-changes-mismatch)];
4453 # Check whether this is a source only upload
4454 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4455 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4456 if ($sourceonlypolicy eq 'ok') {
4457 } elsif ($sourceonlypolicy eq 'always') {
4458 forceable_fail [qw(uploading-binaries)],
4459 "uploading binaries, although distroy policy is source only"
4461 } elsif ($sourceonlypolicy eq 'never') {
4462 forceable_fail [qw(uploading-source-only)],
4463 "source-only upload, although distroy policy requires .debs"
4465 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4466 forceable_fail [qw(uploading-source-only)],
4467 "source-only upload, even though package is entirely NEW\n".
4468 "(this is contrary to policy in ".(access_nomdistro()).")"
4471 && !(archive_query('package_not_wholly_new', $package) // 1);
4473 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4476 # Perhaps adjust .dsc to contain right set of origs
4477 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4479 unless forceing [qw(changes-origs-exactly)];
4481 # Checks complete, we're going to try and go ahead:
4483 responder_send_file('changes',$changesfile);
4484 responder_send_command("param head $dgithead");
4485 responder_send_command("param csuite $csuite");
4486 responder_send_command("param isuite $isuite");
4487 responder_send_command("param tagformat $tagformat");
4488 if (defined $maintviewhead) {
4489 confess "internal error (protovsn=$protovsn)"
4490 if defined $protovsn and $protovsn < 4;
4491 responder_send_command("param maint-view $maintviewhead");
4494 # Perhaps send buildinfo(s) for signing
4495 my $changes_files = getfield $changes, 'Files';
4496 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4497 foreach my $bi (@buildinfos) {
4498 responder_send_command("param buildinfo-filename $bi");
4499 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4502 if (deliberately_not_fast_forward) {
4503 git_for_each_ref(lrfetchrefs, sub {
4504 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4505 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4506 responder_send_command("previously $rrefname=$objid");
4507 $previously{$rrefname} = $objid;
4511 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4512 dgit_privdir()."/tag");
4515 supplementary_message(<<'END');
4516 Push failed, while signing the tag.
4517 You can retry the push, after fixing the problem, if you like.
4519 # If we manage to sign but fail to record it anywhere, it's fine.
4520 if ($we_are_responder) {
4521 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4522 responder_receive_files('signed-tag', @tagobjfns);
4524 @tagobjfns = push_mktags($clogp,$dscpath,
4525 $changesfile,$changesfile,
4528 supplementary_message(<<'END');
4529 Push failed, *after* signing the tag.
4530 If you want to try again, you should use a new version number.
4533 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4535 foreach my $tw (@tagwants) {
4536 my $tag = $tw->{Tag};
4537 my $tagobjfn = $tw->{TagObjFn};
4539 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4540 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4541 runcmd_ordryrun_local
4542 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4545 supplementary_message(<<'END');
4546 Push failed, while updating the remote git repository - see messages above.
4547 If you want to try again, you should use a new version number.
4549 if (!check_for_git()) {
4550 create_remote_git_repo();
4553 my @pushrefs = $forceflag.$dgithead.":".rrref();
4554 foreach my $tw (@tagwants) {
4555 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4558 runcmd_ordryrun @git,
4559 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4560 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4562 supplementary_message(<<'END');
4563 Push failed, while obtaining signatures on the .changes and .dsc.
4564 If it was just that the signature failed, you may try again by using
4565 debsign by hand to sign the changes file (see the command dgit tried,
4566 above), and then dput that changes file to complete the upload.
4567 If you need to change the package, you must use a new version number.
4569 if ($we_are_responder) {
4570 my $dryrunsuffix = act_local() ? "" : ".tmp";
4571 my @rfiles = ($dscpath, $changesfile);
4572 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4573 responder_receive_files('signed-dsc-changes',
4574 map { "$_$dryrunsuffix" } @rfiles);
4577 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4579 progress "[new .dsc left in $dscpath.tmp]";
4581 sign_changes $changesfile;
4584 supplementary_message(<<END);
4585 Push failed, while uploading package(s) to the archive server.
4586 You can retry the upload of exactly these same files with dput of:
4588 If that .changes file is broken, you will need to use a new version
4589 number for your next attempt at the upload.
4591 my $host = access_cfg('upload-host','RETURN-UNDEF');
4592 my @hostarg = defined($host) ? ($host,) : ();
4593 runcmd_ordryrun @dput, @hostarg, $changesfile;
4594 printdone "pushed and uploaded $cversion";
4596 supplementary_message('');
4597 responder_send_command("complete");
4601 not_necessarily_a_tree();
4606 badusage "-p is not allowed with clone; specify as argument instead"
4607 if defined $package;
4610 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4611 ($package,$isuite) = @ARGV;
4612 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4613 ($package,$dstdir) = @ARGV;
4614 } elsif (@ARGV==3) {
4615 ($package,$isuite,$dstdir) = @ARGV;
4617 badusage "incorrect arguments to dgit clone";
4621 $dstdir ||= "$package";
4622 if (stat_exists $dstdir) {
4623 fail "$dstdir already exists";
4627 if ($rmonerror && !$dryrun_level) {
4628 $cwd_remove= getcwd();
4630 return unless defined $cwd_remove;
4631 if (!chdir "$cwd_remove") {
4632 return if $!==&ENOENT;
4633 die "chdir $cwd_remove: $!";
4635 printdebug "clone rmonerror removing $dstdir\n";
4637 rmtree($dstdir) or die "remove $dstdir: $!\n";
4638 } elsif (grep { $! == $_ }
4639 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4641 print STDERR "check whether to remove $dstdir: $!\n";
4647 $cwd_remove = undef;
4650 sub branchsuite () {
4651 my $branch = git_get_symref();
4652 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4659 sub package_from_d_control () {
4660 if (!defined $package) {
4661 my $sourcep = parsecontrol('debian/control','debian/control');
4662 $package = getfield $sourcep, 'Source';
4666 sub fetchpullargs () {
4667 package_from_d_control();
4669 $isuite = branchsuite();
4671 my $clogp = parsechangelog();
4672 my $clogsuite = getfield $clogp, 'Distribution';
4673 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4675 } elsif (@ARGV==1) {
4678 badusage "incorrect arguments to dgit fetch or dgit pull";
4692 if (quiltmode_splitbrain()) {
4693 my ($format, $fopts) = get_source_format();
4694 madformat($format) and fail <<END
4695 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4703 package_from_d_control();
4704 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4708 foreach my $canon (qw(0 1)) {
4713 canonicalise_suite();
4715 if (length git_get_ref lref()) {
4716 # local branch already exists, yay
4719 if (!length git_get_ref lrref()) {
4727 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4730 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4731 "dgit checkout $isuite";
4732 runcmd (@git, qw(checkout), lbranch());
4735 sub cmd_update_vcs_git () {
4737 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4738 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4740 ($specsuite) = (@ARGV);
4745 if ($ARGV[0] eq '-') {
4747 } elsif ($ARGV[0] eq '-') {
4752 package_from_d_control();
4754 if ($specsuite eq '.') {
4755 $ctrl = parsecontrol 'debian/control', 'debian/control';
4757 $isuite = $specsuite;
4761 my $url = getfield $ctrl, 'Vcs-Git';
4764 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4765 if (!defined $orgurl) {
4766 print STDERR "setting up vcs-git: $url\n";
4767 @cmd = (@git, qw(remote add vcs-git), $url);
4768 } elsif ($orgurl eq $url) {
4769 print STDERR "vcs git already configured: $url\n";
4771 print STDERR "changing vcs-git url to: $url\n";
4772 @cmd = (@git, qw(remote set-url vcs-git), $url);
4774 runcmd_ordryrun_local @cmd;
4776 print "fetching (@ARGV)\n";
4777 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4783 build_or_push_prep_early();
4788 } elsif (@ARGV==1) {
4789 ($specsuite) = (@ARGV);
4791 badusage "incorrect arguments to dgit $subcommand";
4794 local ($package) = $existing_package; # this is a hack
4795 canonicalise_suite();
4797 canonicalise_suite();
4799 if (defined $specsuite &&
4800 $specsuite ne $isuite &&
4801 $specsuite ne $csuite) {
4802 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4803 " but command line specifies $specsuite";
4812 #---------- remote commands' implementation ----------
4814 sub pre_remote_push_build_host {
4815 my ($nrargs) = shift @ARGV;
4816 my (@rargs) = @ARGV[0..$nrargs-1];
4817 @ARGV = @ARGV[$nrargs..$#ARGV];
4819 my ($dir,$vsnwant) = @rargs;
4820 # vsnwant is a comma-separated list; we report which we have
4821 # chosen in our ready response (so other end can tell if they
4824 $we_are_responder = 1;
4825 $us .= " (build host)";
4827 open PI, "<&STDIN" or die $!;
4828 open STDIN, "/dev/null" or die $!;
4829 open PO, ">&STDOUT" or die $!;
4831 open STDOUT, ">&STDERR" or die $!;
4835 ($protovsn) = grep {
4836 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4837 } @rpushprotovsn_support;
4839 fail "build host has dgit rpush protocol versions ".
4840 (join ",", @rpushprotovsn_support).
4841 " but invocation host has $vsnwant"
4842 unless defined $protovsn;
4846 sub cmd_remote_push_build_host {
4847 responder_send_command("dgit-remote-push-ready $protovsn");
4851 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4852 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4853 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4854 # a good error message)
4856 sub rpush_handle_protovsn_bothends () {
4857 if ($protovsn < 4) {
4858 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4867 my $report = i_child_report();
4868 if (defined $report) {
4869 printdebug "($report)\n";
4870 } elsif ($i_child_pid) {
4871 printdebug "(killing build host child $i_child_pid)\n";
4872 kill 15, $i_child_pid;
4874 if (defined $i_tmp && !defined $initiator_tempdir) {
4876 eval { rmtree $i_tmp; };
4881 return unless forkcheck_mainprocess();
4886 my ($base,$selector,@args) = @_;
4887 $selector =~ s/\-/_/g;
4888 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4892 not_necessarily_a_tree();
4897 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4905 push @rargs, join ",", @rpushprotovsn_support;
4908 push @rdgit, @ropts;
4909 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4911 my @cmd = (@ssh, $host, shellquote @rdgit);
4914 $we_are_initiator=1;
4916 if (defined $initiator_tempdir) {
4917 rmtree $initiator_tempdir;
4918 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4919 $i_tmp = $initiator_tempdir;
4923 $i_child_pid = open2(\*RO, \*RI, @cmd);
4925 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4926 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4927 $supplementary_message = '' unless $protovsn >= 3;
4930 my ($icmd,$iargs) = initiator_expect {
4931 m/^(\S+)(?: (.*))?$/;
4934 i_method "i_resp", $icmd, $iargs;
4938 sub i_resp_progress ($) {
4940 my $msg = protocol_read_bytes \*RO, $rhs;
4944 sub i_resp_supplementary_message ($) {
4946 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4949 sub i_resp_complete {
4950 my $pid = $i_child_pid;
4951 $i_child_pid = undef; # prevents killing some other process with same pid
4952 printdebug "waiting for build host child $pid...\n";
4953 my $got = waitpid $pid, 0;
4954 die $! unless $got == $pid;
4955 die "build host child failed $?" if $?;
4958 printdebug "all done\n";
4962 sub i_resp_file ($) {
4964 my $localname = i_method "i_localname", $keyword;
4965 my $localpath = "$i_tmp/$localname";
4966 stat_exists $localpath and
4967 badproto \*RO, "file $keyword ($localpath) twice";
4968 protocol_receive_file \*RO, $localpath;
4969 i_method "i_file", $keyword;
4974 sub i_resp_param ($) {
4975 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4979 sub i_resp_previously ($) {
4980 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4981 or badproto \*RO, "bad previously spec";
4982 my $r = system qw(git check-ref-format), $1;
4983 die "bad previously ref spec ($r)" if $r;
4984 $previously{$1} = $2;
4989 sub i_resp_want ($) {
4991 die "$keyword ?" if $i_wanted{$keyword}++;
4993 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4994 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4995 die unless $isuite =~ m/^$suite_re$/;
4998 rpush_handle_protovsn_bothends();
5000 fail "rpush negotiated protocol version $protovsn".
5001 " which does not support quilt mode $quilt_mode"
5002 if quiltmode_splitbrain;
5004 my @localpaths = i_method "i_want", $keyword;
5005 printdebug "[[ $keyword @localpaths\n";
5006 foreach my $localpath (@localpaths) {
5007 protocol_send_file \*RI, $localpath;
5009 print RI "files-end\n" or die $!;
5012 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5014 sub i_localname_parsed_changelog {
5015 return "remote-changelog.822";
5017 sub i_file_parsed_changelog {
5018 ($i_clogp, $i_version, $i_dscfn) =
5019 push_parse_changelog "$i_tmp/remote-changelog.822";
5020 die if $i_dscfn =~ m#/|^\W#;
5023 sub i_localname_dsc {
5024 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5029 sub i_localname_buildinfo ($) {
5030 my $bi = $i_param{'buildinfo-filename'};
5031 defined $bi or badproto \*RO, "buildinfo before filename";
5032 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5033 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5034 or badproto \*RO, "improper buildinfo filename";
5037 sub i_file_buildinfo {
5038 my $bi = $i_param{'buildinfo-filename'};
5039 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5040 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5041 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5042 files_compare_inputs($bd, $ch);
5043 (getfield $bd, $_) eq (getfield $ch, $_) or
5044 fail "buildinfo mismatch $_"
5045 foreach qw(Source Version);
5046 !defined $bd->{$_} or
5047 fail "buildinfo contains $_"
5048 foreach qw(Changes Changed-by Distribution);
5050 push @i_buildinfos, $bi;
5051 delete $i_param{'buildinfo-filename'};
5054 sub i_localname_changes {
5055 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5056 $i_changesfn = $i_dscfn;
5057 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5058 return $i_changesfn;
5060 sub i_file_changes { }
5062 sub i_want_signed_tag {
5063 printdebug Dumper(\%i_param, $i_dscfn);
5064 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5065 && defined $i_param{'csuite'}
5066 or badproto \*RO, "premature desire for signed-tag";
5067 my $head = $i_param{'head'};
5068 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5070 my $maintview = $i_param{'maint-view'};
5071 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5074 if ($protovsn >= 4) {
5075 my $p = $i_param{'tagformat'} // '<undef>';
5077 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5080 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5082 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5084 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5087 push_mktags $i_clogp, $i_dscfn,
5088 $i_changesfn, 'remote changes',
5092 sub i_want_signed_dsc_changes {
5093 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5094 sign_changes $i_changesfn;
5095 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5098 #---------- building etc. ----------
5104 #----- `3.0 (quilt)' handling -----
5106 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5108 sub quiltify_dpkg_commit ($$$;$) {
5109 my ($patchname,$author,$msg, $xinfo) = @_;
5112 mkpath '.git/dgit'; # we are in playtree
5113 my $descfn = ".git/dgit/quilt-description.tmp";
5114 open O, '>', $descfn or die "$descfn: $!";
5115 $msg =~ s/\n+/\n\n/;
5116 print O <<END or die $!;
5118 ${xinfo}Subject: $msg
5125 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5126 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5127 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5128 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5132 sub quiltify_trees_differ ($$;$$$) {
5133 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5134 # returns true iff the two tree objects differ other than in debian/
5135 # with $finegrained,
5136 # returns bitmask 01 - differ in upstream files except .gitignore
5137 # 02 - differ in .gitignore
5138 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5139 # is set for each modified .gitignore filename $fn
5140 # if $unrepres is defined, array ref to which is appeneded
5141 # a list of unrepresentable changes (removals of upstream files
5144 my @cmd = (@git, qw(diff-tree -z --no-renames));
5145 push @cmd, qw(--name-only) unless $unrepres;
5146 push @cmd, qw(-r) if $finegrained || $unrepres;
5148 my $diffs= cmdoutput @cmd;
5151 foreach my $f (split /\0/, $diffs) {
5152 if ($unrepres && !@lmodes) {
5153 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5156 my ($oldmode,$newmode) = @lmodes;
5159 next if $f =~ m#^debian(?:/.*)?$#s;
5163 die "not a plain file or symlink\n"
5164 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5165 $oldmode =~ m/^(?:10|12)\d{4}$/;
5166 if ($oldmode =~ m/[^0]/ &&
5167 $newmode =~ m/[^0]/) {
5168 # both old and new files exist
5169 die "mode or type changed\n" if $oldmode ne $newmode;
5170 die "modified symlink\n" unless $newmode =~ m/^10/;
5171 } elsif ($oldmode =~ m/[^0]/) {
5173 die "deletion of symlink\n"
5174 unless $oldmode =~ m/^10/;
5177 die "creation with non-default mode\n"
5178 unless $newmode =~ m/^100644$/ or
5179 $newmode =~ m/^120000$/;
5183 local $/="\n"; chomp $@;
5184 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5188 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5189 $r |= $isignore ? 02 : 01;
5190 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5192 printdebug "quiltify_trees_differ $x $y => $r\n";
5196 sub quiltify_tree_sentinelfiles ($) {
5197 # lists the `sentinel' files present in the tree
5199 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5200 qw(-- debian/rules debian/control);
5205 sub quiltify_splitbrain_needed () {
5206 if (!$split_brain) {
5207 progress "dgit view: changes are required...";
5208 runcmd @git, qw(checkout -q -b dgit-view);
5213 sub quiltify_splitbrain ($$$$$$$) {
5214 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5215 $editedignores, $cachekey) = @_;
5216 my $gitignore_special = 1;
5217 if ($quilt_mode !~ m/gbp|dpm/) {
5218 # treat .gitignore just like any other upstream file
5219 $diffbits = { %$diffbits };
5220 $_ = !!$_ foreach values %$diffbits;
5221 $gitignore_special = 0;
5223 # We would like any commits we generate to be reproducible
5224 my @authline = clogp_authline($clogp);
5225 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5226 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5227 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5228 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5229 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5230 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5232 my $fulldiffhint = sub {
5234 my $cmd = "git diff $x $y -- :/ ':!debian'";
5235 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5236 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5239 if ($quilt_mode =~ m/gbp|unapplied/ &&
5240 ($diffbits->{O2H} & 01)) {
5242 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5243 " but git tree differs from orig in upstream files.";
5244 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5245 if (!stat_exists "debian/patches") {
5247 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5251 if ($quilt_mode =~ m/dpm/ &&
5252 ($diffbits->{H2A} & 01)) {
5253 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5254 --quilt=$quilt_mode specified, implying patches-applied git tree
5255 but git tree differs from result of applying debian/patches to upstream
5258 if ($quilt_mode =~ m/gbp|unapplied/ &&
5259 ($diffbits->{O2A} & 01)) { # some patches
5260 quiltify_splitbrain_needed();
5261 progress "dgit view: creating patches-applied version using gbp pq";
5262 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5263 # gbp pq import creates a fresh branch; push back to dgit-view
5264 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5265 runcmd @git, qw(checkout -q dgit-view);
5267 if ($quilt_mode =~ m/gbp|dpm/ &&
5268 ($diffbits->{O2A} & 02)) {
5270 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5271 tool which does not create patches for changes to upstream
5272 .gitignores: but, such patches exist in debian/patches.
5275 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5276 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5277 quiltify_splitbrain_needed();
5278 progress "dgit view: creating patch to represent .gitignore changes";
5279 ensuredir "debian/patches";
5280 my $gipatch = "debian/patches/auto-gitignore";
5281 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5282 stat GIPATCH or die "$gipatch: $!";
5283 fail "$gipatch already exists; but want to create it".
5284 " to record .gitignore changes" if (stat _)[7];
5285 print GIPATCH <<END or die "$gipatch: $!";
5286 Subject: Update .gitignore from Debian packaging branch
5288 The Debian packaging git branch contains these updates to the upstream
5289 .gitignore file(s). This patch is autogenerated, to provide these
5290 updates to users of the official Debian archive view of the package.
5292 [dgit ($our_version) update-gitignore]
5295 close GIPATCH or die "$gipatch: $!";
5296 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5297 $unapplied, $headref, "--", sort keys %$editedignores;
5298 open SERIES, "+>>", "debian/patches/series" or die $!;
5299 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5301 defined read SERIES, $newline, 1 or die $!;
5302 print SERIES "\n" or die $! unless $newline eq "\n";
5303 print SERIES "auto-gitignore\n" or die $!;
5304 close SERIES or die $!;
5305 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5307 Commit patch to update .gitignore
5309 [dgit ($our_version) update-gitignore-quilt-fixup]
5313 my $dgitview = git_rev_parse 'HEAD';
5316 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5318 changedir "$playground/work";
5320 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5321 progress "dgit view: created ($saved)";
5324 sub quiltify ($$$$) {
5325 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5327 # Quilt patchification algorithm
5329 # We search backwards through the history of the main tree's HEAD
5330 # (T) looking for a start commit S whose tree object is identical
5331 # to to the patch tip tree (ie the tree corresponding to the
5332 # current dpkg-committed patch series). For these purposes
5333 # `identical' disregards anything in debian/ - this wrinkle is
5334 # necessary because dpkg-source treates debian/ specially.
5336 # We can only traverse edges where at most one of the ancestors'
5337 # trees differs (in changes outside in debian/). And we cannot
5338 # handle edges which change .pc/ or debian/patches. To avoid
5339 # going down a rathole we avoid traversing edges which introduce
5340 # debian/rules or debian/control. And we set a limit on the
5341 # number of edges we are willing to look at.
5343 # If we succeed, we walk forwards again. For each traversed edge
5344 # PC (with P parent, C child) (starting with P=S and ending with
5345 # C=T) to we do this:
5347 # - dpkg-source --commit with a patch name and message derived from C
5348 # After traversing PT, we git commit the changes which
5349 # should be contained within debian/patches.
5351 # The search for the path S..T is breadth-first. We maintain a
5352 # todo list containing search nodes. A search node identifies a
5353 # commit, and looks something like this:
5355 # Commit => $git_commit_id,
5356 # Child => $c, # or undef if P=T
5357 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5358 # Nontrivial => true iff $p..$c has relevant changes
5365 my %considered; # saves being exponential on some weird graphs
5367 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5370 my ($search,$whynot) = @_;
5371 printdebug " search NOT $search->{Commit} $whynot\n";
5372 $search->{Whynot} = $whynot;
5373 push @nots, $search;
5374 no warnings qw(exiting);
5383 my $c = shift @todo;
5384 next if $considered{$c->{Commit}}++;
5386 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5388 printdebug "quiltify investigate $c->{Commit}\n";
5391 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5392 printdebug " search finished hooray!\n";
5397 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5398 if ($quilt_mode eq 'smash') {
5399 printdebug " search quitting smash\n";
5403 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5404 $not->($c, "has $c_sentinels not $t_sentinels")
5405 if $c_sentinels ne $t_sentinels;
5407 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5408 $commitdata =~ m/\n\n/;
5410 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5411 @parents = map { { Commit => $_, Child => $c } } @parents;
5413 $not->($c, "root commit") if !@parents;
5415 foreach my $p (@parents) {
5416 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5418 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5419 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5421 foreach my $p (@parents) {
5422 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5424 my @cmd= (@git, qw(diff-tree -r --name-only),
5425 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5426 my $patchstackchange = cmdoutput @cmd;
5427 if (length $patchstackchange) {
5428 $patchstackchange =~ s/\n/,/g;
5429 $not->($p, "changed $patchstackchange");
5432 printdebug " search queue P=$p->{Commit} ",
5433 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5439 printdebug "quiltify want to smash\n";
5442 my $x = $_[0]{Commit};
5443 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5446 my $reportnot = sub {
5448 my $s = $abbrev->($notp);
5449 my $c = $notp->{Child};
5450 $s .= "..".$abbrev->($c) if $c;
5451 $s .= ": ".$notp->{Whynot};
5454 if ($quilt_mode eq 'linear') {
5455 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5456 my $all_gdr = !!@nots;
5457 foreach my $notp (@nots) {
5458 print STDERR "$us: ", $reportnot->($notp), "\n";
5459 $all_gdr &&= $notp->{Child} &&
5460 (git_cat_file $notp->{Child}{Commit}, 'commit')
5461 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5465 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5467 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5469 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5470 } elsif ($quilt_mode eq 'smash') {
5471 } elsif ($quilt_mode eq 'auto') {
5472 progress "quilt fixup cannot be linear, smashing...";
5474 die "$quilt_mode ?";
5477 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5478 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5480 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5482 quiltify_dpkg_commit "auto-$version-$target-$time",
5483 (getfield $clogp, 'Maintainer'),
5484 "Automatically generated patch ($clogp->{Version})\n".
5485 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5489 progress "quiltify linearisation planning successful, executing...";
5491 for (my $p = $sref_S;
5492 my $c = $p->{Child};
5494 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5495 next unless $p->{Nontrivial};
5497 my $cc = $c->{Commit};
5499 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5500 $commitdata =~ m/\n\n/ or die "$c ?";
5503 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5506 my $commitdate = cmdoutput
5507 @git, qw(log -n1 --pretty=format:%aD), $cc;
5509 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5511 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5518 my $gbp_check_suitable = sub {
5523 die "contains unexpected slashes\n" if m{//} || m{/$};
5524 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5525 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5526 die "is series file\n" if m{$series_filename_re}o;
5527 die "too long" if length > 200;
5529 return $_ unless $@;
5530 print STDERR "quiltifying commit $cc:".
5531 " ignoring/dropping Gbp-Pq $what: $@";
5535 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5537 (\S+) \s* \n //ixm) {
5538 $patchname = $gbp_check_suitable->($1, 'Name');
5540 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5542 (\S+) \s* \n //ixm) {
5543 $patchdir = $gbp_check_suitable->($1, 'Topic');
5548 if (!defined $patchname) {
5549 $patchname = $title;
5550 $patchname =~ s/[.:]$//;
5553 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5554 my $translitname = $converter->convert($patchname);
5555 die unless defined $translitname;
5556 $patchname = $translitname;
5559 "dgit: patch title transliteration error: $@"
5561 $patchname =~ y/ A-Z/-a-z/;
5562 $patchname =~ y/-a-z0-9_.+=~//cd;
5563 $patchname =~ s/^\W/x-$&/;
5564 $patchname = substr($patchname,0,40);
5565 $patchname .= ".patch";
5567 if (!defined $patchdir) {
5570 if (length $patchdir) {
5571 $patchname = "$patchdir/$patchname";
5573 if ($patchname =~ m{^(.*)/}) {
5574 mkpath "debian/patches/$1";
5579 stat "debian/patches/$patchname$index";
5581 $!==ENOENT or die "$patchname$index $!";
5583 runcmd @git, qw(checkout -q), $cc;
5585 # We use the tip's changelog so that dpkg-source doesn't
5586 # produce complaining messages from dpkg-parsechangelog. None
5587 # of the information dpkg-source gets from the changelog is
5588 # actually relevant - it gets put into the original message
5589 # which dpkg-source provides our stunt editor, and then
5591 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5593 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5594 "Date: $commitdate\n".
5595 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5597 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5600 runcmd @git, qw(checkout -q master);
5603 sub build_maybe_quilt_fixup () {
5604 my ($format,$fopts) = get_source_format;
5605 return unless madformat_wantfixup $format;
5608 check_for_vendor_patches();
5610 if (quiltmode_splitbrain) {
5611 fail <<END unless access_cfg_tagformats_can_splitbrain;
5612 quilt mode $quilt_mode requires split view so server needs to support
5613 both "new" and "maint" tag formats, but config says it doesn't.
5617 my $clogp = parsechangelog();
5618 my $headref = git_rev_parse('HEAD');
5619 my $symref = git_get_symref();
5621 if ($quilt_mode eq 'linear'
5622 && !$fopts->{'single-debian-patch'}
5623 && branch_is_gdr($headref)) {
5624 # This is much faster. It also makes patches that gdr
5625 # likes better for future updates without laundering.
5627 # However, it can fail in some casses where we would
5628 # succeed: if there are existing patches, which correspond
5629 # to a prefix of the branch, but are not in gbp/gdr
5630 # format, gdr will fail (exiting status 7), but we might
5631 # be able to figure out where to start linearising. That
5632 # will be slower so hopefully there's not much to do.
5633 my @cmd = (@git_debrebase,
5634 qw(--noop-ok -funclean-mixed -funclean-ordering
5635 make-patches --quiet-would-amend));
5636 # We tolerate soe snags that gdr wouldn't, by default.
5640 failedcmd @cmd if system @cmd and $?!=7*256;
5644 $headref = git_rev_parse('HEAD');
5648 changedir $playground;
5650 my $upstreamversion = upstreamversion $version;
5652 if ($fopts->{'single-debian-patch'}) {
5653 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5655 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5659 runcmd_ordryrun_local
5660 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5663 sub unpack_playtree_mkwork ($) {
5666 mkdir "work" or die $!;
5668 mktree_in_ud_here();
5669 runcmd @git, qw(reset -q --hard), $headref;
5672 sub unpack_playtree_linkorigs ($$) {
5673 my ($upstreamversion, $fn) = @_;
5674 # calls $fn->($leafname);
5676 my $bpd_abs = bpd_abs();
5677 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5678 while ($!=0, defined(my $b = readdir QFD)) {
5679 my $f = bpd_abs()."/".$b;
5681 local ($debuglevel) = $debuglevel-1;
5682 printdebug "QF linkorigs $b, $f ?\n";
5684 next unless is_orig_file_of_vsn $b, $upstreamversion;
5685 printdebug "QF linkorigs $b, $f Y\n";
5686 link_ltarget $f, $b or die "$b $!";
5689 die "$buildproductsdir: $!" if $!;
5693 sub quilt_fixup_delete_pc () {
5694 runcmd @git, qw(rm -rqf .pc);
5696 Commit removal of .pc (quilt series tracking data)
5698 [dgit ($our_version) upgrade quilt-remove-pc]
5702 sub quilt_fixup_singlepatch ($$$) {
5703 my ($clogp, $headref, $upstreamversion) = @_;
5705 progress "starting quiltify (single-debian-patch)";
5707 # dpkg-source --commit generates new patches even if
5708 # single-debian-patch is in debian/source/options. In order to
5709 # get it to generate debian/patches/debian-changes, it is
5710 # necessary to build the source package.
5712 unpack_playtree_linkorigs($upstreamversion, sub { });
5713 unpack_playtree_mkwork($headref);
5715 rmtree("debian/patches");
5717 runcmd @dpkgsource, qw(-b .);
5719 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5720 rename srcfn("$upstreamversion", "/debian/patches"),
5721 "work/debian/patches";
5724 commit_quilty_patch();
5727 sub quilt_make_fake_dsc ($) {
5728 my ($upstreamversion) = @_;
5730 my $fakeversion="$upstreamversion-~~DGITFAKE";
5732 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5733 print $fakedsc <<END or die $!;
5736 Version: $fakeversion
5740 my $dscaddfile=sub {
5743 my $md = new Digest::MD5;
5745 my $fh = new IO::File $b, '<' or die "$b $!";
5750 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5753 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5755 my @files=qw(debian/source/format debian/rules
5756 debian/control debian/changelog);
5757 foreach my $maybe (qw(debian/patches debian/source/options
5758 debian/tests/control)) {
5759 next unless stat_exists "$maindir/$maybe";
5760 push @files, $maybe;
5763 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5764 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5766 $dscaddfile->($debtar);
5767 close $fakedsc or die $!;
5770 sub quilt_fakedsc2unapplied ($$) {
5771 my ($headref, $upstreamversion) = @_;
5772 # must be run in the playground
5773 # quilt_make_fake_dsc must have been called
5776 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5778 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5779 rename $fakexdir, "fake" or die "$fakexdir $!";
5783 remove_stray_gits("source package");
5784 mktree_in_ud_here();
5788 rmtree 'debian'; # git checkout commitish paths does not delete!
5789 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5790 my $unapplied=git_add_write_tree();
5791 printdebug "fake orig tree object $unapplied\n";
5795 sub quilt_check_splitbrain_cache ($$) {
5796 my ($headref, $upstreamversion) = @_;
5797 # Called only if we are in (potentially) split brain mode.
5798 # Called in playground.
5799 # Computes the cache key and looks in the cache.
5800 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5802 my $splitbrain_cachekey;
5805 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5806 # we look in the reflog of dgit-intern/quilt-cache
5807 # we look for an entry whose message is the key for the cache lookup
5808 my @cachekey = (qw(dgit), $our_version);
5809 push @cachekey, $upstreamversion;
5810 push @cachekey, $quilt_mode;
5811 push @cachekey, $headref;
5813 push @cachekey, hashfile('fake.dsc');
5815 my $srcshash = Digest::SHA->new(256);
5816 my %sfs = ( %INC, '$0(dgit)' => $0 );
5817 foreach my $sfk (sort keys %sfs) {
5818 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5819 $srcshash->add($sfk," ");
5820 $srcshash->add(hashfile($sfs{$sfk}));
5821 $srcshash->add("\n");
5823 push @cachekey, $srcshash->hexdigest();
5824 $splitbrain_cachekey = "@cachekey";
5826 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5828 my $cachehit = reflog_cache_lookup
5829 "refs/$splitbraincache", $splitbrain_cachekey;
5832 unpack_playtree_mkwork($headref);
5833 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5834 if ($cachehit ne $headref) {
5835 progress "dgit view: found cached ($saved)";
5836 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5838 return ($cachehit, $splitbrain_cachekey);
5840 progress "dgit view: found cached, no changes required";
5841 return ($headref, $splitbrain_cachekey);
5844 printdebug "splitbrain cache miss\n";
5845 return (undef, $splitbrain_cachekey);
5848 sub quilt_fixup_multipatch ($$$) {
5849 my ($clogp, $headref, $upstreamversion) = @_;
5851 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5854 # - honour any existing .pc in case it has any strangeness
5855 # - determine the git commit corresponding to the tip of
5856 # the patch stack (if there is one)
5857 # - if there is such a git commit, convert each subsequent
5858 # git commit into a quilt patch with dpkg-source --commit
5859 # - otherwise convert all the differences in the tree into
5860 # a single git commit
5864 # Our git tree doesn't necessarily contain .pc. (Some versions of
5865 # dgit would include the .pc in the git tree.) If there isn't
5866 # one, we need to generate one by unpacking the patches that we
5869 # We first look for a .pc in the git tree. If there is one, we
5870 # will use it. (This is not the normal case.)
5872 # Otherwise need to regenerate .pc so that dpkg-source --commit
5873 # can work. We do this as follows:
5874 # 1. Collect all relevant .orig from parent directory
5875 # 2. Generate a debian.tar.gz out of
5876 # debian/{patches,rules,source/format,source/options}
5877 # 3. Generate a fake .dsc containing just these fields:
5878 # Format Source Version Files
5879 # 4. Extract the fake .dsc
5880 # Now the fake .dsc has a .pc directory.
5881 # (In fact we do this in every case, because in future we will
5882 # want to search for a good base commit for generating patches.)
5884 # Then we can actually do the dpkg-source --commit
5885 # 1. Make a new working tree with the same object
5886 # store as our main tree and check out the main
5888 # 2. Copy .pc from the fake's extraction, if necessary
5889 # 3. Run dpkg-source --commit
5890 # 4. If the result has changes to debian/, then
5891 # - git add them them
5892 # - git add .pc if we had a .pc in-tree
5894 # 5. If we had a .pc in-tree, delete it, and git commit
5895 # 6. Back in the main tree, fast forward to the new HEAD
5897 # Another situation we may have to cope with is gbp-style
5898 # patches-unapplied trees.
5900 # We would want to detect these, so we know to escape into
5901 # quilt_fixup_gbp. However, this is in general not possible.
5902 # Consider a package with a one patch which the dgit user reverts
5903 # (with git revert or the moral equivalent).
5905 # That is indistinguishable in contents from a patches-unapplied
5906 # tree. And looking at the history to distinguish them is not
5907 # useful because the user might have made a confusing-looking git
5908 # history structure (which ought to produce an error if dgit can't
5909 # cope, not a silent reintroduction of an unwanted patch).
5911 # So gbp users will have to pass an option. But we can usually
5912 # detect their failure to do so: if the tree is not a clean
5913 # patches-applied tree, quilt linearisation fails, but the tree
5914 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5915 # they want --quilt=unapplied.
5917 # To help detect this, when we are extracting the fake dsc, we
5918 # first extract it with --skip-patches, and then apply the patches
5919 # afterwards with dpkg-source --before-build. That lets us save a
5920 # tree object corresponding to .origs.
5922 my $splitbrain_cachekey;
5924 quilt_make_fake_dsc($upstreamversion);
5926 if (quiltmode_splitbrain()) {
5928 ($cachehit, $splitbrain_cachekey) =
5929 quilt_check_splitbrain_cache($headref, $upstreamversion);
5930 return if $cachehit;
5932 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
5936 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5938 if (system @bbcmd) {
5939 failedcmd @bbcmd if $? < 0;
5941 failed to apply your git tree's patch stack (from debian/patches/) to
5942 the corresponding upstream tarball(s). Your source tree and .orig
5943 are probably too inconsistent. dgit can only fix up certain kinds of
5944 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5950 unpack_playtree_mkwork($headref);
5953 if (stat_exists ".pc") {
5955 progress "Tree already contains .pc - will use it then delete it.";
5958 rename '../fake/.pc','.pc' or die $!;
5961 changedir '../fake';
5963 my $oldtiptree=git_add_write_tree();
5964 printdebug "fake o+d/p tree object $unapplied\n";
5965 changedir '../work';
5968 # We calculate some guesswork now about what kind of tree this might
5969 # be. This is mostly for error reporting.
5975 # O = orig, without patches applied
5976 # A = "applied", ie orig with H's debian/patches applied
5977 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5978 \%editedignores, \@unrepres),
5979 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5980 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5984 foreach my $b (qw(01 02)) {
5985 foreach my $v (qw(O2H O2A H2A)) {
5986 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5989 printdebug "differences \@dl @dl.\n";
5992 "$us: base trees orig=%.20s o+d/p=%.20s",
5993 $unapplied, $oldtiptree;
5995 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5996 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5997 $dl[0], $dl[1], $dl[3], $dl[4],
6001 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
6003 forceable_fail [qw(unrepresentable)], <<END;
6004 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6009 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6010 push @failsuggestion, [ 'unapplied',
6011 "This might be a patches-unapplied branch." ];
6012 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6013 push @failsuggestion, [ 'applied',
6014 "This might be a patches-applied branch." ];
6016 push @failsuggestion, [ 'quilt-mode',
6017 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6019 push @failsuggestion, [ 'gitattrs',
6020 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6021 if stat_exists '.gitattributes';
6023 push @failsuggestion, [ 'origs',
6024 "Maybe orig tarball(s) are not identical to git representation?" ];
6026 if (quiltmode_splitbrain()) {
6027 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6028 $diffbits, \%editedignores,
6029 $splitbrain_cachekey);
6033 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6034 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6036 if (!open P, '>>', ".pc/applied-patches") {
6037 $!==&ENOENT or die $!;
6042 commit_quilty_patch();
6044 if ($mustdeletepc) {
6045 quilt_fixup_delete_pc();
6049 sub quilt_fixup_editor () {
6050 my $descfn = $ENV{$fakeeditorenv};
6051 my $editing = $ARGV[$#ARGV];
6052 open I1, '<', $descfn or die "$descfn: $!";
6053 open I2, '<', $editing or die "$editing: $!";
6054 unlink $editing or die "$editing: $!";
6055 open O, '>', $editing or die "$editing: $!";
6056 while (<I1>) { print O or die $!; } I1->error and die $!;
6059 $copying ||= m/^\-\-\- /;
6060 next unless $copying;
6063 I2->error and die $!;
6068 sub maybe_apply_patches_dirtily () {
6069 return unless $quilt_mode =~ m/gbp|unapplied/;
6070 print STDERR <<END or die $!;
6072 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6073 dgit: Have to apply the patches - making the tree dirty.
6074 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6077 $patches_applied_dirtily = 01;
6078 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6079 runcmd qw(dpkg-source --before-build .);
6082 sub maybe_unapply_patches_again () {
6083 progress "dgit: Unapplying patches again to tidy up the tree."
6084 if $patches_applied_dirtily;
6085 runcmd qw(dpkg-source --after-build .)
6086 if $patches_applied_dirtily & 01;
6088 if $patches_applied_dirtily & 02;
6089 $patches_applied_dirtily = 0;
6092 #----- other building -----
6094 our $clean_using_builder;
6095 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6096 # clean the tree before building (perhaps invoked indirectly by
6097 # whatever we are using to run the build), rather than separately
6098 # and explicitly by us.
6101 return if $clean_using_builder;
6102 if ($cleanmode eq 'dpkg-source') {
6103 maybe_apply_patches_dirtily();
6104 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6105 } elsif ($cleanmode eq 'dpkg-source-d') {
6106 maybe_apply_patches_dirtily();
6107 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6108 } elsif ($cleanmode eq 'git') {
6109 runcmd_ordryrun_local @git, qw(clean -xdf);
6110 } elsif ($cleanmode eq 'git-ff') {
6111 runcmd_ordryrun_local @git, qw(clean -xdff);
6112 } elsif ($cleanmode eq 'check') {
6113 my $leftovers = cmdoutput @git, qw(clean -xdn);
6114 if (length $leftovers) {
6115 print STDERR $leftovers, "\n" or die $!;
6116 fail "tree contains uncommitted files and --clean=check specified";
6118 } elsif ($cleanmode eq 'none') {
6125 badusage "clean takes no additional arguments" if @ARGV;
6128 maybe_unapply_patches_again();
6131 # return values from massage_dbp_args are one or both of these flags
6132 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6133 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6135 sub build_or_push_prep_early () {
6136 our $build_or_push_prep_early_done //= 0;
6137 return if $build_or_push_prep_early_done++;
6138 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6139 my $clogp = parsechangelog();
6140 $isuite = getfield $clogp, 'Distribution';
6141 $package = getfield $clogp, 'Source';
6142 $version = getfield $clogp, 'Version';
6143 $dscfn = dscfn($version);
6146 sub build_prep_early () {
6147 build_or_push_prep_early();
6152 sub build_prep ($) {
6155 # clean the tree if we're trying to include dirty changes in the
6156 # source package, or we are running the builder in $maindir
6157 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6158 build_maybe_quilt_fixup();
6160 my $pat = changespat $version;
6161 foreach my $f (glob "$buildproductsdir/$pat") {
6163 unlink $f or fail "remove old changes file $f: $!";
6165 progress "would remove $f";
6171 sub changesopts_initial () {
6172 my @opts =@changesopts[1..$#changesopts];
6175 sub changesopts_version () {
6176 if (!defined $changes_since_version) {
6179 @vsns = archive_query('archive_query');
6180 my @quirk = access_quirk();
6181 if ($quirk[0] eq 'backports') {
6182 local $isuite = $quirk[2];
6184 canonicalise_suite();
6185 push @vsns, archive_query('archive_query');
6191 "archive query failed (queried because --since-version not specified)";
6194 @vsns = map { $_->[0] } @vsns;
6195 @vsns = sort { -version_compare($a, $b) } @vsns;
6196 $changes_since_version = $vsns[0];
6197 progress "changelog will contain changes since $vsns[0]";
6199 $changes_since_version = '_';
6200 progress "package seems new, not specifying -v<version>";
6203 if ($changes_since_version ne '_') {
6204 return ("-v$changes_since_version");
6210 sub changesopts () {
6211 return (changesopts_initial(), changesopts_version());
6214 sub massage_dbp_args ($;$) {
6215 my ($cmd,$xargs) = @_;
6216 # Since we split the source build out so we can do strange things
6217 # to it, massage the arguments to dpkg-buildpackage so that the
6218 # main build doessn't build source (or add an argument to stop it
6219 # building source by default).
6220 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6221 # -nc has the side effect of specifying -b if nothing else specified
6222 # and some combinations of -S, -b, et al, are errors, rather than
6223 # later simply overriding earlie. So we need to:
6224 # - search the command line for these options
6225 # - pick the last one
6226 # - perhaps add our own as a default
6227 # - perhaps adjust it to the corresponding non-source-building version
6229 foreach my $l ($cmd, $xargs) {
6231 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6234 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6235 my $r = WANTSRC_BUILDER;
6236 printdebug "massage split $dmode.\n";
6237 if ($dmode =~ s/^--build=//) {
6239 my @d = split /,/, $dmode;
6240 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6241 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6242 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6243 fail "Wanted to build nothing!" unless $r;
6244 $dmode = '--build='. join ',', grep m/./, @d;
6247 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6248 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6249 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6252 printdebug "massage done $r $dmode.\n";
6254 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6260 my $wasdir = must_getcwd();
6261 changedir $buildproductsdir;
6266 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6267 sub postbuild_mergechanges ($) {
6268 my ($msg_if_onlyone) = @_;
6269 # If there is only one .changes file, fail with $msg_if_onlyone,
6270 # or if that is undef, be a no-op.
6271 # Returns the changes file to report to the user.
6272 my $pat = changespat $version;
6273 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6274 @changesfiles = sort {
6275 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6279 if (@changesfiles==1) {
6280 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6281 only one changes file from build (@changesfiles)
6283 $result = $changesfiles[0];
6284 } elsif (@changesfiles==2) {
6285 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6286 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6287 fail "$l found in binaries changes file $binchanges"
6290 runcmd_ordryrun_local @mergechanges, @changesfiles;
6291 my $multichanges = changespat $version,'multi';
6293 stat_exists $multichanges or fail "$multichanges: $!";
6294 foreach my $cf (glob $pat) {
6295 next if $cf eq $multichanges;
6296 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6299 $result = $multichanges;
6301 fail "wrong number of different changes files (@changesfiles)";
6303 printdone "build successful, results in $result\n" or die $!;
6306 sub midbuild_checkchanges () {
6307 my $pat = changespat $version;
6308 return if $rmchanges;
6309 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6311 $_ ne changespat $version,'source' and
6312 $_ ne changespat $version,'multi'
6315 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6316 Suggest you delete @unwanted.
6321 sub midbuild_checkchanges_vanilla ($) {
6323 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6326 sub postbuild_mergechanges_vanilla ($) {
6328 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6330 postbuild_mergechanges(undef);
6333 printdone "build successful\n";
6339 $buildproductsdir eq '..' or print STDERR <<END;
6340 $us: warning: build-products-dir set, but not supported by dpkg-buildpackage
6341 $us: warning: build-products-dir will be ignored; files will go to ..
6343 $buildproductsdir = '..';
6344 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6345 my $wantsrc = massage_dbp_args \@dbp;
6346 build_prep($wantsrc);
6347 if ($wantsrc & WANTSRC_SOURCE) {
6349 midbuild_checkchanges_vanilla $wantsrc;
6351 if ($wantsrc & WANTSRC_BUILDER) {
6352 push @dbp, changesopts_version();
6353 maybe_apply_patches_dirtily();
6354 runcmd_ordryrun_local @dbp;
6356 maybe_unapply_patches_again();
6357 postbuild_mergechanges_vanilla $wantsrc;
6361 $quilt_mode //= 'gbp';
6367 # gbp can make .origs out of thin air. In my tests it does this
6368 # even for a 1.0 format package, with no origs present. So I
6369 # guess it keys off just the version number. We don't know
6370 # exactly what .origs ought to exist, but let's assume that we
6371 # should run gbp if: the version has an upstream part and the main
6373 my $upstreamversion = upstreamversion $version;
6374 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6375 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6377 if ($gbp_make_orig) {
6379 $cleanmode = 'none'; # don't do it again
6382 my @dbp = @dpkgbuildpackage;
6384 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6386 if (!length $gbp_build[0]) {
6387 if (length executable_on_path('git-buildpackage')) {
6388 $gbp_build[0] = qw(git-buildpackage);
6390 $gbp_build[0] = 'gbp buildpackage';
6393 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6395 push @cmd, (qw(-us -uc --git-no-sign-tags),
6396 "--git-builder=".(shellquote @dbp));
6398 if ($gbp_make_orig) {
6399 my $priv = dgit_privdir();
6400 my $ok = "$priv/origs-gen-ok";
6401 unlink $ok or $!==&ENOENT or die $!;
6402 my @origs_cmd = @cmd;
6403 push @origs_cmd, qw(--git-cleaner=true);
6404 push @origs_cmd, "--git-prebuild=".
6405 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6406 push @origs_cmd, @ARGV;
6408 debugcmd @origs_cmd;
6410 do { local $!; stat_exists $ok; }
6411 or failedcmd @origs_cmd;
6413 dryrun_report @origs_cmd;
6417 build_prep($wantsrc);
6418 if ($wantsrc & WANTSRC_SOURCE) {
6420 midbuild_checkchanges_vanilla $wantsrc;
6422 if (!$clean_using_builder) {
6423 push @cmd, '--git-cleaner=true';
6426 maybe_unapply_patches_again();
6427 if ($wantsrc & WANTSRC_BUILDER) {
6428 push @cmd, changesopts();
6429 runcmd_ordryrun_local @cmd, @ARGV;
6431 postbuild_mergechanges_vanilla $wantsrc;
6433 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6435 sub building_source_in_playtree {
6436 # If $includedirty, we have to build the source package from the
6437 # working tree, not a playtree, so that uncommitted changes are
6438 # included (copying or hardlinking them into the playtree could
6441 # Note that if we are building a source package in split brain
6442 # mode we do not support including uncommitted changes, because
6443 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6444 # building a source package)) => !$includedirty
6445 return !$includedirty;
6449 $sourcechanges = changespat $version,'source';
6451 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6452 or fail "remove $sourcechanges: $!";
6454 my @cmd = (@dpkgsource, qw(-b --));
6456 if (building_source_in_playtree()) {
6458 my $headref = git_rev_parse('HEAD');
6459 # If we are in split brain, there is already a playtree with
6460 # the thing we should package into a .dsc (thanks to quilt
6461 # fixup). If not, make a playtree
6462 prep_ud() unless $split_brain;
6463 changedir $playground;
6464 unless ($split_brain) {
6465 my $upstreamversion = upstreamversion $version;
6466 unpack_playtree_linkorigs($upstreamversion, sub { });
6467 unpack_playtree_mkwork($headref);
6471 $leafdir = basename $maindir;
6474 runcmd_ordryrun_local @cmd, $leafdir;
6477 runcmd_ordryrun_local qw(sh -ec),
6478 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6479 @dpkggenchanges, qw(-S), changesopts();
6482 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6483 $dsc = parsecontrol($dscfn, "source package");
6487 printdebug " renaming ($why) $l\n";
6488 rename "$l", bpd_abs()."/$l"
6489 or fail "put in place new built file ($l): $!";
6491 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6492 $l =~ m/\S+$/ or next;
6495 $mv->('dsc', $dscfn);
6496 $mv->('changes', $sourcechanges);
6501 sub cmd_build_source {
6502 badusage "build-source takes no additional arguments" if @ARGV;
6503 build_prep(WANTSRC_SOURCE);
6505 maybe_unapply_patches_again();
6506 printdone "source built, results in $dscfn and $sourcechanges";
6509 sub cmd_push_source {
6511 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6512 "sense with push-source!" if $includedirty;
6513 build_maybe_quilt_fixup();
6515 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6516 "source changes file");
6517 unless (test_source_only_changes($changes)) {
6518 fail "user-specified changes file is not source-only";
6521 # Building a source package is very fast, so just do it
6523 die "er, patches are applied dirtily but shouldn't be.."
6524 if $patches_applied_dirtily;
6525 $changesfile = $sourcechanges;
6530 sub binary_builder {
6531 my ($bbuilder, $pbmc_msg, @args) = @_;
6532 build_prep(WANTSRC_SOURCE);
6534 midbuild_checkchanges();
6537 stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
6538 stat_exists $sourcechanges
6539 or fail "$sourcechanges (in build products dir): $!";
6541 runcmd_ordryrun_local @$bbuilder, @args;
6543 maybe_unapply_patches_again();
6545 postbuild_mergechanges($pbmc_msg);
6551 binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
6552 perhaps you need to pass -A ? (sbuild's default is to build only
6553 arch-specific binaries; dgit 1.4 used to override that.)
6558 my ($pbuilder) = @_;
6560 # @ARGV is allowed to contain only things that should be passed to
6561 # pbuilder under debbuildopts; just massage those
6562 my $wantsrc = massage_dbp_args \@ARGV;
6563 fail "you asked for a builder but your debbuildopts didn't ask for".
6564 " any binaries -- is this really what you meant?"
6565 unless $wantsrc & WANTSRC_BUILDER;
6566 fail "we must build a .dsc to pass to the builder but your debbuiltopts".
6567 " forbids the building of a source package; cannot continue"
6568 unless $wantsrc & WANTSRC_SOURCE;
6569 # We do not want to include the verb "build" in @pbuilder because
6570 # the user can customise @pbuilder and they shouldn't be required
6571 # to include "build" in their customised value. However, if the
6572 # user passes any additional args to pbuilder using the dgit
6573 # option --pbuilder:foo, such args need to come after the "build"
6574 # verb. opts_opt_multi_cmd does all of that.
6575 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6576 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6581 pbuilder(\@pbuilder);
6584 sub cmd_cowbuilder {
6585 pbuilder(\@cowbuilder);
6588 sub cmd_quilt_fixup {
6589 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6592 build_maybe_quilt_fixup();
6595 sub cmd_print_unapplied_treeish {
6596 badusage "incorrect arguments to dgit print-unapplied-treeish" if @ARGV;
6597 my $headref = git_rev_parse('HEAD');
6598 my $clogp = commit_getclogp $headref;
6599 $package = getfield $clogp, 'Source';
6600 $version = getfield $clogp, 'Version';
6601 $isuite = getfield $clogp, 'Distribution';
6602 $csuite = $isuite; # we want this to be offline!
6606 changedir $playground;
6607 my $uv = upstreamversion $version;
6608 quilt_make_fake_dsc($uv);
6609 my $u = quilt_fakedsc2unapplied($headref, $uv);
6610 print $u, "\n" or die $!;
6613 sub import_dsc_result {
6614 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6615 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6617 check_gitattrs($newhash, "source tree");
6619 progress "dgit: import-dsc: $what_msg";
6622 sub cmd_import_dsc {
6626 last unless $ARGV[0] =~ m/^-/;
6629 if (m/^--require-valid-signature$/) {
6632 badusage "unknown dgit import-dsc sub-option \`$_'";
6636 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6637 my ($dscfn, $dstbranch) = @ARGV;
6639 badusage "dry run makes no sense with import-dsc" unless act_local();
6641 my $force = $dstbranch =~ s/^\+// ? +1 :
6642 $dstbranch =~ s/^\.\.// ? -1 :
6644 my $info = $force ? " $&" : '';
6645 $info = "$dscfn$info";
6647 my $specbranch = $dstbranch;
6648 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6649 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6651 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6652 my $chead = cmdoutput_errok @symcmd;
6653 defined $chead or $?==256 or failedcmd @symcmd;
6655 fail "$dstbranch is checked out - will not update it"
6656 if defined $chead and $chead eq $dstbranch;
6658 my $oldhash = git_get_ref $dstbranch;
6660 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6661 $dscdata = do { local $/ = undef; <D>; };
6662 D->error and fail "read $dscfn: $!";
6665 # we don't normally need this so import it here
6666 use Dpkg::Source::Package;
6667 my $dp = new Dpkg::Source::Package filename => $dscfn,
6668 require_valid_signature => $needsig;
6670 local $SIG{__WARN__} = sub {
6672 return unless $needsig;
6673 fail "import-dsc signature check failed";
6675 if (!$dp->is_signed()) {
6676 warn "$us: warning: importing unsigned .dsc\n";
6678 my $r = $dp->check_signature();
6679 die "->check_signature => $r" if $needsig && $r;
6685 $package = getfield $dsc, 'Source';
6687 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6688 unless forceing [qw(import-dsc-with-dgit-field)];
6689 parse_dsc_field_def_dsc_distro();
6691 $isuite = 'DGIT-IMPORT-DSC';
6692 $idistro //= $dsc_distro;
6696 if (defined $dsc_hash) {
6697 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6698 resolve_dsc_field_commit undef, undef;
6700 if (defined $dsc_hash) {
6701 my @cmd = (qw(sh -ec),
6702 "echo $dsc_hash | git cat-file --batch-check");
6703 my $objgot = cmdoutput @cmd;
6704 if ($objgot =~ m#^\w+ missing\b#) {
6706 .dsc contains Dgit field referring to object $dsc_hash
6707 Your git tree does not have that object. Try `git fetch' from a
6708 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6711 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6713 progress "Not fast forward, forced update.";
6715 fail "Not fast forward to $dsc_hash";
6718 import_dsc_result $dstbranch, $dsc_hash,
6719 "dgit import-dsc (Dgit): $info",
6720 "updated git ref $dstbranch";
6725 Branch $dstbranch already exists
6726 Specify ..$specbranch for a pseudo-merge, binding in existing history
6727 Specify +$specbranch to overwrite, discarding existing history
6729 if $oldhash && !$force;
6731 my @dfi = dsc_files_info();
6732 foreach my $fi (@dfi) {
6733 my $f = $fi->{Filename};
6734 my $here = "$buildproductsdir/$f";
6737 fail "lstat $here works but stat gives $! !";
6739 fail "stat $here: $!" unless $! == ENOENT;
6741 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6743 } elsif ($dscfn =~ m#^/#) {
6746 fail "cannot import $dscfn which seems to be inside working tree!";
6748 $there =~ s#/+[^/]+$## or
6749 fail "import $dscfn requires ../$f, but it does not exist";
6751 my $test = $there =~ m{^/} ? $there : "../$there";
6752 stat $test or fail "import $dscfn requires $test, but: $!";
6753 symlink $there, $here or fail "symlink $there to $here: $!";
6754 progress "made symlink $here -> $there";
6755 # print STDERR Dumper($fi);
6757 my @mergeinputs = generate_commits_from_dsc();
6758 die unless @mergeinputs == 1;
6760 my $newhash = $mergeinputs[0]{Commit};
6764 progress "Import, forced update - synthetic orphan git history.";
6765 } elsif ($force < 0) {
6766 progress "Import, merging.";
6767 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6768 my $version = getfield $dsc, 'Version';
6769 my $clogp = commit_getclogp $newhash;
6770 my $authline = clogp_authline $clogp;
6771 $newhash = make_commit_text <<END;
6778 Merge $package ($version) import into $dstbranch
6781 die; # caught earlier
6785 import_dsc_result $dstbranch, $newhash,
6786 "dgit import-dsc: $info",
6787 "results are in in git ref $dstbranch";
6790 sub pre_archive_api_query () {
6791 not_necessarily_a_tree();
6793 sub cmd_archive_api_query {
6794 badusage "need only 1 subpath argument" unless @ARGV==1;
6795 my ($subpath) = @ARGV;
6796 local $isuite = 'DGIT-API-QUERY-CMD';
6797 my @cmd = archive_api_query_cmd($subpath);
6800 exec @cmd or fail "exec curl: $!\n";
6803 sub repos_server_url () {
6804 $package = '_dgit-repos-server';
6805 local $access_forpush = 1;
6806 local $isuite = 'DGIT-REPOS-SERVER';
6807 my $url = access_giturl();
6810 sub pre_clone_dgit_repos_server () {
6811 not_necessarily_a_tree();
6813 sub cmd_clone_dgit_repos_server {
6814 badusage "need destination argument" unless @ARGV==1;
6815 my ($destdir) = @ARGV;
6816 my $url = repos_server_url();
6817 my @cmd = (@git, qw(clone), $url, $destdir);
6819 exec @cmd or fail "exec git clone: $!\n";
6822 sub pre_print_dgit_repos_server_source_url () {
6823 not_necessarily_a_tree();
6825 sub cmd_print_dgit_repos_server_source_url {
6826 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6828 my $url = repos_server_url();
6829 print $url, "\n" or die $!;
6832 sub pre_print_dpkg_source_ignores {
6833 not_necessarily_a_tree();
6835 sub cmd_print_dpkg_source_ignores {
6836 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6838 print "@dpkg_source_ignores\n" or die $!;
6841 sub cmd_setup_mergechangelogs {
6842 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6843 local $isuite = 'DGIT-SETUP-TREE';
6844 setup_mergechangelogs(1);
6847 sub cmd_setup_useremail {
6848 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6849 local $isuite = 'DGIT-SETUP-TREE';
6853 sub cmd_setup_gitattributes {
6854 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6855 local $isuite = 'DGIT-SETUP-TREE';
6859 sub cmd_setup_new_tree {
6860 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6861 local $isuite = 'DGIT-SETUP-TREE';
6865 #---------- argument parsing and main program ----------
6868 print "dgit version $our_version\n" or die $!;
6872 our (%valopts_long, %valopts_short);
6873 our (%funcopts_long);
6875 our (@modeopt_cfgs);
6877 sub defvalopt ($$$$) {
6878 my ($long,$short,$val_re,$how) = @_;
6879 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6880 $valopts_long{$long} = $oi;
6881 $valopts_short{$short} = $oi;
6882 # $how subref should:
6883 # do whatever assignemnt or thing it likes with $_[0]
6884 # if the option should not be passed on to remote, @rvalopts=()
6885 # or $how can be a scalar ref, meaning simply assign the value
6888 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6889 defvalopt '--distro', '-d', '.+', \$idistro;
6890 defvalopt '', '-k', '.+', \$keyid;
6891 defvalopt '--existing-package','', '.*', \$existing_package;
6892 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6893 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6894 defvalopt '--package', '-p', $package_re, \$package;
6895 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6897 defvalopt '', '-C', '.+', sub {
6898 ($changesfile) = (@_);
6899 if ($changesfile =~ s#^(.*)/##) {
6900 $buildproductsdir = $1;
6904 defvalopt '--initiator-tempdir','','.*', sub {
6905 ($initiator_tempdir) = (@_);
6906 $initiator_tempdir =~ m#^/# or
6907 badusage "--initiator-tempdir must be used specify an".
6908 " absolute, not relative, directory."
6911 sub defoptmodes ($@) {
6912 my ($varref, $cfgkey, $default, %optmap) = @_;
6914 while (my ($opt,$val) = each %optmap) {
6915 $funcopts_long{$opt} = sub { $$varref = $val; };
6916 $permit{$val} = $val;
6918 push @modeopt_cfgs, {
6921 Default => $default,
6926 defoptmodes \$dodep14tag, qw( dep14tag want
6929 --always-dep14tag always );
6934 if (defined $ENV{'DGIT_SSH'}) {
6935 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6936 } elsif (defined $ENV{'GIT_SSH'}) {
6937 @ssh = ($ENV{'GIT_SSH'});
6945 if (!defined $val) {
6946 badusage "$what needs a value" unless @ARGV;
6948 push @rvalopts, $val;
6950 badusage "bad value \`$val' for $what" unless
6951 $val =~ m/^$oi->{Re}$(?!\n)/s;
6952 my $how = $oi->{How};
6953 if (ref($how) eq 'SCALAR') {
6958 push @ropts, @rvalopts;
6962 last unless $ARGV[0] =~ m/^-/;
6966 if (m/^--dry-run$/) {
6969 } elsif (m/^--damp-run$/) {
6972 } elsif (m/^--no-sign$/) {
6975 } elsif (m/^--help$/) {
6977 } elsif (m/^--version$/) {
6979 } elsif (m/^--new$/) {
6982 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6983 ($om = $opts_opt_map{$1}) &&
6987 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6988 !$opts_opt_cmdonly{$1} &&
6989 ($om = $opts_opt_map{$1})) {
6992 } elsif (m/^--(gbp|dpm)$/s) {
6993 push @ropts, "--quilt=$1";
6995 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6998 } elsif (m/^--no-quilt-fixup$/s) {
7000 $quilt_mode = 'nocheck';
7001 } elsif (m/^--no-rm-on-error$/s) {
7004 } elsif (m/^--no-chase-dsc-distro$/s) {
7006 $chase_dsc_distro = 0;
7007 } elsif (m/^--overwrite$/s) {
7009 $overwrite_version = '';
7010 } elsif (m/^--overwrite=(.+)$/s) {
7012 $overwrite_version = $1;
7013 } elsif (m/^--delayed=(\d+)$/s) {
7016 } elsif (my ($k,$v) =
7017 m/^--save-(dgit-view)=(.+)$/s ||
7018 m/^--(dgit-view)-save=(.+)$/s
7021 $v =~ s#^(?!refs/)#refs/heads/#;
7022 $internal_object_save{$k} = $v;
7023 } elsif (m/^--(no-)?rm-old-changes$/s) {
7026 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7028 push @deliberatelies, $&;
7029 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7033 } elsif (m/^--force-/) {
7035 "$us: warning: ignoring unknown force option $_\n";
7037 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7038 # undocumented, for testing
7040 $tagformat_want = [ $1, 'command line', 1 ];
7041 # 1 menas overrides distro configuration
7042 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7043 # undocumented, for testing
7045 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7046 # ^ it's supposed to be an array ref
7047 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7048 $val = $2 ? $' : undef; #';
7049 $valopt->($oi->{Long});
7050 } elsif ($funcopts_long{$_}) {
7052 $funcopts_long{$_}();
7054 badusage "unknown long option \`$_'";
7061 } elsif (s/^-L/-/) {
7064 } elsif (s/^-h/-/) {
7066 } elsif (s/^-D/-/) {
7070 } elsif (s/^-N/-/) {
7075 push @changesopts, $_;
7077 } elsif (s/^-wn$//s) {
7079 $cleanmode = 'none';
7080 } elsif (s/^-wg$//s) {
7083 } elsif (s/^-wgf$//s) {
7085 $cleanmode = 'git-ff';
7086 } elsif (s/^-wd$//s) {
7088 $cleanmode = 'dpkg-source';
7089 } elsif (s/^-wdd$//s) {
7091 $cleanmode = 'dpkg-source-d';
7092 } elsif (s/^-wc$//s) {
7094 $cleanmode = 'check';
7095 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7096 push @git, '-c', $&;
7097 $gitcfgs{cmdline}{$1} = [ $2 ];
7098 } elsif (s/^-c([^=]+)$//s) {
7099 push @git, '-c', $&;
7100 $gitcfgs{cmdline}{$1} = [ 'true' ];
7101 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7103 $val = undef unless length $val;
7104 $valopt->($oi->{Short});
7107 badusage "unknown short option \`$_'";
7114 sub check_env_sanity () {
7115 my $blocked = new POSIX::SigSet;
7116 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7119 foreach my $name (qw(PIPE CHLD)) {
7120 my $signame = "SIG$name";
7121 my $signum = eval "POSIX::$signame" // die;
7122 die "$signame is set to something other than SIG_DFL\n"
7123 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7124 $blocked->ismember($signum) and
7125 die "$signame is blocked\n";
7131 On entry to dgit, $@
7132 This is a bug produced by something in in your execution environment.
7138 sub parseopts_late_defaults () {
7139 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7140 if defined $idistro;
7141 $isuite //= cfg('dgit.default.default-suite');
7143 foreach my $k (keys %opts_opt_map) {
7144 my $om = $opts_opt_map{$k};
7146 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7148 badcfg "cannot set command for $k"
7149 unless length $om->[0];
7153 foreach my $c (access_cfg_cfgs("opts-$k")) {
7155 map { $_ ? @$_ : () }
7156 map { $gitcfgs{$_}{$c} }
7157 reverse @gitcfgsources;
7158 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7159 "\n" if $debuglevel >= 4;
7161 badcfg "cannot configure options for $k"
7162 if $opts_opt_cmdonly{$k};
7163 my $insertpos = $opts_cfg_insertpos{$k};
7164 @$om = ( @$om[0..$insertpos-1],
7166 @$om[$insertpos..$#$om] );
7170 if (!defined $rmchanges) {
7171 local $access_forpush;
7172 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7175 if (!defined $quilt_mode) {
7176 local $access_forpush;
7177 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7178 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7180 $quilt_mode =~ m/^($quilt_modes_re)$/
7181 or badcfg "unknown quilt-mode \`$quilt_mode'";
7185 foreach my $moc (@modeopt_cfgs) {
7186 local $access_forpush;
7187 my $vr = $moc->{Var};
7188 next if defined $$vr;
7189 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7190 my $v = $moc->{Vals}{$$vr};
7191 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7195 fail "dgit: --include-dirty is not supported in split view quilt mode"
7196 if $split_brain && $includedirty;
7198 if (!defined $cleanmode) {
7199 local $access_forpush;
7200 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7201 $cleanmode //= 'dpkg-source';
7203 badcfg "unknown clean-mode \`$cleanmode'" unless
7204 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7207 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7208 $buildproductsdir //= '..';
7209 $bpd_glob = $buildproductsdir;
7210 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7213 setlocale(LC_MESSAGES, "");
7216 if ($ENV{$fakeeditorenv}) {
7218 quilt_fixup_editor();
7224 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7225 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7226 if $dryrun_level == 1;
7228 print STDERR $helpmsg or die $!;
7231 $cmd = $subcommand = shift @ARGV;
7234 my $pre_fn = ${*::}{"pre_$cmd"};
7235 $pre_fn->() if $pre_fn;
7237 record_maindir if $invoked_in_git_tree;
7240 my $fn = ${*::}{"cmd_$cmd"};
7241 $fn or badusage "unknown operation $cmd";