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;
81 our $chase_dsc_distro=1;
83 our %forceopts = map { $_=>0 }
84 qw(unrepresentable unsupported-source-format
85 dsc-changes-mismatch changes-origs-exactly
86 import-gitapply-absurd
87 import-gitapply-no-absurd
88 import-dsc-with-dgit-field);
90 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
92 our $suite_re = '[-+.0-9a-z]+';
93 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
94 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
95 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
96 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
98 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
99 our $splitbraincache = 'dgit-intern/quilt-cache';
100 our $rewritemap = 'dgit-rewrite/map';
102 our (@git) = qw(git);
103 our (@dget) = qw(dget);
104 our (@curl) = qw(curl);
105 our (@dput) = qw(dput);
106 our (@debsign) = qw(debsign);
107 our (@gpg) = qw(gpg);
108 our (@sbuild) = qw(sbuild);
110 our (@dgit) = qw(dgit);
111 our (@aptget) = qw(apt-get);
112 our (@aptcache) = qw(apt-cache);
113 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
114 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
115 our (@dpkggenchanges) = qw(dpkg-genchanges);
116 our (@mergechanges) = qw(mergechanges -f);
117 our (@gbp_build) = ('');
118 our (@gbp_pq) = ('gbp pq');
119 our (@changesopts) = ('');
121 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
124 'debsign' => \@debsign,
126 'sbuild' => \@sbuild,
130 'apt-get' => \@aptget,
131 'apt-cache' => \@aptcache,
132 'dpkg-source' => \@dpkgsource,
133 'dpkg-buildpackage' => \@dpkgbuildpackage,
134 'dpkg-genchanges' => \@dpkggenchanges,
135 'gbp-build' => \@gbp_build,
136 'gbp-pq' => \@gbp_pq,
137 'ch' => \@changesopts,
138 'mergechanges' => \@mergechanges);
140 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
141 our %opts_cfg_insertpos = map {
143 scalar @{ $opts_opt_map{$_} }
144 } keys %opts_opt_map;
146 sub parseopts_late_defaults();
152 our $supplementary_message = '';
153 our $need_split_build_invocation = 0;
154 our $split_brain = 0;
158 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
161 our $remotename = 'dgit';
162 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
166 if (!defined $absurdity) {
168 $absurdity =~ s{/[^/]+$}{/absurd} or die;
172 my ($v,$distro) = @_;
173 return $tagformatfn->($v, $distro);
176 sub debiantag_maintview ($$) {
177 my ($v,$distro) = @_;
178 return "$distro/".dep14_version_mangle $v;
181 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
183 sub lbranch () { return "$branchprefix/$csuite"; }
184 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
185 sub lref () { return "refs/heads/".lbranch(); }
186 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
187 sub rrref () { return server_ref($csuite); }
197 return "${package}_".(stripepoch $vsn).$sfx
202 return srcfn($vsn,".dsc");
205 sub changespat ($;$) {
206 my ($vsn, $arch) = @_;
207 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
210 sub upstreamversion ($) {
222 foreach my $f (@end) {
224 print STDERR "$us: cleanup: $@" if length $@;
228 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
230 sub forceable_fail ($$) {
231 my ($forceoptsl, $msg) = @_;
232 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
233 print STDERR "warning: overriding problem due to --force:\n". $msg;
237 my ($forceoptsl) = @_;
238 my @got = grep { $forceopts{$_} } @$forceoptsl;
239 return 0 unless @got;
241 "warning: skipping checks or functionality due to --force-$got[0]\n";
244 sub no_such_package () {
245 print STDERR "$us: package $package does not exist in suite $isuite\n";
251 printdebug "CD $newdir\n";
252 chdir $newdir or confess "chdir: $newdir: $!";
255 sub deliberately ($) {
257 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
260 sub deliberately_not_fast_forward () {
261 foreach (qw(not-fast-forward fresh-repo)) {
262 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
266 sub quiltmode_splitbrain () {
267 $quilt_mode =~ m/gbp|dpm|unapplied/;
270 sub opts_opt_multi_cmd {
272 push @cmd, split /\s+/, shift @_;
278 return opts_opt_multi_cmd @gbp_pq;
281 #---------- remote protocol support, common ----------
283 # remote push initiator/responder protocol:
284 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
285 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
286 # < dgit-remote-push-ready <actual-proto-vsn>
293 # > supplementary-message NBYTES # $protovsn >= 3
298 # > file parsed-changelog
299 # [indicates that output of dpkg-parsechangelog follows]
300 # > data-block NBYTES
301 # > [NBYTES bytes of data (no newline)]
302 # [maybe some more blocks]
311 # > param head DGIT-VIEW-HEAD
312 # > param csuite SUITE
313 # > param tagformat old|new
314 # > param maint-view MAINT-VIEW-HEAD
316 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
317 # # goes into tag, for replay prevention
320 # [indicates that signed tag is wanted]
321 # < data-block NBYTES
322 # < [NBYTES bytes of data (no newline)]
323 # [maybe some more blocks]
327 # > want signed-dsc-changes
328 # < data-block NBYTES [transfer of signed dsc]
330 # < data-block NBYTES [transfer of signed changes]
338 sub i_child_report () {
339 # Sees if our child has died, and reap it if so. Returns a string
340 # describing how it died if it failed, or undef otherwise.
341 return undef unless $i_child_pid;
342 my $got = waitpid $i_child_pid, WNOHANG;
343 return undef if $got <= 0;
344 die unless $got == $i_child_pid;
345 $i_child_pid = undef;
346 return undef unless $?;
347 return "build host child ".waitstatusmsg();
352 fail "connection lost: $!" if $fh->error;
353 fail "protocol violation; $m not expected";
356 sub badproto_badread ($$) {
358 fail "connection lost: $!" if $!;
359 my $report = i_child_report();
360 fail $report if defined $report;
361 badproto $fh, "eof (reading $wh)";
364 sub protocol_expect (&$) {
365 my ($match, $fh) = @_;
368 defined && chomp or badproto_badread $fh, "protocol message";
376 badproto $fh, "\`$_'";
379 sub protocol_send_file ($$) {
380 my ($fh, $ourfn) = @_;
381 open PF, "<", $ourfn or die "$ourfn: $!";
384 my $got = read PF, $d, 65536;
385 die "$ourfn: $!" unless defined $got;
387 print $fh "data-block ".length($d)."\n" or die $!;
388 print $fh $d or die $!;
390 PF->error and die "$ourfn $!";
391 print $fh "data-end\n" or die $!;
395 sub protocol_read_bytes ($$) {
396 my ($fh, $nbytes) = @_;
397 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
399 my $got = read $fh, $d, $nbytes;
400 $got==$nbytes or badproto_badread $fh, "data block";
404 sub protocol_receive_file ($$) {
405 my ($fh, $ourfn) = @_;
406 printdebug "() $ourfn\n";
407 open PF, ">", $ourfn or die "$ourfn: $!";
409 my ($y,$l) = protocol_expect {
410 m/^data-block (.*)$/ ? (1,$1) :
411 m/^data-end$/ ? (0,) :
415 my $d = protocol_read_bytes $fh, $l;
416 print PF $d or die $!;
421 #---------- remote protocol support, responder ----------
423 sub responder_send_command ($) {
425 return unless $we_are_responder;
426 # called even without $we_are_responder
427 printdebug ">> $command\n";
428 print PO $command, "\n" or die $!;
431 sub responder_send_file ($$) {
432 my ($keyword, $ourfn) = @_;
433 return unless $we_are_responder;
434 printdebug "]] $keyword $ourfn\n";
435 responder_send_command "file $keyword";
436 protocol_send_file \*PO, $ourfn;
439 sub responder_receive_files ($@) {
440 my ($keyword, @ourfns) = @_;
441 die unless $we_are_responder;
442 printdebug "[[ $keyword @ourfns\n";
443 responder_send_command "want $keyword";
444 foreach my $fn (@ourfns) {
445 protocol_receive_file \*PI, $fn;
448 protocol_expect { m/^files-end$/ } \*PI;
451 #---------- remote protocol support, initiator ----------
453 sub initiator_expect (&) {
455 protocol_expect { &$match } \*RO;
458 #---------- end remote code ----------
461 if ($we_are_responder) {
463 responder_send_command "progress ".length($m) or die $!;
464 print PO $m or die $!;
474 $ua = LWP::UserAgent->new();
478 progress "downloading $what...";
479 my $r = $ua->get(@_) or die $!;
480 return undef if $r->code == 404;
481 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
482 return $r->decoded_content(charset => 'none');
485 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
490 failedcmd @_ if system @_;
493 sub act_local () { return $dryrun_level <= 1; }
494 sub act_scary () { return !$dryrun_level; }
497 if (!$dryrun_level) {
498 progress "$us ok: @_";
500 progress "would be ok: @_ (but dry run only)";
505 printcmd(\*STDERR,$debugprefix."#",@_);
508 sub runcmd_ordryrun {
516 sub runcmd_ordryrun_local {
525 my ($first_shell, @cmd) = @_;
526 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
529 our $helpmsg = <<END;
531 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
532 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
533 dgit [dgit-opts] build [dpkg-buildpackage-opts]
534 dgit [dgit-opts] sbuild [sbuild-opts]
535 dgit [dgit-opts] push [dgit-opts] [suite]
536 dgit [dgit-opts] rpush build-host:build-dir ...
537 important dgit options:
538 -k<keyid> sign tag and package with <keyid> instead of default
539 --dry-run -n do not change anything, but go through the motions
540 --damp-run -L like --dry-run but make local changes, without signing
541 --new -N allow introducing a new package
542 --debug -D increase debug level
543 -c<name>=<value> set git config option (used directly by dgit too)
546 our $later_warning_msg = <<END;
547 Perhaps the upload is stuck in incoming. Using the version from git.
551 print STDERR "$us: @_\n", $helpmsg or die $!;
556 @ARGV or badusage "too few arguments";
557 return scalar shift @ARGV;
561 print $helpmsg or die $!;
565 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
567 our %defcfg = ('dgit.default.distro' => 'debian',
568 'dgit-suite.*-security.distro' => 'debian-security',
569 'dgit.default.username' => '',
570 'dgit.default.archive-query-default-component' => 'main',
571 'dgit.default.ssh' => 'ssh',
572 'dgit.default.archive-query' => 'madison:',
573 'dgit.default.sshpsql-dbname' => 'service=projectb',
574 'dgit.default.aptget-components' => 'main',
575 'dgit.default.dgit-tag-format' => 'new,old,maint',
576 'dgit.dsc-url-proto-ok.http' => 'true',
577 'dgit.dsc-url-proto-ok.https' => 'true',
578 'dgit.dsc-url-proto-ok.git' => 'true',
579 'dgit.default.dsc-url-proto-ok' => 'false',
580 # old means "repo server accepts pushes with old dgit tags"
581 # new means "repo server accepts pushes with new dgit tags"
582 # maint means "repo server accepts split brain pushes"
583 # hist means "repo server may have old pushes without new tag"
584 # ("hist" is implied by "old")
585 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
586 'dgit-distro.debian.git-check' => 'url',
587 'dgit-distro.debian.git-check-suffix' => '/info/refs',
588 'dgit-distro.debian.new-private-pushers' => 't',
589 'dgit-distro.debian/push.git-url' => '',
590 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
591 'dgit-distro.debian/push.git-user-force' => 'dgit',
592 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
593 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
594 'dgit-distro.debian/push.git-create' => 'true',
595 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
596 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
597 # 'dgit-distro.debian.archive-query-tls-key',
598 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
599 # ^ this does not work because curl is broken nowadays
600 # Fixing #790093 properly will involve providing providing the key
601 # in some pacagke and maybe updating these paths.
603 # 'dgit-distro.debian.archive-query-tls-curl-args',
604 # '--ca-path=/etc/ssl/ca-debian',
605 # ^ this is a workaround but works (only) on DSA-administered machines
606 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
607 'dgit-distro.debian.git-url-suffix' => '',
608 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
609 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
610 'dgit-distro.debian-security.archive-query' => 'aptget:',
611 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
612 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
613 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
614 'dgit-distro.debian-security.nominal-distro' => 'debian',
615 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
616 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
617 'dgit-distro.ubuntu.git-check' => 'false',
618 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
619 'dgit-distro.test-dummy.ssh' => "$td/ssh",
620 'dgit-distro.test-dummy.username' => "alice",
621 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
622 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
623 'dgit-distro.test-dummy.git-url' => "$td/git",
624 'dgit-distro.test-dummy.git-host' => "git",
625 'dgit-distro.test-dummy.git-path' => "$td/git",
626 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
627 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
628 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
629 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
633 our @gitcfgsources = qw(cmdline local global system);
635 sub git_slurp_config () {
636 local ($debuglevel) = $debuglevel-2;
639 # This algoritm is a bit subtle, but this is needed so that for
640 # options which we want to be single-valued, we allow the
641 # different config sources to override properly. See #835858.
642 foreach my $src (@gitcfgsources) {
643 next if $src eq 'cmdline';
644 # we do this ourselves since git doesn't handle it
646 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
649 open GITS, "-|", @cmd or die $!;
652 printdebug "=> ", (messagequote $_), "\n";
654 push @{ $gitcfgs{$src}{$`} }, $'; #';
658 or ($!==0 && $?==256)
663 sub git_get_config ($) {
665 foreach my $src (@gitcfgsources) {
666 my $l = $gitcfgs{$src}{$c};
667 croak "$l $c" if $l && !ref $l;
668 printdebug"C $c ".(defined $l ?
669 join " ", map { messagequote "'$_'" } @$l :
673 @$l==1 or badcfg "multiple values for $c".
674 " (in $src git config)" if @$l > 1;
682 return undef if $c =~ /RETURN-UNDEF/;
683 printdebug "C? $c\n" if $debuglevel >= 5;
684 my $v = git_get_config($c);
685 return $v if defined $v;
686 my $dv = $defcfg{$c};
688 printdebug "CD $c $dv\n" if $debuglevel >= 4;
692 badcfg "need value for one of: @_\n".
693 "$us: distro or suite appears not to be (properly) supported";
696 sub access_basedistro__noalias () {
697 if (defined $idistro) {
700 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
701 return $def if defined $def;
702 foreach my $src (@gitcfgsources, 'internal') {
703 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
705 foreach my $k (keys %$kl) {
706 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
708 next unless match_glob $dpat, $isuite;
712 return cfg("dgit.default.distro");
716 sub access_basedistro () {
717 my $noalias = access_basedistro__noalias();
718 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
719 return $canon // $noalias;
722 sub access_nomdistro () {
723 my $base = access_basedistro();
724 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
725 $r =~ m/^$distro_re$/ or badcfg
726 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
730 sub access_quirk () {
731 # returns (quirk name, distro to use instead or undef, quirk-specific info)
732 my $basedistro = access_basedistro();
733 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
735 if (defined $backports_quirk) {
736 my $re = $backports_quirk;
737 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
739 $re =~ s/\%/([-0-9a-z_]+)/
740 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
741 if ($isuite =~ m/^$re$/) {
742 return ('backports',"$basedistro-backports",$1);
745 return ('none',undef);
750 sub parse_cfg_bool ($$$) {
751 my ($what,$def,$v) = @_;
754 $v =~ m/^[ty1]/ ? 1 :
755 $v =~ m/^[fn0]/ ? 0 :
756 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
759 sub access_forpush_config () {
760 my $d = access_basedistro();
764 parse_cfg_bool('new-private-pushers', 0,
765 cfg("dgit-distro.$d.new-private-pushers",
768 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
771 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
772 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
773 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
774 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
777 sub access_forpush () {
778 $access_forpush //= access_forpush_config();
779 return $access_forpush;
783 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
784 badcfg "pushing but distro is configured readonly"
785 if access_forpush_config() eq '0';
787 $supplementary_message = <<'END' unless $we_are_responder;
788 Push failed, before we got started.
789 You can retry the push, after fixing the problem, if you like.
791 parseopts_late_defaults();
795 parseopts_late_defaults();
798 sub supplementary_message ($) {
800 if (!$we_are_responder) {
801 $supplementary_message = $msg;
803 } elsif ($protovsn >= 3) {
804 responder_send_command "supplementary-message ".length($msg)
806 print PO $msg or die $!;
810 sub access_distros () {
811 # Returns list of distros to try, in order
814 # 0. `instead of' distro name(s) we have been pointed to
815 # 1. the access_quirk distro, if any
816 # 2a. the user's specified distro, or failing that } basedistro
817 # 2b. the distro calculated from the suite }
818 my @l = access_basedistro();
820 my (undef,$quirkdistro) = access_quirk();
821 unshift @l, $quirkdistro;
822 unshift @l, $instead_distro;
823 @l = grep { defined } @l;
825 push @l, access_nomdistro();
827 if (access_forpush()) {
828 @l = map { ("$_/push", $_) } @l;
833 sub access_cfg_cfgs (@) {
836 # The nesting of these loops determines the search order. We put
837 # the key loop on the outside so that we search all the distros
838 # for each key, before going on to the next key. That means that
839 # if access_cfg is called with a more specific, and then a less
840 # specific, key, an earlier distro can override the less specific
841 # without necessarily overriding any more specific keys. (If the
842 # distro wants to override the more specific keys it can simply do
843 # so; whereas if we did the loop the other way around, it would be
844 # impossible to for an earlier distro to override a less specific
845 # key but not the more specific ones without restating the unknown
846 # values of the more specific keys.
849 # We have to deal with RETURN-UNDEF specially, so that we don't
850 # terminate the search prematurely.
852 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
855 foreach my $d (access_distros()) {
856 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
858 push @cfgs, map { "dgit.default.$_" } @realkeys;
865 my (@cfgs) = access_cfg_cfgs(@keys);
866 my $value = cfg(@cfgs);
870 sub access_cfg_bool ($$) {
871 my ($def, @keys) = @_;
872 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
875 sub string_to_ssh ($) {
877 if ($spec =~ m/\s/) {
878 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
884 sub access_cfg_ssh () {
885 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
886 if (!defined $gitssh) {
889 return string_to_ssh $gitssh;
893 sub access_runeinfo ($) {
895 return ": dgit ".access_basedistro()." $info ;";
898 sub access_someuserhost ($) {
900 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
901 defined($user) && length($user) or
902 $user = access_cfg("$some-user",'username');
903 my $host = access_cfg("$some-host");
904 return length($user) ? "$user\@$host" : $host;
907 sub access_gituserhost () {
908 return access_someuserhost('git');
911 sub access_giturl (;$) {
913 my $url = access_cfg('git-url','RETURN-UNDEF');
916 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
917 return undef unless defined $proto;
920 access_gituserhost().
921 access_cfg('git-path');
923 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
926 return "$url/$package$suffix";
929 sub parsecontrolfh ($$;$) {
930 my ($fh, $desc, $allowsigned) = @_;
931 our $dpkgcontrolhash_noissigned;
934 my %opts = ('name' => $desc);
935 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
936 $c = Dpkg::Control::Hash->new(%opts);
937 $c->parse($fh,$desc) or die "parsing of $desc failed";
938 last if $allowsigned;
939 last if $dpkgcontrolhash_noissigned;
940 my $issigned= $c->get_option('is_pgp_signed');
941 if (!defined $issigned) {
942 $dpkgcontrolhash_noissigned= 1;
943 seek $fh, 0,0 or die "seek $desc: $!";
944 } elsif ($issigned) {
945 fail "control file $desc is (already) PGP-signed. ".
946 " Note that dgit push needs to modify the .dsc and then".
947 " do the signature itself";
956 my ($file, $desc, $allowsigned) = @_;
957 my $fh = new IO::Handle;
958 open $fh, '<', $file or die "$file: $!";
959 my $c = parsecontrolfh($fh,$desc,$allowsigned);
960 $fh->error and die $!;
966 my ($dctrl,$field) = @_;
967 my $v = $dctrl->{$field};
968 return $v if defined $v;
969 fail "missing field $field in ".$dctrl->get_option('name');
973 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
974 my $p = new IO::Handle;
975 my @cmd = (qw(dpkg-parsechangelog), @_);
976 open $p, '-|', @cmd or die $!;
978 $?=0; $!=0; close $p or failedcmd @cmd;
982 sub commit_getclogp ($) {
983 # Returns the parsed changelog hashref for a particular commit
985 our %commit_getclogp_memo;
986 my $memo = $commit_getclogp_memo{$objid};
987 return $memo if $memo;
989 my $mclog = ".git/dgit/clog-$objid";
990 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
991 "$objid:debian/changelog";
992 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
997 defined $d or fail "getcwd failed: $!";
1001 sub parse_dscdata () {
1002 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1003 printdebug Dumper($dscdata) if $debuglevel>1;
1004 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1005 printdebug Dumper($dsc) if $debuglevel>1;
1010 sub archive_query ($;@) {
1011 my ($method) = shift @_;
1012 fail "this operation does not support multiple comma-separated suites"
1014 my $query = access_cfg('archive-query','RETURN-UNDEF');
1015 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1018 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1021 sub archive_query_prepend_mirror {
1022 my $m = access_cfg('mirror');
1023 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1026 sub pool_dsc_subpath ($$) {
1027 my ($vsn,$component) = @_; # $package is implict arg
1028 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1029 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1032 sub cfg_apply_map ($$$) {
1033 my ($varref, $what, $mapspec) = @_;
1034 return unless $mapspec;
1036 printdebug "config $what EVAL{ $mapspec; }\n";
1038 eval "package Dgit::Config; $mapspec;";
1043 #---------- `ftpmasterapi' archive query method (nascent) ----------
1045 sub archive_api_query_cmd ($) {
1047 my @cmd = (@curl, qw(-sS));
1048 my $url = access_cfg('archive-query-url');
1049 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1051 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1052 foreach my $key (split /\:/, $keys) {
1053 $key =~ s/\%HOST\%/$host/g;
1055 fail "for $url: stat $key: $!" unless $!==ENOENT;
1058 fail "config requested specific TLS key but do not know".
1059 " how to get curl to use exactly that EE key ($key)";
1060 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1061 # # Sadly the above line does not work because of changes
1062 # # to gnutls. The real fix for #790093 may involve
1063 # # new curl options.
1066 # Fixing #790093 properly will involve providing a value
1067 # for this on clients.
1068 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1069 push @cmd, split / /, $kargs if defined $kargs;
1071 push @cmd, $url.$subpath;
1075 sub api_query ($$;$) {
1077 my ($data, $subpath, $ok404) = @_;
1078 badcfg "ftpmasterapi archive query method takes no data part"
1080 my @cmd = archive_api_query_cmd($subpath);
1081 my $url = $cmd[$#cmd];
1082 push @cmd, qw(-w %{http_code});
1083 my $json = cmdoutput @cmd;
1084 unless ($json =~ s/\d+\d+\d$//) {
1085 failedcmd_report_cmd undef, @cmd;
1086 fail "curl failed to print 3-digit HTTP code";
1089 return undef if $code eq '404' && $ok404;
1090 fail "fetch of $url gave HTTP code $code"
1091 unless $url =~ m#^file://# or $code =~ m/^2/;
1092 return decode_json($json);
1095 sub canonicalise_suite_ftpmasterapi {
1096 my ($proto,$data) = @_;
1097 my $suites = api_query($data, 'suites');
1099 foreach my $entry (@$suites) {
1101 my $v = $entry->{$_};
1102 defined $v && $v eq $isuite;
1103 } qw(codename name);
1104 push @matched, $entry;
1106 fail "unknown suite $isuite" unless @matched;
1109 @matched==1 or die "multiple matches for suite $isuite\n";
1110 $cn = "$matched[0]{codename}";
1111 defined $cn or die "suite $isuite info has no codename\n";
1112 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1114 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1119 sub archive_query_ftpmasterapi {
1120 my ($proto,$data) = @_;
1121 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1123 my $digester = Digest::SHA->new(256);
1124 foreach my $entry (@$info) {
1126 my $vsn = "$entry->{version}";
1127 my ($ok,$msg) = version_check $vsn;
1128 die "bad version: $msg\n" unless $ok;
1129 my $component = "$entry->{component}";
1130 $component =~ m/^$component_re$/ or die "bad component";
1131 my $filename = "$entry->{filename}";
1132 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1133 or die "bad filename";
1134 my $sha256sum = "$entry->{sha256sum}";
1135 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1136 push @rows, [ $vsn, "/pool/$component/$filename",
1137 $digester, $sha256sum ];
1139 die "bad ftpmaster api response: $@\n".Dumper($entry)
1142 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1143 return archive_query_prepend_mirror @rows;
1146 sub file_in_archive_ftpmasterapi {
1147 my ($proto,$data,$filename) = @_;
1148 my $pat = $filename;
1151 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1152 my $info = api_query($data, "file_in_archive/$pat", 1);
1155 #---------- `aptget' archive query method ----------
1158 our $aptget_releasefile;
1159 our $aptget_configpath;
1161 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1162 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1164 sub aptget_cache_clean {
1165 runcmd_ordryrun_local qw(sh -ec),
1166 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1170 sub aptget_lock_acquire () {
1171 my $lockfile = "$aptget_base/lock";
1172 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1173 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1176 sub aptget_prep ($) {
1178 return if defined $aptget_base;
1180 badcfg "aptget archive query method takes no data part"
1183 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1186 ensuredir "$cache/dgit";
1188 access_cfg('aptget-cachekey','RETURN-UNDEF')
1189 // access_nomdistro();
1191 $aptget_base = "$cache/dgit/aptget";
1192 ensuredir $aptget_base;
1194 my $quoted_base = $aptget_base;
1195 die "$quoted_base contains bad chars, cannot continue"
1196 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1198 ensuredir $aptget_base;
1200 aptget_lock_acquire();
1202 aptget_cache_clean();
1204 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1205 my $sourceslist = "source.list#$cachekey";
1207 my $aptsuites = $isuite;
1208 cfg_apply_map(\$aptsuites, 'suite map',
1209 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1211 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1212 printf SRCS "deb-src %s %s %s\n",
1213 access_cfg('mirror'),
1215 access_cfg('aptget-components')
1218 ensuredir "$aptget_base/cache";
1219 ensuredir "$aptget_base/lists";
1221 open CONF, ">", $aptget_configpath or die $!;
1223 Debug::NoLocking "true";
1224 APT::Get::List-Cleanup "false";
1225 #clear APT::Update::Post-Invoke-Success;
1226 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1227 Dir::State::Lists "$quoted_base/lists";
1228 Dir::Etc::preferences "$quoted_base/preferences";
1229 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1230 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1233 foreach my $key (qw(
1236 Dir::Cache::Archives
1237 Dir::Etc::SourceParts
1238 Dir::Etc::preferencesparts
1240 ensuredir "$aptget_base/$key";
1241 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1244 my $oldatime = (time // die $!) - 1;
1245 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1246 next unless stat_exists $oldlist;
1247 my ($mtime) = (stat _)[9];
1248 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1251 runcmd_ordryrun_local aptget_aptget(), qw(update);
1254 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1255 next unless stat_exists $oldlist;
1256 my ($atime) = (stat _)[8];
1257 next if $atime == $oldatime;
1258 push @releasefiles, $oldlist;
1260 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1261 @releasefiles = @inreleasefiles if @inreleasefiles;
1262 die "apt updated wrong number of Release files (@releasefiles), erk"
1263 unless @releasefiles == 1;
1265 ($aptget_releasefile) = @releasefiles;
1268 sub canonicalise_suite_aptget {
1269 my ($proto,$data) = @_;
1272 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1274 foreach my $name (qw(Codename Suite)) {
1275 my $val = $release->{$name};
1277 printdebug "release file $name: $val\n";
1278 $val =~ m/^$suite_re$/o or fail
1279 "Release file ($aptget_releasefile) specifies intolerable $name";
1280 cfg_apply_map(\$val, 'suite rmap',
1281 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1288 sub archive_query_aptget {
1289 my ($proto,$data) = @_;
1292 ensuredir "$aptget_base/source";
1293 foreach my $old (<$aptget_base/source/*.dsc>) {
1294 unlink $old or die "$old: $!";
1297 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1298 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1299 # avoids apt-get source failing with ambiguous error code
1301 runcmd_ordryrun_local
1302 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1303 aptget_aptget(), qw(--download-only --only-source source), $package;
1305 my @dscs = <$aptget_base/source/*.dsc>;
1306 fail "apt-get source did not produce a .dsc" unless @dscs;
1307 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1309 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1312 my $uri = "file://". uri_escape $dscs[0];
1313 $uri =~ s{\%2f}{/}gi;
1314 return [ (getfield $pre_dsc, 'Version'), $uri ];
1317 #---------- `dummyapicat' archive query method ----------
1319 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1320 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1322 sub file_in_archive_dummycatapi ($$$) {
1323 my ($proto,$data,$filename) = @_;
1324 my $mirror = access_cfg('mirror');
1325 $mirror =~ s#^file://#/# or die "$mirror ?";
1327 my @cmd = (qw(sh -ec), '
1329 find -name "$2" -print0 |
1331 ', qw(x), $mirror, $filename);
1332 debugcmd "-|", @cmd;
1333 open FIA, "-|", @cmd or die $!;
1336 printdebug "| $_\n";
1337 m/^(\w+) (\S+)$/ or die "$_ ?";
1338 push @out, { sha256sum => $1, filename => $2 };
1340 close FIA or die failedcmd @cmd;
1344 #---------- `madison' archive query method ----------
1346 sub archive_query_madison {
1347 return archive_query_prepend_mirror
1348 map { [ @$_[0..1] ] } madison_get_parse(@_);
1351 sub madison_get_parse {
1352 my ($proto,$data) = @_;
1353 die unless $proto eq 'madison';
1354 if (!length $data) {
1355 $data= access_cfg('madison-distro','RETURN-UNDEF');
1356 $data //= access_basedistro();
1358 $rmad{$proto,$data,$package} ||= cmdoutput
1359 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1360 my $rmad = $rmad{$proto,$data,$package};
1363 foreach my $l (split /\n/, $rmad) {
1364 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1365 \s*( [^ \t|]+ )\s* \|
1366 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1367 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1368 $1 eq $package or die "$rmad $package ?";
1375 $component = access_cfg('archive-query-default-component');
1377 $5 eq 'source' or die "$rmad ?";
1378 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1380 return sort { -version_compare($a->[0],$b->[0]); } @out;
1383 sub canonicalise_suite_madison {
1384 # madison canonicalises for us
1385 my @r = madison_get_parse(@_);
1387 "unable to canonicalise suite using package $package".
1388 " which does not appear to exist in suite $isuite;".
1389 " --existing-package may help";
1393 sub file_in_archive_madison { return undef; }
1395 #---------- `sshpsql' archive query method ----------
1398 my ($data,$runeinfo,$sql) = @_;
1399 if (!length $data) {
1400 $data= access_someuserhost('sshpsql').':'.
1401 access_cfg('sshpsql-dbname');
1403 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1404 my ($userhost,$dbname) = ($`,$'); #';
1406 my @cmd = (access_cfg_ssh, $userhost,
1407 access_runeinfo("ssh-psql $runeinfo").
1408 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1409 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1411 open P, "-|", @cmd or die $!;
1414 printdebug(">|$_|\n");
1417 $!=0; $?=0; close P or failedcmd @cmd;
1419 my $nrows = pop @rows;
1420 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1421 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1422 @rows = map { [ split /\|/, $_ ] } @rows;
1423 my $ncols = scalar @{ shift @rows };
1424 die if grep { scalar @$_ != $ncols } @rows;
1428 sub sql_injection_check {
1429 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1432 sub archive_query_sshpsql ($$) {
1433 my ($proto,$data) = @_;
1434 sql_injection_check $isuite, $package;
1435 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1436 SELECT source.version, component.name, files.filename, files.sha256sum
1438 JOIN src_associations ON source.id = src_associations.source
1439 JOIN suite ON suite.id = src_associations.suite
1440 JOIN dsc_files ON dsc_files.source = source.id
1441 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1442 JOIN component ON component.id = files_archive_map.component_id
1443 JOIN files ON files.id = dsc_files.file
1444 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1445 AND source.source='$package'
1446 AND files.filename LIKE '%.dsc';
1448 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1449 my $digester = Digest::SHA->new(256);
1451 my ($vsn,$component,$filename,$sha256sum) = @$_;
1452 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1454 return archive_query_prepend_mirror @rows;
1457 sub canonicalise_suite_sshpsql ($$) {
1458 my ($proto,$data) = @_;
1459 sql_injection_check $isuite;
1460 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1461 SELECT suite.codename
1462 FROM suite where suite_name='$isuite' or codename='$isuite';
1464 @rows = map { $_->[0] } @rows;
1465 fail "unknown suite $isuite" unless @rows;
1466 die "ambiguous $isuite: @rows ?" if @rows>1;
1470 sub file_in_archive_sshpsql ($$$) { return undef; }
1472 #---------- `dummycat' archive query method ----------
1474 sub canonicalise_suite_dummycat ($$) {
1475 my ($proto,$data) = @_;
1476 my $dpath = "$data/suite.$isuite";
1477 if (!open C, "<", $dpath) {
1478 $!==ENOENT or die "$dpath: $!";
1479 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1483 chomp or die "$dpath: $!";
1485 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1489 sub archive_query_dummycat ($$) {
1490 my ($proto,$data) = @_;
1491 canonicalise_suite();
1492 my $dpath = "$data/package.$csuite.$package";
1493 if (!open C, "<", $dpath) {
1494 $!==ENOENT or die "$dpath: $!";
1495 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1503 printdebug "dummycat query $csuite $package $dpath | $_\n";
1504 my @row = split /\s+/, $_;
1505 @row==2 or die "$dpath: $_ ?";
1508 C->error and die "$dpath: $!";
1510 return archive_query_prepend_mirror
1511 sort { -version_compare($a->[0],$b->[0]); } @rows;
1514 sub file_in_archive_dummycat () { return undef; }
1516 #---------- tag format handling ----------
1518 sub access_cfg_tagformats () {
1519 split /\,/, access_cfg('dgit-tag-format');
1522 sub access_cfg_tagformats_can_splitbrain () {
1523 my %y = map { $_ => 1 } access_cfg_tagformats;
1524 foreach my $needtf (qw(new maint)) {
1525 next if $y{$needtf};
1531 sub need_tagformat ($$) {
1532 my ($fmt, $why) = @_;
1533 fail "need to use tag format $fmt ($why) but also need".
1534 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1535 " - no way to proceed"
1536 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1537 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1540 sub select_tagformat () {
1542 return if $tagformatfn && !$tagformat_want;
1543 die 'bug' if $tagformatfn && $tagformat_want;
1544 # ... $tagformat_want assigned after previous select_tagformat
1546 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1547 printdebug "select_tagformat supported @supported\n";
1549 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1550 printdebug "select_tagformat specified @$tagformat_want\n";
1552 my ($fmt,$why,$override) = @$tagformat_want;
1554 fail "target distro supports tag formats @supported".
1555 " but have to use $fmt ($why)"
1557 or grep { $_ eq $fmt } @supported;
1559 $tagformat_want = undef;
1561 $tagformatfn = ${*::}{"debiantag_$fmt"};
1563 fail "trying to use unknown tag format \`$fmt' ($why) !"
1564 unless $tagformatfn;
1567 #---------- archive query entrypoints and rest of program ----------
1569 sub canonicalise_suite () {
1570 return if defined $csuite;
1571 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1572 $csuite = archive_query('canonicalise_suite');
1573 if ($isuite ne $csuite) {
1574 progress "canonical suite name for $isuite is $csuite";
1576 progress "canonical suite name is $csuite";
1580 sub get_archive_dsc () {
1581 canonicalise_suite();
1582 my @vsns = archive_query('archive_query');
1583 foreach my $vinfo (@vsns) {
1584 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1585 $dscurl = $vsn_dscurl;
1586 $dscdata = url_get($dscurl);
1588 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1593 $digester->add($dscdata);
1594 my $got = $digester->hexdigest();
1596 fail "$dscurl has hash $got but".
1597 " archive told us to expect $digest";
1600 my $fmt = getfield $dsc, 'Format';
1601 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1602 "unsupported source format $fmt, sorry";
1604 $dsc_checked = !!$digester;
1605 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1609 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1612 sub check_for_git ();
1613 sub check_for_git () {
1615 my $how = access_cfg('git-check');
1616 if ($how eq 'ssh-cmd') {
1618 (access_cfg_ssh, access_gituserhost(),
1619 access_runeinfo("git-check $package").
1620 " set -e; cd ".access_cfg('git-path').";".
1621 " if test -d $package.git; then echo 1; else echo 0; fi");
1622 my $r= cmdoutput @cmd;
1623 if (defined $r and $r =~ m/^divert (\w+)$/) {
1625 my ($usedistro,) = access_distros();
1626 # NB that if we are pushing, $usedistro will be $distro/push
1627 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1628 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1629 progress "diverting to $divert (using config for $instead_distro)";
1630 return check_for_git();
1632 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1634 } elsif ($how eq 'url') {
1635 my $prefix = access_cfg('git-check-url','git-url');
1636 my $suffix = access_cfg('git-check-suffix','git-suffix',
1637 'RETURN-UNDEF') // '.git';
1638 my $url = "$prefix/$package$suffix";
1639 my @cmd = (@curl, qw(-sS -I), $url);
1640 my $result = cmdoutput @cmd;
1641 $result =~ s/^\S+ 200 .*\n\r?\n//;
1642 # curl -sS -I with https_proxy prints
1643 # HTTP/1.0 200 Connection established
1644 $result =~ m/^\S+ (404|200) /s or
1645 fail "unexpected results from git check query - ".
1646 Dumper($prefix, $result);
1648 if ($code eq '404') {
1650 } elsif ($code eq '200') {
1655 } elsif ($how eq 'true') {
1657 } elsif ($how eq 'false') {
1660 badcfg "unknown git-check \`$how'";
1664 sub create_remote_git_repo () {
1665 my $how = access_cfg('git-create');
1666 if ($how eq 'ssh-cmd') {
1668 (access_cfg_ssh, access_gituserhost(),
1669 access_runeinfo("git-create $package").
1670 "set -e; cd ".access_cfg('git-path').";".
1671 " cp -a _template $package.git");
1672 } elsif ($how eq 'true') {
1675 badcfg "unknown git-create \`$how'";
1679 our ($dsc_hash,$lastpush_mergeinput);
1680 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1682 our $ud = '.git/dgit/unpack';
1692 sub mktree_in_ud_here () {
1693 runcmd qw(git init -q);
1694 runcmd qw(git config gc.auto 0);
1695 rmtree('.git/objects');
1696 symlink '../../../../objects','.git/objects' or die $!;
1699 sub git_write_tree () {
1700 my $tree = cmdoutput @git, qw(write-tree);
1701 $tree =~ m/^\w+$/ or die "$tree ?";
1705 sub git_add_write_tree () {
1706 runcmd @git, qw(add -Af .);
1707 return git_write_tree();
1710 sub remove_stray_gits ($) {
1712 my @gitscmd = qw(find -name .git -prune -print0);
1713 debugcmd "|",@gitscmd;
1714 open GITS, "-|", @gitscmd or die $!;
1719 print STDERR "$us: warning: removing from $what: ",
1720 (messagequote $_), "\n";
1724 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1727 sub mktree_in_ud_from_only_subdir ($;$) {
1728 my ($what,$raw) = @_;
1730 # changes into the subdir
1732 die "expected one subdir but found @dirs ?" unless @dirs==1;
1733 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1737 remove_stray_gits($what);
1738 mktree_in_ud_here();
1740 my ($format, $fopts) = get_source_format();
1741 if (madformat($format)) {
1746 my $tree=git_add_write_tree();
1747 return ($tree,$dir);
1750 our @files_csum_info_fields =
1751 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1752 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1753 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1755 sub dsc_files_info () {
1756 foreach my $csumi (@files_csum_info_fields) {
1757 my ($fname, $module, $method) = @$csumi;
1758 my $field = $dsc->{$fname};
1759 next unless defined $field;
1760 eval "use $module; 1;" or die $@;
1762 foreach (split /\n/, $field) {
1764 m/^(\w+) (\d+) (\S+)$/ or
1765 fail "could not parse .dsc $fname line \`$_'";
1766 my $digester = eval "$module"."->$method;" or die $@;
1771 Digester => $digester,
1776 fail "missing any supported Checksums-* or Files field in ".
1777 $dsc->get_option('name');
1781 map { $_->{Filename} } dsc_files_info();
1784 sub files_compare_inputs (@) {
1789 my $showinputs = sub {
1790 return join "; ", map { $_->get_option('name') } @$inputs;
1793 foreach my $in (@$inputs) {
1795 my $in_name = $in->get_option('name');
1797 printdebug "files_compare_inputs $in_name\n";
1799 foreach my $csumi (@files_csum_info_fields) {
1800 my ($fname) = @$csumi;
1801 printdebug "files_compare_inputs $in_name $fname\n";
1803 my $field = $in->{$fname};
1804 next unless defined $field;
1807 foreach (split /\n/, $field) {
1810 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1811 fail "could not parse $in_name $fname line \`$_'";
1813 printdebug "files_compare_inputs $in_name $fname $f\n";
1817 my $re = \ $record{$f}{$fname};
1819 $fchecked{$f}{$in_name} = 1;
1821 fail "hash or size of $f varies in $fname fields".
1822 " (between: ".$showinputs->().")";
1827 @files = sort @files;
1828 $expected_files //= \@files;
1829 "@$expected_files" eq "@files" or
1830 fail "file list in $in_name varies between hash fields!";
1833 fail "$in_name has no files list field(s)";
1835 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1838 grep { keys %$_ == @$inputs-1 } values %fchecked
1839 or fail "no file appears in all file lists".
1840 " (looked in: ".$showinputs->().")";
1843 sub is_orig_file_in_dsc ($$) {
1844 my ($f, $dsc_files_info) = @_;
1845 return 0 if @$dsc_files_info <= 1;
1846 # One file means no origs, and the filename doesn't have a "what
1847 # part of dsc" component. (Consider versions ending `.orig'.)
1848 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1852 sub is_orig_file_of_vsn ($$) {
1853 my ($f, $upstreamvsn) = @_;
1854 my $base = srcfn $upstreamvsn, '';
1855 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1859 sub changes_update_origs_from_dsc ($$$$) {
1860 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1862 printdebug "checking origs needed ($upstreamvsn)...\n";
1863 $_ = getfield $changes, 'Files';
1864 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1865 fail "cannot find section/priority from .changes Files field";
1866 my $placementinfo = $1;
1868 printdebug "checking origs needed placement '$placementinfo'...\n";
1869 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1870 $l =~ m/\S+$/ or next;
1872 printdebug "origs $file | $l\n";
1873 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1874 printdebug "origs $file is_orig\n";
1875 my $have = archive_query('file_in_archive', $file);
1876 if (!defined $have) {
1878 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1884 printdebug "origs $file \$#\$have=$#$have\n";
1885 foreach my $h (@$have) {
1888 foreach my $csumi (@files_csum_info_fields) {
1889 my ($fname, $module, $method, $archivefield) = @$csumi;
1890 next unless defined $h->{$archivefield};
1891 $_ = $dsc->{$fname};
1892 next unless defined;
1893 m/^(\w+) .* \Q$file\E$/m or
1894 fail ".dsc $fname missing entry for $file";
1895 if ($h->{$archivefield} eq $1) {
1899 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1902 die "$file ".Dumper($h)." ?!" if $same && @differ;
1905 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1908 printdebug "origs $file f.same=$found_same".
1909 " #f._differ=$#found_differ\n";
1910 if (@found_differ && !$found_same) {
1912 "archive contains $file with different checksum",
1915 # Now we edit the changes file to add or remove it
1916 foreach my $csumi (@files_csum_info_fields) {
1917 my ($fname, $module, $method, $archivefield) = @$csumi;
1918 next unless defined $changes->{$fname};
1920 # in archive, delete from .changes if it's there
1921 $changed{$file} = "removed" if
1922 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1923 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1924 # not in archive, but it's here in the .changes
1926 my $dsc_data = getfield $dsc, $fname;
1927 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1929 $extra =~ s/ \d+ /$&$placementinfo /
1930 or die "$fname $extra >$dsc_data< ?"
1931 if $fname eq 'Files';
1932 $changes->{$fname} .= "\n". $extra;
1933 $changed{$file} = "added";
1938 foreach my $file (keys %changed) {
1940 "edited .changes for archive .orig contents: %s %s",
1941 $changed{$file}, $file;
1943 my $chtmp = "$changesfile.tmp";
1944 $changes->save($chtmp);
1946 rename $chtmp,$changesfile or die "$changesfile $!";
1948 progress "[new .changes left in $changesfile]";
1951 progress "$changesfile already has appropriate .orig(s) (if any)";
1955 sub make_commit ($) {
1957 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1960 sub make_commit_text ($) {
1963 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1965 print Dumper($text) if $debuglevel > 1;
1966 my $child = open2($out, $in, @cmd) or die $!;
1969 print $in $text or die $!;
1970 close $in or die $!;
1972 $h =~ m/^\w+$/ or die;
1974 printdebug "=> $h\n";
1977 waitpid $child, 0 == $child or die "$child $!";
1978 $? and failedcmd @cmd;
1982 sub clogp_authline ($) {
1984 my $author = getfield $clogp, 'Maintainer';
1985 $author =~ s#,.*##ms;
1986 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1987 my $authline = "$author $date";
1988 $authline =~ m/$git_authline_re/o or
1989 fail "unexpected commit author line format \`$authline'".
1990 " (was generated from changelog Maintainer field)";
1991 return ($1,$2,$3) if wantarray;
1995 sub vendor_patches_distro ($$) {
1996 my ($checkdistro, $what) = @_;
1997 return unless defined $checkdistro;
1999 my $series = "debian/patches/\L$checkdistro\E.series";
2000 printdebug "checking for vendor-specific $series ($what)\n";
2002 if (!open SERIES, "<", $series) {
2003 die "$series $!" unless $!==ENOENT;
2012 Unfortunately, this source package uses a feature of dpkg-source where
2013 the same source package unpacks to different source code on different
2014 distros. dgit cannot safely operate on such packages on affected
2015 distros, because the meaning of source packages is not stable.
2017 Please ask the distro/maintainer to remove the distro-specific series
2018 files and use a different technique (if necessary, uploading actually
2019 different packages, if different distros are supposed to have
2023 fail "Found active distro-specific series file for".
2024 " $checkdistro ($what): $series, cannot continue";
2026 die "$series $!" if SERIES->error;
2030 sub check_for_vendor_patches () {
2031 # This dpkg-source feature doesn't seem to be documented anywhere!
2032 # But it can be found in the changelog (reformatted):
2034 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2035 # Author: Raphael Hertzog <hertzog@debian.org>
2036 # Date: Sun Oct 3 09:36:48 2010 +0200
2038 # dpkg-source: correctly create .pc/.quilt_series with alternate
2041 # If you have debian/patches/ubuntu.series and you were
2042 # unpacking the source package on ubuntu, quilt was still
2043 # directed to debian/patches/series instead of
2044 # debian/patches/ubuntu.series.
2046 # debian/changelog | 3 +++
2047 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2048 # 2 files changed, 6 insertions(+), 1 deletion(-)
2051 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2052 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2053 "Dpkg::Vendor \`current vendor'");
2054 vendor_patches_distro(access_basedistro(),
2055 "(base) distro being accessed");
2056 vendor_patches_distro(access_nomdistro(),
2057 "(nominal) distro being accessed");
2060 sub generate_commits_from_dsc () {
2061 # See big comment in fetch_from_archive, below.
2062 # See also README.dsc-import.
2066 my @dfi = dsc_files_info();
2067 foreach my $fi (@dfi) {
2068 my $f = $fi->{Filename};
2069 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2071 printdebug "considering linking $f: ";
2073 link_ltarget "../../../../$f", $f
2074 or ((printdebug "($!) "), 0)
2078 printdebug "linked.\n";
2080 complete_file_from_dsc('.', $fi)
2083 if (is_orig_file_in_dsc($f, \@dfi)) {
2084 link $f, "../../../../$f"
2090 # We unpack and record the orig tarballs first, so that we only
2091 # need disk space for one private copy of the unpacked source.
2092 # But we can't make them into commits until we have the metadata
2093 # from the debian/changelog, so we record the tree objects now and
2094 # make them into commits later.
2096 my $upstreamv = upstreamversion $dsc->{version};
2097 my $orig_f_base = srcfn $upstreamv, '';
2099 foreach my $fi (@dfi) {
2100 # We actually import, and record as a commit, every tarball
2101 # (unless there is only one file, in which case there seems
2104 my $f = $fi->{Filename};
2105 printdebug "import considering $f ";
2106 (printdebug "only one dfi\n"), next if @dfi == 1;
2107 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2108 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2112 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2114 printdebug "Y ", (join ' ', map { $_//"(none)" }
2115 $compr_ext, $orig_f_part
2118 my $input = new IO::File $f, '<' or die "$f $!";
2122 if (defined $compr_ext) {
2124 Dpkg::Compression::compression_guess_from_filename $f;
2125 fail "Dpkg::Compression cannot handle file $f in source package"
2126 if defined $compr_ext && !defined $cname;
2128 new Dpkg::Compression::Process compression => $cname;
2129 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2130 my $compr_fh = new IO::Handle;
2131 my $compr_pid = open $compr_fh, "-|" // die $!;
2133 open STDIN, "<&", $input or die $!;
2135 die "dgit (child): exec $compr_cmd[0]: $!\n";
2140 rmtree "_unpack-tar";
2141 mkdir "_unpack-tar" or die $!;
2142 my @tarcmd = qw(tar -x -f -
2143 --no-same-owner --no-same-permissions
2144 --no-acls --no-xattrs --no-selinux);
2145 my $tar_pid = fork // die $!;
2147 chdir "_unpack-tar" or die $!;
2148 open STDIN, "<&", $input or die $!;
2150 die "dgit (child): exec $tarcmd[0]: $!";
2152 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2153 !$? or failedcmd @tarcmd;
2156 (@compr_cmd ? failedcmd @compr_cmd
2158 # finally, we have the results in "tarball", but maybe
2159 # with the wrong permissions
2161 runcmd qw(chmod -R +rwX _unpack-tar);
2162 changedir "_unpack-tar";
2163 remove_stray_gits($f);
2164 mktree_in_ud_here();
2166 my ($tree) = git_add_write_tree();
2167 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2168 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2170 printdebug "one subtree $1\n";
2172 printdebug "multiple subtrees\n";
2175 rmtree "_unpack-tar";
2177 my $ent = [ $f, $tree ];
2179 Orig => !!$orig_f_part,
2180 Sort => (!$orig_f_part ? 2 :
2181 $orig_f_part =~ m/-/g ? 1 :
2189 # put any without "_" first (spec is not clear whether files
2190 # are always in the usual order). Tarballs without "_" are
2191 # the main orig or the debian tarball.
2192 $a->{Sort} <=> $b->{Sort} or
2196 my $any_orig = grep { $_->{Orig} } @tartrees;
2198 my $dscfn = "$package.dsc";
2200 my $treeimporthow = 'package';
2202 open D, ">", $dscfn or die "$dscfn: $!";
2203 print D $dscdata or die "$dscfn: $!";
2204 close D or die "$dscfn: $!";
2205 my @cmd = qw(dpkg-source);
2206 push @cmd, '--no-check' if $dsc_checked;
2207 if (madformat $dsc->{format}) {
2208 push @cmd, '--skip-patches';
2209 $treeimporthow = 'unpatched';
2211 push @cmd, qw(-x --), $dscfn;
2214 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2215 if (madformat $dsc->{format}) {
2216 check_for_vendor_patches();
2220 if (madformat $dsc->{format}) {
2221 my @pcmd = qw(dpkg-source --before-build .);
2222 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2224 $dappliedtree = git_add_write_tree();
2227 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2228 debugcmd "|",@clogcmd;
2229 open CLOGS, "-|", @clogcmd or die $!;
2234 printdebug "import clog search...\n";
2237 my $stanzatext = do { local $/=""; <CLOGS>; };
2238 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2239 last if !defined $stanzatext;
2241 my $desc = "package changelog, entry no.$.";
2242 open my $stanzafh, "<", \$stanzatext or die;
2243 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2244 $clogp //= $thisstanza;
2246 printdebug "import clog $thisstanza->{version} $desc...\n";
2248 last if !$any_orig; # we don't need $r1clogp
2250 # We look for the first (most recent) changelog entry whose
2251 # version number is lower than the upstream version of this
2252 # package. Then the last (least recent) previous changelog
2253 # entry is treated as the one which introduced this upstream
2254 # version and used for the synthetic commits for the upstream
2257 # One might think that a more sophisticated algorithm would be
2258 # necessary. But: we do not want to scan the whole changelog
2259 # file. Stopping when we see an earlier version, which
2260 # necessarily then is an earlier upstream version, is the only
2261 # realistic way to do that. Then, either the earliest
2262 # changelog entry we have seen so far is indeed the earliest
2263 # upload of this upstream version; or there are only changelog
2264 # entries relating to later upstream versions (which is not
2265 # possible unless the changelog and .dsc disagree about the
2266 # version). Then it remains to choose between the physically
2267 # last entry in the file, and the one with the lowest version
2268 # number. If these are not the same, we guess that the
2269 # versions were created in a non-monotic order rather than
2270 # that the changelog entries have been misordered.
2272 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2274 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2275 $r1clogp = $thisstanza;
2277 printdebug "import clog $r1clogp->{version} becomes r1\n";
2279 die $! if CLOGS->error;
2280 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2282 $clogp or fail "package changelog has no entries!";
2284 my $authline = clogp_authline $clogp;
2285 my $changes = getfield $clogp, 'Changes';
2286 my $cversion = getfield $clogp, 'Version';
2289 $r1clogp //= $clogp; # maybe there's only one entry;
2290 my $r1authline = clogp_authline $r1clogp;
2291 # Strictly, r1authline might now be wrong if it's going to be
2292 # unused because !$any_orig. Whatever.
2294 printdebug "import tartrees authline $authline\n";
2295 printdebug "import tartrees r1authline $r1authline\n";
2297 foreach my $tt (@tartrees) {
2298 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2300 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2303 committer $r1authline
2307 [dgit import orig $tt->{F}]
2315 [dgit import tarball $package $cversion $tt->{F}]
2320 printdebug "import main commit\n";
2322 open C, ">../commit.tmp" or die $!;
2323 print C <<END or die $!;
2326 print C <<END or die $! foreach @tartrees;
2329 print C <<END or die $!;
2335 [dgit import $treeimporthow $package $cversion]
2339 my $rawimport_hash = make_commit qw(../commit.tmp);
2341 if (madformat $dsc->{format}) {
2342 printdebug "import apply patches...\n";
2344 # regularise the state of the working tree so that
2345 # the checkout of $rawimport_hash works nicely.
2346 my $dappliedcommit = make_commit_text(<<END);
2353 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2355 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2357 # We need the answers to be reproducible
2358 my @authline = clogp_authline($clogp);
2359 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2360 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2361 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2362 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2363 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2364 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2366 my $path = $ENV{PATH} or die;
2368 foreach my $use_absurd (qw(0 1)) {
2369 runcmd @git, qw(checkout -q unpa);
2370 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2371 local $ENV{PATH} = $path;
2374 progress "warning: $@";
2375 $path = "$absurdity:$path";
2376 progress "$us: trying slow absurd-git-apply...";
2377 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2382 die "forbid absurd git-apply\n" if $use_absurd
2383 && forceing [qw(import-gitapply-no-absurd)];
2384 die "only absurd git-apply!\n" if !$use_absurd
2385 && forceing [qw(import-gitapply-absurd)];
2387 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2388 local $ENV{PATH} = $path if $use_absurd;
2390 my @showcmd = (gbp_pq, qw(import));
2391 my @realcmd = shell_cmd
2392 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2393 debugcmd "+",@realcmd;
2394 if (system @realcmd) {
2395 die +(shellquote @showcmd).
2397 failedcmd_waitstatus()."\n";
2400 my $gapplied = git_rev_parse('HEAD');
2401 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2402 $gappliedtree eq $dappliedtree or
2404 gbp-pq import and dpkg-source disagree!
2405 gbp-pq import gave commit $gapplied
2406 gbp-pq import gave tree $gappliedtree
2407 dpkg-source --before-build gave tree $dappliedtree
2409 $rawimport_hash = $gapplied;
2414 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2419 progress "synthesised git commit from .dsc $cversion";
2421 my $rawimport_mergeinput = {
2422 Commit => $rawimport_hash,
2423 Info => "Import of source package",
2425 my @output = ($rawimport_mergeinput);
2427 if ($lastpush_mergeinput) {
2428 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2429 my $oversion = getfield $oldclogp, 'Version';
2431 version_compare($oversion, $cversion);
2433 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2434 { Message => <<END, ReverseParents => 1 });
2435 Record $package ($cversion) in archive suite $csuite
2437 } elsif ($vcmp > 0) {
2438 print STDERR <<END or die $!;
2440 Version actually in archive: $cversion (older)
2441 Last version pushed with dgit: $oversion (newer or same)
2444 @output = $lastpush_mergeinput;
2446 # Same version. Use what's in the server git branch,
2447 # discarding our own import. (This could happen if the
2448 # server automatically imports all packages into git.)
2449 @output = $lastpush_mergeinput;
2452 changedir '../../../..';
2457 sub complete_file_from_dsc ($$) {
2458 our ($dstdir, $fi) = @_;
2459 # Ensures that we have, in $dir, the file $fi, with the correct
2460 # contents. (Downloading it from alongside $dscurl if necessary.)
2462 my $f = $fi->{Filename};
2463 my $tf = "$dstdir/$f";
2466 if (stat_exists $tf) {
2467 progress "using existing $f";
2469 printdebug "$tf does not exist, need to fetch\n";
2471 $furl =~ s{/[^/]+$}{};
2473 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2474 die "$f ?" if $f =~ m#/#;
2475 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2476 return 0 if !act_local();
2480 open F, "<", "$tf" or die "$tf: $!";
2481 $fi->{Digester}->reset();
2482 $fi->{Digester}->addfile(*F);
2483 F->error and die $!;
2484 my $got = $fi->{Digester}->hexdigest();
2485 $got eq $fi->{Hash} or
2486 fail "file $f has hash $got but .dsc".
2487 " demands hash $fi->{Hash} ".
2488 ($downloaded ? "(got wrong file from archive!)"
2489 : "(perhaps you should delete this file?)");
2494 sub ensure_we_have_orig () {
2495 my @dfi = dsc_files_info();
2496 foreach my $fi (@dfi) {
2497 my $f = $fi->{Filename};
2498 next unless is_orig_file_in_dsc($f, \@dfi);
2499 complete_file_from_dsc('..', $fi)
2504 #---------- git fetch ----------
2506 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2507 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2509 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2510 # locally fetched refs because they have unhelpful names and clutter
2511 # up gitk etc. So we track whether we have "used up" head ref (ie,
2512 # whether we have made another local ref which refers to this object).
2514 # (If we deleted them unconditionally, then we might end up
2515 # re-fetching the same git objects each time dgit fetch was run.)
2517 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
2518 # in git_fetch_us to fetch the refs in question, and possibly a call
2519 # to lrfetchref_used.
2521 our (%lrfetchrefs_f, %lrfetchrefs_d);
2522 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2524 sub lrfetchref_used ($) {
2525 my ($fullrefname) = @_;
2526 my $objid = $lrfetchrefs_f{$fullrefname};
2527 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2530 sub git_lrfetch_sane {
2531 my ($supplementary, @specs) = @_;
2532 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2533 # at least as regards @specs. Also leave the results in
2534 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2535 # able to clean these up.
2537 # With $supplementary==1, @specs must not contain wildcards
2538 # and we add to our previous fetches (non-atomically).
2540 # This is rather miserable:
2541 # When git fetch --prune is passed a fetchspec ending with a *,
2542 # it does a plausible thing. If there is no * then:
2543 # - it matches subpaths too, even if the supplied refspec
2544 # starts refs, and behaves completely madly if the source
2545 # has refs/refs/something. (See, for example, Debian #NNNN.)
2546 # - if there is no matching remote ref, it bombs out the whole
2548 # We want to fetch a fixed ref, and we don't know in advance
2549 # if it exists, so this is not suitable.
2551 # Our workaround is to use git ls-remote. git ls-remote has its
2552 # own qairks. Notably, it has the absurd multi-tail-matching
2553 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2554 # refs/refs/foo etc.
2556 # Also, we want an idempotent snapshot, but we have to make two
2557 # calls to the remote: one to git ls-remote and to git fetch. The
2558 # solution is use git ls-remote to obtain a target state, and
2559 # git fetch to try to generate it. If we don't manage to generate
2560 # the target state, we try again.
2562 my $url = access_giturl();
2564 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2566 my $specre = join '|', map {
2569 my $wildcard = $x =~ s/\\\*$/.*/;
2570 die if $wildcard && $supplementary;
2573 printdebug "git_lrfetch_sane specre=$specre\n";
2574 my $wanted_rref = sub {
2576 return m/^(?:$specre)$/;
2579 my $fetch_iteration = 0;
2582 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2583 if (++$fetch_iteration > 10) {
2584 fail "too many iterations trying to get sane fetch!";
2587 my @look = map { "refs/$_" } @specs;
2588 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2592 open GITLS, "-|", @lcmd or die $!;
2594 printdebug "=> ", $_;
2595 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2596 my ($objid,$rrefname) = ($1,$2);
2597 if (!$wanted_rref->($rrefname)) {
2599 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2603 $wantr{$rrefname} = $objid;
2606 close GITLS or failedcmd @lcmd;
2608 # OK, now %want is exactly what we want for refs in @specs
2610 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2611 "+refs/$_:".lrfetchrefs."/$_";
2614 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2616 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2617 runcmd_ordryrun_local @fcmd if @fspecs;
2619 if (!$supplementary) {
2620 %lrfetchrefs_f = ();
2624 git_for_each_ref(lrfetchrefs, sub {
2625 my ($objid,$objtype,$lrefname,$reftail) = @_;
2626 $lrfetchrefs_f{$lrefname} = $objid;
2627 $objgot{$objid} = 1;
2630 if ($supplementary) {
2634 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2635 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2636 if (!exists $wantr{$rrefname}) {
2637 if ($wanted_rref->($rrefname)) {
2639 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2643 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2646 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2647 delete $lrfetchrefs_f{$lrefname};
2651 foreach my $rrefname (sort keys %wantr) {
2652 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2653 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2654 my $want = $wantr{$rrefname};
2655 next if $got eq $want;
2656 if (!defined $objgot{$want}) {
2658 warning: git ls-remote suggests we want $lrefname
2659 warning: and it should refer to $want
2660 warning: but git fetch didn't fetch that object to any relevant ref.
2661 warning: This may be due to a race with someone updating the server.
2662 warning: Will try again...
2664 next FETCH_ITERATION;
2667 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2669 runcmd_ordryrun_local @git, qw(update-ref -m),
2670 "dgit fetch git fetch fixup", $lrefname, $want;
2671 $lrfetchrefs_f{$lrefname} = $want;
2675 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2676 Dumper(\%lrfetchrefs_f);
2679 sub git_fetch_us () {
2680 # Want to fetch only what we are going to use, unless
2681 # deliberately-not-ff, in which case we must fetch everything.
2683 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2685 (quiltmode_splitbrain
2686 ? (map { $_->('*',access_nomdistro) }
2687 \&debiantag_new, \&debiantag_maintview)
2688 : debiantags('*',access_nomdistro));
2689 push @specs, server_branch($csuite);
2690 push @specs, $rewritemap;
2691 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2693 git_lrfetch_sane 0, @specs;
2696 my @tagpats = debiantags('*',access_nomdistro);
2698 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2699 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2700 printdebug "currently $fullrefname=$objid\n";
2701 $here{$fullrefname} = $objid;
2703 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2704 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2705 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2706 printdebug "offered $lref=$objid\n";
2707 if (!defined $here{$lref}) {
2708 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2709 runcmd_ordryrun_local @upd;
2710 lrfetchref_used $fullrefname;
2711 } elsif ($here{$lref} eq $objid) {
2712 lrfetchref_used $fullrefname;
2715 "Not updateting $lref from $here{$lref} to $objid.\n";
2720 #---------- dsc and archive handling ----------
2722 sub mergeinfo_getclogp ($) {
2723 # Ensures thit $mi->{Clogp} exists and returns it
2725 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2728 sub mergeinfo_version ($) {
2729 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2732 sub fetch_from_archive_record_1 ($) {
2734 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2735 'DGIT_ARCHIVE', $hash;
2736 cmdoutput @git, qw(log -n2), $hash;
2737 # ... gives git a chance to complain if our commit is malformed
2740 sub fetch_from_archive_record_2 ($) {
2742 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2746 dryrun_report @upd_cmd;
2750 sub parse_dsc_field ($$) {
2751 my ($dsc, $what) = @_;
2753 foreach my $field (@ourdscfield) {
2754 $f = $dsc->{$field};
2758 progress "$what: NO git hash";
2759 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2760 = $f =~ m/^(\w+) ($distro_re) ($versiontag_re) (\S+)(?:\s|$)/) {
2761 progress "$what: specified git info ($dsc_distro)";
2762 $dsc_hint_tag = [ $dsc_hint_tag ];
2763 } elsif ($f =~ m/^\w+\s*$/) {
2765 $dsc_distro //= 'debian';
2766 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2768 progress "$what: specified git hash";
2770 fail "$what: invalid Dgit info";
2774 sub resolve_dsc_field_commit ($$) {
2775 my ($already_distro, $already_mapref) = @_;
2777 return unless defined $dsc_hash;
2780 defined $already_mapref &&
2781 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2782 ? $already_mapref : undef;
2786 my ($what, @fetch) = @_;
2788 local $idistro = $dsc_distro;
2789 my $lrf = lrfetchrefs;
2791 if (!$chase_dsc_distro) {
2793 "not chasing .dsc distro $dsc_distro: not fetching $what";
2798 ".dsc names distro $dsc_distro: fetching $what";
2800 my $url = access_giturl();
2801 if (!defined $url) {
2802 defined $dsc_hint_url or fail <<END;
2803 .dsc Dgit metadata is in context of distro $dsc_distro
2804 for which we have no configured url and .dsc provides no hint
2807 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2808 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2809 parse_cfg_bool "dsc-url-proto-ok", 'false',
2810 cfg("dgit.dsc-url-proto-ok.$proto",
2811 "dgit.default.dsc-url-proto-ok")
2813 .dsc Dgit metadata is in context of distro $dsc_distro
2814 for which we have no configured url;
2815 .dsc provices hinted url with protocol $proto which is unsafe.
2816 (can be overridden by config - consult documentation)
2818 $url = $dsc_hint_url;
2821 git_lrfetch_sane 1, @fetch;
2826 my $rewrite_enable = do {
2827 local $idistro = $dsc_distro;
2828 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2831 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2832 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2833 $mapref = $lrf.'/'.$rewritemap;
2834 my $rewritemapdata = git_cat_file $mapref.':map';
2835 if (defined $rewritemapdata
2836 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2838 "server's git history rewrite map contains a relevant entry!";
2841 if (defined $dsc_hash) {
2842 progress "using rewritten git hash in place of .dsc value";
2844 progress "server data says .dsc hash is to be disregarded";
2849 if (!defined git_cat_file $dsc_hash) {
2850 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2851 my $lrf = $do_fetch->("additional commits", @tags) &&
2852 defined git_cat_file $dsc_hash
2854 .dsc Dgit metadata requires commit $dsc_hash
2855 but we could not obtain that object anywhere.
2857 foreach my $t (@tags) {
2858 my $fullrefname = $lrf.'/'.$t;
2859 print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2860 next unless $lrfetchrefs_f{$fullrefname};
2861 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2862 lrfetchref_used $fullrefname;
2867 sub fetch_from_archive () {
2868 ensure_setup_existing_tree();
2870 # Ensures that lrref() is what is actually in the archive, one way
2871 # or another, according to us - ie this client's
2872 # appropritaely-updated archive view. Also returns the commit id.
2873 # If there is nothing in the archive, leaves lrref alone and
2874 # returns undef. git_fetch_us must have already been called.
2878 parse_dsc_field($dsc, 'last upload to archive');
2879 resolve_dsc_field_commit access_basedistro,
2880 lrfetchrefs."/".$rewritemap
2882 progress "no version available from the archive";
2885 # If the archive's .dsc has a Dgit field, there are three
2886 # relevant git commitids we need to choose between and/or merge
2888 # 1. $dsc_hash: the Dgit field from the archive
2889 # 2. $lastpush_hash: the suite branch on the dgit git server
2890 # 3. $lastfetch_hash: our local tracking brach for the suite
2892 # These may all be distinct and need not be in any fast forward
2895 # If the dsc was pushed to this suite, then the server suite
2896 # branch will have been updated; but it might have been pushed to
2897 # a different suite and copied by the archive. Conversely a more
2898 # recent version may have been pushed with dgit but not appeared
2899 # in the archive (yet).
2901 # $lastfetch_hash may be awkward because archive imports
2902 # (particularly, imports of Dgit-less .dscs) are performed only as
2903 # needed on individual clients, so different clients may perform a
2904 # different subset of them - and these imports are only made
2905 # public during push. So $lastfetch_hash may represent a set of
2906 # imports different to a subsequent upload by a different dgit
2909 # Our approach is as follows:
2911 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2912 # descendant of $dsc_hash, then it was pushed by a dgit user who
2913 # had based their work on $dsc_hash, so we should prefer it.
2914 # Otherwise, $dsc_hash was installed into this suite in the
2915 # archive other than by a dgit push, and (necessarily) after the
2916 # last dgit push into that suite (since a dgit push would have
2917 # been descended from the dgit server git branch); thus, in that
2918 # case, we prefer the archive's version (and produce a
2919 # pseudo-merge to overwrite the dgit server git branch).
2921 # (If there is no Dgit field in the archive's .dsc then
2922 # generate_commit_from_dsc uses the version numbers to decide
2923 # whether the suite branch or the archive is newer. If the suite
2924 # branch is newer it ignores the archive's .dsc; otherwise it
2925 # generates an import of the .dsc, and produces a pseudo-merge to
2926 # overwrite the suite branch with the archive contents.)
2928 # The outcome of that part of the algorithm is the `public view',
2929 # and is same for all dgit clients: it does not depend on any
2930 # unpublished history in the local tracking branch.
2932 # As between the public view and the local tracking branch: The
2933 # local tracking branch is only updated by dgit fetch, and
2934 # whenever dgit fetch runs it includes the public view in the
2935 # local tracking branch. Therefore if the public view is not
2936 # descended from the local tracking branch, the local tracking
2937 # branch must contain history which was imported from the archive
2938 # but never pushed; and, its tip is now out of date. So, we make
2939 # a pseudo-merge to overwrite the old imports and stitch the old
2942 # Finally: we do not necessarily reify the public view (as
2943 # described above). This is so that we do not end up stacking two
2944 # pseudo-merges. So what we actually do is figure out the inputs
2945 # to any public view pseudo-merge and put them in @mergeinputs.
2948 # $mergeinputs[]{Commit}
2949 # $mergeinputs[]{Info}
2950 # $mergeinputs[0] is the one whose tree we use
2951 # @mergeinputs is in the order we use in the actual commit)
2954 # $mergeinputs[]{Message} is a commit message to use
2955 # $mergeinputs[]{ReverseParents} if def specifies that parent
2956 # list should be in opposite order
2957 # Such an entry has no Commit or Info. It applies only when found
2958 # in the last entry. (This ugliness is to support making
2959 # identical imports to previous dgit versions.)
2961 my $lastpush_hash = git_get_ref(lrfetchref());
2962 printdebug "previous reference hash=$lastpush_hash\n";
2963 $lastpush_mergeinput = $lastpush_hash && {
2964 Commit => $lastpush_hash,
2965 Info => "dgit suite branch on dgit git server",
2968 my $lastfetch_hash = git_get_ref(lrref());
2969 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2970 my $lastfetch_mergeinput = $lastfetch_hash && {
2971 Commit => $lastfetch_hash,
2972 Info => "dgit client's archive history view",
2975 my $dsc_mergeinput = $dsc_hash && {
2976 Commit => $dsc_hash,
2977 Info => "Dgit field in .dsc from archive",
2981 my $del_lrfetchrefs = sub {
2984 printdebug "del_lrfetchrefs...\n";
2985 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2986 my $objid = $lrfetchrefs_d{$fullrefname};
2987 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2989 $gur ||= new IO::Handle;
2990 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2992 printf $gur "delete %s %s\n", $fullrefname, $objid;
2995 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2999 if (defined $dsc_hash) {
3000 ensure_we_have_orig();
3001 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3002 @mergeinputs = $dsc_mergeinput
3003 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3004 print STDERR <<END or die $!;
3006 Git commit in archive is behind the last version allegedly pushed/uploaded.
3007 Commit referred to by archive: $dsc_hash
3008 Last version pushed with dgit: $lastpush_hash
3011 @mergeinputs = ($lastpush_mergeinput);
3013 # Archive has .dsc which is not a descendant of the last dgit
3014 # push. This can happen if the archive moves .dscs about.
3015 # Just follow its lead.
3016 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3017 progress "archive .dsc names newer git commit";
3018 @mergeinputs = ($dsc_mergeinput);
3020 progress "archive .dsc names other git commit, fixing up";
3021 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3025 @mergeinputs = generate_commits_from_dsc();
3026 # We have just done an import. Now, our import algorithm might
3027 # have been improved. But even so we do not want to generate
3028 # a new different import of the same package. So if the
3029 # version numbers are the same, just use our existing version.
3030 # If the version numbers are different, the archive has changed
3031 # (perhaps, rewound).
3032 if ($lastfetch_mergeinput &&
3033 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3034 (mergeinfo_version $mergeinputs[0]) )) {
3035 @mergeinputs = ($lastfetch_mergeinput);
3037 } elsif ($lastpush_hash) {
3038 # only in git, not in the archive yet
3039 @mergeinputs = ($lastpush_mergeinput);
3040 print STDERR <<END or die $!;
3042 Package not found in the archive, but has allegedly been pushed using dgit.
3046 printdebug "nothing found!\n";
3047 if (defined $skew_warning_vsn) {
3048 print STDERR <<END or die $!;
3050 Warning: relevant archive skew detected.
3051 Archive allegedly contains $skew_warning_vsn
3052 But we were not able to obtain any version from the archive or git.
3056 unshift @end, $del_lrfetchrefs;
3060 if ($lastfetch_hash &&
3062 my $h = $_->{Commit};
3063 $h and is_fast_fwd($lastfetch_hash, $h);
3064 # If true, one of the existing parents of this commit
3065 # is a descendant of the $lastfetch_hash, so we'll
3066 # be ff from that automatically.
3070 push @mergeinputs, $lastfetch_mergeinput;
3073 printdebug "fetch mergeinfos:\n";
3074 foreach my $mi (@mergeinputs) {
3076 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3078 printdebug sprintf " ReverseParents=%d Message=%s",
3079 $mi->{ReverseParents}, $mi->{Message};
3083 my $compat_info= pop @mergeinputs
3084 if $mergeinputs[$#mergeinputs]{Message};
3086 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3089 if (@mergeinputs > 1) {
3091 my $tree_commit = $mergeinputs[0]{Commit};
3093 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3094 $tree =~ m/\n\n/; $tree = $`;
3095 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3098 # We use the changelog author of the package in question the
3099 # author of this pseudo-merge. This is (roughly) correct if
3100 # this commit is simply representing aa non-dgit upload.
3101 # (Roughly because it does not record sponsorship - but we
3102 # don't have sponsorship info because that's in the .changes,
3103 # which isn't in the archivw.)
3105 # But, it might be that we are representing archive history
3106 # updates (including in-archive copies). These are not really
3107 # the responsibility of the person who created the .dsc, but
3108 # there is no-one whose name we should better use. (The
3109 # author of the .dsc-named commit is clearly worse.)
3111 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3112 my $author = clogp_authline $useclogp;
3113 my $cversion = getfield $useclogp, 'Version';
3115 my $mcf = ".git/dgit/mergecommit";
3116 open MC, ">", $mcf or die "$mcf $!";
3117 print MC <<END or die $!;
3121 my @parents = grep { $_->{Commit} } @mergeinputs;
3122 @parents = reverse @parents if $compat_info->{ReverseParents};
3123 print MC <<END or die $! foreach @parents;
3127 print MC <<END or die $!;
3133 if (defined $compat_info->{Message}) {
3134 print MC $compat_info->{Message} or die $!;
3136 print MC <<END or die $!;
3137 Record $package ($cversion) in archive suite $csuite
3141 my $message_add_info = sub {
3143 my $mversion = mergeinfo_version $mi;
3144 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3148 $message_add_info->($mergeinputs[0]);
3149 print MC <<END or die $!;
3150 should be treated as descended from
3152 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3156 $hash = make_commit $mcf;
3158 $hash = $mergeinputs[0]{Commit};
3160 printdebug "fetch hash=$hash\n";
3163 my ($lasth, $what) = @_;
3164 return unless $lasth;
3165 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3168 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3170 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3172 fetch_from_archive_record_1($hash);
3174 if (defined $skew_warning_vsn) {
3176 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3177 my $gotclogp = commit_getclogp($hash);
3178 my $got_vsn = getfield $gotclogp, 'Version';
3179 printdebug "SKEW CHECK GOT $got_vsn\n";
3180 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3181 print STDERR <<END or die $!;
3183 Warning: archive skew detected. Using the available version:
3184 Archive allegedly contains $skew_warning_vsn
3185 We were able to obtain only $got_vsn
3191 if ($lastfetch_hash ne $hash) {
3192 fetch_from_archive_record_2($hash);
3195 lrfetchref_used lrfetchref();
3197 unshift @end, $del_lrfetchrefs;
3201 sub set_local_git_config ($$) {
3203 runcmd @git, qw(config), $k, $v;
3206 sub setup_mergechangelogs (;$) {
3208 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3210 my $driver = 'dpkg-mergechangelogs';
3211 my $cb = "merge.$driver";
3212 my $attrs = '.git/info/attributes';
3213 ensuredir '.git/info';
3215 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3216 if (!open ATTRS, "<", $attrs) {
3217 $!==ENOENT or die "$attrs: $!";
3221 next if m{^debian/changelog\s};
3222 print NATTRS $_, "\n" or die $!;
3224 ATTRS->error and die $!;
3227 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3230 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3231 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3233 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3236 sub setup_useremail (;$) {
3238 return unless $always || access_cfg_bool(1, 'setup-useremail');
3241 my ($k, $envvar) = @_;
3242 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3243 return unless defined $v;
3244 set_local_git_config "user.$k", $v;
3247 $setup->('email', 'DEBEMAIL');
3248 $setup->('name', 'DEBFULLNAME');
3251 sub ensure_setup_existing_tree () {
3252 my $k = "remote.$remotename.skipdefaultupdate";
3253 my $c = git_get_config $k;
3254 return if defined $c;
3255 set_local_git_config $k, 'true';
3258 sub setup_new_tree () {
3259 setup_mergechangelogs();
3263 sub multisuite_suite_child ($$$) {
3264 my ($tsuite, $merginputs, $fn) = @_;
3265 # in child, sets things up, calls $fn->(), and returns undef
3266 # in parent, returns canonical suite name for $tsuite
3267 my $canonsuitefh = IO::File::new_tmpfile;
3268 my $pid = fork // die $!;
3271 $us .= " [$isuite]";
3272 $debugprefix .= " ";
3273 progress "fetching $tsuite...";
3274 canonicalise_suite();
3275 print $canonsuitefh $csuite, "\n" or die $!;
3276 close $canonsuitefh or die $!;
3280 waitpid $pid,0 == $pid or die $!;
3281 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3282 seek $canonsuitefh,0,0 or die $!;
3283 local $csuite = <$canonsuitefh>;
3284 die $! unless defined $csuite && chomp $csuite;
3286 printdebug "multisuite $tsuite missing\n";
3289 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3290 push @$merginputs, {
3297 sub fork_for_multisuite ($) {
3298 my ($before_fetch_merge) = @_;
3299 # if nothing unusual, just returns ''
3302 # returns 0 to caller in child, to do first of the specified suites
3303 # in child, $csuite is not yet set
3305 # returns 1 to caller in parent, to finish up anything needed after
3306 # in parent, $csuite is set to canonicalised portmanteau
3308 my $org_isuite = $isuite;
3309 my @suites = split /\,/, $isuite;
3310 return '' unless @suites > 1;
3311 printdebug "fork_for_multisuite: @suites\n";
3315 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3317 return 0 unless defined $cbasesuite;
3319 fail "package $package missing in (base suite) $cbasesuite"
3320 unless @mergeinputs;
3322 my @csuites = ($cbasesuite);
3324 $before_fetch_merge->();
3326 foreach my $tsuite (@suites[1..$#suites]) {
3327 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3333 # xxx collecte the ref here
3335 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3336 push @csuites, $csubsuite;
3339 foreach my $mi (@mergeinputs) {
3340 my $ref = git_get_ref $mi->{Ref};
3341 die "$mi->{Ref} ?" unless length $ref;
3342 $mi->{Commit} = $ref;
3345 $csuite = join ",", @csuites;
3347 my $previous = git_get_ref lrref;
3349 unshift @mergeinputs, {
3350 Commit => $previous,
3351 Info => "local combined tracking branch",
3353 "archive seems to have rewound: local tracking branch is ahead!",
3357 foreach my $ix (0..$#mergeinputs) {
3358 $mergeinputs[$ix]{Index} = $ix;
3361 @mergeinputs = sort {
3362 -version_compare(mergeinfo_version $a,
3363 mergeinfo_version $b) # highest version first
3365 $a->{Index} <=> $b->{Index}; # earliest in spec first
3371 foreach my $mi (@mergeinputs) {
3372 printdebug "multisuite merge check $mi->{Info}\n";
3373 foreach my $previous (@needed) {
3374 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3375 printdebug "multisuite merge un-needed $previous->{Info}\n";
3379 printdebug "multisuite merge this-needed\n";
3380 $mi->{Character} = '+';
3383 $needed[0]{Character} = '*';
3385 my $output = $needed[0]{Commit};
3388 printdebug "multisuite merge nontrivial\n";
3389 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3391 my $commit = "tree $tree\n";
3392 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3393 "Input branches:\n";
3395 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3396 printdebug "multisuite merge include $mi->{Info}\n";
3397 $mi->{Character} //= ' ';
3398 $commit .= "parent $mi->{Commit}\n";
3399 $msg .= sprintf " %s %-25s %s\n",
3401 (mergeinfo_version $mi),
3404 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3406 " * marks the highest version branch, which choose to use\n".
3407 " + marks each branch which was not already an ancestor\n\n".
3408 "[dgit multi-suite $csuite]\n";
3410 "author $authline\n".
3411 "committer $authline\n\n";
3412 $output = make_commit_text $commit.$msg;
3413 printdebug "multisuite merge generated $output\n";
3416 fetch_from_archive_record_1($output);
3417 fetch_from_archive_record_2($output);
3419 progress "calculated combined tracking suite $csuite";
3424 sub clone_set_head () {
3425 open H, "> .git/HEAD" or die $!;
3426 print H "ref: ".lref()."\n" or die $!;
3429 sub clone_finish ($) {
3431 runcmd @git, qw(reset --hard), lrref();
3432 runcmd qw(bash -ec), <<'END';
3434 git ls-tree -r --name-only -z HEAD | \
3435 xargs -0r touch -h -r . --
3437 printdone "ready for work in $dstdir";
3442 badusage "dry run makes no sense with clone" unless act_local();
3444 my $multi_fetched = fork_for_multisuite(sub {
3445 printdebug "multi clone before fetch merge\n";
3448 if ($multi_fetched) {
3449 printdebug "multi clone after fetch merge\n";
3451 clone_finish($dstdir);
3454 printdebug "clone main body\n";
3456 canonicalise_suite();
3457 my $hasgit = check_for_git();
3458 mkdir $dstdir or fail "create \`$dstdir': $!";
3460 runcmd @git, qw(init -q);
3462 my $giturl = access_giturl(1);
3463 if (defined $giturl) {
3464 runcmd @git, qw(remote add), 'origin', $giturl;
3467 progress "fetching existing git history";
3469 runcmd_ordryrun_local @git, qw(fetch origin);
3471 progress "starting new git history";
3473 fetch_from_archive() or no_such_package;
3474 my $vcsgiturl = $dsc->{'Vcs-Git'};
3475 if (length $vcsgiturl) {
3476 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3477 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3480 clone_finish($dstdir);
3484 canonicalise_suite();
3485 if (check_for_git()) {
3488 fetch_from_archive() or no_such_package();
3489 printdone "fetched into ".lrref();
3493 my $multi_fetched = fork_for_multisuite(sub { });
3494 fetch() unless $multi_fetched; # parent
3495 return if $multi_fetched eq '0'; # child
3496 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3498 printdone "fetched to ".lrref()." and merged into HEAD";
3501 sub check_not_dirty () {
3502 foreach my $f (qw(local-options local-patch-header)) {
3503 if (stat_exists "debian/source/$f") {
3504 fail "git tree contains debian/source/$f";
3508 return if $ignoredirty;
3510 my @cmd = (@git, qw(diff --quiet HEAD));
3512 $!=0; $?=-1; system @cmd;
3515 fail "working tree is dirty (does not match HEAD)";
3521 sub commit_admin ($) {
3524 runcmd_ordryrun_local @git, qw(commit -m), $m;
3527 sub commit_quilty_patch () {
3528 my $output = cmdoutput @git, qw(status --porcelain);
3530 foreach my $l (split /\n/, $output) {
3531 next unless $l =~ m/\S/;
3532 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3536 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3538 progress "nothing quilty to commit, ok.";
3541 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3542 runcmd_ordryrun_local @git, qw(add -f), @adds;
3544 Commit Debian 3.0 (quilt) metadata
3546 [dgit ($our_version) quilt-fixup]
3550 sub get_source_format () {
3552 if (open F, "debian/source/options") {
3556 s/\s+$//; # ignore missing final newline
3558 my ($k, $v) = ($`, $'); #');
3559 $v =~ s/^"(.*)"$/$1/;
3565 F->error and die $!;
3568 die $! unless $!==&ENOENT;
3571 if (!open F, "debian/source/format") {
3572 die $! unless $!==&ENOENT;
3576 F->error and die $!;
3578 return ($_, \%options);
3581 sub madformat_wantfixup ($) {
3583 return 0 unless $format eq '3.0 (quilt)';
3584 our $quilt_mode_warned;
3585 if ($quilt_mode eq 'nocheck') {
3586 progress "Not doing any fixup of \`$format' due to".
3587 " ----no-quilt-fixup or --quilt=nocheck"
3588 unless $quilt_mode_warned++;
3591 progress "Format \`$format', need to check/update patch stack"
3592 unless $quilt_mode_warned++;
3596 sub maybe_split_brain_save ($$$) {
3597 my ($headref, $dgitview, $msg) = @_;
3598 # => message fragment "$saved" describing disposition of $dgitview
3599 return "commit id $dgitview" unless defined $split_brain_save;
3600 my @cmd = (shell_cmd "cd ../../../..",
3601 @git, qw(update-ref -m),
3602 "dgit --dgit-view-save $msg HEAD=$headref",
3603 $split_brain_save, $dgitview);
3605 return "and left in $split_brain_save";
3608 # An "infopair" is a tuple [ $thing, $what ]
3609 # (often $thing is a commit hash; $what is a description)
3611 sub infopair_cond_equal ($$) {
3613 $x->[0] eq $y->[0] or fail <<END;
3614 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3618 sub infopair_lrf_tag_lookup ($$) {
3619 my ($tagnames, $what) = @_;
3620 # $tagname may be an array ref
3621 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3622 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3623 foreach my $tagname (@tagnames) {
3624 my $lrefname = lrfetchrefs."/tags/$tagname";
3625 my $tagobj = $lrfetchrefs_f{$lrefname};
3626 next unless defined $tagobj;
3627 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3628 return [ git_rev_parse($tagobj), $what ];
3630 fail @tagnames==1 ? <<END : <<END;
3631 Wanted tag $what (@tagnames) on dgit server, but not found
3633 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3637 sub infopair_cond_ff ($$) {
3638 my ($anc,$desc) = @_;
3639 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3640 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3644 sub pseudomerge_version_check ($$) {
3645 my ($clogp, $archive_hash) = @_;
3647 my $arch_clogp = commit_getclogp $archive_hash;
3648 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3649 'version currently in archive' ];
3650 if (defined $overwrite_version) {
3651 if (length $overwrite_version) {
3652 infopair_cond_equal([ $overwrite_version,
3653 '--overwrite= version' ],
3656 my $v = $i_arch_v->[0];
3657 progress "Checking package changelog for archive version $v ...";
3659 my @xa = ("-f$v", "-t$v");
3660 my $vclogp = parsechangelog @xa;
3661 my $cv = [ (getfield $vclogp, 'Version'),
3662 "Version field from dpkg-parsechangelog @xa" ];
3663 infopair_cond_equal($i_arch_v, $cv);
3666 $@ =~ s/^dgit: //gm;
3668 "Perhaps debian/changelog does not mention $v ?";
3673 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3677 sub pseudomerge_make_commit ($$$$ $$) {
3678 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3679 $msg_cmd, $msg_msg) = @_;
3680 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3682 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3683 my $authline = clogp_authline $clogp;
3687 !defined $overwrite_version ? ""
3688 : !length $overwrite_version ? " --overwrite"
3689 : " --overwrite=".$overwrite_version;
3692 my $pmf = ".git/dgit/pseudomerge";
3693 open MC, ">", $pmf or die "$pmf $!";
3694 print MC <<END or die $!;
3697 parent $archive_hash
3707 return make_commit($pmf);
3710 sub splitbrain_pseudomerge ($$$$) {
3711 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3712 # => $merged_dgitview
3713 printdebug "splitbrain_pseudomerge...\n";
3715 # We: debian/PREVIOUS HEAD($maintview)
3716 # expect: o ----------------- o
3719 # a/d/PREVIOUS $dgitview
3722 # we do: `------------------ o
3726 return $dgitview unless defined $archive_hash;
3728 printdebug "splitbrain_pseudomerge...\n";
3730 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3732 if (!defined $overwrite_version) {
3733 progress "Checking that HEAD inciudes all changes in archive...";
3736 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3738 if (defined $overwrite_version) {
3740 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3741 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3742 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3743 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3744 my $i_archive = [ $archive_hash, "current archive contents" ];
3746 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3748 infopair_cond_equal($i_dgit, $i_archive);
3749 infopair_cond_ff($i_dep14, $i_dgit);
3750 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3754 $us: check failed (maybe --overwrite is needed, consult documentation)
3759 my $r = pseudomerge_make_commit
3760 $clogp, $dgitview, $archive_hash, $i_arch_v,
3761 "dgit --quilt=$quilt_mode",
3762 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3763 Declare fast forward from $i_arch_v->[0]
3765 Make fast forward from $i_arch_v->[0]
3768 maybe_split_brain_save $maintview, $r, "pseudomerge";
3770 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3774 sub plain_overwrite_pseudomerge ($$$) {
3775 my ($clogp, $head, $archive_hash) = @_;
3777 printdebug "plain_overwrite_pseudomerge...";
3779 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3781 return $head if is_fast_fwd $archive_hash, $head;
3783 my $m = "Declare fast forward from $i_arch_v->[0]";
3785 my $r = pseudomerge_make_commit
3786 $clogp, $head, $archive_hash, $i_arch_v,
3789 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3791 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3795 sub push_parse_changelog ($) {
3798 my $clogp = Dpkg::Control::Hash->new();
3799 $clogp->load($clogpfn) or die;
3801 my $clogpackage = getfield $clogp, 'Source';
3802 $package //= $clogpackage;
3803 fail "-p specified $package but changelog specified $clogpackage"
3804 unless $package eq $clogpackage;
3805 my $cversion = getfield $clogp, 'Version';
3806 my $tag = debiantag($cversion, access_nomdistro);
3807 runcmd @git, qw(check-ref-format), $tag;
3809 my $dscfn = dscfn($cversion);
3811 return ($clogp, $cversion, $dscfn);
3814 sub push_parse_dsc ($$$) {
3815 my ($dscfn,$dscfnwhat, $cversion) = @_;
3816 $dsc = parsecontrol($dscfn,$dscfnwhat);
3817 my $dversion = getfield $dsc, 'Version';
3818 my $dscpackage = getfield $dsc, 'Source';
3819 ($dscpackage eq $package && $dversion eq $cversion) or
3820 fail "$dscfn is for $dscpackage $dversion".
3821 " but debian/changelog is for $package $cversion";
3824 sub push_tagwants ($$$$) {
3825 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3828 TagFn => \&debiantag,
3833 if (defined $maintviewhead) {
3835 TagFn => \&debiantag_maintview,
3836 Objid => $maintviewhead,
3837 TfSuffix => '-maintview',
3840 } elsif ($dodep14tag eq 'no' ? 0
3841 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3842 : $dodep14tag eq 'always'
3843 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3844 --dep14tag-always (or equivalent in config) means server must support
3845 both "new" and "maint" tag formats, but config says it doesn't.
3847 : die "$dodep14tag ?") {
3849 TagFn => \&debiantag_maintview,
3851 TfSuffix => '-dgit',
3855 foreach my $tw (@tagwants) {
3856 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3857 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3859 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3863 sub push_mktags ($$ $$ $) {
3865 $changesfile,$changesfilewhat,
3868 die unless $tagwants->[0]{View} eq 'dgit';
3870 my $declaredistro = access_nomdistro();
3871 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
3872 $dsc->{$ourdscfield[0]} = join " ",
3873 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
3875 $dsc->save("$dscfn.tmp") or die $!;
3877 my $changes = parsecontrol($changesfile,$changesfilewhat);
3878 foreach my $field (qw(Source Distribution Version)) {
3879 $changes->{$field} eq $clogp->{$field} or
3880 fail "changes field $field \`$changes->{$field}'".
3881 " does not match changelog \`$clogp->{$field}'";
3884 my $cversion = getfield $clogp, 'Version';
3885 my $clogsuite = getfield $clogp, 'Distribution';
3887 # We make the git tag by hand because (a) that makes it easier
3888 # to control the "tagger" (b) we can do remote signing
3889 my $authline = clogp_authline $clogp;
3890 my $delibs = join(" ", "",@deliberatelies);
3894 my $tfn = $tw->{Tfn};
3895 my $head = $tw->{Objid};
3896 my $tag = $tw->{Tag};
3898 open TO, '>', $tfn->('.tmp') or die $!;
3899 print TO <<END or die $!;
3906 if ($tw->{View} eq 'dgit') {
3907 print TO <<END or die $!;
3908 $package release $cversion for $clogsuite ($csuite) [dgit]
3909 [dgit distro=$declaredistro$delibs]
3911 foreach my $ref (sort keys %previously) {
3912 print TO <<END or die $!;
3913 [dgit previously:$ref=$previously{$ref}]
3916 } elsif ($tw->{View} eq 'maint') {
3917 print TO <<END or die $!;
3918 $package release $cversion for $clogsuite ($csuite)
3919 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3922 die Dumper($tw)."?";
3927 my $tagobjfn = $tfn->('.tmp');
3929 if (!defined $keyid) {
3930 $keyid = access_cfg('keyid','RETURN-UNDEF');
3932 if (!defined $keyid) {
3933 $keyid = getfield $clogp, 'Maintainer';
3935 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3936 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3937 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3938 push @sign_cmd, $tfn->('.tmp');
3939 runcmd_ordryrun @sign_cmd;
3941 $tagobjfn = $tfn->('.signed.tmp');
3942 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3943 $tfn->('.tmp'), $tfn->('.tmp.asc');
3949 my @r = map { $mktag->($_); } @$tagwants;
3953 sub sign_changes ($) {
3954 my ($changesfile) = @_;
3956 my @debsign_cmd = @debsign;
3957 push @debsign_cmd, "-k$keyid" if defined $keyid;
3958 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3959 push @debsign_cmd, $changesfile;
3960 runcmd_ordryrun @debsign_cmd;
3965 printdebug "actually entering push\n";
3967 supplementary_message(<<'END');
3968 Push failed, while checking state of the archive.
3969 You can retry the push, after fixing the problem, if you like.
3971 if (check_for_git()) {
3974 my $archive_hash = fetch_from_archive();
3975 if (!$archive_hash) {
3977 fail "package appears to be new in this suite;".
3978 " if this is intentional, use --new";
3981 supplementary_message(<<'END');
3982 Push failed, while preparing your push.
3983 You can retry the push, after fixing the problem, if you like.
3986 need_tagformat 'new', "quilt mode $quilt_mode"
3987 if quiltmode_splitbrain;
3991 access_giturl(); # check that success is vaguely likely
3994 my $clogpfn = ".git/dgit/changelog.822.tmp";
3995 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3997 responder_send_file('parsed-changelog', $clogpfn);
3999 my ($clogp, $cversion, $dscfn) =
4000 push_parse_changelog("$clogpfn");
4002 my $dscpath = "$buildproductsdir/$dscfn";
4003 stat_exists $dscpath or
4004 fail "looked for .dsc $dscpath, but $!;".
4005 " maybe you forgot to build";
4007 responder_send_file('dsc', $dscpath);
4009 push_parse_dsc($dscpath, $dscfn, $cversion);
4011 my $format = getfield $dsc, 'Format';
4012 printdebug "format $format\n";
4014 my $actualhead = git_rev_parse('HEAD');
4015 my $dgithead = $actualhead;
4016 my $maintviewhead = undef;
4018 my $upstreamversion = upstreamversion $clogp->{Version};
4020 if (madformat_wantfixup($format)) {
4021 # user might have not used dgit build, so maybe do this now:
4022 if (quiltmode_splitbrain()) {
4024 quilt_make_fake_dsc($upstreamversion);
4026 ($dgithead, $cachekey) =
4027 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4029 "--quilt=$quilt_mode but no cached dgit view:
4030 perhaps tree changed since dgit build[-source] ?";
4032 $dgithead = splitbrain_pseudomerge($clogp,
4033 $actualhead, $dgithead,
4035 $maintviewhead = $actualhead;
4036 changedir '../../../..';
4037 prep_ud(); # so _only_subdir() works, below
4039 commit_quilty_patch();
4043 if (defined $overwrite_version && !defined $maintviewhead) {
4044 $dgithead = plain_overwrite_pseudomerge($clogp,
4052 if ($archive_hash) {
4053 if (is_fast_fwd($archive_hash, $dgithead)) {
4055 } elsif (deliberately_not_fast_forward) {
4058 fail "dgit push: HEAD is not a descendant".
4059 " of the archive's version.\n".
4060 "To overwrite the archive's contents,".
4061 " pass --overwrite[=VERSION].\n".
4062 "To rewind history, if permitted by the archive,".
4063 " use --deliberately-not-fast-forward.";
4068 progress "checking that $dscfn corresponds to HEAD";
4069 runcmd qw(dpkg-source -x --),
4070 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
4071 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4072 check_for_vendor_patches() if madformat($dsc->{format});
4073 changedir '../../../..';
4074 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4075 debugcmd "+",@diffcmd;
4077 my $r = system @diffcmd;
4080 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4082 HEAD specifies a different tree to $dscfn:
4084 Perhaps you forgot to build. Or perhaps there is a problem with your
4085 source tree (see dgit(7) for some hints). To see a full diff, run
4092 if (!$changesfile) {
4093 my $pat = changespat $cversion;
4094 my @cs = glob "$buildproductsdir/$pat";
4095 fail "failed to find unique changes file".
4096 " (looked for $pat in $buildproductsdir);".
4097 " perhaps you need to use dgit -C"
4099 ($changesfile) = @cs;
4101 $changesfile = "$buildproductsdir/$changesfile";
4104 # Check that changes and .dsc agree enough
4105 $changesfile =~ m{[^/]*$};
4106 my $changes = parsecontrol($changesfile,$&);
4107 files_compare_inputs($dsc, $changes)
4108 unless forceing [qw(dsc-changes-mismatch)];
4110 # Perhaps adjust .dsc to contain right set of origs
4111 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4113 unless forceing [qw(changes-origs-exactly)];
4115 # Checks complete, we're going to try and go ahead:
4117 responder_send_file('changes',$changesfile);
4118 responder_send_command("param head $dgithead");
4119 responder_send_command("param csuite $csuite");
4120 responder_send_command("param tagformat $tagformat");
4121 if (defined $maintviewhead) {
4122 die unless ($protovsn//4) >= 4;
4123 responder_send_command("param maint-view $maintviewhead");
4126 if (deliberately_not_fast_forward) {
4127 git_for_each_ref(lrfetchrefs, sub {
4128 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4129 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4130 responder_send_command("previously $rrefname=$objid");
4131 $previously{$rrefname} = $objid;
4135 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4139 supplementary_message(<<'END');
4140 Push failed, while signing the tag.
4141 You can retry the push, after fixing the problem, if you like.
4143 # If we manage to sign but fail to record it anywhere, it's fine.
4144 if ($we_are_responder) {
4145 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4146 responder_receive_files('signed-tag', @tagobjfns);
4148 @tagobjfns = push_mktags($clogp,$dscpath,
4149 $changesfile,$changesfile,
4152 supplementary_message(<<'END');
4153 Push failed, *after* signing the tag.
4154 If you want to try again, you should use a new version number.
4157 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4159 foreach my $tw (@tagwants) {
4160 my $tag = $tw->{Tag};
4161 my $tagobjfn = $tw->{TagObjFn};
4163 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4164 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4165 runcmd_ordryrun_local
4166 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4169 supplementary_message(<<'END');
4170 Push failed, while updating the remote git repository - see messages above.
4171 If you want to try again, you should use a new version number.
4173 if (!check_for_git()) {
4174 create_remote_git_repo();
4177 my @pushrefs = $forceflag.$dgithead.":".rrref();
4178 foreach my $tw (@tagwants) {
4179 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4182 runcmd_ordryrun @git,
4183 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4184 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4186 supplementary_message(<<'END');
4187 Push failed, while obtaining signatures on the .changes and .dsc.
4188 If it was just that the signature failed, you may try again by using
4189 debsign by hand to sign the changes
4191 and then dput to complete the upload.
4192 If you need to change the package, you must use a new version number.
4194 if ($we_are_responder) {
4195 my $dryrunsuffix = act_local() ? "" : ".tmp";
4196 responder_receive_files('signed-dsc-changes',
4197 "$dscpath$dryrunsuffix",
4198 "$changesfile$dryrunsuffix");
4201 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4203 progress "[new .dsc left in $dscpath.tmp]";
4205 sign_changes $changesfile;
4208 supplementary_message(<<END);
4209 Push failed, while uploading package(s) to the archive server.
4210 You can retry the upload of exactly these same files with dput of:
4212 If that .changes file is broken, you will need to use a new version
4213 number for your next attempt at the upload.
4215 my $host = access_cfg('upload-host','RETURN-UNDEF');
4216 my @hostarg = defined($host) ? ($host,) : ();
4217 runcmd_ordryrun @dput, @hostarg, $changesfile;
4218 printdone "pushed and uploaded $cversion";
4220 supplementary_message('');
4221 responder_send_command("complete");
4227 badusage "-p is not allowed with clone; specify as argument instead"
4228 if defined $package;
4231 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4232 ($package,$isuite) = @ARGV;
4233 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4234 ($package,$dstdir) = @ARGV;
4235 } elsif (@ARGV==3) {
4236 ($package,$isuite,$dstdir) = @ARGV;
4238 badusage "incorrect arguments to dgit clone";
4242 $dstdir ||= "$package";
4243 if (stat_exists $dstdir) {
4244 fail "$dstdir already exists";
4248 if ($rmonerror && !$dryrun_level) {
4249 $cwd_remove= getcwd();
4251 return unless defined $cwd_remove;
4252 if (!chdir "$cwd_remove") {
4253 return if $!==&ENOENT;
4254 die "chdir $cwd_remove: $!";
4256 printdebug "clone rmonerror removing $dstdir\n";
4258 rmtree($dstdir) or die "remove $dstdir: $!\n";
4259 } elsif (grep { $! == $_ }
4260 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4262 print STDERR "check whether to remove $dstdir: $!\n";
4268 $cwd_remove = undef;
4271 sub branchsuite () {
4272 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4273 if ($branch =~ m#$lbranch_re#o) {
4280 sub fetchpullargs () {
4281 if (!defined $package) {
4282 my $sourcep = parsecontrol('debian/control','debian/control');
4283 $package = getfield $sourcep, 'Source';
4286 $isuite = branchsuite();
4288 my $clogp = parsechangelog();
4289 $isuite = getfield $clogp, 'Distribution';
4291 } elsif (@ARGV==1) {
4294 badusage "incorrect arguments to dgit fetch or dgit pull";
4302 my $multi_fetched = fork_for_multisuite(sub { });
4303 exit 0 if $multi_fetched;
4310 if (quiltmode_splitbrain()) {
4311 my ($format, $fopts) = get_source_format();
4312 madformat($format) and fail <<END
4313 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4322 badusage "-p is not allowed with dgit push" if defined $package;
4324 my $clogp = parsechangelog();
4325 $package = getfield $clogp, 'Source';
4328 } elsif (@ARGV==1) {
4329 ($specsuite) = (@ARGV);
4331 badusage "incorrect arguments to dgit push";
4333 $isuite = getfield $clogp, 'Distribution';
4335 local ($package) = $existing_package; # this is a hack
4336 canonicalise_suite();
4338 canonicalise_suite();
4340 if (defined $specsuite &&
4341 $specsuite ne $isuite &&
4342 $specsuite ne $csuite) {
4343 fail "dgit push: changelog specifies $isuite ($csuite)".
4344 " but command line specifies $specsuite";
4349 #---------- remote commands' implementation ----------
4351 sub cmd_remote_push_build_host {
4352 my ($nrargs) = shift @ARGV;
4353 my (@rargs) = @ARGV[0..$nrargs-1];
4354 @ARGV = @ARGV[$nrargs..$#ARGV];
4356 my ($dir,$vsnwant) = @rargs;
4357 # vsnwant is a comma-separated list; we report which we have
4358 # chosen in our ready response (so other end can tell if they
4361 $we_are_responder = 1;
4362 $us .= " (build host)";
4366 open PI, "<&STDIN" or die $!;
4367 open STDIN, "/dev/null" or die $!;
4368 open PO, ">&STDOUT" or die $!;
4370 open STDOUT, ">&STDERR" or die $!;
4374 ($protovsn) = grep {
4375 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4376 } @rpushprotovsn_support;
4378 fail "build host has dgit rpush protocol versions ".
4379 (join ",", @rpushprotovsn_support).
4380 " but invocation host has $vsnwant"
4381 unless defined $protovsn;
4383 responder_send_command("dgit-remote-push-ready $protovsn");
4384 rpush_handle_protovsn_bothends();
4389 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4390 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4391 # a good error message)
4393 sub rpush_handle_protovsn_bothends () {
4394 if ($protovsn < 4) {
4395 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4404 my $report = i_child_report();
4405 if (defined $report) {
4406 printdebug "($report)\n";
4407 } elsif ($i_child_pid) {
4408 printdebug "(killing build host child $i_child_pid)\n";
4409 kill 15, $i_child_pid;
4411 if (defined $i_tmp && !defined $initiator_tempdir) {
4413 eval { rmtree $i_tmp; };
4417 END { i_cleanup(); }
4420 my ($base,$selector,@args) = @_;
4421 $selector =~ s/\-/_/g;
4422 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4429 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4437 push @rargs, join ",", @rpushprotovsn_support;
4440 push @rdgit, @ropts;
4441 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4443 my @cmd = (@ssh, $host, shellquote @rdgit);
4446 if (defined $initiator_tempdir) {
4447 rmtree $initiator_tempdir;
4448 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4449 $i_tmp = $initiator_tempdir;
4453 $i_child_pid = open2(\*RO, \*RI, @cmd);
4455 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4456 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4457 $supplementary_message = '' unless $protovsn >= 3;
4459 fail "rpush negotiated protocol version $protovsn".
4460 " which does not support quilt mode $quilt_mode"
4461 if quiltmode_splitbrain;
4463 rpush_handle_protovsn_bothends();
4465 my ($icmd,$iargs) = initiator_expect {
4466 m/^(\S+)(?: (.*))?$/;
4469 i_method "i_resp", $icmd, $iargs;
4473 sub i_resp_progress ($) {
4475 my $msg = protocol_read_bytes \*RO, $rhs;
4479 sub i_resp_supplementary_message ($) {
4481 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4484 sub i_resp_complete {
4485 my $pid = $i_child_pid;
4486 $i_child_pid = undef; # prevents killing some other process with same pid
4487 printdebug "waiting for build host child $pid...\n";
4488 my $got = waitpid $pid, 0;
4489 die $! unless $got == $pid;
4490 die "build host child failed $?" if $?;
4493 printdebug "all done\n";
4497 sub i_resp_file ($) {
4499 my $localname = i_method "i_localname", $keyword;
4500 my $localpath = "$i_tmp/$localname";
4501 stat_exists $localpath and
4502 badproto \*RO, "file $keyword ($localpath) twice";
4503 protocol_receive_file \*RO, $localpath;
4504 i_method "i_file", $keyword;
4509 sub i_resp_param ($) {
4510 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4514 sub i_resp_previously ($) {
4515 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4516 or badproto \*RO, "bad previously spec";
4517 my $r = system qw(git check-ref-format), $1;
4518 die "bad previously ref spec ($r)" if $r;
4519 $previously{$1} = $2;
4524 sub i_resp_want ($) {
4526 die "$keyword ?" if $i_wanted{$keyword}++;
4527 my @localpaths = i_method "i_want", $keyword;
4528 printdebug "[[ $keyword @localpaths\n";
4529 foreach my $localpath (@localpaths) {
4530 protocol_send_file \*RI, $localpath;
4532 print RI "files-end\n" or die $!;
4535 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4537 sub i_localname_parsed_changelog {
4538 return "remote-changelog.822";
4540 sub i_file_parsed_changelog {
4541 ($i_clogp, $i_version, $i_dscfn) =
4542 push_parse_changelog "$i_tmp/remote-changelog.822";
4543 die if $i_dscfn =~ m#/|^\W#;
4546 sub i_localname_dsc {
4547 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4552 sub i_localname_changes {
4553 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4554 $i_changesfn = $i_dscfn;
4555 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4556 return $i_changesfn;
4558 sub i_file_changes { }
4560 sub i_want_signed_tag {
4561 printdebug Dumper(\%i_param, $i_dscfn);
4562 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4563 && defined $i_param{'csuite'}
4564 or badproto \*RO, "premature desire for signed-tag";
4565 my $head = $i_param{'head'};
4566 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4568 my $maintview = $i_param{'maint-view'};
4569 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4572 if ($protovsn >= 4) {
4573 my $p = $i_param{'tagformat'} // '<undef>';
4575 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4578 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4580 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4582 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4585 push_mktags $i_clogp, $i_dscfn,
4586 $i_changesfn, 'remote changes',
4590 sub i_want_signed_dsc_changes {
4591 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4592 sign_changes $i_changesfn;
4593 return ($i_dscfn, $i_changesfn);
4596 #---------- building etc. ----------
4602 #----- `3.0 (quilt)' handling -----
4604 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4606 sub quiltify_dpkg_commit ($$$;$) {
4607 my ($patchname,$author,$msg, $xinfo) = @_;
4611 my $descfn = ".git/dgit/quilt-description.tmp";
4612 open O, '>', $descfn or die "$descfn: $!";
4613 $msg =~ s/\n+/\n\n/;
4614 print O <<END or die $!;
4616 ${xinfo}Subject: $msg
4623 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4624 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4625 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4626 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4630 sub quiltify_trees_differ ($$;$$$) {
4631 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4632 # returns true iff the two tree objects differ other than in debian/
4633 # with $finegrained,
4634 # returns bitmask 01 - differ in upstream files except .gitignore
4635 # 02 - differ in .gitignore
4636 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4637 # is set for each modified .gitignore filename $fn
4638 # if $unrepres is defined, array ref to which is appeneded
4639 # a list of unrepresentable changes (removals of upstream files
4642 my @cmd = (@git, qw(diff-tree -z));
4643 push @cmd, qw(--name-only) unless $unrepres;
4644 push @cmd, qw(-r) if $finegrained || $unrepres;
4646 my $diffs= cmdoutput @cmd;
4649 foreach my $f (split /\0/, $diffs) {
4650 if ($unrepres && !@lmodes) {
4651 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4654 my ($oldmode,$newmode) = @lmodes;
4657 next if $f =~ m#^debian(?:/.*)?$#s;
4661 die "not a plain file\n"
4662 unless $newmode =~ m/^10\d{4}$/ ||
4663 $oldmode =~ m/^10\d{4}$/;
4664 if ($oldmode =~ m/[^0]/ &&
4665 $newmode =~ m/[^0]/) {
4666 die "mode changed\n" if $oldmode ne $newmode;
4668 die "non-default mode\n"
4669 unless $newmode =~ m/^100644$/ ||
4670 $oldmode =~ m/^100644$/;
4674 local $/="\n"; chomp $@;
4675 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4679 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4680 $r |= $isignore ? 02 : 01;
4681 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4683 printdebug "quiltify_trees_differ $x $y => $r\n";
4687 sub quiltify_tree_sentinelfiles ($) {
4688 # lists the `sentinel' files present in the tree
4690 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4691 qw(-- debian/rules debian/control);
4696 sub quiltify_splitbrain_needed () {
4697 if (!$split_brain) {
4698 progress "dgit view: changes are required...";
4699 runcmd @git, qw(checkout -q -b dgit-view);
4704 sub quiltify_splitbrain ($$$$$$) {
4705 my ($clogp, $unapplied, $headref, $diffbits,
4706 $editedignores, $cachekey) = @_;
4707 if ($quilt_mode !~ m/gbp|dpm/) {
4708 # treat .gitignore just like any other upstream file
4709 $diffbits = { %$diffbits };
4710 $_ = !!$_ foreach values %$diffbits;
4712 # We would like any commits we generate to be reproducible
4713 my @authline = clogp_authline($clogp);
4714 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4715 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4716 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4717 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4718 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4719 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4721 if ($quilt_mode =~ m/gbp|unapplied/ &&
4722 ($diffbits->{O2H} & 01)) {
4724 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4725 " but git tree differs from orig in upstream files.";
4726 if (!stat_exists "debian/patches") {
4728 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4732 if ($quilt_mode =~ m/dpm/ &&
4733 ($diffbits->{H2A} & 01)) {
4735 --quilt=$quilt_mode specified, implying patches-applied git tree
4736 but git tree differs from result of applying debian/patches to upstream
4739 if ($quilt_mode =~ m/gbp|unapplied/ &&
4740 ($diffbits->{O2A} & 01)) { # some patches
4741 quiltify_splitbrain_needed();
4742 progress "dgit view: creating patches-applied version using gbp pq";
4743 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4744 # gbp pq import creates a fresh branch; push back to dgit-view
4745 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4746 runcmd @git, qw(checkout -q dgit-view);
4748 if ($quilt_mode =~ m/gbp|dpm/ &&
4749 ($diffbits->{O2A} & 02)) {
4751 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4752 tool which does not create patches for changes to upstream
4753 .gitignores: but, such patches exist in debian/patches.
4756 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4757 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4758 quiltify_splitbrain_needed();
4759 progress "dgit view: creating patch to represent .gitignore changes";
4760 ensuredir "debian/patches";
4761 my $gipatch = "debian/patches/auto-gitignore";
4762 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4763 stat GIPATCH or die "$gipatch: $!";
4764 fail "$gipatch already exists; but want to create it".
4765 " to record .gitignore changes" if (stat _)[7];
4766 print GIPATCH <<END or die "$gipatch: $!";
4767 Subject: Update .gitignore from Debian packaging branch
4769 The Debian packaging git branch contains these updates to the upstream
4770 .gitignore file(s). This patch is autogenerated, to provide these
4771 updates to users of the official Debian archive view of the package.
4773 [dgit ($our_version) update-gitignore]
4776 close GIPATCH or die "$gipatch: $!";
4777 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4778 $unapplied, $headref, "--", sort keys %$editedignores;
4779 open SERIES, "+>>", "debian/patches/series" or die $!;
4780 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4782 defined read SERIES, $newline, 1 or die $!;
4783 print SERIES "\n" or die $! unless $newline eq "\n";
4784 print SERIES "auto-gitignore\n" or die $!;
4785 close SERIES or die $!;
4786 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4788 Commit patch to update .gitignore
4790 [dgit ($our_version) update-gitignore-quilt-fixup]
4794 my $dgitview = git_rev_parse 'HEAD';
4796 changedir '../../../..';
4797 # When we no longer need to support squeeze, use --create-reflog
4799 ensuredir ".git/logs/refs/dgit-intern";
4800 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4803 my $oldcache = git_get_ref "refs/$splitbraincache";
4804 if ($oldcache eq $dgitview) {
4805 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4806 # git update-ref doesn't always update, in this case. *sigh*
4807 my $dummy = make_commit_text <<END;
4810 author Dgit <dgit\@example.com> 1000000000 +0000
4811 committer Dgit <dgit\@example.com> 1000000000 +0000
4813 Dummy commit - do not use
4815 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4816 "refs/$splitbraincache", $dummy;
4818 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4821 changedir '.git/dgit/unpack/work';
4823 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4824 progress "dgit view: created ($saved)";
4827 sub quiltify ($$$$) {
4828 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4830 # Quilt patchification algorithm
4832 # We search backwards through the history of the main tree's HEAD
4833 # (T) looking for a start commit S whose tree object is identical
4834 # to to the patch tip tree (ie the tree corresponding to the
4835 # current dpkg-committed patch series). For these purposes
4836 # `identical' disregards anything in debian/ - this wrinkle is
4837 # necessary because dpkg-source treates debian/ specially.
4839 # We can only traverse edges where at most one of the ancestors'
4840 # trees differs (in changes outside in debian/). And we cannot
4841 # handle edges which change .pc/ or debian/patches. To avoid
4842 # going down a rathole we avoid traversing edges which introduce
4843 # debian/rules or debian/control. And we set a limit on the
4844 # number of edges we are willing to look at.
4846 # If we succeed, we walk forwards again. For each traversed edge
4847 # PC (with P parent, C child) (starting with P=S and ending with
4848 # C=T) to we do this:
4850 # - dpkg-source --commit with a patch name and message derived from C
4851 # After traversing PT, we git commit the changes which
4852 # should be contained within debian/patches.
4854 # The search for the path S..T is breadth-first. We maintain a
4855 # todo list containing search nodes. A search node identifies a
4856 # commit, and looks something like this:
4858 # Commit => $git_commit_id,
4859 # Child => $c, # or undef if P=T
4860 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4861 # Nontrivial => true iff $p..$c has relevant changes
4868 my %considered; # saves being exponential on some weird graphs
4870 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4873 my ($search,$whynot) = @_;
4874 printdebug " search NOT $search->{Commit} $whynot\n";
4875 $search->{Whynot} = $whynot;
4876 push @nots, $search;
4877 no warnings qw(exiting);
4886 my $c = shift @todo;
4887 next if $considered{$c->{Commit}}++;
4889 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4891 printdebug "quiltify investigate $c->{Commit}\n";
4894 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4895 printdebug " search finished hooray!\n";
4900 if ($quilt_mode eq 'nofix') {
4901 fail "quilt fixup required but quilt mode is \`nofix'\n".
4902 "HEAD commit $c->{Commit} differs from tree implied by ".
4903 " debian/patches (tree object $oldtiptree)";
4905 if ($quilt_mode eq 'smash') {
4906 printdebug " search quitting smash\n";
4910 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4911 $not->($c, "has $c_sentinels not $t_sentinels")
4912 if $c_sentinels ne $t_sentinels;
4914 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4915 $commitdata =~ m/\n\n/;
4917 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4918 @parents = map { { Commit => $_, Child => $c } } @parents;
4920 $not->($c, "root commit") if !@parents;
4922 foreach my $p (@parents) {
4923 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4925 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4926 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4928 foreach my $p (@parents) {
4929 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4931 my @cmd= (@git, qw(diff-tree -r --name-only),
4932 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4933 my $patchstackchange = cmdoutput @cmd;
4934 if (length $patchstackchange) {
4935 $patchstackchange =~ s/\n/,/g;
4936 $not->($p, "changed $patchstackchange");
4939 printdebug " search queue P=$p->{Commit} ",
4940 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4946 printdebug "quiltify want to smash\n";
4949 my $x = $_[0]{Commit};
4950 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4953 my $reportnot = sub {
4955 my $s = $abbrev->($notp);
4956 my $c = $notp->{Child};
4957 $s .= "..".$abbrev->($c) if $c;
4958 $s .= ": ".$notp->{Whynot};
4961 if ($quilt_mode eq 'linear') {
4962 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4963 foreach my $notp (@nots) {
4964 print STDERR "$us: ", $reportnot->($notp), "\n";
4966 print STDERR "$us: $_\n" foreach @$failsuggestion;
4967 fail "quilt fixup naive history linearisation failed.\n".
4968 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4969 } elsif ($quilt_mode eq 'smash') {
4970 } elsif ($quilt_mode eq 'auto') {
4971 progress "quilt fixup cannot be linear, smashing...";
4973 die "$quilt_mode ?";
4976 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4977 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4979 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4981 quiltify_dpkg_commit "auto-$version-$target-$time",
4982 (getfield $clogp, 'Maintainer'),
4983 "Automatically generated patch ($clogp->{Version})\n".
4984 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4988 progress "quiltify linearisation planning successful, executing...";
4990 for (my $p = $sref_S;
4991 my $c = $p->{Child};
4993 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4994 next unless $p->{Nontrivial};
4996 my $cc = $c->{Commit};
4998 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4999 $commitdata =~ m/\n\n/ or die "$c ?";
5002 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5005 my $commitdate = cmdoutput
5006 @git, qw(log -n1 --pretty=format:%aD), $cc;
5008 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5010 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5017 my $gbp_check_suitable = sub {
5022 die "contains unexpected slashes\n" if m{//} || m{/$};
5023 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5024 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5025 die "too long" if length > 200;
5027 return $_ unless $@;
5028 print STDERR "quiltifying commit $cc:".
5029 " ignoring/dropping Gbp-Pq $what: $@";
5033 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5035 (\S+) \s* \n //ixm) {
5036 $patchname = $gbp_check_suitable->($1, 'Name');
5038 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5040 (\S+) \s* \n //ixm) {
5041 $patchdir = $gbp_check_suitable->($1, 'Topic');
5046 if (!defined $patchname) {
5047 $patchname = $title;
5048 $patchname =~ s/[.:]$//;
5051 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5052 my $translitname = $converter->convert($patchname);
5053 die unless defined $translitname;
5054 $patchname = $translitname;
5057 "dgit: patch title transliteration error: $@"
5059 $patchname =~ y/ A-Z/-a-z/;
5060 $patchname =~ y/-a-z0-9_.+=~//cd;
5061 $patchname =~ s/^\W/x-$&/;
5062 $patchname = substr($patchname,0,40);
5064 if (!defined $patchdir) {
5067 if (length $patchdir) {
5068 $patchname = "$patchdir/$patchname";
5070 if ($patchname =~ m{^(.*)/}) {
5071 mkpath "debian/patches/$1";
5076 stat "debian/patches/$patchname$index";
5078 $!==ENOENT or die "$patchname$index $!";
5080 runcmd @git, qw(checkout -q), $cc;
5082 # We use the tip's changelog so that dpkg-source doesn't
5083 # produce complaining messages from dpkg-parsechangelog. None
5084 # of the information dpkg-source gets from the changelog is
5085 # actually relevant - it gets put into the original message
5086 # which dpkg-source provides our stunt editor, and then
5088 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5090 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5091 "Date: $commitdate\n".
5092 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5094 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5097 runcmd @git, qw(checkout -q master);
5100 sub build_maybe_quilt_fixup () {
5101 my ($format,$fopts) = get_source_format;
5102 return unless madformat_wantfixup $format;
5105 check_for_vendor_patches();
5107 if (quiltmode_splitbrain) {
5108 fail <<END unless access_cfg_tagformats_can_splitbrain;
5109 quilt mode $quilt_mode requires split view so server needs to support
5110 both "new" and "maint" tag formats, but config says it doesn't.
5114 my $clogp = parsechangelog();
5115 my $headref = git_rev_parse('HEAD');
5120 my $upstreamversion = upstreamversion $version;
5122 if ($fopts->{'single-debian-patch'}) {
5123 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5125 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5128 die 'bug' if $split_brain && !$need_split_build_invocation;
5130 changedir '../../../..';
5131 runcmd_ordryrun_local
5132 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5135 sub quilt_fixup_mkwork ($) {
5138 mkdir "work" or die $!;
5140 mktree_in_ud_here();
5141 runcmd @git, qw(reset -q --hard), $headref;
5144 sub quilt_fixup_linkorigs ($$) {
5145 my ($upstreamversion, $fn) = @_;
5146 # calls $fn->($leafname);
5148 foreach my $f (<../../../../*>) { #/){
5149 my $b=$f; $b =~ s{.*/}{};
5151 local ($debuglevel) = $debuglevel-1;
5152 printdebug "QF linkorigs $b, $f ?\n";
5154 next unless is_orig_file_of_vsn $b, $upstreamversion;
5155 printdebug "QF linkorigs $b, $f Y\n";
5156 link_ltarget $f, $b or die "$b $!";
5161 sub quilt_fixup_delete_pc () {
5162 runcmd @git, qw(rm -rqf .pc);
5164 Commit removal of .pc (quilt series tracking data)
5166 [dgit ($our_version) upgrade quilt-remove-pc]
5170 sub quilt_fixup_singlepatch ($$$) {
5171 my ($clogp, $headref, $upstreamversion) = @_;
5173 progress "starting quiltify (single-debian-patch)";
5175 # dpkg-source --commit generates new patches even if
5176 # single-debian-patch is in debian/source/options. In order to
5177 # get it to generate debian/patches/debian-changes, it is
5178 # necessary to build the source package.
5180 quilt_fixup_linkorigs($upstreamversion, sub { });
5181 quilt_fixup_mkwork($headref);
5183 rmtree("debian/patches");
5185 runcmd @dpkgsource, qw(-b .);
5187 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5188 rename srcfn("$upstreamversion", "/debian/patches"),
5189 "work/debian/patches";
5192 commit_quilty_patch();
5195 sub quilt_make_fake_dsc ($) {
5196 my ($upstreamversion) = @_;
5198 my $fakeversion="$upstreamversion-~~DGITFAKE";
5200 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5201 print $fakedsc <<END or die $!;
5204 Version: $fakeversion
5208 my $dscaddfile=sub {
5211 my $md = new Digest::MD5;
5213 my $fh = new IO::File $b, '<' or die "$b $!";
5218 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5221 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5223 my @files=qw(debian/source/format debian/rules
5224 debian/control debian/changelog);
5225 foreach my $maybe (qw(debian/patches debian/source/options
5226 debian/tests/control)) {
5227 next unless stat_exists "../../../$maybe";
5228 push @files, $maybe;
5231 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5232 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5234 $dscaddfile->($debtar);
5235 close $fakedsc or die $!;
5238 sub quilt_check_splitbrain_cache ($$) {
5239 my ($headref, $upstreamversion) = @_;
5240 # Called only if we are in (potentially) split brain mode.
5242 # Computes the cache key and looks in the cache.
5243 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5245 my $splitbrain_cachekey;
5248 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5249 # we look in the reflog of dgit-intern/quilt-cache
5250 # we look for an entry whose message is the key for the cache lookup
5251 my @cachekey = (qw(dgit), $our_version);
5252 push @cachekey, $upstreamversion;
5253 push @cachekey, $quilt_mode;
5254 push @cachekey, $headref;
5256 push @cachekey, hashfile('fake.dsc');
5258 my $srcshash = Digest::SHA->new(256);
5259 my %sfs = ( %INC, '$0(dgit)' => $0 );
5260 foreach my $sfk (sort keys %sfs) {
5261 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5262 $srcshash->add($sfk," ");
5263 $srcshash->add(hashfile($sfs{$sfk}));
5264 $srcshash->add("\n");
5266 push @cachekey, $srcshash->hexdigest();
5267 $splitbrain_cachekey = "@cachekey";
5269 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5271 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5272 debugcmd "|(probably)",@cmd;
5273 my $child = open GC, "-|"; defined $child or die $!;
5275 chdir '../../..' or die $!;
5276 if (!stat ".git/logs/refs/$splitbraincache") {
5277 $! == ENOENT or die $!;
5278 printdebug ">(no reflog)\n";
5285 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5286 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5289 quilt_fixup_mkwork($headref);
5290 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5291 if ($cachehit ne $headref) {
5292 progress "dgit view: found cached ($saved)";
5293 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5295 return ($cachehit, $splitbrain_cachekey);
5297 progress "dgit view: found cached, no changes required";
5298 return ($headref, $splitbrain_cachekey);
5300 die $! if GC->error;
5301 failedcmd unless close GC;
5303 printdebug "splitbrain cache miss\n";
5304 return (undef, $splitbrain_cachekey);
5307 sub quilt_fixup_multipatch ($$$) {
5308 my ($clogp, $headref, $upstreamversion) = @_;
5310 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5313 # - honour any existing .pc in case it has any strangeness
5314 # - determine the git commit corresponding to the tip of
5315 # the patch stack (if there is one)
5316 # - if there is such a git commit, convert each subsequent
5317 # git commit into a quilt patch with dpkg-source --commit
5318 # - otherwise convert all the differences in the tree into
5319 # a single git commit
5323 # Our git tree doesn't necessarily contain .pc. (Some versions of
5324 # dgit would include the .pc in the git tree.) If there isn't
5325 # one, we need to generate one by unpacking the patches that we
5328 # We first look for a .pc in the git tree. If there is one, we
5329 # will use it. (This is not the normal case.)
5331 # Otherwise need to regenerate .pc so that dpkg-source --commit
5332 # can work. We do this as follows:
5333 # 1. Collect all relevant .orig from parent directory
5334 # 2. Generate a debian.tar.gz out of
5335 # debian/{patches,rules,source/format,source/options}
5336 # 3. Generate a fake .dsc containing just these fields:
5337 # Format Source Version Files
5338 # 4. Extract the fake .dsc
5339 # Now the fake .dsc has a .pc directory.
5340 # (In fact we do this in every case, because in future we will
5341 # want to search for a good base commit for generating patches.)
5343 # Then we can actually do the dpkg-source --commit
5344 # 1. Make a new working tree with the same object
5345 # store as our main tree and check out the main
5347 # 2. Copy .pc from the fake's extraction, if necessary
5348 # 3. Run dpkg-source --commit
5349 # 4. If the result has changes to debian/, then
5350 # - git add them them
5351 # - git add .pc if we had a .pc in-tree
5353 # 5. If we had a .pc in-tree, delete it, and git commit
5354 # 6. Back in the main tree, fast forward to the new HEAD
5356 # Another situation we may have to cope with is gbp-style
5357 # patches-unapplied trees.
5359 # We would want to detect these, so we know to escape into
5360 # quilt_fixup_gbp. However, this is in general not possible.
5361 # Consider a package with a one patch which the dgit user reverts
5362 # (with git revert or the moral equivalent).
5364 # That is indistinguishable in contents from a patches-unapplied
5365 # tree. And looking at the history to distinguish them is not
5366 # useful because the user might have made a confusing-looking git
5367 # history structure (which ought to produce an error if dgit can't
5368 # cope, not a silent reintroduction of an unwanted patch).
5370 # So gbp users will have to pass an option. But we can usually
5371 # detect their failure to do so: if the tree is not a clean
5372 # patches-applied tree, quilt linearisation fails, but the tree
5373 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5374 # they want --quilt=unapplied.
5376 # To help detect this, when we are extracting the fake dsc, we
5377 # first extract it with --skip-patches, and then apply the patches
5378 # afterwards with dpkg-source --before-build. That lets us save a
5379 # tree object corresponding to .origs.
5381 my $splitbrain_cachekey;
5383 quilt_make_fake_dsc($upstreamversion);
5385 if (quiltmode_splitbrain()) {
5387 ($cachehit, $splitbrain_cachekey) =
5388 quilt_check_splitbrain_cache($headref, $upstreamversion);
5389 return if $cachehit;
5393 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5395 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5396 rename $fakexdir, "fake" or die "$fakexdir $!";
5400 remove_stray_gits("source package");
5401 mktree_in_ud_here();
5405 my $unapplied=git_add_write_tree();
5406 printdebug "fake orig tree object $unapplied\n";
5410 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5412 if (system @bbcmd) {
5413 failedcmd @bbcmd if $? < 0;
5415 failed to apply your git tree's patch stack (from debian/patches/) to
5416 the corresponding upstream tarball(s). Your source tree and .orig
5417 are probably too inconsistent. dgit can only fix up certain kinds of
5418 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5424 quilt_fixup_mkwork($headref);
5427 if (stat_exists ".pc") {
5429 progress "Tree already contains .pc - will use it then delete it.";
5432 rename '../fake/.pc','.pc' or die $!;
5435 changedir '../fake';
5437 my $oldtiptree=git_add_write_tree();
5438 printdebug "fake o+d/p tree object $unapplied\n";
5439 changedir '../work';
5442 # We calculate some guesswork now about what kind of tree this might
5443 # be. This is mostly for error reporting.
5449 # O = orig, without patches applied
5450 # A = "applied", ie orig with H's debian/patches applied
5451 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5452 \%editedignores, \@unrepres),
5453 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5454 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5458 foreach my $b (qw(01 02)) {
5459 foreach my $v (qw(O2H O2A H2A)) {
5460 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5463 printdebug "differences \@dl @dl.\n";
5466 "$us: base trees orig=%.20s o+d/p=%.20s",
5467 $unapplied, $oldtiptree;
5469 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5470 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5471 $dl[0], $dl[1], $dl[3], $dl[4],
5475 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5477 forceable_fail [qw(unrepresentable)], <<END;
5478 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5483 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5484 push @failsuggestion, "This might be a patches-unapplied branch.";
5485 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5486 push @failsuggestion, "This might be a patches-applied branch.";
5488 push @failsuggestion, "Maybe you need to specify one of".
5489 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5491 if (quiltmode_splitbrain()) {
5492 quiltify_splitbrain($clogp, $unapplied, $headref,
5493 $diffbits, \%editedignores,
5494 $splitbrain_cachekey);
5498 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5499 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5501 if (!open P, '>>', ".pc/applied-patches") {
5502 $!==&ENOENT or die $!;
5507 commit_quilty_patch();
5509 if ($mustdeletepc) {
5510 quilt_fixup_delete_pc();
5514 sub quilt_fixup_editor () {
5515 my $descfn = $ENV{$fakeeditorenv};
5516 my $editing = $ARGV[$#ARGV];
5517 open I1, '<', $descfn or die "$descfn: $!";
5518 open I2, '<', $editing or die "$editing: $!";
5519 unlink $editing or die "$editing: $!";
5520 open O, '>', $editing or die "$editing: $!";
5521 while (<I1>) { print O or die $!; } I1->error and die $!;
5524 $copying ||= m/^\-\-\- /;
5525 next unless $copying;
5528 I2->error and die $!;
5533 sub maybe_apply_patches_dirtily () {
5534 return unless $quilt_mode =~ m/gbp|unapplied/;
5535 print STDERR <<END or die $!;
5537 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5538 dgit: Have to apply the patches - making the tree dirty.
5539 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5542 $patches_applied_dirtily = 01;
5543 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5544 runcmd qw(dpkg-source --before-build .);
5547 sub maybe_unapply_patches_again () {
5548 progress "dgit: Unapplying patches again to tidy up the tree."
5549 if $patches_applied_dirtily;
5550 runcmd qw(dpkg-source --after-build .)
5551 if $patches_applied_dirtily & 01;
5553 if $patches_applied_dirtily & 02;
5554 $patches_applied_dirtily = 0;
5557 #----- other building -----
5559 our $clean_using_builder;
5560 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5561 # clean the tree before building (perhaps invoked indirectly by
5562 # whatever we are using to run the build), rather than separately
5563 # and explicitly by us.
5566 return if $clean_using_builder;
5567 if ($cleanmode eq 'dpkg-source') {
5568 maybe_apply_patches_dirtily();
5569 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5570 } elsif ($cleanmode eq 'dpkg-source-d') {
5571 maybe_apply_patches_dirtily();
5572 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5573 } elsif ($cleanmode eq 'git') {
5574 runcmd_ordryrun_local @git, qw(clean -xdf);
5575 } elsif ($cleanmode eq 'git-ff') {
5576 runcmd_ordryrun_local @git, qw(clean -xdff);
5577 } elsif ($cleanmode eq 'check') {
5578 my $leftovers = cmdoutput @git, qw(clean -xdn);
5579 if (length $leftovers) {
5580 print STDERR $leftovers, "\n" or die $!;
5581 fail "tree contains uncommitted files and --clean=check specified";
5583 } elsif ($cleanmode eq 'none') {
5590 badusage "clean takes no additional arguments" if @ARGV;
5593 maybe_unapply_patches_again();
5596 sub build_prep_early () {
5597 our $build_prep_early_done //= 0;
5598 return if $build_prep_early_done++;
5600 badusage "-p is not allowed when building" if defined $package;
5601 my $clogp = parsechangelog();
5602 $isuite = getfield $clogp, 'Distribution';
5603 $package = getfield $clogp, 'Source';
5604 $version = getfield $clogp, 'Version';
5611 build_maybe_quilt_fixup();
5613 my $pat = changespat $version;
5614 foreach my $f (glob "$buildproductsdir/$pat") {
5616 unlink $f or fail "remove old changes file $f: $!";
5618 progress "would remove $f";
5624 sub changesopts_initial () {
5625 my @opts =@changesopts[1..$#changesopts];
5628 sub changesopts_version () {
5629 if (!defined $changes_since_version) {
5630 my @vsns = archive_query('archive_query');
5631 my @quirk = access_quirk();
5632 if ($quirk[0] eq 'backports') {
5633 local $isuite = $quirk[2];
5635 canonicalise_suite();
5636 push @vsns, archive_query('archive_query');
5639 @vsns = map { $_->[0] } @vsns;
5640 @vsns = sort { -version_compare($a, $b) } @vsns;
5641 $changes_since_version = $vsns[0];
5642 progress "changelog will contain changes since $vsns[0]";
5644 $changes_since_version = '_';
5645 progress "package seems new, not specifying -v<version>";
5648 if ($changes_since_version ne '_') {
5649 return ("-v$changes_since_version");
5655 sub changesopts () {
5656 return (changesopts_initial(), changesopts_version());
5659 sub massage_dbp_args ($;$) {
5660 my ($cmd,$xargs) = @_;
5663 # - if we're going to split the source build out so we can
5664 # do strange things to it, massage the arguments to dpkg-buildpackage
5665 # so that the main build doessn't build source (or add an argument
5666 # to stop it building source by default).
5668 # - add -nc to stop dpkg-source cleaning the source tree,
5669 # unless we're not doing a split build and want dpkg-source
5670 # as cleanmode, in which case we can do nothing
5673 # 0 - source will NOT need to be built separately by caller
5674 # +1 - source will need to be built separately by caller
5675 # +2 - source will need to be built separately by caller AND
5676 # dpkg-buildpackage should not in fact be run at all!
5677 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5678 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5679 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5680 $clean_using_builder = 1;
5683 # -nc has the side effect of specifying -b if nothing else specified
5684 # and some combinations of -S, -b, et al, are errors, rather than
5685 # later simply overriding earlie. So we need to:
5686 # - search the command line for these options
5687 # - pick the last one
5688 # - perhaps add our own as a default
5689 # - perhaps adjust it to the corresponding non-source-building version
5691 foreach my $l ($cmd, $xargs) {
5693 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5696 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5698 if ($need_split_build_invocation) {
5699 printdebug "massage split $dmode.\n";
5700 $r = $dmode =~ m/[S]/ ? +2 :
5701 $dmode =~ y/gGF/ABb/ ? +1 :
5702 $dmode =~ m/[ABb]/ ? 0 :
5705 printdebug "massage done $r $dmode.\n";
5707 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5713 my $wasdir = must_getcwd();
5719 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5720 my ($msg_if_onlyone) = @_;
5721 # If there is only one .changes file, fail with $msg_if_onlyone,
5722 # or if that is undef, be a no-op.
5723 # Returns the changes file to report to the user.
5724 my $pat = changespat $version;
5725 my @changesfiles = glob $pat;
5726 @changesfiles = sort {
5727 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5731 if (@changesfiles==1) {
5732 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5733 only one changes file from build (@changesfiles)
5735 $result = $changesfiles[0];
5736 } elsif (@changesfiles==2) {
5737 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5738 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5739 fail "$l found in binaries changes file $binchanges"
5742 runcmd_ordryrun_local @mergechanges, @changesfiles;
5743 my $multichanges = changespat $version,'multi';
5745 stat_exists $multichanges or fail "$multichanges: $!";
5746 foreach my $cf (glob $pat) {
5747 next if $cf eq $multichanges;
5748 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5751 $result = $multichanges;
5753 fail "wrong number of different changes files (@changesfiles)";
5755 printdone "build successful, results in $result\n" or die $!;
5758 sub midbuild_checkchanges () {
5759 my $pat = changespat $version;
5760 return if $rmchanges;
5761 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5762 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5764 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5765 Suggest you delete @unwanted.
5770 sub midbuild_checkchanges_vanilla ($) {
5772 midbuild_checkchanges() if $wantsrc == 1;
5775 sub postbuild_mergechanges_vanilla ($) {
5777 if ($wantsrc == 1) {
5779 postbuild_mergechanges(undef);
5782 printdone "build successful\n";
5788 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5789 my $wantsrc = massage_dbp_args \@dbp;
5792 midbuild_checkchanges_vanilla $wantsrc;
5797 push @dbp, changesopts_version();
5798 maybe_apply_patches_dirtily();
5799 runcmd_ordryrun_local @dbp;
5801 maybe_unapply_patches_again();
5802 postbuild_mergechanges_vanilla $wantsrc;
5806 $quilt_mode //= 'gbp';
5812 # gbp can make .origs out of thin air. In my tests it does this
5813 # even for a 1.0 format package, with no origs present. So I
5814 # guess it keys off just the version number. We don't know
5815 # exactly what .origs ought to exist, but let's assume that we
5816 # should run gbp if: the version has an upstream part and the main
5818 my $upstreamversion = upstreamversion $version;
5819 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5820 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5822 if ($gbp_make_orig) {
5824 $cleanmode = 'none'; # don't do it again
5825 $need_split_build_invocation = 1;
5828 my @dbp = @dpkgbuildpackage;
5830 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5832 if (!length $gbp_build[0]) {
5833 if (length executable_on_path('git-buildpackage')) {
5834 $gbp_build[0] = qw(git-buildpackage);
5836 $gbp_build[0] = 'gbp buildpackage';
5839 my @cmd = opts_opt_multi_cmd @gbp_build;
5841 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5843 if ($gbp_make_orig) {
5844 ensuredir '.git/dgit';
5845 my $ok = '.git/dgit/origs-gen-ok';
5846 unlink $ok or $!==&ENOENT or die $!;
5847 my @origs_cmd = @cmd;
5848 push @origs_cmd, qw(--git-cleaner=true);
5849 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5850 push @origs_cmd, @ARGV;
5852 debugcmd @origs_cmd;
5854 do { local $!; stat_exists $ok; }
5855 or failedcmd @origs_cmd;
5857 dryrun_report @origs_cmd;
5863 midbuild_checkchanges_vanilla $wantsrc;
5865 if (!$clean_using_builder) {
5866 push @cmd, '--git-cleaner=true';
5870 maybe_unapply_patches_again();
5872 push @cmd, changesopts();
5873 runcmd_ordryrun_local @cmd, @ARGV;
5875 postbuild_mergechanges_vanilla $wantsrc;
5877 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5881 my $our_cleanmode = $cleanmode;
5882 if ($need_split_build_invocation) {
5883 # Pretend that clean is being done some other way. This
5884 # forces us not to try to use dpkg-buildpackage to clean and
5885 # build source all in one go; and instead we run dpkg-source
5886 # (and build_prep() will do the clean since $clean_using_builder
5888 $our_cleanmode = 'ELSEWHERE';
5890 if ($our_cleanmode =~ m/^dpkg-source/) {
5891 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5892 $clean_using_builder = 1;
5895 $sourcechanges = changespat $version,'source';
5897 unlink "../$sourcechanges" or $!==ENOENT
5898 or fail "remove $sourcechanges: $!";
5900 $dscfn = dscfn($version);
5901 if ($our_cleanmode eq 'dpkg-source') {
5902 maybe_apply_patches_dirtily();
5903 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5905 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5906 maybe_apply_patches_dirtily();
5907 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5910 my @cmd = (@dpkgsource, qw(-b --));
5913 runcmd_ordryrun_local @cmd, "work";
5914 my @udfiles = <${package}_*>;
5915 changedir "../../..";
5916 foreach my $f (@udfiles) {
5917 printdebug "source copy, found $f\n";
5920 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5921 $f eq srcfn($version, $&));
5922 printdebug "source copy, found $f - renaming\n";
5923 rename "$ud/$f", "../$f" or $!==ENOENT
5924 or fail "put in place new source file ($f): $!";
5927 my $pwd = must_getcwd();
5928 my $leafdir = basename $pwd;
5930 runcmd_ordryrun_local @cmd, $leafdir;
5933 runcmd_ordryrun_local qw(sh -ec),
5934 'exec >$1; shift; exec "$@"','x',
5935 "../$sourcechanges",
5936 @dpkggenchanges, qw(-S), changesopts();
5940 sub cmd_build_source {
5942 badusage "build-source takes no additional arguments" if @ARGV;
5944 maybe_unapply_patches_again();
5945 printdone "source built, results in $dscfn and $sourcechanges";
5950 midbuild_checkchanges();
5953 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5954 stat_exists $sourcechanges
5955 or fail "$sourcechanges (in parent directory): $!";
5957 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5959 maybe_unapply_patches_again();
5961 postbuild_mergechanges(<<END);
5962 perhaps you need to pass -A ? (sbuild's default is to build only
5963 arch-specific binaries; dgit 1.4 used to override that.)
5968 sub cmd_quilt_fixup {
5969 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5972 build_maybe_quilt_fixup();
5975 sub cmd_import_dsc {
5979 last unless $ARGV[0] =~ m/^-/;
5982 if (m/^--require-valid-signature$/) {
5985 badusage "unknown dgit import-dsc sub-option \`$_'";
5989 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5990 my ($dscfn, $dstbranch) = @ARGV;
5992 badusage "dry run makes no sense with import-dsc" unless act_local();
5994 my $force = $dstbranch =~ s/^\+// ? +1 :
5995 $dstbranch =~ s/^\.\.// ? -1 :
5997 my $info = $force ? " $&" : '';
5998 $info = "$dscfn$info";
6000 my $specbranch = $dstbranch;
6001 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6002 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6004 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6005 my $chead = cmdoutput_errok @symcmd;
6006 defined $chead or $?==256 or failedcmd @symcmd;
6008 fail "$dstbranch is checked out - will not update it"
6009 if defined $chead and $chead eq $dstbranch;
6011 my $oldhash = git_get_ref $dstbranch;
6013 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6014 $dscdata = do { local $/ = undef; <D>; };
6015 D->error and fail "read $dscfn: $!";
6018 # we don't normally need this so import it here
6019 use Dpkg::Source::Package;
6020 my $dp = new Dpkg::Source::Package filename => $dscfn,
6021 require_valid_signature => $needsig;
6023 local $SIG{__WARN__} = sub {
6025 return unless $needsig;
6026 fail "import-dsc signature check failed";
6028 if (!$dp->is_signed()) {
6029 warn "$us: warning: importing unsigned .dsc\n";
6031 my $r = $dp->check_signature();
6032 die "->check_signature => $r" if $needsig && $r;
6038 $package = getfield $dsc, 'Source';
6040 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6041 unless forceing [qw(import-dsc-with-dgit-field)];
6043 if (defined $dsc_hash) {
6044 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6045 resolve_dsc_field_commit undef, undef;
6047 if (defined $dsc_hash) {
6048 my @cmd = (qw(sh -ec),
6049 "echo $dsc_hash | git cat-file --batch-check");
6050 my $objgot = cmdoutput @cmd;
6051 if ($objgot =~ m#^\w+ missing\b#) {
6053 .dsc contains Dgit field referring to object $dsc_hash
6054 Your git tree does not have that object. Try `git fetch' from a
6055 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6058 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6060 progress "Not fast forward, forced update.";
6062 fail "Not fast forward to $dsc_hash";
6065 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
6066 $dstbranch, $dsc_hash);
6068 progress "dgit: import-dsc updated git ref $dstbranch";
6073 Branch $dstbranch already exists
6074 Specify ..$specbranch for a pseudo-merge, binding in existing history
6075 Specify +$specbranch to overwrite, discarding existing history
6077 if $oldhash && !$force;
6079 my @dfi = dsc_files_info();
6080 foreach my $fi (@dfi) {
6081 my $f = $fi->{Filename};
6083 next if lstat $here;
6084 fail "stat $here: $!" unless $! == ENOENT;
6086 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6088 } elsif ($dscfn =~ m#^/#) {
6091 fail "cannot import $dscfn which seems to be inside working tree!";
6093 $there =~ s#/+[^/]+$## or
6094 fail "cannot import $dscfn which seems to not have a basename";
6096 symlink $there, $here or fail "symlink $there to $here: $!";
6097 progress "made symlink $here -> $there";
6098 # print STDERR Dumper($fi);
6100 my @mergeinputs = generate_commits_from_dsc();
6101 die unless @mergeinputs == 1;
6103 my $newhash = $mergeinputs[0]{Commit};
6107 progress "Import, forced update - synthetic orphan git history.";
6108 } elsif ($force < 0) {
6109 progress "Import, merging.";
6110 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6111 my $version = getfield $dsc, 'Version';
6112 my $clogp = commit_getclogp $newhash;
6113 my $authline = clogp_authline $clogp;
6114 $newhash = make_commit_text <<END;
6121 Merge $package ($version) import into $dstbranch
6124 die; # caught earlier
6128 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
6129 $dstbranch, $newhash);
6131 progress "dgit: import-dsc results are in in git ref $dstbranch";
6134 sub cmd_archive_api_query {
6135 badusage "need only 1 subpath argument" unless @ARGV==1;
6136 my ($subpath) = @ARGV;
6137 my @cmd = archive_api_query_cmd($subpath);
6140 exec @cmd or fail "exec curl: $!\n";
6143 sub cmd_clone_dgit_repos_server {
6144 badusage "need destination argument" unless @ARGV==1;
6145 my ($destdir) = @ARGV;
6146 $package = '_dgit-repos-server';
6147 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6149 exec @cmd or fail "exec git clone: $!\n";
6152 sub cmd_setup_mergechangelogs {
6153 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6154 setup_mergechangelogs(1);
6157 sub cmd_setup_useremail {
6158 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6162 sub cmd_setup_new_tree {
6163 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6167 #---------- argument parsing and main program ----------
6170 print "dgit version $our_version\n" or die $!;
6174 our (%valopts_long, %valopts_short);
6177 sub defvalopt ($$$$) {
6178 my ($long,$short,$val_re,$how) = @_;
6179 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6180 $valopts_long{$long} = $oi;
6181 $valopts_short{$short} = $oi;
6182 # $how subref should:
6183 # do whatever assignemnt or thing it likes with $_[0]
6184 # if the option should not be passed on to remote, @rvalopts=()
6185 # or $how can be a scalar ref, meaning simply assign the value
6188 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6189 defvalopt '--distro', '-d', '.+', \$idistro;
6190 defvalopt '', '-k', '.+', \$keyid;
6191 defvalopt '--existing-package','', '.*', \$existing_package;
6192 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6193 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6194 defvalopt '--package', '-p', $package_re, \$package;
6195 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6197 defvalopt '', '-C', '.+', sub {
6198 ($changesfile) = (@_);
6199 if ($changesfile =~ s#^(.*)/##) {
6200 $buildproductsdir = $1;
6204 defvalopt '--initiator-tempdir','','.*', sub {
6205 ($initiator_tempdir) = (@_);
6206 $initiator_tempdir =~ m#^/# or
6207 badusage "--initiator-tempdir must be used specify an".
6208 " absolute, not relative, directory."
6214 if (defined $ENV{'DGIT_SSH'}) {
6215 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6216 } elsif (defined $ENV{'GIT_SSH'}) {
6217 @ssh = ($ENV{'GIT_SSH'});
6225 if (!defined $val) {
6226 badusage "$what needs a value" unless @ARGV;
6228 push @rvalopts, $val;
6230 badusage "bad value \`$val' for $what" unless
6231 $val =~ m/^$oi->{Re}$(?!\n)/s;
6232 my $how = $oi->{How};
6233 if (ref($how) eq 'SCALAR') {
6238 push @ropts, @rvalopts;
6242 last unless $ARGV[0] =~ m/^-/;
6246 if (m/^--dry-run$/) {
6249 } elsif (m/^--damp-run$/) {
6252 } elsif (m/^--no-sign$/) {
6255 } elsif (m/^--help$/) {
6257 } elsif (m/^--version$/) {
6259 } elsif (m/^--new$/) {
6262 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6263 ($om = $opts_opt_map{$1}) &&
6267 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6268 !$opts_opt_cmdonly{$1} &&
6269 ($om = $opts_opt_map{$1})) {
6272 } elsif (m/^--(gbp|dpm)$/s) {
6273 push @ropts, "--quilt=$1";
6275 } elsif (m/^--ignore-dirty$/s) {
6278 } elsif (m/^--no-quilt-fixup$/s) {
6280 $quilt_mode = 'nocheck';
6281 } elsif (m/^--no-rm-on-error$/s) {
6284 } elsif (m/^--no-chase-dsc-distro$/s) {
6286 $chase_dsc_distro = 0;
6287 } elsif (m/^--overwrite$/s) {
6289 $overwrite_version = '';
6290 } elsif (m/^--overwrite=(.+)$/s) {
6292 $overwrite_version = $1;
6293 } elsif (m/^--dep14tag$/s) {
6295 $dodep14tag= 'want';
6296 } elsif (m/^--no-dep14tag$/s) {
6299 } elsif (m/^--always-dep14tag$/s) {
6301 $dodep14tag= 'always';
6302 } elsif (m/^--delayed=(\d+)$/s) {
6305 } elsif (m/^--dgit-view-save=(.+)$/s) {
6307 $split_brain_save = $1;
6308 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6309 } elsif (m/^--(no-)?rm-old-changes$/s) {
6312 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6314 push @deliberatelies, $&;
6315 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6319 } elsif (m/^--force-/) {
6321 "$us: warning: ignoring unknown force option $_\n";
6323 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6324 # undocumented, for testing
6326 $tagformat_want = [ $1, 'command line', 1 ];
6327 # 1 menas overrides distro configuration
6328 } elsif (m/^--always-split-source-build$/s) {
6329 # undocumented, for testing
6331 $need_split_build_invocation = 1;
6332 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6333 # undocumented, for testing
6335 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6336 # ^ it's supposed to be an array ref
6337 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6338 $val = $2 ? $' : undef; #';
6339 $valopt->($oi->{Long});
6341 badusage "unknown long option \`$_'";
6348 } elsif (s/^-L/-/) {
6351 } elsif (s/^-h/-/) {
6353 } elsif (s/^-D/-/) {
6357 } elsif (s/^-N/-/) {
6362 push @changesopts, $_;
6364 } elsif (s/^-wn$//s) {
6366 $cleanmode = 'none';
6367 } elsif (s/^-wg$//s) {
6370 } elsif (s/^-wgf$//s) {
6372 $cleanmode = 'git-ff';
6373 } elsif (s/^-wd$//s) {
6375 $cleanmode = 'dpkg-source';
6376 } elsif (s/^-wdd$//s) {
6378 $cleanmode = 'dpkg-source-d';
6379 } elsif (s/^-wc$//s) {
6381 $cleanmode = 'check';
6382 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6383 push @git, '-c', $&;
6384 $gitcfgs{cmdline}{$1} = [ $2 ];
6385 } elsif (s/^-c([^=]+)$//s) {
6386 push @git, '-c', $&;
6387 $gitcfgs{cmdline}{$1} = [ 'true' ];
6388 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6390 $val = undef unless length $val;
6391 $valopt->($oi->{Short});
6394 badusage "unknown short option \`$_'";
6401 sub check_env_sanity () {
6402 my $blocked = new POSIX::SigSet;
6403 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6406 foreach my $name (qw(PIPE CHLD)) {
6407 my $signame = "SIG$name";
6408 my $signum = eval "POSIX::$signame" // die;
6409 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6410 die "$signame is set to something other than SIG_DFL\n";
6411 $blocked->ismember($signum) and
6412 die "$signame is blocked\n";
6418 On entry to dgit, $@
6419 This is a bug produced by something in in your execution environment.
6425 sub parseopts_late_defaults () {
6426 foreach my $k (keys %opts_opt_map) {
6427 my $om = $opts_opt_map{$k};
6429 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6431 badcfg "cannot set command for $k"
6432 unless length $om->[0];
6436 foreach my $c (access_cfg_cfgs("opts-$k")) {
6438 map { $_ ? @$_ : () }
6439 map { $gitcfgs{$_}{$c} }
6440 reverse @gitcfgsources;
6441 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6442 "\n" if $debuglevel >= 4;
6444 badcfg "cannot configure options for $k"
6445 if $opts_opt_cmdonly{$k};
6446 my $insertpos = $opts_cfg_insertpos{$k};
6447 @$om = ( @$om[0..$insertpos-1],
6449 @$om[$insertpos..$#$om] );
6453 if (!defined $rmchanges) {
6454 local $access_forpush;
6455 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6458 if (!defined $quilt_mode) {
6459 local $access_forpush;
6460 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6461 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6463 $quilt_mode =~ m/^($quilt_modes_re)$/
6464 or badcfg "unknown quilt-mode \`$quilt_mode'";
6468 if (!defined $dodep14tag) {
6469 local $access_forpush;
6470 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6471 $dodep14tag =~ m/^($dodep14tag_re)$/
6472 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6476 $need_split_build_invocation ||= quiltmode_splitbrain();
6478 if (!defined $cleanmode) {
6479 local $access_forpush;
6480 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6481 $cleanmode //= 'dpkg-source';
6483 badcfg "unknown clean-mode \`$cleanmode'" unless
6484 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6488 if ($ENV{$fakeeditorenv}) {
6490 quilt_fixup_editor();
6497 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6498 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6499 if $dryrun_level == 1;
6501 print STDERR $helpmsg or die $!;
6504 my $cmd = shift @ARGV;
6507 my $pre_fn = ${*::}{"pre_$cmd"};
6508 $pre_fn->() if $pre_fn;
6510 my $fn = ${*::}{"cmd_$cmd"};
6511 $fn or badusage "unknown operation $cmd";