3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2018 Ian Jackson
6 # Copyright (C)2017-2018 Sean Whitton
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
22 use Debian::Dgit::ExitStatus;
26 use Debian::Dgit qw(:DEFAULT :playground);
32 use Dpkg::Control::Hash;
34 use File::Temp qw(tempdir);
37 use Dpkg::Compression;
38 use Dpkg::Compression::Process;
43 use List::MoreUtils qw(pairwise);
44 use Text::Glob qw(match_glob);
45 use Fcntl qw(:DEFAULT :flock);
50 our $our_version = 'UNRELEASED'; ###substituted###
51 our $absurdity = undef; ###substituted###
53 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
64 our $dryrun_level = 0;
66 our $buildproductsdir;
69 our $includedirty = 0;
73 our $existing_package = 'dpkg';
75 our $changes_since_version;
77 our $overwrite_version; # undef: not specified; '': check changelog
79 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
81 our $split_brain_save;
82 our $we_are_responder;
83 our $we_are_initiator;
84 our $initiator_tempdir;
85 our $patches_applied_dirtily = 00;
89 our $chase_dsc_distro=1;
91 our %forceopts = map { $_=>0 }
92 qw(unrepresentable unsupported-source-format
93 dsc-changes-mismatch changes-origs-exactly
94 uploading-binaries uploading-source-only
95 import-gitapply-absurd
96 import-gitapply-no-absurd
97 import-dsc-with-dgit-field);
99 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
101 our $suite_re = '[-+.0-9a-z]+';
102 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
103 our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
104 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
105 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
107 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
108 our $splitbraincache = 'dgit-intern/quilt-cache';
109 our $rewritemap = 'dgit-rewrite/map';
111 our @dpkg_source_ignores = qw(-i(?:^|/)\.git(?:/|$) -I.git);
113 our (@git) = qw(git);
114 our (@dget) = qw(dget);
115 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
116 our (@dput) = qw(dput);
117 our (@debsign) = qw(debsign);
118 our (@gpg) = qw(gpg);
119 our (@sbuild) = qw(sbuild);
121 our (@dgit) = qw(dgit);
122 our (@git_debrebase) = qw(git-debrebase);
123 our (@aptget) = qw(apt-get);
124 our (@aptcache) = qw(apt-cache);
125 our (@dpkgbuildpackage) = (qw(dpkg-buildpackage), @dpkg_source_ignores);
126 our (@dpkgsource) = (qw(dpkg-source), @dpkg_source_ignores);
127 our (@dpkggenchanges) = qw(dpkg-genchanges);
128 our (@mergechanges) = qw(mergechanges -f);
129 our (@gbp_build) = ('');
130 our (@gbp_pq) = ('gbp pq');
131 our (@changesopts) = ('');
132 our (@pbuilder) = ("sudo -E pbuilder");
133 our (@cowbuilder) = ("sudo -E cowbuilder");
135 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
138 'debsign' => \@debsign,
140 'sbuild' => \@sbuild,
144 'git-debrebase' => \@git_debrebase,
145 'apt-get' => \@aptget,
146 'apt-cache' => \@aptcache,
147 'dpkg-source' => \@dpkgsource,
148 'dpkg-buildpackage' => \@dpkgbuildpackage,
149 'dpkg-genchanges' => \@dpkggenchanges,
150 'gbp-build' => \@gbp_build,
151 'gbp-pq' => \@gbp_pq,
152 'ch' => \@changesopts,
153 'mergechanges' => \@mergechanges,
154 'pbuilder' => \@pbuilder,
155 'cowbuilder' => \@cowbuilder);
157 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
158 our %opts_cfg_insertpos = map {
160 scalar @{ $opts_opt_map{$_} }
161 } keys %opts_opt_map;
163 sub parseopts_late_defaults();
164 sub setup_gitattrs(;$);
165 sub check_gitattrs($$);
172 our $supplementary_message = '';
173 our $split_brain = 0;
177 return unless forkcheck_mainprocess();
178 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
181 our $remotename = 'dgit';
182 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
186 if (!defined $absurdity) {
188 $absurdity =~ s{/[^/]+$}{/absurd} or die;
192 my ($v,$distro) = @_;
193 return $tagformatfn->($v, $distro);
196 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
198 sub lbranch () { return "$branchprefix/$csuite"; }
199 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
200 sub lref () { return "refs/heads/".lbranch(); }
201 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
202 sub rrref () { return server_ref($csuite); }
212 return "${package}_".(stripepoch $vsn).$sfx
217 return srcfn($vsn,".dsc");
220 sub changespat ($;$) {
221 my ($vsn, $arch) = @_;
222 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
225 sub upstreamversion ($) {
237 return unless forkcheck_mainprocess();
238 foreach my $f (@end) {
240 print STDERR "$us: cleanup: $@" if length $@;
244 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; finish 12; }
246 sub forceable_fail ($$) {
247 my ($forceoptsl, $msg) = @_;
248 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
249 print STDERR "warning: overriding problem due to --force:\n". $msg;
253 my ($forceoptsl) = @_;
254 my @got = grep { $forceopts{$_} } @$forceoptsl;
255 return 0 unless @got;
257 "warning: skipping checks or functionality due to --force-$got[0]\n";
260 sub no_such_package () {
261 print STDERR "$us: package $package does not exist in suite $isuite\n";
265 sub deliberately ($) {
267 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
270 sub deliberately_not_fast_forward () {
271 foreach (qw(not-fast-forward fresh-repo)) {
272 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
276 sub quiltmode_splitbrain () {
277 $quilt_mode =~ m/gbp|dpm|unapplied/;
280 sub opts_opt_multi_cmd {
283 push @cmd, split /\s+/, shift @_;
290 return opts_opt_multi_cmd [], @gbp_pq;
293 sub dgit_privdir () {
294 our $dgit_privdir_made //= ensure_a_playground 'dgit';
298 my $r = $buildproductsdir;
299 $r = "$maindir/$r" unless $r =~ m{^/};
303 sub branch_gdr_info ($$) {
304 my ($symref, $head) = @_;
305 my ($status, $msg, $current, $ffq_prev, $gdrlast) =
306 gdr_ffq_prev_branchinfo($symref);
307 return () unless $status eq 'branch';
308 $ffq_prev = git_get_ref $ffq_prev;
309 $gdrlast = git_get_ref $gdrlast;
310 $gdrlast &&= is_fast_fwd $gdrlast, $head;
311 return ($ffq_prev, $gdrlast);
314 sub branch_is_gdr ($$) {
315 my ($symref, $head) = @_;
316 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
317 return 0 unless $ffq_prev || $gdrlast;
321 sub branch_is_gdr_unstitched_ff ($$$) {
322 my ($symref, $head, $ancestor) = @_;
323 my ($ffq_prev, $gdrlast) = branch_gdr_info($symref, $head);
324 return 0 unless $ffq_prev;
325 return 0 unless is_fast_fwd $ancestor, $ffq_prev;
329 #---------- remote protocol support, common ----------
331 # remote push initiator/responder protocol:
332 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
333 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
334 # < dgit-remote-push-ready <actual-proto-vsn>
341 # > supplementary-message NBYTES # $protovsn >= 3
346 # > file parsed-changelog
347 # [indicates that output of dpkg-parsechangelog follows]
348 # > data-block NBYTES
349 # > [NBYTES bytes of data (no newline)]
350 # [maybe some more blocks]
359 # > param head DGIT-VIEW-HEAD
360 # > param csuite SUITE
361 # > param tagformat old|new
362 # > param maint-view MAINT-VIEW-HEAD
364 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
365 # > file buildinfo # for buildinfos to sign
367 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
368 # # goes into tag, for replay prevention
371 # [indicates that signed tag is wanted]
372 # < data-block NBYTES
373 # < [NBYTES bytes of data (no newline)]
374 # [maybe some more blocks]
378 # > want signed-dsc-changes
379 # < data-block NBYTES [transfer of signed dsc]
381 # < data-block NBYTES [transfer of signed changes]
383 # < data-block NBYTES [transfer of each signed buildinfo
384 # [etc] same number and order as "file buildinfo"]
392 sub i_child_report () {
393 # Sees if our child has died, and reap it if so. Returns a string
394 # describing how it died if it failed, or undef otherwise.
395 return undef unless $i_child_pid;
396 my $got = waitpid $i_child_pid, WNOHANG;
397 return undef if $got <= 0;
398 die unless $got == $i_child_pid;
399 $i_child_pid = undef;
400 return undef unless $?;
401 return "build host child ".waitstatusmsg();
406 fail "connection lost: $!" if $fh->error;
407 fail "protocol violation; $m not expected";
410 sub badproto_badread ($$) {
412 fail "connection lost: $!" if $!;
413 my $report = i_child_report();
414 fail $report if defined $report;
415 badproto $fh, "eof (reading $wh)";
418 sub protocol_expect (&$) {
419 my ($match, $fh) = @_;
422 defined && chomp or badproto_badread $fh, "protocol message";
430 badproto $fh, "\`$_'";
433 sub protocol_send_file ($$) {
434 my ($fh, $ourfn) = @_;
435 open PF, "<", $ourfn or die "$ourfn: $!";
438 my $got = read PF, $d, 65536;
439 die "$ourfn: $!" unless defined $got;
441 print $fh "data-block ".length($d)."\n" or die $!;
442 print $fh $d or die $!;
444 PF->error and die "$ourfn $!";
445 print $fh "data-end\n" or die $!;
449 sub protocol_read_bytes ($$) {
450 my ($fh, $nbytes) = @_;
451 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
453 my $got = read $fh, $d, $nbytes;
454 $got==$nbytes or badproto_badread $fh, "data block";
458 sub protocol_receive_file ($$) {
459 my ($fh, $ourfn) = @_;
460 printdebug "() $ourfn\n";
461 open PF, ">", $ourfn or die "$ourfn: $!";
463 my ($y,$l) = protocol_expect {
464 m/^data-block (.*)$/ ? (1,$1) :
465 m/^data-end$/ ? (0,) :
469 my $d = protocol_read_bytes $fh, $l;
470 print PF $d or die $!;
475 #---------- remote protocol support, responder ----------
477 sub responder_send_command ($) {
479 return unless $we_are_responder;
480 # called even without $we_are_responder
481 printdebug ">> $command\n";
482 print PO $command, "\n" or die $!;
485 sub responder_send_file ($$) {
486 my ($keyword, $ourfn) = @_;
487 return unless $we_are_responder;
488 printdebug "]] $keyword $ourfn\n";
489 responder_send_command "file $keyword";
490 protocol_send_file \*PO, $ourfn;
493 sub responder_receive_files ($@) {
494 my ($keyword, @ourfns) = @_;
495 die unless $we_are_responder;
496 printdebug "[[ $keyword @ourfns\n";
497 responder_send_command "want $keyword";
498 foreach my $fn (@ourfns) {
499 protocol_receive_file \*PI, $fn;
502 protocol_expect { m/^files-end$/ } \*PI;
505 #---------- remote protocol support, initiator ----------
507 sub initiator_expect (&) {
509 protocol_expect { &$match } \*RO;
512 #---------- end remote code ----------
515 if ($we_are_responder) {
517 responder_send_command "progress ".length($m) or die $!;
518 print PO $m or die $!;
528 $ua = LWP::UserAgent->new();
532 progress "downloading $what...";
533 my $r = $ua->get(@_) or die $!;
534 return undef if $r->code == 404;
535 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
536 return $r->decoded_content(charset => 'none');
539 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
541 sub act_local () { return $dryrun_level <= 1; }
542 sub act_scary () { return !$dryrun_level; }
545 if (!$dryrun_level) {
546 progress "$us ok: @_";
548 progress "would be ok: @_ (but dry run only)";
553 printcmd(\*STDERR,$debugprefix."#",@_);
556 sub runcmd_ordryrun {
564 sub runcmd_ordryrun_local {
572 our $helpmsg = <<END;
574 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
575 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
576 dgit [dgit-opts] build [dpkg-buildpackage-opts]
577 dgit [dgit-opts] sbuild [sbuild-opts]
578 dgit [dgit-opts] pbuilder|cowbuilder [debbuildopts]
579 dgit [dgit-opts] push [dgit-opts] [suite]
580 dgit [dgit-opts] push-source [dgit-opts] [suite]
581 dgit [dgit-opts] rpush build-host:build-dir ...
582 important dgit options:
583 -k<keyid> sign tag and package with <keyid> instead of default
584 --dry-run -n do not change anything, but go through the motions
585 --damp-run -L like --dry-run but make local changes, without signing
586 --new -N allow introducing a new package
587 --debug -D increase debug level
588 -c<name>=<value> set git config option (used directly by dgit too)
591 our $later_warning_msg = <<END;
592 Perhaps the upload is stuck in incoming. Using the version from git.
596 print STDERR "$us: @_\n", $helpmsg or die $!;
601 @ARGV or badusage "too few arguments";
602 return scalar shift @ARGV;
606 not_necessarily_a_tree();
609 print $helpmsg or die $!;
613 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
615 our %defcfg = ('dgit.default.distro' => 'debian',
616 'dgit.default.default-suite' => 'unstable',
617 'dgit.default.old-dsc-distro' => 'debian',
618 'dgit-suite.*-security.distro' => 'debian-security',
619 'dgit.default.username' => '',
620 'dgit.default.archive-query-default-component' => 'main',
621 'dgit.default.ssh' => 'ssh',
622 'dgit.default.archive-query' => 'madison:',
623 'dgit.default.sshpsql-dbname' => 'service=projectb',
624 'dgit.default.aptget-components' => 'main',
625 'dgit.default.dgit-tag-format' => 'new,old,maint',
626 'dgit.default.source-only-uploads' => 'ok',
627 'dgit.dsc-url-proto-ok.http' => 'true',
628 'dgit.dsc-url-proto-ok.https' => 'true',
629 'dgit.dsc-url-proto-ok.git' => 'true',
630 'dgit.vcs-git.suites', => 'sid', # ;-separated
631 'dgit.default.dsc-url-proto-ok' => 'false',
632 # old means "repo server accepts pushes with old dgit tags"
633 # new means "repo server accepts pushes with new dgit tags"
634 # maint means "repo server accepts split brain pushes"
635 # hist means "repo server may have old pushes without new tag"
636 # ("hist" is implied by "old")
637 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
638 'dgit-distro.debian.git-check' => 'url',
639 'dgit-distro.debian.git-check-suffix' => '/info/refs',
640 'dgit-distro.debian.new-private-pushers' => 't',
641 'dgit-distro.debian.source-only-uploads' => 'not-wholly-new',
642 'dgit-distro.debian/push.git-url' => '',
643 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
644 'dgit-distro.debian/push.git-user-force' => 'dgit',
645 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
646 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
647 'dgit-distro.debian/push.git-create' => 'true',
648 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
649 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
650 # 'dgit-distro.debian.archive-query-tls-key',
651 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
652 # ^ this does not work because curl is broken nowadays
653 # Fixing #790093 properly will involve providing providing the key
654 # in some pacagke and maybe updating these paths.
656 # 'dgit-distro.debian.archive-query-tls-curl-args',
657 # '--ca-path=/etc/ssl/ca-debian',
658 # ^ this is a workaround but works (only) on DSA-administered machines
659 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
660 'dgit-distro.debian.git-url-suffix' => '',
661 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
662 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
663 'dgit-distro.debian-security.archive-query' => 'aptget:',
664 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
665 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
666 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
667 'dgit-distro.debian-security.nominal-distro' => 'debian',
668 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
669 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
670 'dgit-distro.ubuntu.git-check' => 'false',
671 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
672 'dgit-distro.test-dummy.ssh' => "$td/ssh",
673 'dgit-distro.test-dummy.username' => "alice",
674 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
675 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
676 'dgit-distro.test-dummy.git-url' => "$td/git",
677 'dgit-distro.test-dummy.git-host' => "git",
678 'dgit-distro.test-dummy.git-path' => "$td/git",
679 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
680 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
681 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
682 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
686 our @gitcfgsources = qw(cmdline local global system);
687 our $invoked_in_git_tree = 1;
689 sub git_slurp_config () {
690 # This algoritm is a bit subtle, but this is needed so that for
691 # options which we want to be single-valued, we allow the
692 # different config sources to override properly. See #835858.
693 foreach my $src (@gitcfgsources) {
694 next if $src eq 'cmdline';
695 # we do this ourselves since git doesn't handle it
697 $gitcfgs{$src} = git_slurp_config_src $src;
701 sub git_get_config ($) {
703 foreach my $src (@gitcfgsources) {
704 my $l = $gitcfgs{$src}{$c};
705 confess "internal error ($l $c)" if $l && !ref $l;
706 printdebug"C $c ".(defined $l ?
707 join " ", map { messagequote "'$_'" } @$l :
711 @$l==1 or badcfg "multiple values for $c".
712 " (in $src git config)" if @$l > 1;
720 return undef if $c =~ /RETURN-UNDEF/;
721 printdebug "C? $c\n" if $debuglevel >= 5;
722 my $v = git_get_config($c);
723 return $v if defined $v;
724 my $dv = $defcfg{$c};
726 printdebug "CD $c $dv\n" if $debuglevel >= 4;
730 badcfg "need value for one of: @_\n".
731 "$us: distro or suite appears not to be (properly) supported";
734 sub not_necessarily_a_tree () {
735 # needs to be called from pre_*
736 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
737 $invoked_in_git_tree = 0;
740 sub access_basedistro__noalias () {
741 if (defined $idistro) {
744 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
745 return $def if defined $def;
746 foreach my $src (@gitcfgsources, 'internal') {
747 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
749 foreach my $k (keys %$kl) {
750 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
752 next unless match_glob $dpat, $isuite;
756 return cfg("dgit.default.distro");
760 sub access_basedistro () {
761 my $noalias = access_basedistro__noalias();
762 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
763 return $canon // $noalias;
766 sub access_nomdistro () {
767 my $base = access_basedistro();
768 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
769 $r =~ m/^$distro_re$/ or badcfg
770 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
774 sub access_quirk () {
775 # returns (quirk name, distro to use instead or undef, quirk-specific info)
776 my $basedistro = access_basedistro();
777 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
779 if (defined $backports_quirk) {
780 my $re = $backports_quirk;
781 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
783 $re =~ s/\%/([-0-9a-z_]+)/
784 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
785 if ($isuite =~ m/^$re$/) {
786 return ('backports',"$basedistro-backports",$1);
789 return ('none',undef);
794 sub parse_cfg_bool ($$$) {
795 my ($what,$def,$v) = @_;
798 $v =~ m/^[ty1]/ ? 1 :
799 $v =~ m/^[fn0]/ ? 0 :
800 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
803 sub access_forpush_config () {
804 my $d = access_basedistro();
808 parse_cfg_bool('new-private-pushers', 0,
809 cfg("dgit-distro.$d.new-private-pushers",
812 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
815 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
816 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
817 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
818 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
821 sub access_forpush () {
822 $access_forpush //= access_forpush_config();
823 return $access_forpush;
827 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
828 badcfg "pushing but distro is configured readonly"
829 if access_forpush_config() eq '0';
831 $supplementary_message = <<'END' unless $we_are_responder;
832 Push failed, before we got started.
833 You can retry the push, after fixing the problem, if you like.
835 parseopts_late_defaults();
839 parseopts_late_defaults();
842 sub supplementary_message ($) {
844 if (!$we_are_responder) {
845 $supplementary_message = $msg;
847 } elsif ($protovsn >= 3) {
848 responder_send_command "supplementary-message ".length($msg)
850 print PO $msg or die $!;
854 sub access_distros () {
855 # Returns list of distros to try, in order
858 # 0. `instead of' distro name(s) we have been pointed to
859 # 1. the access_quirk distro, if any
860 # 2a. the user's specified distro, or failing that } basedistro
861 # 2b. the distro calculated from the suite }
862 my @l = access_basedistro();
864 my (undef,$quirkdistro) = access_quirk();
865 unshift @l, $quirkdistro;
866 unshift @l, $instead_distro;
867 @l = grep { defined } @l;
869 push @l, access_nomdistro();
871 if (access_forpush()) {
872 @l = map { ("$_/push", $_) } @l;
877 sub access_cfg_cfgs (@) {
880 # The nesting of these loops determines the search order. We put
881 # the key loop on the outside so that we search all the distros
882 # for each key, before going on to the next key. That means that
883 # if access_cfg is called with a more specific, and then a less
884 # specific, key, an earlier distro can override the less specific
885 # without necessarily overriding any more specific keys. (If the
886 # distro wants to override the more specific keys it can simply do
887 # so; whereas if we did the loop the other way around, it would be
888 # impossible to for an earlier distro to override a less specific
889 # key but not the more specific ones without restating the unknown
890 # values of the more specific keys.
893 # We have to deal with RETURN-UNDEF specially, so that we don't
894 # terminate the search prematurely.
896 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
899 foreach my $d (access_distros()) {
900 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
902 push @cfgs, map { "dgit.default.$_" } @realkeys;
909 my (@cfgs) = access_cfg_cfgs(@keys);
910 my $value = cfg(@cfgs);
914 sub access_cfg_bool ($$) {
915 my ($def, @keys) = @_;
916 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
919 sub string_to_ssh ($) {
921 if ($spec =~ m/\s/) {
922 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
928 sub access_cfg_ssh () {
929 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
930 if (!defined $gitssh) {
933 return string_to_ssh $gitssh;
937 sub access_runeinfo ($) {
939 return ": dgit ".access_basedistro()." $info ;";
942 sub access_someuserhost ($) {
944 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
945 defined($user) && length($user) or
946 $user = access_cfg("$some-user",'username');
947 my $host = access_cfg("$some-host");
948 return length($user) ? "$user\@$host" : $host;
951 sub access_gituserhost () {
952 return access_someuserhost('git');
955 sub access_giturl (;$) {
957 my $url = access_cfg('git-url','RETURN-UNDEF');
960 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
961 return undef unless defined $proto;
964 access_gituserhost().
965 access_cfg('git-path');
967 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
970 return "$url/$package$suffix";
973 sub commit_getclogp ($) {
974 # Returns the parsed changelog hashref for a particular commit
976 our %commit_getclogp_memo;
977 my $memo = $commit_getclogp_memo{$objid};
978 return $memo if $memo;
980 my $mclog = dgit_privdir()."clog";
981 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
982 "$objid:debian/changelog";
983 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
986 sub parse_dscdata () {
987 my $dscfh = new IO::File \$dscdata, '<' or die $!;
988 printdebug Dumper($dscdata) if $debuglevel>1;
989 $dsc = parsecontrolfh($dscfh,$dscurl,1);
990 printdebug Dumper($dsc) if $debuglevel>1;
995 sub archive_query ($;@) {
996 my ($method) = shift @_;
997 fail "this operation does not support multiple comma-separated suites"
999 my $query = access_cfg('archive-query','RETURN-UNDEF');
1000 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1003 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1006 sub archive_query_prepend_mirror {
1007 my $m = access_cfg('mirror');
1008 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1011 sub pool_dsc_subpath ($$) {
1012 my ($vsn,$component) = @_; # $package is implict arg
1013 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1014 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1017 sub cfg_apply_map ($$$) {
1018 my ($varref, $what, $mapspec) = @_;
1019 return unless $mapspec;
1021 printdebug "config $what EVAL{ $mapspec; }\n";
1023 eval "package Dgit::Config; $mapspec;";
1028 #---------- `ftpmasterapi' archive query method (nascent) ----------
1030 sub archive_api_query_cmd ($) {
1032 my @cmd = (@curl, qw(-sS));
1033 my $url = access_cfg('archive-query-url');
1034 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1036 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1037 foreach my $key (split /\:/, $keys) {
1038 $key =~ s/\%HOST\%/$host/g;
1040 fail "for $url: stat $key: $!" unless $!==ENOENT;
1043 fail "config requested specific TLS key but do not know".
1044 " how to get curl to use exactly that EE key ($key)";
1045 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1046 # # Sadly the above line does not work because of changes
1047 # # to gnutls. The real fix for #790093 may involve
1048 # # new curl options.
1051 # Fixing #790093 properly will involve providing a value
1052 # for this on clients.
1053 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1054 push @cmd, split / /, $kargs if defined $kargs;
1056 push @cmd, $url.$subpath;
1060 sub api_query ($$;$) {
1062 my ($data, $subpath, $ok404) = @_;
1063 badcfg "ftpmasterapi archive query method takes no data part"
1065 my @cmd = archive_api_query_cmd($subpath);
1066 my $url = $cmd[$#cmd];
1067 push @cmd, qw(-w %{http_code});
1068 my $json = cmdoutput @cmd;
1069 unless ($json =~ s/\d+\d+\d$//) {
1070 failedcmd_report_cmd undef, @cmd;
1071 fail "curl failed to print 3-digit HTTP code";
1074 return undef if $code eq '404' && $ok404;
1075 fail "fetch of $url gave HTTP code $code"
1076 unless $url =~ m#^file://# or $code =~ m/^2/;
1077 return decode_json($json);
1080 sub canonicalise_suite_ftpmasterapi {
1081 my ($proto,$data) = @_;
1082 my $suites = api_query($data, 'suites');
1084 foreach my $entry (@$suites) {
1086 my $v = $entry->{$_};
1087 defined $v && $v eq $isuite;
1088 } qw(codename name);
1089 push @matched, $entry;
1091 fail "unknown suite $isuite" unless @matched;
1094 @matched==1 or die "multiple matches for suite $isuite\n";
1095 $cn = "$matched[0]{codename}";
1096 defined $cn or die "suite $isuite info has no codename\n";
1097 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1099 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1104 sub archive_query_ftpmasterapi {
1105 my ($proto,$data) = @_;
1106 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1108 my $digester = Digest::SHA->new(256);
1109 foreach my $entry (@$info) {
1111 my $vsn = "$entry->{version}";
1112 my ($ok,$msg) = version_check $vsn;
1113 die "bad version: $msg\n" unless $ok;
1114 my $component = "$entry->{component}";
1115 $component =~ m/^$component_re$/ or die "bad component";
1116 my $filename = "$entry->{filename}";
1117 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1118 or die "bad filename";
1119 my $sha256sum = "$entry->{sha256sum}";
1120 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1121 push @rows, [ $vsn, "/pool/$component/$filename",
1122 $digester, $sha256sum ];
1124 die "bad ftpmaster api response: $@\n".Dumper($entry)
1127 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1128 return archive_query_prepend_mirror @rows;
1131 sub file_in_archive_ftpmasterapi {
1132 my ($proto,$data,$filename) = @_;
1133 my $pat = $filename;
1136 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1137 my $info = api_query($data, "file_in_archive/$pat", 1);
1140 sub package_not_wholly_new_ftpmasterapi {
1141 my ($proto,$data,$pkg) = @_;
1142 my $info = api_query($data,"madison?package=${pkg}&f=json");
1146 #---------- `aptget' archive query method ----------
1149 our $aptget_releasefile;
1150 our $aptget_configpath;
1152 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1153 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1155 sub aptget_cache_clean {
1156 runcmd_ordryrun_local qw(sh -ec),
1157 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1161 sub aptget_lock_acquire () {
1162 my $lockfile = "$aptget_base/lock";
1163 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1164 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1167 sub aptget_prep ($) {
1169 return if defined $aptget_base;
1171 badcfg "aptget archive query method takes no data part"
1174 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1177 ensuredir "$cache/dgit";
1179 access_cfg('aptget-cachekey','RETURN-UNDEF')
1180 // access_nomdistro();
1182 $aptget_base = "$cache/dgit/aptget";
1183 ensuredir $aptget_base;
1185 my $quoted_base = $aptget_base;
1186 die "$quoted_base contains bad chars, cannot continue"
1187 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1189 ensuredir $aptget_base;
1191 aptget_lock_acquire();
1193 aptget_cache_clean();
1195 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1196 my $sourceslist = "source.list#$cachekey";
1198 my $aptsuites = $isuite;
1199 cfg_apply_map(\$aptsuites, 'suite map',
1200 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1202 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1203 printf SRCS "deb-src %s %s %s\n",
1204 access_cfg('mirror'),
1206 access_cfg('aptget-components')
1209 ensuredir "$aptget_base/cache";
1210 ensuredir "$aptget_base/lists";
1212 open CONF, ">", $aptget_configpath or die $!;
1214 Debug::NoLocking "true";
1215 APT::Get::List-Cleanup "false";
1216 #clear APT::Update::Post-Invoke-Success;
1217 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1218 Dir::State::Lists "$quoted_base/lists";
1219 Dir::Etc::preferences "$quoted_base/preferences";
1220 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1221 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1224 foreach my $key (qw(
1227 Dir::Cache::Archives
1228 Dir::Etc::SourceParts
1229 Dir::Etc::preferencesparts
1231 ensuredir "$aptget_base/$key";
1232 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1235 my $oldatime = (time // die $!) - 1;
1236 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1237 next unless stat_exists $oldlist;
1238 my ($mtime) = (stat _)[9];
1239 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1242 runcmd_ordryrun_local aptget_aptget(), qw(update);
1245 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1246 next unless stat_exists $oldlist;
1247 my ($atime) = (stat _)[8];
1248 next if $atime == $oldatime;
1249 push @releasefiles, $oldlist;
1251 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1252 @releasefiles = @inreleasefiles if @inreleasefiles;
1253 if (!@releasefiles) {
1255 apt seemed to not to update dgit's cached Release files for $isuite.
1257 is on a filesystem mounted `noatime'; if so, please use `relatime'.)
1260 die "apt updated too many Release files (@releasefiles), erk"
1261 unless @releasefiles == 1;
1263 ($aptget_releasefile) = @releasefiles;
1266 sub canonicalise_suite_aptget {
1267 my ($proto,$data) = @_;
1270 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1272 foreach my $name (qw(Codename Suite)) {
1273 my $val = $release->{$name};
1275 printdebug "release file $name: $val\n";
1276 $val =~ m/^$suite_re$/o or fail
1277 "Release file ($aptget_releasefile) specifies intolerable $name";
1278 cfg_apply_map(\$val, 'suite rmap',
1279 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1286 sub archive_query_aptget {
1287 my ($proto,$data) = @_;
1290 ensuredir "$aptget_base/source";
1291 foreach my $old (<$aptget_base/source/*.dsc>) {
1292 unlink $old or die "$old: $!";
1295 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1296 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1297 # avoids apt-get source failing with ambiguous error code
1299 runcmd_ordryrun_local
1300 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1301 aptget_aptget(), qw(--download-only --only-source source), $package;
1303 my @dscs = <$aptget_base/source/*.dsc>;
1304 fail "apt-get source did not produce a .dsc" unless @dscs;
1305 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1307 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1310 my $uri = "file://". uri_escape $dscs[0];
1311 $uri =~ s{\%2f}{/}gi;
1312 return [ (getfield $pre_dsc, 'Version'), $uri ];
1315 sub file_in_archive_aptget () { return undef; }
1316 sub package_not_wholly_new_aptget () { return undef; }
1318 #---------- `dummyapicat' archive query method ----------
1320 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1321 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1323 sub dummycatapi_run_in_mirror ($@) {
1324 # runs $fn with FIA open onto rune
1325 my ($rune, $argl, $fn) = @_;
1327 my $mirror = access_cfg('mirror');
1328 $mirror =~ s#^file://#/# or die "$mirror ?";
1329 my @cmd = (qw(sh -ec), 'cd "$1"; shift'."\n".$rune,
1330 qw(x), $mirror, @$argl);
1331 debugcmd "-|", @cmd;
1332 open FIA, "-|", @cmd or die $!;
1334 close FIA or ($!==0 && $?==141) or die failedcmd @cmd;
1338 sub file_in_archive_dummycatapi ($$$) {
1339 my ($proto,$data,$filename) = @_;
1341 dummycatapi_run_in_mirror '
1342 find -name "$1" -print0 |
1344 ', [$filename], sub {
1347 printdebug "| $_\n";
1348 m/^(\w+) (\S+)$/ or die "$_ ?";
1349 push @out, { sha256sum => $1, filename => $2 };
1355 sub package_not_wholly_new_dummycatapi {
1356 my ($proto,$data,$pkg) = @_;
1357 dummycatapi_run_in_mirror "
1358 find -name ${pkg}_*.dsc
1365 #---------- `madison' archive query method ----------
1367 sub archive_query_madison {
1368 return archive_query_prepend_mirror
1369 map { [ @$_[0..1] ] } madison_get_parse(@_);
1372 sub madison_get_parse {
1373 my ($proto,$data) = @_;
1374 die unless $proto eq 'madison';
1375 if (!length $data) {
1376 $data= access_cfg('madison-distro','RETURN-UNDEF');
1377 $data //= access_basedistro();
1379 $rmad{$proto,$data,$package} ||= cmdoutput
1380 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1381 my $rmad = $rmad{$proto,$data,$package};
1384 foreach my $l (split /\n/, $rmad) {
1385 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1386 \s*( [^ \t|]+ )\s* \|
1387 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1388 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1389 $1 eq $package or die "$rmad $package ?";
1396 $component = access_cfg('archive-query-default-component');
1398 $5 eq 'source' or die "$rmad ?";
1399 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1401 return sort { -version_compare($a->[0],$b->[0]); } @out;
1404 sub canonicalise_suite_madison {
1405 # madison canonicalises for us
1406 my @r = madison_get_parse(@_);
1408 "unable to canonicalise suite using package $package".
1409 " which does not appear to exist in suite $isuite;".
1410 " --existing-package may help";
1414 sub file_in_archive_madison { return undef; }
1415 sub package_not_wholly_new_madison { return undef; }
1417 #---------- `sshpsql' archive query method ----------
1420 my ($data,$runeinfo,$sql) = @_;
1421 if (!length $data) {
1422 $data= access_someuserhost('sshpsql').':'.
1423 access_cfg('sshpsql-dbname');
1425 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1426 my ($userhost,$dbname) = ($`,$'); #';
1428 my @cmd = (access_cfg_ssh, $userhost,
1429 access_runeinfo("ssh-psql $runeinfo").
1430 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1431 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1433 open P, "-|", @cmd or die $!;
1436 printdebug(">|$_|\n");
1439 $!=0; $?=0; close P or failedcmd @cmd;
1441 my $nrows = pop @rows;
1442 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1443 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1444 @rows = map { [ split /\|/, $_ ] } @rows;
1445 my $ncols = scalar @{ shift @rows };
1446 die if grep { scalar @$_ != $ncols } @rows;
1450 sub sql_injection_check {
1451 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1454 sub archive_query_sshpsql ($$) {
1455 my ($proto,$data) = @_;
1456 sql_injection_check $isuite, $package;
1457 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1458 SELECT source.version, component.name, files.filename, files.sha256sum
1460 JOIN src_associations ON source.id = src_associations.source
1461 JOIN suite ON suite.id = src_associations.suite
1462 JOIN dsc_files ON dsc_files.source = source.id
1463 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1464 JOIN component ON component.id = files_archive_map.component_id
1465 JOIN files ON files.id = dsc_files.file
1466 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1467 AND source.source='$package'
1468 AND files.filename LIKE '%.dsc';
1470 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1471 my $digester = Digest::SHA->new(256);
1473 my ($vsn,$component,$filename,$sha256sum) = @$_;
1474 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1476 return archive_query_prepend_mirror @rows;
1479 sub canonicalise_suite_sshpsql ($$) {
1480 my ($proto,$data) = @_;
1481 sql_injection_check $isuite;
1482 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1483 SELECT suite.codename
1484 FROM suite where suite_name='$isuite' or codename='$isuite';
1486 @rows = map { $_->[0] } @rows;
1487 fail "unknown suite $isuite" unless @rows;
1488 die "ambiguous $isuite: @rows ?" if @rows>1;
1492 sub file_in_archive_sshpsql ($$$) { return undef; }
1493 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1495 #---------- `dummycat' archive query method ----------
1497 sub canonicalise_suite_dummycat ($$) {
1498 my ($proto,$data) = @_;
1499 my $dpath = "$data/suite.$isuite";
1500 if (!open C, "<", $dpath) {
1501 $!==ENOENT or die "$dpath: $!";
1502 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1506 chomp or die "$dpath: $!";
1508 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1512 sub archive_query_dummycat ($$) {
1513 my ($proto,$data) = @_;
1514 canonicalise_suite();
1515 my $dpath = "$data/package.$csuite.$package";
1516 if (!open C, "<", $dpath) {
1517 $!==ENOENT or die "$dpath: $!";
1518 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1526 printdebug "dummycat query $csuite $package $dpath | $_\n";
1527 my @row = split /\s+/, $_;
1528 @row==2 or die "$dpath: $_ ?";
1531 C->error and die "$dpath: $!";
1533 return archive_query_prepend_mirror
1534 sort { -version_compare($a->[0],$b->[0]); } @rows;
1537 sub file_in_archive_dummycat () { return undef; }
1538 sub package_not_wholly_new_dummycat () { return undef; }
1540 #---------- tag format handling ----------
1542 sub access_cfg_tagformats () {
1543 split /\,/, access_cfg('dgit-tag-format');
1546 sub access_cfg_tagformats_can_splitbrain () {
1547 my %y = map { $_ => 1 } access_cfg_tagformats;
1548 foreach my $needtf (qw(new maint)) {
1549 next if $y{$needtf};
1555 sub need_tagformat ($$) {
1556 my ($fmt, $why) = @_;
1557 fail "need to use tag format $fmt ($why) but also need".
1558 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1559 " - no way to proceed"
1560 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1561 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1564 sub select_tagformat () {
1566 return if $tagformatfn && !$tagformat_want;
1567 die 'bug' if $tagformatfn && $tagformat_want;
1568 # ... $tagformat_want assigned after previous select_tagformat
1570 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1571 printdebug "select_tagformat supported @supported\n";
1573 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1574 printdebug "select_tagformat specified @$tagformat_want\n";
1576 my ($fmt,$why,$override) = @$tagformat_want;
1578 fail "target distro supports tag formats @supported".
1579 " but have to use $fmt ($why)"
1581 or grep { $_ eq $fmt } @supported;
1583 $tagformat_want = undef;
1585 $tagformatfn = ${*::}{"debiantag_$fmt"};
1587 fail "trying to use unknown tag format \`$fmt' ($why) !"
1588 unless $tagformatfn;
1591 #---------- archive query entrypoints and rest of program ----------
1593 sub canonicalise_suite () {
1594 return if defined $csuite;
1595 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1596 $csuite = archive_query('canonicalise_suite');
1597 if ($isuite ne $csuite) {
1598 progress "canonical suite name for $isuite is $csuite";
1600 progress "canonical suite name is $csuite";
1604 sub get_archive_dsc () {
1605 canonicalise_suite();
1606 my @vsns = archive_query('archive_query');
1607 foreach my $vinfo (@vsns) {
1608 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1609 $dscurl = $vsn_dscurl;
1610 $dscdata = url_get($dscurl);
1612 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1617 $digester->add($dscdata);
1618 my $got = $digester->hexdigest();
1620 fail "$dscurl has hash $got but".
1621 " archive told us to expect $digest";
1624 my $fmt = getfield $dsc, 'Format';
1625 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1626 "unsupported source format $fmt, sorry";
1628 $dsc_checked = !!$digester;
1629 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1633 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1636 sub check_for_git ();
1637 sub check_for_git () {
1639 my $how = access_cfg('git-check');
1640 if ($how eq 'ssh-cmd') {
1642 (access_cfg_ssh, access_gituserhost(),
1643 access_runeinfo("git-check $package").
1644 " set -e; cd ".access_cfg('git-path').";".
1645 " if test -d $package.git; then echo 1; else echo 0; fi");
1646 my $r= cmdoutput @cmd;
1647 if (defined $r and $r =~ m/^divert (\w+)$/) {
1649 my ($usedistro,) = access_distros();
1650 # NB that if we are pushing, $usedistro will be $distro/push
1651 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1652 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1653 progress "diverting to $divert (using config for $instead_distro)";
1654 return check_for_git();
1656 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1658 } elsif ($how eq 'url') {
1659 my $prefix = access_cfg('git-check-url','git-url');
1660 my $suffix = access_cfg('git-check-suffix','git-suffix',
1661 'RETURN-UNDEF') // '.git';
1662 my $url = "$prefix/$package$suffix";
1663 my @cmd = (@curl, qw(-sS -I), $url);
1664 my $result = cmdoutput @cmd;
1665 $result =~ s/^\S+ 200 .*\n\r?\n//;
1666 # curl -sS -I with https_proxy prints
1667 # HTTP/1.0 200 Connection established
1668 $result =~ m/^\S+ (404|200) /s or
1669 fail "unexpected results from git check query - ".
1670 Dumper($prefix, $result);
1672 if ($code eq '404') {
1674 } elsif ($code eq '200') {
1679 } elsif ($how eq 'true') {
1681 } elsif ($how eq 'false') {
1684 badcfg "unknown git-check \`$how'";
1688 sub create_remote_git_repo () {
1689 my $how = access_cfg('git-create');
1690 if ($how eq 'ssh-cmd') {
1692 (access_cfg_ssh, access_gituserhost(),
1693 access_runeinfo("git-create $package").
1694 "set -e; cd ".access_cfg('git-path').";".
1695 " cp -a _template $package.git");
1696 } elsif ($how eq 'true') {
1699 badcfg "unknown git-create \`$how'";
1703 our ($dsc_hash,$lastpush_mergeinput);
1704 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1708 dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1709 $playground = fresh_playground 'dgit/unpack';
1712 sub mktree_in_ud_here () {
1713 playtree_setup $gitcfgs{local};
1716 sub git_write_tree () {
1717 my $tree = cmdoutput @git, qw(write-tree);
1718 $tree =~ m/^\w+$/ or die "$tree ?";
1722 sub git_add_write_tree () {
1723 runcmd @git, qw(add -Af .);
1724 return git_write_tree();
1727 sub remove_stray_gits ($) {
1729 my @gitscmd = qw(find -name .git -prune -print0);
1730 debugcmd "|",@gitscmd;
1731 open GITS, "-|", @gitscmd or die $!;
1736 print STDERR "$us: warning: removing from $what: ",
1737 (messagequote $_), "\n";
1741 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1744 sub mktree_in_ud_from_only_subdir ($;$) {
1745 my ($what,$raw) = @_;
1746 # changes into the subdir
1749 die "expected one subdir but found @dirs ?" unless @dirs==1;
1750 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1754 remove_stray_gits($what);
1755 mktree_in_ud_here();
1757 my ($format, $fopts) = get_source_format();
1758 if (madformat($format)) {
1763 my $tree=git_add_write_tree();
1764 return ($tree,$dir);
1767 our @files_csum_info_fields =
1768 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1769 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1770 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1772 sub dsc_files_info () {
1773 foreach my $csumi (@files_csum_info_fields) {
1774 my ($fname, $module, $method) = @$csumi;
1775 my $field = $dsc->{$fname};
1776 next unless defined $field;
1777 eval "use $module; 1;" or die $@;
1779 foreach (split /\n/, $field) {
1781 m/^(\w+) (\d+) (\S+)$/ or
1782 fail "could not parse .dsc $fname line \`$_'";
1783 my $digester = eval "$module"."->$method;" or die $@;
1788 Digester => $digester,
1793 fail "missing any supported Checksums-* or Files field in ".
1794 $dsc->get_option('name');
1798 map { $_->{Filename} } dsc_files_info();
1801 sub files_compare_inputs (@) {
1806 my $showinputs = sub {
1807 return join "; ", map { $_->get_option('name') } @$inputs;
1810 foreach my $in (@$inputs) {
1812 my $in_name = $in->get_option('name');
1814 printdebug "files_compare_inputs $in_name\n";
1816 foreach my $csumi (@files_csum_info_fields) {
1817 my ($fname) = @$csumi;
1818 printdebug "files_compare_inputs $in_name $fname\n";
1820 my $field = $in->{$fname};
1821 next unless defined $field;
1824 foreach (split /\n/, $field) {
1827 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1828 fail "could not parse $in_name $fname line \`$_'";
1830 printdebug "files_compare_inputs $in_name $fname $f\n";
1834 my $re = \ $record{$f}{$fname};
1836 $fchecked{$f}{$in_name} = 1;
1838 fail "hash or size of $f varies in $fname fields".
1839 " (between: ".$showinputs->().")";
1844 @files = sort @files;
1845 $expected_files //= \@files;
1846 "@$expected_files" eq "@files" or
1847 fail "file list in $in_name varies between hash fields!";
1850 fail "$in_name has no files list field(s)";
1852 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1855 grep { keys %$_ == @$inputs-1 } values %fchecked
1856 or fail "no file appears in all file lists".
1857 " (looked in: ".$showinputs->().")";
1860 sub is_orig_file_in_dsc ($$) {
1861 my ($f, $dsc_files_info) = @_;
1862 return 0 if @$dsc_files_info <= 1;
1863 # One file means no origs, and the filename doesn't have a "what
1864 # part of dsc" component. (Consider versions ending `.orig'.)
1865 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1869 sub is_orig_file_of_vsn ($$) {
1870 my ($f, $upstreamvsn) = @_;
1871 my $base = srcfn $upstreamvsn, '';
1872 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1876 # This function determines whether a .changes file is source-only from
1877 # the point of view of dak. Thus, it permits *_source.buildinfo
1880 # It does not, however, permit any other buildinfo files. After a
1881 # source-only upload, the buildds will try to upload files like
1882 # foo_1.2.3_amd64.buildinfo. If the package maintainer included files
1883 # named like this in their (otherwise) source-only upload, the uploads
1884 # of the buildd can be rejected by dak. Fixing the resultant
1885 # situation can require manual intervention. So we block such
1886 # .buildinfo files when the user tells us to perform a source-only
1887 # upload (such as when using the push-source subcommand with the -C
1888 # option, which calls this function).
1890 # Note, though, that when dgit is told to prepare a source-only
1891 # upload, such as when subcommands like build-source and push-source
1892 # without -C are used, dgit has a more restrictive notion of
1893 # source-only .changes than dak: such uploads will never include
1894 # *_source.buildinfo files. This is because there is no use for such
1895 # files when using a tool like dgit to produce the source package, as
1896 # dgit ensures the source is identical to git HEAD.
1897 sub test_source_only_changes ($) {
1899 foreach my $l (split /\n/, getfield $changes, 'Files') {
1900 $l =~ m/\S+$/ or next;
1901 # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1902 unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1903 print "purportedly source-only changes polluted by $&\n";
1910 sub changes_update_origs_from_dsc ($$$$) {
1911 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1913 printdebug "checking origs needed ($upstreamvsn)...\n";
1914 $_ = getfield $changes, 'Files';
1915 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1916 fail "cannot find section/priority from .changes Files field";
1917 my $placementinfo = $1;
1919 printdebug "checking origs needed placement '$placementinfo'...\n";
1920 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1921 $l =~ m/\S+$/ or next;
1923 printdebug "origs $file | $l\n";
1924 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1925 printdebug "origs $file is_orig\n";
1926 my $have = archive_query('file_in_archive', $file);
1927 if (!defined $have) {
1929 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1935 printdebug "origs $file \$#\$have=$#$have\n";
1936 foreach my $h (@$have) {
1939 foreach my $csumi (@files_csum_info_fields) {
1940 my ($fname, $module, $method, $archivefield) = @$csumi;
1941 next unless defined $h->{$archivefield};
1942 $_ = $dsc->{$fname};
1943 next unless defined;
1944 m/^(\w+) .* \Q$file\E$/m or
1945 fail ".dsc $fname missing entry for $file";
1946 if ($h->{$archivefield} eq $1) {
1950 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1953 die "$file ".Dumper($h)." ?!" if $same && @differ;
1956 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1959 printdebug "origs $file f.same=$found_same".
1960 " #f._differ=$#found_differ\n";
1961 if (@found_differ && !$found_same) {
1963 "archive contains $file with different checksum",
1966 # Now we edit the changes file to add or remove it
1967 foreach my $csumi (@files_csum_info_fields) {
1968 my ($fname, $module, $method, $archivefield) = @$csumi;
1969 next unless defined $changes->{$fname};
1971 # in archive, delete from .changes if it's there
1972 $changed{$file} = "removed" if
1973 $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
1974 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
1975 # not in archive, but it's here in the .changes
1977 my $dsc_data = getfield $dsc, $fname;
1978 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
1980 $extra =~ s/ \d+ /$&$placementinfo /
1981 or die "$fname $extra >$dsc_data< ?"
1982 if $fname eq 'Files';
1983 $changes->{$fname} .= "\n". $extra;
1984 $changed{$file} = "added";
1989 foreach my $file (keys %changed) {
1991 "edited .changes for archive .orig contents: %s %s",
1992 $changed{$file}, $file;
1994 my $chtmp = "$changesfile.tmp";
1995 $changes->save($chtmp);
1997 rename $chtmp,$changesfile or die "$changesfile $!";
1999 progress "[new .changes left in $changesfile]";
2002 progress "$changesfile already has appropriate .orig(s) (if any)";
2006 sub make_commit ($) {
2008 return cmdoutput @git, qw(hash-object -w -t commit), $file;
2011 sub make_commit_text ($) {
2014 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
2016 print Dumper($text) if $debuglevel > 1;
2017 my $child = open2($out, $in, @cmd) or die $!;
2020 print $in $text or die $!;
2021 close $in or die $!;
2023 $h =~ m/^\w+$/ or die;
2025 printdebug "=> $h\n";
2028 waitpid $child, 0 == $child or die "$child $!";
2029 $? and failedcmd @cmd;
2033 sub clogp_authline ($) {
2035 my $author = getfield $clogp, 'Maintainer';
2036 if ($author =~ m/^[^"\@]+\,/) {
2037 # single entry Maintainer field with unquoted comma
2038 $author = ($& =~ y/,//rd).$'; # strip the comma
2040 # git wants a single author; any remaining commas in $author
2041 # are by now preceded by @ (or "). It seems safer to punt on
2042 # "..." for now rather than attempting to dequote or something.
2043 $author =~ s#,.*##ms unless $author =~ m/"/;
2044 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2045 my $authline = "$author $date";
2046 $authline =~ m/$git_authline_re/o or
2047 fail "unexpected commit author line format \`$authline'".
2048 " (was generated from changelog Maintainer field)";
2049 return ($1,$2,$3) if wantarray;
2053 sub vendor_patches_distro ($$) {
2054 my ($checkdistro, $what) = @_;
2055 return unless defined $checkdistro;
2057 my $series = "debian/patches/\L$checkdistro\E.series";
2058 printdebug "checking for vendor-specific $series ($what)\n";
2060 if (!open SERIES, "<", $series) {
2061 die "$series $!" unless $!==ENOENT;
2070 Unfortunately, this source package uses a feature of dpkg-source where
2071 the same source package unpacks to different source code on different
2072 distros. dgit cannot safely operate on such packages on affected
2073 distros, because the meaning of source packages is not stable.
2075 Please ask the distro/maintainer to remove the distro-specific series
2076 files and use a different technique (if necessary, uploading actually
2077 different packages, if different distros are supposed to have
2081 fail "Found active distro-specific series file for".
2082 " $checkdistro ($what): $series, cannot continue";
2084 die "$series $!" if SERIES->error;
2088 sub check_for_vendor_patches () {
2089 # This dpkg-source feature doesn't seem to be documented anywhere!
2090 # But it can be found in the changelog (reformatted):
2092 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2093 # Author: Raphael Hertzog <hertzog@debian.org>
2094 # Date: Sun Oct 3 09:36:48 2010 +0200
2096 # dpkg-source: correctly create .pc/.quilt_series with alternate
2099 # If you have debian/patches/ubuntu.series and you were
2100 # unpacking the source package on ubuntu, quilt was still
2101 # directed to debian/patches/series instead of
2102 # debian/patches/ubuntu.series.
2104 # debian/changelog | 3 +++
2105 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2106 # 2 files changed, 6 insertions(+), 1 deletion(-)
2109 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2110 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2111 "Dpkg::Vendor \`current vendor'");
2112 vendor_patches_distro(access_basedistro(),
2113 "(base) distro being accessed");
2114 vendor_patches_distro(access_nomdistro(),
2115 "(nominal) distro being accessed");
2118 sub generate_commits_from_dsc () {
2119 # See big comment in fetch_from_archive, below.
2120 # See also README.dsc-import.
2122 changedir $playground;
2124 my @dfi = dsc_files_info();
2125 foreach my $fi (@dfi) {
2126 my $f = $fi->{Filename};
2127 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2128 my $upper_f = (bpd_abs()."/$f");
2130 printdebug "considering reusing $f: ";
2132 if (link_ltarget "$upper_f,fetch", $f) {
2133 printdebug "linked (using ...,fetch).\n";
2134 } elsif ((printdebug "($!) "),
2136 fail "accessing $buildproductsdir/$f,fetch: $!";
2137 } elsif (link_ltarget $upper_f, $f) {
2138 printdebug "linked.\n";
2139 } elsif ((printdebug "($!) "),
2141 fail "accessing $buildproductsdir/$f: $!";
2143 printdebug "absent.\n";
2147 complete_file_from_dsc('.', $fi, \$refetched)
2150 printdebug "considering saving $f: ";
2152 if (link $f, $upper_f) {
2153 printdebug "linked.\n";
2154 } elsif ((printdebug "($!) "),
2156 fail "saving $buildproductsdir/$f: $!";
2157 } elsif (!$refetched) {
2158 printdebug "no need.\n";
2159 } elsif (link $f, "$upper_f,fetch") {
2160 printdebug "linked (using ...,fetch).\n";
2161 } elsif ((printdebug "($!) "),
2163 fail "saving $buildproductsdir/$f,fetch: $!";
2165 printdebug "cannot.\n";
2169 # We unpack and record the orig tarballs first, so that we only
2170 # need disk space for one private copy of the unpacked source.
2171 # But we can't make them into commits until we have the metadata
2172 # from the debian/changelog, so we record the tree objects now and
2173 # make them into commits later.
2175 my $upstreamv = upstreamversion $dsc->{version};
2176 my $orig_f_base = srcfn $upstreamv, '';
2178 foreach my $fi (@dfi) {
2179 # We actually import, and record as a commit, every tarball
2180 # (unless there is only one file, in which case there seems
2183 my $f = $fi->{Filename};
2184 printdebug "import considering $f ";
2185 (printdebug "only one dfi\n"), next if @dfi == 1;
2186 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2187 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2191 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2193 printdebug "Y ", (join ' ', map { $_//"(none)" }
2194 $compr_ext, $orig_f_part
2197 my $input = new IO::File $f, '<' or die "$f $!";
2201 if (defined $compr_ext) {
2203 Dpkg::Compression::compression_guess_from_filename $f;
2204 fail "Dpkg::Compression cannot handle file $f in source package"
2205 if defined $compr_ext && !defined $cname;
2207 new Dpkg::Compression::Process compression => $cname;
2208 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2209 my $compr_fh = new IO::Handle;
2210 my $compr_pid = open $compr_fh, "-|" // die $!;
2212 open STDIN, "<&", $input or die $!;
2214 die "dgit (child): exec $compr_cmd[0]: $!\n";
2219 rmtree "_unpack-tar";
2220 mkdir "_unpack-tar" or die $!;
2221 my @tarcmd = qw(tar -x -f -
2222 --no-same-owner --no-same-permissions
2223 --no-acls --no-xattrs --no-selinux);
2224 my $tar_pid = fork // die $!;
2226 chdir "_unpack-tar" or die $!;
2227 open STDIN, "<&", $input or die $!;
2229 die "dgit (child): exec $tarcmd[0]: $!";
2231 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2232 !$? or failedcmd @tarcmd;
2235 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2237 # finally, we have the results in "tarball", but maybe
2238 # with the wrong permissions
2240 runcmd qw(chmod -R +rwX _unpack-tar);
2241 changedir "_unpack-tar";
2242 remove_stray_gits($f);
2243 mktree_in_ud_here();
2245 my ($tree) = git_add_write_tree();
2246 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2247 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2249 printdebug "one subtree $1\n";
2251 printdebug "multiple subtrees\n";
2254 rmtree "_unpack-tar";
2256 my $ent = [ $f, $tree ];
2258 Orig => !!$orig_f_part,
2259 Sort => (!$orig_f_part ? 2 :
2260 $orig_f_part =~ m/-/g ? 1 :
2268 # put any without "_" first (spec is not clear whether files
2269 # are always in the usual order). Tarballs without "_" are
2270 # the main orig or the debian tarball.
2271 $a->{Sort} <=> $b->{Sort} or
2275 my $any_orig = grep { $_->{Orig} } @tartrees;
2277 my $dscfn = "$package.dsc";
2279 my $treeimporthow = 'package';
2281 open D, ">", $dscfn or die "$dscfn: $!";
2282 print D $dscdata or die "$dscfn: $!";
2283 close D or die "$dscfn: $!";
2284 my @cmd = qw(dpkg-source);
2285 push @cmd, '--no-check' if $dsc_checked;
2286 if (madformat $dsc->{format}) {
2287 push @cmd, '--skip-patches';
2288 $treeimporthow = 'unpatched';
2290 push @cmd, qw(-x --), $dscfn;
2293 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2294 if (madformat $dsc->{format}) {
2295 check_for_vendor_patches();
2299 if (madformat $dsc->{format}) {
2300 my @pcmd = qw(dpkg-source --before-build .);
2301 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2303 $dappliedtree = git_add_write_tree();
2306 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2310 printdebug "import clog search...\n";
2311 parsechangelog_loop \@clogcmd, "package changelog", sub {
2312 my ($thisstanza, $desc) = @_;
2313 no warnings qw(exiting);
2315 $clogp //= $thisstanza;
2317 printdebug "import clog $thisstanza->{version} $desc...\n";
2319 last if !$any_orig; # we don't need $r1clogp
2321 # We look for the first (most recent) changelog entry whose
2322 # version number is lower than the upstream version of this
2323 # package. Then the last (least recent) previous changelog
2324 # entry is treated as the one which introduced this upstream
2325 # version and used for the synthetic commits for the upstream
2328 # One might think that a more sophisticated algorithm would be
2329 # necessary. But: we do not want to scan the whole changelog
2330 # file. Stopping when we see an earlier version, which
2331 # necessarily then is an earlier upstream version, is the only
2332 # realistic way to do that. Then, either the earliest
2333 # changelog entry we have seen so far is indeed the earliest
2334 # upload of this upstream version; or there are only changelog
2335 # entries relating to later upstream versions (which is not
2336 # possible unless the changelog and .dsc disagree about the
2337 # version). Then it remains to choose between the physically
2338 # last entry in the file, and the one with the lowest version
2339 # number. If these are not the same, we guess that the
2340 # versions were created in a non-monotonic order rather than
2341 # that the changelog entries have been misordered.
2343 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2345 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2346 $r1clogp = $thisstanza;
2348 printdebug "import clog $r1clogp->{version} becomes r1\n";
2351 $clogp or fail "package changelog has no entries!";
2353 my $authline = clogp_authline $clogp;
2354 my $changes = getfield $clogp, 'Changes';
2355 $changes =~ s/^\n//; # Changes: \n
2356 my $cversion = getfield $clogp, 'Version';
2359 $r1clogp //= $clogp; # maybe there's only one entry;
2360 my $r1authline = clogp_authline $r1clogp;
2361 # Strictly, r1authline might now be wrong if it's going to be
2362 # unused because !$any_orig. Whatever.
2364 printdebug "import tartrees authline $authline\n";
2365 printdebug "import tartrees r1authline $r1authline\n";
2367 foreach my $tt (@tartrees) {
2368 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2370 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2373 committer $r1authline
2377 [dgit import orig $tt->{F}]
2385 [dgit import tarball $package $cversion $tt->{F}]
2390 printdebug "import main commit\n";
2392 open C, ">../commit.tmp" or die $!;
2393 print C <<END or die $!;
2396 print C <<END or die $! foreach @tartrees;
2399 print C <<END or die $!;
2405 [dgit import $treeimporthow $package $cversion]
2409 my $rawimport_hash = make_commit qw(../commit.tmp);
2411 if (madformat $dsc->{format}) {
2412 printdebug "import apply patches...\n";
2414 # regularise the state of the working tree so that
2415 # the checkout of $rawimport_hash works nicely.
2416 my $dappliedcommit = make_commit_text(<<END);
2423 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2425 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2427 # We need the answers to be reproducible
2428 my @authline = clogp_authline($clogp);
2429 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2430 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2431 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2432 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2433 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2434 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2436 my $path = $ENV{PATH} or die;
2438 # we use ../../gbp-pq-output, which (given that we are in
2439 # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2442 foreach my $use_absurd (qw(0 1)) {
2443 runcmd @git, qw(checkout -q unpa);
2444 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2445 local $ENV{PATH} = $path;
2448 progress "warning: $@";
2449 $path = "$absurdity:$path";
2450 progress "$us: trying slow absurd-git-apply...";
2451 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2456 die "forbid absurd git-apply\n" if $use_absurd
2457 && forceing [qw(import-gitapply-no-absurd)];
2458 die "only absurd git-apply!\n" if !$use_absurd
2459 && forceing [qw(import-gitapply-absurd)];
2461 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2462 local $ENV{PATH} = $path if $use_absurd;
2464 my @showcmd = (gbp_pq, qw(import));
2465 my @realcmd = shell_cmd
2466 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2467 debugcmd "+",@realcmd;
2468 if (system @realcmd) {
2469 die +(shellquote @showcmd).
2471 failedcmd_waitstatus()."\n";
2474 my $gapplied = git_rev_parse('HEAD');
2475 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2476 $gappliedtree eq $dappliedtree or
2478 gbp-pq import and dpkg-source disagree!
2479 gbp-pq import gave commit $gapplied
2480 gbp-pq import gave tree $gappliedtree
2481 dpkg-source --before-build gave tree $dappliedtree
2483 $rawimport_hash = $gapplied;
2488 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2493 progress "synthesised git commit from .dsc $cversion";
2495 my $rawimport_mergeinput = {
2496 Commit => $rawimport_hash,
2497 Info => "Import of source package",
2499 my @output = ($rawimport_mergeinput);
2501 if ($lastpush_mergeinput) {
2502 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2503 my $oversion = getfield $oldclogp, 'Version';
2505 version_compare($oversion, $cversion);
2507 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2508 { Message => <<END, ReverseParents => 1 });
2509 Record $package ($cversion) in archive suite $csuite
2511 } elsif ($vcmp > 0) {
2512 print STDERR <<END or die $!;
2514 Version actually in archive: $cversion (older)
2515 Last version pushed with dgit: $oversion (newer or same)
2518 @output = $lastpush_mergeinput;
2520 # Same version. Use what's in the server git branch,
2521 # discarding our own import. (This could happen if the
2522 # server automatically imports all packages into git.)
2523 @output = $lastpush_mergeinput;
2531 sub complete_file_from_dsc ($$;$) {
2532 our ($dstdir, $fi, $refetched) = @_;
2533 # Ensures that we have, in $dstdir, the file $fi, with the correct
2534 # contents. (Downloading it from alongside $dscurl if necessary.)
2535 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2536 # and will set $$refetched=1 if it did so (or tried to).
2538 my $f = $fi->{Filename};
2539 my $tf = "$dstdir/$f";
2543 my $checkhash = sub {
2544 open F, "<", "$tf" or die "$tf: $!";
2545 $fi->{Digester}->reset();
2546 $fi->{Digester}->addfile(*F);
2547 F->error and die $!;
2548 $got = $fi->{Digester}->hexdigest();
2549 return $got eq $fi->{Hash};
2552 if (stat_exists $tf) {
2553 if ($checkhash->()) {
2554 progress "using existing $f";
2558 fail "file $f has hash $got but .dsc".
2559 " demands hash $fi->{Hash} ".
2560 "(perhaps you should delete this file?)";
2562 progress "need to fetch correct version of $f";
2563 unlink $tf or die "$tf $!";
2566 printdebug "$tf does not exist, need to fetch\n";
2570 $furl =~ s{/[^/]+$}{};
2572 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2573 die "$f ?" if $f =~ m#/#;
2574 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2575 return 0 if !act_local();
2578 fail "file $f has hash $got but .dsc".
2579 " demands hash $fi->{Hash} ".
2580 "(got wrong file from archive!)";
2585 sub ensure_we_have_orig () {
2586 my @dfi = dsc_files_info();
2587 foreach my $fi (@dfi) {
2588 my $f = $fi->{Filename};
2589 next unless is_orig_file_in_dsc($f, \@dfi);
2590 complete_file_from_dsc($buildproductsdir, $fi)
2595 #---------- git fetch ----------
2597 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2598 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2600 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2601 # locally fetched refs because they have unhelpful names and clutter
2602 # up gitk etc. So we track whether we have "used up" head ref (ie,
2603 # whether we have made another local ref which refers to this object).
2605 # (If we deleted them unconditionally, then we might end up
2606 # re-fetching the same git objects each time dgit fetch was run.)
2608 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2609 # in git_fetch_us to fetch the refs in question, and possibly a call
2610 # to lrfetchref_used.
2612 our (%lrfetchrefs_f, %lrfetchrefs_d);
2613 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2615 sub lrfetchref_used ($) {
2616 my ($fullrefname) = @_;
2617 my $objid = $lrfetchrefs_f{$fullrefname};
2618 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2621 sub git_lrfetch_sane {
2622 my ($url, $supplementary, @specs) = @_;
2623 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2624 # at least as regards @specs. Also leave the results in
2625 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2626 # able to clean these up.
2628 # With $supplementary==1, @specs must not contain wildcards
2629 # and we add to our previous fetches (non-atomically).
2631 # This is rather miserable:
2632 # When git fetch --prune is passed a fetchspec ending with a *,
2633 # it does a plausible thing. If there is no * then:
2634 # - it matches subpaths too, even if the supplied refspec
2635 # starts refs, and behaves completely madly if the source
2636 # has refs/refs/something. (See, for example, Debian #NNNN.)
2637 # - if there is no matching remote ref, it bombs out the whole
2639 # We want to fetch a fixed ref, and we don't know in advance
2640 # if it exists, so this is not suitable.
2642 # Our workaround is to use git ls-remote. git ls-remote has its
2643 # own qairks. Notably, it has the absurd multi-tail-matching
2644 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2645 # refs/refs/foo etc.
2647 # Also, we want an idempotent snapshot, but we have to make two
2648 # calls to the remote: one to git ls-remote and to git fetch. The
2649 # solution is use git ls-remote to obtain a target state, and
2650 # git fetch to try to generate it. If we don't manage to generate
2651 # the target state, we try again.
2653 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2655 my $specre = join '|', map {
2658 my $wildcard = $x =~ s/\\\*$/.*/;
2659 die if $wildcard && $supplementary;
2662 printdebug "git_lrfetch_sane specre=$specre\n";
2663 my $wanted_rref = sub {
2665 return m/^(?:$specre)$/;
2668 my $fetch_iteration = 0;
2671 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2672 if (++$fetch_iteration > 10) {
2673 fail "too many iterations trying to get sane fetch!";
2676 my @look = map { "refs/$_" } @specs;
2677 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2681 open GITLS, "-|", @lcmd or die $!;
2683 printdebug "=> ", $_;
2684 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2685 my ($objid,$rrefname) = ($1,$2);
2686 if (!$wanted_rref->($rrefname)) {
2688 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2692 $wantr{$rrefname} = $objid;
2695 close GITLS or failedcmd @lcmd;
2697 # OK, now %want is exactly what we want for refs in @specs
2699 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2700 "+refs/$_:".lrfetchrefs."/$_";
2703 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2705 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2706 runcmd_ordryrun_local @fcmd if @fspecs;
2708 if (!$supplementary) {
2709 %lrfetchrefs_f = ();
2713 git_for_each_ref(lrfetchrefs, sub {
2714 my ($objid,$objtype,$lrefname,$reftail) = @_;
2715 $lrfetchrefs_f{$lrefname} = $objid;
2716 $objgot{$objid} = 1;
2719 if ($supplementary) {
2723 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2724 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2725 if (!exists $wantr{$rrefname}) {
2726 if ($wanted_rref->($rrefname)) {
2728 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2732 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2735 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2736 delete $lrfetchrefs_f{$lrefname};
2740 foreach my $rrefname (sort keys %wantr) {
2741 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2742 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2743 my $want = $wantr{$rrefname};
2744 next if $got eq $want;
2745 if (!defined $objgot{$want}) {
2746 fail <<END unless act_local();
2747 --dry-run specified but we actually wanted the results of git fetch,
2748 so this is not going to work. Try running dgit fetch first,
2749 or using --damp-run instead of --dry-run.
2752 warning: git ls-remote suggests we want $lrefname
2753 warning: and it should refer to $want
2754 warning: but git fetch didn't fetch that object to any relevant ref.
2755 warning: This may be due to a race with someone updating the server.
2756 warning: Will try again...
2758 next FETCH_ITERATION;
2761 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2763 runcmd_ordryrun_local @git, qw(update-ref -m),
2764 "dgit fetch git fetch fixup", $lrefname, $want;
2765 $lrfetchrefs_f{$lrefname} = $want;
2770 if (defined $csuite) {
2771 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2772 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2773 my ($objid,$objtype,$lrefname,$reftail) = @_;
2774 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2775 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2779 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2780 Dumper(\%lrfetchrefs_f);
2783 sub git_fetch_us () {
2784 # Want to fetch only what we are going to use, unless
2785 # deliberately-not-ff, in which case we must fetch everything.
2787 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2789 (quiltmode_splitbrain
2790 ? (map { $_->('*',access_nomdistro) }
2791 \&debiantag_new, \&debiantag_maintview)
2792 : debiantags('*',access_nomdistro));
2793 push @specs, server_branch($csuite);
2794 push @specs, $rewritemap;
2795 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2797 my $url = access_giturl();
2798 git_lrfetch_sane $url, 0, @specs;
2801 my @tagpats = debiantags('*',access_nomdistro);
2803 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2804 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2805 printdebug "currently $fullrefname=$objid\n";
2806 $here{$fullrefname} = $objid;
2808 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2809 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2810 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2811 printdebug "offered $lref=$objid\n";
2812 if (!defined $here{$lref}) {
2813 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2814 runcmd_ordryrun_local @upd;
2815 lrfetchref_used $fullrefname;
2816 } elsif ($here{$lref} eq $objid) {
2817 lrfetchref_used $fullrefname;
2820 "Not updating $lref from $here{$lref} to $objid.\n";
2825 #---------- dsc and archive handling ----------
2827 sub mergeinfo_getclogp ($) {
2828 # Ensures thit $mi->{Clogp} exists and returns it
2830 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2833 sub mergeinfo_version ($) {
2834 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2837 sub fetch_from_archive_record_1 ($) {
2839 runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2840 cmdoutput @git, qw(log -n2), $hash;
2841 # ... gives git a chance to complain if our commit is malformed
2844 sub fetch_from_archive_record_2 ($) {
2846 my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2850 dryrun_report @upd_cmd;
2854 sub parse_dsc_field_def_dsc_distro () {
2855 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2856 dgit.default.distro);
2859 sub parse_dsc_field ($$) {
2860 my ($dsc, $what) = @_;
2862 foreach my $field (@ourdscfield) {
2863 $f = $dsc->{$field};
2868 progress "$what: NO git hash";
2869 parse_dsc_field_def_dsc_distro();
2870 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2871 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2872 progress "$what: specified git info ($dsc_distro)";
2873 $dsc_hint_tag = [ $dsc_hint_tag ];
2874 } elsif ($f =~ m/^\w+\s*$/) {
2876 parse_dsc_field_def_dsc_distro();
2877 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2879 progress "$what: specified git hash";
2881 fail "$what: invalid Dgit info";
2885 sub resolve_dsc_field_commit ($$) {
2886 my ($already_distro, $already_mapref) = @_;
2888 return unless defined $dsc_hash;
2891 defined $already_mapref &&
2892 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2893 ? $already_mapref : undef;
2897 my ($what, @fetch) = @_;
2899 local $idistro = $dsc_distro;
2900 my $lrf = lrfetchrefs;
2902 if (!$chase_dsc_distro) {
2904 "not chasing .dsc distro $dsc_distro: not fetching $what";
2909 ".dsc names distro $dsc_distro: fetching $what";
2911 my $url = access_giturl();
2912 if (!defined $url) {
2913 defined $dsc_hint_url or fail <<END;
2914 .dsc Dgit metadata is in context of distro $dsc_distro
2915 for which we have no configured url and .dsc provides no hint
2918 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2919 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2920 parse_cfg_bool "dsc-url-proto-ok", 'false',
2921 cfg("dgit.dsc-url-proto-ok.$proto",
2922 "dgit.default.dsc-url-proto-ok")
2924 .dsc Dgit metadata is in context of distro $dsc_distro
2925 for which we have no configured url;
2926 .dsc provides hinted url with protocol $proto which is unsafe.
2927 (can be overridden by config - consult documentation)
2929 $url = $dsc_hint_url;
2932 git_lrfetch_sane $url, 1, @fetch;
2937 my $rewrite_enable = do {
2938 local $idistro = $dsc_distro;
2939 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2942 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2943 if (!defined $mapref) {
2944 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2945 $mapref = $lrf.'/'.$rewritemap;
2947 my $rewritemapdata = git_cat_file $mapref.':map';
2948 if (defined $rewritemapdata
2949 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2951 "server's git history rewrite map contains a relevant entry!";
2954 if (defined $dsc_hash) {
2955 progress "using rewritten git hash in place of .dsc value";
2957 progress "server data says .dsc hash is to be disregarded";
2962 if (!defined git_cat_file $dsc_hash) {
2963 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2964 my $lrf = $do_fetch->("additional commits", @tags) &&
2965 defined git_cat_file $dsc_hash
2967 .dsc Dgit metadata requires commit $dsc_hash
2968 but we could not obtain that object anywhere.
2970 foreach my $t (@tags) {
2971 my $fullrefname = $lrf.'/'.$t;
2972 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2973 next unless $lrfetchrefs_f{$fullrefname};
2974 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2975 lrfetchref_used $fullrefname;
2980 sub fetch_from_archive () {
2981 ensure_setup_existing_tree();
2983 # Ensures that lrref() is what is actually in the archive, one way
2984 # or another, according to us - ie this client's
2985 # appropritaely-updated archive view. Also returns the commit id.
2986 # If there is nothing in the archive, leaves lrref alone and
2987 # returns undef. git_fetch_us must have already been called.
2991 parse_dsc_field($dsc, 'last upload to archive');
2992 resolve_dsc_field_commit access_basedistro,
2993 lrfetchrefs."/".$rewritemap
2995 progress "no version available from the archive";
2998 # If the archive's .dsc has a Dgit field, there are three
2999 # relevant git commitids we need to choose between and/or merge
3001 # 1. $dsc_hash: the Dgit field from the archive
3002 # 2. $lastpush_hash: the suite branch on the dgit git server
3003 # 3. $lastfetch_hash: our local tracking brach for the suite
3005 # These may all be distinct and need not be in any fast forward
3008 # If the dsc was pushed to this suite, then the server suite
3009 # branch will have been updated; but it might have been pushed to
3010 # a different suite and copied by the archive. Conversely a more
3011 # recent version may have been pushed with dgit but not appeared
3012 # in the archive (yet).
3014 # $lastfetch_hash may be awkward because archive imports
3015 # (particularly, imports of Dgit-less .dscs) are performed only as
3016 # needed on individual clients, so different clients may perform a
3017 # different subset of them - and these imports are only made
3018 # public during push. So $lastfetch_hash may represent a set of
3019 # imports different to a subsequent upload by a different dgit
3022 # Our approach is as follows:
3024 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3025 # descendant of $dsc_hash, then it was pushed by a dgit user who
3026 # had based their work on $dsc_hash, so we should prefer it.
3027 # Otherwise, $dsc_hash was installed into this suite in the
3028 # archive other than by a dgit push, and (necessarily) after the
3029 # last dgit push into that suite (since a dgit push would have
3030 # been descended from the dgit server git branch); thus, in that
3031 # case, we prefer the archive's version (and produce a
3032 # pseudo-merge to overwrite the dgit server git branch).
3034 # (If there is no Dgit field in the archive's .dsc then
3035 # generate_commit_from_dsc uses the version numbers to decide
3036 # whether the suite branch or the archive is newer. If the suite
3037 # branch is newer it ignores the archive's .dsc; otherwise it
3038 # generates an import of the .dsc, and produces a pseudo-merge to
3039 # overwrite the suite branch with the archive contents.)
3041 # The outcome of that part of the algorithm is the `public view',
3042 # and is same for all dgit clients: it does not depend on any
3043 # unpublished history in the local tracking branch.
3045 # As between the public view and the local tracking branch: The
3046 # local tracking branch is only updated by dgit fetch, and
3047 # whenever dgit fetch runs it includes the public view in the
3048 # local tracking branch. Therefore if the public view is not
3049 # descended from the local tracking branch, the local tracking
3050 # branch must contain history which was imported from the archive
3051 # but never pushed; and, its tip is now out of date. So, we make
3052 # a pseudo-merge to overwrite the old imports and stitch the old
3055 # Finally: we do not necessarily reify the public view (as
3056 # described above). This is so that we do not end up stacking two
3057 # pseudo-merges. So what we actually do is figure out the inputs
3058 # to any public view pseudo-merge and put them in @mergeinputs.
3061 # $mergeinputs[]{Commit}
3062 # $mergeinputs[]{Info}
3063 # $mergeinputs[0] is the one whose tree we use
3064 # @mergeinputs is in the order we use in the actual commit)
3067 # $mergeinputs[]{Message} is a commit message to use
3068 # $mergeinputs[]{ReverseParents} if def specifies that parent
3069 # list should be in opposite order
3070 # Such an entry has no Commit or Info. It applies only when found
3071 # in the last entry. (This ugliness is to support making
3072 # identical imports to previous dgit versions.)
3074 my $lastpush_hash = git_get_ref(lrfetchref());
3075 printdebug "previous reference hash=$lastpush_hash\n";
3076 $lastpush_mergeinput = $lastpush_hash && {
3077 Commit => $lastpush_hash,
3078 Info => "dgit suite branch on dgit git server",
3081 my $lastfetch_hash = git_get_ref(lrref());
3082 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3083 my $lastfetch_mergeinput = $lastfetch_hash && {
3084 Commit => $lastfetch_hash,
3085 Info => "dgit client's archive history view",
3088 my $dsc_mergeinput = $dsc_hash && {
3089 Commit => $dsc_hash,
3090 Info => "Dgit field in .dsc from archive",
3094 my $del_lrfetchrefs = sub {
3097 printdebug "del_lrfetchrefs...\n";
3098 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3099 my $objid = $lrfetchrefs_d{$fullrefname};
3100 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3102 $gur ||= new IO::Handle;
3103 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3105 printf $gur "delete %s %s\n", $fullrefname, $objid;
3108 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3112 if (defined $dsc_hash) {
3113 ensure_we_have_orig();
3114 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3115 @mergeinputs = $dsc_mergeinput
3116 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3117 print STDERR <<END or die $!;
3119 Git commit in archive is behind the last version allegedly pushed/uploaded.
3120 Commit referred to by archive: $dsc_hash
3121 Last version pushed with dgit: $lastpush_hash
3124 @mergeinputs = ($lastpush_mergeinput);
3126 # Archive has .dsc which is not a descendant of the last dgit
3127 # push. This can happen if the archive moves .dscs about.
3128 # Just follow its lead.
3129 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3130 progress "archive .dsc names newer git commit";
3131 @mergeinputs = ($dsc_mergeinput);
3133 progress "archive .dsc names other git commit, fixing up";
3134 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3138 @mergeinputs = generate_commits_from_dsc();
3139 # We have just done an import. Now, our import algorithm might
3140 # have been improved. But even so we do not want to generate
3141 # a new different import of the same package. So if the
3142 # version numbers are the same, just use our existing version.
3143 # If the version numbers are different, the archive has changed
3144 # (perhaps, rewound).
3145 if ($lastfetch_mergeinput &&
3146 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3147 (mergeinfo_version $mergeinputs[0]) )) {
3148 @mergeinputs = ($lastfetch_mergeinput);
3150 } elsif ($lastpush_hash) {
3151 # only in git, not in the archive yet
3152 @mergeinputs = ($lastpush_mergeinput);
3153 print STDERR <<END or die $!;
3155 Package not found in the archive, but has allegedly been pushed using dgit.
3159 printdebug "nothing found!\n";
3160 if (defined $skew_warning_vsn) {
3161 print STDERR <<END or die $!;
3163 Warning: relevant archive skew detected.
3164 Archive allegedly contains $skew_warning_vsn
3165 But we were not able to obtain any version from the archive or git.
3169 unshift @end, $del_lrfetchrefs;
3173 if ($lastfetch_hash &&
3175 my $h = $_->{Commit};
3176 $h and is_fast_fwd($lastfetch_hash, $h);
3177 # If true, one of the existing parents of this commit
3178 # is a descendant of the $lastfetch_hash, so we'll
3179 # be ff from that automatically.
3183 push @mergeinputs, $lastfetch_mergeinput;
3186 printdebug "fetch mergeinfos:\n";
3187 foreach my $mi (@mergeinputs) {
3189 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3191 printdebug sprintf " ReverseParents=%d Message=%s",
3192 $mi->{ReverseParents}, $mi->{Message};
3196 my $compat_info= pop @mergeinputs
3197 if $mergeinputs[$#mergeinputs]{Message};
3199 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3202 if (@mergeinputs > 1) {
3204 my $tree_commit = $mergeinputs[0]{Commit};
3206 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3207 $tree =~ m/\n\n/; $tree = $`;
3208 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3211 # We use the changelog author of the package in question the
3212 # author of this pseudo-merge. This is (roughly) correct if
3213 # this commit is simply representing aa non-dgit upload.
3214 # (Roughly because it does not record sponsorship - but we
3215 # don't have sponsorship info because that's in the .changes,
3216 # which isn't in the archivw.)
3218 # But, it might be that we are representing archive history
3219 # updates (including in-archive copies). These are not really
3220 # the responsibility of the person who created the .dsc, but
3221 # there is no-one whose name we should better use. (The
3222 # author of the .dsc-named commit is clearly worse.)
3224 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3225 my $author = clogp_authline $useclogp;
3226 my $cversion = getfield $useclogp, 'Version';
3228 my $mcf = dgit_privdir()."/mergecommit";
3229 open MC, ">", $mcf or die "$mcf $!";
3230 print MC <<END or die $!;
3234 my @parents = grep { $_->{Commit} } @mergeinputs;
3235 @parents = reverse @parents if $compat_info->{ReverseParents};
3236 print MC <<END or die $! foreach @parents;
3240 print MC <<END or die $!;
3246 if (defined $compat_info->{Message}) {
3247 print MC $compat_info->{Message} or die $!;
3249 print MC <<END or die $!;
3250 Record $package ($cversion) in archive suite $csuite
3254 my $message_add_info = sub {
3256 my $mversion = mergeinfo_version $mi;
3257 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3261 $message_add_info->($mergeinputs[0]);
3262 print MC <<END or die $!;
3263 should be treated as descended from
3265 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3269 $hash = make_commit $mcf;
3271 $hash = $mergeinputs[0]{Commit};
3273 printdebug "fetch hash=$hash\n";
3276 my ($lasth, $what) = @_;
3277 return unless $lasth;
3278 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3281 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3283 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3285 fetch_from_archive_record_1($hash);
3287 if (defined $skew_warning_vsn) {
3288 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3289 my $gotclogp = commit_getclogp($hash);
3290 my $got_vsn = getfield $gotclogp, 'Version';
3291 printdebug "SKEW CHECK GOT $got_vsn\n";
3292 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3293 print STDERR <<END or die $!;
3295 Warning: archive skew detected. Using the available version:
3296 Archive allegedly contains $skew_warning_vsn
3297 We were able to obtain only $got_vsn
3303 if ($lastfetch_hash ne $hash) {
3304 fetch_from_archive_record_2($hash);
3307 lrfetchref_used lrfetchref();
3309 check_gitattrs($hash, "fetched source tree");
3311 unshift @end, $del_lrfetchrefs;
3315 sub set_local_git_config ($$) {
3317 runcmd @git, qw(config), $k, $v;
3320 sub setup_mergechangelogs (;$) {
3322 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3324 my $driver = 'dpkg-mergechangelogs';
3325 my $cb = "merge.$driver";
3326 confess unless defined $maindir;
3327 my $attrs = "$maindir_gitcommon/info/attributes";
3328 ensuredir "$maindir_gitcommon/info";
3330 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3331 if (!open ATTRS, "<", $attrs) {
3332 $!==ENOENT or die "$attrs: $!";
3336 next if m{^debian/changelog\s};
3337 print NATTRS $_, "\n" or die $!;
3339 ATTRS->error and die $!;
3342 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3345 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3346 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3348 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3351 sub setup_useremail (;$) {
3353 return unless $always || access_cfg_bool(1, 'setup-useremail');
3356 my ($k, $envvar) = @_;
3357 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3358 return unless defined $v;
3359 set_local_git_config "user.$k", $v;
3362 $setup->('email', 'DEBEMAIL');
3363 $setup->('name', 'DEBFULLNAME');
3366 sub ensure_setup_existing_tree () {
3367 my $k = "remote.$remotename.skipdefaultupdate";
3368 my $c = git_get_config $k;
3369 return if defined $c;
3370 set_local_git_config $k, 'true';
3373 sub open_main_gitattrs () {
3374 confess 'internal error no maindir' unless defined $maindir;
3375 my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3377 or die "open $maindir_gitcommon/info/attributes: $!";
3381 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3383 sub is_gitattrs_setup () {
3386 # 1: gitattributes set up and should be left alone
3388 # 0: there is a dgit-defuse-attrs but it needs fixing
3389 # undef: there is none
3390 my $gai = open_main_gitattrs();
3391 return 0 unless $gai;
3393 next unless m{$gitattrs_ourmacro_re};
3394 return 1 if m{\s-working-tree-encoding\s};
3395 printdebug "is_gitattrs_setup: found old macro\n";
3398 $gai->error and die $!;
3399 printdebug "is_gitattrs_setup: found nothing\n";
3403 sub setup_gitattrs (;$) {
3405 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3407 my $already = is_gitattrs_setup();
3410 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3411 not doing further gitattributes setup
3415 my $new = "[attr]dgit-defuse-attrs $negate_harmful_gitattrs";
3416 my $af = "$maindir_gitcommon/info/attributes";
3417 ensuredir "$maindir_gitcommon/info";
3419 open GAO, "> $af.new" or die $!;
3420 print GAO <<END or die $! unless defined $already;
3423 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3425 my $gai = open_main_gitattrs();
3428 if (m{$gitattrs_ourmacro_re}) {
3429 die unless defined $already;
3433 print GAO $_, "\n" or die $!;
3435 $gai->error and die $!;
3437 close GAO or die $!;
3438 rename "$af.new", "$af" or die "install $af: $!";
3441 sub setup_new_tree () {
3442 setup_mergechangelogs();
3447 sub check_gitattrs ($$) {
3448 my ($treeish, $what) = @_;
3450 return if is_gitattrs_setup;
3453 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3455 my $gafl = new IO::File;
3456 open $gafl, "-|", @cmd or die $!;
3459 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3461 next unless m{(?:^|/)\.gitattributes$};
3463 # oh dear, found one
3465 dgit: warning: $what contains .gitattributes
3466 dgit: .gitattributes not (fully) defused. Recommended: dgit setup-new-tree.
3471 # tree contains no .gitattributes files
3472 $?=0; $!=0; close $gafl or failedcmd @cmd;
3476 sub multisuite_suite_child ($$$) {
3477 my ($tsuite, $merginputs, $fn) = @_;
3478 # in child, sets things up, calls $fn->(), and returns undef
3479 # in parent, returns canonical suite name for $tsuite
3480 my $canonsuitefh = IO::File::new_tmpfile;
3481 my $pid = fork // die $!;
3485 $us .= " [$isuite]";
3486 $debugprefix .= " ";
3487 progress "fetching $tsuite...";
3488 canonicalise_suite();
3489 print $canonsuitefh $csuite, "\n" or die $!;
3490 close $canonsuitefh or die $!;
3494 waitpid $pid,0 == $pid or die $!;
3495 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3496 seek $canonsuitefh,0,0 or die $!;
3497 local $csuite = <$canonsuitefh>;
3498 die $! unless defined $csuite && chomp $csuite;
3500 printdebug "multisuite $tsuite missing\n";
3503 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3504 push @$merginputs, {
3511 sub fork_for_multisuite ($) {
3512 my ($before_fetch_merge) = @_;
3513 # if nothing unusual, just returns ''
3516 # returns 0 to caller in child, to do first of the specified suites
3517 # in child, $csuite is not yet set
3519 # returns 1 to caller in parent, to finish up anything needed after
3520 # in parent, $csuite is set to canonicalised portmanteau
3522 my $org_isuite = $isuite;
3523 my @suites = split /\,/, $isuite;
3524 return '' unless @suites > 1;
3525 printdebug "fork_for_multisuite: @suites\n";
3529 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3531 return 0 unless defined $cbasesuite;
3533 fail "package $package missing in (base suite) $cbasesuite"
3534 unless @mergeinputs;
3536 my @csuites = ($cbasesuite);
3538 $before_fetch_merge->();
3540 foreach my $tsuite (@suites[1..$#suites]) {
3541 $tsuite =~ s/^-/$cbasesuite-/;
3542 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3548 # xxx collecte the ref here
3550 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3551 push @csuites, $csubsuite;
3554 foreach my $mi (@mergeinputs) {
3555 my $ref = git_get_ref $mi->{Ref};
3556 die "$mi->{Ref} ?" unless length $ref;
3557 $mi->{Commit} = $ref;
3560 $csuite = join ",", @csuites;
3562 my $previous = git_get_ref lrref;
3564 unshift @mergeinputs, {
3565 Commit => $previous,
3566 Info => "local combined tracking branch",
3568 "archive seems to have rewound: local tracking branch is ahead!",
3572 foreach my $ix (0..$#mergeinputs) {
3573 $mergeinputs[$ix]{Index} = $ix;
3576 @mergeinputs = sort {
3577 -version_compare(mergeinfo_version $a,
3578 mergeinfo_version $b) # highest version first
3580 $a->{Index} <=> $b->{Index}; # earliest in spec first
3586 foreach my $mi (@mergeinputs) {
3587 printdebug "multisuite merge check $mi->{Info}\n";
3588 foreach my $previous (@needed) {
3589 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3590 printdebug "multisuite merge un-needed $previous->{Info}\n";
3594 printdebug "multisuite merge this-needed\n";
3595 $mi->{Character} = '+';
3598 $needed[0]{Character} = '*';
3600 my $output = $needed[0]{Commit};
3603 printdebug "multisuite merge nontrivial\n";
3604 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3606 my $commit = "tree $tree\n";
3607 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3608 "Input branches:\n";
3610 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3611 printdebug "multisuite merge include $mi->{Info}\n";
3612 $mi->{Character} //= ' ';
3613 $commit .= "parent $mi->{Commit}\n";
3614 $msg .= sprintf " %s %-25s %s\n",
3616 (mergeinfo_version $mi),
3619 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3621 " * marks the highest version branch, which choose to use\n".
3622 " + marks each branch which was not already an ancestor\n\n".
3623 "[dgit multi-suite $csuite]\n";
3625 "author $authline\n".
3626 "committer $authline\n\n";
3627 $output = make_commit_text $commit.$msg;
3628 printdebug "multisuite merge generated $output\n";
3631 fetch_from_archive_record_1($output);
3632 fetch_from_archive_record_2($output);
3634 progress "calculated combined tracking suite $csuite";
3639 sub clone_set_head () {
3640 open H, "> .git/HEAD" or die $!;
3641 print H "ref: ".lref()."\n" or die $!;
3644 sub clone_finish ($) {
3646 runcmd @git, qw(reset --hard), lrref();
3647 runcmd qw(bash -ec), <<'END';
3649 git ls-tree -r --name-only -z HEAD | \
3650 xargs -0r touch -h -r . --
3652 printdone "ready for work in $dstdir";
3656 # in multisuite, returns twice!
3657 # once in parent after first suite fetched,
3658 # and then again in child after everything is finished
3660 badusage "dry run makes no sense with clone" unless act_local();
3662 my $multi_fetched = fork_for_multisuite(sub {
3663 printdebug "multi clone before fetch merge\n";
3667 if ($multi_fetched) {
3668 printdebug "multi clone after fetch merge\n";
3670 clone_finish($dstdir);
3673 printdebug "clone main body\n";
3675 canonicalise_suite();
3676 my $hasgit = check_for_git();
3677 mkdir $dstdir or fail "create \`$dstdir': $!";
3679 runcmd @git, qw(init -q);
3683 my $giturl = access_giturl(1);
3684 if (defined $giturl) {
3685 runcmd @git, qw(remote add), 'origin', $giturl;
3688 progress "fetching existing git history";
3690 runcmd_ordryrun_local @git, qw(fetch origin);
3692 progress "starting new git history";
3694 fetch_from_archive() or no_such_package;
3695 my $vcsgiturl = $dsc->{'Vcs-Git'};
3696 if (length $vcsgiturl) {
3697 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3698 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3700 clone_finish($dstdir);
3704 canonicalise_suite();
3705 if (check_for_git()) {
3708 fetch_from_archive() or no_such_package();
3710 my $vcsgiturl = $dsc && $dsc->{'Vcs-Git'};
3711 if (length $vcsgiturl and
3712 (grep { $csuite eq $_ }
3714 cfg 'dgit.vcs-git.suites')) {
3715 my $current = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
3716 if (defined $current && $current ne $vcsgiturl) {
3718 FYI: Vcs-Git in $csuite has different url to your vcs-git remote.
3719 Your vcs-git remote url may be out of date. Use dgit update-vcs-git ?
3723 printdone "fetched into ".lrref();
3727 my $multi_fetched = fork_for_multisuite(sub { });
3728 fetch_one() unless $multi_fetched; # parent
3729 finish 0 if $multi_fetched eq '0'; # child
3734 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3736 printdone "fetched to ".lrref()." and merged into HEAD";
3739 sub check_not_dirty () {
3740 foreach my $f (qw(local-options local-patch-header)) {
3741 if (stat_exists "debian/source/$f") {
3742 fail "git tree contains debian/source/$f";
3746 return if $includedirty;
3748 git_check_unmodified();
3751 sub commit_admin ($) {
3754 runcmd_ordryrun_local @git, qw(commit -m), $m;
3757 sub quiltify_nofix_bail ($$) {
3758 my ($headinfo, $xinfo) = @_;
3759 if ($quilt_mode eq 'nofix') {
3760 fail "quilt fixup required but quilt mode is \`nofix'\n".
3761 "HEAD commit".$headinfo." differs from tree implied by ".
3762 " debian/patches".$xinfo;
3766 sub commit_quilty_patch () {
3767 my $output = cmdoutput @git, qw(status --ignored --porcelain);
3769 foreach my $l (split /\n/, $output) {
3770 next unless $l =~ m/\S/;
3771 if ($l =~ m{^(?:[?!][?!]| [MADRC]) (.pc|debian/patches)}) {
3775 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3777 progress "nothing quilty to commit, ok.";
3780 quiltify_nofix_bail "", " (wanted to commit patch update)";
3781 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3782 runcmd_ordryrun_local @git, qw(add -f), @adds;
3784 Commit Debian 3.0 (quilt) metadata
3786 [dgit ($our_version) quilt-fixup]
3790 sub get_source_format () {
3792 if (open F, "debian/source/options") {
3796 s/\s+$//; # ignore missing final newline
3798 my ($k, $v) = ($`, $'); #');
3799 $v =~ s/^"(.*)"$/$1/;
3805 F->error and die $!;
3808 die $! unless $!==&ENOENT;
3811 if (!open F, "debian/source/format") {
3812 die $! unless $!==&ENOENT;
3816 F->error and die $!;
3818 return ($_, \%options);
3821 sub madformat_wantfixup ($) {
3823 return 0 unless $format eq '3.0 (quilt)';
3824 our $quilt_mode_warned;
3825 if ($quilt_mode eq 'nocheck') {
3826 progress "Not doing any fixup of \`$format' due to".
3827 " ----no-quilt-fixup or --quilt=nocheck"
3828 unless $quilt_mode_warned++;
3831 progress "Format \`$format', need to check/update patch stack"
3832 unless $quilt_mode_warned++;
3836 sub maybe_split_brain_save ($$$) {
3837 my ($headref, $dgitview, $msg) = @_;
3838 # => message fragment "$saved" describing disposition of $dgitview
3839 return "commit id $dgitview" unless defined $split_brain_save;
3840 my @cmd = (shell_cmd 'cd "$1"; shift', $maindir,
3842 "dgit --dgit-view-save $msg HEAD=$headref",
3843 $split_brain_save, $dgitview);
3845 return "and left in $split_brain_save";
3848 # An "infopair" is a tuple [ $thing, $what ]
3849 # (often $thing is a commit hash; $what is a description)
3851 sub infopair_cond_equal ($$) {
3853 $x->[0] eq $y->[0] or fail <<END;
3854 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3858 sub infopair_lrf_tag_lookup ($$) {
3859 my ($tagnames, $what) = @_;
3860 # $tagname may be an array ref
3861 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3862 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3863 foreach my $tagname (@tagnames) {
3864 my $lrefname = lrfetchrefs."/tags/$tagname";
3865 my $tagobj = $lrfetchrefs_f{$lrefname};
3866 next unless defined $tagobj;
3867 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3868 return [ git_rev_parse($tagobj), $what ];
3870 fail @tagnames==1 ? <<END : <<END;
3871 Wanted tag $what (@tagnames) on dgit server, but not found
3873 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3877 sub infopair_cond_ff ($$) {
3878 my ($anc,$desc) = @_;
3879 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3880 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3884 sub pseudomerge_version_check ($$) {
3885 my ($clogp, $archive_hash) = @_;
3887 my $arch_clogp = commit_getclogp $archive_hash;
3888 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3889 'version currently in archive' ];
3890 if (defined $overwrite_version) {
3891 if (length $overwrite_version) {
3892 infopair_cond_equal([ $overwrite_version,
3893 '--overwrite= version' ],
3896 my $v = $i_arch_v->[0];
3897 progress "Checking package changelog for archive version $v ...";
3900 my @xa = ("-f$v", "-t$v");
3901 my $vclogp = parsechangelog @xa;
3904 [ (getfield $vclogp, $fn),
3905 "$fn field from dpkg-parsechangelog @xa" ];
3907 my $cv = $gf->('Version');
3908 infopair_cond_equal($i_arch_v, $cv);
3909 $cd = $gf->('Distribution');
3912 $@ =~ s/^dgit: //gm;
3914 "Perhaps debian/changelog does not mention $v ?";
3916 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3917 $cd->[1] is $cd->[0]
3918 Your tree seems to based on earlier (not uploaded) $v.
3923 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3927 sub pseudomerge_make_commit ($$$$ $$) {
3928 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3929 $msg_cmd, $msg_msg) = @_;
3930 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3932 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3933 my $authline = clogp_authline $clogp;
3937 !defined $overwrite_version ? ""
3938 : !length $overwrite_version ? " --overwrite"
3939 : " --overwrite=".$overwrite_version;
3941 # Contributing parent is the first parent - that makes
3942 # git rev-list --first-parent DTRT.
3943 my $pmf = dgit_privdir()."/pseudomerge";
3944 open MC, ">", $pmf or die "$pmf $!";
3945 print MC <<END or die $!;
3948 parent $archive_hash
3958 return make_commit($pmf);
3961 sub splitbrain_pseudomerge ($$$$) {
3962 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3963 # => $merged_dgitview
3964 printdebug "splitbrain_pseudomerge...\n";
3966 # We: debian/PREVIOUS HEAD($maintview)
3967 # expect: o ----------------- o
3970 # a/d/PREVIOUS $dgitview
3973 # we do: `------------------ o
3977 return $dgitview unless defined $archive_hash;
3978 return $dgitview if deliberately_not_fast_forward();
3980 printdebug "splitbrain_pseudomerge...\n";
3982 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3984 if (!defined $overwrite_version) {
3985 progress "Checking that HEAD inciudes all changes in archive...";
3988 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3990 if (defined $overwrite_version) {
3992 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3993 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3994 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3995 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3996 my $i_archive = [ $archive_hash, "current archive contents" ];
3998 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
4000 infopair_cond_equal($i_dgit, $i_archive);
4001 infopair_cond_ff($i_dep14, $i_dgit);
4002 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
4005 $@ =~ s/^\n//; chomp $@;
4008 | Not fast forward; maybe --overwrite is needed ? Please see dgit(1).
4013 my $r = pseudomerge_make_commit
4014 $clogp, $dgitview, $archive_hash, $i_arch_v,
4015 "dgit --quilt=$quilt_mode",
4016 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
4017 Declare fast forward from $i_arch_v->[0]
4019 Make fast forward from $i_arch_v->[0]
4022 maybe_split_brain_save $maintview, $r, "pseudomerge";
4024 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
4028 sub plain_overwrite_pseudomerge ($$$) {
4029 my ($clogp, $head, $archive_hash) = @_;
4031 printdebug "plain_overwrite_pseudomerge...";
4033 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
4035 return $head if is_fast_fwd $archive_hash, $head;
4037 my $m = "Declare fast forward from $i_arch_v->[0]";
4039 my $r = pseudomerge_make_commit
4040 $clogp, $head, $archive_hash, $i_arch_v,
4043 runcmd git_update_ref_cmd $m, 'HEAD', $r, $head;
4045 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
4049 sub push_parse_changelog ($) {
4052 my $clogp = Dpkg::Control::Hash->new();
4053 $clogp->load($clogpfn) or die;
4055 my $clogpackage = getfield $clogp, 'Source';
4056 $package //= $clogpackage;
4057 fail "-p specified $package but changelog specified $clogpackage"
4058 unless $package eq $clogpackage;
4059 my $cversion = getfield $clogp, 'Version';
4061 if (!$we_are_initiator) {
4062 # rpush initiator can't do this because it doesn't have $isuite yet
4063 my $tag = debiantag($cversion, access_nomdistro);
4064 runcmd @git, qw(check-ref-format), $tag;
4067 my $dscfn = dscfn($cversion);
4069 return ($clogp, $cversion, $dscfn);
4072 sub push_parse_dsc ($$$) {
4073 my ($dscfn,$dscfnwhat, $cversion) = @_;
4074 $dsc = parsecontrol($dscfn,$dscfnwhat);
4075 my $dversion = getfield $dsc, 'Version';
4076 my $dscpackage = getfield $dsc, 'Source';
4077 ($dscpackage eq $package && $dversion eq $cversion) or
4078 fail "$dscfn is for $dscpackage $dversion".
4079 " but debian/changelog is for $package $cversion";
4082 sub push_tagwants ($$$$) {
4083 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4086 TagFn => \&debiantag,
4091 if (defined $maintviewhead) {
4093 TagFn => \&debiantag_maintview,
4094 Objid => $maintviewhead,
4095 TfSuffix => '-maintview',
4098 } elsif ($dodep14tag eq 'no' ? 0
4099 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4100 : $dodep14tag eq 'always'
4101 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4102 --dep14tag-always (or equivalent in config) means server must support
4103 both "new" and "maint" tag formats, but config says it doesn't.
4105 : die "$dodep14tag ?") {
4107 TagFn => \&debiantag_maintview,
4109 TfSuffix => '-dgit',
4113 foreach my $tw (@tagwants) {
4114 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4115 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4117 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4121 sub push_mktags ($$ $$ $) {
4123 $changesfile,$changesfilewhat,
4126 die unless $tagwants->[0]{View} eq 'dgit';
4128 my $declaredistro = access_nomdistro();
4129 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4130 $dsc->{$ourdscfield[0]} = join " ",
4131 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4133 $dsc->save("$dscfn.tmp") or die $!;
4135 my $changes = parsecontrol($changesfile,$changesfilewhat);
4136 foreach my $field (qw(Source Distribution Version)) {
4137 $changes->{$field} eq $clogp->{$field} or
4138 fail "changes field $field \`$changes->{$field}'".
4139 " does not match changelog \`$clogp->{$field}'";
4142 my $cversion = getfield $clogp, 'Version';
4143 my $clogsuite = getfield $clogp, 'Distribution';
4145 # We make the git tag by hand because (a) that makes it easier
4146 # to control the "tagger" (b) we can do remote signing
4147 my $authline = clogp_authline $clogp;
4148 my $delibs = join(" ", "",@deliberatelies);
4152 my $tfn = $tw->{Tfn};
4153 my $head = $tw->{Objid};
4154 my $tag = $tw->{Tag};
4156 open TO, '>', $tfn->('.tmp') or die $!;
4157 print TO <<END or die $!;
4164 if ($tw->{View} eq 'dgit') {
4165 print TO <<END or die $!;
4166 $package release $cversion for $clogsuite ($csuite) [dgit]
4167 [dgit distro=$declaredistro$delibs]
4169 foreach my $ref (sort keys %previously) {
4170 print TO <<END or die $!;
4171 [dgit previously:$ref=$previously{$ref}]
4174 } elsif ($tw->{View} eq 'maint') {
4175 print TO <<END or die $!;
4176 $package release $cversion for $clogsuite ($csuite)
4177 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4180 die Dumper($tw)."?";
4185 my $tagobjfn = $tfn->('.tmp');
4187 if (!defined $keyid) {
4188 $keyid = access_cfg('keyid','RETURN-UNDEF');
4190 if (!defined $keyid) {
4191 $keyid = getfield $clogp, 'Maintainer';
4193 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4194 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4195 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4196 push @sign_cmd, $tfn->('.tmp');
4197 runcmd_ordryrun @sign_cmd;
4199 $tagobjfn = $tfn->('.signed.tmp');
4200 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4201 $tfn->('.tmp'), $tfn->('.tmp.asc');
4207 my @r = map { $mktag->($_); } @$tagwants;
4211 sub sign_changes ($) {
4212 my ($changesfile) = @_;
4214 my @debsign_cmd = @debsign;
4215 push @debsign_cmd, "-k$keyid" if defined $keyid;
4216 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4217 push @debsign_cmd, $changesfile;
4218 runcmd_ordryrun @debsign_cmd;
4223 printdebug "actually entering push\n";
4225 supplementary_message(<<'END');
4226 Push failed, while checking state of the archive.
4227 You can retry the push, after fixing the problem, if you like.
4229 if (check_for_git()) {
4232 my $archive_hash = fetch_from_archive();
4233 if (!$archive_hash) {
4235 fail "package appears to be new in this suite;".
4236 " if this is intentional, use --new";
4239 supplementary_message(<<'END');
4240 Push failed, while preparing your push.
4241 You can retry the push, after fixing the problem, if you like.
4244 need_tagformat 'new', "quilt mode $quilt_mode"
4245 if quiltmode_splitbrain;
4249 access_giturl(); # check that success is vaguely likely
4250 rpush_handle_protovsn_bothends() if $we_are_initiator;
4253 my $clogpfn = dgit_privdir()."/changelog.822.tmp";
4254 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4256 responder_send_file('parsed-changelog', $clogpfn);
4258 my ($clogp, $cversion, $dscfn) =
4259 push_parse_changelog("$clogpfn");
4261 my $dscpath = "$buildproductsdir/$dscfn";
4262 stat_exists $dscpath or
4263 fail "looked for .dsc $dscpath, but $!;".
4264 " maybe you forgot to build";
4266 responder_send_file('dsc', $dscpath);
4268 push_parse_dsc($dscpath, $dscfn, $cversion);
4270 my $format = getfield $dsc, 'Format';
4271 printdebug "format $format\n";
4273 my $symref = git_get_symref();
4274 my $actualhead = git_rev_parse('HEAD');
4276 if (branch_is_gdr_unstitched_ff($symref, $actualhead, $archive_hash)) {
4277 runcmd_ordryrun_local @git_debrebase, 'stitch';
4278 $actualhead = git_rev_parse('HEAD');
4281 my $dgithead = $actualhead;
4282 my $maintviewhead = undef;
4284 my $upstreamversion = upstreamversion $clogp->{Version};
4286 if (madformat_wantfixup($format)) {
4287 # user might have not used dgit build, so maybe do this now:
4288 if (quiltmode_splitbrain()) {
4289 changedir $playground;
4290 quilt_make_fake_dsc($upstreamversion);
4292 ($dgithead, $cachekey) =
4293 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4295 "--quilt=$quilt_mode but no cached dgit view:
4296 perhaps HEAD changed since dgit build[-source] ?";
4298 $dgithead = splitbrain_pseudomerge($clogp,
4299 $actualhead, $dgithead,
4301 $maintviewhead = $actualhead;
4303 prep_ud(); # so _only_subdir() works, below
4305 commit_quilty_patch();
4309 if (defined $overwrite_version && !defined $maintviewhead
4311 $dgithead = plain_overwrite_pseudomerge($clogp,
4319 if ($archive_hash) {
4320 if (is_fast_fwd($archive_hash, $dgithead)) {
4322 } elsif (deliberately_not_fast_forward) {
4325 fail "dgit push: HEAD is not a descendant".
4326 " of the archive's version.\n".
4327 "To overwrite the archive's contents,".
4328 " pass --overwrite[=VERSION].\n".
4329 "To rewind history, if permitted by the archive,".
4330 " use --deliberately-not-fast-forward.";
4334 changedir $playground;
4335 progress "checking that $dscfn corresponds to HEAD";
4336 runcmd qw(dpkg-source -x --),
4337 $dscpath =~ m#^/# ? $dscpath : "$maindir/$dscpath";
4338 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4339 check_for_vendor_patches() if madformat($dsc->{format});
4341 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4342 debugcmd "+",@diffcmd;
4344 my $r = system @diffcmd;
4347 my $referent = $split_brain ? $dgithead : 'HEAD';
4348 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4351 my $raw = cmdoutput @git,
4352 qw(diff --no-renames -z -r --raw), $tree, $dgithead;
4354 foreach (split /\0/, $raw) {
4355 if (defined $changed) {
4356 push @mode_changes, "$changed: $_\n" if $changed;
4359 } elsif (m/^:0+ 0+ /) {
4361 } elsif (m/^:(?:10*)?(\d+) (?:10*)?(\d+) /) {
4362 $changed = "Mode change from $1 to $2"
4367 if (@mode_changes) {
4368 fail <<END.(join '', @mode_changes).<<END;
4369 HEAD specifies a different tree to $dscfn:
4372 There is a problem with your source tree (see dgit(7) for some hints).
4373 To see a full diff, run git diff $tree $referent
4378 HEAD specifies a different tree to $dscfn:
4380 Perhaps you forgot to build. Or perhaps there is a problem with your
4381 source tree (see dgit(7) for some hints). To see a full diff, run
4382 git diff $tree $referent
4388 if (!$changesfile) {
4389 my $pat = changespat $cversion;
4390 my @cs = glob "$buildproductsdir/$pat";
4391 fail "failed to find unique changes file".
4392 " (looked for $pat in $buildproductsdir);".
4393 " perhaps you need to use dgit -C"
4395 ($changesfile) = @cs;
4397 $changesfile = "$buildproductsdir/$changesfile";
4400 # Check that changes and .dsc agree enough
4401 $changesfile =~ m{[^/]*$};
4402 my $changes = parsecontrol($changesfile,$&);
4403 files_compare_inputs($dsc, $changes)
4404 unless forceing [qw(dsc-changes-mismatch)];
4406 # Check whether this is a source only upload
4407 my $hasdebs = $changes->{Files} =~ m{\.deb$}m;
4408 my $sourceonlypolicy = access_cfg 'source-only-uploads';
4409 if ($sourceonlypolicy eq 'ok') {
4410 } elsif ($sourceonlypolicy eq 'always') {
4411 forceable_fail [qw(uploading-binaries)],
4412 "uploading binaries, although distroy policy is source only"
4414 } elsif ($sourceonlypolicy eq 'never') {
4415 forceable_fail [qw(uploading-source-only)],
4416 "source-only upload, although distroy policy requires .debs"
4418 } elsif ($sourceonlypolicy eq 'not-wholly-new') {
4419 forceable_fail [qw(uploading-source-only)],
4420 "source-only upload, even though package is entirely NEW\n".
4421 "(this is contrary to policy in ".(access_nomdistro()).")"
4424 && !(archive_query('package_not_wholly_new', $package) // 1);
4426 badcfg "unknown source-only-uploads policy \`$sourceonlypolicy'";
4429 # Perhaps adjust .dsc to contain right set of origs
4430 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4432 unless forceing [qw(changes-origs-exactly)];
4434 # Checks complete, we're going to try and go ahead:
4436 responder_send_file('changes',$changesfile);
4437 responder_send_command("param head $dgithead");
4438 responder_send_command("param csuite $csuite");
4439 responder_send_command("param isuite $isuite");
4440 responder_send_command("param tagformat $tagformat");
4441 if (defined $maintviewhead) {
4442 die unless ($protovsn//4) >= 4;
4443 responder_send_command("param maint-view $maintviewhead");
4446 # Perhaps send buildinfo(s) for signing
4447 my $changes_files = getfield $changes, 'Files';
4448 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4449 foreach my $bi (@buildinfos) {
4450 responder_send_command("param buildinfo-filename $bi");
4451 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4454 if (deliberately_not_fast_forward) {
4455 git_for_each_ref(lrfetchrefs, sub {
4456 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4457 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4458 responder_send_command("previously $rrefname=$objid");
4459 $previously{$rrefname} = $objid;
4463 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4464 dgit_privdir()."/tag");
4467 supplementary_message(<<'END');
4468 Push failed, while signing the tag.
4469 You can retry the push, after fixing the problem, if you like.
4471 # If we manage to sign but fail to record it anywhere, it's fine.
4472 if ($we_are_responder) {
4473 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4474 responder_receive_files('signed-tag', @tagobjfns);
4476 @tagobjfns = push_mktags($clogp,$dscpath,
4477 $changesfile,$changesfile,
4480 supplementary_message(<<'END');
4481 Push failed, *after* signing the tag.
4482 If you want to try again, you should use a new version number.
4485 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4487 foreach my $tw (@tagwants) {
4488 my $tag = $tw->{Tag};
4489 my $tagobjfn = $tw->{TagObjFn};
4491 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4492 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4493 runcmd_ordryrun_local
4494 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4497 supplementary_message(<<'END');
4498 Push failed, while updating the remote git repository - see messages above.
4499 If you want to try again, you should use a new version number.
4501 if (!check_for_git()) {
4502 create_remote_git_repo();
4505 my @pushrefs = $forceflag.$dgithead.":".rrref();
4506 foreach my $tw (@tagwants) {
4507 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4510 runcmd_ordryrun @git,
4511 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4512 runcmd_ordryrun git_update_ref_cmd 'dgit push', lrref(), $dgithead;
4514 supplementary_message(<<'END');
4515 Push failed, while obtaining signatures on the .changes and .dsc.
4516 If it was just that the signature failed, you may try again by using
4517 debsign by hand to sign the changes
4519 and then dput to complete the upload.
4520 If you need to change the package, you must use a new version number.
4522 if ($we_are_responder) {
4523 my $dryrunsuffix = act_local() ? "" : ".tmp";
4524 my @rfiles = ($dscpath, $changesfile);
4525 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4526 responder_receive_files('signed-dsc-changes',
4527 map { "$_$dryrunsuffix" } @rfiles);
4530 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4532 progress "[new .dsc left in $dscpath.tmp]";
4534 sign_changes $changesfile;
4537 supplementary_message(<<END);
4538 Push failed, while uploading package(s) to the archive server.
4539 You can retry the upload of exactly these same files with dput of:
4541 If that .changes file is broken, you will need to use a new version
4542 number for your next attempt at the upload.
4544 my $host = access_cfg('upload-host','RETURN-UNDEF');
4545 my @hostarg = defined($host) ? ($host,) : ();
4546 runcmd_ordryrun @dput, @hostarg, $changesfile;
4547 printdone "pushed and uploaded $cversion";
4549 supplementary_message('');
4550 responder_send_command("complete");
4554 not_necessarily_a_tree();
4559 badusage "-p is not allowed with clone; specify as argument instead"
4560 if defined $package;
4563 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4564 ($package,$isuite) = @ARGV;
4565 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4566 ($package,$dstdir) = @ARGV;
4567 } elsif (@ARGV==3) {
4568 ($package,$isuite,$dstdir) = @ARGV;
4570 badusage "incorrect arguments to dgit clone";
4574 $dstdir ||= "$package";
4575 if (stat_exists $dstdir) {
4576 fail "$dstdir already exists";
4580 if ($rmonerror && !$dryrun_level) {
4581 $cwd_remove= getcwd();
4583 return unless defined $cwd_remove;
4584 if (!chdir "$cwd_remove") {
4585 return if $!==&ENOENT;
4586 die "chdir $cwd_remove: $!";
4588 printdebug "clone rmonerror removing $dstdir\n";
4590 rmtree($dstdir) or die "remove $dstdir: $!\n";
4591 } elsif (grep { $! == $_ }
4592 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4594 print STDERR "check whether to remove $dstdir: $!\n";
4600 $cwd_remove = undef;
4603 sub branchsuite () {
4604 my $branch = git_get_symref();
4605 if (defined $branch && $branch =~ m#$lbranch_re#o) {
4612 sub package_from_d_control () {
4613 if (!defined $package) {
4614 my $sourcep = parsecontrol('debian/control','debian/control');
4615 $package = getfield $sourcep, 'Source';
4619 sub fetchpullargs () {
4620 package_from_d_control();
4622 $isuite = branchsuite();
4624 my $clogp = parsechangelog();
4625 my $clogsuite = getfield $clogp, 'Distribution';
4626 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4628 } elsif (@ARGV==1) {
4631 badusage "incorrect arguments to dgit fetch or dgit pull";
4645 if (quiltmode_splitbrain()) {
4646 my ($format, $fopts) = get_source_format();
4647 madformat($format) and fail <<END
4648 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4656 package_from_d_control();
4657 @ARGV==1 or badusage "dgit checkout needs a suite argument";
4661 foreach my $canon (qw(0 1)) {
4666 canonicalise_suite();
4668 if (length git_get_ref lref()) {
4669 # local branch already exists, yay
4672 if (!length git_get_ref lrref()) {
4680 runcmd (@git, qw(update-ref), lref(), lrref(), '');
4683 local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
4684 "dgit checkout $isuite";
4685 runcmd (@git, qw(checkout), lbranch());
4688 sub cmd_update_vcs_git () {
4690 if (@ARGV==0 || $ARGV[0] =~ m/^-/) {
4691 ($specsuite,) = split /\;/, cfg 'dgit.vcs-git.suites';
4693 ($specsuite) = (@ARGV);
4698 if ($ARGV[0] eq '-') {
4700 } elsif ($ARGV[0] eq '-') {
4705 package_from_d_control();
4707 if ($specsuite eq '.') {
4708 $ctrl = parsecontrol 'debian/control', 'debian/control';
4710 $isuite = $specsuite;
4714 my $url = getfield $ctrl, 'Vcs-Git';
4717 my $orgurl = cfg 'remote.vcs-git.url', 'RETURN-UNDEF';
4718 if (!defined $orgurl) {
4719 print STDERR "setting up vcs-git: $url\n";
4720 @cmd = (@git, qw(remote add vcs-git), $url);
4721 } elsif ($orgurl eq $url) {
4722 print STDERR "vcs git already configured: $url\n";
4724 print STDERR "changing vcs-git url to: $url\n";
4725 @cmd = (@git, qw(remote set-url vcs-git), $url);
4727 runcmd_ordryrun_local @cmd;
4729 print "fetching (@ARGV)\n";
4730 runcmd_ordryrun_local @git, qw(fetch vcs-git), @ARGV;
4736 build_or_push_prep_early();
4741 } elsif (@ARGV==1) {
4742 ($specsuite) = (@ARGV);
4744 badusage "incorrect arguments to dgit $subcommand";
4747 local ($package) = $existing_package; # this is a hack
4748 canonicalise_suite();
4750 canonicalise_suite();
4752 if (defined $specsuite &&
4753 $specsuite ne $isuite &&
4754 $specsuite ne $csuite) {
4755 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4756 " but command line specifies $specsuite";
4765 #---------- remote commands' implementation ----------
4767 sub pre_remote_push_build_host {
4768 my ($nrargs) = shift @ARGV;
4769 my (@rargs) = @ARGV[0..$nrargs-1];
4770 @ARGV = @ARGV[$nrargs..$#ARGV];
4772 my ($dir,$vsnwant) = @rargs;
4773 # vsnwant is a comma-separated list; we report which we have
4774 # chosen in our ready response (so other end can tell if they
4777 $we_are_responder = 1;
4778 $us .= " (build host)";
4780 open PI, "<&STDIN" or die $!;
4781 open STDIN, "/dev/null" or die $!;
4782 open PO, ">&STDOUT" or die $!;
4784 open STDOUT, ">&STDERR" or die $!;
4788 ($protovsn) = grep {
4789 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4790 } @rpushprotovsn_support;
4792 fail "build host has dgit rpush protocol versions ".
4793 (join ",", @rpushprotovsn_support).
4794 " but invocation host has $vsnwant"
4795 unless defined $protovsn;
4799 sub cmd_remote_push_build_host {
4800 responder_send_command("dgit-remote-push-ready $protovsn");
4804 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4805 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4806 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4807 # a good error message)
4809 sub rpush_handle_protovsn_bothends () {
4810 if ($protovsn < 4) {
4811 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4820 my $report = i_child_report();
4821 if (defined $report) {
4822 printdebug "($report)\n";
4823 } elsif ($i_child_pid) {
4824 printdebug "(killing build host child $i_child_pid)\n";
4825 kill 15, $i_child_pid;
4827 if (defined $i_tmp && !defined $initiator_tempdir) {
4829 eval { rmtree $i_tmp; };
4834 return unless forkcheck_mainprocess();
4839 my ($base,$selector,@args) = @_;
4840 $selector =~ s/\-/_/g;
4841 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4845 not_necessarily_a_tree();
4850 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4858 push @rargs, join ",", @rpushprotovsn_support;
4861 push @rdgit, @ropts;
4862 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4864 my @cmd = (@ssh, $host, shellquote @rdgit);
4867 $we_are_initiator=1;
4869 if (defined $initiator_tempdir) {
4870 rmtree $initiator_tempdir;
4871 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4872 $i_tmp = $initiator_tempdir;
4876 $i_child_pid = open2(\*RO, \*RI, @cmd);
4878 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4879 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4880 $supplementary_message = '' unless $protovsn >= 3;
4883 my ($icmd,$iargs) = initiator_expect {
4884 m/^(\S+)(?: (.*))?$/;
4887 i_method "i_resp", $icmd, $iargs;
4891 sub i_resp_progress ($) {
4893 my $msg = protocol_read_bytes \*RO, $rhs;
4897 sub i_resp_supplementary_message ($) {
4899 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4902 sub i_resp_complete {
4903 my $pid = $i_child_pid;
4904 $i_child_pid = undef; # prevents killing some other process with same pid
4905 printdebug "waiting for build host child $pid...\n";
4906 my $got = waitpid $pid, 0;
4907 die $! unless $got == $pid;
4908 die "build host child failed $?" if $?;
4911 printdebug "all done\n";
4915 sub i_resp_file ($) {
4917 my $localname = i_method "i_localname", $keyword;
4918 my $localpath = "$i_tmp/$localname";
4919 stat_exists $localpath and
4920 badproto \*RO, "file $keyword ($localpath) twice";
4921 protocol_receive_file \*RO, $localpath;
4922 i_method "i_file", $keyword;
4927 sub i_resp_param ($) {
4928 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4932 sub i_resp_previously ($) {
4933 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4934 or badproto \*RO, "bad previously spec";
4935 my $r = system qw(git check-ref-format), $1;
4936 die "bad previously ref spec ($r)" if $r;
4937 $previously{$1} = $2;
4942 sub i_resp_want ($) {
4944 die "$keyword ?" if $i_wanted{$keyword}++;
4946 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4947 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4948 die unless $isuite =~ m/^$suite_re$/;
4951 rpush_handle_protovsn_bothends();
4953 fail "rpush negotiated protocol version $protovsn".
4954 " which does not support quilt mode $quilt_mode"
4955 if quiltmode_splitbrain;
4957 my @localpaths = i_method "i_want", $keyword;
4958 printdebug "[[ $keyword @localpaths\n";
4959 foreach my $localpath (@localpaths) {
4960 protocol_send_file \*RI, $localpath;
4962 print RI "files-end\n" or die $!;
4965 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4967 sub i_localname_parsed_changelog {
4968 return "remote-changelog.822";
4970 sub i_file_parsed_changelog {
4971 ($i_clogp, $i_version, $i_dscfn) =
4972 push_parse_changelog "$i_tmp/remote-changelog.822";
4973 die if $i_dscfn =~ m#/|^\W#;
4976 sub i_localname_dsc {
4977 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4982 sub i_localname_buildinfo ($) {
4983 my $bi = $i_param{'buildinfo-filename'};
4984 defined $bi or badproto \*RO, "buildinfo before filename";
4985 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4986 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4987 or badproto \*RO, "improper buildinfo filename";
4990 sub i_file_buildinfo {
4991 my $bi = $i_param{'buildinfo-filename'};
4992 my $bd = parsecontrol "$i_tmp/$bi", $bi;
4993 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4994 if (!forceing [qw(buildinfo-changes-mismatch)]) {
4995 files_compare_inputs($bd, $ch);
4996 (getfield $bd, $_) eq (getfield $ch, $_) or
4997 fail "buildinfo mismatch $_"
4998 foreach qw(Source Version);
4999 !defined $bd->{$_} or
5000 fail "buildinfo contains $_"
5001 foreach qw(Changes Changed-by Distribution);
5003 push @i_buildinfos, $bi;
5004 delete $i_param{'buildinfo-filename'};
5007 sub i_localname_changes {
5008 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
5009 $i_changesfn = $i_dscfn;
5010 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
5011 return $i_changesfn;
5013 sub i_file_changes { }
5015 sub i_want_signed_tag {
5016 printdebug Dumper(\%i_param, $i_dscfn);
5017 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
5018 && defined $i_param{'csuite'}
5019 or badproto \*RO, "premature desire for signed-tag";
5020 my $head = $i_param{'head'};
5021 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
5023 my $maintview = $i_param{'maint-view'};
5024 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
5027 if ($protovsn >= 4) {
5028 my $p = $i_param{'tagformat'} // '<undef>';
5030 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
5033 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
5035 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
5037 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
5040 push_mktags $i_clogp, $i_dscfn,
5041 $i_changesfn, 'remote changes',
5045 sub i_want_signed_dsc_changes {
5046 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
5047 sign_changes $i_changesfn;
5048 return ($i_dscfn, $i_changesfn, @i_buildinfos);
5051 #---------- building etc. ----------
5057 #----- `3.0 (quilt)' handling -----
5059 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
5061 sub quiltify_dpkg_commit ($$$;$) {
5062 my ($patchname,$author,$msg, $xinfo) = @_;
5065 mkpath '.git/dgit'; # we are in playtree
5066 my $descfn = ".git/dgit/quilt-description.tmp";
5067 open O, '>', $descfn or die "$descfn: $!";
5068 $msg =~ s/\n+/\n\n/;
5069 print O <<END or die $!;
5071 ${xinfo}Subject: $msg
5078 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
5079 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
5080 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
5081 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
5085 sub quiltify_trees_differ ($$;$$$) {
5086 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
5087 # returns true iff the two tree objects differ other than in debian/
5088 # with $finegrained,
5089 # returns bitmask 01 - differ in upstream files except .gitignore
5090 # 02 - differ in .gitignore
5091 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
5092 # is set for each modified .gitignore filename $fn
5093 # if $unrepres is defined, array ref to which is appeneded
5094 # a list of unrepresentable changes (removals of upstream files
5097 my @cmd = (@git, qw(diff-tree -z --no-renames));
5098 push @cmd, qw(--name-only) unless $unrepres;
5099 push @cmd, qw(-r) if $finegrained || $unrepres;
5101 my $diffs= cmdoutput @cmd;
5104 foreach my $f (split /\0/, $diffs) {
5105 if ($unrepres && !@lmodes) {
5106 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
5109 my ($oldmode,$newmode) = @lmodes;
5112 next if $f =~ m#^debian(?:/.*)?$#s;
5116 die "not a plain file or symlink\n"
5117 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
5118 $oldmode =~ m/^(?:10|12)\d{4}$/;
5119 if ($oldmode =~ m/[^0]/ &&
5120 $newmode =~ m/[^0]/) {
5121 # both old and new files exist
5122 die "mode or type changed\n" if $oldmode ne $newmode;
5123 die "modified symlink\n" unless $newmode =~ m/^10/;
5124 } elsif ($oldmode =~ m/[^0]/) {
5126 die "deletion of symlink\n"
5127 unless $oldmode =~ m/^10/;
5130 die "creation with non-default mode\n"
5131 unless $newmode =~ m/^100644$/ or
5132 $newmode =~ m/^120000$/;
5136 local $/="\n"; chomp $@;
5137 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
5141 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
5142 $r |= $isignore ? 02 : 01;
5143 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
5145 printdebug "quiltify_trees_differ $x $y => $r\n";
5149 sub quiltify_tree_sentinelfiles ($) {
5150 # lists the `sentinel' files present in the tree
5152 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
5153 qw(-- debian/rules debian/control);
5158 sub quiltify_splitbrain_needed () {
5159 if (!$split_brain) {
5160 progress "dgit view: changes are required...";
5161 runcmd @git, qw(checkout -q -b dgit-view);
5166 sub quiltify_splitbrain ($$$$$$$) {
5167 my ($clogp, $unapplied, $headref, $oldtiptree, $diffbits,
5168 $editedignores, $cachekey) = @_;
5169 my $gitignore_special = 1;
5170 if ($quilt_mode !~ m/gbp|dpm/) {
5171 # treat .gitignore just like any other upstream file
5172 $diffbits = { %$diffbits };
5173 $_ = !!$_ foreach values %$diffbits;
5174 $gitignore_special = 0;
5176 # We would like any commits we generate to be reproducible
5177 my @authline = clogp_authline($clogp);
5178 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
5179 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
5180 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
5181 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
5182 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
5183 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
5185 my $fulldiffhint = sub {
5187 my $cmd = "git diff $x $y -- :/ ':!debian'";
5188 $cmd .= " ':!/.gitignore' ':!*/.gitignore'" if $gitignore_special;
5189 return "\nFor full diff showing the problem(s), type:\n $cmd\n";
5192 if ($quilt_mode =~ m/gbp|unapplied/ &&
5193 ($diffbits->{O2H} & 01)) {
5195 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
5196 " but git tree differs from orig in upstream files.";
5197 $msg .= $fulldiffhint->($unapplied, 'HEAD');
5198 if (!stat_exists "debian/patches") {
5200 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
5204 if ($quilt_mode =~ m/dpm/ &&
5205 ($diffbits->{H2A} & 01)) {
5206 fail <<END. $fulldiffhint->($oldtiptree,'HEAD');
5207 --quilt=$quilt_mode specified, implying patches-applied git tree
5208 but git tree differs from result of applying debian/patches to upstream
5211 if ($quilt_mode =~ m/gbp|unapplied/ &&
5212 ($diffbits->{O2A} & 01)) { # some patches
5213 quiltify_splitbrain_needed();
5214 progress "dgit view: creating patches-applied version using gbp pq";
5215 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
5216 # gbp pq import creates a fresh branch; push back to dgit-view
5217 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
5218 runcmd @git, qw(checkout -q dgit-view);
5220 if ($quilt_mode =~ m/gbp|dpm/ &&
5221 ($diffbits->{O2A} & 02)) {
5223 --quilt=$quilt_mode specified, implying that HEAD is for use with a
5224 tool which does not create patches for changes to upstream
5225 .gitignores: but, such patches exist in debian/patches.
5228 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
5229 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
5230 quiltify_splitbrain_needed();
5231 progress "dgit view: creating patch to represent .gitignore changes";
5232 ensuredir "debian/patches";
5233 my $gipatch = "debian/patches/auto-gitignore";
5234 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
5235 stat GIPATCH or die "$gipatch: $!";
5236 fail "$gipatch already exists; but want to create it".
5237 " to record .gitignore changes" if (stat _)[7];
5238 print GIPATCH <<END or die "$gipatch: $!";
5239 Subject: Update .gitignore from Debian packaging branch
5241 The Debian packaging git branch contains these updates to the upstream
5242 .gitignore file(s). This patch is autogenerated, to provide these
5243 updates to users of the official Debian archive view of the package.
5245 [dgit ($our_version) update-gitignore]
5248 close GIPATCH or die "$gipatch: $!";
5249 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5250 $unapplied, $headref, "--", sort keys %$editedignores;
5251 open SERIES, "+>>", "debian/patches/series" or die $!;
5252 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5254 defined read SERIES, $newline, 1 or die $!;
5255 print SERIES "\n" or die $! unless $newline eq "\n";
5256 print SERIES "auto-gitignore\n" or die $!;
5257 close SERIES or die $!;
5258 runcmd @git, qw(add -f -- debian/patches/series), $gipatch;
5260 Commit patch to update .gitignore
5262 [dgit ($our_version) update-gitignore-quilt-fixup]
5266 my $dgitview = git_rev_parse 'HEAD';
5269 # When we no longer need to support squeeze, use --create-reflog
5271 ensuredir "$maindir_gitcommon/logs/refs/dgit-intern";
5272 my $makelogfh = new IO::File "$maindir_gitcommon/logs/refs/$splitbraincache", '>>'
5275 my $oldcache = git_get_ref "refs/$splitbraincache";
5276 if ($oldcache eq $dgitview) {
5277 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5278 # git update-ref doesn't always update, in this case. *sigh*
5279 my $dummy = make_commit_text <<END;
5282 author Dgit <dgit\@example.com> 1000000000 +0000
5283 committer Dgit <dgit\@example.com> 1000000000 +0000
5285 Dummy commit - do not use
5287 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5288 "refs/$splitbraincache", $dummy;
5290 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5293 changedir "$playground/work";
5295 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5296 progress "dgit view: created ($saved)";
5299 sub quiltify ($$$$) {
5300 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5302 # Quilt patchification algorithm
5304 # We search backwards through the history of the main tree's HEAD
5305 # (T) looking for a start commit S whose tree object is identical
5306 # to to the patch tip tree (ie the tree corresponding to the
5307 # current dpkg-committed patch series). For these purposes
5308 # `identical' disregards anything in debian/ - this wrinkle is
5309 # necessary because dpkg-source treates debian/ specially.
5311 # We can only traverse edges where at most one of the ancestors'
5312 # trees differs (in changes outside in debian/). And we cannot
5313 # handle edges which change .pc/ or debian/patches. To avoid
5314 # going down a rathole we avoid traversing edges which introduce
5315 # debian/rules or debian/control. And we set a limit on the
5316 # number of edges we are willing to look at.
5318 # If we succeed, we walk forwards again. For each traversed edge
5319 # PC (with P parent, C child) (starting with P=S and ending with
5320 # C=T) to we do this:
5322 # - dpkg-source --commit with a patch name and message derived from C
5323 # After traversing PT, we git commit the changes which
5324 # should be contained within debian/patches.
5326 # The search for the path S..T is breadth-first. We maintain a
5327 # todo list containing search nodes. A search node identifies a
5328 # commit, and looks something like this:
5330 # Commit => $git_commit_id,
5331 # Child => $c, # or undef if P=T
5332 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5333 # Nontrivial => true iff $p..$c has relevant changes
5340 my %considered; # saves being exponential on some weird graphs
5342 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5345 my ($search,$whynot) = @_;
5346 printdebug " search NOT $search->{Commit} $whynot\n";
5347 $search->{Whynot} = $whynot;
5348 push @nots, $search;
5349 no warnings qw(exiting);
5358 my $c = shift @todo;
5359 next if $considered{$c->{Commit}}++;
5361 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5363 printdebug "quiltify investigate $c->{Commit}\n";
5366 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5367 printdebug " search finished hooray!\n";
5372 quiltify_nofix_bail " $c->{Commit}", " (tree object $oldtiptree)";
5373 if ($quilt_mode eq 'smash') {
5374 printdebug " search quitting smash\n";
5378 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5379 $not->($c, "has $c_sentinels not $t_sentinels")
5380 if $c_sentinels ne $t_sentinels;
5382 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5383 $commitdata =~ m/\n\n/;
5385 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5386 @parents = map { { Commit => $_, Child => $c } } @parents;
5388 $not->($c, "root commit") if !@parents;
5390 foreach my $p (@parents) {
5391 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5393 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5394 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5396 foreach my $p (@parents) {
5397 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5399 my @cmd= (@git, qw(diff-tree -r --name-only),
5400 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5401 my $patchstackchange = cmdoutput @cmd;
5402 if (length $patchstackchange) {
5403 $patchstackchange =~ s/\n/,/g;
5404 $not->($p, "changed $patchstackchange");
5407 printdebug " search queue P=$p->{Commit} ",
5408 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5414 printdebug "quiltify want to smash\n";
5417 my $x = $_[0]{Commit};
5418 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5421 my $reportnot = sub {
5423 my $s = $abbrev->($notp);
5424 my $c = $notp->{Child};
5425 $s .= "..".$abbrev->($c) if $c;
5426 $s .= ": ".$notp->{Whynot};
5429 if ($quilt_mode eq 'linear') {
5430 print STDERR "\n$us: error: quilt fixup cannot be linear. Stopped at:\n";
5431 foreach my $notp (@nots) {
5432 print STDERR "$us: ", $reportnot->($notp), "\n";
5434 print STDERR "$us: $_\n" foreach @$failsuggestion;
5436 "quilt history linearisation failed. Search \`quilt fixup' in dgit(7).\n".
5437 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5438 } elsif ($quilt_mode eq 'smash') {
5439 } elsif ($quilt_mode eq 'auto') {
5440 progress "quilt fixup cannot be linear, smashing...";
5442 die "$quilt_mode ?";
5445 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5446 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5448 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5450 quiltify_dpkg_commit "auto-$version-$target-$time",
5451 (getfield $clogp, 'Maintainer'),
5452 "Automatically generated patch ($clogp->{Version})\n".
5453 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5457 progress "quiltify linearisation planning successful, executing...";
5459 for (my $p = $sref_S;
5460 my $c = $p->{Child};
5462 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5463 next unless $p->{Nontrivial};
5465 my $cc = $c->{Commit};
5467 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5468 $commitdata =~ m/\n\n/ or die "$c ?";
5471 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5474 my $commitdate = cmdoutput
5475 @git, qw(log -n1 --pretty=format:%aD), $cc;
5477 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5479 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5486 my $gbp_check_suitable = sub {
5491 die "contains unexpected slashes\n" if m{//} || m{/$};
5492 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5493 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5494 die "is series file\n" if m{$series_filename_re}o;
5495 die "too long" if length > 200;
5497 return $_ unless $@;
5498 print STDERR "quiltifying commit $cc:".
5499 " ignoring/dropping Gbp-Pq $what: $@";
5503 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5505 (\S+) \s* \n //ixm) {
5506 $patchname = $gbp_check_suitable->($1, 'Name');
5508 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5510 (\S+) \s* \n //ixm) {
5511 $patchdir = $gbp_check_suitable->($1, 'Topic');
5516 if (!defined $patchname) {
5517 $patchname = $title;
5518 $patchname =~ s/[.:]$//;
5521 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5522 my $translitname = $converter->convert($patchname);
5523 die unless defined $translitname;
5524 $patchname = $translitname;
5527 "dgit: patch title transliteration error: $@"
5529 $patchname =~ y/ A-Z/-a-z/;
5530 $patchname =~ y/-a-z0-9_.+=~//cd;
5531 $patchname =~ s/^\W/x-$&/;
5532 $patchname = substr($patchname,0,40);
5533 $patchname .= ".patch";
5535 if (!defined $patchdir) {
5538 if (length $patchdir) {
5539 $patchname = "$patchdir/$patchname";
5541 if ($patchname =~ m{^(.*)/}) {
5542 mkpath "debian/patches/$1";
5547 stat "debian/patches/$patchname$index";
5549 $!==ENOENT or die "$patchname$index $!";
5551 runcmd @git, qw(checkout -q), $cc;
5553 # We use the tip's changelog so that dpkg-source doesn't
5554 # produce complaining messages from dpkg-parsechangelog. None
5555 # of the information dpkg-source gets from the changelog is
5556 # actually relevant - it gets put into the original message
5557 # which dpkg-source provides our stunt editor, and then
5559 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5561 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5562 "Date: $commitdate\n".
5563 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5565 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5568 runcmd @git, qw(checkout -q master);
5571 sub build_maybe_quilt_fixup () {
5572 my ($format,$fopts) = get_source_format;
5573 return unless madformat_wantfixup $format;
5576 check_for_vendor_patches();
5578 if (quiltmode_splitbrain) {
5579 fail <<END unless access_cfg_tagformats_can_splitbrain;
5580 quilt mode $quilt_mode requires split view so server needs to support
5581 both "new" and "maint" tag formats, but config says it doesn't.
5585 my $clogp = parsechangelog();
5586 my $headref = git_rev_parse('HEAD');
5587 my $symref = git_get_symref();
5589 if ($quilt_mode eq 'linear'
5590 && !$fopts->{'single-debian-patch'}
5591 && branch_is_gdr($symref, $headref)) {
5592 # This is much faster. It also makes patches that gdr
5593 # likes better for future updates without laundering.
5595 # However, it can fail in some casses where we would
5596 # succeed: if there are existing patches, which correspond
5597 # to a prefix of the branch, but are not in gbp/gdr
5598 # format, gdr will fail (exiting status 7), but we might
5599 # be able to figure out where to start linearising. That
5600 # will be slower so hopefully there's not much to do.
5601 my @cmd = (@git_debrebase,
5602 qw(--noop-ok -funclean-mixed -funclean-ordering
5603 make-patches --quiet-would-amend));
5604 # We tolerate soe snags that gdr wouldn't, by default.
5608 failedcmd @cmd if system @cmd and $?!=7*256;
5612 $headref = git_rev_parse('HEAD');
5616 changedir $playground;
5618 my $upstreamversion = upstreamversion $version;
5620 if ($fopts->{'single-debian-patch'}) {
5621 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5623 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5627 runcmd_ordryrun_local
5628 @git, qw(pull --ff-only -q), "$playground/work", qw(master);
5631 sub unpack_playtree_mkwork ($) {
5634 mkdir "work" or die $!;
5636 mktree_in_ud_here();
5637 runcmd @git, qw(reset -q --hard), $headref;
5640 sub unpack_playtree_linkorigs ($$) {
5641 my ($upstreamversion, $fn) = @_;
5642 # calls $fn->($leafname);
5644 my $bpd_abs = bpd_abs();
5645 opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
5646 while ($!=0, defined(my $b = readdir QFD)) {
5647 my $f = bpd_abs()."/".$b;
5649 local ($debuglevel) = $debuglevel-1;
5650 printdebug "QF linkorigs $b, $f ?\n";
5652 next unless is_orig_file_of_vsn $b, $upstreamversion;
5653 printdebug "QF linkorigs $b, $f Y\n";
5654 link_ltarget $f, $b or die "$b $!";
5657 die "$buildproductsdir: $!" if $!;
5661 sub quilt_fixup_delete_pc () {
5662 runcmd @git, qw(rm -rqf .pc);
5664 Commit removal of .pc (quilt series tracking data)
5666 [dgit ($our_version) upgrade quilt-remove-pc]
5670 sub quilt_fixup_singlepatch ($$$) {
5671 my ($clogp, $headref, $upstreamversion) = @_;
5673 progress "starting quiltify (single-debian-patch)";
5675 # dpkg-source --commit generates new patches even if
5676 # single-debian-patch is in debian/source/options. In order to
5677 # get it to generate debian/patches/debian-changes, it is
5678 # necessary to build the source package.
5680 unpack_playtree_linkorigs($upstreamversion, sub { });
5681 unpack_playtree_mkwork($headref);
5683 rmtree("debian/patches");
5685 runcmd @dpkgsource, qw(-b .);
5687 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5688 rename srcfn("$upstreamversion", "/debian/patches"),
5689 "work/debian/patches";
5692 commit_quilty_patch();
5695 sub quilt_make_fake_dsc ($) {
5696 my ($upstreamversion) = @_;
5698 my $fakeversion="$upstreamversion-~~DGITFAKE";
5700 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5701 print $fakedsc <<END or die $!;
5704 Version: $fakeversion
5708 my $dscaddfile=sub {
5711 my $md = new Digest::MD5;
5713 my $fh = new IO::File $b, '<' or die "$b $!";
5718 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5721 unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
5723 my @files=qw(debian/source/format debian/rules
5724 debian/control debian/changelog);
5725 foreach my $maybe (qw(debian/patches debian/source/options
5726 debian/tests/control)) {
5727 next unless stat_exists "$maindir/$maybe";
5728 push @files, $maybe;
5731 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5732 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C), $maindir, @files;
5734 $dscaddfile->($debtar);
5735 close $fakedsc or die $!;
5738 sub quilt_check_splitbrain_cache ($$) {
5739 my ($headref, $upstreamversion) = @_;
5740 # Called only if we are in (potentially) split brain mode.
5741 # Called in playground.
5742 # Computes the cache key and looks in the cache.
5743 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5745 my $splitbrain_cachekey;
5748 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5749 # we look in the reflog of dgit-intern/quilt-cache
5750 # we look for an entry whose message is the key for the cache lookup
5751 my @cachekey = (qw(dgit), $our_version);
5752 push @cachekey, $upstreamversion;
5753 push @cachekey, $quilt_mode;
5754 push @cachekey, $headref;
5756 push @cachekey, hashfile('fake.dsc');
5758 my $srcshash = Digest::SHA->new(256);
5759 my %sfs = ( %INC, '$0(dgit)' => $0 );
5760 foreach my $sfk (sort keys %sfs) {
5761 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5762 $srcshash->add($sfk," ");
5763 $srcshash->add(hashfile($sfs{$sfk}));
5764 $srcshash->add("\n");
5766 push @cachekey, $srcshash->hexdigest();
5767 $splitbrain_cachekey = "@cachekey";
5769 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5771 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5772 debugcmd "|(probably)",@cmd;
5773 my $child = open GC, "-|"; defined $child or die $!;
5775 chdir $maindir or die $!;
5776 if (!stat "$maindir_gitcommon/logs/refs/$splitbraincache") {
5777 $! == ENOENT or die $!;
5778 printdebug ">(no reflog)\n";
5785 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5786 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5789 unpack_playtree_mkwork($headref);
5790 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5791 if ($cachehit ne $headref) {
5792 progress "dgit view: found cached ($saved)";
5793 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5795 return ($cachehit, $splitbrain_cachekey);
5797 progress "dgit view: found cached, no changes required";
5798 return ($headref, $splitbrain_cachekey);
5800 die $! if GC->error;
5801 failedcmd unless close GC;
5803 printdebug "splitbrain cache miss\n";
5804 return (undef, $splitbrain_cachekey);
5807 sub quilt_fixup_multipatch ($$$) {
5808 my ($clogp, $headref, $upstreamversion) = @_;
5810 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5813 # - honour any existing .pc in case it has any strangeness
5814 # - determine the git commit corresponding to the tip of
5815 # the patch stack (if there is one)
5816 # - if there is such a git commit, convert each subsequent
5817 # git commit into a quilt patch with dpkg-source --commit
5818 # - otherwise convert all the differences in the tree into
5819 # a single git commit
5823 # Our git tree doesn't necessarily contain .pc. (Some versions of
5824 # dgit would include the .pc in the git tree.) If there isn't
5825 # one, we need to generate one by unpacking the patches that we
5828 # We first look for a .pc in the git tree. If there is one, we
5829 # will use it. (This is not the normal case.)
5831 # Otherwise need to regenerate .pc so that dpkg-source --commit
5832 # can work. We do this as follows:
5833 # 1. Collect all relevant .orig from parent directory
5834 # 2. Generate a debian.tar.gz out of
5835 # debian/{patches,rules,source/format,source/options}
5836 # 3. Generate a fake .dsc containing just these fields:
5837 # Format Source Version Files
5838 # 4. Extract the fake .dsc
5839 # Now the fake .dsc has a .pc directory.
5840 # (In fact we do this in every case, because in future we will
5841 # want to search for a good base commit for generating patches.)
5843 # Then we can actually do the dpkg-source --commit
5844 # 1. Make a new working tree with the same object
5845 # store as our main tree and check out the main
5847 # 2. Copy .pc from the fake's extraction, if necessary
5848 # 3. Run dpkg-source --commit
5849 # 4. If the result has changes to debian/, then
5850 # - git add them them
5851 # - git add .pc if we had a .pc in-tree
5853 # 5. If we had a .pc in-tree, delete it, and git commit
5854 # 6. Back in the main tree, fast forward to the new HEAD
5856 # Another situation we may have to cope with is gbp-style
5857 # patches-unapplied trees.
5859 # We would want to detect these, so we know to escape into
5860 # quilt_fixup_gbp. However, this is in general not possible.
5861 # Consider a package with a one patch which the dgit user reverts
5862 # (with git revert or the moral equivalent).
5864 # That is indistinguishable in contents from a patches-unapplied
5865 # tree. And looking at the history to distinguish them is not
5866 # useful because the user might have made a confusing-looking git
5867 # history structure (which ought to produce an error if dgit can't
5868 # cope, not a silent reintroduction of an unwanted patch).
5870 # So gbp users will have to pass an option. But we can usually
5871 # detect their failure to do so: if the tree is not a clean
5872 # patches-applied tree, quilt linearisation fails, but the tree
5873 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5874 # they want --quilt=unapplied.
5876 # To help detect this, when we are extracting the fake dsc, we
5877 # first extract it with --skip-patches, and then apply the patches
5878 # afterwards with dpkg-source --before-build. That lets us save a
5879 # tree object corresponding to .origs.
5881 my $splitbrain_cachekey;
5883 quilt_make_fake_dsc($upstreamversion);
5885 if (quiltmode_splitbrain()) {
5887 ($cachehit, $splitbrain_cachekey) =
5888 quilt_check_splitbrain_cache($headref, $upstreamversion);
5889 return if $cachehit;
5893 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5895 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5896 rename $fakexdir, "fake" or die "$fakexdir $!";
5900 remove_stray_gits("source package");
5901 mktree_in_ud_here();
5905 rmtree 'debian'; # git checkout commitish paths does not delete!
5906 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5907 my $unapplied=git_add_write_tree();
5908 printdebug "fake orig tree object $unapplied\n";
5912 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5914 if (system @bbcmd) {
5915 failedcmd @bbcmd if $? < 0;
5917 failed to apply your git tree's patch stack (from debian/patches/) to
5918 the corresponding upstream tarball(s). Your source tree and .orig
5919 are probably too inconsistent. dgit can only fix up certain kinds of
5920 anomaly (depending on the quilt mode). Please see --quilt= in dgit(1).
5926 unpack_playtree_mkwork($headref);
5929 if (stat_exists ".pc") {
5931 progress "Tree already contains .pc - will use it then delete it.";
5934 rename '../fake/.pc','.pc' or die $!;
5937 changedir '../fake';
5939 my $oldtiptree=git_add_write_tree();
5940 printdebug "fake o+d/p tree object $unapplied\n";
5941 changedir '../work';
5944 # We calculate some guesswork now about what kind of tree this might
5945 # be. This is mostly for error reporting.
5951 # O = orig, without patches applied
5952 # A = "applied", ie orig with H's debian/patches applied
5953 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5954 \%editedignores, \@unrepres),
5955 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5956 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5960 foreach my $b (qw(01 02)) {
5961 foreach my $v (qw(O2H O2A H2A)) {
5962 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5965 printdebug "differences \@dl @dl.\n";
5968 "$us: base trees orig=%.20s o+d/p=%.20s",
5969 $unapplied, $oldtiptree;
5971 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5972 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5973 $dl[0], $dl[1], $dl[3], $dl[4],
5977 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5979 forceable_fail [qw(unrepresentable)], <<END;
5980 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5985 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5986 push @failsuggestion, "This might be a patches-unapplied branch.";
5987 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5988 push @failsuggestion, "This might be a patches-applied branch.";
5990 push @failsuggestion, "Maybe you need to specify one of".
5991 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5993 if (quiltmode_splitbrain()) {
5994 quiltify_splitbrain($clogp, $unapplied, $headref, $oldtiptree,
5995 $diffbits, \%editedignores,
5996 $splitbrain_cachekey);
6000 progress "starting quiltify (multiple patches, $quilt_mode mode)";
6001 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
6003 if (!open P, '>>', ".pc/applied-patches") {
6004 $!==&ENOENT or die $!;
6009 commit_quilty_patch();
6011 if ($mustdeletepc) {
6012 quilt_fixup_delete_pc();
6016 sub quilt_fixup_editor () {
6017 my $descfn = $ENV{$fakeeditorenv};
6018 my $editing = $ARGV[$#ARGV];
6019 open I1, '<', $descfn or die "$descfn: $!";
6020 open I2, '<', $editing or die "$editing: $!";
6021 unlink $editing or die "$editing: $!";
6022 open O, '>', $editing or die "$editing: $!";
6023 while (<I1>) { print O or die $!; } I1->error and die $!;
6026 $copying ||= m/^\-\-\- /;
6027 next unless $copying;
6030 I2->error and die $!;
6035 sub maybe_apply_patches_dirtily () {
6036 return unless $quilt_mode =~ m/gbp|unapplied/;
6037 print STDERR <<END or die $!;
6039 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
6040 dgit: Have to apply the patches - making the tree dirty.
6041 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
6044 $patches_applied_dirtily = 01;
6045 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
6046 runcmd qw(dpkg-source --before-build .);
6049 sub maybe_unapply_patches_again () {
6050 progress "dgit: Unapplying patches again to tidy up the tree."
6051 if $patches_applied_dirtily;
6052 runcmd qw(dpkg-source --after-build .)
6053 if $patches_applied_dirtily & 01;
6055 if $patches_applied_dirtily & 02;
6056 $patches_applied_dirtily = 0;
6059 #----- other building -----
6061 our $clean_using_builder;
6062 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
6063 # clean the tree before building (perhaps invoked indirectly by
6064 # whatever we are using to run the build), rather than separately
6065 # and explicitly by us.
6068 return if $clean_using_builder;
6069 if ($cleanmode eq 'dpkg-source') {
6070 maybe_apply_patches_dirtily();
6071 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
6072 } elsif ($cleanmode eq 'dpkg-source-d') {
6073 maybe_apply_patches_dirtily();
6074 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
6075 } elsif ($cleanmode eq 'git') {
6076 runcmd_ordryrun_local @git, qw(clean -xdf);
6077 } elsif ($cleanmode eq 'git-ff') {
6078 runcmd_ordryrun_local @git, qw(clean -xdff);
6079 } elsif ($cleanmode eq 'check') {
6080 my $leftovers = cmdoutput @git, qw(clean -xdn);
6081 if (length $leftovers) {
6082 print STDERR $leftovers, "\n" or die $!;
6083 fail "tree contains uncommitted files and --clean=check specified";
6085 } elsif ($cleanmode eq 'none') {
6092 badusage "clean takes no additional arguments" if @ARGV;
6095 maybe_unapply_patches_again();
6098 # return values from massage_dbp_args are one or both of these flags
6099 sub WANTSRC_SOURCE () { 01; } # caller should build source (separately)
6100 sub WANTSRC_BUILDER () { 02; } # caller should run dpkg-buildpackage
6102 sub build_or_push_prep_early () {
6103 our $build_or_push_prep_early_done //= 0;
6104 return if $build_or_push_prep_early_done++;
6105 badusage "-p is not allowed with dgit $subcommand" if defined $package;
6106 my $clogp = parsechangelog();
6107 $isuite = getfield $clogp, 'Distribution';
6108 $package = getfield $clogp, 'Source';
6109 $version = getfield $clogp, 'Version';
6110 $dscfn = dscfn($version);
6113 sub build_prep_early () {
6114 build_or_push_prep_early();
6119 sub build_prep ($) {
6122 # clean the tree if we're trying to include dirty changes in the
6123 # source package, or we are running the builder in $maindir
6124 clean_tree() if $includedirty || ($wantsrc & WANTSRC_BUILDER);
6125 build_maybe_quilt_fixup();
6127 my $pat = changespat $version;
6128 foreach my $f (glob "$buildproductsdir/$pat") {
6130 unlink $f or fail "remove old changes file $f: $!";
6132 progress "would remove $f";
6138 sub changesopts_initial () {
6139 my @opts =@changesopts[1..$#changesopts];
6142 sub changesopts_version () {
6143 if (!defined $changes_since_version) {
6146 @vsns = archive_query('archive_query');
6147 my @quirk = access_quirk();
6148 if ($quirk[0] eq 'backports') {
6149 local $isuite = $quirk[2];
6151 canonicalise_suite();
6152 push @vsns, archive_query('archive_query');
6158 "archive query failed (queried because --since-version not specified)";
6161 @vsns = map { $_->[0] } @vsns;
6162 @vsns = sort { -version_compare($a, $b) } @vsns;
6163 $changes_since_version = $vsns[0];
6164 progress "changelog will contain changes since $vsns[0]";
6166 $changes_since_version = '_';
6167 progress "package seems new, not specifying -v<version>";
6170 if ($changes_since_version ne '_') {
6171 return ("-v$changes_since_version");
6177 sub changesopts () {
6178 return (changesopts_initial(), changesopts_version());
6181 sub massage_dbp_args ($;$) {
6182 my ($cmd,$xargs) = @_;
6183 # Since we split the source build out so we can do strange things
6184 # to it, massage the arguments to dpkg-buildpackage so that the
6185 # main build doessn't build source (or add an argument to stop it
6186 # building source by default).
6187 debugcmd '#massaging#', @$cmd if $debuglevel>1;
6188 # -nc has the side effect of specifying -b if nothing else specified
6189 # and some combinations of -S, -b, et al, are errors, rather than
6190 # later simply overriding earlie. So we need to:
6191 # - search the command line for these options
6192 # - pick the last one
6193 # - perhaps add our own as a default
6194 # - perhaps adjust it to the corresponding non-source-building version
6196 foreach my $l ($cmd, $xargs) {
6198 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
6201 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
6202 my $r = WANTSRC_BUILDER;
6203 printdebug "massage split $dmode.\n";
6204 $r = $dmode =~ m/[S]/ ? WANTSRC_SOURCE :
6205 $dmode =~ y/gGF/ABb/ ? WANTSRC_SOURCE | WANTSRC_BUILDER :
6206 $dmode =~ m/[ABb]/ ? WANTSRC_BUILDER :
6208 printdebug "massage done $r $dmode.\n";
6210 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
6216 my $wasdir = must_getcwd();
6217 changedir $buildproductsdir;
6222 # this sub must run with CWD=$buildproductsdir (eg in in_bpd)
6223 sub postbuild_mergechanges ($) {
6224 my ($msg_if_onlyone) = @_;
6225 # If there is only one .changes file, fail with $msg_if_onlyone,
6226 # or if that is undef, be a no-op.
6227 # Returns the changes file to report to the user.
6228 my $pat = changespat $version;
6229 my @changesfiles = grep { !m/_multi\.changes/ } glob $pat;
6230 @changesfiles = sort {
6231 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
6235 if (@changesfiles==1) {
6236 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
6237 only one changes file from build (@changesfiles)
6239 $result = $changesfiles[0];
6240 } elsif (@changesfiles==2) {
6241 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
6242 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
6243 fail "$l found in binaries changes file $binchanges"
6246 runcmd_ordryrun_local @mergechanges, @changesfiles;
6247 my $multichanges = changespat $version,'multi';
6249 stat_exists $multichanges or fail "$multichanges: $!";
6250 foreach my $cf (glob $pat) {
6251 next if $cf eq $multichanges;
6252 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
6255 $result = $multichanges;
6257 fail "wrong number of different changes files (@changesfiles)";
6259 printdone "build successful, results in $result\n" or die $!;
6262 sub midbuild_checkchanges () {
6263 my $pat = changespat $version;
6264 return if $rmchanges;
6265 my @unwanted = map { s#.*/##; $_; } glob "$bpd_glob/$pat";
6267 $_ ne changespat $version,'source' and
6268 $_ ne changespat $version,'multi'
6271 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
6272 Suggest you delete @unwanted.
6277 sub midbuild_checkchanges_vanilla ($) {
6279 midbuild_checkchanges() if $wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER);
6282 sub postbuild_mergechanges_vanilla ($) {
6284 if ($wantsrc == (WANTSRC_SOURCE|WANTSRC_BUILDER)) {
6286 postbuild_mergechanges(undef);
6289 printdone "build successful\n";
6295 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6296 my $wantsrc = massage_dbp_args \@dbp;
6297 build_prep($wantsrc);
6298 if ($wantsrc & WANTSRC_SOURCE) {
6300 midbuild_checkchanges_vanilla $wantsrc;
6302 if ($wantsrc & WANTSRC_BUILDER) {
6303 push @dbp, changesopts_version();
6304 maybe_apply_patches_dirtily();
6305 runcmd_ordryrun_local @dbp;
6307 maybe_unapply_patches_again();
6308 postbuild_mergechanges_vanilla $wantsrc;
6312 $quilt_mode //= 'gbp';
6318 # gbp can make .origs out of thin air. In my tests it does this
6319 # even for a 1.0 format package, with no origs present. So I
6320 # guess it keys off just the version number. We don't know
6321 # exactly what .origs ought to exist, but let's assume that we
6322 # should run gbp if: the version has an upstream part and the main
6324 my $upstreamversion = upstreamversion $version;
6325 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6326 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "$bpd_glob/$origfnpat");
6328 if ($gbp_make_orig) {
6330 $cleanmode = 'none'; # don't do it again
6333 my @dbp = @dpkgbuildpackage;
6335 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6337 if (!length $gbp_build[0]) {
6338 if (length executable_on_path('git-buildpackage')) {
6339 $gbp_build[0] = qw(git-buildpackage);
6341 $gbp_build[0] = 'gbp buildpackage';
6344 my @cmd = opts_opt_multi_cmd [], @gbp_build;
6346 push @cmd, (qw(-us -uc --git-no-sign-tags),
6347 "--git-builder=".(shellquote @dbp));
6349 if ($gbp_make_orig) {
6350 my $priv = dgit_privdir();
6351 my $ok = "$priv/origs-gen-ok";
6352 unlink $ok or $!==&ENOENT or die $!;
6353 my @origs_cmd = @cmd;
6354 push @origs_cmd, qw(--git-cleaner=true);
6355 push @origs_cmd, "--git-prebuild=".
6356 "touch ".(shellquote $ok)." ".(shellquote "$priv/no-such-dir/ok");
6357 push @origs_cmd, @ARGV;
6359 debugcmd @origs_cmd;
6361 do { local $!; stat_exists $ok; }
6362 or failedcmd @origs_cmd;
6364 dryrun_report @origs_cmd;
6368 build_prep($wantsrc);
6369 if ($wantsrc & WANTSRC_SOURCE) {
6371 midbuild_checkchanges_vanilla $wantsrc;
6373 if (!$clean_using_builder) {
6374 push @cmd, '--git-cleaner=true';
6377 maybe_unapply_patches_again();
6378 if ($wantsrc & WANTSRC_BUILDER) {
6379 push @cmd, changesopts();
6380 runcmd_ordryrun_local @cmd, @ARGV;
6382 postbuild_mergechanges_vanilla $wantsrc;
6384 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6386 sub building_source_in_playtree {
6387 # If $includedirty, we have to build the source package from the
6388 # working tree, not a playtree, so that uncommitted changes are
6389 # included (copying or hardlinking them into the playtree could
6392 # Note that if we are building a source package in split brain
6393 # mode we do not support including uncommitted changes, because
6394 # that makes quilt fixup too hard. I.e. ($split_brain && (dgit is
6395 # building a source package)) => !$includedirty
6396 return !$includedirty;
6400 $sourcechanges = changespat $version,'source';
6402 unlink "$buildproductsdir/$sourcechanges" or $!==ENOENT
6403 or fail "remove $sourcechanges: $!";
6405 my @cmd = (@dpkgsource, qw(-b --));
6407 if (building_source_in_playtree()) {
6409 my $headref = git_rev_parse('HEAD');
6410 # If we are in split brain, there is already a playtree with
6411 # the thing we should package into a .dsc (thanks to quilt
6412 # fixup). If not, make a playtree
6413 prep_ud() unless $split_brain;
6414 changedir $playground;
6415 unless ($split_brain) {
6416 my $upstreamversion = upstreamversion $version;
6417 unpack_playtree_linkorigs($upstreamversion, sub { });
6418 unpack_playtree_mkwork($headref);
6422 $leafdir = basename $maindir;
6425 runcmd_ordryrun_local @cmd, $leafdir;
6428 runcmd_ordryrun_local qw(sh -ec),
6429 'exec >../$1; shift; exec "$@"','x', $sourcechanges,
6430 @dpkggenchanges, qw(-S), changesopts();
6433 printdebug "moving $dscfn, $sourcechanges, etc. to ".bpd_abs()."\n";
6434 $dsc = parsecontrol($dscfn, "source package");
6438 printdebug " renaming ($why) $l\n";
6439 rename "$l", bpd_abs()."/$l"
6440 or fail "put in place new built file ($l): $!";
6442 foreach my $l (split /\n/, getfield $dsc, 'Files') {
6443 $l =~ m/\S+$/ or next;
6446 $mv->('dsc', $dscfn);
6447 $mv->('changes', $sourcechanges);
6452 sub cmd_build_source {
6453 badusage "build-source takes no additional arguments" if @ARGV;
6454 build_prep(WANTSRC_SOURCE);
6456 maybe_unapply_patches_again();
6457 printdone "source built, results in $dscfn and $sourcechanges";
6460 sub cmd_push_source {
6462 fail "dgit push-source: --include-dirty/--ignore-dirty does not make".
6463 "sense with push-source!" if $includedirty;
6464 build_maybe_quilt_fixup();
6466 my $changes = parsecontrol("$buildproductsdir/$changesfile",
6467 "source changes file");
6468 unless (test_source_only_changes($changes)) {
6469 fail "user-specified changes file is not source-only";
6472 # Building a source package is very fast, so just do it
6474 die "er, patches are applied dirtily but shouldn't be.."
6475 if $patches_applied_dirtily;
6476 $changesfile = $sourcechanges;
6481 sub binary_builder {
6482 my ($bbuilder, $pbmc_msg, @args) = @_;
6483 build_prep(WANTSRC_SOURCE);
6485 midbuild_checkchanges();
6488 stat_exists $dscfn or fail "$dscfn (in build products dir): $!";
6489 stat_exists $sourcechanges
6490 or fail "$sourcechanges (in build products dir): $!";
6492 runcmd_ordryrun_local @$bbuilder, @args;
6494 maybe_unapply_patches_again();
6496 postbuild_mergechanges($pbmc_msg);
6502 binary_builder(\@sbuild, <<END, qw(-d), $isuite, @ARGV, $dscfn);
6503 perhaps you need to pass -A ? (sbuild's default is to build only
6504 arch-specific binaries; dgit 1.4 used to override that.)
6509 my ($pbuilder) = @_;
6511 # @ARGV is allowed to contain only things that should be passed to
6512 # pbuilder under debbuildopts; just massage those
6513 my $wantsrc = massage_dbp_args \@ARGV;
6514 fail "you asked for a builder but your debbuildopts didn't ask for".
6515 " any binaries -- is this really what you meant?"
6516 unless $wantsrc & WANTSRC_BUILDER;
6517 fail "we must build a .dsc to pass to the builder but your debbuiltopts".
6518 " forbids the building of a source package; cannot continue"
6519 unless $wantsrc & WANTSRC_SOURCE;
6520 # We do not want to include the verb "build" in @pbuilder because
6521 # the user can customise @pbuilder and they shouldn't be required
6522 # to include "build" in their customised value. However, if the
6523 # user passes any additional args to pbuilder using the dgit
6524 # option --pbuilder:foo, such args need to come after the "build"
6525 # verb. opts_opt_multi_cmd does all of that.
6526 binary_builder([opts_opt_multi_cmd ["build"], @$pbuilder], undef,
6527 qw(--debbuildopts), "@ARGV", qw(--distribution), $isuite,
6532 pbuilder(\@pbuilder);
6535 sub cmd_cowbuilder {
6536 pbuilder(\@cowbuilder);
6539 sub cmd_quilt_fixup {
6540 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6543 build_maybe_quilt_fixup();
6546 sub import_dsc_result {
6547 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6548 my @cmd = (git_update_ref_cmd $what_log, $dstref, $newhash);
6550 check_gitattrs($newhash, "source tree");
6552 progress "dgit: import-dsc: $what_msg";
6555 sub cmd_import_dsc {
6559 last unless $ARGV[0] =~ m/^-/;
6562 if (m/^--require-valid-signature$/) {
6565 badusage "unknown dgit import-dsc sub-option \`$_'";
6569 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6570 my ($dscfn, $dstbranch) = @ARGV;
6572 badusage "dry run makes no sense with import-dsc" unless act_local();
6574 my $force = $dstbranch =~ s/^\+// ? +1 :
6575 $dstbranch =~ s/^\.\.// ? -1 :
6577 my $info = $force ? " $&" : '';
6578 $info = "$dscfn$info";
6580 my $specbranch = $dstbranch;
6581 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6582 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6584 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6585 my $chead = cmdoutput_errok @symcmd;
6586 defined $chead or $?==256 or failedcmd @symcmd;
6588 fail "$dstbranch is checked out - will not update it"
6589 if defined $chead and $chead eq $dstbranch;
6591 my $oldhash = git_get_ref $dstbranch;
6593 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6594 $dscdata = do { local $/ = undef; <D>; };
6595 D->error and fail "read $dscfn: $!";
6598 # we don't normally need this so import it here
6599 use Dpkg::Source::Package;
6600 my $dp = new Dpkg::Source::Package filename => $dscfn,
6601 require_valid_signature => $needsig;
6603 local $SIG{__WARN__} = sub {
6605 return unless $needsig;
6606 fail "import-dsc signature check failed";
6608 if (!$dp->is_signed()) {
6609 warn "$us: warning: importing unsigned .dsc\n";
6611 my $r = $dp->check_signature();
6612 die "->check_signature => $r" if $needsig && $r;
6618 $package = getfield $dsc, 'Source';
6620 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6621 unless forceing [qw(import-dsc-with-dgit-field)];
6622 parse_dsc_field_def_dsc_distro();
6624 $isuite = 'DGIT-IMPORT-DSC';
6625 $idistro //= $dsc_distro;
6629 if (defined $dsc_hash) {
6630 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6631 resolve_dsc_field_commit undef, undef;
6633 if (defined $dsc_hash) {
6634 my @cmd = (qw(sh -ec),
6635 "echo $dsc_hash | git cat-file --batch-check");
6636 my $objgot = cmdoutput @cmd;
6637 if ($objgot =~ m#^\w+ missing\b#) {
6639 .dsc contains Dgit field referring to object $dsc_hash
6640 Your git tree does not have that object. Try `git fetch' from a
6641 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6644 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6646 progress "Not fast forward, forced update.";
6648 fail "Not fast forward to $dsc_hash";
6651 import_dsc_result $dstbranch, $dsc_hash,
6652 "dgit import-dsc (Dgit): $info",
6653 "updated git ref $dstbranch";
6658 Branch $dstbranch already exists
6659 Specify ..$specbranch for a pseudo-merge, binding in existing history
6660 Specify +$specbranch to overwrite, discarding existing history
6662 if $oldhash && !$force;
6664 my @dfi = dsc_files_info();
6665 foreach my $fi (@dfi) {
6666 my $f = $fi->{Filename};
6667 my $here = "$buildproductsdir/$f";
6670 fail "lstat $here works but stat gives $! !";
6672 fail "stat $here: $!" unless $! == ENOENT;
6674 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6676 } elsif ($dscfn =~ m#^/#) {
6679 fail "cannot import $dscfn which seems to be inside working tree!";
6681 $there =~ s#/+[^/]+$## or
6682 fail "import $dscfn requires ../$f, but it does not exist";
6684 my $test = $there =~ m{^/} ? $there : "../$there";
6685 stat $test or fail "import $dscfn requires $test, but: $!";
6686 symlink $there, $here or fail "symlink $there to $here: $!";
6687 progress "made symlink $here -> $there";
6688 # print STDERR Dumper($fi);
6690 my @mergeinputs = generate_commits_from_dsc();
6691 die unless @mergeinputs == 1;
6693 my $newhash = $mergeinputs[0]{Commit};
6697 progress "Import, forced update - synthetic orphan git history.";
6698 } elsif ($force < 0) {
6699 progress "Import, merging.";
6700 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6701 my $version = getfield $dsc, 'Version';
6702 my $clogp = commit_getclogp $newhash;
6703 my $authline = clogp_authline $clogp;
6704 $newhash = make_commit_text <<END;
6711 Merge $package ($version) import into $dstbranch
6714 die; # caught earlier
6718 import_dsc_result $dstbranch, $newhash,
6719 "dgit import-dsc: $info",
6720 "results are in in git ref $dstbranch";
6723 sub pre_archive_api_query () {
6724 not_necessarily_a_tree();
6726 sub cmd_archive_api_query {
6727 badusage "need only 1 subpath argument" unless @ARGV==1;
6728 my ($subpath) = @ARGV;
6729 local $isuite = 'DGIT-API-QUERY-CMD';
6730 my @cmd = archive_api_query_cmd($subpath);
6733 exec @cmd or fail "exec curl: $!\n";
6736 sub repos_server_url () {
6737 $package = '_dgit-repos-server';
6738 local $access_forpush = 1;
6739 local $isuite = 'DGIT-REPOS-SERVER';
6740 my $url = access_giturl();
6743 sub pre_clone_dgit_repos_server () {
6744 not_necessarily_a_tree();
6746 sub cmd_clone_dgit_repos_server {
6747 badusage "need destination argument" unless @ARGV==1;
6748 my ($destdir) = @ARGV;
6749 my $url = repos_server_url();
6750 my @cmd = (@git, qw(clone), $url, $destdir);
6752 exec @cmd or fail "exec git clone: $!\n";
6755 sub pre_print_dgit_repos_server_source_url () {
6756 not_necessarily_a_tree();
6758 sub cmd_print_dgit_repos_server_source_url {
6759 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6761 my $url = repos_server_url();
6762 print $url, "\n" or die $!;
6765 sub pre_print_dpkg_source_ignores {
6766 not_necessarily_a_tree();
6768 sub cmd_print_dpkg_source_ignores {
6769 badusage "no arguments allowed to dgit print-dpkg-source-ignores"
6771 print "@dpkg_source_ignores\n" or die $!;
6774 sub cmd_setup_mergechangelogs {
6775 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6776 local $isuite = 'DGIT-SETUP-TREE';
6777 setup_mergechangelogs(1);
6780 sub cmd_setup_useremail {
6781 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6782 local $isuite = 'DGIT-SETUP-TREE';
6786 sub cmd_setup_gitattributes {
6787 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6788 local $isuite = 'DGIT-SETUP-TREE';
6792 sub cmd_setup_new_tree {
6793 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6794 local $isuite = 'DGIT-SETUP-TREE';
6798 #---------- argument parsing and main program ----------
6801 print "dgit version $our_version\n" or die $!;
6805 our (%valopts_long, %valopts_short);
6806 our (%funcopts_long);
6808 our (@modeopt_cfgs);
6810 sub defvalopt ($$$$) {
6811 my ($long,$short,$val_re,$how) = @_;
6812 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6813 $valopts_long{$long} = $oi;
6814 $valopts_short{$short} = $oi;
6815 # $how subref should:
6816 # do whatever assignemnt or thing it likes with $_[0]
6817 # if the option should not be passed on to remote, @rvalopts=()
6818 # or $how can be a scalar ref, meaning simply assign the value
6821 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6822 defvalopt '--distro', '-d', '.+', \$idistro;
6823 defvalopt '', '-k', '.+', \$keyid;
6824 defvalopt '--existing-package','', '.*', \$existing_package;
6825 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6826 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6827 defvalopt '--package', '-p', $package_re, \$package;
6828 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6830 defvalopt '', '-C', '.+', sub {
6831 ($changesfile) = (@_);
6832 if ($changesfile =~ s#^(.*)/##) {
6833 $buildproductsdir = $1;
6837 defvalopt '--initiator-tempdir','','.*', sub {
6838 ($initiator_tempdir) = (@_);
6839 $initiator_tempdir =~ m#^/# or
6840 badusage "--initiator-tempdir must be used specify an".
6841 " absolute, not relative, directory."
6844 sub defoptmodes ($@) {
6845 my ($varref, $cfgkey, $default, %optmap) = @_;
6847 while (my ($opt,$val) = each %optmap) {
6848 $funcopts_long{$opt} = sub { $$varref = $val; };
6849 $permit{$val} = $val;
6851 push @modeopt_cfgs, {
6854 Default => $default,
6859 defoptmodes \$dodep14tag, qw( dep14tag want
6862 --always-dep14tag always );
6867 if (defined $ENV{'DGIT_SSH'}) {
6868 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6869 } elsif (defined $ENV{'GIT_SSH'}) {
6870 @ssh = ($ENV{'GIT_SSH'});
6878 if (!defined $val) {
6879 badusage "$what needs a value" unless @ARGV;
6881 push @rvalopts, $val;
6883 badusage "bad value \`$val' for $what" unless
6884 $val =~ m/^$oi->{Re}$(?!\n)/s;
6885 my $how = $oi->{How};
6886 if (ref($how) eq 'SCALAR') {
6891 push @ropts, @rvalopts;
6895 last unless $ARGV[0] =~ m/^-/;
6899 if (m/^--dry-run$/) {
6902 } elsif (m/^--damp-run$/) {
6905 } elsif (m/^--no-sign$/) {
6908 } elsif (m/^--help$/) {
6910 } elsif (m/^--version$/) {
6912 } elsif (m/^--new$/) {
6915 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6916 ($om = $opts_opt_map{$1}) &&
6920 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6921 !$opts_opt_cmdonly{$1} &&
6922 ($om = $opts_opt_map{$1})) {
6925 } elsif (m/^--(gbp|dpm)$/s) {
6926 push @ropts, "--quilt=$1";
6928 } elsif (m/^--(?:ignore|include)-dirty$/s) {
6931 } elsif (m/^--no-quilt-fixup$/s) {
6933 $quilt_mode = 'nocheck';
6934 } elsif (m/^--no-rm-on-error$/s) {
6937 } elsif (m/^--no-chase-dsc-distro$/s) {
6939 $chase_dsc_distro = 0;
6940 } elsif (m/^--overwrite$/s) {
6942 $overwrite_version = '';
6943 } elsif (m/^--overwrite=(.+)$/s) {
6945 $overwrite_version = $1;
6946 } elsif (m/^--delayed=(\d+)$/s) {
6949 } elsif (m/^--dgit-view-save=(.+)$/s) {
6951 $split_brain_save = $1;
6952 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6953 } elsif (m/^--(no-)?rm-old-changes$/s) {
6956 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6958 push @deliberatelies, $&;
6959 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6963 } elsif (m/^--force-/) {
6965 "$us: warning: ignoring unknown force option $_\n";
6967 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6968 # undocumented, for testing
6970 $tagformat_want = [ $1, 'command line', 1 ];
6971 # 1 menas overrides distro configuration
6972 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6973 # undocumented, for testing
6975 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6976 # ^ it's supposed to be an array ref
6977 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6978 $val = $2 ? $' : undef; #';
6979 $valopt->($oi->{Long});
6980 } elsif ($funcopts_long{$_}) {
6982 $funcopts_long{$_}();
6984 badusage "unknown long option \`$_'";
6991 } elsif (s/^-L/-/) {
6994 } elsif (s/^-h/-/) {
6996 } elsif (s/^-D/-/) {
7000 } elsif (s/^-N/-/) {
7005 push @changesopts, $_;
7007 } elsif (s/^-wn$//s) {
7009 $cleanmode = 'none';
7010 } elsif (s/^-wg$//s) {
7013 } elsif (s/^-wgf$//s) {
7015 $cleanmode = 'git-ff';
7016 } elsif (s/^-wd$//s) {
7018 $cleanmode = 'dpkg-source';
7019 } elsif (s/^-wdd$//s) {
7021 $cleanmode = 'dpkg-source-d';
7022 } elsif (s/^-wc$//s) {
7024 $cleanmode = 'check';
7025 } elsif (s/^-c([^=]*)\=(.*)$//s) {
7026 push @git, '-c', $&;
7027 $gitcfgs{cmdline}{$1} = [ $2 ];
7028 } elsif (s/^-c([^=]+)$//s) {
7029 push @git, '-c', $&;
7030 $gitcfgs{cmdline}{$1} = [ 'true' ];
7031 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
7033 $val = undef unless length $val;
7034 $valopt->($oi->{Short});
7037 badusage "unknown short option \`$_'";
7044 sub check_env_sanity () {
7045 my $blocked = new POSIX::SigSet;
7046 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
7049 foreach my $name (qw(PIPE CHLD)) {
7050 my $signame = "SIG$name";
7051 my $signum = eval "POSIX::$signame" // die;
7052 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
7053 die "$signame is set to something other than SIG_DFL\n";
7054 $blocked->ismember($signum) and
7055 die "$signame is blocked\n";
7061 On entry to dgit, $@
7062 This is a bug produced by something in in your execution environment.
7068 sub parseopts_late_defaults () {
7069 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
7070 if defined $idistro;
7071 $isuite //= cfg('dgit.default.default-suite');
7073 foreach my $k (keys %opts_opt_map) {
7074 my $om = $opts_opt_map{$k};
7076 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
7078 badcfg "cannot set command for $k"
7079 unless length $om->[0];
7083 foreach my $c (access_cfg_cfgs("opts-$k")) {
7085 map { $_ ? @$_ : () }
7086 map { $gitcfgs{$_}{$c} }
7087 reverse @gitcfgsources;
7088 printdebug "CL $c ", (join " ", map { shellquote } @vl),
7089 "\n" if $debuglevel >= 4;
7091 badcfg "cannot configure options for $k"
7092 if $opts_opt_cmdonly{$k};
7093 my $insertpos = $opts_cfg_insertpos{$k};
7094 @$om = ( @$om[0..$insertpos-1],
7096 @$om[$insertpos..$#$om] );
7100 if (!defined $rmchanges) {
7101 local $access_forpush;
7102 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
7105 if (!defined $quilt_mode) {
7106 local $access_forpush;
7107 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
7108 // access_cfg('quilt-mode', 'RETURN-UNDEF')
7110 $quilt_mode =~ m/^($quilt_modes_re)$/
7111 or badcfg "unknown quilt-mode \`$quilt_mode'";
7115 foreach my $moc (@modeopt_cfgs) {
7116 local $access_forpush;
7117 my $vr = $moc->{Var};
7118 next if defined $$vr;
7119 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
7120 my $v = $moc->{Vals}{$$vr};
7121 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
7125 fail "dgit: --include-dirty is not supported in split view quilt mode"
7126 if $split_brain && $includedirty;
7128 if (!defined $cleanmode) {
7129 local $access_forpush;
7130 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
7131 $cleanmode //= 'dpkg-source';
7133 badcfg "unknown clean-mode \`$cleanmode'" unless
7134 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
7137 $buildproductsdir //= access_cfg('build-products-dir', 'RETURN-UNDEF');
7138 $buildproductsdir //= '..';
7139 $bpd_glob = $buildproductsdir;
7140 $bpd_glob =~ s#[][\\{}*?~]#\\$&#g;
7143 if ($ENV{$fakeeditorenv}) {
7145 quilt_fixup_editor();
7151 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
7152 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
7153 if $dryrun_level == 1;
7155 print STDERR $helpmsg or die $!;
7158 $cmd = $subcommand = shift @ARGV;
7161 my $pre_fn = ${*::}{"pre_$cmd"};
7162 $pre_fn->() if $pre_fn;
7164 record_maindir if $invoked_in_git_tree;
7167 my $fn = ${*::}{"cmd_$cmd"};
7168 $fn or badusage "unknown operation $cmd";