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 %s".
1479 " which does not appear to exist in suite %s;".
1480 " --existing-package may help",
1485 sub file_in_archive_madison { return undef; }
1486 sub package_not_wholly_new_madison { return undef; }
1488 #---------- `sshpsql' archive query method ----------
1491 my ($data,$runeinfo,$sql) = @_;
1492 if (!length $data) {
1493 $data= access_someuserhost('sshpsql').':'.
1494 access_cfg('sshpsql-dbname');
1496 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1497 my ($userhost,$dbname) = ($`,$'); #';
1499 my @cmd = (access_cfg_ssh, $userhost,
1500 access_runeinfo("ssh-psql $runeinfo").
1501 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1502 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1504 open P, "-|", @cmd or die $!;
1507 printdebug(">|$_|\n");
1510 $!=0; $?=0; close P or failedcmd @cmd;
1512 my $nrows = pop @rows;
1513 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1514 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1515 @rows = map { [ split /\|/, $_ ] } @rows;
1516 my $ncols = scalar @{ shift @rows };
1517 die if grep { scalar @$_ != $ncols } @rows;
1521 sub sql_injection_check {
1522 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1525 sub archive_query_sshpsql ($$) {
1526 my ($proto,$data) = @_;
1527 sql_injection_check $isuite, $package;
1528 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1529 SELECT source.version, component.name, files.filename, files.sha256sum
1531 JOIN src_associations ON source.id = src_associations.source
1532 JOIN suite ON suite.id = src_associations.suite
1533 JOIN dsc_files ON dsc_files.source = source.id
1534 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1535 JOIN component ON component.id = files_archive_map.component_id
1536 JOIN files ON files.id = dsc_files.file
1537 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1538 AND source.source='$package'
1539 AND files.filename LIKE '%.dsc';
1541 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1542 my $digester = Digest::SHA->new(256);
1544 my ($vsn,$component,$filename,$sha256sum) = @$_;
1545 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1547 return archive_query_prepend_mirror @rows;
1550 sub canonicalise_suite_sshpsql ($$) {
1551 my ($proto,$data) = @_;
1552 sql_injection_check $isuite;
1553 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1554 SELECT suite.codename
1555 FROM suite where suite_name='$isuite' or codename='$isuite';
1557 @rows = map { $_->[0] } @rows;
1558 fail "unknown suite $isuite" unless @rows;
1559 die "ambiguous $isuite: @rows ?" if @rows>1;
1563 sub file_in_archive_sshpsql ($$$) { return undef; }
1564 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1566 #---------- `dummycat' archive query method ----------
1568 sub canonicalise_suite_dummycat ($$) {
1569 my ($proto,$data) = @_;
1570 my $dpath = "$data/suite.$isuite";
1571 if (!open C, "<", $dpath) {
1572 $!==ENOENT or die "$dpath: $!";
1573 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1577 chomp or die "$dpath: $!";
1579 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1583 sub archive_query_dummycat ($$) {
1584 my ($proto,$data) = @_;
1585 canonicalise_suite();
1586 my $dpath = "$data/package.$csuite.$package";
1587 if (!open C, "<", $dpath) {
1588 $!==ENOENT or die "$dpath: $!";
1589 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1597 printdebug "dummycat query $csuite $package $dpath | $_\n";
1598 my @row = split /\s+/, $_;
1599 @row==2 or die "$dpath: $_ ?";
1602 C->error and die "$dpath: $!";
1604 return archive_query_prepend_mirror
1605 sort { -version_compare($a->[0],$b->[0]); } @rows;
1608 sub file_in_archive_dummycat () { return undef; }
1609 sub package_not_wholly_new_dummycat () { return undef; }
1611 #---------- tag format handling ----------
1613 sub access_cfg_tagformats () {
1614 split /\,/, access_cfg('dgit-tag-format');
1617 sub access_cfg_tagformats_can_splitbrain () {
1618 my %y = map { $_ => 1 } access_cfg_tagformats;
1619 foreach my $needtf (qw(new maint)) {
1620 next if $y{$needtf};
1626 sub need_tagformat ($$) {
1627 my ($fmt, $why) = @_;
1628 fail "need to use tag format $fmt ($why) but also need".
1629 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1630 " - no way to proceed"
1631 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1632 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1635 sub select_tagformat () {
1637 return if $tagformatfn && !$tagformat_want;
1638 die 'bug' if $tagformatfn && $tagformat_want;
1639 # ... $tagformat_want assigned after previous select_tagformat
1641 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1642 printdebug "select_tagformat supported @supported\n";
1644 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1645 printdebug "select_tagformat specified @$tagformat_want\n";
1647 my ($fmt,$why,$override) = @$tagformat_want;
1649 fail "target distro supports tag formats @supported".
1650 " but have to use $fmt ($why)"
1652 or grep { $_ eq $fmt } @supported;
1654 $tagformat_want = undef;
1656 $tagformatfn = ${*::}{"debiantag_$fmt"};
1658 fail "trying to use unknown tag format \`$fmt' ($why) !"
1659 unless $tagformatfn;
1662 #---------- archive query entrypoints and rest of program ----------
1664 sub canonicalise_suite () {
1665 return if defined $csuite;
1666 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1667 $csuite = archive_query('canonicalise_suite');
1668 if ($isuite ne $csuite) {
1669 progress "canonical suite name for $isuite is $csuite";
1671 progress "canonical suite name is $csuite";
1675 sub get_archive_dsc () {
1676 canonicalise_suite();
1677 my @vsns = archive_query('archive_query');
1678 foreach my $vinfo (@vsns) {
1679 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1680 $dscurl = $vsn_dscurl;
1681 $dscdata = url_get($dscurl);
1683 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1688 $digester->add($dscdata);
1689 my $got = $digester->hexdigest();
1691 fail "$dscurl has hash $got but".
1692 " archive told us to expect $digest";
1695 my $fmt = getfield $dsc, 'Format';
1696 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1697 "unsupported source format $fmt, sorry";
1699 $dsc_checked = !!$digester;
1700 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1704 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1707 sub check_for_git ();
1708 sub check_for_git () {
1710 my $how = access_cfg('git-check');
1711 if ($how eq 'ssh-cmd') {
1713 (access_cfg_ssh, access_gituserhost(),
1714 access_runeinfo("git-check $package").
1715 " set -e; cd ".access_cfg('git-path').";".
1716 " if test -d $package.git; then echo 1; else echo 0; fi");
1717 my $r= cmdoutput @cmd;
1718 if (defined $r and $r =~ m/^divert (\w+)$/) {
1720 my ($usedistro,) = access_distros();
1721 # NB that if we are pushing, $usedistro will be $distro/push
1722 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1723 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1724 progress "diverting to $divert (using config for $instead_distro)";
1725 return check_for_git();
1727 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1729 } elsif ($how eq 'url') {
1730 my $prefix = access_cfg('git-check-url','git-url');
1731 my $suffix = access_cfg('git-check-suffix','git-suffix',
1732 'RETURN-UNDEF') // '.git';
1733 my $url = "$prefix/$package$suffix";
1734 my @cmd = (@curl, qw(-sS -I), $url);
1735 my $result = cmdoutput @cmd;
1736 $result =~ s/^\S+ 200 .*\n\r?\n//;
1737 # curl -sS -I with https_proxy prints
1738 # HTTP/1.0 200 Connection established
1739 $result =~ m/^\S+ (404|200) /s or
1740 fail "unexpected results from git check query - ".
1741 Dumper($prefix, $result);
1743 if ($code eq '404') {
1745 } elsif ($code eq '200') {
1750 } elsif ($how eq 'true') {
1752 } elsif ($how eq 'false') {
1755 badcfg "unknown git-check \`$how'";
1759 sub create_remote_git_repo () {
1760 my $how = access_cfg('git-create');
1761 if ($how eq 'ssh-cmd') {
1763 (access_cfg_ssh, access_gituserhost(),
1764 access_runeinfo("git-create $package").
1765 "set -e; cd ".access_cfg('git-path').";".
1766 " cp -a _template $package.git");
1767 } elsif ($how eq 'true') {
1770 badcfg "unknown git-create \`$how'";
1774 our ($dsc_hash,$lastpush_mergeinput);
1775 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1779 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1780 $playground = fresh_playground 'dgit/unpack';
1783 sub mktree_in_ud_here () {
1784 playtree_setup $gitcfgs{local};
1787 sub git_write_tree () {
1788 my $tree = cmdoutput @git, qw(write-tree);
1789 $tree =~ m/^\w+$/ or die "$tree ?";
1793 sub git_add_write_tree () {
1794 runcmd @git, qw(add -Af .);
1795 return git_write_tree();
1798 sub remove_stray_gits ($) {
1800 my @gitscmd = qw(find -name .git -prune -print0);
1801 debugcmd "|",@gitscmd;
1802 open GITS, "-|", @gitscmd or die $!;
1807 print STDERR "$us: warning: removing from $what: ",
1808 (messagequote $_), "\n";
1812 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1815 sub mktree_in_ud_from_only_subdir ($;$) {
1816 my ($what,$raw) = @_;
1817 # changes into the subdir
1820 die "expected one subdir but found @dirs ?" unless @dirs==1;
1821 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1825 remove_stray_gits($what);
1826 mktree_in_ud_here();
1828 my ($format, $fopts) = get_source_format();
1829 if (madformat($format)) {
1834 my $tree=git_add_write_tree();
1835 return ($tree,$dir);
1838 our @files_csum_info_fields =
1839 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1840 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1841 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1843 sub dsc_files_info () {
1844 foreach my $csumi (@files_csum_info_fields) {
1845 my ($fname, $module, $method) = @$csumi;
1846 my $field = $dsc->{$fname};
1847 next unless defined $field;
1848 eval "use $module; 1;" or die $@;
1850 foreach (split /\n/, $field) {
1852 m/^(\w+) (\d+) (\S+)$/ or
1853 fail "could not parse .dsc $fname line \`$_'";
1854 my $digester = eval "$module"."->$method;" or die $@;
1859 Digester => $digester,
1864 fail "missing any supported Checksums-* or Files field in ".
1865 $dsc->get_option('name');
1869 map { $_->{Filename} } dsc_files_info();
1872 sub files_compare_inputs (@) {
1877 my $showinputs = sub {
1878 return join "; ", map { $_->get_option('name') } @$inputs;
1881 foreach my $in (@$inputs) {
1883 my $in_name = $in->get_option('name');
1885 printdebug "files_compare_inputs $in_name\n";
1887 foreach my $csumi (@files_csum_info_fields) {
1888 my ($fname) = @$csumi;
1889 printdebug "files_compare_inputs $in_name $fname\n";
1891 my $field = $in->{$fname};
1892 next unless defined $field;
1895 foreach (split /\n/, $field) {
1898 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1899 fail "could not parse $in_name $fname line \`$_'";
1901 printdebug "files_compare_inputs $in_name $fname $f\n";
1905 my $re = \ $record{$f}{$fname};
1907 $fchecked{$f}{$in_name} = 1;
1909 fail "hash or size of $f varies in $fname fields".
1910 " (between: ".$showinputs->().")";
1915 @files = sort @files;
1916 $expected_files //= \@files;
1917 "@$expected_files" eq "@files" or
1918 fail "file list in $in_name varies between hash fields!";
1921 fail "$in_name has no files list field(s)";
1923 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1926 grep { keys %$_ == @$inputs-1 } values %fchecked
1927 or fail "no file appears in all file lists".
1928 " (looked in: ".$showinputs->().")";
1931 sub is_orig_file_in_dsc ($$) {
1932 my ($f, $dsc_files_info) = @_;
1933 return 0 if @$dsc_files_info <= 1;
1934 # One file means no origs, and the filename doesn't have a "what
1935 # part of dsc" component. (Consider versions ending `.orig'.)
1936 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1940 # This function determines whether a .changes file is source-only from
1941 # the point of view of dak. Thus, it permits *_source.buildinfo
1944 # It does not, however, permit any other buildinfo files. After a
1945 # source-only upload, the buildds will try to upload files like
1946 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1947 # named like this in their (otherwise) source-only upload, the uploads
1948 # of the buildd can be rejected by dak. Fixing the resultant
1949 # situation can require manual intervention. So we block such
1950 # .buildinfo files when the user tells us to perform a source-only
1951 # upload (such as when using the push-source subcommand with the -C
1952 # option, which calls this function).
1954 # Note, though, that when dgit is told to prepare a source-only
1955 # upload, such as when subcommands like build-source and push-source
1956 # without -C are used, dgit has a more restrictive notion of
1957 # source-only .changes than dak: such uploads will never include
1958 # *_source.buildinfo files. This is because there is no use for such
1959 # files when using a tool like dgit to produce the source package, as
1960 # dgit ensures the source is identical to git HEAD.
1961 sub test_source_only_changes ($) {
1963 foreach my $l (split /\n/, getfield $changes, 'Files') {
1964 $l =~ m/\S+$/ or next;
1965 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1966 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1967 print "purportedly source-only changes polluted by $&\n";
1974 sub changes_update_origs_from_dsc ($$$$) {
1975 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1977 printdebug "checking origs needed ($upstreamvsn)...\n";
1978 $_ = getfield $changes, 'Files';
1979 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1980 fail "cannot find section/priority from .changes Files field";
1981 my $placementinfo = $1;
1983 printdebug "checking origs needed placement '$placementinfo'...\n";
1984 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1985 $l =~ m/\S+$/ or next;
1987 printdebug "origs $file | $l\n";
1988 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1989 printdebug "origs $file is_orig\n";
1990 my $have = archive_query('file_in_archive', $file);
1991 if (!defined $have) {
1993 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1999 printdebug "origs $file \$#\$have=$#$have\n";
2000 foreach my $h (@$have) {
2003 foreach my $csumi (@files_csum_info_fields) {
2004 my ($fname, $module, $method, $archivefield) = @$csumi;
2005 next unless defined $h->{$archivefield};
2006 $_ = $dsc->{$fname};
2007 next unless defined;
2008 m/^(\w+) .* \Q$file\E$/m or
2009 fail ".dsc $fname missing entry for $file";
2010 if ($h->{$archivefield} eq $1) {
2014 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
2017 die "$file ".Dumper($h)." ?!" if $same && @differ;
2020 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
2023 printdebug "origs $file f.same=$found_same".
2024 " #f._differ=$#found_differ\n";
2025 if (@found_differ && !$found_same) {
2027 "archive contains $file with different checksum",
2030 # Now we edit the changes file to add or remove it
2031 foreach my $csumi (@files_csum_info_fields) {
2032 my ($fname, $module, $method, $archivefield) = @$csumi;
2033 next unless defined $changes->{$fname};
2035 # in archive, delete from .changes if it's there
2036 $changed{$file} = "removed" if
2037 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2038 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2039 # not in archive, but it's here in the .changes
2041 my $dsc_data = getfield $dsc, $fname;
2042 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2044 $extra =~ s/ \d+ /$&$placementinfo /
2045 or die "$fname $extra >$dsc_data< ?"
2046 if $fname eq 'Files';
2047 $changes->{$fname} .= "\n". $extra;
2048 $changed{$file} = "added";
2053 foreach my $file (keys %changed) {
2055 "edited .changes for archive .orig contents: %s %s",
2056 $changed{$file}, $file;
2058 my $chtmp = "$changesfile.tmp";
2059 $changes->save($chtmp);
2061 rename $chtmp,$changesfile or die "$changesfile $!";
2063 progress "[new .changes left in $changesfile]";
2066 progress "$changesfile already has appropriate .orig(s) (if any)";
2070 sub make_commit ($) {
2072 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2075 sub clogp_authline ($) {
2077 my $author = getfield $clogp, 'Maintainer';
2078 if ($author =~ m/^[^"\@]+\,/) {
2079 # single entry Maintainer field with unquoted comma
2080 $author = ($& =~ y/,//rd).$'; # strip the comma
2082 # git wants a single author; any remaining commas in $author
2083 # are by now preceded by @ (or "). It seems safer to punt on
2084 # "..." for now rather than attempting to dequote or something.
2085 $author =~ s#,.*##ms unless $author =~ m/"/;
2086 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2087 my $authline = "$author $date";
2088 $authline =~ m/$git_authline_re/o or
2089 fail "unexpected commit author line format \`$authline'".
2090 " (was generated from changelog Maintainer field)";
2091 return ($1,$2,$3) if wantarray;
2095 sub vendor_patches_distro ($$) {
2096 my ($checkdistro, $what) = @_;
2097 return unless defined $checkdistro;
2099 my $series = "debian/patches/\L$checkdistro\E.series";
2100 printdebug "checking for vendor-specific $series ($what)\n";
2102 if (!open SERIES, "<", $series) {
2103 die "$series $!" unless $!==ENOENT;
2112 Unfortunately, this source package uses a feature of dpkg-source where
2113 the same source package unpacks to different source code on different
2114 distros. dgit cannot safely operate on such packages on affected
2115 distros, because the meaning of source packages is not stable.
2117 Please ask the distro/maintainer to remove the distro-specific series
2118 files and use a different technique (if necessary, uploading actually
2119 different packages, if different distros are supposed to have
2123 fail "Found active distro-specific series file for".
2124 " $checkdistro ($what): $series, cannot continue";
2126 die "$series $!" if SERIES->error;
2130 sub check_for_vendor_patches () {
2131 # This dpkg-source feature doesn't seem to be documented anywhere!
2132 # But it can be found in the changelog (reformatted):
2134 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2135 # Author: Raphael Hertzog <hertzog@debian.org>
2136 # Date: Sun Oct 3 09:36:48 2010 +0200
2138 # dpkg-source: correctly create .pc/.quilt_series with alternate
2141 # If you have debian/patches/ubuntu.series and you were
2142 # unpacking the source package on ubuntu, quilt was still
2143 # directed to debian/patches/series instead of
2144 # debian/patches/ubuntu.series.
2146 # debian/changelog | 3 +++
2147 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2148 # 2 files changed, 6 insertions(+), 1 deletion(-)
2151 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2152 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2153 "Dpkg::Vendor \`current vendor'");
2154 vendor_patches_distro(access_basedistro(),
2155 "(base) distro being accessed");
2156 vendor_patches_distro(access_nomdistro(),
2157 "(nominal) distro being accessed");
2160 sub generate_commits_from_dsc () {
2161 # See big comment in fetch_from_archive, below.
2162 # See also README.dsc-import.
2164 changedir $playground;
2166 my @dfi = dsc_files_info();
2167 foreach my $fi (@dfi) {
2168 my $f = $fi->{Filename};
2169 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2170 my $upper_f = (bpd_abs()."/$f");
2172 printdebug "considering reusing $f: ";
2174 if (link_ltarget "$upper_f,fetch", $f) {
2175 printdebug "linked (using ...,fetch).\n";
2176 } elsif ((printdebug "($!) "),
2178 fail "accessing $buildproductsdir/$f,fetch: $!";
2179 } elsif (link_ltarget $upper_f, $f) {
2180 printdebug "linked.\n";
2181 } elsif ((printdebug "($!) "),
2183 fail "accessing $buildproductsdir/$f: $!";
2185 printdebug "absent.\n";
2189 complete_file_from_dsc('.', $fi, \$refetched)
2192 printdebug "considering saving $f: ";
2194 if (link $f, $upper_f) {
2195 printdebug "linked.\n";
2196 } elsif ((printdebug "($!) "),
2198 fail "saving $buildproductsdir/$f: $!";
2199 } elsif (!$refetched) {
2200 printdebug "no need.\n";
2201 } elsif (link $f, "$upper_f,fetch") {
2202 printdebug "linked (using ...,fetch).\n";
2203 } elsif ((printdebug "($!) "),
2205 fail "saving $buildproductsdir/$f,fetch: $!";
2207 printdebug "cannot.\n";
2211 # We unpack and record the orig tarballs first, so that we only
2212 # need disk space for one private copy of the unpacked source.
2213 # But we can't make them into commits until we have the metadata
2214 # from the debian/changelog, so we record the tree objects now and
2215 # make them into commits later.
2217 my $upstreamv = upstreamversion $dsc->{version};
2218 my $orig_f_base = srcfn $upstreamv, '';
2220 foreach my $fi (@dfi) {
2221 # We actually import, and record as a commit, every tarball
2222 # (unless there is only one file, in which case there seems
2225 my $f = $fi->{Filename};
2226 printdebug "import considering $f ";
2227 (printdebug "only one dfi\n"), next if @dfi == 1;
2228 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2229 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2233 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2235 printdebug "Y ", (join ' ', map { $_//"(none)" }
2236 $compr_ext, $orig_f_part
2239 my $input = new IO::File $f, '<' or die "$f $!";
2243 if (defined $compr_ext) {
2245 Dpkg::Compression::compression_guess_from_filename $f;
2246 fail "Dpkg::Compression cannot handle file $f in source package"
2247 if defined $compr_ext && !defined $cname;
2249 new Dpkg::Compression::Process compression => $cname;
2250 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2251 my $compr_fh = new IO::Handle;
2252 my $compr_pid = open $compr_fh, "-|" // die $!;
2254 open STDIN, "<&", $input or die $!;
2256 die "dgit (child): exec $compr_cmd[0]: $!\n";
2261 rmtree "_unpack-tar";
2262 mkdir "_unpack-tar" or die $!;
2263 my @tarcmd = qw(tar -x -f -
2264 --no-same-owner --no-same-permissions
2265 --no-acls --no-xattrs --no-selinux);
2266 my $tar_pid = fork // die $!;
2268 chdir "_unpack-tar" or die $!;
2269 open STDIN, "<&", $input or die $!;
2271 die "dgit (child): exec $tarcmd[0]: $!";
2273 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2274 !$? or failedcmd @tarcmd;
2277 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2279 # finally, we have the results in "tarball", but maybe
2280 # with the wrong permissions
2282 runcmd qw(chmod -R +rwX _unpack-tar);
2283 changedir "_unpack-tar";
2284 remove_stray_gits($f);
2285 mktree_in_ud_here();
2287 my ($tree) = git_add_write_tree();
2288 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2289 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2291 printdebug "one subtree $1\n";
2293 printdebug "multiple subtrees\n";
2296 rmtree "_unpack-tar";
2298 my $ent = [ $f, $tree ];
2300 Orig => !!$orig_f_part,
2301 Sort => (!$orig_f_part ? 2 :
2302 $orig_f_part =~ m/-/g ? 1 :
2310 # put any without "_" first (spec is not clear whether files
2311 # are always in the usual order). Tarballs without "_" are
2312 # the main orig or the debian tarball.
2313 $a->{Sort} <=> $b->{Sort} or
2317 my $any_orig = grep { $_->{Orig} } @tartrees;
2319 my $dscfn = "$package.dsc";
2321 my $treeimporthow = 'package';
2323 open D, ">", $dscfn or die "$dscfn: $!";
2324 print D $dscdata or die "$dscfn: $!";
2325 close D or die "$dscfn: $!";
2326 my @cmd = qw(dpkg-source);
2327 push @cmd, '--no-check' if $dsc_checked;
2328 if (madformat $dsc->{format}) {
2329 push @cmd, '--skip-patches';
2330 $treeimporthow = 'unpatched';
2332 push @cmd, qw(-x --), $dscfn;
2335 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2336 if (madformat $dsc->{format}) {
2337 check_for_vendor_patches();
2341 if (madformat $dsc->{format}) {
2342 my @pcmd = qw(dpkg-source --before-build .);
2343 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2345 $dappliedtree = git_add_write_tree();
2348 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2352 printdebug "import clog search...\n";
2353 parsechangelog_loop \@clogcmd, "package changelog", sub {
2354 my ($thisstanza, $desc) = @_;
2355 no warnings qw(exiting);
2357 $clogp //= $thisstanza;
2359 printdebug "import clog $thisstanza->{version} $desc...\n";
2361 last if !$any_orig; # we don't need $r1clogp
2363 # We look for the first (most recent) changelog entry whose
2364 # version number is lower than the upstream version of this
2365 # package. Then the last (least recent) previous changelog
2366 # entry is treated as the one which introduced this upstream
2367 # version and used for the synthetic commits for the upstream
2370 # One might think that a more sophisticated algorithm would be
2371 # necessary. But: we do not want to scan the whole changelog
2372 # file. Stopping when we see an earlier version, which
2373 # necessarily then is an earlier upstream version, is the only
2374 # realistic way to do that. Then, either the earliest
2375 # changelog entry we have seen so far is indeed the earliest
2376 # upload of this upstream version; or there are only changelog
2377 # entries relating to later upstream versions (which is not
2378 # possible unless the changelog and .dsc disagree about the
2379 # version). Then it remains to choose between the physically
2380 # last entry in the file, and the one with the lowest version
2381 # number. If these are not the same, we guess that the
2382 # versions were created in a non-monotonic order rather than
2383 # that the changelog entries have been misordered.
2385 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2387 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2388 $r1clogp = $thisstanza;
2390 printdebug "import clog $r1clogp->{version} becomes r1\n";
2393 $clogp or fail "package changelog has no entries!";
2395 my $authline = clogp_authline $clogp;
2396 my $changes = getfield $clogp, 'Changes';
2397 $changes =~ s/^\n//; # Changes: \n
2398 my $cversion = getfield $clogp, 'Version';
2401 $r1clogp //= $clogp; # maybe there's only one entry;
2402 my $r1authline = clogp_authline $r1clogp;
2403 # Strictly, r1authline might now be wrong if it's going to be
2404 # unused because !$any_orig. Whatever.
2406 printdebug "import tartrees authline $authline\n";
2407 printdebug "import tartrees r1authline $r1authline\n";
2409 foreach my $tt (@tartrees) {
2410 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2412 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2415 committer $r1authline
2419 [dgit import orig $tt->{F}]
2427 [dgit import tarball $package $cversion $tt->{F}]
2432 printdebug "import main commit\n";
2434 open C, ">../commit.tmp" or die $!;
2435 print C <<END or die $!;
2438 print C <<END or die $! foreach @tartrees;
2441 print C <<END or die $!;
2447 [dgit import $treeimporthow $package $cversion]
2451 my $rawimport_hash = make_commit qw(../commit.tmp);
2453 if (madformat $dsc->{format}) {
2454 printdebug "import apply patches...\n";
2456 # regularise the state of the working tree so that
2457 # the checkout of $rawimport_hash works nicely.
2458 my $dappliedcommit = make_commit_text(<<END);
2465 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2467 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2469 # We need the answers to be reproducible
2470 my @authline = clogp_authline($clogp);
2471 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2472 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2473 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2474 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2475 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2476 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2478 my $path = $ENV{PATH} or die;
2480 # we use ../../gbp-pq-output, which (given that we are in
2481 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2484 foreach my $use_absurd (qw(0 1)) {
2485 runcmd @git, qw(checkout -q unpa);
2486 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2487 local $ENV{PATH} = $path;
2490 progress "warning: $@";
2491 $path = "$absurdity:$path";
2492 progress "$us: trying slow absurd-git-apply...";
2493 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2498 die "forbid absurd git-apply\n" if $use_absurd
2499 && forceing [qw(import-gitapply-no-absurd)];
2500 die "only absurd git-apply!\n" if !$use_absurd
2501 && forceing [qw(import-gitapply-absurd)];
2503 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2504 local $ENV{PATH} = $path if $use_absurd;
2506 my @showcmd = (gbp_pq, qw(import));
2507 my @realcmd = shell_cmd
2508 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2509 debugcmd "+",@realcmd;
2510 if (system @realcmd) {
2511 die +(shellquote @showcmd).
2513 failedcmd_waitstatus()."\n";
2516 my $gapplied = git_rev_parse('HEAD');
2517 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2518 $gappliedtree eq $dappliedtree or
2520 gbp-pq import and dpkg-source disagree!
2521 gbp-pq import gave commit $gapplied
2522 gbp-pq import gave tree $gappliedtree
2523 dpkg-source --before-build gave tree $dappliedtree
2525 $rawimport_hash = $gapplied;
2530 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2535 progress "synthesised git commit from .dsc $cversion";
2537 my $rawimport_mergeinput = {
2538 Commit => $rawimport_hash,
2539 Info => "Import of source package",
2541 my @output = ($rawimport_mergeinput);
2543 if ($lastpush_mergeinput) {
2544 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2545 my $oversion = getfield $oldclogp, 'Version';
2547 version_compare($oversion, $cversion);
2549 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2550 { Message => <<END, ReverseParents => 1 });
2551 Record $package ($cversion) in archive suite $csuite
2553 } elsif ($vcmp > 0) {
2554 print STDERR <<END or die $!;
2556 Version actually in archive: $cversion (older)
2557 Last version pushed with dgit: $oversion (newer or same)
2560 @output = $lastpush_mergeinput;
2562 # Same version. Use what's in the server git branch,
2563 # discarding our own import. (This could happen if the
2564 # server automatically imports all packages into git.)
2565 @output = $lastpush_mergeinput;
2573 sub complete_file_from_dsc ($$;$) {
2574 our ($dstdir, $fi, $refetched) = @_;
2575 # Ensures that we have, in $dstdir, the file $fi, with the correct
2576 # contents. (Downloading it from alongside $dscurl if necessary.)
2577 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2578 # and will set $$refetched=1 if it did so (or tried to).
2580 my $f = $fi->{Filename};
2581 my $tf = "$dstdir/$f";
2585 my $checkhash = sub {
2586 open F, "<", "$tf" or die "$tf: $!";
2587 $fi->{Digester}->reset();
2588 $fi->{Digester}->addfile(*F);
2589 F->error and die $!;
2590 $got = $fi->{Digester}->hexdigest();
2591 return $got eq $fi->{Hash};
2594 if (stat_exists $tf) {
2595 if ($checkhash->()) {
2596 progress "using existing $f";
2600 fail "file $f has hash $got but .dsc".
2601 " demands hash $fi->{Hash} ".
2602 "(perhaps you should delete this file?)";
2604 progress "need to fetch correct version of $f";
2605 unlink $tf or die "$tf $!";
2608 printdebug "$tf does not exist, need to fetch\n";
2612 $furl =~ s{/[^/]+$}{};
2614 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2615 die "$f ?" if $f =~ m#/#;
2616 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2617 return 0 if !act_local();
2620 fail "file $f has hash $got but .dsc".
2621 " demands hash $fi->{Hash} ".
2622 "(got wrong file from archive!)";
2627 sub ensure_we_have_orig () {
2628 my @dfi = dsc_files_info();
2629 foreach my $fi (@dfi) {
2630 my $f = $fi->{Filename};
2631 next unless is_orig_file_in_dsc($f, \@dfi);
2632 complete_file_from_dsc($buildproductsdir, $fi)
2637 #---------- git fetch ----------
2639 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2640 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2642 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2643 # locally fetched refs because they have unhelpful names and clutter
2644 # up gitk etc. So we track whether we have "used up" head ref (ie,
2645 # whether we have made another local ref which refers to this object).
2647 # (If we deleted them unconditionally, then we might end up
2648 # re-fetching the same git objects each time dgit fetch was run.)
2650 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2651 # in git_fetch_us to fetch the refs in question, and possibly a call
2652 # to lrfetchref_used.
2654 our (%lrfetchrefs_f, %lrfetchrefs_d);
2655 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2657 sub lrfetchref_used ($) {
2658 my ($fullrefname) = @_;
2659 my $objid = $lrfetchrefs_f{$fullrefname};
2660 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2663 sub git_lrfetch_sane {
2664 my ($url, $supplementary, @specs) = @_;
2665 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2666 # at least as regards @specs. Also leave the results in
2667 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2668 # able to clean these up.
2670 # With $supplementary==1, @specs must not contain wildcards
2671 # and we add to our previous fetches (non-atomically).
2673 # This is rather miserable:
2674 # When git fetch --prune is passed a fetchspec ending with a *,
2675 # it does a plausible thing. If there is no * then:
2676 # - it matches subpaths too, even if the supplied refspec
2677 # starts refs, and behaves completely madly if the source
2678 # has refs/refs/something. (See, for example, Debian #NNNN.)
2679 # - if there is no matching remote ref, it bombs out the whole
2681 # We want to fetch a fixed ref, and we don't know in advance
2682 # if it exists, so this is not suitable.
2684 # Our workaround is to use git ls-remote. git ls-remote has its
2685 # own qairks. Notably, it has the absurd multi-tail-matching
2686 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2687 # refs/refs/foo etc.
2689 # Also, we want an idempotent snapshot, but we have to make two
2690 # calls to the remote: one to git ls-remote and to git fetch. The
2691 # solution is use git ls-remote to obtain a target state, and
2692 # git fetch to try to generate it. If we don't manage to generate
2693 # the target state, we try again.
2695 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2697 my $specre = join '|', map {
2700 my $wildcard = $x =~ s/\\\*$/.*/;
2701 die if $wildcard && $supplementary;
2704 printdebug "git_lrfetch_sane specre=$specre\n";
2705 my $wanted_rref = sub {
2707 return m/^(?:$specre)$/;
2710 my $fetch_iteration = 0;
2713 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2714 if (++$fetch_iteration > 10) {
2715 fail "too many iterations trying to get sane fetch!";
2718 my @look = map { "refs/$_" } @specs;
2719 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2723 open GITLS, "-|", @lcmd or die $!;
2725 printdebug "=> ", $_;
2726 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2727 my ($objid,$rrefname) = ($1,$2);
2728 if (!$wanted_rref->($rrefname)) {
2730 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2734 $wantr{$rrefname} = $objid;
2737 close GITLS or failedcmd @lcmd;
2739 # OK, now %want is exactly what we want for refs in @specs
2741 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2742 "+refs/$_:".lrfetchrefs."/$_";
2745 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2747 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2748 runcmd_ordryrun_local @fcmd if @fspecs;
2750 if (!$supplementary) {
2751 %lrfetchrefs_f = ();
2755 git_for_each_ref(lrfetchrefs, sub {
2756 my ($objid,$objtype,$lrefname,$reftail) = @_;
2757 $lrfetchrefs_f{$lrefname} = $objid;
2758 $objgot{$objid} = 1;
2761 if ($supplementary) {
2765 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2766 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2767 if (!exists $wantr{$rrefname}) {
2768 if ($wanted_rref->($rrefname)) {
2770 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2774 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2777 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2778 delete $lrfetchrefs_f{$lrefname};
2782 foreach my $rrefname (sort keys %wantr) {
2783 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2784 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2785 my $want = $wantr{$rrefname};
2786 next if $got eq $want;
2787 if (!defined $objgot{$want}) {
2788 fail <<END unless act_local();
2789 --dry-run specified but we actually wanted the results of git fetch,
2790 so this is not going to work. Try running dgit fetch first,
2791 or using --damp-run instead of --dry-run.
2794 warning: git ls-remote suggests we want $lrefname
2795 warning: and it should refer to $want
2796 warning: but git fetch didn't fetch that object to any relevant ref.
2797 warning: This may be due to a race with someone updating the server.
2798 warning: Will try again...
2800 next FETCH_ITERATION;
2803 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2805 runcmd_ordryrun_local @git, qw(update-ref -m),
2806 "dgit fetch git fetch fixup", $lrefname, $want;
2807 $lrfetchrefs_f{$lrefname} = $want;
2812 if (defined $csuite) {
2813 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2814 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2815 my ($objid,$objtype,$lrefname,$reftail) = @_;
2816 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2817 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2821 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2822 Dumper(\%lrfetchrefs_f);
2825 sub git_fetch_us () {
2826 # Want to fetch only what we are going to use, unless
2827 # deliberately-not-ff, in which case we must fetch everything.
2829 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2831 (quiltmode_splitbrain
2832 ? (map { $_->('*',access_nomdistro) }
2833 \&debiantag_new, \&debiantag_maintview)
2834 : debiantags('*',access_nomdistro));
2835 push @specs, server_branch($csuite);
2836 push @specs, $rewritemap;
2837 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2839 my $url = access_giturl();
2840 git_lrfetch_sane $url, 0, @specs;
2843 my @tagpats = debiantags('*',access_nomdistro);
2845 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2846 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2847 printdebug "currently $fullrefname=$objid\n";
2848 $here{$fullrefname} = $objid;
2850 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2851 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2852 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2853 printdebug "offered $lref=$objid\n";
2854 if (!defined $here{$lref}) {
2855 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2856 runcmd_ordryrun_local @upd;
2857 lrfetchref_used $fullrefname;
2858 } elsif ($here{$lref} eq $objid) {
2859 lrfetchref_used $fullrefname;
2862 "Not updating $lref from $here{$lref} to $objid.\n";
2867 #---------- dsc and archive handling ----------
2869 sub mergeinfo_getclogp ($) {
2870 # Ensures thit $mi->{Clogp} exists and returns it
2872 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2875 sub mergeinfo_version ($) {
2876 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2879 sub fetch_from_archive_record_1 ($) {
2881 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2882 cmdoutput @git, qw(log -n2), $hash;
2883 # ... gives git a chance to complain if our commit is malformed
2886 sub fetch_from_archive_record_2 ($) {
2888 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2892 dryrun_report @upd_cmd;
2896 sub parse_dsc_field_def_dsc_distro () {
2897 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2898 dgit.default.distro);
2901 sub parse_dsc_field ($$) {
2902 my ($dsc, $what) = @_;
2904 foreach my $field (@ourdscfield) {
2905 $f = $dsc->{$field};
2910 progress "$what: NO git hash";
2911 parse_dsc_field_def_dsc_distro();
2912 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2913 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2914 progress "$what: specified git info ($dsc_distro)";
2915 $dsc_hint_tag = [ $dsc_hint_tag ];
2916 } elsif ($f =~ m/^\w+\s*$/) {
2918 parse_dsc_field_def_dsc_distro();
2919 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2921 progress "$what: specified git hash";
2923 fail "$what: invalid Dgit info";
2927 sub resolve_dsc_field_commit ($$) {
2928 my ($already_distro, $already_mapref) = @_;
2930 return unless defined $dsc_hash;
2933 defined $already_mapref &&
2934 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2935 ? $already_mapref : undef;
2939 my ($what, @fetch) = @_;
2941 local $idistro = $dsc_distro;
2942 my $lrf = lrfetchrefs;
2944 if (!$chase_dsc_distro) {
2946 "not chasing .dsc distro $dsc_distro: not fetching $what";
2951 ".dsc names distro $dsc_distro: fetching $what";
2953 my $url = access_giturl();
2954 if (!defined $url) {
2955 defined $dsc_hint_url or fail <<END;
2956 .dsc Dgit metadata is in context of distro $dsc_distro
2957 for which we have no configured url and .dsc provides no hint
2960 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2961 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2962 parse_cfg_bool "dsc-url-proto-ok", 'false',
2963 cfg("dgit.dsc-url-proto-ok.$proto",
2964 "dgit.default.dsc-url-proto-ok")
2966 .dsc Dgit metadata is in context of distro $dsc_distro
2967 for which we have no configured url;
2968 .dsc provides hinted url with protocol $proto which is unsafe.
2969 (can be overridden by config - consult documentation)
2971 $url = $dsc_hint_url;
2974 git_lrfetch_sane $url, 1, @fetch;
2979 my $rewrite_enable = do {
2980 local $idistro = $dsc_distro;
2981 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2984 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2985 if (!defined $mapref) {
2986 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2987 $mapref = $lrf.'/'.$rewritemap;
2989 my $rewritemapdata = git_cat_file $mapref.':map';
2990 if (defined $rewritemapdata
2991 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2993 "server's git history rewrite map contains a relevant entry!";
2996 if (defined $dsc_hash) {
2997 progress "using rewritten git hash in place of .dsc value";
2999 progress "server data says .dsc hash is to be disregarded";
3004 if (!defined git_cat_file $dsc_hash) {
3005 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3006 my $lrf = $do_fetch->("additional commits", @tags) &&
3007 defined git_cat_file $dsc_hash
3009 .dsc Dgit metadata requires commit $dsc_hash
3010 but we could not obtain that object anywhere.
3012 foreach my $t (@tags) {
3013 my $fullrefname = $lrf.'/'.$t;
3014 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3015 next unless $lrfetchrefs_f{$fullrefname};
3016 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3017 lrfetchref_used $fullrefname;
3022 sub fetch_from_archive () {
3023 ensure_setup_existing_tree();
3025 # Ensures that lrref() is what is actually in the archive, one way
3026 # or another, according to us - ie this client's
3027 # appropritaely-updated archive view. Also returns the commit id.
3028 # If there is nothing in the archive, leaves lrref alone and
3029 # returns undef. git_fetch_us must have already been called.
3033 parse_dsc_field($dsc, 'last upload to archive');
3034 resolve_dsc_field_commit access_basedistro,
3035 lrfetchrefs."/".$rewritemap
3037 progress "no version available from the archive";
3040 # If the archive's .dsc has a Dgit field, there are three
3041 # relevant git commitids we need to choose between and/or merge
3043 # 1. $dsc_hash: the Dgit field from the archive
3044 # 2. $lastpush_hash: the suite branch on the dgit git server
3045 # 3. $lastfetch_hash: our local tracking brach for the suite
3047 # These may all be distinct and need not be in any fast forward
3050 # If the dsc was pushed to this suite, then the server suite
3051 # branch will have been updated; but it might have been pushed to
3052 # a different suite and copied by the archive. Conversely a more
3053 # recent version may have been pushed with dgit but not appeared
3054 # in the archive (yet).
3056 # $lastfetch_hash may be awkward because archive imports
3057 # (particularly, imports of Dgit-less .dscs) are performed only as
3058 # needed on individual clients, so different clients may perform a
3059 # different subset of them - and these imports are only made
3060 # public during push. So $lastfetch_hash may represent a set of
3061 # imports different to a subsequent upload by a different dgit
3064 # Our approach is as follows:
3066 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3067 # descendant of $dsc_hash, then it was pushed by a dgit user who
3068 # had based their work on $dsc_hash, so we should prefer it.
3069 # Otherwise, $dsc_hash was installed into this suite in the
3070 # archive other than by a dgit push, and (necessarily) after the
3071 # last dgit push into that suite (since a dgit push would have
3072 # been descended from the dgit server git branch); thus, in that
3073 # case, we prefer the archive's version (and produce a
3074 # pseudo-merge to overwrite the dgit server git branch).
3076 # (If there is no Dgit field in the archive's .dsc then
3077 # generate_commit_from_dsc uses the version numbers to decide
3078 # whether the suite branch or the archive is newer. If the suite
3079 # branch is newer it ignores the archive's .dsc; otherwise it
3080 # generates an import of the .dsc, and produces a pseudo-merge to
3081 # overwrite the suite branch with the archive contents.)
3083 # The outcome of that part of the algorithm is the `public view',
3084 # and is same for all dgit clients: it does not depend on any
3085 # unpublished history in the local tracking branch.
3087 # As between the public view and the local tracking branch: The
3088 # local tracking branch is only updated by dgit fetch, and
3089 # whenever dgit fetch runs it includes the public view in the
3090 # local tracking branch. Therefore if the public view is not
3091 # descended from the local tracking branch, the local tracking
3092 # branch must contain history which was imported from the archive
3093 # but never pushed; and, its tip is now out of date. So, we make
3094 # a pseudo-merge to overwrite the old imports and stitch the old
3097 # Finally: we do not necessarily reify the public view (as
3098 # described above). This is so that we do not end up stacking two
3099 # pseudo-merges. So what we actually do is figure out the inputs
3100 # to any public view pseudo-merge and put them in @mergeinputs.
3103 # $mergeinputs[]{Commit}
3104 # $mergeinputs[]{Info}
3105 # $mergeinputs[0] is the one whose tree we use
3106 # @mergeinputs is in the order we use in the actual commit)
3109 # $mergeinputs[]{Message} is a commit message to use
3110 # $mergeinputs[]{ReverseParents} if def specifies that parent
3111 # list should be in opposite order
3112 # Such an entry has no Commit or Info. It applies only when found
3113 # in the last entry. (This ugliness is to support making
3114 # identical imports to previous dgit versions.)
3116 my $lastpush_hash = git_get_ref(lrfetchref());
3117 printdebug "previous reference hash=$lastpush_hash\n";
3118 $lastpush_mergeinput = $lastpush_hash && {
3119 Commit => $lastpush_hash,
3120 Info => "dgit suite branch on dgit git server",
3123 my $lastfetch_hash = git_get_ref(lrref());
3124 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3125 my $lastfetch_mergeinput = $lastfetch_hash && {
3126 Commit => $lastfetch_hash,
3127 Info => "dgit client's archive history view",
3130 my $dsc_mergeinput = $dsc_hash && {
3131 Commit => $dsc_hash,
3132 Info => "Dgit field in .dsc from archive",
3136 my $del_lrfetchrefs = sub {
3139 printdebug "del_lrfetchrefs...\n";
3140 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3141 my $objid = $lrfetchrefs_d{$fullrefname};
3142 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3144 $gur ||= new IO::Handle;
3145 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3147 printf $gur "delete %s %s\n", $fullrefname, $objid;
3150 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3154 if (defined $dsc_hash) {
3155 ensure_we_have_orig();
3156 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3157 @mergeinputs = $dsc_mergeinput
3158 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3159 print STDERR <<END or die $!;
3161 Git commit in archive is behind the last version allegedly pushed/uploaded.
3162 Commit referred to by archive: $dsc_hash
3163 Last version pushed with dgit: $lastpush_hash
3166 @mergeinputs = ($lastpush_mergeinput);
3168 # Archive has .dsc which is not a descendant of the last dgit
3169 # push. This can happen if the archive moves .dscs about.
3170 # Just follow its lead.
3171 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3172 progress "archive .dsc names newer git commit";
3173 @mergeinputs = ($dsc_mergeinput);
3175 progress "archive .dsc names other git commit, fixing up";
3176 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3180 @mergeinputs = generate_commits_from_dsc();
3181 # We have just done an import. Now, our import algorithm might
3182 # have been improved. But even so we do not want to generate
3183 # a new different import of the same package. So if the
3184 # version numbers are the same, just use our existing version.
3185 # If the version numbers are different, the archive has changed
3186 # (perhaps, rewound).
3187 if ($lastfetch_mergeinput &&
3188 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3189 (mergeinfo_version $mergeinputs[0]) )) {
3190 @mergeinputs = ($lastfetch_mergeinput);
3192 } elsif ($lastpush_hash) {
3193 # only in git, not in the archive yet
3194 @mergeinputs = ($lastpush_mergeinput);
3195 print STDERR <<END or die $!;
3197 Package not found in the archive, but has allegedly been pushed using dgit.
3201 printdebug "nothing found!\n";
3202 if (defined $skew_warning_vsn) {
3203 print STDERR <<END or die $!;
3205 Warning: relevant archive skew detected.
3206 Archive allegedly contains $skew_warning_vsn
3207 But we were not able to obtain any version from the archive or git.
3211 unshift @end, $del_lrfetchrefs;
3215 if ($lastfetch_hash &&
3217 my $h = $_->{Commit};
3218 $h and is_fast_fwd($lastfetch_hash, $h);
3219 # If true, one of the existing parents of this commit
3220 # is a descendant of the $lastfetch_hash, so we'll
3221 # be ff from that automatically.
3225 push @mergeinputs, $lastfetch_mergeinput;
3228 printdebug "fetch mergeinfos:\n";
3229 foreach my $mi (@mergeinputs) {
3231 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3233 printdebug sprintf " ReverseParents=%d Message=%s",
3234 $mi->{ReverseParents}, $mi->{Message};
3238 my $compat_info= pop @mergeinputs
3239 if $mergeinputs[$#mergeinputs]{Message};
3241 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3244 if (@mergeinputs > 1) {
3246 my $tree_commit = $mergeinputs[0]{Commit};
3248 my $tree = get_tree_of_commit $tree_commit;;
3250 # We use the changelog author of the package in question the
3251 # author of this pseudo-merge. This is (roughly) correct if
3252 # this commit is simply representing aa non-dgit upload.
3253 # (Roughly because it does not record sponsorship - but we
3254 # don't have sponsorship info because that's in the .changes,
3255 # which isn't in the archivw.)
3257 # But, it might be that we are representing archive history
3258 # updates (including in-archive copies). These are not really
3259 # the responsibility of the person who created the .dsc, but
3260 # there is no-one whose name we should better use. (The
3261 # author of the .dsc-named commit is clearly worse.)
3263 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3264 my $author = clogp_authline $useclogp;
3265 my $cversion = getfield $useclogp, 'Version';
3267 my $mcf = dgit_privdir()."/mergecommit";
3268 open MC, ">", $mcf or die "$mcf $!";
3269 print MC <<END or die $!;
3273 my @parents = grep { $_->{Commit} } @mergeinputs;
3274 @parents = reverse @parents if $compat_info->{ReverseParents};
3275 print MC <<END or die $! foreach @parents;
3279 print MC <<END or die $!;
3285 if (defined $compat_info->{Message}) {
3286 print MC $compat_info->{Message} or die $!;
3288 print MC <<END or die $!;
3289 Record $package ($cversion) in archive suite $csuite
3293 my $message_add_info = sub {
3295 my $mversion = mergeinfo_version $mi;
3296 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3300 $message_add_info->($mergeinputs[0]);
3301 print MC <<END or die $!;
3302 should be treated as descended from
3304 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3308 $hash = make_commit $mcf;
3310 $hash = $mergeinputs[0]{Commit};
3312 printdebug "fetch hash=$hash\n";
3315 my ($lasth, $what) = @_;
3316 return unless $lasth;
3317 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3320 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3322 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3324 fetch_from_archive_record_1($hash);
3326 if (defined $skew_warning_vsn) {
3327 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3328 my $gotclogp = commit_getclogp($hash);
3329 my $got_vsn = getfield $gotclogp, 'Version';
3330 printdebug "SKEW CHECK GOT $got_vsn\n";
3331 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3332 print STDERR <<END or die $!;
3334 Warning: archive skew detected. Using the available version:
3335 Archive allegedly contains $skew_warning_vsn
3336 We were able to obtain only $got_vsn
3342 if ($lastfetch_hash ne $hash) {
3343 fetch_from_archive_record_2($hash);
3346 lrfetchref_used lrfetchref();
3348 check_gitattrs($hash, "fetched source tree");
3350 unshift @end, $del_lrfetchrefs;
3354 sub set_local_git_config ($$) {
3356 runcmd @git, qw(config), $k, $v;
3359 sub setup_mergechangelogs (;$) {
3361 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3363 my $driver = 'dpkg-mergechangelogs';
3364 my $cb = "merge.$driver";
3365 confess unless defined $maindir;
3366 my $attrs = "$maindir_gitcommon/info/attributes";
3367 ensuredir "$maindir_gitcommon/info";
3369 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3370 if (!open ATTRS, "<", $attrs) {
3371 $!==ENOENT or die "$attrs: $!";
3375 next if m{^debian/changelog\s};
3376 print NATTRS $_, "\n" or die $!;
3378 ATTRS->error and die $!;
3381 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3384 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3385 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3387 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3390 sub setup_useremail (;$) {
3392 return unless $always || access_cfg_bool(1, 'setup-useremail');
3395 my ($k, $envvar) = @_;
3396 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3397 return unless defined $v;
3398 set_local_git_config "user.$k", $v;
3401 $setup->('email', 'DEBEMAIL');
3402 $setup->('name', 'DEBFULLNAME');
3405 sub ensure_setup_existing_tree () {
3406 my $k = "remote.$remotename.skipdefaultupdate";
3407 my $c = git_get_config $k;
3408 return if defined $c;
3409 set_local_git_config $k, 'true';
3412 sub open_main_gitattrs () {
3413 confess 'internal error no maindir' unless defined $maindir;
3414 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3416 or die "open $maindir_gitcommon/info/attributes: $!";
3420 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3422 sub is_gitattrs_setup () {
3425 # 1: gitattributes set up and should be left alone
3427 # 0: there is a dgit-defuse-attrs but it needs fixing
3428 # undef: there is none
3429 my $gai = open_main_gitattrs();
3430 return 0 unless $gai;
3432 next unless m{$gitattrs_ourmacro_re};
3433 return 1 if m{\s-working-tree-encoding\s};
3434 printdebug "is_gitattrs_setup: found old macro\n";
3437 $gai->error and die $!;
3438 printdebug "is_gitattrs_setup: found nothing\n";
3442 sub setup_gitattrs (;$) {
3444 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3446 my $already = is_gitattrs_setup();
3449 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3450 not doing further gitattributes setup
3454 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3455 my $af = "$maindir_gitcommon/info/attributes";
3456 ensuredir "$maindir_gitcommon/info";
3458 open GAO, "> $af.new" or die $!;
3459 print GAO <<END or die $! unless defined $already;
3462 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3464 my $gai = open_main_gitattrs();
3467 if (m{$gitattrs_ourmacro_re}) {
3468 die unless defined $already;
3472 print GAO $_, "\n" or die $!;
3474 $gai->error and die $!;
3476 close GAO or die $!;
3477 rename "$af.new", "$af" or die "install $af: $!";
3480 sub setup_new_tree () {
3481 setup_mergechangelogs();
3486 sub check_gitattrs ($$) {
3487 my ($treeish, $what) = @_;
3489 return if is_gitattrs_setup;
3492 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3494 my $gafl = new IO::File;
3495 open $gafl, "-|", @cmd or die $!;
3498 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3500 next unless m{(?:^|/)\.gitattributes$};
3502 # oh dear, found one
3504 dgit: warning: $what contains .gitattributes
3505 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3510 # tree contains no .gitattributes files
3511 $?=0; $!=0; close $gafl or failedcmd @cmd;
3515 sub multisuite_suite_child ($$$) {
3516 my ($tsuite, $mergeinputs, $fn) = @_;
3517 # in child, sets things up, calls $fn->(), and returns undef
3518 # in parent, returns canonical suite name for $tsuite
3519 my $canonsuitefh = IO::File::new_tmpfile;
3520 my $pid = fork // die $!;
3524 $us .= " [$isuite]";
3525 $debugprefix .= " ";
3526 progress "fetching $tsuite...";
3527 canonicalise_suite();
3528 print $canonsuitefh $csuite, "\n" or die $!;
3529 close $canonsuitefh or die $!;
3533 waitpid $pid,0 == $pid or die $!;
3534 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3535 seek $canonsuitefh,0,0 or die $!;
3536 local $csuite = <$canonsuitefh>;
3537 die $! unless defined $csuite && chomp $csuite;
3539 printdebug "multisuite $tsuite missing\n";
3542 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3543 push @$mergeinputs, {
3550 sub fork_for_multisuite ($) {
3551 my ($before_fetch_merge) = @_;
3552 # if nothing unusual, just returns ''
3555 # returns 0 to caller in child, to do first of the specified suites
3556 # in child, $csuite is not yet set
3558 # returns 1 to caller in parent, to finish up anything needed after
3559 # in parent, $csuite is set to canonicalised portmanteau
3561 my $org_isuite = $isuite;
3562 my @suites = split /\,/, $isuite;
3563 return '' unless @suites > 1;
3564 printdebug "fork_for_multisuite: @suites\n";
3568 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3570 return 0 unless defined $cbasesuite;
3572 fail "package $package missing in (base suite) $cbasesuite"
3573 unless @mergeinputs;
3575 my @csuites = ($cbasesuite);
3577 $before_fetch_merge->();
3579 foreach my $tsuite (@suites[1..$#suites]) {
3580 $tsuite =~ s/^-/$cbasesuite-/;
3581 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3588 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3589 push @csuites, $csubsuite;
3592 foreach my $mi (@mergeinputs) {
3593 my $ref = git_get_ref $mi->{Ref};
3594 die "$mi->{Ref} ?" unless length $ref;
3595 $mi->{Commit} = $ref;
3598 $csuite = join ",", @csuites;
3600 my $previous = git_get_ref lrref;
3602 unshift @mergeinputs, {
3603 Commit => $previous,
3604 Info => "local combined tracking branch",
3606 "archive seems to have rewound: local tracking branch is ahead!",
3610 foreach my $ix (0..$#mergeinputs) {
3611 $mergeinputs[$ix]{Index} = $ix;
3614 @mergeinputs = sort {
3615 -version_compare(mergeinfo_version $a,
3616 mergeinfo_version $b) # highest version first
3618 $a->{Index} <=> $b->{Index}; # earliest in spec first
3624 foreach my $mi (@mergeinputs) {
3625 printdebug "multisuite merge check $mi->{Info}\n";
3626 foreach my $previous (@needed) {
3627 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3628 printdebug "multisuite merge un-needed $previous->{Info}\n";
3632 printdebug "multisuite merge this-needed\n";
3633 $mi->{Character} = '+';
3636 $needed[0]{Character} = '*';
3638 my $output = $needed[0]{Commit};
3641 printdebug "multisuite merge nontrivial\n";
3642 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3644 my $commit = "tree $tree\n";
3645 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3646 "Input branches:\n";
3648 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3649 printdebug "multisuite merge include $mi->{Info}\n";
3650 $mi->{Character} //= ' ';
3651 $commit .= "parent $mi->{Commit}\n";
3652 $msg .= sprintf " %s %-25s %s\n",
3654 (mergeinfo_version $mi),
3657 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3659 " * marks the highest version branch, which choose to use\n".
3660 " + marks each branch which was not already an ancestor\n\n".
3661 "[dgit multi-suite $csuite]\n";
3663 "author $authline\n".
3664 "committer $authline\n\n";
3665 $output = make_commit_text $commit.$msg;
3666 printdebug "multisuite merge generated $output\n";
3669 fetch_from_archive_record_1($output);
3670 fetch_from_archive_record_2($output);
3672 progress "calculated combined tracking suite $csuite";
3677 sub clone_set_head () {
3678 open H, "> .git/HEAD" or die $!;
3679 print H "ref: ".lref()."\n" or die $!;
3682 sub clone_finish ($) {
3684 runcmd @git, qw(reset --hard), lrref();
3685 runcmd qw(bash -ec), <<'END';
3687 git ls-tree -r --name-only -z HEAD | \
3688 xargs -0r touch -h -r . --
3690 printdone "ready for work in $dstdir";
3694 # in multisuite, returns twice!
3695 # once in parent after first suite fetched,
3696 # and then again in child after everything is finished
3698 badusage "dry run makes no sense with clone" unless act_local();
3700 my $multi_fetched = fork_for_multisuite(sub {
3701 printdebug "multi clone before fetch merge\n";
3705 if ($multi_fetched) {
3706 printdebug "multi clone after fetch merge\n";
3708 clone_finish($dstdir);
3711 printdebug "clone main body\n";
3713 canonicalise_suite();
3714 my $hasgit = check_for_git();
3715 mkdir $dstdir or fail "create \`$dstdir': $!";
3717 runcmd @git, qw(init -q);
3721 my $giturl = access_giturl(1);
3722 if (defined $giturl) {
3723 runcmd @git, qw(remote add), 'origin', $giturl;
3726 progress "fetching existing git history";
3728 runcmd_ordryrun_local @git, qw(fetch origin);
3730 progress "starting new git history";
3732 fetch_from_archive() or no_such_package;
3733 my $vcsgiturl = $dsc->{'Vcs-Git'};
3734 if (length $vcsgiturl) {
3735 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3736 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3738 clone_finish($dstdir);
3742 canonicalise_suite();
3743 if (check_for_git()) {
3746 fetch_from_archive() or no_such_package();
3748 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3749 if (length $vcsgiturl and
3750 (grep { $csuite eq $_ }
3752 cfg 'dgit.vcs-git.suites')) {
3753 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3754 if (defined $current && $current ne $vcsgiturl) {
3756 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3757 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3761 printdone "fetched into ".lrref();
3765 my $multi_fetched = fork_for_multisuite(sub { });
3766 fetch_one() unless $multi_fetched; # parent
3767 finish 0 if $multi_fetched eq '0'; # child
3772 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3774 printdone "fetched to ".lrref()." and merged into HEAD";
3777 sub check_not_dirty () {
3778 foreach my $f (qw(local-options local-patch-header)) {
3779 if (stat_exists "debian/source/$f") {
3780 fail "git tree contains debian/source/$f";
3784 return if $includedirty;
3786 git_check_unmodified();
3789 sub commit_admin ($) {
3792 runcmd_ordryrun_local @git, qw(commit -m), $m;
3795 sub quiltify_nofix_bail ($$) {
3796 my ($headinfo, $xinfo) = @_;
3797 if ($quilt_mode eq 'nofix') {
3798 fail "quilt fixup required but quilt mode is \`nofix'\n".
3799 "HEAD commit".$headinfo." differs from tree implied by ".
3800 " debian/patches".$xinfo;
3804 sub commit_quilty_patch () {
3805 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3807 foreach my $l (split /\n/, $output) {
3808 next unless $l =~ m/\S/;
3809 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3813 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3815 progress "nothing quilty to commit, ok.";
3818 quiltify_nofix_bail "", " (wanted to commit patch update)";
3819 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3820 runcmd_ordryrun_local @git, qw(add -f), @adds;
3822 Commit Debian 3.0 (quilt) metadata
3824 [dgit ($our_version) quilt-fixup]
3828 sub get_source_format () {
3830 if (open F, "debian/source/options") {
3834 s/\s+$//; # ignore missing final newline
3836 my ($k, $v) = ($`, $'); #');
3837 $v =~ s/^"(.*)"$/$1/;
3843 F->error and die $!;
3846 die $! unless $!==&ENOENT;
3849 if (!open F, "debian/source/format") {
3850 die $! unless $!==&ENOENT;
3854 F->error and die $!;
3856 return ($_, \%options);
3859 sub madformat_wantfixup ($) {
3861 return 0 unless $format eq '3.0 (quilt)';
3862 our $quilt_mode_warned;
3863 if ($quilt_mode eq 'nocheck') {
3864 progress "Not doing any fixup of \`$format' due to".
3865 " ----no-quilt-fixup or --quilt=nocheck"
3866 unless $quilt_mode_warned++;
3869 progress "Format \`$format', need to check/update patch stack"
3870 unless $quilt_mode_warned++;
3874 sub maybe_split_brain_save ($$$) {
3875 my ($headref, $dgitview, $msg) = @_;
3876 # => message fragment "$saved" describing disposition of $dgitview
3877 my $save = $internal_object_save{'dgit-view'};
3878 return "commit id $dgitview" unless defined $save;
3879 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3881 "dgit --dgit-view-save $msg HEAD=$headref",
3884 return "and left in $save";
3887 # An "infopair" is a tuple [ $thing, $what ]
3888 # (often $thing is a commit hash; $what is a description)
3890 sub infopair_cond_equal ($$) {
3892 $x->[0] eq $y->[0] or fail <<END;
3893 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3897 sub infopair_lrf_tag_lookup ($$) {
3898 my ($tagnames, $what) = @_;
3899 # $tagname may be an array ref
3900 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3901 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3902 foreach my $tagname (@tagnames) {
3903 my $lrefname = lrfetchrefs."/tags/$tagname";
3904 my $tagobj = $lrfetchrefs_f{$lrefname};
3905 next unless defined $tagobj;
3906 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3907 return [ git_rev_parse($tagobj), $what ];
3909 fail @tagnames==1 ? <<END : <<END;
3910 Wanted tag $what (@tagnames) on dgit server, but not found
3912 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3916 sub infopair_cond_ff ($$) {
3917 my ($anc,$desc) = @_;
3918 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3919 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3923 sub pseudomerge_version_check ($$) {
3924 my ($clogp, $archive_hash) = @_;
3926 my $arch_clogp = commit_getclogp $archive_hash;
3927 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3928 'version currently in archive' ];
3929 if (defined $overwrite_version) {
3930 if (length $overwrite_version) {
3931 infopair_cond_equal([ $overwrite_version,
3932 '--overwrite= version' ],
3935 my $v = $i_arch_v->[0];
3936 progress "Checking package changelog for archive version $v ...";
3939 my @xa = ("-f$v", "-t$v");
3940 my $vclogp = parsechangelog @xa;
3943 [ (getfield $vclogp, $fn),
3944 "$fn field from dpkg-parsechangelog @xa" ];
3946 my $cv = $gf->('Version');
3947 infopair_cond_equal($i_arch_v, $cv);
3948 $cd = $gf->('Distribution');
3951 $@ =~ s/^dgit: //gm;
3953 "Perhaps debian/changelog does not mention $v ?";
3955 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3956 $cd->[1] is $cd->[0]
3957 Your tree seems to based on earlier (not uploaded) $v.
3962 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3966 sub pseudomerge_make_commit ($$$$ $$) {
3967 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3968 $msg_cmd, $msg_msg) = @_;
3969 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3971 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3972 my $authline = clogp_authline $clogp;
3976 !defined $overwrite_version ? ""
3977 : !length $overwrite_version ? " --overwrite"
3978 : " --overwrite=".$overwrite_version;
3980 # Contributing parent is the first parent - that makes
3981 # git rev-list --first-parent DTRT.
3982 my $pmf = dgit_privdir()."/pseudomerge";
3983 open MC, ">", $pmf or die "$pmf $!";
3984 print MC <<END or die $!;
3987 parent $archive_hash
3997 return make_commit($pmf);
4000 sub splitbrain_pseudomerge ($$$$) {
4001 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
4002 # => $merged_dgitview
4003 printdebug "splitbrain_pseudomerge...\n";
4005 # We: debian/PREVIOUS HEAD($maintview)
4006 # expect: o ----------------- o
4009 # a/d/PREVIOUS $dgitview
4012 # we do: `------------------ o
4016 return $dgitview unless defined $archive_hash;
4017 return $dgitview if deliberately_not_fast_forward();
4019 printdebug "splitbrain_pseudomerge...\n";
4021 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4023 if (!defined $overwrite_version) {
4024 progress "Checking that HEAD inciudes all changes in archive...";
4027 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
4029 if (defined $overwrite_version) {
4031 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
4032 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
4033 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
4034 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
4035 my $i_archive = [ $archive_hash, "current archive contents" ];
4037 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4039 infopair_cond_equal($i_dgit, $i_archive);
4040 infopair_cond_ff($i_dep14, $i_dgit);
4041 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4044 $@ =~ s/^\n//; chomp $@;
4047 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4052 my $r = pseudomerge_make_commit
4053 $clogp, $dgitview, $archive_hash, $i_arch_v,
4054 "dgit --quilt=$quilt_mode",
4055 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4056 Declare fast forward from $i_arch_v->[0]
4058 Make fast forward from $i_arch_v->[0]
4061 maybe_split_brain_save $maintview, $r, "pseudomerge";
4063 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4067 sub plain_overwrite_pseudomerge ($$$) {
4068 my ($clogp, $head, $archive_hash) = @_;
4070 printdebug "plain_overwrite_pseudomerge...";
4072 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4074 return $head if is_fast_fwd $archive_hash, $head;
4076 my $m = "Declare fast forward from $i_arch_v->[0]";
4078 my $r = pseudomerge_make_commit
4079 $clogp, $head, $archive_hash, $i_arch_v,
4082 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4084 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4088 sub push_parse_changelog ($) {
4091 my $clogp = Dpkg::Control::Hash->new();
4092 $clogp->load($clogpfn) or die;
4094 my $clogpackage = getfield $clogp, 'Source';
4095 $package //= $clogpackage;
4096 fail "-p specified $package but changelog specified $clogpackage"
4097 unless $package eq $clogpackage;
4098 my $cversion = getfield $clogp, 'Version';
4100 if (!$we_are_initiator) {
4101 # rpush initiator can't do this because it doesn't have $isuite yet
4102 my $tag = debiantag($cversion, access_nomdistro);
4103 runcmd @git, qw(check-ref-format), $tag;
4106 my $dscfn = dscfn($cversion);
4108 return ($clogp, $cversion, $dscfn);
4111 sub push_parse_dsc ($$$) {
4112 my ($dscfn,$dscfnwhat, $cversion) = @_;
4113 $dsc = parsecontrol($dscfn,$dscfnwhat);
4114 my $dversion = getfield $dsc, 'Version';
4115 my $dscpackage = getfield $dsc, 'Source';
4116 ($dscpackage eq $package && $dversion eq $cversion) or
4117 fail "$dscfn is for $dscpackage $dversion".
4118 " but debian/changelog is for $package $cversion";
4121 sub push_tagwants ($$$$) {
4122 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4125 TagFn => \&debiantag,
4130 if (defined $maintviewhead) {
4132 TagFn => \&debiantag_maintview,
4133 Objid => $maintviewhead,
4134 TfSuffix => '-maintview',
4137 } elsif ($dodep14tag eq 'no' ? 0
4138 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4139 : $dodep14tag eq 'always'
4140 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4141 --dep14tag-always (or equivalent in config) means server must support
4142 both "new" and "maint" tag formats, but config says it doesn't.
4144 : die "$dodep14tag ?") {
4146 TagFn => \&debiantag_maintview,
4148 TfSuffix => '-dgit',
4152 foreach my $tw (@tagwants) {
4153 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4154 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4156 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4160 sub push_mktags ($$ $$ $) {
4162 $changesfile,$changesfilewhat,
4165 die unless $tagwants->[0]{View} eq 'dgit';
4167 my $declaredistro = access_nomdistro();
4168 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4169 $dsc->{$ourdscfield[0]} = join " ",
4170 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4172 $dsc->save("$dscfn.tmp") or die $!;
4174 my $changes = parsecontrol($changesfile,$changesfilewhat);
4175 foreach my $field (qw(Source Distribution Version)) {
4176 $changes->{$field} eq $clogp->{$field} or
4177 fail "changes field $field \`$changes->{$field}'".
4178 " does not match changelog \`$clogp->{$field}'";
4181 my $cversion = getfield $clogp, 'Version';
4182 my $clogsuite = getfield $clogp, 'Distribution';
4184 # We make the git tag by hand because (a) that makes it easier
4185 # to control the "tagger" (b) we can do remote signing
4186 my $authline = clogp_authline $clogp;
4187 my $delibs = join(" ", "",@deliberatelies);
4191 my $tfn = $tw->{Tfn};
4192 my $head = $tw->{Objid};
4193 my $tag = $tw->{Tag};
4195 open TO, '>', $tfn->('.tmp') or die $!;
4196 print TO <<END or die $!;
4203 if ($tw->{View} eq 'dgit') {
4204 print TO <<END or die $!;
4205 $package release $cversion for $clogsuite ($csuite) [dgit]
4206 [dgit distro=$declaredistro$delibs]
4208 foreach my $ref (sort keys %previously) {
4209 print TO <<END or die $!;
4210 [dgit previously:$ref=$previously{$ref}]
4213 } elsif ($tw->{View} eq 'maint') {
4214 print TO <<END or die $!;
4215 $package release $cversion for $clogsuite ($csuite)
4216 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4219 die Dumper($tw)."?";
4224 my $tagobjfn = $tfn->('.tmp');
4226 if (!defined $keyid) {
4227 $keyid = access_cfg('keyid','RETURN-UNDEF');
4229 if (!defined $keyid) {
4230 $keyid = getfield $clogp, 'Maintainer';
4232 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4233 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4234 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4235 push @sign_cmd, $tfn->('.tmp');
4236 runcmd_ordryrun @sign_cmd;
4238 $tagobjfn = $tfn->('.signed.tmp');
4239 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4240 $tfn->('.tmp'), $tfn->('.tmp.asc');
4246 my @r = map { $mktag->($_); } @$tagwants;
4250 sub sign_changes ($) {
4251 my ($changesfile) = @_;
4253 my @debsign_cmd = @debsign;
4254 push @debsign_cmd, "-k$keyid" if defined $keyid;
4255 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4256 push @debsign_cmd, $changesfile;
4257 runcmd_ordryrun @debsign_cmd;
4262 printdebug "actually entering push\n";
4264 supplementary_message(<<'END');
4265 Push failed, while checking state of the archive.
4266 You can retry the push, after fixing the problem, if you like.
4268 if (check_for_git()) {
4271 my $archive_hash = fetch_from_archive();
4272 if (!$archive_hash) {
4274 fail "package appears to be new in this suite;".
4275 " if this is intentional, use --new";
4278 supplementary_message(<<'END');
4279 Push failed, while preparing your push.
4280 You can retry the push, after fixing the problem, if you like.
4283 need_tagformat 'new', "quilt mode $quilt_mode"
4284 if quiltmode_splitbrain;
4288 access_giturl(); # check that success is vaguely likely
4289 rpush_handle_protovsn_bothends() if $we_are_initiator;
4292 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4293 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4295 responder_send_file('parsed-changelog', $clogpfn);
4297 my ($clogp, $cversion, $dscfn) =
4298 push_parse_changelog("$clogpfn");
4300 my $dscpath = "$buildproductsdir/$dscfn";
4301 stat_exists $dscpath or
4302 fail "looked for .dsc $dscpath, but $!;".
4303 " maybe you forgot to build";
4305 responder_send_file('dsc', $dscpath);
4307 push_parse_dsc($dscpath, $dscfn, $cversion);
4309 my $format = getfield $dsc, 'Format';
4310 printdebug "format $format\n";
4312 my $symref = git_get_symref();
4313 my $actualhead = git_rev_parse('HEAD');
4315 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4316 if (quiltmode_splitbrain()) {
4317 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $actualhead);
4319 Branch is managed by git-debrebase ($ffq_prev
4320 exists), but quilt mode ($quilt_mode) implies a split view.
4321 Pass the right --quilt option or adjust your git config.
4322 Or, maybe, run git-debrebase forget-was-ever-debrebase.
4325 runcmd_ordryrun_local @git_debrebase, 'stitch';
4326 $actualhead = git_rev_parse('HEAD');
4329 my $dgithead = $actualhead;
4330 my $maintviewhead = undef;
4332 my $upstreamversion = upstreamversion $clogp->{Version};
4334 if (madformat_wantfixup($format)) {
4335 # user might have not used dgit build, so maybe do this now:
4336 if (quiltmode_splitbrain()) {
4337 changedir $playground;
4338 quilt_make_fake_dsc($upstreamversion);
4340 ($dgithead, $cachekey) =
4341 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4343 "--quilt=$quilt_mode but no cached dgit view:
4344 perhaps HEAD changed since dgit build[-source] ?";
4346 $dgithead = splitbrain_pseudomerge($clogp,
4347 $actualhead, $dgithead,
4349 $maintviewhead = $actualhead;
4351 prep_ud(); # so _only_subdir() works, below
4353 commit_quilty_patch();
4357 if (defined $overwrite_version && !defined $maintviewhead
4359 $dgithead = plain_overwrite_pseudomerge($clogp,
4367 if ($archive_hash) {
4368 if (is_fast_fwd($archive_hash, $dgithead)) {
4370 } elsif (deliberately_not_fast_forward) {
4373 fail "dgit push: HEAD is not a descendant".
4374 " of the archive's version.\n".
4375 "To overwrite the archive's contents,".
4376 " pass --overwrite[=VERSION].\n".
4377 "To rewind history, if permitted by the archive,".
4378 " use --deliberately-not-fast-forward.";
4382 changedir $playground;
4383 progress "checking that $dscfn corresponds to HEAD";
4384 runcmd qw(dpkg-source -x --),
4385 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4386 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4387 check_for_vendor_patches() if madformat($dsc->{format});
4389 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4390 debugcmd "+",@diffcmd;
4392 my $r = system @diffcmd;
4395 my $referent = $split_brain ? $dgithead : 'HEAD';
4396 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4399 my $raw = cmdoutput @git,
4400 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4402 foreach (split /\0/, $raw) {
4403 if (defined $changed) {
4404 push @mode_changes, "$changed: $_\n" if $changed;
4407 } elsif (m/^:0+ 0+ /) {
4409 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4410 $changed = "Mode change from $1 to $2"
4415 if (@mode_changes) {
4416 fail <<END.(join '', @mode_changes).<<END;
4417 HEAD specifies a different tree to $dscfn:
4420 There is a problem with your source tree (see dgit(7) for some hints).
4421 To see a full diff, run git diff $tree $referent
4426 HEAD specifies a different tree to $dscfn:
4428 Perhaps you forgot to build. Or perhaps there is a problem with your
4429 source tree (see dgit(7) for some hints). To see a full diff, run
4430 git diff $tree $referent
4436 if (!$changesfile) {
4437 my $pat = changespat $cversion;
4438 my @cs = glob "$buildproductsdir/$pat";
4439 fail "failed to find unique changes file".
4440 " (looked for $pat in $buildproductsdir);".
4441 " perhaps you need to use dgit -C"
4443 ($changesfile) = @cs;
4445 $changesfile = "$buildproductsdir/$changesfile";
4448 # Check that changes and .dsc agree enough
4449 $changesfile =~ m{[^/]*$};
4450 my $changes = parsecontrol($changesfile,$&);
4451 files_compare_inputs($dsc, $changes)
4452 unless forceing [qw(dsc-changes-mismatch)];
4454 # Check whether this is a source only upload
4455 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4456 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4457 if ($sourceonlypolicy eq 'ok') {
4458 } elsif ($sourceonlypolicy eq 'always') {
4459 forceable_fail [qw(uploading-binaries)],
4460 "uploading binaries, although distroy policy is source only"
4462 } elsif ($sourceonlypolicy eq 'never') {
4463 forceable_fail [qw(uploading-source-only)],
4464 "source-only upload, although distroy policy requires .debs"
4466 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4467 forceable_fail [qw(uploading-source-only)],
4468 "source-only upload, even though package is entirely NEW\n".
4469 "(this is contrary to policy in ".(access_nomdistro()).")"
4472 && !(archive_query('package_not_wholly_new', $package) // 1);
4474 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4477 # Perhaps adjust .dsc to contain right set of origs
4478 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4480 unless forceing [qw(changes-origs-exactly)];
4482 # Checks complete, we're going to try and go ahead:
4484 responder_send_file('changes',$changesfile);
4485 responder_send_command("param head $dgithead");
4486 responder_send_command("param csuite $csuite");
4487 responder_send_command("param isuite $isuite");
4488 responder_send_command("param tagformat $tagformat");
4489 if (defined $maintviewhead) {
4490 confess "internal error (protovsn=$protovsn)"
4491 if defined $protovsn and $protovsn < 4;
4492 responder_send_command("param maint-view $maintviewhead");
4495 # Perhaps send buildinfo(s) for signing
4496 my $changes_files = getfield $changes, 'Files';
4497 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4498 foreach my $bi (@buildinfos) {
4499 responder_send_command("param buildinfo-filename $bi");
4500 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4503 if (deliberately_not_fast_forward) {
4504 git_for_each_ref(lrfetchrefs, sub {
4505 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4506 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4507 responder_send_command("previously $rrefname=$objid");
4508 $previously{$rrefname} = $objid;
4512 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4513 dgit_privdir()."/tag");
4516 supplementary_message(<<'END');
4517 Push failed, while signing the tag.
4518 You can retry the push, after fixing the problem, if you like.
4520 # If we manage to sign but fail to record it anywhere, it's fine.
4521 if ($we_are_responder) {
4522 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4523 responder_receive_files('signed-tag', @tagobjfns);
4525 @tagobjfns = push_mktags($clogp,$dscpath,
4526 $changesfile,$changesfile,
4529 supplementary_message(<<'END');
4530 Push failed, *after* signing the tag.
4531 If you want to try again, you should use a new version number.
4534 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4536 foreach my $tw (@tagwants) {
4537 my $tag = $tw->{Tag};
4538 my $tagobjfn = $tw->{TagObjFn};
4540 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4541 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4542 runcmd_ordryrun_local
4543 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4546 supplementary_message(<<'END');
4547 Push failed, while updating the remote git repository - see messages above.
4548 If you want to try again, you should use a new version number.
4550 if (!check_for_git()) {
4551 create_remote_git_repo();
4554 my @pushrefs = $forceflag.$dgithead.":".rrref();
4555 foreach my $tw (@tagwants) {
4556 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4559 runcmd_ordryrun @git,
4560 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4561 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4563 supplementary_message(<<'END');
4564 Push failed, while obtaining signatures on the .changes and .dsc.
4565 If it was just that the signature failed, you may try again by using
4566 debsign by hand to sign the changes file (see the command dgit tried,
4567 above), and then dput that changes file to complete the upload.
4568 If you need to change the package, you must use a new version number.
4570 if ($we_are_responder) {
4571 my $dryrunsuffix = act_local() ? "" : ".tmp";
4572 my @rfiles = ($dscpath, $changesfile);
4573 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4574 responder_receive_files('signed-dsc-changes',
4575 map { "$_$dryrunsuffix" } @rfiles);
4578 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4580 progress "[new .dsc left in $dscpath.tmp]";
4582 sign_changes $changesfile;
4585 supplementary_message(<<END);
4586 Push failed, while uploading package(s) to the archive server.
4587 You can retry the upload of exactly these same files with dput of:
4589 If that .changes file is broken, you will need to use a new version
4590 number for your next attempt at the upload.
4592 my $host = access_cfg('upload-host','RETURN-UNDEF');
4593 my @hostarg = defined($host) ? ($host,) : ();
4594 runcmd_ordryrun @dput, @hostarg, $changesfile;
4595 printdone "pushed and uploaded $cversion";
4597 supplementary_message('');
4598 responder_send_command("complete");
4602 not_necessarily_a_tree();
4607 badusage "-p is not allowed with clone; specify as argument instead"
4608 if defined $package;
4611 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4612 ($package,$isuite) = @ARGV;
4613 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4614 ($package,$dstdir) = @ARGV;
4615 } elsif (@ARGV==3) {
4616 ($package,$isuite,$dstdir) = @ARGV;
4618 badusage "incorrect arguments to dgit clone";
4622 $dstdir ||= "$package";
4623 if (stat_exists $dstdir) {
4624 fail "$dstdir already exists";
4628 if ($rmonerror && !$dryrun_level) {
4629 $cwd_remove= getcwd();
4631 return unless defined $cwd_remove;
4632 if (!chdir "$cwd_remove") {
4633 return if $!==&ENOENT;
4634 die "chdir $cwd_remove: $!";
4636 printdebug "clone rmonerror removing $dstdir\n";
4638 rmtree($dstdir) or die "remove $dstdir: $!\n";
4639 } elsif (grep { $! == $_ }
4640 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4642 print STDERR "check whether to remove $dstdir: $!\n";
4648 $cwd_remove = undef;
4651 sub branchsuite () {
4652 my $branch = git_get_symref();
4653 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4660 sub package_from_d_control () {
4661 if (!defined $package) {
4662 my $sourcep = parsecontrol('debian/control','debian/control');
4663 $package = getfield $sourcep, 'Source';
4667 sub fetchpullargs () {
4668 package_from_d_control();
4670 $isuite = branchsuite();
4672 my $clogp = parsechangelog();
4673 my $clogsuite = getfield $clogp, 'Distribution';
4674 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4676 } elsif (@ARGV==1) {
4679 badusage "incorrect arguments to dgit fetch or dgit pull";
4693 if (quiltmode_splitbrain()) {
4694 my ($format, $fopts) = get_source_format();
4695 madformat($format) and fail <<END
4696 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4704 package_from_d_control();
4705 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4709 foreach my $canon (qw(0 1)) {
4714 canonicalise_suite();
4716 if (length git_get_ref lref()) {
4717 # local branch already exists, yay
4720 if (!length git_get_ref lrref()) {
4728 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4731 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4732 "dgit checkout $isuite";
4733 runcmd (@git, qw(checkout), lbranch());
4736 sub cmd_update_vcs_git () {
4738 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4739 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4741 ($specsuite) = (@ARGV);
4746 if ($ARGV[0] eq '-') {
4748 } elsif ($ARGV[0] eq '-') {
4753 package_from_d_control();
4755 if ($specsuite eq '.') {
4756 $ctrl = parsecontrol 'debian/control', 'debian/control';
4758 $isuite = $specsuite;
4762 my $url = getfield $ctrl, 'Vcs-Git';
4765 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4766 if (!defined $orgurl) {
4767 print STDERR "setting up vcs-git: $url\n";
4768 @cmd = (@git, qw(remote add vcs-git), $url);
4769 } elsif ($orgurl eq $url) {
4770 print STDERR "vcs git already configured: $url\n";
4772 print STDERR "changing vcs-git url to: $url\n";
4773 @cmd = (@git, qw(remote set-url vcs-git), $url);
4775 runcmd_ordryrun_local @cmd;
4777 print "fetching (@ARGV)\n";
4778 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4784 build_or_push_prep_early();
4789 } elsif (@ARGV==1) {
4790 ($specsuite) = (@ARGV);
4792 badusage "incorrect arguments to dgit $subcommand";
4795 local ($package) = $existing_package; # this is a hack
4796 canonicalise_suite();
4798 canonicalise_suite();
4800 if (defined $specsuite &&
4801 $specsuite ne $isuite &&
4802 $specsuite ne $csuite) {
4803 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4804 " but command line specifies $specsuite";
4813 #---------- remote commands' implementation ----------
4815 sub pre_remote_push_build_host {
4816 my ($nrargs) = shift @ARGV;
4817 my (@rargs) = @ARGV[0..$nrargs-1];
4818 @ARGV = @ARGV[$nrargs..$#ARGV];
4820 my ($dir,$vsnwant) = @rargs;
4821 # vsnwant is a comma-separated list; we report which we have
4822 # chosen in our ready response (so other end can tell if they
4825 $we_are_responder = 1;
4826 $us .= " (build host)";
4828 open PI, "<&STDIN" or die $!;
4829 open STDIN, "/dev/null" or die $!;
4830 open PO, ">&STDOUT" or die $!;
4832 open STDOUT, ">&STDERR" or die $!;
4836 ($protovsn) = grep {
4837 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4838 } @rpushprotovsn_support;
4840 fail "build host has dgit rpush protocol versions ".
4841 (join ",", @rpushprotovsn_support).
4842 " but invocation host has $vsnwant"
4843 unless defined $protovsn;
4847 sub cmd_remote_push_build_host {
4848 responder_send_command("dgit-remote-push-ready $protovsn");
4852 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4853 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4854 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4855 # a good error message)
4857 sub rpush_handle_protovsn_bothends () {
4858 if ($protovsn < 4) {
4859 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4868 my $report = i_child_report();
4869 if (defined $report) {
4870 printdebug "($report)\n";
4871 } elsif ($i_child_pid) {
4872 printdebug "(killing build host child $i_child_pid)\n";
4873 kill 15, $i_child_pid;
4875 if (defined $i_tmp && !defined $initiator_tempdir) {
4877 eval { rmtree $i_tmp; };
4882 return unless forkcheck_mainprocess();
4887 my ($base,$selector,@args) = @_;
4888 $selector =~ s/\-/_/g;
4889 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4893 not_necessarily_a_tree();
4898 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4906 push @rargs, join ",", @rpushprotovsn_support;
4909 push @rdgit, @ropts;
4910 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4912 my @cmd = (@ssh, $host, shellquote @rdgit);
4915 $we_are_initiator=1;
4917 if (defined $initiator_tempdir) {
4918 rmtree $initiator_tempdir;
4919 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4920 $i_tmp = $initiator_tempdir;
4924 $i_child_pid = open2(\*RO, \*RI, @cmd);
4926 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4927 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4928 $supplementary_message = '' unless $protovsn >= 3;
4931 my ($icmd,$iargs) = initiator_expect {
4932 m/^(\S+)(?: (.*))?$/;
4935 i_method "i_resp", $icmd, $iargs;
4939 sub i_resp_progress ($) {
4941 my $msg = protocol_read_bytes \*RO, $rhs;
4945 sub i_resp_supplementary_message ($) {
4947 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4950 sub i_resp_complete {
4951 my $pid = $i_child_pid;
4952 $i_child_pid = undef; # prevents killing some other process with same pid
4953 printdebug "waiting for build host child $pid...\n";
4954 my $got = waitpid $pid, 0;
4955 die $! unless $got == $pid;
4956 die "build host child failed $?" if $?;
4959 printdebug "all done\n";
4963 sub i_resp_file ($) {
4965 my $localname = i_method "i_localname", $keyword;
4966 my $localpath = "$i_tmp/$localname";
4967 stat_exists $localpath and
4968 badproto \*RO, "file $keyword ($localpath) twice";
4969 protocol_receive_file \*RO, $localpath;
4970 i_method "i_file", $keyword;
4975 sub i_resp_param ($) {
4976 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4980 sub i_resp_previously ($) {
4981 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4982 or badproto \*RO, "bad previously spec";
4983 my $r = system qw(git check-ref-format), $1;
4984 die "bad previously ref spec ($r)" if $r;
4985 $previously{$1} = $2;
4990 sub i_resp_want ($) {
4992 die "$keyword ?" if $i_wanted{$keyword}++;
4994 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4995 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4996 die unless $isuite =~ m/^$suite_re$/;
4999 rpush_handle_protovsn_bothends();
5001 fail "rpush negotiated protocol version $protovsn".
5002 " which does not support quilt mode $quilt_mode"
5003 if quiltmode_splitbrain;
5005 my @localpaths = i_method "i_want", $keyword;
5006 printdebug "[[ $keyword @localpaths\n";
5007 foreach my $localpath (@localpaths) {
5008 protocol_send_file \*RI, $localpath;
5010 print RI "files-end\n" or die $!;
5013 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
5015 sub i_localname_parsed_changelog {
5016 return "remote-changelog.822";
5018 sub i_file_parsed_changelog {
5019 ($i_clogp, $i_version, $i_dscfn) =
5020 push_parse_changelog "$i_tmp/remote-changelog.822";
5021 die if $i_dscfn =~ m#/|^\W#;
5024 sub i_localname_dsc {
5025 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5030 sub i_localname_buildinfo ($) {
5031 my $bi = $i_param{'buildinfo-filename'};
5032 defined $bi or badproto \*RO, "buildinfo before filename";
5033 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
5034 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
5035 or badproto \*RO, "improper buildinfo filename";
5038 sub i_file_buildinfo {
5039 my $bi = $i_param{'buildinfo-filename'};
5040 my $bd = parsecontrol "$i_tmp/$bi", $bi;
5041 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
5042 if (!forceing [qw(buildinfo-changes-mismatch)]) {
5043 files_compare_inputs($bd, $ch);
5044 (getfield $bd, $_) eq (getfield $ch, $_) or
5045 fail "buildinfo mismatch $_"
5046 foreach qw(Source Version);
5047 !defined $bd->{$_} or
5048 fail "buildinfo contains $_"
5049 foreach qw(Changes Changed-by Distribution);
5051 push @i_buildinfos, $bi;
5052 delete $i_param{'buildinfo-filename'};
5055 sub i_localname_changes {
5056 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5057 $i_changesfn = $i_dscfn;
5058 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5059 return $i_changesfn;
5061 sub i_file_changes { }
5063 sub i_want_signed_tag {
5064 printdebug Dumper(\%i_param, $i_dscfn);
5065 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5066 && defined $i_param{'csuite'}
5067 or badproto \*RO, "premature desire for signed-tag";
5068 my $head = $i_param{'head'};
5069 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5071 my $maintview = $i_param{'maint-view'};
5072 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5075 if ($protovsn >= 4) {
5076 my $p = $i_param{'tagformat'} // '<undef>';
5078 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5081 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5083 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5085 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5088 push_mktags $i_clogp, $i_dscfn,
5089 $i_changesfn, 'remote changes',
5093 sub i_want_signed_dsc_changes {
5094 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5095 sign_changes $i_changesfn;
5096 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5099 #---------- building etc. ----------
5105 #----- `3.0 (quilt)' handling -----
5107 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5109 sub quiltify_dpkg_commit ($$$;$) {
5110 my ($patchname,$author,$msg, $xinfo) = @_;
5113 mkpath '.git/dgit'; # we are in playtree
5114 my $descfn = ".git/dgit/quilt-description.tmp";
5115 open O, '>', $descfn or die "$descfn: $!";
5116 $msg =~ s/\n+/\n\n/;
5117 print O <<END or die $!;
5119 ${xinfo}Subject: $msg
5126 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5127 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5128 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5129 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5133 sub quiltify_trees_differ ($$;$$$) {
5134 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5135 # returns true iff the two tree objects differ other than in debian/
5136 # with $finegrained,
5137 # returns bitmask 01 - differ in upstream files except .gitignore
5138 # 02 - differ in .gitignore
5139 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5140 # is set for each modified .gitignore filename $fn
5141 # if $unrepres is defined, array ref to which is appeneded
5142 # a list of unrepresentable changes (removals of upstream files
5145 my @cmd = (@git, qw(diff-tree -z --no-renames));
5146 push @cmd, qw(--name-only) unless $unrepres;
5147 push @cmd, qw(-r) if $finegrained || $unrepres;
5149 my $diffs= cmdoutput @cmd;
5152 foreach my $f (split /\0/, $diffs) {
5153 if ($unrepres && !@lmodes) {
5154 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5157 my ($oldmode,$newmode) = @lmodes;
5160 next if $f =~ m#^debian(?:/.*)?$#s;
5164 die "not a plain file or symlink\n"
5165 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5166 $oldmode =~ m/^(?:10|12)\d{4}$/;
5167 if ($oldmode =~ m/[^0]/ &&
5168 $newmode =~ m/[^0]/) {
5169 # both old and new files exist
5170 die "mode or type changed\n" if $oldmode ne $newmode;
5171 die "modified symlink\n" unless $newmode =~ m/^10/;
5172 } elsif ($oldmode =~ m/[^0]/) {
5174 die "deletion of symlink\n"
5175 unless $oldmode =~ m/^10/;
5178 die "creation with non-default mode\n"
5179 unless $newmode =~ m/^100644$/ or
5180 $newmode =~ m/^120000$/;
5184 local $/="\n"; chomp $@;
5185 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5189 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5190 $r |= $isignore ? 02 : 01;
5191 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5193 printdebug "quiltify_trees_differ $x $y => $r\n";
5197 sub quiltify_tree_sentinelfiles ($) {
5198 # lists the `sentinel' files present in the tree
5200 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5201 qw(-- debian/rules debian/control);
5206 sub quiltify_splitbrain_needed () {
5207 if (!$split_brain) {
5208 progress "dgit view: changes are required...";
5209 runcmd @git, qw(checkout -q -b dgit-view);
5214 sub quiltify_splitbrain ($$$$$$$) {
5215 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5216 $editedignores, $cachekey) = @_;
5217 my $gitignore_special = 1;
5218 if ($quilt_mode !~ m/gbp|dpm/) {
5219 # treat .gitignore just like any other upstream file
5220 $diffbits = { %$diffbits };
5221 $_ = !!$_ foreach values %$diffbits;
5222 $gitignore_special = 0;
5224 # We would like any commits we generate to be reproducible
5225 my @authline = clogp_authline($clogp);
5226 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5227 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5228 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5229 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5230 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5231 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5233 my $fulldiffhint = sub {
5235 my $cmd = "git diff $x $y -- :/ ':!debian'";
5236 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5237 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5240 if ($quilt_mode =~ m/gbp|unapplied/ &&
5241 ($diffbits->{O2H} & 01)) {
5243 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5244 " but git tree differs from orig in upstream files.";
5245 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5246 if (!stat_exists "debian/patches") {
5248 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5252 if ($quilt_mode =~ m/dpm/ &&
5253 ($diffbits->{H2A} & 01)) {
5254 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5255 --quilt=$quilt_mode specified, implying patches-applied git tree
5256 but git tree differs from result of applying debian/patches to upstream
5259 if ($quilt_mode =~ m/gbp|unapplied/ &&
5260 ($diffbits->{O2A} & 01)) { # some patches
5261 quiltify_splitbrain_needed();
5262 progress "dgit view: creating patches-applied version using gbp pq";
5263 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5264 # gbp pq import creates a fresh branch; push back to dgit-view
5265 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5266 runcmd @git, qw(checkout -q dgit-view);
5268 if ($quilt_mode =~ m/gbp|dpm/ &&
5269 ($diffbits->{O2A} & 02)) {
5271 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5272 tool which does not create patches for changes to upstream
5273 .gitignores: but, such patches exist in debian/patches.
5276 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5277 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5278 quiltify_splitbrain_needed();
5279 progress "dgit view: creating patch to represent .gitignore changes";
5280 ensuredir "debian/patches";
5281 my $gipatch = "debian/patches/auto-gitignore";
5282 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5283 stat GIPATCH or die "$gipatch: $!";
5284 fail "$gipatch already exists; but want to create it".
5285 " to record .gitignore changes" if (stat _)[7];
5286 print GIPATCH <<END or die "$gipatch: $!";
5287 Subject: Update .gitignore from Debian packaging branch
5289 The Debian packaging git branch contains these updates to the upstream
5290 .gitignore file(s). This patch is autogenerated, to provide these
5291 updates to users of the official Debian archive view of the package.
5293 [dgit ($our_version) update-gitignore]
5296 close GIPATCH or die "$gipatch: $!";
5297 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5298 $unapplied, $headref, "--", sort keys %$editedignores;
5299 open SERIES, "+>>", "debian/patches/series" or die $!;
5300 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5302 defined read SERIES, $newline, 1 or die $!;
5303 print SERIES "\n" or die $! unless $newline eq "\n";
5304 print SERIES "auto-gitignore\n" or die $!;
5305 close SERIES or die $!;
5306 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5308 Commit patch to update .gitignore
5310 [dgit ($our_version) update-gitignore-quilt-fixup]
5314 my $dgitview = git_rev_parse 'HEAD';
5317 reflog_cache_insert "refs/$splitbraincache", $cachekey, $dgitview;
5319 changedir "$playground/work";
5321 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5322 progress "dgit view: created ($saved)";
5325 sub quiltify ($$$$) {
5326 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5328 # Quilt patchification algorithm
5330 # We search backwards through the history of the main tree's HEAD
5331 # (T) looking for a start commit S whose tree object is identical
5332 # to to the patch tip tree (ie the tree corresponding to the
5333 # current dpkg-committed patch series). For these purposes
5334 # `identical' disregards anything in debian/ - this wrinkle is
5335 # necessary because dpkg-source treates debian/ specially.
5337 # We can only traverse edges where at most one of the ancestors'
5338 # trees differs (in changes outside in debian/). And we cannot
5339 # handle edges which change .pc/ or debian/patches. To avoid
5340 # going down a rathole we avoid traversing edges which introduce
5341 # debian/rules or debian/control. And we set a limit on the
5342 # number of edges we are willing to look at.
5344 # If we succeed, we walk forwards again. For each traversed edge
5345 # PC (with P parent, C child) (starting with P=S and ending with
5346 # C=T) to we do this:
5348 # - dpkg-source --commit with a patch name and message derived from C
5349 # After traversing PT, we git commit the changes which
5350 # should be contained within debian/patches.
5352 # The search for the path S..T is breadth-first. We maintain a
5353 # todo list containing search nodes. A search node identifies a
5354 # commit, and looks something like this:
5356 # Commit => $git_commit_id,
5357 # Child => $c, # or undef if P=T
5358 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5359 # Nontrivial => true iff $p..$c has relevant changes
5366 my %considered; # saves being exponential on some weird graphs
5368 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5371 my ($search,$whynot) = @_;
5372 printdebug " search NOT $search->{Commit} $whynot\n";
5373 $search->{Whynot} = $whynot;
5374 push @nots, $search;
5375 no warnings qw(exiting);
5384 my $c = shift @todo;
5385 next if $considered{$c->{Commit}}++;
5387 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5389 printdebug "quiltify investigate $c->{Commit}\n";
5392 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5393 printdebug " search finished hooray!\n";
5398 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5399 if ($quilt_mode eq 'smash') {
5400 printdebug " search quitting smash\n";
5404 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5405 $not->($c, "has $c_sentinels not $t_sentinels")
5406 if $c_sentinels ne $t_sentinels;
5408 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5409 $commitdata =~ m/\n\n/;
5411 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5412 @parents = map { { Commit => $_, Child => $c } } @parents;
5414 $not->($c, "root commit") if !@parents;
5416 foreach my $p (@parents) {
5417 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5419 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5420 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5422 foreach my $p (@parents) {
5423 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5425 my @cmd= (@git, qw(diff-tree -r --name-only),
5426 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5427 my $patchstackchange = cmdoutput @cmd;
5428 if (length $patchstackchange) {
5429 $patchstackchange =~ s/\n/,/g;
5430 $not->($p, "changed $patchstackchange");
5433 printdebug " search queue P=$p->{Commit} ",
5434 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5440 printdebug "quiltify want to smash\n";
5443 my $x = $_[0]{Commit};
5444 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5447 my $reportnot = sub {
5449 my $s = $abbrev->($notp);
5450 my $c = $notp->{Child};
5451 $s .= "..".$abbrev->($c) if $c;
5452 $s .= ": ".$notp->{Whynot};
5455 if ($quilt_mode eq 'linear') {
5456 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5457 my $all_gdr = !!@nots;
5458 foreach my $notp (@nots) {
5459 print STDERR "$us: ", $reportnot->($notp), "\n";
5460 $all_gdr &&= $notp->{Child} &&
5461 (git_cat_file $notp->{Child}{Commit}, 'commit')
5462 =~ m{^\[git-debrebase(?! split[: ]).*\]$}m;
5466 [ grep { $_->[0] ne 'quilt-mode' } @$failsuggestion ]
5468 print STDERR "$us: $_->[1]\n" foreach @$failsuggestion;
5470 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n";
5471 } elsif ($quilt_mode eq 'smash') {
5472 } elsif ($quilt_mode eq 'auto') {
5473 progress "quilt fixup cannot be linear, smashing...";
5475 die "$quilt_mode ?";
5478 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5479 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5481 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5483 quiltify_dpkg_commit "auto-$version-$target-$time",
5484 (getfield $clogp, 'Maintainer'),
5485 "Automatically generated patch ($clogp->{Version})\n".
5486 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5490 progress "quiltify linearisation planning successful, executing...";
5492 for (my $p = $sref_S;
5493 my $c = $p->{Child};
5495 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5496 next unless $p->{Nontrivial};
5498 my $cc = $c->{Commit};
5500 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5501 $commitdata =~ m/\n\n/ or die "$c ?";
5504 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5507 my $commitdate = cmdoutput
5508 @git, qw(log -n1 --pretty=format:%aD), $cc;
5510 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5512 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5519 my $gbp_check_suitable = sub {
5524 die "contains unexpected slashes\n" if m{//} || m{/$};
5525 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5526 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5527 die "is series file\n" if m{$series_filename_re}o;
5528 die "too long" if length > 200;
5530 return $_ unless $@;
5531 print STDERR "quiltifying commit $cc:".
5532 " ignoring/dropping Gbp-Pq $what: $@";
5536 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5538 (\S+) \s* \n //ixm) {
5539 $patchname = $gbp_check_suitable->($1, 'Name');
5541 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5543 (\S+) \s* \n //ixm) {
5544 $patchdir = $gbp_check_suitable->($1, 'Topic');
5549 if (!defined $patchname) {
5550 $patchname = $title;
5551 $patchname =~ s/[.:]$//;
5554 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5555 my $translitname = $converter->convert($patchname);
5556 die unless defined $translitname;
5557 $patchname = $translitname;
5560 "dgit: patch title transliteration error: $@"
5562 $patchname =~ y/ A-Z/-a-z/;
5563 $patchname =~ y/-a-z0-9_.+=~//cd;
5564 $patchname =~ s/^\W/x-$&/;
5565 $patchname = substr($patchname,0,40);
5566 $patchname .= ".patch";
5568 if (!defined $patchdir) {
5571 if (length $patchdir) {
5572 $patchname = "$patchdir/$patchname";
5574 if ($patchname =~ m{^(.*)/}) {
5575 mkpath "debian/patches/$1";
5580 stat "debian/patches/$patchname$index";
5582 $!==ENOENT or die "$patchname$index $!";
5584 runcmd @git, qw(checkout -q), $cc;
5586 # We use the tip's changelog so that dpkg-source doesn't
5587 # produce complaining messages from dpkg-parsechangelog. None
5588 # of the information dpkg-source gets from the changelog is
5589 # actually relevant - it gets put into the original message
5590 # which dpkg-source provides our stunt editor, and then
5592 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5594 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5595 "Date: $commitdate\n".
5596 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5598 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5601 runcmd @git, qw(checkout -q master);
5604 sub build_maybe_quilt_fixup () {
5605 my ($format,$fopts) = get_source_format;
5606 return unless madformat_wantfixup $format;
5609 check_for_vendor_patches();
5611 if (quiltmode_splitbrain) {
5612 fail <<END unless access_cfg_tagformats_can_splitbrain;
5613 quilt mode $quilt_mode requires split view so server needs to support
5614 both "new" and "maint" tag formats, but config says it doesn't.
5618 my $clogp = parsechangelog();
5619 my $headref = git_rev_parse('HEAD');
5620 my $symref = git_get_symref();
5622 if ($quilt_mode eq 'linear'
5623 && !$fopts->{'single-debian-patch'}
5624 && branch_is_gdr($headref)) {
5625 # This is much faster. It also makes patches that gdr
5626 # likes better for future updates without laundering.
5628 # However, it can fail in some casses where we would
5629 # succeed: if there are existing patches, which correspond
5630 # to a prefix of the branch, but are not in gbp/gdr
5631 # format, gdr will fail (exiting status 7), but we might
5632 # be able to figure out where to start linearising. That
5633 # will be slower so hopefully there's not much to do.
5634 my @cmd = (@git_debrebase,
5635 qw(--noop-ok -funclean-mixed -funclean-ordering
5636 make-patches --quiet-would-amend));
5637 # We tolerate soe snags that gdr wouldn't, by default.
5641 failedcmd @cmd if system @cmd and $?!=7*256;
5645 $headref = git_rev_parse('HEAD');
5649 changedir $playground;
5651 my $upstreamversion = upstreamversion $version;
5653 if ($fopts->{'single-debian-patch'}) {
5654 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5656 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5660 runcmd_ordryrun_local
5661 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5664 sub unpack_playtree_mkwork ($) {
5667 mkdir "work" or die $!;
5669 mktree_in_ud_here();
5670 runcmd @git, qw(reset -q --hard), $headref;
5673 sub unpack_playtree_linkorigs ($$) {
5674 my ($upstreamversion, $fn) = @_;
5675 # calls $fn->($leafname);
5677 my $bpd_abs = bpd_abs();
5678 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5679 while ($!=0, defined(my $b = readdir QFD)) {
5680 my $f = bpd_abs()."/".$b;
5682 local ($debuglevel) = $debuglevel-1;
5683 printdebug "QF linkorigs $b, $f ?\n";
5685 next unless is_orig_file_of_vsn $b, $upstreamversion;
5686 printdebug "QF linkorigs $b, $f Y\n";
5687 link_ltarget $f, $b or die "$b $!";
5690 die "$buildproductsdir: $!" if $!;
5694 sub quilt_fixup_delete_pc () {
5695 runcmd @git, qw(rm -rqf .pc);
5697 Commit removal of .pc (quilt series tracking data)
5699 [dgit ($our_version) upgrade quilt-remove-pc]
5703 sub quilt_fixup_singlepatch ($$$) {
5704 my ($clogp, $headref, $upstreamversion) = @_;
5706 progress "starting quiltify (single-debian-patch)";
5708 # dpkg-source --commit generates new patches even if
5709 # single-debian-patch is in debian/source/options. In order to
5710 # get it to generate debian/patches/debian-changes, it is
5711 # necessary to build the source package.
5713 unpack_playtree_linkorigs($upstreamversion, sub { });
5714 unpack_playtree_mkwork($headref);
5716 rmtree("debian/patches");
5718 runcmd @dpkgsource, qw(-b .);
5720 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5721 rename srcfn("$upstreamversion", "/debian/patches"),
5722 "work/debian/patches";
5725 commit_quilty_patch();
5728 sub quilt_make_fake_dsc ($) {
5729 my ($upstreamversion) = @_;
5731 my $fakeversion="$upstreamversion-~~DGITFAKE";
5733 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5734 print $fakedsc <<END or die $!;
5737 Version: $fakeversion
5741 my $dscaddfile=sub {
5744 my $md = new Digest::MD5;
5746 my $fh = new IO::File $b, '<' or die "$b $!";
5751 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5754 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5756 my @files=qw(debian/source/format debian/rules
5757 debian/control debian/changelog);
5758 foreach my $maybe (qw(debian/patches debian/source/options
5759 debian/tests/control)) {
5760 next unless stat_exists "$maindir/$maybe";
5761 push @files, $maybe;
5764 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5765 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5767 $dscaddfile->($debtar);
5768 close $fakedsc or die $!;
5771 sub quilt_fakedsc2unapplied ($$) {
5772 my ($headref, $upstreamversion) = @_;
5773 # must be run in the playground
5774 # quilt_make_fake_dsc must have been called
5777 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5779 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5780 rename $fakexdir, "fake" or die "$fakexdir $!";
5784 remove_stray_gits("source package");
5785 mktree_in_ud_here();
5789 rmtree 'debian'; # git checkout commitish paths does not delete!
5790 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5791 my $unapplied=git_add_write_tree();
5792 printdebug "fake orig tree object $unapplied\n";
5796 sub quilt_check_splitbrain_cache ($$) {
5797 my ($headref, $upstreamversion) = @_;
5798 # Called only if we are in (potentially) split brain mode.
5799 # Called in playground.
5800 # Computes the cache key and looks in the cache.
5801 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5803 my $splitbrain_cachekey;
5806 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5807 # we look in the reflog of dgit-intern/quilt-cache
5808 # we look for an entry whose message is the key for the cache lookup
5809 my @cachekey = (qw(dgit), $our_version);
5810 push @cachekey, $upstreamversion;
5811 push @cachekey, $quilt_mode;
5812 push @cachekey, $headref;
5814 push @cachekey, hashfile('fake.dsc');
5816 my $srcshash = Digest::SHA->new(256);
5817 my %sfs = ( %INC, '$0(dgit)' => $0 );
5818 foreach my $sfk (sort keys %sfs) {
5819 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5820 $srcshash->add($sfk," ");
5821 $srcshash->add(hashfile($sfs{$sfk}));
5822 $srcshash->add("\n");
5824 push @cachekey, $srcshash->hexdigest();
5825 $splitbrain_cachekey = "@cachekey";
5827 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5829 my $cachehit = reflog_cache_lookup
5830 "refs/$splitbraincache", $splitbrain_cachekey;
5833 unpack_playtree_mkwork($headref);
5834 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5835 if ($cachehit ne $headref) {
5836 progress "dgit view: found cached ($saved)";
5837 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5839 return ($cachehit, $splitbrain_cachekey);
5841 progress "dgit view: found cached, no changes required";
5842 return ($headref, $splitbrain_cachekey);
5845 printdebug "splitbrain cache miss\n";
5846 return (undef, $splitbrain_cachekey);
5849 sub quilt_fixup_multipatch ($$$) {
5850 my ($clogp, $headref, $upstreamversion) = @_;
5852 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5855 # - honour any existing .pc in case it has any strangeness
5856 # - determine the git commit corresponding to the tip of
5857 # the patch stack (if there is one)
5858 # - if there is such a git commit, convert each subsequent
5859 # git commit into a quilt patch with dpkg-source --commit
5860 # - otherwise convert all the differences in the tree into
5861 # a single git commit
5865 # Our git tree doesn't necessarily contain .pc. (Some versions of
5866 # dgit would include the .pc in the git tree.) If there isn't
5867 # one, we need to generate one by unpacking the patches that we
5870 # We first look for a .pc in the git tree. If there is one, we
5871 # will use it. (This is not the normal case.)
5873 # Otherwise need to regenerate .pc so that dpkg-source --commit
5874 # can work. We do this as follows:
5875 # 1. Collect all relevant .orig from parent directory
5876 # 2. Generate a debian.tar.gz out of
5877 # debian/{patches,rules,source/format,source/options}
5878 # 3. Generate a fake .dsc containing just these fields:
5879 # Format Source Version Files
5880 # 4. Extract the fake .dsc
5881 # Now the fake .dsc has a .pc directory.
5882 # (In fact we do this in every case, because in future we will
5883 # want to search for a good base commit for generating patches.)
5885 # Then we can actually do the dpkg-source --commit
5886 # 1. Make a new working tree with the same object
5887 # store as our main tree and check out the main
5889 # 2. Copy .pc from the fake's extraction, if necessary
5890 # 3. Run dpkg-source --commit
5891 # 4. If the result has changes to debian/, then
5892 # - git add them them
5893 # - git add .pc if we had a .pc in-tree
5895 # 5. If we had a .pc in-tree, delete it, and git commit
5896 # 6. Back in the main tree, fast forward to the new HEAD
5898 # Another situation we may have to cope with is gbp-style
5899 # patches-unapplied trees.
5901 # We would want to detect these, so we know to escape into
5902 # quilt_fixup_gbp. However, this is in general not possible.
5903 # Consider a package with a one patch which the dgit user reverts
5904 # (with git revert or the moral equivalent).
5906 # That is indistinguishable in contents from a patches-unapplied
5907 # tree. And looking at the history to distinguish them is not
5908 # useful because the user might have made a confusing-looking git
5909 # history structure (which ought to produce an error if dgit can't
5910 # cope, not a silent reintroduction of an unwanted patch).
5912 # So gbp users will have to pass an option. But we can usually
5913 # detect their failure to do so: if the tree is not a clean
5914 # patches-applied tree, quilt linearisation fails, but the tree
5915 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5916 # they want --quilt=unapplied.
5918 # To help detect this, when we are extracting the fake dsc, we
5919 # first extract it with --skip-patches, and then apply the patches
5920 # afterwards with dpkg-source --before-build. That lets us save a
5921 # tree object corresponding to .origs.
5923 my $splitbrain_cachekey;
5925 quilt_make_fake_dsc($upstreamversion);
5927 if (quiltmode_splitbrain()) {
5929 ($cachehit, $splitbrain_cachekey) =
5930 quilt_check_splitbrain_cache($headref, $upstreamversion);
5931 return if $cachehit;
5933 my $unapplied=quilt_fakedsc2unapplied($headref, $upstreamversion);
5937 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5939 if (system @bbcmd) {
5940 failedcmd @bbcmd if $? < 0;
5942 failed to apply your git tree's patch stack (from debian/patches/) to
5943 the corresponding upstream tarball(s). Your source tree and .orig
5944 are probably too inconsistent. dgit can only fix up certain kinds of
5945 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5951 unpack_playtree_mkwork($headref);
5954 if (stat_exists ".pc") {
5956 progress "Tree already contains .pc - will use it then delete it.";
5959 rename '../fake/.pc','.pc' or die $!;
5962 changedir '../fake';
5964 my $oldtiptree=git_add_write_tree();
5965 printdebug "fake o+d/p tree object $unapplied\n";
5966 changedir '../work';
5969 # We calculate some guesswork now about what kind of tree this might
5970 # be. This is mostly for error reporting.
5976 # O = orig, without patches applied
5977 # A = "applied", ie orig with H's debian/patches applied
5978 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5979 \%editedignores, \@unrepres),
5980 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5981 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5985 foreach my $b (qw(01 02)) {
5986 foreach my $v (qw(O2H O2A H2A)) {
5987 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5990 printdebug "differences \@dl @dl.\n";
5993 "$us: base trees orig=%.20s o+d/p=%.20s",
5994 $unapplied, $oldtiptree;
5996 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5997 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5998 $dl[0], $dl[1], $dl[3], $dl[4],
6002 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
6004 forceable_fail [qw(unrepresentable)], <<END;
6005 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
6010 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
6011 push @failsuggestion, [ 'unapplied',
6012 "This might be a patches-unapplied branch." ];
6013 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
6014 push @failsuggestion, [ 'applied',
6015 "This might be a patches-applied branch." ];
6017 push @failsuggestion, [ 'quilt-mode',
6018 "Maybe you need one of --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?" ];
6020 push @failsuggestion, [ 'gitattrs',
6021 "Warning: Tree has .gitattributes. See GITATTRIBUTES in dgit(7)." ]
6022 if stat_exists '.gitattributes';
6024 push @failsuggestion, [ 'origs',
6025 "Maybe orig tarball(s) are not identical to git representation?" ];
6027 if (quiltmode_splitbrain()) {
6028 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
6029 $diffbits, \%editedignores,
6030 $splitbrain_cachekey);
6034 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6035 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6037 if (!open P, '>>', ".pc/applied-patches") {
6038 $!==&ENOENT or die $!;
6043 commit_quilty_patch();
6045 if ($mustdeletepc) {
6046 quilt_fixup_delete_pc();
6050 sub quilt_fixup_editor () {
6051 my $descfn = $ENV{$fakeeditorenv};
6052 my $editing = $ARGV[$#ARGV];
6053 open I1, '<', $descfn or die "$descfn: $!";
6054 open I2, '<', $editing or die "$editing: $!";
6055 unlink $editing or die "$editing: $!";
6056 open O, '>', $editing or die "$editing: $!";
6057 while (<I1>) { print O or die $!; } I1->error and die $!;
6060 $copying ||= m/^\-\-\- /;
6061 next unless $copying;
6064 I2->error and die $!;
6069 sub maybe_apply_patches_dirtily () {
6070 return unless $quilt_mode =~ m/gbp|unapplied/;
6071 print STDERR <<END or die $!;
6073 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6074 dgit: Have to apply the patches - making the tree dirty.
6075 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6078 $patches_applied_dirtily = 01;
6079 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6080 runcmd qw(dpkg-source --before-build .);
6083 sub maybe_unapply_patches_again () {
6084 progress "dgit: Unapplying patches again to tidy up the tree."
6085 if $patches_applied_dirtily;
6086 runcmd qw(dpkg-source --after-build .)
6087 if $patches_applied_dirtily & 01;
6089 if $patches_applied_dirtily & 02;
6090 $patches_applied_dirtily = 0;
6093 #----- other building -----
6095 our $clean_using_builder;
6096 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6097 # clean the tree before building (perhaps invoked indirectly by
6098 # whatever we are using to run the build), rather than separately
6099 # and explicitly by us.
6102 return if $clean_using_builder;
6103 if ($cleanmode eq 'dpkg-source') {
6104 maybe_apply_patches_dirtily();
6105 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6106 } elsif ($cleanmode eq 'dpkg-source-d') {
6107 maybe_apply_patches_dirtily();
6108 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6109 } elsif ($cleanmode eq 'git') {
6110 runcmd_ordryrun_local @git, qw(clean -xdf);
6111 } elsif ($cleanmode eq 'git-ff') {
6112 runcmd_ordryrun_local @git, qw(clean -xdff);
6113 } elsif ($cleanmode eq 'check') {
6114 my $leftovers = cmdoutput @git, qw(clean -xdn);
6115 if (length $leftovers) {
6116 print STDERR $leftovers, "\n" or die $!;
6117 fail "tree contains uncommitted files and --clean=check specified";
6119 } elsif ($cleanmode eq 'none') {
6126 badusage "clean takes no additional arguments" if @ARGV;
6129 maybe_unapply_patches_again();
6132 # return values from massage_dbp_args are one or both of these flags
6133 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6134 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6136 sub build_or_push_prep_early () {
6137 our $build_or_push_prep_early_done //= 0;
6138 return if $build_or_push_prep_early_done++;
6139 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6140 my $clogp = parsechangelog();
6141 $isuite = getfield $clogp, 'Distribution';
6142 $package = getfield $clogp, 'Source';
6143 $version = getfield $clogp, 'Version';
6144 $dscfn = dscfn($version);
6147 sub build_prep_early () {
6148 build_or_push_prep_early();
6153 sub build_prep ($) {
6156 # clean the tree if we're trying to include dirty changes in the
6157 # source package, or we are running the builder in $maindir
6158 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6159 build_maybe_quilt_fixup();
6161 my $pat = changespat $version;
6162 foreach my $f (glob "$buildproductsdir/$pat") {
6164 unlink $f or fail "remove old changes file $f: $!";
6166 progress "would remove $f";
6172 sub changesopts_initial () {
6173 my @opts =@changesopts[1..$#changesopts];
6176 sub changesopts_version () {
6177 if (!defined $changes_since_version) {
6180 @vsns = archive_query('archive_query');
6181 my @quirk = access_quirk();
6182 if ($quirk[0] eq 'backports') {
6183 local $isuite = $quirk[2];
6185 canonicalise_suite();
6186 push @vsns, archive_query('archive_query');
6192 "archive query failed (queried because --since-version not specified)";
6195 @vsns = map { $_->[0] } @vsns;
6196 @vsns = sort { -version_compare($a, $b) } @vsns;
6197 $changes_since_version = $vsns[0];
6198 progress "changelog will contain changes since $vsns[0]";
6200 $changes_since_version = '_';
6201 progress "package seems new, not specifying -v<version>";
6204 if ($changes_since_version ne '_') {
6205 return ("-v$changes_since_version");
6211 sub changesopts () {
6212 return (changesopts_initial(), changesopts_version());
6215 sub massage_dbp_args ($;$) {
6216 my ($cmd,$xargs) = @_;
6217 # Since we split the source build out so we can do strange things
6218 # to it, massage the arguments to dpkg-buildpackage so that the
6219 # main build doessn't build source (or add an argument to stop it
6220 # building source by default).
6221 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6222 # -nc has the side effect of specifying -b if nothing else specified
6223 # and some combinations of -S, -b, et al, are errors, rather than
6224 # later simply overriding earlie. So we need to:
6225 # - search the command line for these options
6226 # - pick the last one
6227 # - perhaps add our own as a default
6228 # - perhaps adjust it to the corresponding non-source-building version
6230 foreach my $l ($cmd, $xargs) {
6232 @$l = grep { !(m/^-[SgGFABb]$|^--build=/s and $dmode=$_) } @$l;
6235 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6236 my $r = WANTSRC_BUILDER;
6237 printdebug "massage split $dmode.\n";
6238 if ($dmode =~ s/^--build=//) {
6240 my @d = split /,/, $dmode;
6241 $r |= WANTSRC_SOURCE if grep { s/^full$/binary/ } @d;
6242 $r |= WANTSRC_SOURCE if grep { s/^source$// } @d;
6243 $r |= WANTSRC_BUILDER if grep { m/./ } @d;
6244 fail "Wanted to build nothing!" unless $r;
6245 $dmode = '--build='. join ',', grep m/./, @d;
6248 $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6249 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6250 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6253 printdebug "massage done $r $dmode.\n";
6255 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6261 my $wasdir = must_getcwd();
6262 changedir $buildproductsdir;
6267 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6268 sub postbuild_mergechanges ($) {
6269 my ($msg_if_onlyone) = @_;
6270 # If there is only one .changes file, fail with $msg_if_onlyone,
6271 # or if that is undef, be a no-op.
6272 # Returns the changes file to report to the user.
6273 my $pat = changespat $version;
6274 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6275 @changesfiles = sort {
6276 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6280 if (@changesfiles==1) {
6281 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6282 only one changes file from build (@changesfiles)
6284 $result = $changesfiles[0];
6285 } elsif (@changesfiles==2) {
6286 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6287 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6288 fail "$l found in binaries changes file $binchanges"
6291 runcmd_ordryrun_local @mergechanges, @changesfiles;
6292 my $multichanges = changespat $version,'multi';
6294 stat_exists $multichanges or fail "$multichanges: $!";
6295 foreach my $cf (glob $pat) {
6296 next if $cf eq $multichanges;
6297 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6300 $result = $multichanges;
6302 fail "wrong number of different changes files (@changesfiles)";
6304 printdone "build successful, results in $result\n" or die $!;
6307 sub midbuild_checkchanges () {
6308 my $pat = changespat $version;
6309 return if $rmchanges;
6310 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6312 $_ ne changespat $version,'source' and
6313 $_ ne changespat $version,'multi'
6316 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6317 Suggest you delete @unwanted.
6322 sub midbuild_checkchanges_vanilla ($) {
6324 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6327 sub postbuild_mergechanges_vanilla ($) {
6329 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6331 postbuild_mergechanges(undef);
6334 printdone "build successful\n";
6340 $buildproductsdir eq '..' or print STDERR <<END;
6341 $us: warning: build-products-dir set, but not supported by dpkg-buildpackage
6342 $us: warning: build-products-dir will be ignored; files will go to ..
6344 $buildproductsdir = '..';
6345 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6346 my $wantsrc = massage_dbp_args \@dbp;
6347 build_prep($wantsrc);
6348 if ($wantsrc & WANTSRC_SOURCE) {
6350 midbuild_checkchanges_vanilla $wantsrc;
6352 if ($wantsrc & WANTSRC_BUILDER) {
6353 push @dbp, changesopts_version();
6354 maybe_apply_patches_dirtily();
6355 runcmd_ordryrun_local @dbp;
6357 maybe_unapply_patches_again();
6358 postbuild_mergechanges_vanilla $wantsrc;
6362 $quilt_mode //= 'gbp';
6368 # gbp can make .origs out of thin air. In my tests it does this
6369 # even for a 1.0 format package, with no origs present. So I
6370 # guess it keys off just the version number. We don't know
6371 # exactly what .origs ought to exist, but let's assume that we
6372 # should run gbp if: the version has an upstream part and the main
6374 my $upstreamversion = upstreamversion $version;
6375 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6376 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6378 if ($gbp_make_orig) {
6380 $cleanmode = 'none'; # don't do it again
6383 my @dbp = @dpkgbuildpackage;
6385 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6387 if (!length $gbp_build[0]) {
6388 if (length executable_on_path('git-buildpackage')) {
6389 $gbp_build[0] = qw(git-buildpackage);
6391 $gbp_build[0] = 'gbp buildpackage';
6394 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6396 push @cmd, (qw(-us -uc --git-no-sign-tags),
6397 "--git-builder=".(shellquote @dbp));
6399 if ($gbp_make_orig) {
6400 my $priv = dgit_privdir();
6401 my $ok = "$priv/origs-gen-ok";
6402 unlink $ok or $!==&ENOENT or die $!;
6403 my @origs_cmd = @cmd;
6404 push @origs_cmd, qw(--git-cleaner=true);
6405 push @origs_cmd, "--git-prebuild=".
6406 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6407 push @origs_cmd, @ARGV;
6409 debugcmd @origs_cmd;
6411 do { local $!; stat_exists $ok; }
6412 or failedcmd @origs_cmd;
6414 dryrun_report @origs_cmd;
6418 build_prep($wantsrc);
6419 if ($wantsrc & WANTSRC_SOURCE) {
6421 midbuild_checkchanges_vanilla $wantsrc;
6423 if (!$clean_using_builder) {
6424 push @cmd, '--git-cleaner=true';
6427 maybe_unapply_patches_again();
6428 if ($wantsrc & WANTSRC_BUILDER) {
6429 push @cmd, changesopts();
6430 runcmd_ordryrun_local @cmd, @ARGV;
6432 postbuild_mergechanges_vanilla $wantsrc;
6434 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6436 sub building_source_in_playtree {
6437 # If $includedirty, we have to build the source package from the
6438 # working tree, not a playtree, so that uncommitted changes are
6439 # included (copying or hardlinking them into the playtree could
6442 # Note that if we are building a source package in split brain
6443 # mode we do not support including uncommitted changes, because
6444 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6445 # building a source package)) => !$includedirty
6446 return !$includedirty;
6450 $sourcechanges = changespat $version,'source';
6452 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6453 or fail "remove $sourcechanges: $!";
6455 my @cmd = (@dpkgsource, qw(-b --));
6457 if (building_source_in_playtree()) {
6459 my $headref = git_rev_parse('HEAD');
6460 # If we are in split brain, there is already a playtree with
6461 # the thing we should package into a .dsc (thanks to quilt
6462 # fixup). If not, make a playtree
6463 prep_ud() unless $split_brain;
6464 changedir $playground;
6465 unless ($split_brain) {
6466 my $upstreamversion = upstreamversion $version;
6467 unpack_playtree_linkorigs($upstreamversion, sub { });
6468 unpack_playtree_mkwork($headref);
6472 $leafdir = basename $maindir;
6475 runcmd_ordryrun_local @cmd, $leafdir;
6478 runcmd_ordryrun_local qw(sh -ec),
6479 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6480 @dpkggenchanges, qw(-S), changesopts();
6483 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6484 $dsc = parsecontrol($dscfn, "source package");
6488 printdebug " renaming ($why) $l\n";
6489 rename "$l", bpd_abs()."/$l"
6490 or fail "put in place new built file ($l): $!";
6492 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6493 $l =~ m/\S+$/ or next;
6496 $mv->('dsc', $dscfn);
6497 $mv->('changes', $sourcechanges);
6502 sub cmd_build_source {
6503 badusage "build-source takes no additional arguments" if @ARGV;
6504 build_prep(WANTSRC_SOURCE);
6506 maybe_unapply_patches_again();
6507 printdone "source built, results in $dscfn and $sourcechanges";
6510 sub cmd_push_source {
6512 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6513 "sense with push-source!" if $includedirty;
6514 build_maybe_quilt_fixup();
6516 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6517 "source changes file");
6518 unless (test_source_only_changes($changes)) {
6519 fail "user-specified changes file is not source-only";
6522 # Building a source package is very fast, so just do it
6524 die "er, patches are applied dirtily but shouldn't be.."
6525 if $patches_applied_dirtily;
6526 $changesfile = $sourcechanges;
6531 sub binary_builder {
6532 my ($bbuilder, $pbmc_msg, @args) = @_;
6533 build_prep(WANTSRC_SOURCE);
6535 midbuild_checkchanges();
6538 stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
6539 stat_exists $sourcechanges
6540 or fail "$sourcechanges (in build products dir): $!";
6542 runcmd_ordryrun_local @$bbuilder, @args;
6544 maybe_unapply_patches_again();
6546 postbuild_mergechanges($pbmc_msg);
6552 binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
6553 perhaps you need to pass -A ? (sbuild's default is to build only
6554 arch-specific binaries; dgit 1.4 used to override that.)
6559 my ($pbuilder) = @_;
6561 # @ARGV is allowed to contain only things that should be passed to
6562 # pbuilder under debbuildopts; just massage those
6563 my $wantsrc = massage_dbp_args \@ARGV;
6564 fail "you asked for a builder but your debbuildopts didn't ask for".
6565 " any binaries -- is this really what you meant?"
6566 unless $wantsrc & WANTSRC_BUILDER;
6567 fail "we must build a .dsc to pass to the builder but your debbuiltopts".
6568 " forbids the building of a source package; cannot continue"
6569 unless $wantsrc & WANTSRC_SOURCE;
6570 # We do not want to include the verb "build" in @pbuilder because
6571 # the user can customise @pbuilder and they shouldn't be required
6572 # to include "build" in their customised value. However, if the
6573 # user passes any additional args to pbuilder using the dgit
6574 # option --pbuilder:foo, such args need to come after the "build"
6575 # verb. opts_opt_multi_cmd does all of that.
6576 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6577 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6582 pbuilder(\@pbuilder);
6585 sub cmd_cowbuilder {
6586 pbuilder(\@cowbuilder);
6589 sub cmd_quilt_fixup {
6590 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6593 build_maybe_quilt_fixup();
6596 sub cmd_print_unapplied_treeish {
6597 badusage "incorrect arguments to dgit print-unapplied-treeish" if @ARGV;
6598 my $headref = git_rev_parse('HEAD');
6599 my $clogp = commit_getclogp $headref;
6600 $package = getfield $clogp, 'Source';
6601 $version = getfield $clogp, 'Version';
6602 $isuite = getfield $clogp, 'Distribution';
6603 $csuite = $isuite; # we want this to be offline!
6607 changedir $playground;
6608 my $uv = upstreamversion $version;
6609 quilt_make_fake_dsc($uv);
6610 my $u = quilt_fakedsc2unapplied($headref, $uv);
6611 print $u, "\n" or die $!;
6614 sub import_dsc_result {
6615 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6616 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6618 check_gitattrs($newhash, "source tree");
6620 progress "dgit: import-dsc: $what_msg";
6623 sub cmd_import_dsc {
6627 last unless $ARGV[0] =~ m/^-/;
6630 if (m/^--require-valid-signature$/) {
6633 badusage "unknown dgit import-dsc sub-option \`$_'";
6637 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6638 my ($dscfn, $dstbranch) = @ARGV;
6640 badusage "dry run makes no sense with import-dsc" unless act_local();
6642 my $force = $dstbranch =~ s/^\+// ? +1 :
6643 $dstbranch =~ s/^\.\.// ? -1 :
6645 my $info = $force ? " $&" : '';
6646 $info = "$dscfn$info";
6648 my $specbranch = $dstbranch;
6649 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6650 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6652 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6653 my $chead = cmdoutput_errok @symcmd;
6654 defined $chead or $?==256 or failedcmd @symcmd;
6656 fail "$dstbranch is checked out - will not update it"
6657 if defined $chead and $chead eq $dstbranch;
6659 my $oldhash = git_get_ref $dstbranch;
6661 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6662 $dscdata = do { local $/ = undef; <D>; };
6663 D->error and fail "read $dscfn: $!";
6666 # we don't normally need this so import it here
6667 use Dpkg::Source::Package;
6668 my $dp = new Dpkg::Source::Package filename => $dscfn,
6669 require_valid_signature => $needsig;
6671 local $SIG{__WARN__} = sub {
6673 return unless $needsig;
6674 fail "import-dsc signature check failed";
6676 if (!$dp->is_signed()) {
6677 warn "$us: warning: importing unsigned .dsc\n";
6679 my $r = $dp->check_signature();
6680 die "->check_signature => $r" if $needsig && $r;
6686 $package = getfield $dsc, 'Source';
6688 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6689 unless forceing [qw(import-dsc-with-dgit-field)];
6690 parse_dsc_field_def_dsc_distro();
6692 $isuite = 'DGIT-IMPORT-DSC';
6693 $idistro //= $dsc_distro;
6697 if (defined $dsc_hash) {
6698 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6699 resolve_dsc_field_commit undef, undef;
6701 if (defined $dsc_hash) {
6702 my @cmd = (qw(sh -ec),
6703 "echo $dsc_hash | git cat-file --batch-check");
6704 my $objgot = cmdoutput @cmd;
6705 if ($objgot =~ m#^\w+ missing\b#) {
6707 .dsc contains Dgit field referring to object $dsc_hash
6708 Your git tree does not have that object. Try `git fetch' from a
6709 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6712 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6714 progress "Not fast forward, forced update.";
6716 fail "Not fast forward to $dsc_hash";
6719 import_dsc_result $dstbranch, $dsc_hash,
6720 "dgit import-dsc (Dgit): $info",
6721 "updated git ref $dstbranch";
6726 Branch $dstbranch already exists
6727 Specify ..$specbranch for a pseudo-merge, binding in existing history
6728 Specify +$specbranch to overwrite, discarding existing history
6730 if $oldhash && !$force;
6732 my @dfi = dsc_files_info();
6733 foreach my $fi (@dfi) {
6734 my $f = $fi->{Filename};
6735 my $here = "$buildproductsdir/$f";
6738 fail "lstat $here works but stat gives $! !";
6740 fail "stat $here: $!" unless $! == ENOENT;
6742 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6744 } elsif ($dscfn =~ m#^/#) {
6747 fail "cannot import $dscfn which seems to be inside working tree!";
6749 $there =~ s#/+[^/]+$## or
6750 fail "import $dscfn requires ../$f, but it does not exist";
6752 my $test = $there =~ m{^/} ? $there : "../$there";
6753 stat $test or fail "import $dscfn requires $test, but: $!";
6754 symlink $there, $here or fail "symlink $there to $here: $!";
6755 progress "made symlink $here -> $there";
6756 # print STDERR Dumper($fi);
6758 my @mergeinputs = generate_commits_from_dsc();
6759 die unless @mergeinputs == 1;
6761 my $newhash = $mergeinputs[0]{Commit};
6765 progress "Import, forced update - synthetic orphan git history.";
6766 } elsif ($force < 0) {
6767 progress "Import, merging.";
6768 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6769 my $version = getfield $dsc, 'Version';
6770 my $clogp = commit_getclogp $newhash;
6771 my $authline = clogp_authline $clogp;
6772 $newhash = make_commit_text <<END;
6779 Merge $package ($version) import into $dstbranch
6782 die; # caught earlier
6786 import_dsc_result $dstbranch, $newhash,
6787 "dgit import-dsc: $info",
6788 "results are in in git ref $dstbranch";
6791 sub pre_archive_api_query () {
6792 not_necessarily_a_tree();
6794 sub cmd_archive_api_query {
6795 badusage "need only 1 subpath argument" unless @ARGV==1;
6796 my ($subpath) = @ARGV;
6797 local $isuite = 'DGIT-API-QUERY-CMD';
6798 my @cmd = archive_api_query_cmd($subpath);
6801 exec @cmd or fail "exec curl: $!\n";
6804 sub repos_server_url () {
6805 $package = '_dgit-repos-server';
6806 local $access_forpush = 1;
6807 local $isuite = 'DGIT-REPOS-SERVER';
6808 my $url = access_giturl();
6811 sub pre_clone_dgit_repos_server () {
6812 not_necessarily_a_tree();
6814 sub cmd_clone_dgit_repos_server {
6815 badusage "need destination argument" unless @ARGV==1;
6816 my ($destdir) = @ARGV;
6817 my $url = repos_server_url();
6818 my @cmd = (@git, qw(clone), $url, $destdir);
6820 exec @cmd or fail "exec git clone: $!\n";
6823 sub pre_print_dgit_repos_server_source_url () {
6824 not_necessarily_a_tree();
6826 sub cmd_print_dgit_repos_server_source_url {
6827 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6829 my $url = repos_server_url();
6830 print $url, "\n" or die $!;
6833 sub pre_print_dpkg_source_ignores {
6834 not_necessarily_a_tree();
6836 sub cmd_print_dpkg_source_ignores {
6837 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6839 print "@dpkg_source_ignores\n" or die $!;
6842 sub cmd_setup_mergechangelogs {
6843 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6844 local $isuite = 'DGIT-SETUP-TREE';
6845 setup_mergechangelogs(1);
6848 sub cmd_setup_useremail {
6849 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6850 local $isuite = 'DGIT-SETUP-TREE';
6854 sub cmd_setup_gitattributes {
6855 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6856 local $isuite = 'DGIT-SETUP-TREE';
6860 sub cmd_setup_new_tree {
6861 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6862 local $isuite = 'DGIT-SETUP-TREE';
6866 #---------- argument parsing and main program ----------
6869 print "dgit version $our_version\n" or die $!;
6873 our (%valopts_long, %valopts_short);
6874 our (%funcopts_long);
6876 our (@modeopt_cfgs);
6878 sub defvalopt ($$$$) {
6879 my ($long,$short,$val_re,$how) = @_;
6880 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6881 $valopts_long{$long} = $oi;
6882 $valopts_short{$short} = $oi;
6883 # $how subref should:
6884 # do whatever assignemnt or thing it likes with $_[0]
6885 # if the option should not be passed on to remote, @rvalopts=()
6886 # or $how can be a scalar ref, meaning simply assign the value
6889 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6890 defvalopt '--distro', '-d', '.+', \$idistro;
6891 defvalopt '', '-k', '.+', \$keyid;
6892 defvalopt '--existing-package','', '.*', \$existing_package;
6893 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6894 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6895 defvalopt '--package', '-p', $package_re, \$package;
6896 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6898 defvalopt '', '-C', '.+', sub {
6899 ($changesfile) = (@_);
6900 if ($changesfile =~ s#^(.*)/##) {
6901 $buildproductsdir = $1;
6905 defvalopt '--initiator-tempdir','','.*', sub {
6906 ($initiator_tempdir) = (@_);
6907 $initiator_tempdir =~ m#^/# or
6908 badusage "--initiator-tempdir must be used specify an".
6909 " absolute, not relative, directory."
6912 sub defoptmodes ($@) {
6913 my ($varref, $cfgkey, $default, %optmap) = @_;
6915 while (my ($opt,$val) = each %optmap) {
6916 $funcopts_long{$opt} = sub { $$varref = $val; };
6917 $permit{$val} = $val;
6919 push @modeopt_cfgs, {
6922 Default => $default,
6927 defoptmodes \$dodep14tag, qw( dep14tag want
6930 --always-dep14tag always );
6935 if (defined $ENV{'DGIT_SSH'}) {
6936 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6937 } elsif (defined $ENV{'GIT_SSH'}) {
6938 @ssh = ($ENV{'GIT_SSH'});
6946 if (!defined $val) {
6947 badusage "$what needs a value" unless @ARGV;
6949 push @rvalopts, $val;
6951 badusage "bad value \`$val' for $what" unless
6952 $val =~ m/^$oi->{Re}$(?!\n)/s;
6953 my $how = $oi->{How};
6954 if (ref($how) eq 'SCALAR') {
6959 push @ropts, @rvalopts;
6963 last unless $ARGV[0] =~ m/^-/;
6967 if (m/^--dry-run$/) {
6970 } elsif (m/^--damp-run$/) {
6973 } elsif (m/^--no-sign$/) {
6976 } elsif (m/^--help$/) {
6978 } elsif (m/^--version$/) {
6980 } elsif (m/^--new$/) {
6983 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6984 ($om = $opts_opt_map{$1}) &&
6988 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6989 !$opts_opt_cmdonly{$1} &&
6990 ($om = $opts_opt_map{$1})) {
6993 } elsif (m/^--(gbp|dpm)$/s) {
6994 push @ropts, "--quilt=$1";
6996 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6999 } elsif (m/^--no-quilt-fixup$/s) {
7001 $quilt_mode = 'nocheck';
7002 } elsif (m/^--no-rm-on-error$/s) {
7005 } elsif (m/^--no-chase-dsc-distro$/s) {
7007 $chase_dsc_distro = 0;
7008 } elsif (m/^--overwrite$/s) {
7010 $overwrite_version = '';
7011 } elsif (m/^--overwrite=(.+)$/s) {
7013 $overwrite_version = $1;
7014 } elsif (m/^--delayed=(\d+)$/s) {
7017 } elsif (my ($k,$v) =
7018 m/^--save-(dgit-view)=(.+)$/s ||
7019 m/^--(dgit-view)-save=(.+)$/s
7022 $v =~ s#^(?!refs/)#refs/heads/#;
7023 $internal_object_save{$k} = $v;
7024 } elsif (m/^--(no-)?rm-old-changes$/s) {
7027 } elsif (m/^--deliberately-($deliberately_re)$/s) {
7029 push @deliberatelies, $&;
7030 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
7034 } elsif (m/^--force-/) {
7036 "$us: warning: ignoring unknown force option $_\n";
7038 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
7039 # undocumented, for testing
7041 $tagformat_want = [ $1, 'command line', 1 ];
7042 # 1 menas overrides distro configuration
7043 } elsif (m/^--config-lookup-explode=(.+)$/s) {
7044 # undocumented, for testing
7046 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
7047 # ^ it's supposed to be an array ref
7048 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
7049 $val = $2 ? $' : undef; #';
7050 $valopt->($oi->{Long});
7051 } elsif ($funcopts_long{$_}) {
7053 $funcopts_long{$_}();
7055 badusage "unknown long option \`$_'";
7062 } elsif (s/^-L/-/) {
7065 } elsif (s/^-h/-/) {
7067 } elsif (s/^-D/-/) {
7071 } elsif (s/^-N/-/) {
7076 push @changesopts, $_;
7078 } elsif (s/^-wn$//s) {
7080 $cleanmode = 'none';
7081 } elsif (s/^-wg$//s) {
7084 } elsif (s/^-wgf$//s) {
7086 $cleanmode = 'git-ff';
7087 } elsif (s/^-wd$//s) {
7089 $cleanmode = 'dpkg-source';
7090 } elsif (s/^-wdd$//s) {
7092 $cleanmode = 'dpkg-source-d';
7093 } elsif (s/^-wc$//s) {
7095 $cleanmode = 'check';
7096 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7097 push @git, '-c', $&;
7098 $gitcfgs{cmdline}{$1} = [ $2 ];
7099 } elsif (s/^-c([^=]+)$//s) {
7100 push @git, '-c', $&;
7101 $gitcfgs{cmdline}{$1} = [ 'true' ];
7102 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7104 $val = undef unless length $val;
7105 $valopt->($oi->{Short});
7108 badusage "unknown short option \`$_'";
7115 sub check_env_sanity () {
7116 my $blocked = new POSIX::SigSet;
7117 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7120 foreach my $name (qw(PIPE CHLD)) {
7121 my $signame = "SIG$name";
7122 my $signum = eval "POSIX::$signame" // die;
7123 die "$signame is set to something other than SIG_DFL\n"
7124 if defined $SIG{$name} and $SIG{$name} ne 'DEFAULT';
7125 $blocked->ismember($signum) and
7126 die "$signame is blocked\n";
7132 On entry to dgit, $@
7133 This is a bug produced by something in in your execution environment.
7139 sub parseopts_late_defaults () {
7140 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7141 if defined $idistro;
7142 $isuite //= cfg('dgit.default.default-suite');
7144 foreach my $k (keys %opts_opt_map) {
7145 my $om = $opts_opt_map{$k};
7147 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7149 badcfg "cannot set command for $k"
7150 unless length $om->[0];
7154 foreach my $c (access_cfg_cfgs("opts-$k")) {
7156 map { $_ ? @$_ : () }
7157 map { $gitcfgs{$_}{$c} }
7158 reverse @gitcfgsources;
7159 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7160 "\n" if $debuglevel >= 4;
7162 badcfg "cannot configure options for $k"
7163 if $opts_opt_cmdonly{$k};
7164 my $insertpos = $opts_cfg_insertpos{$k};
7165 @$om = ( @$om[0..$insertpos-1],
7167 @$om[$insertpos..$#$om] );
7171 if (!defined $rmchanges) {
7172 local $access_forpush;
7173 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7176 if (!defined $quilt_mode) {
7177 local $access_forpush;
7178 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7179 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7181 $quilt_mode =~ m/^($quilt_modes_re)$/
7182 or badcfg "unknown quilt-mode \`$quilt_mode'";
7186 foreach my $moc (@modeopt_cfgs) {
7187 local $access_forpush;
7188 my $vr = $moc->{Var};
7189 next if defined $$vr;
7190 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7191 my $v = $moc->{Vals}{$$vr};
7192 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7196 fail __ "dgit: --include-dirty is not supported in split view quilt mode"
7197 if $split_brain && $includedirty;
7199 if (!defined $cleanmode) {
7200 local $access_forpush;
7201 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7202 $cleanmode //= 'dpkg-source';
7204 badcfg "unknown clean-mode \`$cleanmode'" unless
7205 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7208 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7209 $buildproductsdir //= '..';
7210 $bpd_glob = $buildproductsdir;
7211 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7214 setlocale(LC_MESSAGES, "");
7217 if ($ENV{$fakeeditorenv}) {
7219 quilt_fixup_editor();
7225 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7226 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7227 if $dryrun_level == 1;
7229 print STDERR $helpmsg or die $!;
7232 $cmd = $subcommand = shift @ARGV;
7235 my $pre_fn = ${*::}{"pre_$cmd"};
7236 $pre_fn->() if $pre_fn;
7238 record_maindir if $invoked_in_git_tree;
7241 my $fn = ${*::}{"cmd_$cmd"};
7242 $fn or badusage "unknown operation $cmd";