3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
39 use Text::Glob qw(match_glob);
40 use Fcntl qw(:DEFAULT :flock);
45 our $our_version = 'UNRELEASED'; ###substituted###
46 our $absurdity = undef; ###substituted###
48 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
51 our $isuite = 'unstable';
57 our $dryrun_level = 0;
59 our $buildproductsdir = '..';
65 our $existing_package = 'dpkg';
67 our $changes_since_version;
69 our $overwrite_version; # undef: not specified; '': check changelog
71 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
73 our $dodep14tag_re = 'want|no|always';
74 our $split_brain_save;
75 our $we_are_responder;
76 our $initiator_tempdir;
77 our $patches_applied_dirtily = 00;
82 our %forceopts = map { $_=>0 }
83 qw(unrepresentable unsupported-source-format
84 dsc-changes-mismatch changes-origs-exactly
85 import-gitapply-absurd
86 import-gitapply-no-absurd
87 import-dsc-with-dgit-field);
89 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
91 our $suite_re = '[-+.0-9a-z]+';
92 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
93 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
94 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
95 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
97 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
98 our $splitbraincache = 'dgit-intern/quilt-cache';
99 our $rewritemap = 'dgit-rewrite/map';
101 our (@git) = qw(git);
102 our (@dget) = qw(dget);
103 our (@curl) = qw(curl);
104 our (@dput) = qw(dput);
105 our (@debsign) = qw(debsign);
106 our (@gpg) = qw(gpg);
107 our (@sbuild) = qw(sbuild);
109 our (@dgit) = qw(dgit);
110 our (@aptget) = qw(apt-get);
111 our (@aptcache) = qw(apt-cache);
112 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
113 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
114 our (@dpkggenchanges) = qw(dpkg-genchanges);
115 our (@mergechanges) = qw(mergechanges -f);
116 our (@gbp_build) = ('');
117 our (@gbp_pq) = ('gbp pq');
118 our (@changesopts) = ('');
120 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
123 'debsign' => \@debsign,
125 'sbuild' => \@sbuild,
129 'apt-get' => \@aptget,
130 'apt-cache' => \@aptcache,
131 'dpkg-source' => \@dpkgsource,
132 'dpkg-buildpackage' => \@dpkgbuildpackage,
133 'dpkg-genchanges' => \@dpkggenchanges,
134 'gbp-build' => \@gbp_build,
135 'gbp-pq' => \@gbp_pq,
136 'ch' => \@changesopts,
137 'mergechanges' => \@mergechanges);
139 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
140 our %opts_cfg_insertpos = map {
142 scalar @{ $opts_opt_map{$_} }
143 } keys %opts_opt_map;
145 sub parseopts_late_defaults();
151 our $supplementary_message = '';
152 our $need_split_build_invocation = 0;
153 our $split_brain = 0;
157 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
160 our $remotename = 'dgit';
161 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
165 if (!defined $absurdity) {
167 $absurdity =~ s{/[^/]+$}{/absurd} or die;
171 my ($v,$distro) = @_;
172 return $tagformatfn->($v, $distro);
175 sub debiantag_maintview ($$) {
176 my ($v,$distro) = @_;
177 return "$distro/".dep14_version_mangle $v;
180 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
182 sub lbranch () { return "$branchprefix/$csuite"; }
183 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
184 sub lref () { return "refs/heads/".lbranch(); }
185 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
186 sub rrref () { return server_ref($csuite); }
196 return "${package}_".(stripepoch $vsn).$sfx
201 return srcfn($vsn,".dsc");
204 sub changespat ($;$) {
205 my ($vsn, $arch) = @_;
206 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
209 sub upstreamversion ($) {
221 foreach my $f (@end) {
223 print STDERR "$us: cleanup: $@" if length $@;
227 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
229 sub forceable_fail ($$) {
230 my ($forceoptsl, $msg) = @_;
231 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
232 print STDERR "warning: overriding problem due to --force:\n". $msg;
236 my ($forceoptsl) = @_;
237 my @got = grep { $forceopts{$_} } @$forceoptsl;
238 return 0 unless @got;
240 "warning: skipping checks or functionality due to --force-$got[0]\n";
243 sub no_such_package () {
244 print STDERR "$us: package $package does not exist in suite $isuite\n";
250 printdebug "CD $newdir\n";
251 chdir $newdir or confess "chdir: $newdir: $!";
254 sub deliberately ($) {
256 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
259 sub deliberately_not_fast_forward () {
260 foreach (qw(not-fast-forward fresh-repo)) {
261 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
265 sub quiltmode_splitbrain () {
266 $quilt_mode =~ m/gbp|dpm|unapplied/;
269 sub opts_opt_multi_cmd {
271 push @cmd, split /\s+/, shift @_;
277 return opts_opt_multi_cmd @gbp_pq;
280 #---------- remote protocol support, common ----------
282 # remote push initiator/responder protocol:
283 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
284 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
285 # < dgit-remote-push-ready <actual-proto-vsn>
292 # > supplementary-message NBYTES # $protovsn >= 3
297 # > file parsed-changelog
298 # [indicates that output of dpkg-parsechangelog follows]
299 # > data-block NBYTES
300 # > [NBYTES bytes of data (no newline)]
301 # [maybe some more blocks]
310 # > param head DGIT-VIEW-HEAD
311 # > param csuite SUITE
312 # > param tagformat old|new
313 # > param maint-view MAINT-VIEW-HEAD
315 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
316 # # goes into tag, for replay prevention
319 # [indicates that signed tag is wanted]
320 # < data-block NBYTES
321 # < [NBYTES bytes of data (no newline)]
322 # [maybe some more blocks]
326 # > want signed-dsc-changes
327 # < data-block NBYTES [transfer of signed dsc]
329 # < data-block NBYTES [transfer of signed changes]
337 sub i_child_report () {
338 # Sees if our child has died, and reap it if so. Returns a string
339 # describing how it died if it failed, or undef otherwise.
340 return undef unless $i_child_pid;
341 my $got = waitpid $i_child_pid, WNOHANG;
342 return undef if $got <= 0;
343 die unless $got == $i_child_pid;
344 $i_child_pid = undef;
345 return undef unless $?;
346 return "build host child ".waitstatusmsg();
351 fail "connection lost: $!" if $fh->error;
352 fail "protocol violation; $m not expected";
355 sub badproto_badread ($$) {
357 fail "connection lost: $!" if $!;
358 my $report = i_child_report();
359 fail $report if defined $report;
360 badproto $fh, "eof (reading $wh)";
363 sub protocol_expect (&$) {
364 my ($match, $fh) = @_;
367 defined && chomp or badproto_badread $fh, "protocol message";
375 badproto $fh, "\`$_'";
378 sub protocol_send_file ($$) {
379 my ($fh, $ourfn) = @_;
380 open PF, "<", $ourfn or die "$ourfn: $!";
383 my $got = read PF, $d, 65536;
384 die "$ourfn: $!" unless defined $got;
386 print $fh "data-block ".length($d)."\n" or die $!;
387 print $fh $d or die $!;
389 PF->error and die "$ourfn $!";
390 print $fh "data-end\n" or die $!;
394 sub protocol_read_bytes ($$) {
395 my ($fh, $nbytes) = @_;
396 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
398 my $got = read $fh, $d, $nbytes;
399 $got==$nbytes or badproto_badread $fh, "data block";
403 sub protocol_receive_file ($$) {
404 my ($fh, $ourfn) = @_;
405 printdebug "() $ourfn\n";
406 open PF, ">", $ourfn or die "$ourfn: $!";
408 my ($y,$l) = protocol_expect {
409 m/^data-block (.*)$/ ? (1,$1) :
410 m/^data-end$/ ? (0,) :
414 my $d = protocol_read_bytes $fh, $l;
415 print PF $d or die $!;
420 #---------- remote protocol support, responder ----------
422 sub responder_send_command ($) {
424 return unless $we_are_responder;
425 # called even without $we_are_responder
426 printdebug ">> $command\n";
427 print PO $command, "\n" or die $!;
430 sub responder_send_file ($$) {
431 my ($keyword, $ourfn) = @_;
432 return unless $we_are_responder;
433 printdebug "]] $keyword $ourfn\n";
434 responder_send_command "file $keyword";
435 protocol_send_file \*PO, $ourfn;
438 sub responder_receive_files ($@) {
439 my ($keyword, @ourfns) = @_;
440 die unless $we_are_responder;
441 printdebug "[[ $keyword @ourfns\n";
442 responder_send_command "want $keyword";
443 foreach my $fn (@ourfns) {
444 protocol_receive_file \*PI, $fn;
447 protocol_expect { m/^files-end$/ } \*PI;
450 #---------- remote protocol support, initiator ----------
452 sub initiator_expect (&) {
454 protocol_expect { &$match } \*RO;
457 #---------- end remote code ----------
460 if ($we_are_responder) {
462 responder_send_command "progress ".length($m) or die $!;
463 print PO $m or die $!;
473 $ua = LWP::UserAgent->new();
477 progress "downloading $what...";
478 my $r = $ua->get(@_) or die $!;
479 return undef if $r->code == 404;
480 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
481 return $r->decoded_content(charset => 'none');
484 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
489 failedcmd @_ if system @_;
492 sub act_local () { return $dryrun_level <= 1; }
493 sub act_scary () { return !$dryrun_level; }
496 if (!$dryrun_level) {
497 progress "$us ok: @_";
499 progress "would be ok: @_ (but dry run only)";
504 printcmd(\*STDERR,$debugprefix."#",@_);
507 sub runcmd_ordryrun {
515 sub runcmd_ordryrun_local {
524 my ($first_shell, @cmd) = @_;
525 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
528 our $helpmsg = <<END;
530 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
531 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
532 dgit [dgit-opts] build [dpkg-buildpackage-opts]
533 dgit [dgit-opts] sbuild [sbuild-opts]
534 dgit [dgit-opts] push [dgit-opts] [suite]
535 dgit [dgit-opts] rpush build-host:build-dir ...
536 important dgit options:
537 -k<keyid> sign tag and package with <keyid> instead of default
538 --dry-run -n do not change anything, but go through the motions
539 --damp-run -L like --dry-run but make local changes, without signing
540 --new -N allow introducing a new package
541 --debug -D increase debug level
542 -c<name>=<value> set git config option (used directly by dgit too)
545 our $later_warning_msg = <<END;
546 Perhaps the upload is stuck in incoming. Using the version from git.
550 print STDERR "$us: @_\n", $helpmsg or die $!;
555 @ARGV or badusage "too few arguments";
556 return scalar shift @ARGV;
560 print $helpmsg or die $!;
564 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
566 our %defcfg = ('dgit.default.distro' => 'debian',
567 'dgit-suite.*-security.distro' => 'debian-security',
568 'dgit.default.username' => '',
569 'dgit.default.archive-query-default-component' => 'main',
570 'dgit.default.ssh' => 'ssh',
571 'dgit.default.archive-query' => 'madison:',
572 'dgit.default.sshpsql-dbname' => 'service=projectb',
573 'dgit.default.aptget-components' => 'main',
574 'dgit.default.dgit-tag-format' => 'new,old,maint',
575 # old means "repo server accepts pushes with old dgit tags"
576 # new means "repo server accepts pushes with new dgit tags"
577 # maint means "repo server accepts split brain pushes"
578 # hist means "repo server may have old pushes without new tag"
579 # ("hist" is implied by "old")
580 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
581 'dgit-distro.debian.git-check' => 'url',
582 'dgit-distro.debian.git-check-suffix' => '/info/refs',
583 'dgit-distro.debian.new-private-pushers' => 't',
584 'dgit-distro.debian/push.git-url' => '',
585 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
586 'dgit-distro.debian/push.git-user-force' => 'dgit',
587 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
588 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
589 'dgit-distro.debian/push.git-create' => 'true',
590 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
591 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
592 # 'dgit-distro.debian.archive-query-tls-key',
593 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
594 # ^ this does not work because curl is broken nowadays
595 # Fixing #790093 properly will involve providing providing the key
596 # in some pacagke and maybe updating these paths.
598 # 'dgit-distro.debian.archive-query-tls-curl-args',
599 # '--ca-path=/etc/ssl/ca-debian',
600 # ^ this is a workaround but works (only) on DSA-administered machines
601 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
602 'dgit-distro.debian.git-url-suffix' => '',
603 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
604 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
605 'dgit-distro.debian-security.archive-query' => 'aptget:',
606 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
607 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
608 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
609 'dgit-distro.debian-security.nominal-distro' => 'debian',
610 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
611 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
612 'dgit-distro.ubuntu.git-check' => 'false',
613 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
614 'dgit-distro.test-dummy.ssh' => "$td/ssh",
615 'dgit-distro.test-dummy.username' => "alice",
616 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
617 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
618 'dgit-distro.test-dummy.git-url' => "$td/git",
619 'dgit-distro.test-dummy.git-host' => "git",
620 'dgit-distro.test-dummy.git-path' => "$td/git",
621 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
622 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
623 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
624 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
628 our @gitcfgsources = qw(cmdline local global system);
630 sub git_slurp_config () {
631 local ($debuglevel) = $debuglevel-2;
634 # This algoritm is a bit subtle, but this is needed so that for
635 # options which we want to be single-valued, we allow the
636 # different config sources to override properly. See #835858.
637 foreach my $src (@gitcfgsources) {
638 next if $src eq 'cmdline';
639 # we do this ourselves since git doesn't handle it
641 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
644 open GITS, "-|", @cmd or die $!;
647 printdebug "=> ", (messagequote $_), "\n";
649 push @{ $gitcfgs{$src}{$`} }, $'; #';
653 or ($!==0 && $?==256)
658 sub git_get_config ($) {
660 foreach my $src (@gitcfgsources) {
661 my $l = $gitcfgs{$src}{$c};
662 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
665 @$l==1 or badcfg "multiple values for $c".
666 " (in $src git config)" if @$l > 1;
674 return undef if $c =~ /RETURN-UNDEF/;
675 my $v = git_get_config($c);
676 return $v if defined $v;
677 my $dv = $defcfg{$c};
678 return $dv if defined $dv;
680 badcfg "need value for one of: @_\n".
681 "$us: distro or suite appears not to be (properly) supported";
684 sub access_basedistro () {
685 if (defined $idistro) {
688 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
689 return $def if defined $def;
690 foreach my $src (@gitcfgsources, 'internal') {
691 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
693 foreach my $k (keys %$kl) {
694 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
696 next unless match_glob $dpat, $isuite;
700 return cfg("dgit.default.distro");
704 sub access_nomdistro () {
705 my $base = access_basedistro();
706 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
707 $r =~ m/^$distro_re$/ or badcfg
708 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
712 sub access_quirk () {
713 # returns (quirk name, distro to use instead or undef, quirk-specific info)
714 my $basedistro = access_basedistro();
715 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
717 if (defined $backports_quirk) {
718 my $re = $backports_quirk;
719 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
721 $re =~ s/\%/([-0-9a-z_]+)/
722 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
723 if ($isuite =~ m/^$re$/) {
724 return ('backports',"$basedistro-backports",$1);
727 return ('none',undef);
732 sub parse_cfg_bool ($$$) {
733 my ($what,$def,$v) = @_;
736 $v =~ m/^[ty1]/ ? 1 :
737 $v =~ m/^[fn0]/ ? 0 :
738 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
741 sub access_forpush_config () {
742 my $d = access_basedistro();
746 parse_cfg_bool('new-private-pushers', 0,
747 cfg("dgit-distro.$d.new-private-pushers",
750 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
753 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
754 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
755 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
756 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
759 sub access_forpush () {
760 $access_forpush //= access_forpush_config();
761 return $access_forpush;
765 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
766 badcfg "pushing but distro is configured readonly"
767 if access_forpush_config() eq '0';
769 $supplementary_message = <<'END' unless $we_are_responder;
770 Push failed, before we got started.
771 You can retry the push, after fixing the problem, if you like.
773 parseopts_late_defaults();
777 parseopts_late_defaults();
780 sub supplementary_message ($) {
782 if (!$we_are_responder) {
783 $supplementary_message = $msg;
785 } elsif ($protovsn >= 3) {
786 responder_send_command "supplementary-message ".length($msg)
788 print PO $msg or die $!;
792 sub access_distros () {
793 # Returns list of distros to try, in order
796 # 0. `instead of' distro name(s) we have been pointed to
797 # 1. the access_quirk distro, if any
798 # 2a. the user's specified distro, or failing that } basedistro
799 # 2b. the distro calculated from the suite }
800 my @l = access_basedistro();
802 my (undef,$quirkdistro) = access_quirk();
803 unshift @l, $quirkdistro;
804 unshift @l, $instead_distro;
805 @l = grep { defined } @l;
807 push @l, access_nomdistro();
809 if (access_forpush()) {
810 @l = map { ("$_/push", $_) } @l;
815 sub access_cfg_cfgs (@) {
818 # The nesting of these loops determines the search order. We put
819 # the key loop on the outside so that we search all the distros
820 # for each key, before going on to the next key. That means that
821 # if access_cfg is called with a more specific, and then a less
822 # specific, key, an earlier distro can override the less specific
823 # without necessarily overriding any more specific keys. (If the
824 # distro wants to override the more specific keys it can simply do
825 # so; whereas if we did the loop the other way around, it would be
826 # impossible to for an earlier distro to override a less specific
827 # key but not the more specific ones without restating the unknown
828 # values of the more specific keys.
831 # We have to deal with RETURN-UNDEF specially, so that we don't
832 # terminate the search prematurely.
834 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
837 foreach my $d (access_distros()) {
838 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
840 push @cfgs, map { "dgit.default.$_" } @realkeys;
847 my (@cfgs) = access_cfg_cfgs(@keys);
848 my $value = cfg(@cfgs);
852 sub access_cfg_bool ($$) {
853 my ($def, @keys) = @_;
854 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
857 sub string_to_ssh ($) {
859 if ($spec =~ m/\s/) {
860 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
866 sub access_cfg_ssh () {
867 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
868 if (!defined $gitssh) {
871 return string_to_ssh $gitssh;
875 sub access_runeinfo ($) {
877 return ": dgit ".access_basedistro()." $info ;";
880 sub access_someuserhost ($) {
882 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
883 defined($user) && length($user) or
884 $user = access_cfg("$some-user",'username');
885 my $host = access_cfg("$some-host");
886 return length($user) ? "$user\@$host" : $host;
889 sub access_gituserhost () {
890 return access_someuserhost('git');
893 sub access_giturl (;$) {
895 my $url = access_cfg('git-url','RETURN-UNDEF');
898 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
899 return undef unless defined $proto;
902 access_gituserhost().
903 access_cfg('git-path');
905 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
908 return "$url/$package$suffix";
911 sub parsecontrolfh ($$;$) {
912 my ($fh, $desc, $allowsigned) = @_;
913 our $dpkgcontrolhash_noissigned;
916 my %opts = ('name' => $desc);
917 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
918 $c = Dpkg::Control::Hash->new(%opts);
919 $c->parse($fh,$desc) or die "parsing of $desc failed";
920 last if $allowsigned;
921 last if $dpkgcontrolhash_noissigned;
922 my $issigned= $c->get_option('is_pgp_signed');
923 if (!defined $issigned) {
924 $dpkgcontrolhash_noissigned= 1;
925 seek $fh, 0,0 or die "seek $desc: $!";
926 } elsif ($issigned) {
927 fail "control file $desc is (already) PGP-signed. ".
928 " Note that dgit push needs to modify the .dsc and then".
929 " do the signature itself";
938 my ($file, $desc, $allowsigned) = @_;
939 my $fh = new IO::Handle;
940 open $fh, '<', $file or die "$file: $!";
941 my $c = parsecontrolfh($fh,$desc,$allowsigned);
942 $fh->error and die $!;
948 my ($dctrl,$field) = @_;
949 my $v = $dctrl->{$field};
950 return $v if defined $v;
951 fail "missing field $field in ".$dctrl->get_option('name');
955 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
956 my $p = new IO::Handle;
957 my @cmd = (qw(dpkg-parsechangelog), @_);
958 open $p, '-|', @cmd or die $!;
960 $?=0; $!=0; close $p or failedcmd @cmd;
964 sub commit_getclogp ($) {
965 # Returns the parsed changelog hashref for a particular commit
967 our %commit_getclogp_memo;
968 my $memo = $commit_getclogp_memo{$objid};
969 return $memo if $memo;
971 my $mclog = ".git/dgit/clog-$objid";
972 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
973 "$objid:debian/changelog";
974 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
979 defined $d or fail "getcwd failed: $!";
983 sub parse_dscdata () {
984 my $dscfh = new IO::File \$dscdata, '<' or die $!;
985 printdebug Dumper($dscdata) if $debuglevel>1;
986 $dsc = parsecontrolfh($dscfh,$dscurl,1);
987 printdebug Dumper($dsc) if $debuglevel>1;
992 sub archive_query ($;@) {
993 my ($method) = shift @_;
994 fail "this operation does not support multiple comma-separated suites"
996 my $query = access_cfg('archive-query','RETURN-UNDEF');
997 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1000 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1003 sub archive_query_prepend_mirror {
1004 my $m = access_cfg('mirror');
1005 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1008 sub pool_dsc_subpath ($$) {
1009 my ($vsn,$component) = @_; # $package is implict arg
1010 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1011 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1014 sub cfg_apply_map ($$$) {
1015 my ($varref, $what, $mapspec) = @_;
1016 return unless $mapspec;
1018 printdebug "config $what EVAL{ $mapspec; }\n";
1020 eval "package Dgit::Config; $mapspec;";
1025 #---------- `ftpmasterapi' archive query method (nascent) ----------
1027 sub archive_api_query_cmd ($) {
1029 my @cmd = (@curl, qw(-sS));
1030 my $url = access_cfg('archive-query-url');
1031 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1033 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1034 foreach my $key (split /\:/, $keys) {
1035 $key =~ s/\%HOST\%/$host/g;
1037 fail "for $url: stat $key: $!" unless $!==ENOENT;
1040 fail "config requested specific TLS key but do not know".
1041 " how to get curl to use exactly that EE key ($key)";
1042 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1043 # # Sadly the above line does not work because of changes
1044 # # to gnutls. The real fix for #790093 may involve
1045 # # new curl options.
1048 # Fixing #790093 properly will involve providing a value
1049 # for this on clients.
1050 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1051 push @cmd, split / /, $kargs if defined $kargs;
1053 push @cmd, $url.$subpath;
1057 sub api_query ($$;$) {
1059 my ($data, $subpath, $ok404) = @_;
1060 badcfg "ftpmasterapi archive query method takes no data part"
1062 my @cmd = archive_api_query_cmd($subpath);
1063 my $url = $cmd[$#cmd];
1064 push @cmd, qw(-w %{http_code});
1065 my $json = cmdoutput @cmd;
1066 unless ($json =~ s/\d+\d+\d$//) {
1067 failedcmd_report_cmd undef, @cmd;
1068 fail "curl failed to print 3-digit HTTP code";
1071 return undef if $code eq '404' && $ok404;
1072 fail "fetch of $url gave HTTP code $code"
1073 unless $url =~ m#^file://# or $code =~ m/^2/;
1074 return decode_json($json);
1077 sub canonicalise_suite_ftpmasterapi {
1078 my ($proto,$data) = @_;
1079 my $suites = api_query($data, 'suites');
1081 foreach my $entry (@$suites) {
1083 my $v = $entry->{$_};
1084 defined $v && $v eq $isuite;
1085 } qw(codename name);
1086 push @matched, $entry;
1088 fail "unknown suite $isuite" unless @matched;
1091 @matched==1 or die "multiple matches for suite $isuite\n";
1092 $cn = "$matched[0]{codename}";
1093 defined $cn or die "suite $isuite info has no codename\n";
1094 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1096 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1101 sub archive_query_ftpmasterapi {
1102 my ($proto,$data) = @_;
1103 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1105 my $digester = Digest::SHA->new(256);
1106 foreach my $entry (@$info) {
1108 my $vsn = "$entry->{version}";
1109 my ($ok,$msg) = version_check $vsn;
1110 die "bad version: $msg\n" unless $ok;
1111 my $component = "$entry->{component}";
1112 $component =~ m/^$component_re$/ or die "bad component";
1113 my $filename = "$entry->{filename}";
1114 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1115 or die "bad filename";
1116 my $sha256sum = "$entry->{sha256sum}";
1117 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1118 push @rows, [ $vsn, "/pool/$component/$filename",
1119 $digester, $sha256sum ];
1121 die "bad ftpmaster api response: $@\n".Dumper($entry)
1124 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1125 return archive_query_prepend_mirror @rows;
1128 sub file_in_archive_ftpmasterapi {
1129 my ($proto,$data,$filename) = @_;
1130 my $pat = $filename;
1133 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1134 my $info = api_query($data, "file_in_archive/$pat", 1);
1137 #---------- `aptget' archive query method ----------
1140 our $aptget_releasefile;
1141 our $aptget_configpath;
1143 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1144 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1146 sub aptget_cache_clean {
1147 runcmd_ordryrun_local qw(sh -ec),
1148 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1152 sub aptget_lock_acquire () {
1153 my $lockfile = "$aptget_base/lock";
1154 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1155 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1158 sub aptget_prep ($) {
1160 return if defined $aptget_base;
1162 badcfg "aptget archive query method takes no data part"
1165 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1168 ensuredir "$cache/dgit";
1170 access_cfg('aptget-cachekey','RETURN-UNDEF')
1171 // access_nomdistro();
1173 $aptget_base = "$cache/dgit/aptget";
1174 ensuredir $aptget_base;
1176 my $quoted_base = $aptget_base;
1177 die "$quoted_base contains bad chars, cannot continue"
1178 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1180 ensuredir $aptget_base;
1182 aptget_lock_acquire();
1184 aptget_cache_clean();
1186 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1187 my $sourceslist = "source.list#$cachekey";
1189 my $aptsuites = $isuite;
1190 cfg_apply_map(\$aptsuites, 'suite map',
1191 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1193 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1194 printf SRCS "deb-src %s %s %s\n",
1195 access_cfg('mirror'),
1197 access_cfg('aptget-components')
1200 ensuredir "$aptget_base/cache";
1201 ensuredir "$aptget_base/lists";
1203 open CONF, ">", $aptget_configpath or die $!;
1205 Debug::NoLocking "true";
1206 APT::Get::List-Cleanup "false";
1207 #clear APT::Update::Post-Invoke-Success;
1208 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1209 Dir::State::Lists "$quoted_base/lists";
1210 Dir::Etc::preferences "$quoted_base/preferences";
1211 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1212 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1215 foreach my $key (qw(
1218 Dir::Cache::Archives
1219 Dir::Etc::SourceParts
1220 Dir::Etc::preferencesparts
1222 ensuredir "$aptget_base/$key";
1223 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1226 my $oldatime = (time // die $!) - 1;
1227 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1228 next unless stat_exists $oldlist;
1229 my ($mtime) = (stat _)[9];
1230 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1233 runcmd_ordryrun_local aptget_aptget(), qw(update);
1236 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1237 next unless stat_exists $oldlist;
1238 my ($atime) = (stat _)[8];
1239 next if $atime == $oldatime;
1240 push @releasefiles, $oldlist;
1242 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1243 @releasefiles = @inreleasefiles if @inreleasefiles;
1244 die "apt updated wrong number of Release files (@releasefiles), erk"
1245 unless @releasefiles == 1;
1247 ($aptget_releasefile) = @releasefiles;
1250 sub canonicalise_suite_aptget {
1251 my ($proto,$data) = @_;
1254 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1256 foreach my $name (qw(Codename Suite)) {
1257 my $val = $release->{$name};
1259 printdebug "release file $name: $val\n";
1260 $val =~ m/^$suite_re$/o or fail
1261 "Release file ($aptget_releasefile) specifies intolerable $name";
1262 cfg_apply_map(\$val, 'suite rmap',
1263 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1270 sub archive_query_aptget {
1271 my ($proto,$data) = @_;
1274 ensuredir "$aptget_base/source";
1275 foreach my $old (<$aptget_base/source/*.dsc>) {
1276 unlink $old or die "$old: $!";
1279 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1280 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1281 # avoids apt-get source failing with ambiguous error code
1283 runcmd_ordryrun_local
1284 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1285 aptget_aptget(), qw(--download-only --only-source source), $package;
1287 my @dscs = <$aptget_base/source/*.dsc>;
1288 fail "apt-get source did not produce a .dsc" unless @dscs;
1289 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1291 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1294 my $uri = "file://". uri_escape $dscs[0];
1295 $uri =~ s{\%2f}{/}gi;
1296 return [ (getfield $pre_dsc, 'Version'), $uri ];
1299 #---------- `dummyapicat' archive query method ----------
1301 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1302 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1304 sub file_in_archive_dummycatapi ($$$) {
1305 my ($proto,$data,$filename) = @_;
1306 my $mirror = access_cfg('mirror');
1307 $mirror =~ s#^file://#/# or die "$mirror ?";
1309 my @cmd = (qw(sh -ec), '
1311 find -name "$2" -print0 |
1313 ', qw(x), $mirror, $filename);
1314 debugcmd "-|", @cmd;
1315 open FIA, "-|", @cmd or die $!;
1318 printdebug "| $_\n";
1319 m/^(\w+) (\S+)$/ or die "$_ ?";
1320 push @out, { sha256sum => $1, filename => $2 };
1322 close FIA or die failedcmd @cmd;
1326 #---------- `madison' archive query method ----------
1328 sub archive_query_madison {
1329 return archive_query_prepend_mirror
1330 map { [ @$_[0..1] ] } madison_get_parse(@_);
1333 sub madison_get_parse {
1334 my ($proto,$data) = @_;
1335 die unless $proto eq 'madison';
1336 if (!length $data) {
1337 $data= access_cfg('madison-distro','RETURN-UNDEF');
1338 $data //= access_basedistro();
1340 $rmad{$proto,$data,$package} ||= cmdoutput
1341 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1342 my $rmad = $rmad{$proto,$data,$package};
1345 foreach my $l (split /\n/, $rmad) {
1346 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1347 \s*( [^ \t|]+ )\s* \|
1348 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1349 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1350 $1 eq $package or die "$rmad $package ?";
1357 $component = access_cfg('archive-query-default-component');
1359 $5 eq 'source' or die "$rmad ?";
1360 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1362 return sort { -version_compare($a->[0],$b->[0]); } @out;
1365 sub canonicalise_suite_madison {
1366 # madison canonicalises for us
1367 my @r = madison_get_parse(@_);
1369 "unable to canonicalise suite using package $package".
1370 " which does not appear to exist in suite $isuite;".
1371 " --existing-package may help";
1375 sub file_in_archive_madison { return undef; }
1377 #---------- `sshpsql' archive query method ----------
1380 my ($data,$runeinfo,$sql) = @_;
1381 if (!length $data) {
1382 $data= access_someuserhost('sshpsql').':'.
1383 access_cfg('sshpsql-dbname');
1385 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1386 my ($userhost,$dbname) = ($`,$'); #';
1388 my @cmd = (access_cfg_ssh, $userhost,
1389 access_runeinfo("ssh-psql $runeinfo").
1390 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1391 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1393 open P, "-|", @cmd or die $!;
1396 printdebug(">|$_|\n");
1399 $!=0; $?=0; close P or failedcmd @cmd;
1401 my $nrows = pop @rows;
1402 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1403 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1404 @rows = map { [ split /\|/, $_ ] } @rows;
1405 my $ncols = scalar @{ shift @rows };
1406 die if grep { scalar @$_ != $ncols } @rows;
1410 sub sql_injection_check {
1411 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1414 sub archive_query_sshpsql ($$) {
1415 my ($proto,$data) = @_;
1416 sql_injection_check $isuite, $package;
1417 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1418 SELECT source.version, component.name, files.filename, files.sha256sum
1420 JOIN src_associations ON source.id = src_associations.source
1421 JOIN suite ON suite.id = src_associations.suite
1422 JOIN dsc_files ON dsc_files.source = source.id
1423 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1424 JOIN component ON component.id = files_archive_map.component_id
1425 JOIN files ON files.id = dsc_files.file
1426 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1427 AND source.source='$package'
1428 AND files.filename LIKE '%.dsc';
1430 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1431 my $digester = Digest::SHA->new(256);
1433 my ($vsn,$component,$filename,$sha256sum) = @$_;
1434 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1436 return archive_query_prepend_mirror @rows;
1439 sub canonicalise_suite_sshpsql ($$) {
1440 my ($proto,$data) = @_;
1441 sql_injection_check $isuite;
1442 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1443 SELECT suite.codename
1444 FROM suite where suite_name='$isuite' or codename='$isuite';
1446 @rows = map { $_->[0] } @rows;
1447 fail "unknown suite $isuite" unless @rows;
1448 die "ambiguous $isuite: @rows ?" if @rows>1;
1452 sub file_in_archive_sshpsql ($$$) { return undef; }
1454 #---------- `dummycat' archive query method ----------
1456 sub canonicalise_suite_dummycat ($$) {
1457 my ($proto,$data) = @_;
1458 my $dpath = "$data/suite.$isuite";
1459 if (!open C, "<", $dpath) {
1460 $!==ENOENT or die "$dpath: $!";
1461 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1465 chomp or die "$dpath: $!";
1467 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1471 sub archive_query_dummycat ($$) {
1472 my ($proto,$data) = @_;
1473 canonicalise_suite();
1474 my $dpath = "$data/package.$csuite.$package";
1475 if (!open C, "<", $dpath) {
1476 $!==ENOENT or die "$dpath: $!";
1477 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1485 printdebug "dummycat query $csuite $package $dpath | $_\n";
1486 my @row = split /\s+/, $_;
1487 @row==2 or die "$dpath: $_ ?";
1490 C->error and die "$dpath: $!";
1492 return archive_query_prepend_mirror
1493 sort { -version_compare($a->[0],$b->[0]); } @rows;
1496 sub file_in_archive_dummycat () { return undef; }
1498 #---------- tag format handling ----------
1500 sub access_cfg_tagformats () {
1501 split /\,/, access_cfg('dgit-tag-format');
1504 sub access_cfg_tagformats_can_splitbrain () {
1505 my %y = map { $_ => 1 } access_cfg_tagformats;
1506 foreach my $needtf (qw(new maint)) {
1507 next if $y{$needtf};
1513 sub need_tagformat ($$) {
1514 my ($fmt, $why) = @_;
1515 fail "need to use tag format $fmt ($why) but also need".
1516 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1517 " - no way to proceed"
1518 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1519 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1522 sub select_tagformat () {
1524 return if $tagformatfn && !$tagformat_want;
1525 die 'bug' if $tagformatfn && $tagformat_want;
1526 # ... $tagformat_want assigned after previous select_tagformat
1528 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1529 printdebug "select_tagformat supported @supported\n";
1531 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1532 printdebug "select_tagformat specified @$tagformat_want\n";
1534 my ($fmt,$why,$override) = @$tagformat_want;
1536 fail "target distro supports tag formats @supported".
1537 " but have to use $fmt ($why)"
1539 or grep { $_ eq $fmt } @supported;
1541 $tagformat_want = undef;
1543 $tagformatfn = ${*::}{"debiantag_$fmt"};
1545 fail "trying to use unknown tag format \`$fmt' ($why) !"
1546 unless $tagformatfn;
1549 #---------- archive query entrypoints and rest of program ----------
1551 sub canonicalise_suite () {
1552 return if defined $csuite;
1553 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1554 $csuite = archive_query('canonicalise_suite');
1555 if ($isuite ne $csuite) {
1556 progress "canonical suite name for $isuite is $csuite";
1558 progress "canonical suite name is $csuite";
1562 sub get_archive_dsc () {
1563 canonicalise_suite();
1564 my @vsns = archive_query('archive_query');
1565 foreach my $vinfo (@vsns) {
1566 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1567 $dscurl = $vsn_dscurl;
1568 $dscdata = url_get($dscurl);
1570 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1575 $digester->add($dscdata);
1576 my $got = $digester->hexdigest();
1578 fail "$dscurl has hash $got but".
1579 " archive told us to expect $digest";
1582 my $fmt = getfield $dsc, 'Format';
1583 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1584 "unsupported source format $fmt, sorry";
1586 $dsc_checked = !!$digester;
1587 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1591 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1594 sub check_for_git ();
1595 sub check_for_git () {
1597 my $how = access_cfg('git-check');
1598 if ($how eq 'ssh-cmd') {
1600 (access_cfg_ssh, access_gituserhost(),
1601 access_runeinfo("git-check $package").
1602 " set -e; cd ".access_cfg('git-path').";".
1603 " if test -d $package.git; then echo 1; else echo 0; fi");
1604 my $r= cmdoutput @cmd;
1605 if (defined $r and $r =~ m/^divert (\w+)$/) {
1607 my ($usedistro,) = access_distros();
1608 # NB that if we are pushing, $usedistro will be $distro/push
1609 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1610 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1611 progress "diverting to $divert (using config for $instead_distro)";
1612 return check_for_git();
1614 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1616 } elsif ($how eq 'url') {
1617 my $prefix = access_cfg('git-check-url','git-url');
1618 my $suffix = access_cfg('git-check-suffix','git-suffix',
1619 'RETURN-UNDEF') // '.git';
1620 my $url = "$prefix/$package$suffix";
1621 my @cmd = (@curl, qw(-sS -I), $url);
1622 my $result = cmdoutput @cmd;
1623 $result =~ s/^\S+ 200 .*\n\r?\n//;
1624 # curl -sS -I with https_proxy prints
1625 # HTTP/1.0 200 Connection established
1626 $result =~ m/^\S+ (404|200) /s or
1627 fail "unexpected results from git check query - ".
1628 Dumper($prefix, $result);
1630 if ($code eq '404') {
1632 } elsif ($code eq '200') {
1637 } elsif ($how eq 'true') {
1639 } elsif ($how eq 'false') {
1642 badcfg "unknown git-check \`$how'";
1646 sub create_remote_git_repo () {
1647 my $how = access_cfg('git-create');
1648 if ($how eq 'ssh-cmd') {
1650 (access_cfg_ssh, access_gituserhost(),
1651 access_runeinfo("git-create $package").
1652 "set -e; cd ".access_cfg('git-path').";".
1653 " cp -a _template $package.git");
1654 } elsif ($how eq 'true') {
1657 badcfg "unknown git-create \`$how'";
1661 our ($dsc_hash,$lastpush_mergeinput);
1662 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1664 our $ud = '.git/dgit/unpack';
1674 sub mktree_in_ud_here () {
1675 runcmd qw(git init -q);
1676 runcmd qw(git config gc.auto 0);
1677 rmtree('.git/objects');
1678 symlink '../../../../objects','.git/objects' or die $!;
1681 sub git_write_tree () {
1682 my $tree = cmdoutput @git, qw(write-tree);
1683 $tree =~ m/^\w+$/ or die "$tree ?";
1687 sub git_add_write_tree () {
1688 runcmd @git, qw(add -Af .);
1689 return git_write_tree();
1692 sub remove_stray_gits ($) {
1694 my @gitscmd = qw(find -name .git -prune -print0);
1695 debugcmd "|",@gitscmd;
1696 open GITS, "-|", @gitscmd or die $!;
1701 print STDERR "$us: warning: removing from $what: ",
1702 (messagequote $_), "\n";
1706 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1709 sub mktree_in_ud_from_only_subdir ($;$) {
1710 my ($what,$raw) = @_;
1712 # changes into the subdir
1714 die "expected one subdir but found @dirs ?" unless @dirs==1;
1715 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1719 remove_stray_gits($what);
1720 mktree_in_ud_here();
1722 my ($format, $fopts) = get_source_format();
1723 if (madformat($format)) {
1728 my $tree=git_add_write_tree();
1729 return ($tree,$dir);
1732 our @files_csum_info_fields =
1733 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1734 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1735 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1737 sub dsc_files_info () {
1738 foreach my $csumi (@files_csum_info_fields) {
1739 my ($fname, $module, $method) = @$csumi;
1740 my $field = $dsc->{$fname};
1741 next unless defined $field;
1742 eval "use $module; 1;" or die $@;
1744 foreach (split /\n/, $field) {
1746 m/^(\w+) (\d+) (\S+)$/ or
1747 fail "could not parse .dsc $fname line \`$_'";
1748 my $digester = eval "$module"."->$method;" or die $@;
1753 Digester => $digester,
1758 fail "missing any supported Checksums-* or Files field in ".
1759 $dsc->get_option('name');
1763 map { $_->{Filename} } dsc_files_info();
1766 sub files_compare_inputs (@) {
1771 my $showinputs = sub {
1772 return join "; ", map { $_->get_option('name') } @$inputs;
1775 foreach my $in (@$inputs) {
1777 my $in_name = $in->get_option('name');
1779 printdebug "files_compare_inputs $in_name\n";
1781 foreach my $csumi (@files_csum_info_fields) {
1782 my ($fname) = @$csumi;
1783 printdebug "files_compare_inputs $in_name $fname\n";
1785 my $field = $in->{$fname};
1786 next unless defined $field;
1789 foreach (split /\n/, $field) {
1792 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1793 fail "could not parse $in_name $fname line \`$_'";
1795 printdebug "files_compare_inputs $in_name $fname $f\n";
1799 my $re = \ $record{$f}{$fname};
1801 $fchecked{$f}{$in_name} = 1;
1803 fail "hash or size of $f varies in $fname fields".
1804 " (between: ".$showinputs->().")";
1809 @files = sort @files;
1810 $expected_files //= \@files;
1811 "@$expected_files" eq "@files" or
1812 fail "file list in $in_name varies between hash fields!";
1815 fail "$in_name has no files list field(s)";
1817 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1820 grep { keys %$_ == @$inputs-1 } values %fchecked
1821 or fail "no file appears in all file lists".
1822 " (looked in: ".$showinputs->().")";
1825 sub is_orig_file_in_dsc ($$) {
1826 my ($f, $dsc_files_info) = @_;
1827 return 0 if @$dsc_files_info <= 1;
1828 # One file means no origs, and the filename doesn't have a "what
1829 # part of dsc" component. (Consider versions ending `.orig'.)
1830 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1834 sub is_orig_file_of_vsn ($$) {
1835 my ($f, $upstreamvsn) = @_;
1836 my $base = srcfn $upstreamvsn, '';
1837 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1841 sub changes_update_origs_from_dsc ($$$$) {
1842 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1844 printdebug "checking origs needed ($upstreamvsn)...\n";
1845 $_ = getfield $changes, 'Files';
1846 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1847 fail "cannot find section/priority from .changes Files field";
1848 my $placementinfo = $1;
1850 printdebug "checking origs needed placement '$placementinfo'...\n";
1851 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1852 $l =~ m/\S+$/ or next;
1854 printdebug "origs $file | $l\n";
1855 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1856 printdebug "origs $file is_orig\n";
1857 my $have = archive_query('file_in_archive', $file);
1858 if (!defined $have) {
1860 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1866 printdebug "origs $file \$#\$have=$#$have\n";
1867 foreach my $h (@$have) {
1870 foreach my $csumi (@files_csum_info_fields) {
1871 my ($fname, $module, $method, $archivefield) = @$csumi;
1872 next unless defined $h->{$archivefield};
1873 $_ = $dsc->{$fname};
1874 next unless defined;
1875 m/^(\w+) .* \Q$file\E$/m or
1876 fail ".dsc $fname missing entry for $file";
1877 if ($h->{$archivefield} eq $1) {
1881 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1884 die "$file ".Dumper($h)." ?!" if $same && @differ;
1887 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1890 printdebug "origs $file f.same=$found_same".
1891 " #f._differ=$#found_differ\n";
1892 if (@found_differ && !$found_same) {
1894 "archive contains $file with different checksum",
1897 # Now we edit the changes file to add or remove it
1898 foreach my $csumi (@files_csum_info_fields) {
1899 my ($fname, $module, $method, $archivefield) = @$csumi;
1900 next unless defined $changes->{$fname};
1902 # in archive, delete from .changes if it's there
1903 $changed{$file} = "removed" if
1904 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1905 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1906 # not in archive, but it's here in the .changes
1908 my $dsc_data = getfield $dsc, $fname;
1909 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1911 $extra =~ s/ \d+ /$&$placementinfo /
1912 or die "$fname $extra >$dsc_data< ?"
1913 if $fname eq 'Files';
1914 $changes->{$fname} .= "\n". $extra;
1915 $changed{$file} = "added";
1920 foreach my $file (keys %changed) {
1922 "edited .changes for archive .orig contents: %s %s",
1923 $changed{$file}, $file;
1925 my $chtmp = "$changesfile.tmp";
1926 $changes->save($chtmp);
1928 rename $chtmp,$changesfile or die "$changesfile $!";
1930 progress "[new .changes left in $changesfile]";
1933 progress "$changesfile already has appropriate .orig(s) (if any)";
1937 sub make_commit ($) {
1939 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1942 sub make_commit_text ($) {
1945 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1947 print Dumper($text) if $debuglevel > 1;
1948 my $child = open2($out, $in, @cmd) or die $!;
1951 print $in $text or die $!;
1952 close $in or die $!;
1954 $h =~ m/^\w+$/ or die;
1956 printdebug "=> $h\n";
1959 waitpid $child, 0 == $child or die "$child $!";
1960 $? and failedcmd @cmd;
1964 sub clogp_authline ($) {
1966 my $author = getfield $clogp, 'Maintainer';
1967 $author =~ s#,.*##ms;
1968 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1969 my $authline = "$author $date";
1970 $authline =~ m/$git_authline_re/o or
1971 fail "unexpected commit author line format \`$authline'".
1972 " (was generated from changelog Maintainer field)";
1973 return ($1,$2,$3) if wantarray;
1977 sub vendor_patches_distro ($$) {
1978 my ($checkdistro, $what) = @_;
1979 return unless defined $checkdistro;
1981 my $series = "debian/patches/\L$checkdistro\E.series";
1982 printdebug "checking for vendor-specific $series ($what)\n";
1984 if (!open SERIES, "<", $series) {
1985 die "$series $!" unless $!==ENOENT;
1994 Unfortunately, this source package uses a feature of dpkg-source where
1995 the same source package unpacks to different source code on different
1996 distros. dgit cannot safely operate on such packages on affected
1997 distros, because the meaning of source packages is not stable.
1999 Please ask the distro/maintainer to remove the distro-specific series
2000 files and use a different technique (if necessary, uploading actually
2001 different packages, if different distros are supposed to have
2005 fail "Found active distro-specific series file for".
2006 " $checkdistro ($what): $series, cannot continue";
2008 die "$series $!" if SERIES->error;
2012 sub check_for_vendor_patches () {
2013 # This dpkg-source feature doesn't seem to be documented anywhere!
2014 # But it can be found in the changelog (reformatted):
2016 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2017 # Author: Raphael Hertzog <hertzog@debian.org>
2018 # Date: Sun Oct 3 09:36:48 2010 +0200
2020 # dpkg-source: correctly create .pc/.quilt_series with alternate
2023 # If you have debian/patches/ubuntu.series and you were
2024 # unpacking the source package on ubuntu, quilt was still
2025 # directed to debian/patches/series instead of
2026 # debian/patches/ubuntu.series.
2028 # debian/changelog | 3 +++
2029 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2030 # 2 files changed, 6 insertions(+), 1 deletion(-)
2033 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2034 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2035 "Dpkg::Vendor \`current vendor'");
2036 vendor_patches_distro(access_basedistro(),
2037 "(base) distro being accessed");
2038 vendor_patches_distro(access_nomdistro(),
2039 "(nominal) distro being accessed");
2042 sub generate_commits_from_dsc () {
2043 # See big comment in fetch_from_archive, below.
2044 # See also README.dsc-import.
2048 my @dfi = dsc_files_info();
2049 foreach my $fi (@dfi) {
2050 my $f = $fi->{Filename};
2051 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2053 printdebug "considering linking $f: ";
2055 link_ltarget "../../../../$f", $f
2056 or ((printdebug "($!) "), 0)
2060 printdebug "linked.\n";
2062 complete_file_from_dsc('.', $fi)
2065 if (is_orig_file_in_dsc($f, \@dfi)) {
2066 link $f, "../../../../$f"
2072 # We unpack and record the orig tarballs first, so that we only
2073 # need disk space for one private copy of the unpacked source.
2074 # But we can't make them into commits until we have the metadata
2075 # from the debian/changelog, so we record the tree objects now and
2076 # make them into commits later.
2078 my $upstreamv = upstreamversion $dsc->{version};
2079 my $orig_f_base = srcfn $upstreamv, '';
2081 foreach my $fi (@dfi) {
2082 # We actually import, and record as a commit, every tarball
2083 # (unless there is only one file, in which case there seems
2086 my $f = $fi->{Filename};
2087 printdebug "import considering $f ";
2088 (printdebug "only one dfi\n"), next if @dfi == 1;
2089 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2090 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2094 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2096 printdebug "Y ", (join ' ', map { $_//"(none)" }
2097 $compr_ext, $orig_f_part
2100 my $input = new IO::File $f, '<' or die "$f $!";
2104 if (defined $compr_ext) {
2106 Dpkg::Compression::compression_guess_from_filename $f;
2107 fail "Dpkg::Compression cannot handle file $f in source package"
2108 if defined $compr_ext && !defined $cname;
2110 new Dpkg::Compression::Process compression => $cname;
2111 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2112 my $compr_fh = new IO::Handle;
2113 my $compr_pid = open $compr_fh, "-|" // die $!;
2115 open STDIN, "<&", $input or die $!;
2117 die "dgit (child): exec $compr_cmd[0]: $!\n";
2122 rmtree "_unpack-tar";
2123 mkdir "_unpack-tar" or die $!;
2124 my @tarcmd = qw(tar -x -f -
2125 --no-same-owner --no-same-permissions
2126 --no-acls --no-xattrs --no-selinux);
2127 my $tar_pid = fork // die $!;
2129 chdir "_unpack-tar" or die $!;
2130 open STDIN, "<&", $input or die $!;
2132 die "dgit (child): exec $tarcmd[0]: $!";
2134 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2135 !$? or failedcmd @tarcmd;
2138 (@compr_cmd ? failedcmd @compr_cmd
2140 # finally, we have the results in "tarball", but maybe
2141 # with the wrong permissions
2143 runcmd qw(chmod -R +rwX _unpack-tar);
2144 changedir "_unpack-tar";
2145 remove_stray_gits($f);
2146 mktree_in_ud_here();
2148 my ($tree) = git_add_write_tree();
2149 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2150 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2152 printdebug "one subtree $1\n";
2154 printdebug "multiple subtrees\n";
2157 rmtree "_unpack-tar";
2159 my $ent = [ $f, $tree ];
2161 Orig => !!$orig_f_part,
2162 Sort => (!$orig_f_part ? 2 :
2163 $orig_f_part =~ m/-/g ? 1 :
2171 # put any without "_" first (spec is not clear whether files
2172 # are always in the usual order). Tarballs without "_" are
2173 # the main orig or the debian tarball.
2174 $a->{Sort} <=> $b->{Sort} or
2178 my $any_orig = grep { $_->{Orig} } @tartrees;
2180 my $dscfn = "$package.dsc";
2182 my $treeimporthow = 'package';
2184 open D, ">", $dscfn or die "$dscfn: $!";
2185 print D $dscdata or die "$dscfn: $!";
2186 close D or die "$dscfn: $!";
2187 my @cmd = qw(dpkg-source);
2188 push @cmd, '--no-check' if $dsc_checked;
2189 if (madformat $dsc->{format}) {
2190 push @cmd, '--skip-patches';
2191 $treeimporthow = 'unpatched';
2193 push @cmd, qw(-x --), $dscfn;
2196 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2197 if (madformat $dsc->{format}) {
2198 check_for_vendor_patches();
2202 if (madformat $dsc->{format}) {
2203 my @pcmd = qw(dpkg-source --before-build .);
2204 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2206 $dappliedtree = git_add_write_tree();
2209 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2210 debugcmd "|",@clogcmd;
2211 open CLOGS, "-|", @clogcmd or die $!;
2216 printdebug "import clog search...\n";
2219 my $stanzatext = do { local $/=""; <CLOGS>; };
2220 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2221 last if !defined $stanzatext;
2223 my $desc = "package changelog, entry no.$.";
2224 open my $stanzafh, "<", \$stanzatext or die;
2225 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2226 $clogp //= $thisstanza;
2228 printdebug "import clog $thisstanza->{version} $desc...\n";
2230 last if !$any_orig; # we don't need $r1clogp
2232 # We look for the first (most recent) changelog entry whose
2233 # version number is lower than the upstream version of this
2234 # package. Then the last (least recent) previous changelog
2235 # entry is treated as the one which introduced this upstream
2236 # version and used for the synthetic commits for the upstream
2239 # One might think that a more sophisticated algorithm would be
2240 # necessary. But: we do not want to scan the whole changelog
2241 # file. Stopping when we see an earlier version, which
2242 # necessarily then is an earlier upstream version, is the only
2243 # realistic way to do that. Then, either the earliest
2244 # changelog entry we have seen so far is indeed the earliest
2245 # upload of this upstream version; or there are only changelog
2246 # entries relating to later upstream versions (which is not
2247 # possible unless the changelog and .dsc disagree about the
2248 # version). Then it remains to choose between the physically
2249 # last entry in the file, and the one with the lowest version
2250 # number. If these are not the same, we guess that the
2251 # versions were created in a non-monotic order rather than
2252 # that the changelog entries have been misordered.
2254 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2256 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2257 $r1clogp = $thisstanza;
2259 printdebug "import clog $r1clogp->{version} becomes r1\n";
2261 die $! if CLOGS->error;
2262 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2264 $clogp or fail "package changelog has no entries!";
2266 my $authline = clogp_authline $clogp;
2267 my $changes = getfield $clogp, 'Changes';
2268 my $cversion = getfield $clogp, 'Version';
2271 $r1clogp //= $clogp; # maybe there's only one entry;
2272 my $r1authline = clogp_authline $r1clogp;
2273 # Strictly, r1authline might now be wrong if it's going to be
2274 # unused because !$any_orig. Whatever.
2276 printdebug "import tartrees authline $authline\n";
2277 printdebug "import tartrees r1authline $r1authline\n";
2279 foreach my $tt (@tartrees) {
2280 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2282 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2285 committer $r1authline
2289 [dgit import orig $tt->{F}]
2297 [dgit import tarball $package $cversion $tt->{F}]
2302 printdebug "import main commit\n";
2304 open C, ">../commit.tmp" or die $!;
2305 print C <<END or die $!;
2308 print C <<END or die $! foreach @tartrees;
2311 print C <<END or die $!;
2317 [dgit import $treeimporthow $package $cversion]
2321 my $rawimport_hash = make_commit qw(../commit.tmp);
2323 if (madformat $dsc->{format}) {
2324 printdebug "import apply patches...\n";
2326 # regularise the state of the working tree so that
2327 # the checkout of $rawimport_hash works nicely.
2328 my $dappliedcommit = make_commit_text(<<END);
2335 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2337 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2339 # We need the answers to be reproducible
2340 my @authline = clogp_authline($clogp);
2341 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2342 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2343 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2344 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2345 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2346 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2348 my $path = $ENV{PATH} or die;
2350 foreach my $use_absurd (qw(0 1)) {
2351 runcmd @git, qw(checkout -q unpa);
2352 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2353 local $ENV{PATH} = $path;
2356 progress "warning: $@";
2357 $path = "$absurdity:$path";
2358 progress "$us: trying slow absurd-git-apply...";
2359 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2364 die "forbid absurd git-apply\n" if $use_absurd
2365 && forceing [qw(import-gitapply-no-absurd)];
2366 die "only absurd git-apply!\n" if !$use_absurd
2367 && forceing [qw(import-gitapply-absurd)];
2369 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2370 local $ENV{PATH} = $path if $use_absurd;
2372 my @showcmd = (gbp_pq, qw(import));
2373 my @realcmd = shell_cmd
2374 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2375 debugcmd "+",@realcmd;
2376 if (system @realcmd) {
2377 die +(shellquote @showcmd).
2379 failedcmd_waitstatus()."\n";
2382 my $gapplied = git_rev_parse('HEAD');
2383 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2384 $gappliedtree eq $dappliedtree or
2386 gbp-pq import and dpkg-source disagree!
2387 gbp-pq import gave commit $gapplied
2388 gbp-pq import gave tree $gappliedtree
2389 dpkg-source --before-build gave tree $dappliedtree
2391 $rawimport_hash = $gapplied;
2396 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2401 progress "synthesised git commit from .dsc $cversion";
2403 my $rawimport_mergeinput = {
2404 Commit => $rawimport_hash,
2405 Info => "Import of source package",
2407 my @output = ($rawimport_mergeinput);
2409 if ($lastpush_mergeinput) {
2410 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2411 my $oversion = getfield $oldclogp, 'Version';
2413 version_compare($oversion, $cversion);
2415 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2416 { Message => <<END, ReverseParents => 1 });
2417 Record $package ($cversion) in archive suite $csuite
2419 } elsif ($vcmp > 0) {
2420 print STDERR <<END or die $!;
2422 Version actually in archive: $cversion (older)
2423 Last version pushed with dgit: $oversion (newer or same)
2426 @output = $lastpush_mergeinput;
2428 # Same version. Use what's in the server git branch,
2429 # discarding our own import. (This could happen if the
2430 # server automatically imports all packages into git.)
2431 @output = $lastpush_mergeinput;
2434 changedir '../../../..';
2439 sub complete_file_from_dsc ($$) {
2440 our ($dstdir, $fi) = @_;
2441 # Ensures that we have, in $dir, the file $fi, with the correct
2442 # contents. (Downloading it from alongside $dscurl if necessary.)
2444 my $f = $fi->{Filename};
2445 my $tf = "$dstdir/$f";
2448 if (stat_exists $tf) {
2449 progress "using existing $f";
2451 printdebug "$tf does not exist, need to fetch\n";
2453 $furl =~ s{/[^/]+$}{};
2455 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2456 die "$f ?" if $f =~ m#/#;
2457 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2458 return 0 if !act_local();
2462 open F, "<", "$tf" or die "$tf: $!";
2463 $fi->{Digester}->reset();
2464 $fi->{Digester}->addfile(*F);
2465 F->error and die $!;
2466 my $got = $fi->{Digester}->hexdigest();
2467 $got eq $fi->{Hash} or
2468 fail "file $f has hash $got but .dsc".
2469 " demands hash $fi->{Hash} ".
2470 ($downloaded ? "(got wrong file from archive!)"
2471 : "(perhaps you should delete this file?)");
2476 sub ensure_we_have_orig () {
2477 my @dfi = dsc_files_info();
2478 foreach my $fi (@dfi) {
2479 my $f = $fi->{Filename};
2480 next unless is_orig_file_in_dsc($f, \@dfi);
2481 complete_file_from_dsc('..', $fi)
2486 #---------- git fetch ----------
2488 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2489 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2491 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2492 # locally fetched refs because they have unhelpful names and clutter
2493 # up gitk etc. So we track whether we have "used up" head ref (ie,
2494 # whether we have made another local ref which refers to this object).
2496 # (If we deleted them unconditionally, then we might end up
2497 # re-fetching the same git objects each time dgit fetch was run.)
2499 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
2500 # in git_fetch_us to fetch the refs in question, and possibly a call
2501 # to lrfetchref_used.
2503 our (%lrfetchrefs_f, %lrfetchrefs_d);
2504 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2506 sub lrfetchref_used ($) {
2507 my ($fullrefname) = @_;
2508 my $objid = $lrfetchrefs_f{$fullrefname};
2509 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2512 sub git_lrfetch_sane {
2515 # This is rather miserable:
2516 # When git fetch --prune is passed a fetchspec ending with a *,
2517 # it does a plausible thing. If there is no * then:
2518 # - it matches subpaths too, even if the supplied refspec
2519 # starts refs, and behaves completely madly if the source
2520 # has refs/refs/something. (See, for example, Debian #NNNN.)
2521 # - if there is no matching remote ref, it bombs out the whole
2523 # We want to fetch a fixed ref, and we don't know in advance
2524 # if it exists, so this is not suitable.
2526 # Our workaround is to use git ls-remote. git ls-remote has its
2527 # own qairks. Notably, it has the absurd multi-tail-matching
2528 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2529 # refs/refs/foo etc.
2531 # Also, we want an idempotent snapshot, but we have to make two
2532 # calls to the remote: one to git ls-remote and to git fetch. The
2533 # solution is use git ls-remote to obtain a target state, and
2534 # git fetch to try to generate it. If we don't manage to generate
2535 # the target state, we try again.
2537 printdebug "git_fetch_us specs @specs\n";
2539 my $specre = join '|', map {
2545 printdebug "git_fetch_us specre=$specre\n";
2546 my $wanted_rref = sub {
2548 return m/^(?:$specre)$/o;
2551 my $fetch_iteration = 0;
2554 printdebug "git_fetch_us iteration $fetch_iteration\n";
2555 if (++$fetch_iteration > 10) {
2556 fail "too many iterations trying to get sane fetch!";
2559 my @look = map { "refs/$_" } @specs;
2560 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2564 open GITLS, "-|", @lcmd or die $!;
2566 printdebug "=> ", $_;
2567 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2568 my ($objid,$rrefname) = ($1,$2);
2569 if (!$wanted_rref->($rrefname)) {
2571 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2575 $wantr{$rrefname} = $objid;
2578 close GITLS or failedcmd @lcmd;
2580 # OK, now %want is exactly what we want for refs in @specs
2582 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2583 "+refs/$_:".lrfetchrefs."/$_";
2586 printdebug "git_fetch_us fspecs @fspecs\n";
2588 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2589 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2592 %lrfetchrefs_f = ();
2595 git_for_each_ref(lrfetchrefs, sub {
2596 my ($objid,$objtype,$lrefname,$reftail) = @_;
2597 $lrfetchrefs_f{$lrefname} = $objid;
2598 $objgot{$objid} = 1;
2601 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2602 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2603 if (!exists $wantr{$rrefname}) {
2604 if ($wanted_rref->($rrefname)) {
2606 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2610 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2613 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2614 delete $lrfetchrefs_f{$lrefname};
2618 foreach my $rrefname (sort keys %wantr) {
2619 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2620 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2621 my $want = $wantr{$rrefname};
2622 next if $got eq $want;
2623 if (!defined $objgot{$want}) {
2625 warning: git ls-remote suggests we want $lrefname
2626 warning: and it should refer to $want
2627 warning: but git fetch didn't fetch that object to any relevant ref.
2628 warning: This may be due to a race with someone updating the server.
2629 warning: Will try again...
2631 next FETCH_ITERATION;
2634 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2636 runcmd_ordryrun_local @git, qw(update-ref -m),
2637 "dgit fetch git fetch fixup", $lrefname, $want;
2638 $lrfetchrefs_f{$lrefname} = $want;
2642 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2643 Dumper(\%lrfetchrefs_f);
2646 sub git_fetch_us () {
2647 # Want to fetch only what we are going to use, unless
2648 # deliberately-not-ff, in which case we must fetch everything.
2650 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2652 (quiltmode_splitbrain
2653 ? (map { $_->('*',access_nomdistro) }
2654 \&debiantag_new, \&debiantag_maintview)
2655 : debiantags('*',access_nomdistro));
2656 push @specs, server_branch($csuite);
2657 push @specs, $rewritemap;
2658 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2660 git_lrfetch_sane @specs;
2663 my @tagpats = debiantags('*',access_nomdistro);
2665 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2666 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2667 printdebug "currently $fullrefname=$objid\n";
2668 $here{$fullrefname} = $objid;
2670 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2671 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2672 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2673 printdebug "offered $lref=$objid\n";
2674 if (!defined $here{$lref}) {
2675 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2676 runcmd_ordryrun_local @upd;
2677 lrfetchref_used $fullrefname;
2678 } elsif ($here{$lref} eq $objid) {
2679 lrfetchref_used $fullrefname;
2682 "Not updateting $lref from $here{$lref} to $objid.\n";
2687 #---------- dsc and archive handling ----------
2689 sub mergeinfo_getclogp ($) {
2690 # Ensures thit $mi->{Clogp} exists and returns it
2692 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2695 sub mergeinfo_version ($) {
2696 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2699 sub fetch_from_archive_record_1 ($) {
2701 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2702 'DGIT_ARCHIVE', $hash;
2703 cmdoutput @git, qw(log -n2), $hash;
2704 # ... gives git a chance to complain if our commit is malformed
2707 sub fetch_from_archive_record_2 ($) {
2709 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2713 dryrun_report @upd_cmd;
2717 sub parse_dsc_field ($$) {
2718 my ($dsc, $what) = @_;
2720 foreach my $field (@ourdscfield) {
2721 $f = $dsc->{$field};
2725 progress "$what: NO git hash";
2726 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2727 = $f =~ m/^(\w+) ($distro_re) ($versiontag_re) (\S+)(?:\s|$)/) {
2728 progress "$what: specified git info ($dsc_distro)";
2729 $dsc_hint_tag = [ $dsc_hint_tag ];
2730 } elsif ($f =~ m/^\w+\s*$/) {
2732 $dsc_distro //= 'debian';
2733 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2735 progress "$what: specified git hash";
2737 fail "$what: invalid Dgit info";
2741 sub resolve_dsc_field_commit ($$) {
2742 my ($already_distro, $already_mapref) = @_;
2744 return unless defined $dsc_hash;
2746 my $rewritemapdata = git_cat_file $already_mapref.':map';
2747 if (defined $rewritemapdata
2748 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2749 progress "server's git history rewrite map contains a relevant entry!";
2752 if (defined $dsc_hash) {
2753 progress "using rewritten git hash in place of .dsc value";
2755 progress "server data says .dsc hash is to be disregarded";
2760 sub fetch_from_archive () {
2761 ensure_setup_existing_tree();
2763 # Ensures that lrref() is what is actually in the archive, one way
2764 # or another, according to us - ie this client's
2765 # appropritaely-updated archive view. Also returns the commit id.
2766 # If there is nothing in the archive, leaves lrref alone and
2767 # returns undef. git_fetch_us must have already been called.
2771 parse_dsc_field($dsc, 'last upload to archive');
2772 resolve_dsc_field_commit access_basedistro,
2773 lrfetchrefs."/".$rewritemap
2775 progress "no version available from the archive";
2778 # If the archive's .dsc has a Dgit field, there are three
2779 # relevant git commitids we need to choose between and/or merge
2781 # 1. $dsc_hash: the Dgit field from the archive
2782 # 2. $lastpush_hash: the suite branch on the dgit git server
2783 # 3. $lastfetch_hash: our local tracking brach for the suite
2785 # These may all be distinct and need not be in any fast forward
2788 # If the dsc was pushed to this suite, then the server suite
2789 # branch will have been updated; but it might have been pushed to
2790 # a different suite and copied by the archive. Conversely a more
2791 # recent version may have been pushed with dgit but not appeared
2792 # in the archive (yet).
2794 # $lastfetch_hash may be awkward because archive imports
2795 # (particularly, imports of Dgit-less .dscs) are performed only as
2796 # needed on individual clients, so different clients may perform a
2797 # different subset of them - and these imports are only made
2798 # public during push. So $lastfetch_hash may represent a set of
2799 # imports different to a subsequent upload by a different dgit
2802 # Our approach is as follows:
2804 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2805 # descendant of $dsc_hash, then it was pushed by a dgit user who
2806 # had based their work on $dsc_hash, so we should prefer it.
2807 # Otherwise, $dsc_hash was installed into this suite in the
2808 # archive other than by a dgit push, and (necessarily) after the
2809 # last dgit push into that suite (since a dgit push would have
2810 # been descended from the dgit server git branch); thus, in that
2811 # case, we prefer the archive's version (and produce a
2812 # pseudo-merge to overwrite the dgit server git branch).
2814 # (If there is no Dgit field in the archive's .dsc then
2815 # generate_commit_from_dsc uses the version numbers to decide
2816 # whether the suite branch or the archive is newer. If the suite
2817 # branch is newer it ignores the archive's .dsc; otherwise it
2818 # generates an import of the .dsc, and produces a pseudo-merge to
2819 # overwrite the suite branch with the archive contents.)
2821 # The outcome of that part of the algorithm is the `public view',
2822 # and is same for all dgit clients: it does not depend on any
2823 # unpublished history in the local tracking branch.
2825 # As between the public view and the local tracking branch: The
2826 # local tracking branch is only updated by dgit fetch, and
2827 # whenever dgit fetch runs it includes the public view in the
2828 # local tracking branch. Therefore if the public view is not
2829 # descended from the local tracking branch, the local tracking
2830 # branch must contain history which was imported from the archive
2831 # but never pushed; and, its tip is now out of date. So, we make
2832 # a pseudo-merge to overwrite the old imports and stitch the old
2835 # Finally: we do not necessarily reify the public view (as
2836 # described above). This is so that we do not end up stacking two
2837 # pseudo-merges. So what we actually do is figure out the inputs
2838 # to any public view pseudo-merge and put them in @mergeinputs.
2841 # $mergeinputs[]{Commit}
2842 # $mergeinputs[]{Info}
2843 # $mergeinputs[0] is the one whose tree we use
2844 # @mergeinputs is in the order we use in the actual commit)
2847 # $mergeinputs[]{Message} is a commit message to use
2848 # $mergeinputs[]{ReverseParents} if def specifies that parent
2849 # list should be in opposite order
2850 # Such an entry has no Commit or Info. It applies only when found
2851 # in the last entry. (This ugliness is to support making
2852 # identical imports to previous dgit versions.)
2854 my $lastpush_hash = git_get_ref(lrfetchref());
2855 printdebug "previous reference hash=$lastpush_hash\n";
2856 $lastpush_mergeinput = $lastpush_hash && {
2857 Commit => $lastpush_hash,
2858 Info => "dgit suite branch on dgit git server",
2861 my $lastfetch_hash = git_get_ref(lrref());
2862 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2863 my $lastfetch_mergeinput = $lastfetch_hash && {
2864 Commit => $lastfetch_hash,
2865 Info => "dgit client's archive history view",
2868 my $dsc_mergeinput = $dsc_hash && {
2869 Commit => $dsc_hash,
2870 Info => "Dgit field in .dsc from archive",
2874 my $del_lrfetchrefs = sub {
2877 printdebug "del_lrfetchrefs...\n";
2878 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2879 my $objid = $lrfetchrefs_d{$fullrefname};
2880 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2882 $gur ||= new IO::Handle;
2883 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2885 printf $gur "delete %s %s\n", $fullrefname, $objid;
2888 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2892 if (defined $dsc_hash) {
2893 ensure_we_have_orig();
2894 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2895 @mergeinputs = $dsc_mergeinput
2896 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2897 print STDERR <<END or die $!;
2899 Git commit in archive is behind the last version allegedly pushed/uploaded.
2900 Commit referred to by archive: $dsc_hash
2901 Last version pushed with dgit: $lastpush_hash
2904 @mergeinputs = ($lastpush_mergeinput);
2906 # Archive has .dsc which is not a descendant of the last dgit
2907 # push. This can happen if the archive moves .dscs about.
2908 # Just follow its lead.
2909 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2910 progress "archive .dsc names newer git commit";
2911 @mergeinputs = ($dsc_mergeinput);
2913 progress "archive .dsc names other git commit, fixing up";
2914 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2918 @mergeinputs = generate_commits_from_dsc();
2919 # We have just done an import. Now, our import algorithm might
2920 # have been improved. But even so we do not want to generate
2921 # a new different import of the same package. So if the
2922 # version numbers are the same, just use our existing version.
2923 # If the version numbers are different, the archive has changed
2924 # (perhaps, rewound).
2925 if ($lastfetch_mergeinput &&
2926 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2927 (mergeinfo_version $mergeinputs[0]) )) {
2928 @mergeinputs = ($lastfetch_mergeinput);
2930 } elsif ($lastpush_hash) {
2931 # only in git, not in the archive yet
2932 @mergeinputs = ($lastpush_mergeinput);
2933 print STDERR <<END or die $!;
2935 Package not found in the archive, but has allegedly been pushed using dgit.
2939 printdebug "nothing found!\n";
2940 if (defined $skew_warning_vsn) {
2941 print STDERR <<END or die $!;
2943 Warning: relevant archive skew detected.
2944 Archive allegedly contains $skew_warning_vsn
2945 But we were not able to obtain any version from the archive or git.
2949 unshift @end, $del_lrfetchrefs;
2953 if ($lastfetch_hash &&
2955 my $h = $_->{Commit};
2956 $h and is_fast_fwd($lastfetch_hash, $h);
2957 # If true, one of the existing parents of this commit
2958 # is a descendant of the $lastfetch_hash, so we'll
2959 # be ff from that automatically.
2963 push @mergeinputs, $lastfetch_mergeinput;
2966 printdebug "fetch mergeinfos:\n";
2967 foreach my $mi (@mergeinputs) {
2969 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2971 printdebug sprintf " ReverseParents=%d Message=%s",
2972 $mi->{ReverseParents}, $mi->{Message};
2976 my $compat_info= pop @mergeinputs
2977 if $mergeinputs[$#mergeinputs]{Message};
2979 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2982 if (@mergeinputs > 1) {
2984 my $tree_commit = $mergeinputs[0]{Commit};
2986 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2987 $tree =~ m/\n\n/; $tree = $`;
2988 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2991 # We use the changelog author of the package in question the
2992 # author of this pseudo-merge. This is (roughly) correct if
2993 # this commit is simply representing aa non-dgit upload.
2994 # (Roughly because it does not record sponsorship - but we
2995 # don't have sponsorship info because that's in the .changes,
2996 # which isn't in the archivw.)
2998 # But, it might be that we are representing archive history
2999 # updates (including in-archive copies). These are not really
3000 # the responsibility of the person who created the .dsc, but
3001 # there is no-one whose name we should better use. (The
3002 # author of the .dsc-named commit is clearly worse.)
3004 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3005 my $author = clogp_authline $useclogp;
3006 my $cversion = getfield $useclogp, 'Version';
3008 my $mcf = ".git/dgit/mergecommit";
3009 open MC, ">", $mcf or die "$mcf $!";
3010 print MC <<END or die $!;
3014 my @parents = grep { $_->{Commit} } @mergeinputs;
3015 @parents = reverse @parents if $compat_info->{ReverseParents};
3016 print MC <<END or die $! foreach @parents;
3020 print MC <<END or die $!;
3026 if (defined $compat_info->{Message}) {
3027 print MC $compat_info->{Message} or die $!;
3029 print MC <<END or die $!;
3030 Record $package ($cversion) in archive suite $csuite
3034 my $message_add_info = sub {
3036 my $mversion = mergeinfo_version $mi;
3037 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3041 $message_add_info->($mergeinputs[0]);
3042 print MC <<END or die $!;
3043 should be treated as descended from
3045 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3049 $hash = make_commit $mcf;
3051 $hash = $mergeinputs[0]{Commit};
3053 printdebug "fetch hash=$hash\n";
3056 my ($lasth, $what) = @_;
3057 return unless $lasth;
3058 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3061 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3063 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3065 fetch_from_archive_record_1($hash);
3067 if (defined $skew_warning_vsn) {
3069 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3070 my $gotclogp = commit_getclogp($hash);
3071 my $got_vsn = getfield $gotclogp, 'Version';
3072 printdebug "SKEW CHECK GOT $got_vsn\n";
3073 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3074 print STDERR <<END or die $!;
3076 Warning: archive skew detected. Using the available version:
3077 Archive allegedly contains $skew_warning_vsn
3078 We were able to obtain only $got_vsn
3084 if ($lastfetch_hash ne $hash) {
3085 fetch_from_archive_record_2($hash);
3088 lrfetchref_used lrfetchref();
3090 unshift @end, $del_lrfetchrefs;
3094 sub set_local_git_config ($$) {
3096 runcmd @git, qw(config), $k, $v;
3099 sub setup_mergechangelogs (;$) {
3101 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3103 my $driver = 'dpkg-mergechangelogs';
3104 my $cb = "merge.$driver";
3105 my $attrs = '.git/info/attributes';
3106 ensuredir '.git/info';
3108 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3109 if (!open ATTRS, "<", $attrs) {
3110 $!==ENOENT or die "$attrs: $!";
3114 next if m{^debian/changelog\s};
3115 print NATTRS $_, "\n" or die $!;
3117 ATTRS->error and die $!;
3120 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3123 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3124 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3126 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3129 sub setup_useremail (;$) {
3131 return unless $always || access_cfg_bool(1, 'setup-useremail');
3134 my ($k, $envvar) = @_;
3135 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3136 return unless defined $v;
3137 set_local_git_config "user.$k", $v;
3140 $setup->('email', 'DEBEMAIL');
3141 $setup->('name', 'DEBFULLNAME');
3144 sub ensure_setup_existing_tree () {
3145 my $k = "remote.$remotename.skipdefaultupdate";
3146 my $c = git_get_config $k;
3147 return if defined $c;
3148 set_local_git_config $k, 'true';
3151 sub setup_new_tree () {
3152 setup_mergechangelogs();
3156 sub multisuite_suite_child ($$$) {
3157 my ($tsuite, $merginputs, $fn) = @_;
3158 # in child, sets things up, calls $fn->(), and returns undef
3159 # in parent, returns canonical suite name for $tsuite
3160 my $canonsuitefh = IO::File::new_tmpfile;
3161 my $pid = fork // die $!;
3164 $us .= " [$isuite]";
3165 $debugprefix .= " ";
3166 progress "fetching $tsuite...";
3167 canonicalise_suite();
3168 print $canonsuitefh $csuite, "\n" or die $!;
3169 close $canonsuitefh or die $!;
3173 waitpid $pid,0 == $pid or die $!;
3174 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3175 seek $canonsuitefh,0,0 or die $!;
3176 local $csuite = <$canonsuitefh>;
3177 die $! unless defined $csuite && chomp $csuite;
3179 printdebug "multisuite $tsuite missing\n";
3182 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3183 push @$merginputs, {
3190 sub fork_for_multisuite ($) {
3191 my ($before_fetch_merge) = @_;
3192 # if nothing unusual, just returns ''
3195 # returns 0 to caller in child, to do first of the specified suites
3196 # in child, $csuite is not yet set
3198 # returns 1 to caller in parent, to finish up anything needed after
3199 # in parent, $csuite is set to canonicalised portmanteau
3201 my $org_isuite = $isuite;
3202 my @suites = split /\,/, $isuite;
3203 return '' unless @suites > 1;
3204 printdebug "fork_for_multisuite: @suites\n";
3208 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3210 return 0 unless defined $cbasesuite;
3212 fail "package $package missing in (base suite) $cbasesuite"
3213 unless @mergeinputs;
3215 my @csuites = ($cbasesuite);
3217 $before_fetch_merge->();
3219 foreach my $tsuite (@suites[1..$#suites]) {
3220 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3226 # xxx collecte the ref here
3228 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3229 push @csuites, $csubsuite;
3232 foreach my $mi (@mergeinputs) {
3233 my $ref = git_get_ref $mi->{Ref};
3234 die "$mi->{Ref} ?" unless length $ref;
3235 $mi->{Commit} = $ref;
3238 $csuite = join ",", @csuites;
3240 my $previous = git_get_ref lrref;
3242 unshift @mergeinputs, {
3243 Commit => $previous,
3244 Info => "local combined tracking branch",
3246 "archive seems to have rewound: local tracking branch is ahead!",
3250 foreach my $ix (0..$#mergeinputs) {
3251 $mergeinputs[$ix]{Index} = $ix;
3254 @mergeinputs = sort {
3255 -version_compare(mergeinfo_version $a,
3256 mergeinfo_version $b) # highest version first
3258 $a->{Index} <=> $b->{Index}; # earliest in spec first
3264 foreach my $mi (@mergeinputs) {
3265 printdebug "multisuite merge check $mi->{Info}\n";
3266 foreach my $previous (@needed) {
3267 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3268 printdebug "multisuite merge un-needed $previous->{Info}\n";
3272 printdebug "multisuite merge this-needed\n";
3273 $mi->{Character} = '+';
3276 $needed[0]{Character} = '*';
3278 my $output = $needed[0]{Commit};
3281 printdebug "multisuite merge nontrivial\n";
3282 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3284 my $commit = "tree $tree\n";
3285 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3286 "Input branches:\n";
3288 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3289 printdebug "multisuite merge include $mi->{Info}\n";
3290 $mi->{Character} //= ' ';
3291 $commit .= "parent $mi->{Commit}\n";
3292 $msg .= sprintf " %s %-25s %s\n",
3294 (mergeinfo_version $mi),
3297 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3299 " * marks the highest version branch, which choose to use\n".
3300 " + marks each branch which was not already an ancestor\n\n".
3301 "[dgit multi-suite $csuite]\n";
3303 "author $authline\n".
3304 "committer $authline\n\n";
3305 $output = make_commit_text $commit.$msg;
3306 printdebug "multisuite merge generated $output\n";
3309 fetch_from_archive_record_1($output);
3310 fetch_from_archive_record_2($output);
3312 progress "calculated combined tracking suite $csuite";
3317 sub clone_set_head () {
3318 open H, "> .git/HEAD" or die $!;
3319 print H "ref: ".lref()."\n" or die $!;
3322 sub clone_finish ($) {
3324 runcmd @git, qw(reset --hard), lrref();
3325 runcmd qw(bash -ec), <<'END';
3327 git ls-tree -r --name-only -z HEAD | \
3328 xargs -0r touch -h -r . --
3330 printdone "ready for work in $dstdir";
3335 badusage "dry run makes no sense with clone" unless act_local();
3337 my $multi_fetched = fork_for_multisuite(sub {
3338 printdebug "multi clone before fetch merge\n";
3341 if ($multi_fetched) {
3342 printdebug "multi clone after fetch merge\n";
3344 clone_finish($dstdir);
3347 printdebug "clone main body\n";
3349 canonicalise_suite();
3350 my $hasgit = check_for_git();
3351 mkdir $dstdir or fail "create \`$dstdir': $!";
3353 runcmd @git, qw(init -q);
3355 my $giturl = access_giturl(1);
3356 if (defined $giturl) {
3357 runcmd @git, qw(remote add), 'origin', $giturl;
3360 progress "fetching existing git history";
3362 runcmd_ordryrun_local @git, qw(fetch origin);
3364 progress "starting new git history";
3366 fetch_from_archive() or no_such_package;
3367 my $vcsgiturl = $dsc->{'Vcs-Git'};
3368 if (length $vcsgiturl) {
3369 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3370 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3373 clone_finish($dstdir);
3377 canonicalise_suite();
3378 if (check_for_git()) {
3381 fetch_from_archive() or no_such_package();
3382 printdone "fetched into ".lrref();
3386 my $multi_fetched = fork_for_multisuite(sub { });
3387 fetch() unless $multi_fetched; # parent
3388 return if $multi_fetched eq '0'; # child
3389 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3391 printdone "fetched to ".lrref()." and merged into HEAD";
3394 sub check_not_dirty () {
3395 foreach my $f (qw(local-options local-patch-header)) {
3396 if (stat_exists "debian/source/$f") {
3397 fail "git tree contains debian/source/$f";
3401 return if $ignoredirty;
3403 my @cmd = (@git, qw(diff --quiet HEAD));
3405 $!=0; $?=-1; system @cmd;
3408 fail "working tree is dirty (does not match HEAD)";
3414 sub commit_admin ($) {
3417 runcmd_ordryrun_local @git, qw(commit -m), $m;
3420 sub commit_quilty_patch () {
3421 my $output = cmdoutput @git, qw(status --porcelain);
3423 foreach my $l (split /\n/, $output) {
3424 next unless $l =~ m/\S/;
3425 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3429 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3431 progress "nothing quilty to commit, ok.";
3434 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3435 runcmd_ordryrun_local @git, qw(add -f), @adds;
3437 Commit Debian 3.0 (quilt) metadata
3439 [dgit ($our_version) quilt-fixup]
3443 sub get_source_format () {
3445 if (open F, "debian/source/options") {
3449 s/\s+$//; # ignore missing final newline
3451 my ($k, $v) = ($`, $'); #');
3452 $v =~ s/^"(.*)"$/$1/;
3458 F->error and die $!;
3461 die $! unless $!==&ENOENT;
3464 if (!open F, "debian/source/format") {
3465 die $! unless $!==&ENOENT;
3469 F->error and die $!;
3471 return ($_, \%options);
3474 sub madformat_wantfixup ($) {
3476 return 0 unless $format eq '3.0 (quilt)';
3477 our $quilt_mode_warned;
3478 if ($quilt_mode eq 'nocheck') {
3479 progress "Not doing any fixup of \`$format' due to".
3480 " ----no-quilt-fixup or --quilt=nocheck"
3481 unless $quilt_mode_warned++;
3484 progress "Format \`$format', need to check/update patch stack"
3485 unless $quilt_mode_warned++;
3489 sub maybe_split_brain_save ($$$) {
3490 my ($headref, $dgitview, $msg) = @_;
3491 # => message fragment "$saved" describing disposition of $dgitview
3492 return "commit id $dgitview" unless defined $split_brain_save;
3493 my @cmd = (shell_cmd "cd ../../../..",
3494 @git, qw(update-ref -m),
3495 "dgit --dgit-view-save $msg HEAD=$headref",
3496 $split_brain_save, $dgitview);
3498 return "and left in $split_brain_save";
3501 # An "infopair" is a tuple [ $thing, $what ]
3502 # (often $thing is a commit hash; $what is a description)
3504 sub infopair_cond_equal ($$) {
3506 $x->[0] eq $y->[0] or fail <<END;
3507 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3511 sub infopair_lrf_tag_lookup ($$) {
3512 my ($tagnames, $what) = @_;
3513 # $tagname may be an array ref
3514 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3515 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3516 foreach my $tagname (@tagnames) {
3517 my $lrefname = lrfetchrefs."/tags/$tagname";
3518 my $tagobj = $lrfetchrefs_f{$lrefname};
3519 next unless defined $tagobj;
3520 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3521 return [ git_rev_parse($tagobj), $what ];
3523 fail @tagnames==1 ? <<END : <<END;
3524 Wanted tag $what (@tagnames) on dgit server, but not found
3526 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3530 sub infopair_cond_ff ($$) {
3531 my ($anc,$desc) = @_;
3532 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3533 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3537 sub pseudomerge_version_check ($$) {
3538 my ($clogp, $archive_hash) = @_;
3540 my $arch_clogp = commit_getclogp $archive_hash;
3541 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3542 'version currently in archive' ];
3543 if (defined $overwrite_version) {
3544 if (length $overwrite_version) {
3545 infopair_cond_equal([ $overwrite_version,
3546 '--overwrite= version' ],
3549 my $v = $i_arch_v->[0];
3550 progress "Checking package changelog for archive version $v ...";
3552 my @xa = ("-f$v", "-t$v");
3553 my $vclogp = parsechangelog @xa;
3554 my $cv = [ (getfield $vclogp, 'Version'),
3555 "Version field from dpkg-parsechangelog @xa" ];
3556 infopair_cond_equal($i_arch_v, $cv);
3559 $@ =~ s/^dgit: //gm;
3561 "Perhaps debian/changelog does not mention $v ?";
3566 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3570 sub pseudomerge_make_commit ($$$$ $$) {
3571 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3572 $msg_cmd, $msg_msg) = @_;
3573 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3575 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3576 my $authline = clogp_authline $clogp;
3580 !defined $overwrite_version ? ""
3581 : !length $overwrite_version ? " --overwrite"
3582 : " --overwrite=".$overwrite_version;
3585 my $pmf = ".git/dgit/pseudomerge";
3586 open MC, ">", $pmf or die "$pmf $!";
3587 print MC <<END or die $!;
3590 parent $archive_hash
3600 return make_commit($pmf);
3603 sub splitbrain_pseudomerge ($$$$) {
3604 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3605 # => $merged_dgitview
3606 printdebug "splitbrain_pseudomerge...\n";
3608 # We: debian/PREVIOUS HEAD($maintview)
3609 # expect: o ----------------- o
3612 # a/d/PREVIOUS $dgitview
3615 # we do: `------------------ o
3619 return $dgitview unless defined $archive_hash;
3621 printdebug "splitbrain_pseudomerge...\n";
3623 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3625 if (!defined $overwrite_version) {
3626 progress "Checking that HEAD inciudes all changes in archive...";
3629 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3631 if (defined $overwrite_version) {
3633 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3634 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3635 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3636 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3637 my $i_archive = [ $archive_hash, "current archive contents" ];
3639 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3641 infopair_cond_equal($i_dgit, $i_archive);
3642 infopair_cond_ff($i_dep14, $i_dgit);
3643 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3647 $us: check failed (maybe --overwrite is needed, consult documentation)
3652 my $r = pseudomerge_make_commit
3653 $clogp, $dgitview, $archive_hash, $i_arch_v,
3654 "dgit --quilt=$quilt_mode",
3655 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3656 Declare fast forward from $i_arch_v->[0]
3658 Make fast forward from $i_arch_v->[0]
3661 maybe_split_brain_save $maintview, $r, "pseudomerge";
3663 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3667 sub plain_overwrite_pseudomerge ($$$) {
3668 my ($clogp, $head, $archive_hash) = @_;
3670 printdebug "plain_overwrite_pseudomerge...";
3672 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3674 return $head if is_fast_fwd $archive_hash, $head;
3676 my $m = "Declare fast forward from $i_arch_v->[0]";
3678 my $r = pseudomerge_make_commit
3679 $clogp, $head, $archive_hash, $i_arch_v,
3682 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3684 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3688 sub push_parse_changelog ($) {
3691 my $clogp = Dpkg::Control::Hash->new();
3692 $clogp->load($clogpfn) or die;
3694 my $clogpackage = getfield $clogp, 'Source';
3695 $package //= $clogpackage;
3696 fail "-p specified $package but changelog specified $clogpackage"
3697 unless $package eq $clogpackage;
3698 my $cversion = getfield $clogp, 'Version';
3699 my $tag = debiantag($cversion, access_nomdistro);
3700 runcmd @git, qw(check-ref-format), $tag;
3702 my $dscfn = dscfn($cversion);
3704 return ($clogp, $cversion, $dscfn);
3707 sub push_parse_dsc ($$$) {
3708 my ($dscfn,$dscfnwhat, $cversion) = @_;
3709 $dsc = parsecontrol($dscfn,$dscfnwhat);
3710 my $dversion = getfield $dsc, 'Version';
3711 my $dscpackage = getfield $dsc, 'Source';
3712 ($dscpackage eq $package && $dversion eq $cversion) or
3713 fail "$dscfn is for $dscpackage $dversion".
3714 " but debian/changelog is for $package $cversion";
3717 sub push_tagwants ($$$$) {
3718 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3721 TagFn => \&debiantag,
3726 if (defined $maintviewhead) {
3728 TagFn => \&debiantag_maintview,
3729 Objid => $maintviewhead,
3730 TfSuffix => '-maintview',
3733 } elsif ($dodep14tag eq 'no' ? 0
3734 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3735 : $dodep14tag eq 'always'
3736 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3737 --dep14tag-always (or equivalent in config) means server must support
3738 both "new" and "maint" tag formats, but config says it doesn't.
3740 : die "$dodep14tag ?") {
3742 TagFn => \&debiantag_maintview,
3744 TfSuffix => '-dgit',
3748 foreach my $tw (@tagwants) {
3749 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3750 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3752 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3756 sub push_mktags ($$ $$ $) {
3758 $changesfile,$changesfilewhat,
3761 die unless $tagwants->[0]{View} eq 'dgit';
3763 my $declaredistro = access_nomdistro();
3764 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
3765 $dsc->{$ourdscfield[0]} = join " ",
3766 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
3768 $dsc->save("$dscfn.tmp") or die $!;
3770 my $changes = parsecontrol($changesfile,$changesfilewhat);
3771 foreach my $field (qw(Source Distribution Version)) {
3772 $changes->{$field} eq $clogp->{$field} or
3773 fail "changes field $field \`$changes->{$field}'".
3774 " does not match changelog \`$clogp->{$field}'";
3777 my $cversion = getfield $clogp, 'Version';
3778 my $clogsuite = getfield $clogp, 'Distribution';
3780 # We make the git tag by hand because (a) that makes it easier
3781 # to control the "tagger" (b) we can do remote signing
3782 my $authline = clogp_authline $clogp;
3783 my $delibs = join(" ", "",@deliberatelies);
3787 my $tfn = $tw->{Tfn};
3788 my $head = $tw->{Objid};
3789 my $tag = $tw->{Tag};
3791 open TO, '>', $tfn->('.tmp') or die $!;
3792 print TO <<END or die $!;
3799 if ($tw->{View} eq 'dgit') {
3800 print TO <<END or die $!;
3801 $package release $cversion for $clogsuite ($csuite) [dgit]
3802 [dgit distro=$declaredistro$delibs]
3804 foreach my $ref (sort keys %previously) {
3805 print TO <<END or die $!;
3806 [dgit previously:$ref=$previously{$ref}]
3809 } elsif ($tw->{View} eq 'maint') {
3810 print TO <<END or die $!;
3811 $package release $cversion for $clogsuite ($csuite)
3812 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3815 die Dumper($tw)."?";
3820 my $tagobjfn = $tfn->('.tmp');
3822 if (!defined $keyid) {
3823 $keyid = access_cfg('keyid','RETURN-UNDEF');
3825 if (!defined $keyid) {
3826 $keyid = getfield $clogp, 'Maintainer';
3828 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3829 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3830 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3831 push @sign_cmd, $tfn->('.tmp');
3832 runcmd_ordryrun @sign_cmd;
3834 $tagobjfn = $tfn->('.signed.tmp');
3835 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3836 $tfn->('.tmp'), $tfn->('.tmp.asc');
3842 my @r = map { $mktag->($_); } @$tagwants;
3846 sub sign_changes ($) {
3847 my ($changesfile) = @_;
3849 my @debsign_cmd = @debsign;
3850 push @debsign_cmd, "-k$keyid" if defined $keyid;
3851 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3852 push @debsign_cmd, $changesfile;
3853 runcmd_ordryrun @debsign_cmd;
3858 printdebug "actually entering push\n";
3860 supplementary_message(<<'END');
3861 Push failed, while checking state of the archive.
3862 You can retry the push, after fixing the problem, if you like.
3864 if (check_for_git()) {
3867 my $archive_hash = fetch_from_archive();
3868 if (!$archive_hash) {
3870 fail "package appears to be new in this suite;".
3871 " if this is intentional, use --new";
3874 supplementary_message(<<'END');
3875 Push failed, while preparing your push.
3876 You can retry the push, after fixing the problem, if you like.
3879 need_tagformat 'new', "quilt mode $quilt_mode"
3880 if quiltmode_splitbrain;
3884 access_giturl(); # check that success is vaguely likely
3887 my $clogpfn = ".git/dgit/changelog.822.tmp";
3888 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3890 responder_send_file('parsed-changelog', $clogpfn);
3892 my ($clogp, $cversion, $dscfn) =
3893 push_parse_changelog("$clogpfn");
3895 my $dscpath = "$buildproductsdir/$dscfn";
3896 stat_exists $dscpath or
3897 fail "looked for .dsc $dscpath, but $!;".
3898 " maybe you forgot to build";
3900 responder_send_file('dsc', $dscpath);
3902 push_parse_dsc($dscpath, $dscfn, $cversion);
3904 my $format = getfield $dsc, 'Format';
3905 printdebug "format $format\n";
3907 my $actualhead = git_rev_parse('HEAD');
3908 my $dgithead = $actualhead;
3909 my $maintviewhead = undef;
3911 my $upstreamversion = upstreamversion $clogp->{Version};
3913 if (madformat_wantfixup($format)) {
3914 # user might have not used dgit build, so maybe do this now:
3915 if (quiltmode_splitbrain()) {
3917 quilt_make_fake_dsc($upstreamversion);
3919 ($dgithead, $cachekey) =
3920 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3922 "--quilt=$quilt_mode but no cached dgit view:
3923 perhaps tree changed since dgit build[-source] ?";
3925 $dgithead = splitbrain_pseudomerge($clogp,
3926 $actualhead, $dgithead,
3928 $maintviewhead = $actualhead;
3929 changedir '../../../..';
3930 prep_ud(); # so _only_subdir() works, below
3932 commit_quilty_patch();
3936 if (defined $overwrite_version && !defined $maintviewhead) {
3937 $dgithead = plain_overwrite_pseudomerge($clogp,
3945 if ($archive_hash) {
3946 if (is_fast_fwd($archive_hash, $dgithead)) {
3948 } elsif (deliberately_not_fast_forward) {
3951 fail "dgit push: HEAD is not a descendant".
3952 " of the archive's version.\n".
3953 "To overwrite the archive's contents,".
3954 " pass --overwrite[=VERSION].\n".
3955 "To rewind history, if permitted by the archive,".
3956 " use --deliberately-not-fast-forward.";
3961 progress "checking that $dscfn corresponds to HEAD";
3962 runcmd qw(dpkg-source -x --),
3963 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3964 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
3965 check_for_vendor_patches() if madformat($dsc->{format});
3966 changedir '../../../..';
3967 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3968 debugcmd "+",@diffcmd;
3970 my $r = system @diffcmd;
3973 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3975 HEAD specifies a different tree to $dscfn:
3977 Perhaps you forgot to build. Or perhaps there is a problem with your
3978 source tree (see dgit(7) for some hints). To see a full diff, run
3985 if (!$changesfile) {
3986 my $pat = changespat $cversion;
3987 my @cs = glob "$buildproductsdir/$pat";
3988 fail "failed to find unique changes file".
3989 " (looked for $pat in $buildproductsdir);".
3990 " perhaps you need to use dgit -C"
3992 ($changesfile) = @cs;
3994 $changesfile = "$buildproductsdir/$changesfile";
3997 # Check that changes and .dsc agree enough
3998 $changesfile =~ m{[^/]*$};
3999 my $changes = parsecontrol($changesfile,$&);
4000 files_compare_inputs($dsc, $changes)
4001 unless forceing [qw(dsc-changes-mismatch)];
4003 # Perhaps adjust .dsc to contain right set of origs
4004 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4006 unless forceing [qw(changes-origs-exactly)];
4008 # Checks complete, we're going to try and go ahead:
4010 responder_send_file('changes',$changesfile);
4011 responder_send_command("param head $dgithead");
4012 responder_send_command("param csuite $csuite");
4013 responder_send_command("param tagformat $tagformat");
4014 if (defined $maintviewhead) {
4015 die unless ($protovsn//4) >= 4;
4016 responder_send_command("param maint-view $maintviewhead");
4019 if (deliberately_not_fast_forward) {
4020 git_for_each_ref(lrfetchrefs, sub {
4021 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4022 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4023 responder_send_command("previously $rrefname=$objid");
4024 $previously{$rrefname} = $objid;
4028 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4032 supplementary_message(<<'END');
4033 Push failed, while signing the tag.
4034 You can retry the push, after fixing the problem, if you like.
4036 # If we manage to sign but fail to record it anywhere, it's fine.
4037 if ($we_are_responder) {
4038 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4039 responder_receive_files('signed-tag', @tagobjfns);
4041 @tagobjfns = push_mktags($clogp,$dscpath,
4042 $changesfile,$changesfile,
4045 supplementary_message(<<'END');
4046 Push failed, *after* signing the tag.
4047 If you want to try again, you should use a new version number.
4050 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4052 foreach my $tw (@tagwants) {
4053 my $tag = $tw->{Tag};
4054 my $tagobjfn = $tw->{TagObjFn};
4056 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4057 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4058 runcmd_ordryrun_local
4059 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4062 supplementary_message(<<'END');
4063 Push failed, while updating the remote git repository - see messages above.
4064 If you want to try again, you should use a new version number.
4066 if (!check_for_git()) {
4067 create_remote_git_repo();
4070 my @pushrefs = $forceflag.$dgithead.":".rrref();
4071 foreach my $tw (@tagwants) {
4072 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4075 runcmd_ordryrun @git,
4076 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4077 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4079 supplementary_message(<<'END');
4080 Push failed, while obtaining signatures on the .changes and .dsc.
4081 If it was just that the signature failed, you may try again by using
4082 debsign by hand to sign the changes
4084 and then dput to complete the upload.
4085 If you need to change the package, you must use a new version number.
4087 if ($we_are_responder) {
4088 my $dryrunsuffix = act_local() ? "" : ".tmp";
4089 responder_receive_files('signed-dsc-changes',
4090 "$dscpath$dryrunsuffix",
4091 "$changesfile$dryrunsuffix");
4094 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4096 progress "[new .dsc left in $dscpath.tmp]";
4098 sign_changes $changesfile;
4101 supplementary_message(<<END);
4102 Push failed, while uploading package(s) to the archive server.
4103 You can retry the upload of exactly these same files with dput of:
4105 If that .changes file is broken, you will need to use a new version
4106 number for your next attempt at the upload.
4108 my $host = access_cfg('upload-host','RETURN-UNDEF');
4109 my @hostarg = defined($host) ? ($host,) : ();
4110 runcmd_ordryrun @dput, @hostarg, $changesfile;
4111 printdone "pushed and uploaded $cversion";
4113 supplementary_message('');
4114 responder_send_command("complete");
4120 badusage "-p is not allowed with clone; specify as argument instead"
4121 if defined $package;
4124 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4125 ($package,$isuite) = @ARGV;
4126 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4127 ($package,$dstdir) = @ARGV;
4128 } elsif (@ARGV==3) {
4129 ($package,$isuite,$dstdir) = @ARGV;
4131 badusage "incorrect arguments to dgit clone";
4135 $dstdir ||= "$package";
4136 if (stat_exists $dstdir) {
4137 fail "$dstdir already exists";
4141 if ($rmonerror && !$dryrun_level) {
4142 $cwd_remove= getcwd();
4144 return unless defined $cwd_remove;
4145 if (!chdir "$cwd_remove") {
4146 return if $!==&ENOENT;
4147 die "chdir $cwd_remove: $!";
4149 printdebug "clone rmonerror removing $dstdir\n";
4151 rmtree($dstdir) or die "remove $dstdir: $!\n";
4152 } elsif (grep { $! == $_ }
4153 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4155 print STDERR "check whether to remove $dstdir: $!\n";
4161 $cwd_remove = undef;
4164 sub branchsuite () {
4165 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4166 if ($branch =~ m#$lbranch_re#o) {
4173 sub fetchpullargs () {
4174 if (!defined $package) {
4175 my $sourcep = parsecontrol('debian/control','debian/control');
4176 $package = getfield $sourcep, 'Source';
4179 $isuite = branchsuite();
4181 my $clogp = parsechangelog();
4182 $isuite = getfield $clogp, 'Distribution';
4184 } elsif (@ARGV==1) {
4187 badusage "incorrect arguments to dgit fetch or dgit pull";
4195 my $multi_fetched = fork_for_multisuite(sub { });
4196 exit 0 if $multi_fetched;
4203 if (quiltmode_splitbrain()) {
4204 my ($format, $fopts) = get_source_format();
4205 madformat($format) and fail <<END
4206 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4215 badusage "-p is not allowed with dgit push" if defined $package;
4217 my $clogp = parsechangelog();
4218 $package = getfield $clogp, 'Source';
4221 } elsif (@ARGV==1) {
4222 ($specsuite) = (@ARGV);
4224 badusage "incorrect arguments to dgit push";
4226 $isuite = getfield $clogp, 'Distribution';
4228 local ($package) = $existing_package; # this is a hack
4229 canonicalise_suite();
4231 canonicalise_suite();
4233 if (defined $specsuite &&
4234 $specsuite ne $isuite &&
4235 $specsuite ne $csuite) {
4236 fail "dgit push: changelog specifies $isuite ($csuite)".
4237 " but command line specifies $specsuite";
4242 #---------- remote commands' implementation ----------
4244 sub cmd_remote_push_build_host {
4245 my ($nrargs) = shift @ARGV;
4246 my (@rargs) = @ARGV[0..$nrargs-1];
4247 @ARGV = @ARGV[$nrargs..$#ARGV];
4249 my ($dir,$vsnwant) = @rargs;
4250 # vsnwant is a comma-separated list; we report which we have
4251 # chosen in our ready response (so other end can tell if they
4254 $we_are_responder = 1;
4255 $us .= " (build host)";
4259 open PI, "<&STDIN" or die $!;
4260 open STDIN, "/dev/null" or die $!;
4261 open PO, ">&STDOUT" or die $!;
4263 open STDOUT, ">&STDERR" or die $!;
4267 ($protovsn) = grep {
4268 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4269 } @rpushprotovsn_support;
4271 fail "build host has dgit rpush protocol versions ".
4272 (join ",", @rpushprotovsn_support).
4273 " but invocation host has $vsnwant"
4274 unless defined $protovsn;
4276 responder_send_command("dgit-remote-push-ready $protovsn");
4277 rpush_handle_protovsn_bothends();
4282 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4283 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4284 # a good error message)
4286 sub rpush_handle_protovsn_bothends () {
4287 if ($protovsn < 4) {
4288 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4297 my $report = i_child_report();
4298 if (defined $report) {
4299 printdebug "($report)\n";
4300 } elsif ($i_child_pid) {
4301 printdebug "(killing build host child $i_child_pid)\n";
4302 kill 15, $i_child_pid;
4304 if (defined $i_tmp && !defined $initiator_tempdir) {
4306 eval { rmtree $i_tmp; };
4310 END { i_cleanup(); }
4313 my ($base,$selector,@args) = @_;
4314 $selector =~ s/\-/_/g;
4315 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4322 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4330 push @rargs, join ",", @rpushprotovsn_support;
4333 push @rdgit, @ropts;
4334 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4336 my @cmd = (@ssh, $host, shellquote @rdgit);
4339 if (defined $initiator_tempdir) {
4340 rmtree $initiator_tempdir;
4341 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4342 $i_tmp = $initiator_tempdir;
4346 $i_child_pid = open2(\*RO, \*RI, @cmd);
4348 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4349 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4350 $supplementary_message = '' unless $protovsn >= 3;
4352 fail "rpush negotiated protocol version $protovsn".
4353 " which does not support quilt mode $quilt_mode"
4354 if quiltmode_splitbrain;
4356 rpush_handle_protovsn_bothends();
4358 my ($icmd,$iargs) = initiator_expect {
4359 m/^(\S+)(?: (.*))?$/;
4362 i_method "i_resp", $icmd, $iargs;
4366 sub i_resp_progress ($) {
4368 my $msg = protocol_read_bytes \*RO, $rhs;
4372 sub i_resp_supplementary_message ($) {
4374 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4377 sub i_resp_complete {
4378 my $pid = $i_child_pid;
4379 $i_child_pid = undef; # prevents killing some other process with same pid
4380 printdebug "waiting for build host child $pid...\n";
4381 my $got = waitpid $pid, 0;
4382 die $! unless $got == $pid;
4383 die "build host child failed $?" if $?;
4386 printdebug "all done\n";
4390 sub i_resp_file ($) {
4392 my $localname = i_method "i_localname", $keyword;
4393 my $localpath = "$i_tmp/$localname";
4394 stat_exists $localpath and
4395 badproto \*RO, "file $keyword ($localpath) twice";
4396 protocol_receive_file \*RO, $localpath;
4397 i_method "i_file", $keyword;
4402 sub i_resp_param ($) {
4403 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4407 sub i_resp_previously ($) {
4408 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4409 or badproto \*RO, "bad previously spec";
4410 my $r = system qw(git check-ref-format), $1;
4411 die "bad previously ref spec ($r)" if $r;
4412 $previously{$1} = $2;
4417 sub i_resp_want ($) {
4419 die "$keyword ?" if $i_wanted{$keyword}++;
4420 my @localpaths = i_method "i_want", $keyword;
4421 printdebug "[[ $keyword @localpaths\n";
4422 foreach my $localpath (@localpaths) {
4423 protocol_send_file \*RI, $localpath;
4425 print RI "files-end\n" or die $!;
4428 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4430 sub i_localname_parsed_changelog {
4431 return "remote-changelog.822";
4433 sub i_file_parsed_changelog {
4434 ($i_clogp, $i_version, $i_dscfn) =
4435 push_parse_changelog "$i_tmp/remote-changelog.822";
4436 die if $i_dscfn =~ m#/|^\W#;
4439 sub i_localname_dsc {
4440 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4445 sub i_localname_changes {
4446 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4447 $i_changesfn = $i_dscfn;
4448 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4449 return $i_changesfn;
4451 sub i_file_changes { }
4453 sub i_want_signed_tag {
4454 printdebug Dumper(\%i_param, $i_dscfn);
4455 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4456 && defined $i_param{'csuite'}
4457 or badproto \*RO, "premature desire for signed-tag";
4458 my $head = $i_param{'head'};
4459 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4461 my $maintview = $i_param{'maint-view'};
4462 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4465 if ($protovsn >= 4) {
4466 my $p = $i_param{'tagformat'} // '<undef>';
4468 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4471 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4473 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4475 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4478 push_mktags $i_clogp, $i_dscfn,
4479 $i_changesfn, 'remote changes',
4483 sub i_want_signed_dsc_changes {
4484 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4485 sign_changes $i_changesfn;
4486 return ($i_dscfn, $i_changesfn);
4489 #---------- building etc. ----------
4495 #----- `3.0 (quilt)' handling -----
4497 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4499 sub quiltify_dpkg_commit ($$$;$) {
4500 my ($patchname,$author,$msg, $xinfo) = @_;
4504 my $descfn = ".git/dgit/quilt-description.tmp";
4505 open O, '>', $descfn or die "$descfn: $!";
4506 $msg =~ s/\n+/\n\n/;
4507 print O <<END or die $!;
4509 ${xinfo}Subject: $msg
4516 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4517 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4518 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4519 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4523 sub quiltify_trees_differ ($$;$$$) {
4524 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4525 # returns true iff the two tree objects differ other than in debian/
4526 # with $finegrained,
4527 # returns bitmask 01 - differ in upstream files except .gitignore
4528 # 02 - differ in .gitignore
4529 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4530 # is set for each modified .gitignore filename $fn
4531 # if $unrepres is defined, array ref to which is appeneded
4532 # a list of unrepresentable changes (removals of upstream files
4535 my @cmd = (@git, qw(diff-tree -z));
4536 push @cmd, qw(--name-only) unless $unrepres;
4537 push @cmd, qw(-r) if $finegrained || $unrepres;
4539 my $diffs= cmdoutput @cmd;
4542 foreach my $f (split /\0/, $diffs) {
4543 if ($unrepres && !@lmodes) {
4544 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4547 my ($oldmode,$newmode) = @lmodes;
4550 next if $f =~ m#^debian(?:/.*)?$#s;
4554 die "not a plain file\n"
4555 unless $newmode =~ m/^10\d{4}$/ ||
4556 $oldmode =~ m/^10\d{4}$/;
4557 if ($oldmode =~ m/[^0]/ &&
4558 $newmode =~ m/[^0]/) {
4559 die "mode changed\n" if $oldmode ne $newmode;
4561 die "non-default mode\n"
4562 unless $newmode =~ m/^100644$/ ||
4563 $oldmode =~ m/^100644$/;
4567 local $/="\n"; chomp $@;
4568 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4572 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4573 $r |= $isignore ? 02 : 01;
4574 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4576 printdebug "quiltify_trees_differ $x $y => $r\n";
4580 sub quiltify_tree_sentinelfiles ($) {
4581 # lists the `sentinel' files present in the tree
4583 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4584 qw(-- debian/rules debian/control);
4589 sub quiltify_splitbrain_needed () {
4590 if (!$split_brain) {
4591 progress "dgit view: changes are required...";
4592 runcmd @git, qw(checkout -q -b dgit-view);
4597 sub quiltify_splitbrain ($$$$$$) {
4598 my ($clogp, $unapplied, $headref, $diffbits,
4599 $editedignores, $cachekey) = @_;
4600 if ($quilt_mode !~ m/gbp|dpm/) {
4601 # treat .gitignore just like any other upstream file
4602 $diffbits = { %$diffbits };
4603 $_ = !!$_ foreach values %$diffbits;
4605 # We would like any commits we generate to be reproducible
4606 my @authline = clogp_authline($clogp);
4607 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4608 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4609 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4610 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4611 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4612 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4614 if ($quilt_mode =~ m/gbp|unapplied/ &&
4615 ($diffbits->{O2H} & 01)) {
4617 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4618 " but git tree differs from orig in upstream files.";
4619 if (!stat_exists "debian/patches") {
4621 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4625 if ($quilt_mode =~ m/dpm/ &&
4626 ($diffbits->{H2A} & 01)) {
4628 --quilt=$quilt_mode specified, implying patches-applied git tree
4629 but git tree differs from result of applying debian/patches to upstream
4632 if ($quilt_mode =~ m/gbp|unapplied/ &&
4633 ($diffbits->{O2A} & 01)) { # some patches
4634 quiltify_splitbrain_needed();
4635 progress "dgit view: creating patches-applied version using gbp pq";
4636 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4637 # gbp pq import creates a fresh branch; push back to dgit-view
4638 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4639 runcmd @git, qw(checkout -q dgit-view);
4641 if ($quilt_mode =~ m/gbp|dpm/ &&
4642 ($diffbits->{O2A} & 02)) {
4644 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4645 tool which does not create patches for changes to upstream
4646 .gitignores: but, such patches exist in debian/patches.
4649 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4650 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4651 quiltify_splitbrain_needed();
4652 progress "dgit view: creating patch to represent .gitignore changes";
4653 ensuredir "debian/patches";
4654 my $gipatch = "debian/patches/auto-gitignore";
4655 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4656 stat GIPATCH or die "$gipatch: $!";
4657 fail "$gipatch already exists; but want to create it".
4658 " to record .gitignore changes" if (stat _)[7];
4659 print GIPATCH <<END or die "$gipatch: $!";
4660 Subject: Update .gitignore from Debian packaging branch
4662 The Debian packaging git branch contains these updates to the upstream
4663 .gitignore file(s). This patch is autogenerated, to provide these
4664 updates to users of the official Debian archive view of the package.
4666 [dgit ($our_version) update-gitignore]
4669 close GIPATCH or die "$gipatch: $!";
4670 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4671 $unapplied, $headref, "--", sort keys %$editedignores;
4672 open SERIES, "+>>", "debian/patches/series" or die $!;
4673 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4675 defined read SERIES, $newline, 1 or die $!;
4676 print SERIES "\n" or die $! unless $newline eq "\n";
4677 print SERIES "auto-gitignore\n" or die $!;
4678 close SERIES or die $!;
4679 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4681 Commit patch to update .gitignore
4683 [dgit ($our_version) update-gitignore-quilt-fixup]
4687 my $dgitview = git_rev_parse 'HEAD';
4689 changedir '../../../..';
4690 # When we no longer need to support squeeze, use --create-reflog
4692 ensuredir ".git/logs/refs/dgit-intern";
4693 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4696 my $oldcache = git_get_ref "refs/$splitbraincache";
4697 if ($oldcache eq $dgitview) {
4698 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4699 # git update-ref doesn't always update, in this case. *sigh*
4700 my $dummy = make_commit_text <<END;
4703 author Dgit <dgit\@example.com> 1000000000 +0000
4704 committer Dgit <dgit\@example.com> 1000000000 +0000
4706 Dummy commit - do not use
4708 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4709 "refs/$splitbraincache", $dummy;
4711 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4714 changedir '.git/dgit/unpack/work';
4716 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4717 progress "dgit view: created ($saved)";
4720 sub quiltify ($$$$) {
4721 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4723 # Quilt patchification algorithm
4725 # We search backwards through the history of the main tree's HEAD
4726 # (T) looking for a start commit S whose tree object is identical
4727 # to to the patch tip tree (ie the tree corresponding to the
4728 # current dpkg-committed patch series). For these purposes
4729 # `identical' disregards anything in debian/ - this wrinkle is
4730 # necessary because dpkg-source treates debian/ specially.
4732 # We can only traverse edges where at most one of the ancestors'
4733 # trees differs (in changes outside in debian/). And we cannot
4734 # handle edges which change .pc/ or debian/patches. To avoid
4735 # going down a rathole we avoid traversing edges which introduce
4736 # debian/rules or debian/control. And we set a limit on the
4737 # number of edges we are willing to look at.
4739 # If we succeed, we walk forwards again. For each traversed edge
4740 # PC (with P parent, C child) (starting with P=S and ending with
4741 # C=T) to we do this:
4743 # - dpkg-source --commit with a patch name and message derived from C
4744 # After traversing PT, we git commit the changes which
4745 # should be contained within debian/patches.
4747 # The search for the path S..T is breadth-first. We maintain a
4748 # todo list containing search nodes. A search node identifies a
4749 # commit, and looks something like this:
4751 # Commit => $git_commit_id,
4752 # Child => $c, # or undef if P=T
4753 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4754 # Nontrivial => true iff $p..$c has relevant changes
4761 my %considered; # saves being exponential on some weird graphs
4763 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4766 my ($search,$whynot) = @_;
4767 printdebug " search NOT $search->{Commit} $whynot\n";
4768 $search->{Whynot} = $whynot;
4769 push @nots, $search;
4770 no warnings qw(exiting);
4779 my $c = shift @todo;
4780 next if $considered{$c->{Commit}}++;
4782 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4784 printdebug "quiltify investigate $c->{Commit}\n";
4787 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4788 printdebug " search finished hooray!\n";
4793 if ($quilt_mode eq 'nofix') {
4794 fail "quilt fixup required but quilt mode is \`nofix'\n".
4795 "HEAD commit $c->{Commit} differs from tree implied by ".
4796 " debian/patches (tree object $oldtiptree)";
4798 if ($quilt_mode eq 'smash') {
4799 printdebug " search quitting smash\n";
4803 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4804 $not->($c, "has $c_sentinels not $t_sentinels")
4805 if $c_sentinels ne $t_sentinels;
4807 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4808 $commitdata =~ m/\n\n/;
4810 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4811 @parents = map { { Commit => $_, Child => $c } } @parents;
4813 $not->($c, "root commit") if !@parents;
4815 foreach my $p (@parents) {
4816 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4818 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4819 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4821 foreach my $p (@parents) {
4822 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4824 my @cmd= (@git, qw(diff-tree -r --name-only),
4825 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4826 my $patchstackchange = cmdoutput @cmd;
4827 if (length $patchstackchange) {
4828 $patchstackchange =~ s/\n/,/g;
4829 $not->($p, "changed $patchstackchange");
4832 printdebug " search queue P=$p->{Commit} ",
4833 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4839 printdebug "quiltify want to smash\n";
4842 my $x = $_[0]{Commit};
4843 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4846 my $reportnot = sub {
4848 my $s = $abbrev->($notp);
4849 my $c = $notp->{Child};
4850 $s .= "..".$abbrev->($c) if $c;
4851 $s .= ": ".$notp->{Whynot};
4854 if ($quilt_mode eq 'linear') {
4855 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4856 foreach my $notp (@nots) {
4857 print STDERR "$us: ", $reportnot->($notp), "\n";
4859 print STDERR "$us: $_\n" foreach @$failsuggestion;
4860 fail "quilt fixup naive history linearisation failed.\n".
4861 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4862 } elsif ($quilt_mode eq 'smash') {
4863 } elsif ($quilt_mode eq 'auto') {
4864 progress "quilt fixup cannot be linear, smashing...";
4866 die "$quilt_mode ?";
4869 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4870 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4872 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4874 quiltify_dpkg_commit "auto-$version-$target-$time",
4875 (getfield $clogp, 'Maintainer'),
4876 "Automatically generated patch ($clogp->{Version})\n".
4877 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4881 progress "quiltify linearisation planning successful, executing...";
4883 for (my $p = $sref_S;
4884 my $c = $p->{Child};
4886 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4887 next unless $p->{Nontrivial};
4889 my $cc = $c->{Commit};
4891 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4892 $commitdata =~ m/\n\n/ or die "$c ?";
4895 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4898 my $commitdate = cmdoutput
4899 @git, qw(log -n1 --pretty=format:%aD), $cc;
4901 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4903 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4910 my $gbp_check_suitable = sub {
4915 die "contains unexpected slashes\n" if m{//} || m{/$};
4916 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4917 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4918 die "too long" if length > 200;
4920 return $_ unless $@;
4921 print STDERR "quiltifying commit $cc:".
4922 " ignoring/dropping Gbp-Pq $what: $@";
4926 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4928 (\S+) \s* \n //ixm) {
4929 $patchname = $gbp_check_suitable->($1, 'Name');
4931 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4933 (\S+) \s* \n //ixm) {
4934 $patchdir = $gbp_check_suitable->($1, 'Topic');
4939 if (!defined $patchname) {
4940 $patchname = $title;
4941 $patchname =~ s/[.:]$//;
4944 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4945 my $translitname = $converter->convert($patchname);
4946 die unless defined $translitname;
4947 $patchname = $translitname;
4950 "dgit: patch title transliteration error: $@"
4952 $patchname =~ y/ A-Z/-a-z/;
4953 $patchname =~ y/-a-z0-9_.+=~//cd;
4954 $patchname =~ s/^\W/x-$&/;
4955 $patchname = substr($patchname,0,40);
4957 if (!defined $patchdir) {
4960 if (length $patchdir) {
4961 $patchname = "$patchdir/$patchname";
4963 if ($patchname =~ m{^(.*)/}) {
4964 mkpath "debian/patches/$1";
4969 stat "debian/patches/$patchname$index";
4971 $!==ENOENT or die "$patchname$index $!";
4973 runcmd @git, qw(checkout -q), $cc;
4975 # We use the tip's changelog so that dpkg-source doesn't
4976 # produce complaining messages from dpkg-parsechangelog. None
4977 # of the information dpkg-source gets from the changelog is
4978 # actually relevant - it gets put into the original message
4979 # which dpkg-source provides our stunt editor, and then
4981 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4983 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4984 "Date: $commitdate\n".
4985 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4987 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4990 runcmd @git, qw(checkout -q master);
4993 sub build_maybe_quilt_fixup () {
4994 my ($format,$fopts) = get_source_format;
4995 return unless madformat_wantfixup $format;
4998 check_for_vendor_patches();
5000 if (quiltmode_splitbrain) {
5001 fail <<END unless access_cfg_tagformats_can_splitbrain;
5002 quilt mode $quilt_mode requires split view so server needs to support
5003 both "new" and "maint" tag formats, but config says it doesn't.
5007 my $clogp = parsechangelog();
5008 my $headref = git_rev_parse('HEAD');
5013 my $upstreamversion = upstreamversion $version;
5015 if ($fopts->{'single-debian-patch'}) {
5016 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5018 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5021 die 'bug' if $split_brain && !$need_split_build_invocation;
5023 changedir '../../../..';
5024 runcmd_ordryrun_local
5025 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5028 sub quilt_fixup_mkwork ($) {
5031 mkdir "work" or die $!;
5033 mktree_in_ud_here();
5034 runcmd @git, qw(reset -q --hard), $headref;
5037 sub quilt_fixup_linkorigs ($$) {
5038 my ($upstreamversion, $fn) = @_;
5039 # calls $fn->($leafname);
5041 foreach my $f (<../../../../*>) { #/){
5042 my $b=$f; $b =~ s{.*/}{};
5044 local ($debuglevel) = $debuglevel-1;
5045 printdebug "QF linkorigs $b, $f ?\n";
5047 next unless is_orig_file_of_vsn $b, $upstreamversion;
5048 printdebug "QF linkorigs $b, $f Y\n";
5049 link_ltarget $f, $b or die "$b $!";
5054 sub quilt_fixup_delete_pc () {
5055 runcmd @git, qw(rm -rqf .pc);
5057 Commit removal of .pc (quilt series tracking data)
5059 [dgit ($our_version) upgrade quilt-remove-pc]
5063 sub quilt_fixup_singlepatch ($$$) {
5064 my ($clogp, $headref, $upstreamversion) = @_;
5066 progress "starting quiltify (single-debian-patch)";
5068 # dpkg-source --commit generates new patches even if
5069 # single-debian-patch is in debian/source/options. In order to
5070 # get it to generate debian/patches/debian-changes, it is
5071 # necessary to build the source package.
5073 quilt_fixup_linkorigs($upstreamversion, sub { });
5074 quilt_fixup_mkwork($headref);
5076 rmtree("debian/patches");
5078 runcmd @dpkgsource, qw(-b .);
5080 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5081 rename srcfn("$upstreamversion", "/debian/patches"),
5082 "work/debian/patches";
5085 commit_quilty_patch();
5088 sub quilt_make_fake_dsc ($) {
5089 my ($upstreamversion) = @_;
5091 my $fakeversion="$upstreamversion-~~DGITFAKE";
5093 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5094 print $fakedsc <<END or die $!;
5097 Version: $fakeversion
5101 my $dscaddfile=sub {
5104 my $md = new Digest::MD5;
5106 my $fh = new IO::File $b, '<' or die "$b $!";
5111 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5114 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5116 my @files=qw(debian/source/format debian/rules
5117 debian/control debian/changelog);
5118 foreach my $maybe (qw(debian/patches debian/source/options
5119 debian/tests/control)) {
5120 next unless stat_exists "../../../$maybe";
5121 push @files, $maybe;
5124 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5125 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5127 $dscaddfile->($debtar);
5128 close $fakedsc or die $!;
5131 sub quilt_check_splitbrain_cache ($$) {
5132 my ($headref, $upstreamversion) = @_;
5133 # Called only if we are in (potentially) split brain mode.
5135 # Computes the cache key and looks in the cache.
5136 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5138 my $splitbrain_cachekey;
5141 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5142 # we look in the reflog of dgit-intern/quilt-cache
5143 # we look for an entry whose message is the key for the cache lookup
5144 my @cachekey = (qw(dgit), $our_version);
5145 push @cachekey, $upstreamversion;
5146 push @cachekey, $quilt_mode;
5147 push @cachekey, $headref;
5149 push @cachekey, hashfile('fake.dsc');
5151 my $srcshash = Digest::SHA->new(256);
5152 my %sfs = ( %INC, '$0(dgit)' => $0 );
5153 foreach my $sfk (sort keys %sfs) {
5154 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5155 $srcshash->add($sfk," ");
5156 $srcshash->add(hashfile($sfs{$sfk}));
5157 $srcshash->add("\n");
5159 push @cachekey, $srcshash->hexdigest();
5160 $splitbrain_cachekey = "@cachekey";
5162 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5164 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5165 debugcmd "|(probably)",@cmd;
5166 my $child = open GC, "-|"; defined $child or die $!;
5168 chdir '../../..' or die $!;
5169 if (!stat ".git/logs/refs/$splitbraincache") {
5170 $! == ENOENT or die $!;
5171 printdebug ">(no reflog)\n";
5178 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5179 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5182 quilt_fixup_mkwork($headref);
5183 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5184 if ($cachehit ne $headref) {
5185 progress "dgit view: found cached ($saved)";
5186 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5188 return ($cachehit, $splitbrain_cachekey);
5190 progress "dgit view: found cached, no changes required";
5191 return ($headref, $splitbrain_cachekey);
5193 die $! if GC->error;
5194 failedcmd unless close GC;
5196 printdebug "splitbrain cache miss\n";
5197 return (undef, $splitbrain_cachekey);
5200 sub quilt_fixup_multipatch ($$$) {
5201 my ($clogp, $headref, $upstreamversion) = @_;
5203 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5206 # - honour any existing .pc in case it has any strangeness
5207 # - determine the git commit corresponding to the tip of
5208 # the patch stack (if there is one)
5209 # - if there is such a git commit, convert each subsequent
5210 # git commit into a quilt patch with dpkg-source --commit
5211 # - otherwise convert all the differences in the tree into
5212 # a single git commit
5216 # Our git tree doesn't necessarily contain .pc. (Some versions of
5217 # dgit would include the .pc in the git tree.) If there isn't
5218 # one, we need to generate one by unpacking the patches that we
5221 # We first look for a .pc in the git tree. If there is one, we
5222 # will use it. (This is not the normal case.)
5224 # Otherwise need to regenerate .pc so that dpkg-source --commit
5225 # can work. We do this as follows:
5226 # 1. Collect all relevant .orig from parent directory
5227 # 2. Generate a debian.tar.gz out of
5228 # debian/{patches,rules,source/format,source/options}
5229 # 3. Generate a fake .dsc containing just these fields:
5230 # Format Source Version Files
5231 # 4. Extract the fake .dsc
5232 # Now the fake .dsc has a .pc directory.
5233 # (In fact we do this in every case, because in future we will
5234 # want to search for a good base commit for generating patches.)
5236 # Then we can actually do the dpkg-source --commit
5237 # 1. Make a new working tree with the same object
5238 # store as our main tree and check out the main
5240 # 2. Copy .pc from the fake's extraction, if necessary
5241 # 3. Run dpkg-source --commit
5242 # 4. If the result has changes to debian/, then
5243 # - git add them them
5244 # - git add .pc if we had a .pc in-tree
5246 # 5. If we had a .pc in-tree, delete it, and git commit
5247 # 6. Back in the main tree, fast forward to the new HEAD
5249 # Another situation we may have to cope with is gbp-style
5250 # patches-unapplied trees.
5252 # We would want to detect these, so we know to escape into
5253 # quilt_fixup_gbp. However, this is in general not possible.
5254 # Consider a package with a one patch which the dgit user reverts
5255 # (with git revert or the moral equivalent).
5257 # That is indistinguishable in contents from a patches-unapplied
5258 # tree. And looking at the history to distinguish them is not
5259 # useful because the user might have made a confusing-looking git
5260 # history structure (which ought to produce an error if dgit can't
5261 # cope, not a silent reintroduction of an unwanted patch).
5263 # So gbp users will have to pass an option. But we can usually
5264 # detect their failure to do so: if the tree is not a clean
5265 # patches-applied tree, quilt linearisation fails, but the tree
5266 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5267 # they want --quilt=unapplied.
5269 # To help detect this, when we are extracting the fake dsc, we
5270 # first extract it with --skip-patches, and then apply the patches
5271 # afterwards with dpkg-source --before-build. That lets us save a
5272 # tree object corresponding to .origs.
5274 my $splitbrain_cachekey;
5276 quilt_make_fake_dsc($upstreamversion);
5278 if (quiltmode_splitbrain()) {
5280 ($cachehit, $splitbrain_cachekey) =
5281 quilt_check_splitbrain_cache($headref, $upstreamversion);
5282 return if $cachehit;
5286 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5288 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5289 rename $fakexdir, "fake" or die "$fakexdir $!";
5293 remove_stray_gits("source package");
5294 mktree_in_ud_here();
5298 my $unapplied=git_add_write_tree();
5299 printdebug "fake orig tree object $unapplied\n";
5303 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5305 if (system @bbcmd) {
5306 failedcmd @bbcmd if $? < 0;
5308 failed to apply your git tree's patch stack (from debian/patches/) to
5309 the corresponding upstream tarball(s). Your source tree and .orig
5310 are probably too inconsistent. dgit can only fix up certain kinds of
5311 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5317 quilt_fixup_mkwork($headref);
5320 if (stat_exists ".pc") {
5322 progress "Tree already contains .pc - will use it then delete it.";
5325 rename '../fake/.pc','.pc' or die $!;
5328 changedir '../fake';
5330 my $oldtiptree=git_add_write_tree();
5331 printdebug "fake o+d/p tree object $unapplied\n";
5332 changedir '../work';
5335 # We calculate some guesswork now about what kind of tree this might
5336 # be. This is mostly for error reporting.
5342 # O = orig, without patches applied
5343 # A = "applied", ie orig with H's debian/patches applied
5344 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5345 \%editedignores, \@unrepres),
5346 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5347 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5351 foreach my $b (qw(01 02)) {
5352 foreach my $v (qw(O2H O2A H2A)) {
5353 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5356 printdebug "differences \@dl @dl.\n";
5359 "$us: base trees orig=%.20s o+d/p=%.20s",
5360 $unapplied, $oldtiptree;
5362 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5363 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5364 $dl[0], $dl[1], $dl[3], $dl[4],
5368 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5370 forceable_fail [qw(unrepresentable)], <<END;
5371 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5376 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5377 push @failsuggestion, "This might be a patches-unapplied branch.";
5378 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5379 push @failsuggestion, "This might be a patches-applied branch.";
5381 push @failsuggestion, "Maybe you need to specify one of".
5382 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5384 if (quiltmode_splitbrain()) {
5385 quiltify_splitbrain($clogp, $unapplied, $headref,
5386 $diffbits, \%editedignores,
5387 $splitbrain_cachekey);
5391 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5392 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5394 if (!open P, '>>', ".pc/applied-patches") {
5395 $!==&ENOENT or die $!;
5400 commit_quilty_patch();
5402 if ($mustdeletepc) {
5403 quilt_fixup_delete_pc();
5407 sub quilt_fixup_editor () {
5408 my $descfn = $ENV{$fakeeditorenv};
5409 my $editing = $ARGV[$#ARGV];
5410 open I1, '<', $descfn or die "$descfn: $!";
5411 open I2, '<', $editing or die "$editing: $!";
5412 unlink $editing or die "$editing: $!";
5413 open O, '>', $editing or die "$editing: $!";
5414 while (<I1>) { print O or die $!; } I1->error and die $!;
5417 $copying ||= m/^\-\-\- /;
5418 next unless $copying;
5421 I2->error and die $!;
5426 sub maybe_apply_patches_dirtily () {
5427 return unless $quilt_mode =~ m/gbp|unapplied/;
5428 print STDERR <<END or die $!;
5430 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5431 dgit: Have to apply the patches - making the tree dirty.
5432 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5435 $patches_applied_dirtily = 01;
5436 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5437 runcmd qw(dpkg-source --before-build .);
5440 sub maybe_unapply_patches_again () {
5441 progress "dgit: Unapplying patches again to tidy up the tree."
5442 if $patches_applied_dirtily;
5443 runcmd qw(dpkg-source --after-build .)
5444 if $patches_applied_dirtily & 01;
5446 if $patches_applied_dirtily & 02;
5447 $patches_applied_dirtily = 0;
5450 #----- other building -----
5452 our $clean_using_builder;
5453 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5454 # clean the tree before building (perhaps invoked indirectly by
5455 # whatever we are using to run the build), rather than separately
5456 # and explicitly by us.
5459 return if $clean_using_builder;
5460 if ($cleanmode eq 'dpkg-source') {
5461 maybe_apply_patches_dirtily();
5462 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5463 } elsif ($cleanmode eq 'dpkg-source-d') {
5464 maybe_apply_patches_dirtily();
5465 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5466 } elsif ($cleanmode eq 'git') {
5467 runcmd_ordryrun_local @git, qw(clean -xdf);
5468 } elsif ($cleanmode eq 'git-ff') {
5469 runcmd_ordryrun_local @git, qw(clean -xdff);
5470 } elsif ($cleanmode eq 'check') {
5471 my $leftovers = cmdoutput @git, qw(clean -xdn);
5472 if (length $leftovers) {
5473 print STDERR $leftovers, "\n" or die $!;
5474 fail "tree contains uncommitted files and --clean=check specified";
5476 } elsif ($cleanmode eq 'none') {
5483 badusage "clean takes no additional arguments" if @ARGV;
5486 maybe_unapply_patches_again();
5489 sub build_prep_early () {
5490 our $build_prep_early_done //= 0;
5491 return if $build_prep_early_done++;
5493 badusage "-p is not allowed when building" if defined $package;
5494 my $clogp = parsechangelog();
5495 $isuite = getfield $clogp, 'Distribution';
5496 $package = getfield $clogp, 'Source';
5497 $version = getfield $clogp, 'Version';
5504 build_maybe_quilt_fixup();
5506 my $pat = changespat $version;
5507 foreach my $f (glob "$buildproductsdir/$pat") {
5509 unlink $f or fail "remove old changes file $f: $!";
5511 progress "would remove $f";
5517 sub changesopts_initial () {
5518 my @opts =@changesopts[1..$#changesopts];
5521 sub changesopts_version () {
5522 if (!defined $changes_since_version) {
5523 my @vsns = archive_query('archive_query');
5524 my @quirk = access_quirk();
5525 if ($quirk[0] eq 'backports') {
5526 local $isuite = $quirk[2];
5528 canonicalise_suite();
5529 push @vsns, archive_query('archive_query');
5532 @vsns = map { $_->[0] } @vsns;
5533 @vsns = sort { -version_compare($a, $b) } @vsns;
5534 $changes_since_version = $vsns[0];
5535 progress "changelog will contain changes since $vsns[0]";
5537 $changes_since_version = '_';
5538 progress "package seems new, not specifying -v<version>";
5541 if ($changes_since_version ne '_') {
5542 return ("-v$changes_since_version");
5548 sub changesopts () {
5549 return (changesopts_initial(), changesopts_version());
5552 sub massage_dbp_args ($;$) {
5553 my ($cmd,$xargs) = @_;
5556 # - if we're going to split the source build out so we can
5557 # do strange things to it, massage the arguments to dpkg-buildpackage
5558 # so that the main build doessn't build source (or add an argument
5559 # to stop it building source by default).
5561 # - add -nc to stop dpkg-source cleaning the source tree,
5562 # unless we're not doing a split build and want dpkg-source
5563 # as cleanmode, in which case we can do nothing
5566 # 0 - source will NOT need to be built separately by caller
5567 # +1 - source will need to be built separately by caller
5568 # +2 - source will need to be built separately by caller AND
5569 # dpkg-buildpackage should not in fact be run at all!
5570 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5571 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5572 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5573 $clean_using_builder = 1;
5576 # -nc has the side effect of specifying -b if nothing else specified
5577 # and some combinations of -S, -b, et al, are errors, rather than
5578 # later simply overriding earlie. So we need to:
5579 # - search the command line for these options
5580 # - pick the last one
5581 # - perhaps add our own as a default
5582 # - perhaps adjust it to the corresponding non-source-building version
5584 foreach my $l ($cmd, $xargs) {
5586 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5589 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5591 if ($need_split_build_invocation) {
5592 printdebug "massage split $dmode.\n";
5593 $r = $dmode =~ m/[S]/ ? +2 :
5594 $dmode =~ y/gGF/ABb/ ? +1 :
5595 $dmode =~ m/[ABb]/ ? 0 :
5598 printdebug "massage done $r $dmode.\n";
5600 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5606 my $wasdir = must_getcwd();
5612 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5613 my ($msg_if_onlyone) = @_;
5614 # If there is only one .changes file, fail with $msg_if_onlyone,
5615 # or if that is undef, be a no-op.
5616 # Returns the changes file to report to the user.
5617 my $pat = changespat $version;
5618 my @changesfiles = glob $pat;
5619 @changesfiles = sort {
5620 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5624 if (@changesfiles==1) {
5625 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5626 only one changes file from build (@changesfiles)
5628 $result = $changesfiles[0];
5629 } elsif (@changesfiles==2) {
5630 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5631 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5632 fail "$l found in binaries changes file $binchanges"
5635 runcmd_ordryrun_local @mergechanges, @changesfiles;
5636 my $multichanges = changespat $version,'multi';
5638 stat_exists $multichanges or fail "$multichanges: $!";
5639 foreach my $cf (glob $pat) {
5640 next if $cf eq $multichanges;
5641 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5644 $result = $multichanges;
5646 fail "wrong number of different changes files (@changesfiles)";
5648 printdone "build successful, results in $result\n" or die $!;
5651 sub midbuild_checkchanges () {
5652 my $pat = changespat $version;
5653 return if $rmchanges;
5654 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5655 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5657 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5658 Suggest you delete @unwanted.
5663 sub midbuild_checkchanges_vanilla ($) {
5665 midbuild_checkchanges() if $wantsrc == 1;
5668 sub postbuild_mergechanges_vanilla ($) {
5670 if ($wantsrc == 1) {
5672 postbuild_mergechanges(undef);
5675 printdone "build successful\n";
5681 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5682 my $wantsrc = massage_dbp_args \@dbp;
5685 midbuild_checkchanges_vanilla $wantsrc;
5690 push @dbp, changesopts_version();
5691 maybe_apply_patches_dirtily();
5692 runcmd_ordryrun_local @dbp;
5694 maybe_unapply_patches_again();
5695 postbuild_mergechanges_vanilla $wantsrc;
5699 $quilt_mode //= 'gbp';
5705 # gbp can make .origs out of thin air. In my tests it does this
5706 # even for a 1.0 format package, with no origs present. So I
5707 # guess it keys off just the version number. We don't know
5708 # exactly what .origs ought to exist, but let's assume that we
5709 # should run gbp if: the version has an upstream part and the main
5711 my $upstreamversion = upstreamversion $version;
5712 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5713 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5715 if ($gbp_make_orig) {
5717 $cleanmode = 'none'; # don't do it again
5718 $need_split_build_invocation = 1;
5721 my @dbp = @dpkgbuildpackage;
5723 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5725 if (!length $gbp_build[0]) {
5726 if (length executable_on_path('git-buildpackage')) {
5727 $gbp_build[0] = qw(git-buildpackage);
5729 $gbp_build[0] = 'gbp buildpackage';
5732 my @cmd = opts_opt_multi_cmd @gbp_build;
5734 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5736 if ($gbp_make_orig) {
5737 ensuredir '.git/dgit';
5738 my $ok = '.git/dgit/origs-gen-ok';
5739 unlink $ok or $!==&ENOENT or die $!;
5740 my @origs_cmd = @cmd;
5741 push @origs_cmd, qw(--git-cleaner=true);
5742 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5743 push @origs_cmd, @ARGV;
5745 debugcmd @origs_cmd;
5747 do { local $!; stat_exists $ok; }
5748 or failedcmd @origs_cmd;
5750 dryrun_report @origs_cmd;
5756 midbuild_checkchanges_vanilla $wantsrc;
5758 if (!$clean_using_builder) {
5759 push @cmd, '--git-cleaner=true';
5763 maybe_unapply_patches_again();
5765 push @cmd, changesopts();
5766 runcmd_ordryrun_local @cmd, @ARGV;
5768 postbuild_mergechanges_vanilla $wantsrc;
5770 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5774 my $our_cleanmode = $cleanmode;
5775 if ($need_split_build_invocation) {
5776 # Pretend that clean is being done some other way. This
5777 # forces us not to try to use dpkg-buildpackage to clean and
5778 # build source all in one go; and instead we run dpkg-source
5779 # (and build_prep() will do the clean since $clean_using_builder
5781 $our_cleanmode = 'ELSEWHERE';
5783 if ($our_cleanmode =~ m/^dpkg-source/) {
5784 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5785 $clean_using_builder = 1;
5788 $sourcechanges = changespat $version,'source';
5790 unlink "../$sourcechanges" or $!==ENOENT
5791 or fail "remove $sourcechanges: $!";
5793 $dscfn = dscfn($version);
5794 if ($our_cleanmode eq 'dpkg-source') {
5795 maybe_apply_patches_dirtily();
5796 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5798 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5799 maybe_apply_patches_dirtily();
5800 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5803 my @cmd = (@dpkgsource, qw(-b --));
5806 runcmd_ordryrun_local @cmd, "work";
5807 my @udfiles = <${package}_*>;
5808 changedir "../../..";
5809 foreach my $f (@udfiles) {
5810 printdebug "source copy, found $f\n";
5813 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5814 $f eq srcfn($version, $&));
5815 printdebug "source copy, found $f - renaming\n";
5816 rename "$ud/$f", "../$f" or $!==ENOENT
5817 or fail "put in place new source file ($f): $!";
5820 my $pwd = must_getcwd();
5821 my $leafdir = basename $pwd;
5823 runcmd_ordryrun_local @cmd, $leafdir;
5826 runcmd_ordryrun_local qw(sh -ec),
5827 'exec >$1; shift; exec "$@"','x',
5828 "../$sourcechanges",
5829 @dpkggenchanges, qw(-S), changesopts();
5833 sub cmd_build_source {
5835 badusage "build-source takes no additional arguments" if @ARGV;
5837 maybe_unapply_patches_again();
5838 printdone "source built, results in $dscfn and $sourcechanges";
5843 midbuild_checkchanges();
5846 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5847 stat_exists $sourcechanges
5848 or fail "$sourcechanges (in parent directory): $!";
5850 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5852 maybe_unapply_patches_again();
5854 postbuild_mergechanges(<<END);
5855 perhaps you need to pass -A ? (sbuild's default is to build only
5856 arch-specific binaries; dgit 1.4 used to override that.)
5861 sub cmd_quilt_fixup {
5862 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5865 build_maybe_quilt_fixup();
5868 sub cmd_import_dsc {
5872 last unless $ARGV[0] =~ m/^-/;
5875 if (m/^--require-valid-signature$/) {
5878 badusage "unknown dgit import-dsc sub-option \`$_'";
5882 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5883 my ($dscfn, $dstbranch) = @ARGV;
5885 badusage "dry run makes no sense with import-dsc" unless act_local();
5887 my $force = $dstbranch =~ s/^\+// ? +1 :
5888 $dstbranch =~ s/^\.\.// ? -1 :
5890 my $info = $force ? " $&" : '';
5891 $info = "$dscfn$info";
5893 my $specbranch = $dstbranch;
5894 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5895 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5897 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5898 my $chead = cmdoutput_errok @symcmd;
5899 defined $chead or $?==256 or failedcmd @symcmd;
5901 fail "$dstbranch is checked out - will not update it"
5902 if defined $chead and $chead eq $dstbranch;
5904 my $oldhash = git_get_ref $dstbranch;
5906 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5907 $dscdata = do { local $/ = undef; <D>; };
5908 D->error and fail "read $dscfn: $!";
5911 # we don't normally need this so import it here
5912 use Dpkg::Source::Package;
5913 my $dp = new Dpkg::Source::Package filename => $dscfn,
5914 require_valid_signature => $needsig;
5916 local $SIG{__WARN__} = sub {
5918 return unless $needsig;
5919 fail "import-dsc signature check failed";
5921 if (!$dp->is_signed()) {
5922 warn "$us: warning: importing unsigned .dsc\n";
5924 my $r = $dp->check_signature();
5925 die "->check_signature => $r" if $needsig && $r;
5931 parse_dsc_field($dsc, "Dgit metadata in .dsc");
5933 if (defined $dsc_hash
5934 && !forceing [qw(import-dsc-with-dgit-field)]) {
5935 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5936 my @cmd = (qw(sh -ec),
5937 "echo $dsc_hash | git cat-file --batch-check");
5938 my $objgot = cmdoutput @cmd;
5939 if ($objgot =~ m#^\w+ missing\b#) {
5941 .dsc contains Dgit field referring to object $dsc_hash
5942 Your git tree does not have that object. Try `git fetch' from a
5943 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5946 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
5948 progress "Not fast forward, forced update.";
5950 fail "Not fast forward to $dsc_hash";
5953 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5954 $dstbranch, $dsc_hash);
5956 progress "dgit: import-dsc updated git ref $dstbranch";
5961 Branch $dstbranch already exists
5962 Specify ..$specbranch for a pseudo-merge, binding in existing history
5963 Specify +$specbranch to overwrite, discarding existing history
5965 if $oldhash && !$force;
5967 $package = getfield $dsc, 'Source';
5968 my @dfi = dsc_files_info();
5969 foreach my $fi (@dfi) {
5970 my $f = $fi->{Filename};
5972 next if lstat $here;
5973 fail "stat $here: $!" unless $! == ENOENT;
5975 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5977 } elsif ($dscfn =~ m#^/#) {
5980 fail "cannot import $dscfn which seems to be inside working tree!";
5982 $there =~ s#/+[^/]+$## or
5983 fail "cannot import $dscfn which seems to not have a basename";
5985 symlink $there, $here or fail "symlink $there to $here: $!";
5986 progress "made symlink $here -> $there";
5987 # print STDERR Dumper($fi);
5989 my @mergeinputs = generate_commits_from_dsc();
5990 die unless @mergeinputs == 1;
5992 my $newhash = $mergeinputs[0]{Commit};
5996 progress "Import, forced update - synthetic orphan git history.";
5997 } elsif ($force < 0) {
5998 progress "Import, merging.";
5999 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6000 my $version = getfield $dsc, 'Version';
6001 my $clogp = commit_getclogp $newhash;
6002 my $authline = clogp_authline $clogp;
6003 $newhash = make_commit_text <<END;
6010 Merge $package ($version) import into $dstbranch
6013 die; # caught earlier
6017 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
6018 $dstbranch, $newhash);
6020 progress "dgit: import-dsc results are in in git ref $dstbranch";
6023 sub cmd_archive_api_query {
6024 badusage "need only 1 subpath argument" unless @ARGV==1;
6025 my ($subpath) = @ARGV;
6026 my @cmd = archive_api_query_cmd($subpath);
6029 exec @cmd or fail "exec curl: $!\n";
6032 sub cmd_clone_dgit_repos_server {
6033 badusage "need destination argument" unless @ARGV==1;
6034 my ($destdir) = @ARGV;
6035 $package = '_dgit-repos-server';
6036 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6038 exec @cmd or fail "exec git clone: $!\n";
6041 sub cmd_setup_mergechangelogs {
6042 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6043 setup_mergechangelogs(1);
6046 sub cmd_setup_useremail {
6047 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6051 sub cmd_setup_new_tree {
6052 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6056 #---------- argument parsing and main program ----------
6059 print "dgit version $our_version\n" or die $!;
6063 our (%valopts_long, %valopts_short);
6066 sub defvalopt ($$$$) {
6067 my ($long,$short,$val_re,$how) = @_;
6068 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6069 $valopts_long{$long} = $oi;
6070 $valopts_short{$short} = $oi;
6071 # $how subref should:
6072 # do whatever assignemnt or thing it likes with $_[0]
6073 # if the option should not be passed on to remote, @rvalopts=()
6074 # or $how can be a scalar ref, meaning simply assign the value
6077 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6078 defvalopt '--distro', '-d', '.+', \$idistro;
6079 defvalopt '', '-k', '.+', \$keyid;
6080 defvalopt '--existing-package','', '.*', \$existing_package;
6081 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6082 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6083 defvalopt '--package', '-p', $package_re, \$package;
6084 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6086 defvalopt '', '-C', '.+', sub {
6087 ($changesfile) = (@_);
6088 if ($changesfile =~ s#^(.*)/##) {
6089 $buildproductsdir = $1;
6093 defvalopt '--initiator-tempdir','','.*', sub {
6094 ($initiator_tempdir) = (@_);
6095 $initiator_tempdir =~ m#^/# or
6096 badusage "--initiator-tempdir must be used specify an".
6097 " absolute, not relative, directory."
6103 if (defined $ENV{'DGIT_SSH'}) {
6104 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6105 } elsif (defined $ENV{'GIT_SSH'}) {
6106 @ssh = ($ENV{'GIT_SSH'});
6114 if (!defined $val) {
6115 badusage "$what needs a value" unless @ARGV;
6117 push @rvalopts, $val;
6119 badusage "bad value \`$val' for $what" unless
6120 $val =~ m/^$oi->{Re}$(?!\n)/s;
6121 my $how = $oi->{How};
6122 if (ref($how) eq 'SCALAR') {
6127 push @ropts, @rvalopts;
6131 last unless $ARGV[0] =~ m/^-/;
6135 if (m/^--dry-run$/) {
6138 } elsif (m/^--damp-run$/) {
6141 } elsif (m/^--no-sign$/) {
6144 } elsif (m/^--help$/) {
6146 } elsif (m/^--version$/) {
6148 } elsif (m/^--new$/) {
6151 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6152 ($om = $opts_opt_map{$1}) &&
6156 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6157 !$opts_opt_cmdonly{$1} &&
6158 ($om = $opts_opt_map{$1})) {
6161 } elsif (m/^--(gbp|dpm)$/s) {
6162 push @ropts, "--quilt=$1";
6164 } elsif (m/^--ignore-dirty$/s) {
6167 } elsif (m/^--no-quilt-fixup$/s) {
6169 $quilt_mode = 'nocheck';
6170 } elsif (m/^--no-rm-on-error$/s) {
6173 } elsif (m/^--overwrite$/s) {
6175 $overwrite_version = '';
6176 } elsif (m/^--overwrite=(.+)$/s) {
6178 $overwrite_version = $1;
6179 } elsif (m/^--dep14tag$/s) {
6181 $dodep14tag= 'want';
6182 } elsif (m/^--no-dep14tag$/s) {
6185 } elsif (m/^--always-dep14tag$/s) {
6187 $dodep14tag= 'always';
6188 } elsif (m/^--delayed=(\d+)$/s) {
6191 } elsif (m/^--dgit-view-save=(.+)$/s) {
6193 $split_brain_save = $1;
6194 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6195 } elsif (m/^--(no-)?rm-old-changes$/s) {
6198 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6200 push @deliberatelies, $&;
6201 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6205 } elsif (m/^--force-/) {
6207 "$us: warning: ignoring unknown force option $_\n";
6209 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6210 # undocumented, for testing
6212 $tagformat_want = [ $1, 'command line', 1 ];
6213 # 1 menas overrides distro configuration
6214 } elsif (m/^--always-split-source-build$/s) {
6215 # undocumented, for testing
6217 $need_split_build_invocation = 1;
6218 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6219 $val = $2 ? $' : undef; #';
6220 $valopt->($oi->{Long});
6222 badusage "unknown long option \`$_'";
6229 } elsif (s/^-L/-/) {
6232 } elsif (s/^-h/-/) {
6234 } elsif (s/^-D/-/) {
6238 } elsif (s/^-N/-/) {
6243 push @changesopts, $_;
6245 } elsif (s/^-wn$//s) {
6247 $cleanmode = 'none';
6248 } elsif (s/^-wg$//s) {
6251 } elsif (s/^-wgf$//s) {
6253 $cleanmode = 'git-ff';
6254 } elsif (s/^-wd$//s) {
6256 $cleanmode = 'dpkg-source';
6257 } elsif (s/^-wdd$//s) {
6259 $cleanmode = 'dpkg-source-d';
6260 } elsif (s/^-wc$//s) {
6262 $cleanmode = 'check';
6263 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6264 push @git, '-c', $&;
6265 $gitcfgs{cmdline}{$1} = [ $2 ];
6266 } elsif (s/^-c([^=]+)$//s) {
6267 push @git, '-c', $&;
6268 $gitcfgs{cmdline}{$1} = [ 'true' ];
6269 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6271 $val = undef unless length $val;
6272 $valopt->($oi->{Short});
6275 badusage "unknown short option \`$_'";
6282 sub check_env_sanity () {
6283 my $blocked = new POSIX::SigSet;
6284 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6287 foreach my $name (qw(PIPE CHLD)) {
6288 my $signame = "SIG$name";
6289 my $signum = eval "POSIX::$signame" // die;
6290 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6291 die "$signame is set to something other than SIG_DFL\n";
6292 $blocked->ismember($signum) and
6293 die "$signame is blocked\n";
6299 On entry to dgit, $@
6300 This is a bug produced by something in in your execution environment.
6306 sub parseopts_late_defaults () {
6307 foreach my $k (keys %opts_opt_map) {
6308 my $om = $opts_opt_map{$k};
6310 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6312 badcfg "cannot set command for $k"
6313 unless length $om->[0];
6317 foreach my $c (access_cfg_cfgs("opts-$k")) {
6319 map { $_ ? @$_ : () }
6320 map { $gitcfgs{$_}{$c} }
6321 reverse @gitcfgsources;
6322 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6323 "\n" if $debuglevel >= 4;
6325 badcfg "cannot configure options for $k"
6326 if $opts_opt_cmdonly{$k};
6327 my $insertpos = $opts_cfg_insertpos{$k};
6328 @$om = ( @$om[0..$insertpos-1],
6330 @$om[$insertpos..$#$om] );
6334 if (!defined $rmchanges) {
6335 local $access_forpush;
6336 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6339 if (!defined $quilt_mode) {
6340 local $access_forpush;
6341 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6342 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6344 $quilt_mode =~ m/^($quilt_modes_re)$/
6345 or badcfg "unknown quilt-mode \`$quilt_mode'";
6349 if (!defined $dodep14tag) {
6350 local $access_forpush;
6351 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6352 $dodep14tag =~ m/^($dodep14tag_re)$/
6353 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6357 $need_split_build_invocation ||= quiltmode_splitbrain();
6359 if (!defined $cleanmode) {
6360 local $access_forpush;
6361 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6362 $cleanmode //= 'dpkg-source';
6364 badcfg "unknown clean-mode \`$cleanmode'" unless
6365 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6369 if ($ENV{$fakeeditorenv}) {
6371 quilt_fixup_editor();
6378 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6379 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6380 if $dryrun_level == 1;
6382 print STDERR $helpmsg or die $!;
6385 my $cmd = shift @ARGV;
6388 my $pre_fn = ${*::}{"pre_$cmd"};
6389 $pre_fn->() if $pre_fn;
6391 my $fn = ${*::}{"cmd_$cmd"};
6392 $fn or badusage "unknown operation $cmd";