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
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.default.default-suite' => 'unstable',
569 'dgit.default.old-dsc-distro' => 'debian',
570 'dgit-suite.*-security.distro' => 'debian-security',
571 'dgit.default.username' => '',
572 'dgit.default.archive-query-default-component' => 'main',
573 'dgit.default.ssh' => 'ssh',
574 'dgit.default.archive-query' => 'madison:',
575 'dgit.default.sshpsql-dbname' => 'service=projectb',
576 'dgit.default.aptget-components' => 'main',
577 'dgit.default.dgit-tag-format' => 'new,old,maint',
578 'dgit.dsc-url-proto-ok.http' => 'true',
579 'dgit.dsc-url-proto-ok.https' => 'true',
580 'dgit.dsc-url-proto-ok.git' => 'true',
581 'dgit.default.dsc-url-proto-ok' => 'false',
582 # old means "repo server accepts pushes with old dgit tags"
583 # new means "repo server accepts pushes with new dgit tags"
584 # maint means "repo server accepts split brain pushes"
585 # hist means "repo server may have old pushes without new tag"
586 # ("hist" is implied by "old")
587 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
588 'dgit-distro.debian.git-check' => 'url',
589 'dgit-distro.debian.git-check-suffix' => '/info/refs',
590 'dgit-distro.debian.new-private-pushers' => 't',
591 'dgit-distro.debian/push.git-url' => '',
592 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
593 'dgit-distro.debian/push.git-user-force' => 'dgit',
594 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
595 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
596 'dgit-distro.debian/push.git-create' => 'true',
597 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
598 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
599 # 'dgit-distro.debian.archive-query-tls-key',
600 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
601 # ^ this does not work because curl is broken nowadays
602 # Fixing #790093 properly will involve providing providing the key
603 # in some pacagke and maybe updating these paths.
605 # 'dgit-distro.debian.archive-query-tls-curl-args',
606 # '--ca-path=/etc/ssl/ca-debian',
607 # ^ this is a workaround but works (only) on DSA-administered machines
608 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
609 'dgit-distro.debian.git-url-suffix' => '',
610 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
611 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
612 'dgit-distro.debian-security.archive-query' => 'aptget:',
613 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
614 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
615 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
616 'dgit-distro.debian-security.nominal-distro' => 'debian',
617 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
618 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
619 'dgit-distro.ubuntu.git-check' => 'false',
620 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
621 'dgit-distro.test-dummy.ssh' => "$td/ssh",
622 'dgit-distro.test-dummy.username' => "alice",
623 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
624 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
625 'dgit-distro.test-dummy.git-url' => "$td/git",
626 'dgit-distro.test-dummy.git-host' => "git",
627 'dgit-distro.test-dummy.git-path' => "$td/git",
628 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
629 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
630 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
631 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
635 our @gitcfgsources = qw(cmdline local global system);
637 sub git_slurp_config () {
638 local ($debuglevel) = $debuglevel-2;
641 # This algoritm is a bit subtle, but this is needed so that for
642 # options which we want to be single-valued, we allow the
643 # different config sources to override properly. See #835858.
644 foreach my $src (@gitcfgsources) {
645 next if $src eq 'cmdline';
646 # we do this ourselves since git doesn't handle it
648 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
651 open GITS, "-|", @cmd or die $!;
654 printdebug "=> ", (messagequote $_), "\n";
656 push @{ $gitcfgs{$src}{$`} }, $'; #';
660 or ($!==0 && $?==256)
665 sub git_get_config ($) {
667 foreach my $src (@gitcfgsources) {
668 my $l = $gitcfgs{$src}{$c};
669 croak "$l $c" if $l && !ref $l;
670 printdebug"C $c ".(defined $l ?
671 join " ", map { messagequote "'$_'" } @$l :
675 @$l==1 or badcfg "multiple values for $c".
676 " (in $src git config)" if @$l > 1;
684 return undef if $c =~ /RETURN-UNDEF/;
685 printdebug "C? $c\n" if $debuglevel >= 5;
686 my $v = git_get_config($c);
687 return $v if defined $v;
688 my $dv = $defcfg{$c};
690 printdebug "CD $c $dv\n" if $debuglevel >= 4;
694 badcfg "need value for one of: @_\n".
695 "$us: distro or suite appears not to be (properly) supported";
698 sub access_basedistro__noalias () {
699 if (defined $idistro) {
702 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
703 return $def if defined $def;
704 foreach my $src (@gitcfgsources, 'internal') {
705 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
707 foreach my $k (keys %$kl) {
708 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
710 next unless match_glob $dpat, $isuite;
714 return cfg("dgit.default.distro");
718 sub access_basedistro () {
719 my $noalias = access_basedistro__noalias();
720 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
721 return $canon // $noalias;
724 sub access_nomdistro () {
725 my $base = access_basedistro();
726 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
727 $r =~ m/^$distro_re$/ or badcfg
728 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
732 sub access_quirk () {
733 # returns (quirk name, distro to use instead or undef, quirk-specific info)
734 my $basedistro = access_basedistro();
735 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
737 if (defined $backports_quirk) {
738 my $re = $backports_quirk;
739 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
741 $re =~ s/\%/([-0-9a-z_]+)/
742 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
743 if ($isuite =~ m/^$re$/) {
744 return ('backports',"$basedistro-backports",$1);
747 return ('none',undef);
752 sub parse_cfg_bool ($$$) {
753 my ($what,$def,$v) = @_;
756 $v =~ m/^[ty1]/ ? 1 :
757 $v =~ m/^[fn0]/ ? 0 :
758 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
761 sub access_forpush_config () {
762 my $d = access_basedistro();
766 parse_cfg_bool('new-private-pushers', 0,
767 cfg("dgit-distro.$d.new-private-pushers",
770 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
773 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
774 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
775 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
776 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
779 sub access_forpush () {
780 $access_forpush //= access_forpush_config();
781 return $access_forpush;
785 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
786 badcfg "pushing but distro is configured readonly"
787 if access_forpush_config() eq '0';
789 $supplementary_message = <<'END' unless $we_are_responder;
790 Push failed, before we got started.
791 You can retry the push, after fixing the problem, if you like.
793 parseopts_late_defaults();
797 parseopts_late_defaults();
800 sub supplementary_message ($) {
802 if (!$we_are_responder) {
803 $supplementary_message = $msg;
805 } elsif ($protovsn >= 3) {
806 responder_send_command "supplementary-message ".length($msg)
808 print PO $msg or die $!;
812 sub access_distros () {
813 # Returns list of distros to try, in order
816 # 0. `instead of' distro name(s) we have been pointed to
817 # 1. the access_quirk distro, if any
818 # 2a. the user's specified distro, or failing that } basedistro
819 # 2b. the distro calculated from the suite }
820 my @l = access_basedistro();
822 my (undef,$quirkdistro) = access_quirk();
823 unshift @l, $quirkdistro;
824 unshift @l, $instead_distro;
825 @l = grep { defined } @l;
827 push @l, access_nomdistro();
829 if (access_forpush()) {
830 @l = map { ("$_/push", $_) } @l;
835 sub access_cfg_cfgs (@) {
838 # The nesting of these loops determines the search order. We put
839 # the key loop on the outside so that we search all the distros
840 # for each key, before going on to the next key. That means that
841 # if access_cfg is called with a more specific, and then a less
842 # specific, key, an earlier distro can override the less specific
843 # without necessarily overriding any more specific keys. (If the
844 # distro wants to override the more specific keys it can simply do
845 # so; whereas if we did the loop the other way around, it would be
846 # impossible to for an earlier distro to override a less specific
847 # key but not the more specific ones without restating the unknown
848 # values of the more specific keys.
851 # We have to deal with RETURN-UNDEF specially, so that we don't
852 # terminate the search prematurely.
854 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
857 foreach my $d (access_distros()) {
858 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
860 push @cfgs, map { "dgit.default.$_" } @realkeys;
867 my (@cfgs) = access_cfg_cfgs(@keys);
868 my $value = cfg(@cfgs);
872 sub access_cfg_bool ($$) {
873 my ($def, @keys) = @_;
874 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
877 sub string_to_ssh ($) {
879 if ($spec =~ m/\s/) {
880 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
886 sub access_cfg_ssh () {
887 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
888 if (!defined $gitssh) {
891 return string_to_ssh $gitssh;
895 sub access_runeinfo ($) {
897 return ": dgit ".access_basedistro()." $info ;";
900 sub access_someuserhost ($) {
902 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
903 defined($user) && length($user) or
904 $user = access_cfg("$some-user",'username');
905 my $host = access_cfg("$some-host");
906 return length($user) ? "$user\@$host" : $host;
909 sub access_gituserhost () {
910 return access_someuserhost('git');
913 sub access_giturl (;$) {
915 my $url = access_cfg('git-url','RETURN-UNDEF');
918 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
919 return undef unless defined $proto;
922 access_gituserhost().
923 access_cfg('git-path');
925 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
928 return "$url/$package$suffix";
931 sub parsecontrolfh ($$;$) {
932 my ($fh, $desc, $allowsigned) = @_;
933 our $dpkgcontrolhash_noissigned;
936 my %opts = ('name' => $desc);
937 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
938 $c = Dpkg::Control::Hash->new(%opts);
939 $c->parse($fh,$desc) or die "parsing of $desc failed";
940 last if $allowsigned;
941 last if $dpkgcontrolhash_noissigned;
942 my $issigned= $c->get_option('is_pgp_signed');
943 if (!defined $issigned) {
944 $dpkgcontrolhash_noissigned= 1;
945 seek $fh, 0,0 or die "seek $desc: $!";
946 } elsif ($issigned) {
947 fail "control file $desc is (already) PGP-signed. ".
948 " Note that dgit push needs to modify the .dsc and then".
949 " do the signature itself";
958 my ($file, $desc, $allowsigned) = @_;
959 my $fh = new IO::Handle;
960 open $fh, '<', $file or die "$file: $!";
961 my $c = parsecontrolfh($fh,$desc,$allowsigned);
962 $fh->error and die $!;
968 my ($dctrl,$field) = @_;
969 my $v = $dctrl->{$field};
970 return $v if defined $v;
971 fail "missing field $field in ".$dctrl->get_option('name');
975 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
976 my $p = new IO::Handle;
977 my @cmd = (qw(dpkg-parsechangelog), @_);
978 open $p, '-|', @cmd or die $!;
980 $?=0; $!=0; close $p or failedcmd @cmd;
984 sub commit_getclogp ($) {
985 # Returns the parsed changelog hashref for a particular commit
987 our %commit_getclogp_memo;
988 my $memo = $commit_getclogp_memo{$objid};
989 return $memo if $memo;
991 my $mclog = ".git/dgit/clog-$objid";
992 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
993 "$objid:debian/changelog";
994 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
999 defined $d or fail "getcwd failed: $!";
1003 sub parse_dscdata () {
1004 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1005 printdebug Dumper($dscdata) if $debuglevel>1;
1006 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1007 printdebug Dumper($dsc) if $debuglevel>1;
1012 sub archive_query ($;@) {
1013 my ($method) = shift @_;
1014 fail "this operation does not support multiple comma-separated suites"
1016 my $query = access_cfg('archive-query','RETURN-UNDEF');
1017 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1020 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1023 sub archive_query_prepend_mirror {
1024 my $m = access_cfg('mirror');
1025 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1028 sub pool_dsc_subpath ($$) {
1029 my ($vsn,$component) = @_; # $package is implict arg
1030 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1031 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1034 sub cfg_apply_map ($$$) {
1035 my ($varref, $what, $mapspec) = @_;
1036 return unless $mapspec;
1038 printdebug "config $what EVAL{ $mapspec; }\n";
1040 eval "package Dgit::Config; $mapspec;";
1045 #---------- `ftpmasterapi' archive query method (nascent) ----------
1047 sub archive_api_query_cmd ($) {
1049 my @cmd = (@curl, qw(-sS));
1050 my $url = access_cfg('archive-query-url');
1051 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1053 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1054 foreach my $key (split /\:/, $keys) {
1055 $key =~ s/\%HOST\%/$host/g;
1057 fail "for $url: stat $key: $!" unless $!==ENOENT;
1060 fail "config requested specific TLS key but do not know".
1061 " how to get curl to use exactly that EE key ($key)";
1062 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1063 # # Sadly the above line does not work because of changes
1064 # # to gnutls. The real fix for #790093 may involve
1065 # # new curl options.
1068 # Fixing #790093 properly will involve providing a value
1069 # for this on clients.
1070 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1071 push @cmd, split / /, $kargs if defined $kargs;
1073 push @cmd, $url.$subpath;
1077 sub api_query ($$;$) {
1079 my ($data, $subpath, $ok404) = @_;
1080 badcfg "ftpmasterapi archive query method takes no data part"
1082 my @cmd = archive_api_query_cmd($subpath);
1083 my $url = $cmd[$#cmd];
1084 push @cmd, qw(-w %{http_code});
1085 my $json = cmdoutput @cmd;
1086 unless ($json =~ s/\d+\d+\d$//) {
1087 failedcmd_report_cmd undef, @cmd;
1088 fail "curl failed to print 3-digit HTTP code";
1091 return undef if $code eq '404' && $ok404;
1092 fail "fetch of $url gave HTTP code $code"
1093 unless $url =~ m#^file://# or $code =~ m/^2/;
1094 return decode_json($json);
1097 sub canonicalise_suite_ftpmasterapi {
1098 my ($proto,$data) = @_;
1099 my $suites = api_query($data, 'suites');
1101 foreach my $entry (@$suites) {
1103 my $v = $entry->{$_};
1104 defined $v && $v eq $isuite;
1105 } qw(codename name);
1106 push @matched, $entry;
1108 fail "unknown suite $isuite" unless @matched;
1111 @matched==1 or die "multiple matches for suite $isuite\n";
1112 $cn = "$matched[0]{codename}";
1113 defined $cn or die "suite $isuite info has no codename\n";
1114 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1116 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1121 sub archive_query_ftpmasterapi {
1122 my ($proto,$data) = @_;
1123 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1125 my $digester = Digest::SHA->new(256);
1126 foreach my $entry (@$info) {
1128 my $vsn = "$entry->{version}";
1129 my ($ok,$msg) = version_check $vsn;
1130 die "bad version: $msg\n" unless $ok;
1131 my $component = "$entry->{component}";
1132 $component =~ m/^$component_re$/ or die "bad component";
1133 my $filename = "$entry->{filename}";
1134 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1135 or die "bad filename";
1136 my $sha256sum = "$entry->{sha256sum}";
1137 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1138 push @rows, [ $vsn, "/pool/$component/$filename",
1139 $digester, $sha256sum ];
1141 die "bad ftpmaster api response: $@\n".Dumper($entry)
1144 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1145 return archive_query_prepend_mirror @rows;
1148 sub file_in_archive_ftpmasterapi {
1149 my ($proto,$data,$filename) = @_;
1150 my $pat = $filename;
1153 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1154 my $info = api_query($data, "file_in_archive/$pat", 1);
1157 #---------- `aptget' archive query method ----------
1160 our $aptget_releasefile;
1161 our $aptget_configpath;
1163 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1164 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1166 sub aptget_cache_clean {
1167 runcmd_ordryrun_local qw(sh -ec),
1168 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1172 sub aptget_lock_acquire () {
1173 my $lockfile = "$aptget_base/lock";
1174 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1175 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1178 sub aptget_prep ($) {
1180 return if defined $aptget_base;
1182 badcfg "aptget archive query method takes no data part"
1185 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1188 ensuredir "$cache/dgit";
1190 access_cfg('aptget-cachekey','RETURN-UNDEF')
1191 // access_nomdistro();
1193 $aptget_base = "$cache/dgit/aptget";
1194 ensuredir $aptget_base;
1196 my $quoted_base = $aptget_base;
1197 die "$quoted_base contains bad chars, cannot continue"
1198 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1200 ensuredir $aptget_base;
1202 aptget_lock_acquire();
1204 aptget_cache_clean();
1206 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1207 my $sourceslist = "source.list#$cachekey";
1209 my $aptsuites = $isuite;
1210 cfg_apply_map(\$aptsuites, 'suite map',
1211 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1213 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1214 printf SRCS "deb-src %s %s %s\n",
1215 access_cfg('mirror'),
1217 access_cfg('aptget-components')
1220 ensuredir "$aptget_base/cache";
1221 ensuredir "$aptget_base/lists";
1223 open CONF, ">", $aptget_configpath or die $!;
1225 Debug::NoLocking "true";
1226 APT::Get::List-Cleanup "false";
1227 #clear APT::Update::Post-Invoke-Success;
1228 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1229 Dir::State::Lists "$quoted_base/lists";
1230 Dir::Etc::preferences "$quoted_base/preferences";
1231 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1232 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1235 foreach my $key (qw(
1238 Dir::Cache::Archives
1239 Dir::Etc::SourceParts
1240 Dir::Etc::preferencesparts
1242 ensuredir "$aptget_base/$key";
1243 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1246 my $oldatime = (time // die $!) - 1;
1247 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1248 next unless stat_exists $oldlist;
1249 my ($mtime) = (stat _)[9];
1250 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1253 runcmd_ordryrun_local aptget_aptget(), qw(update);
1256 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1257 next unless stat_exists $oldlist;
1258 my ($atime) = (stat _)[8];
1259 next if $atime == $oldatime;
1260 push @releasefiles, $oldlist;
1262 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1263 @releasefiles = @inreleasefiles if @inreleasefiles;
1264 die "apt updated wrong number of Release files (@releasefiles), erk"
1265 unless @releasefiles == 1;
1267 ($aptget_releasefile) = @releasefiles;
1270 sub canonicalise_suite_aptget {
1271 my ($proto,$data) = @_;
1274 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1276 foreach my $name (qw(Codename Suite)) {
1277 my $val = $release->{$name};
1279 printdebug "release file $name: $val\n";
1280 $val =~ m/^$suite_re$/o or fail
1281 "Release file ($aptget_releasefile) specifies intolerable $name";
1282 cfg_apply_map(\$val, 'suite rmap',
1283 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1290 sub archive_query_aptget {
1291 my ($proto,$data) = @_;
1294 ensuredir "$aptget_base/source";
1295 foreach my $old (<$aptget_base/source/*.dsc>) {
1296 unlink $old or die "$old: $!";
1299 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1300 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1301 # avoids apt-get source failing with ambiguous error code
1303 runcmd_ordryrun_local
1304 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1305 aptget_aptget(), qw(--download-only --only-source source), $package;
1307 my @dscs = <$aptget_base/source/*.dsc>;
1308 fail "apt-get source did not produce a .dsc" unless @dscs;
1309 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1311 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1314 my $uri = "file://". uri_escape $dscs[0];
1315 $uri =~ s{\%2f}{/}gi;
1316 return [ (getfield $pre_dsc, 'Version'), $uri ];
1319 #---------- `dummyapicat' archive query method ----------
1321 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1322 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1324 sub file_in_archive_dummycatapi ($$$) {
1325 my ($proto,$data,$filename) = @_;
1326 my $mirror = access_cfg('mirror');
1327 $mirror =~ s#^file://#/# or die "$mirror ?";
1329 my @cmd = (qw(sh -ec), '
1331 find -name "$2" -print0 |
1333 ', qw(x), $mirror, $filename);
1334 debugcmd "-|", @cmd;
1335 open FIA, "-|", @cmd or die $!;
1338 printdebug "| $_\n";
1339 m/^(\w+) (\S+)$/ or die "$_ ?";
1340 push @out, { sha256sum => $1, filename => $2 };
1342 close FIA or die failedcmd @cmd;
1346 #---------- `madison' archive query method ----------
1348 sub archive_query_madison {
1349 return archive_query_prepend_mirror
1350 map { [ @$_[0..1] ] } madison_get_parse(@_);
1353 sub madison_get_parse {
1354 my ($proto,$data) = @_;
1355 die unless $proto eq 'madison';
1356 if (!length $data) {
1357 $data= access_cfg('madison-distro','RETURN-UNDEF');
1358 $data //= access_basedistro();
1360 $rmad{$proto,$data,$package} ||= cmdoutput
1361 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1362 my $rmad = $rmad{$proto,$data,$package};
1365 foreach my $l (split /\n/, $rmad) {
1366 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1367 \s*( [^ \t|]+ )\s* \|
1368 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1369 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1370 $1 eq $package or die "$rmad $package ?";
1377 $component = access_cfg('archive-query-default-component');
1379 $5 eq 'source' or die "$rmad ?";
1380 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1382 return sort { -version_compare($a->[0],$b->[0]); } @out;
1385 sub canonicalise_suite_madison {
1386 # madison canonicalises for us
1387 my @r = madison_get_parse(@_);
1389 "unable to canonicalise suite using package $package".
1390 " which does not appear to exist in suite $isuite;".
1391 " --existing-package may help";
1395 sub file_in_archive_madison { return undef; }
1397 #---------- `sshpsql' archive query method ----------
1400 my ($data,$runeinfo,$sql) = @_;
1401 if (!length $data) {
1402 $data= access_someuserhost('sshpsql').':'.
1403 access_cfg('sshpsql-dbname');
1405 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1406 my ($userhost,$dbname) = ($`,$'); #';
1408 my @cmd = (access_cfg_ssh, $userhost,
1409 access_runeinfo("ssh-psql $runeinfo").
1410 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1411 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1413 open P, "-|", @cmd or die $!;
1416 printdebug(">|$_|\n");
1419 $!=0; $?=0; close P or failedcmd @cmd;
1421 my $nrows = pop @rows;
1422 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1423 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1424 @rows = map { [ split /\|/, $_ ] } @rows;
1425 my $ncols = scalar @{ shift @rows };
1426 die if grep { scalar @$_ != $ncols } @rows;
1430 sub sql_injection_check {
1431 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1434 sub archive_query_sshpsql ($$) {
1435 my ($proto,$data) = @_;
1436 sql_injection_check $isuite, $package;
1437 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1438 SELECT source.version, component.name, files.filename, files.sha256sum
1440 JOIN src_associations ON source.id = src_associations.source
1441 JOIN suite ON suite.id = src_associations.suite
1442 JOIN dsc_files ON dsc_files.source = source.id
1443 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1444 JOIN component ON component.id = files_archive_map.component_id
1445 JOIN files ON files.id = dsc_files.file
1446 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1447 AND source.source='$package'
1448 AND files.filename LIKE '%.dsc';
1450 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1451 my $digester = Digest::SHA->new(256);
1453 my ($vsn,$component,$filename,$sha256sum) = @$_;
1454 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1456 return archive_query_prepend_mirror @rows;
1459 sub canonicalise_suite_sshpsql ($$) {
1460 my ($proto,$data) = @_;
1461 sql_injection_check $isuite;
1462 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1463 SELECT suite.codename
1464 FROM suite where suite_name='$isuite' or codename='$isuite';
1466 @rows = map { $_->[0] } @rows;
1467 fail "unknown suite $isuite" unless @rows;
1468 die "ambiguous $isuite: @rows ?" if @rows>1;
1472 sub file_in_archive_sshpsql ($$$) { return undef; }
1474 #---------- `dummycat' archive query method ----------
1476 sub canonicalise_suite_dummycat ($$) {
1477 my ($proto,$data) = @_;
1478 my $dpath = "$data/suite.$isuite";
1479 if (!open C, "<", $dpath) {
1480 $!==ENOENT or die "$dpath: $!";
1481 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1485 chomp or die "$dpath: $!";
1487 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1491 sub archive_query_dummycat ($$) {
1492 my ($proto,$data) = @_;
1493 canonicalise_suite();
1494 my $dpath = "$data/package.$csuite.$package";
1495 if (!open C, "<", $dpath) {
1496 $!==ENOENT or die "$dpath: $!";
1497 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1505 printdebug "dummycat query $csuite $package $dpath | $_\n";
1506 my @row = split /\s+/, $_;
1507 @row==2 or die "$dpath: $_ ?";
1510 C->error and die "$dpath: $!";
1512 return archive_query_prepend_mirror
1513 sort { -version_compare($a->[0],$b->[0]); } @rows;
1516 sub file_in_archive_dummycat () { return undef; }
1518 #---------- tag format handling ----------
1520 sub access_cfg_tagformats () {
1521 split /\,/, access_cfg('dgit-tag-format');
1524 sub access_cfg_tagformats_can_splitbrain () {
1525 my %y = map { $_ => 1 } access_cfg_tagformats;
1526 foreach my $needtf (qw(new maint)) {
1527 next if $y{$needtf};
1533 sub need_tagformat ($$) {
1534 my ($fmt, $why) = @_;
1535 fail "need to use tag format $fmt ($why) but also need".
1536 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1537 " - no way to proceed"
1538 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1539 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1542 sub select_tagformat () {
1544 return if $tagformatfn && !$tagformat_want;
1545 die 'bug' if $tagformatfn && $tagformat_want;
1546 # ... $tagformat_want assigned after previous select_tagformat
1548 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1549 printdebug "select_tagformat supported @supported\n";
1551 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1552 printdebug "select_tagformat specified @$tagformat_want\n";
1554 my ($fmt,$why,$override) = @$tagformat_want;
1556 fail "target distro supports tag formats @supported".
1557 " but have to use $fmt ($why)"
1559 or grep { $_ eq $fmt } @supported;
1561 $tagformat_want = undef;
1563 $tagformatfn = ${*::}{"debiantag_$fmt"};
1565 fail "trying to use unknown tag format \`$fmt' ($why) !"
1566 unless $tagformatfn;
1569 #---------- archive query entrypoints and rest of program ----------
1571 sub canonicalise_suite () {
1572 return if defined $csuite;
1573 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1574 $csuite = archive_query('canonicalise_suite');
1575 if ($isuite ne $csuite) {
1576 progress "canonical suite name for $isuite is $csuite";
1578 progress "canonical suite name is $csuite";
1582 sub get_archive_dsc () {
1583 canonicalise_suite();
1584 my @vsns = archive_query('archive_query');
1585 foreach my $vinfo (@vsns) {
1586 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1587 $dscurl = $vsn_dscurl;
1588 $dscdata = url_get($dscurl);
1590 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1595 $digester->add($dscdata);
1596 my $got = $digester->hexdigest();
1598 fail "$dscurl has hash $got but".
1599 " archive told us to expect $digest";
1602 my $fmt = getfield $dsc, 'Format';
1603 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1604 "unsupported source format $fmt, sorry";
1606 $dsc_checked = !!$digester;
1607 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1611 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1614 sub check_for_git ();
1615 sub check_for_git () {
1617 my $how = access_cfg('git-check');
1618 if ($how eq 'ssh-cmd') {
1620 (access_cfg_ssh, access_gituserhost(),
1621 access_runeinfo("git-check $package").
1622 " set -e; cd ".access_cfg('git-path').";".
1623 " if test -d $package.git; then echo 1; else echo 0; fi");
1624 my $r= cmdoutput @cmd;
1625 if (defined $r and $r =~ m/^divert (\w+)$/) {
1627 my ($usedistro,) = access_distros();
1628 # NB that if we are pushing, $usedistro will be $distro/push
1629 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1630 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1631 progress "diverting to $divert (using config for $instead_distro)";
1632 return check_for_git();
1634 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1636 } elsif ($how eq 'url') {
1637 my $prefix = access_cfg('git-check-url','git-url');
1638 my $suffix = access_cfg('git-check-suffix','git-suffix',
1639 'RETURN-UNDEF') // '.git';
1640 my $url = "$prefix/$package$suffix";
1641 my @cmd = (@curl, qw(-sS -I), $url);
1642 my $result = cmdoutput @cmd;
1643 $result =~ s/^\S+ 200 .*\n\r?\n//;
1644 # curl -sS -I with https_proxy prints
1645 # HTTP/1.0 200 Connection established
1646 $result =~ m/^\S+ (404|200) /s or
1647 fail "unexpected results from git check query - ".
1648 Dumper($prefix, $result);
1650 if ($code eq '404') {
1652 } elsif ($code eq '200') {
1657 } elsif ($how eq 'true') {
1659 } elsif ($how eq 'false') {
1662 badcfg "unknown git-check \`$how'";
1666 sub create_remote_git_repo () {
1667 my $how = access_cfg('git-create');
1668 if ($how eq 'ssh-cmd') {
1670 (access_cfg_ssh, access_gituserhost(),
1671 access_runeinfo("git-create $package").
1672 "set -e; cd ".access_cfg('git-path').";".
1673 " cp -a _template $package.git");
1674 } elsif ($how eq 'true') {
1677 badcfg "unknown git-create \`$how'";
1681 our ($dsc_hash,$lastpush_mergeinput);
1682 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1684 our $ud = '.git/dgit/unpack';
1694 sub mktree_in_ud_here () {
1695 runcmd qw(git init -q);
1696 runcmd qw(git config gc.auto 0);
1697 rmtree('.git/objects');
1698 symlink '../../../../objects','.git/objects' or die $!;
1701 sub git_write_tree () {
1702 my $tree = cmdoutput @git, qw(write-tree);
1703 $tree =~ m/^\w+$/ or die "$tree ?";
1707 sub git_add_write_tree () {
1708 runcmd @git, qw(add -Af .);
1709 return git_write_tree();
1712 sub remove_stray_gits ($) {
1714 my @gitscmd = qw(find -name .git -prune -print0);
1715 debugcmd "|",@gitscmd;
1716 open GITS, "-|", @gitscmd or die $!;
1721 print STDERR "$us: warning: removing from $what: ",
1722 (messagequote $_), "\n";
1726 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1729 sub mktree_in_ud_from_only_subdir ($;$) {
1730 my ($what,$raw) = @_;
1732 # changes into the subdir
1734 die "expected one subdir but found @dirs ?" unless @dirs==1;
1735 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1739 remove_stray_gits($what);
1740 mktree_in_ud_here();
1742 my ($format, $fopts) = get_source_format();
1743 if (madformat($format)) {
1748 my $tree=git_add_write_tree();
1749 return ($tree,$dir);
1752 our @files_csum_info_fields =
1753 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1754 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1755 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1757 sub dsc_files_info () {
1758 foreach my $csumi (@files_csum_info_fields) {
1759 my ($fname, $module, $method) = @$csumi;
1760 my $field = $dsc->{$fname};
1761 next unless defined $field;
1762 eval "use $module; 1;" or die $@;
1764 foreach (split /\n/, $field) {
1766 m/^(\w+) (\d+) (\S+)$/ or
1767 fail "could not parse .dsc $fname line \`$_'";
1768 my $digester = eval "$module"."->$method;" or die $@;
1773 Digester => $digester,
1778 fail "missing any supported Checksums-* or Files field in ".
1779 $dsc->get_option('name');
1783 map { $_->{Filename} } dsc_files_info();
1786 sub files_compare_inputs (@) {
1791 my $showinputs = sub {
1792 return join "; ", map { $_->get_option('name') } @$inputs;
1795 foreach my $in (@$inputs) {
1797 my $in_name = $in->get_option('name');
1799 printdebug "files_compare_inputs $in_name\n";
1801 foreach my $csumi (@files_csum_info_fields) {
1802 my ($fname) = @$csumi;
1803 printdebug "files_compare_inputs $in_name $fname\n";
1805 my $field = $in->{$fname};
1806 next unless defined $field;
1809 foreach (split /\n/, $field) {
1812 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1813 fail "could not parse $in_name $fname line \`$_'";
1815 printdebug "files_compare_inputs $in_name $fname $f\n";
1819 my $re = \ $record{$f}{$fname};
1821 $fchecked{$f}{$in_name} = 1;
1823 fail "hash or size of $f varies in $fname fields".
1824 " (between: ".$showinputs->().")";
1829 @files = sort @files;
1830 $expected_files //= \@files;
1831 "@$expected_files" eq "@files" or
1832 fail "file list in $in_name varies between hash fields!";
1835 fail "$in_name has no files list field(s)";
1837 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1840 grep { keys %$_ == @$inputs-1 } values %fchecked
1841 or fail "no file appears in all file lists".
1842 " (looked in: ".$showinputs->().")";
1845 sub is_orig_file_in_dsc ($$) {
1846 my ($f, $dsc_files_info) = @_;
1847 return 0 if @$dsc_files_info <= 1;
1848 # One file means no origs, and the filename doesn't have a "what
1849 # part of dsc" component. (Consider versions ending `.orig'.)
1850 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1854 sub is_orig_file_of_vsn ($$) {
1855 my ($f, $upstreamvsn) = @_;
1856 my $base = srcfn $upstreamvsn, '';
1857 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1861 sub changes_update_origs_from_dsc ($$$$) {
1862 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1864 printdebug "checking origs needed ($upstreamvsn)...\n";
1865 $_ = getfield $changes, 'Files';
1866 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1867 fail "cannot find section/priority from .changes Files field";
1868 my $placementinfo = $1;
1870 printdebug "checking origs needed placement '$placementinfo'...\n";
1871 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1872 $l =~ m/\S+$/ or next;
1874 printdebug "origs $file | $l\n";
1875 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1876 printdebug "origs $file is_orig\n";
1877 my $have = archive_query('file_in_archive', $file);
1878 if (!defined $have) {
1880 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1886 printdebug "origs $file \$#\$have=$#$have\n";
1887 foreach my $h (@$have) {
1890 foreach my $csumi (@files_csum_info_fields) {
1891 my ($fname, $module, $method, $archivefield) = @$csumi;
1892 next unless defined $h->{$archivefield};
1893 $_ = $dsc->{$fname};
1894 next unless defined;
1895 m/^(\w+) .* \Q$file\E$/m or
1896 fail ".dsc $fname missing entry for $file";
1897 if ($h->{$archivefield} eq $1) {
1901 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1904 die "$file ".Dumper($h)." ?!" if $same && @differ;
1907 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1910 printdebug "origs $file f.same=$found_same".
1911 " #f._differ=$#found_differ\n";
1912 if (@found_differ && !$found_same) {
1914 "archive contains $file with different checksum",
1917 # Now we edit the changes file to add or remove it
1918 foreach my $csumi (@files_csum_info_fields) {
1919 my ($fname, $module, $method, $archivefield) = @$csumi;
1920 next unless defined $changes->{$fname};
1922 # in archive, delete from .changes if it's there
1923 $changed{$file} = "removed" if
1924 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1925 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1926 # not in archive, but it's here in the .changes
1928 my $dsc_data = getfield $dsc, $fname;
1929 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1931 $extra =~ s/ \d+ /$&$placementinfo /
1932 or die "$fname $extra >$dsc_data< ?"
1933 if $fname eq 'Files';
1934 $changes->{$fname} .= "\n". $extra;
1935 $changed{$file} = "added";
1940 foreach my $file (keys %changed) {
1942 "edited .changes for archive .orig contents: %s %s",
1943 $changed{$file}, $file;
1945 my $chtmp = "$changesfile.tmp";
1946 $changes->save($chtmp);
1948 rename $chtmp,$changesfile or die "$changesfile $!";
1950 progress "[new .changes left in $changesfile]";
1953 progress "$changesfile already has appropriate .orig(s) (if any)";
1957 sub make_commit ($) {
1959 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1962 sub make_commit_text ($) {
1965 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1967 print Dumper($text) if $debuglevel > 1;
1968 my $child = open2($out, $in, @cmd) or die $!;
1971 print $in $text or die $!;
1972 close $in or die $!;
1974 $h =~ m/^\w+$/ or die;
1976 printdebug "=> $h\n";
1979 waitpid $child, 0 == $child or die "$child $!";
1980 $? and failedcmd @cmd;
1984 sub clogp_authline ($) {
1986 my $author = getfield $clogp, 'Maintainer';
1987 $author =~ s#,.*##ms;
1988 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1989 my $authline = "$author $date";
1990 $authline =~ m/$git_authline_re/o or
1991 fail "unexpected commit author line format \`$authline'".
1992 " (was generated from changelog Maintainer field)";
1993 return ($1,$2,$3) if wantarray;
1997 sub vendor_patches_distro ($$) {
1998 my ($checkdistro, $what) = @_;
1999 return unless defined $checkdistro;
2001 my $series = "debian/patches/\L$checkdistro\E.series";
2002 printdebug "checking for vendor-specific $series ($what)\n";
2004 if (!open SERIES, "<", $series) {
2005 die "$series $!" unless $!==ENOENT;
2014 Unfortunately, this source package uses a feature of dpkg-source where
2015 the same source package unpacks to different source code on different
2016 distros. dgit cannot safely operate on such packages on affected
2017 distros, because the meaning of source packages is not stable.
2019 Please ask the distro/maintainer to remove the distro-specific series
2020 files and use a different technique (if necessary, uploading actually
2021 different packages, if different distros are supposed to have
2025 fail "Found active distro-specific series file for".
2026 " $checkdistro ($what): $series, cannot continue";
2028 die "$series $!" if SERIES->error;
2032 sub check_for_vendor_patches () {
2033 # This dpkg-source feature doesn't seem to be documented anywhere!
2034 # But it can be found in the changelog (reformatted):
2036 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2037 # Author: Raphael Hertzog <hertzog@debian.org>
2038 # Date: Sun Oct 3 09:36:48 2010 +0200
2040 # dpkg-source: correctly create .pc/.quilt_series with alternate
2043 # If you have debian/patches/ubuntu.series and you were
2044 # unpacking the source package on ubuntu, quilt was still
2045 # directed to debian/patches/series instead of
2046 # debian/patches/ubuntu.series.
2048 # debian/changelog | 3 +++
2049 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2050 # 2 files changed, 6 insertions(+), 1 deletion(-)
2053 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2054 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2055 "Dpkg::Vendor \`current vendor'");
2056 vendor_patches_distro(access_basedistro(),
2057 "(base) distro being accessed");
2058 vendor_patches_distro(access_nomdistro(),
2059 "(nominal) distro being accessed");
2062 sub generate_commits_from_dsc () {
2063 # See big comment in fetch_from_archive, below.
2064 # See also README.dsc-import.
2068 my @dfi = dsc_files_info();
2069 foreach my $fi (@dfi) {
2070 my $f = $fi->{Filename};
2071 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2073 printdebug "considering linking $f: ";
2075 link_ltarget "../../../../$f", $f
2076 or ((printdebug "($!) "), 0)
2080 printdebug "linked.\n";
2082 complete_file_from_dsc('.', $fi)
2085 if (is_orig_file_in_dsc($f, \@dfi)) {
2086 link $f, "../../../../$f"
2092 # We unpack and record the orig tarballs first, so that we only
2093 # need disk space for one private copy of the unpacked source.
2094 # But we can't make them into commits until we have the metadata
2095 # from the debian/changelog, so we record the tree objects now and
2096 # make them into commits later.
2098 my $upstreamv = upstreamversion $dsc->{version};
2099 my $orig_f_base = srcfn $upstreamv, '';
2101 foreach my $fi (@dfi) {
2102 # We actually import, and record as a commit, every tarball
2103 # (unless there is only one file, in which case there seems
2106 my $f = $fi->{Filename};
2107 printdebug "import considering $f ";
2108 (printdebug "only one dfi\n"), next if @dfi == 1;
2109 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2110 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2114 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2116 printdebug "Y ", (join ' ', map { $_//"(none)" }
2117 $compr_ext, $orig_f_part
2120 my $input = new IO::File $f, '<' or die "$f $!";
2124 if (defined $compr_ext) {
2126 Dpkg::Compression::compression_guess_from_filename $f;
2127 fail "Dpkg::Compression cannot handle file $f in source package"
2128 if defined $compr_ext && !defined $cname;
2130 new Dpkg::Compression::Process compression => $cname;
2131 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2132 my $compr_fh = new IO::Handle;
2133 my $compr_pid = open $compr_fh, "-|" // die $!;
2135 open STDIN, "<&", $input or die $!;
2137 die "dgit (child): exec $compr_cmd[0]: $!\n";
2142 rmtree "_unpack-tar";
2143 mkdir "_unpack-tar" or die $!;
2144 my @tarcmd = qw(tar -x -f -
2145 --no-same-owner --no-same-permissions
2146 --no-acls --no-xattrs --no-selinux);
2147 my $tar_pid = fork // die $!;
2149 chdir "_unpack-tar" or die $!;
2150 open STDIN, "<&", $input or die $!;
2152 die "dgit (child): exec $tarcmd[0]: $!";
2154 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2155 !$? or failedcmd @tarcmd;
2158 (@compr_cmd ? failedcmd @compr_cmd
2160 # finally, we have the results in "tarball", but maybe
2161 # with the wrong permissions
2163 runcmd qw(chmod -R +rwX _unpack-tar);
2164 changedir "_unpack-tar";
2165 remove_stray_gits($f);
2166 mktree_in_ud_here();
2168 my ($tree) = git_add_write_tree();
2169 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2170 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2172 printdebug "one subtree $1\n";
2174 printdebug "multiple subtrees\n";
2177 rmtree "_unpack-tar";
2179 my $ent = [ $f, $tree ];
2181 Orig => !!$orig_f_part,
2182 Sort => (!$orig_f_part ? 2 :
2183 $orig_f_part =~ m/-/g ? 1 :
2191 # put any without "_" first (spec is not clear whether files
2192 # are always in the usual order). Tarballs without "_" are
2193 # the main orig or the debian tarball.
2194 $a->{Sort} <=> $b->{Sort} or
2198 my $any_orig = grep { $_->{Orig} } @tartrees;
2200 my $dscfn = "$package.dsc";
2202 my $treeimporthow = 'package';
2204 open D, ">", $dscfn or die "$dscfn: $!";
2205 print D $dscdata or die "$dscfn: $!";
2206 close D or die "$dscfn: $!";
2207 my @cmd = qw(dpkg-source);
2208 push @cmd, '--no-check' if $dsc_checked;
2209 if (madformat $dsc->{format}) {
2210 push @cmd, '--skip-patches';
2211 $treeimporthow = 'unpatched';
2213 push @cmd, qw(-x --), $dscfn;
2216 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2217 if (madformat $dsc->{format}) {
2218 check_for_vendor_patches();
2222 if (madformat $dsc->{format}) {
2223 my @pcmd = qw(dpkg-source --before-build .);
2224 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2226 $dappliedtree = git_add_write_tree();
2229 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2230 debugcmd "|",@clogcmd;
2231 open CLOGS, "-|", @clogcmd or die $!;
2236 printdebug "import clog search...\n";
2239 my $stanzatext = do { local $/=""; <CLOGS>; };
2240 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2241 last if !defined $stanzatext;
2243 my $desc = "package changelog, entry no.$.";
2244 open my $stanzafh, "<", \$stanzatext or die;
2245 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2246 $clogp //= $thisstanza;
2248 printdebug "import clog $thisstanza->{version} $desc...\n";
2250 last if !$any_orig; # we don't need $r1clogp
2252 # We look for the first (most recent) changelog entry whose
2253 # version number is lower than the upstream version of this
2254 # package. Then the last (least recent) previous changelog
2255 # entry is treated as the one which introduced this upstream
2256 # version and used for the synthetic commits for the upstream
2259 # One might think that a more sophisticated algorithm would be
2260 # necessary. But: we do not want to scan the whole changelog
2261 # file. Stopping when we see an earlier version, which
2262 # necessarily then is an earlier upstream version, is the only
2263 # realistic way to do that. Then, either the earliest
2264 # changelog entry we have seen so far is indeed the earliest
2265 # upload of this upstream version; or there are only changelog
2266 # entries relating to later upstream versions (which is not
2267 # possible unless the changelog and .dsc disagree about the
2268 # version). Then it remains to choose between the physically
2269 # last entry in the file, and the one with the lowest version
2270 # number. If these are not the same, we guess that the
2271 # versions were created in a non-monotic order rather than
2272 # that the changelog entries have been misordered.
2274 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2276 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2277 $r1clogp = $thisstanza;
2279 printdebug "import clog $r1clogp->{version} becomes r1\n";
2281 die $! if CLOGS->error;
2282 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2284 $clogp or fail "package changelog has no entries!";
2286 my $authline = clogp_authline $clogp;
2287 my $changes = getfield $clogp, 'Changes';
2288 my $cversion = getfield $clogp, 'Version';
2291 $r1clogp //= $clogp; # maybe there's only one entry;
2292 my $r1authline = clogp_authline $r1clogp;
2293 # Strictly, r1authline might now be wrong if it's going to be
2294 # unused because !$any_orig. Whatever.
2296 printdebug "import tartrees authline $authline\n";
2297 printdebug "import tartrees r1authline $r1authline\n";
2299 foreach my $tt (@tartrees) {
2300 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2302 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2305 committer $r1authline
2309 [dgit import orig $tt->{F}]
2317 [dgit import tarball $package $cversion $tt->{F}]
2322 printdebug "import main commit\n";
2324 open C, ">../commit.tmp" or die $!;
2325 print C <<END or die $!;
2328 print C <<END or die $! foreach @tartrees;
2331 print C <<END or die $!;
2337 [dgit import $treeimporthow $package $cversion]
2341 my $rawimport_hash = make_commit qw(../commit.tmp);
2343 if (madformat $dsc->{format}) {
2344 printdebug "import apply patches...\n";
2346 # regularise the state of the working tree so that
2347 # the checkout of $rawimport_hash works nicely.
2348 my $dappliedcommit = make_commit_text(<<END);
2355 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2357 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2359 # We need the answers to be reproducible
2360 my @authline = clogp_authline($clogp);
2361 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2362 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2363 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2364 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2365 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2366 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2368 my $path = $ENV{PATH} or die;
2370 foreach my $use_absurd (qw(0 1)) {
2371 runcmd @git, qw(checkout -q unpa);
2372 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2373 local $ENV{PATH} = $path;
2376 progress "warning: $@";
2377 $path = "$absurdity:$path";
2378 progress "$us: trying slow absurd-git-apply...";
2379 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2384 die "forbid absurd git-apply\n" if $use_absurd
2385 && forceing [qw(import-gitapply-no-absurd)];
2386 die "only absurd git-apply!\n" if !$use_absurd
2387 && forceing [qw(import-gitapply-absurd)];
2389 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2390 local $ENV{PATH} = $path if $use_absurd;
2392 my @showcmd = (gbp_pq, qw(import));
2393 my @realcmd = shell_cmd
2394 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2395 debugcmd "+",@realcmd;
2396 if (system @realcmd) {
2397 die +(shellquote @showcmd).
2399 failedcmd_waitstatus()."\n";
2402 my $gapplied = git_rev_parse('HEAD');
2403 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2404 $gappliedtree eq $dappliedtree or
2406 gbp-pq import and dpkg-source disagree!
2407 gbp-pq import gave commit $gapplied
2408 gbp-pq import gave tree $gappliedtree
2409 dpkg-source --before-build gave tree $dappliedtree
2411 $rawimport_hash = $gapplied;
2416 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2421 progress "synthesised git commit from .dsc $cversion";
2423 my $rawimport_mergeinput = {
2424 Commit => $rawimport_hash,
2425 Info => "Import of source package",
2427 my @output = ($rawimport_mergeinput);
2429 if ($lastpush_mergeinput) {
2430 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2431 my $oversion = getfield $oldclogp, 'Version';
2433 version_compare($oversion, $cversion);
2435 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2436 { Message => <<END, ReverseParents => 1 });
2437 Record $package ($cversion) in archive suite $csuite
2439 } elsif ($vcmp > 0) {
2440 print STDERR <<END or die $!;
2442 Version actually in archive: $cversion (older)
2443 Last version pushed with dgit: $oversion (newer or same)
2446 @output = $lastpush_mergeinput;
2448 # Same version. Use what's in the server git branch,
2449 # discarding our own import. (This could happen if the
2450 # server automatically imports all packages into git.)
2451 @output = $lastpush_mergeinput;
2454 changedir '../../../..';
2459 sub complete_file_from_dsc ($$) {
2460 our ($dstdir, $fi) = @_;
2461 # Ensures that we have, in $dir, the file $fi, with the correct
2462 # contents. (Downloading it from alongside $dscurl if necessary.)
2464 my $f = $fi->{Filename};
2465 my $tf = "$dstdir/$f";
2468 if (stat_exists $tf) {
2469 progress "using existing $f";
2471 printdebug "$tf does not exist, need to fetch\n";
2473 $furl =~ s{/[^/]+$}{};
2475 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2476 die "$f ?" if $f =~ m#/#;
2477 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2478 return 0 if !act_local();
2482 open F, "<", "$tf" or die "$tf: $!";
2483 $fi->{Digester}->reset();
2484 $fi->{Digester}->addfile(*F);
2485 F->error and die $!;
2486 my $got = $fi->{Digester}->hexdigest();
2487 $got eq $fi->{Hash} or
2488 fail "file $f has hash $got but .dsc".
2489 " demands hash $fi->{Hash} ".
2490 ($downloaded ? "(got wrong file from archive!)"
2491 : "(perhaps you should delete this file?)");
2496 sub ensure_we_have_orig () {
2497 my @dfi = dsc_files_info();
2498 foreach my $fi (@dfi) {
2499 my $f = $fi->{Filename};
2500 next unless is_orig_file_in_dsc($f, \@dfi);
2501 complete_file_from_dsc('..', $fi)
2506 #---------- git fetch ----------
2508 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2509 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2511 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2512 # locally fetched refs because they have unhelpful names and clutter
2513 # up gitk etc. So we track whether we have "used up" head ref (ie,
2514 # whether we have made another local ref which refers to this object).
2516 # (If we deleted them unconditionally, then we might end up
2517 # re-fetching the same git objects each time dgit fetch was run.)
2519 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
2520 # in git_fetch_us to fetch the refs in question, and possibly a call
2521 # to lrfetchref_used.
2523 our (%lrfetchrefs_f, %lrfetchrefs_d);
2524 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2526 sub lrfetchref_used ($) {
2527 my ($fullrefname) = @_;
2528 my $objid = $lrfetchrefs_f{$fullrefname};
2529 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2532 sub git_lrfetch_sane {
2533 my ($supplementary, @specs) = @_;
2534 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2535 # at least as regards @specs. Also leave the results in
2536 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2537 # able to clean these up.
2539 # With $supplementary==1, @specs must not contain wildcards
2540 # and we add to our previous fetches (non-atomically).
2542 # This is rather miserable:
2543 # When git fetch --prune is passed a fetchspec ending with a *,
2544 # it does a plausible thing. If there is no * then:
2545 # - it matches subpaths too, even if the supplied refspec
2546 # starts refs, and behaves completely madly if the source
2547 # has refs/refs/something. (See, for example, Debian #NNNN.)
2548 # - if there is no matching remote ref, it bombs out the whole
2550 # We want to fetch a fixed ref, and we don't know in advance
2551 # if it exists, so this is not suitable.
2553 # Our workaround is to use git ls-remote. git ls-remote has its
2554 # own qairks. Notably, it has the absurd multi-tail-matching
2555 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2556 # refs/refs/foo etc.
2558 # Also, we want an idempotent snapshot, but we have to make two
2559 # calls to the remote: one to git ls-remote and to git fetch. The
2560 # solution is use git ls-remote to obtain a target state, and
2561 # git fetch to try to generate it. If we don't manage to generate
2562 # the target state, we try again.
2564 my $url = access_giturl();
2566 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2568 my $specre = join '|', map {
2571 my $wildcard = $x =~ s/\\\*$/.*/;
2572 die if $wildcard && $supplementary;
2575 printdebug "git_lrfetch_sane specre=$specre\n";
2576 my $wanted_rref = sub {
2578 return m/^(?:$specre)$/;
2581 my $fetch_iteration = 0;
2584 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2585 if (++$fetch_iteration > 10) {
2586 fail "too many iterations trying to get sane fetch!";
2589 my @look = map { "refs/$_" } @specs;
2590 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2594 open GITLS, "-|", @lcmd or die $!;
2596 printdebug "=> ", $_;
2597 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2598 my ($objid,$rrefname) = ($1,$2);
2599 if (!$wanted_rref->($rrefname)) {
2601 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2605 $wantr{$rrefname} = $objid;
2608 close GITLS or failedcmd @lcmd;
2610 # OK, now %want is exactly what we want for refs in @specs
2612 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2613 "+refs/$_:".lrfetchrefs."/$_";
2616 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2618 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2619 runcmd_ordryrun_local @fcmd if @fspecs;
2621 if (!$supplementary) {
2622 %lrfetchrefs_f = ();
2626 git_for_each_ref(lrfetchrefs, sub {
2627 my ($objid,$objtype,$lrefname,$reftail) = @_;
2628 $lrfetchrefs_f{$lrefname} = $objid;
2629 $objgot{$objid} = 1;
2632 if ($supplementary) {
2636 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2637 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2638 if (!exists $wantr{$rrefname}) {
2639 if ($wanted_rref->($rrefname)) {
2641 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2645 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2648 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2649 delete $lrfetchrefs_f{$lrefname};
2653 foreach my $rrefname (sort keys %wantr) {
2654 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2655 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2656 my $want = $wantr{$rrefname};
2657 next if $got eq $want;
2658 if (!defined $objgot{$want}) {
2660 warning: git ls-remote suggests we want $lrefname
2661 warning: and it should refer to $want
2662 warning: but git fetch didn't fetch that object to any relevant ref.
2663 warning: This may be due to a race with someone updating the server.
2664 warning: Will try again...
2666 next FETCH_ITERATION;
2669 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2671 runcmd_ordryrun_local @git, qw(update-ref -m),
2672 "dgit fetch git fetch fixup", $lrefname, $want;
2673 $lrfetchrefs_f{$lrefname} = $want;
2678 if (defined $csuite) {
2679 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2680 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2681 my ($objid,$objtype,$lrefname,$reftail) = @_;
2682 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2683 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2687 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2688 Dumper(\%lrfetchrefs_f);
2691 sub git_fetch_us () {
2692 # Want to fetch only what we are going to use, unless
2693 # deliberately-not-ff, in which case we must fetch everything.
2695 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2697 (quiltmode_splitbrain
2698 ? (map { $_->('*',access_nomdistro) }
2699 \&debiantag_new, \&debiantag_maintview)
2700 : debiantags('*',access_nomdistro));
2701 push @specs, server_branch($csuite);
2702 push @specs, $rewritemap;
2703 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2705 git_lrfetch_sane 0, @specs;
2708 my @tagpats = debiantags('*',access_nomdistro);
2710 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2711 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2712 printdebug "currently $fullrefname=$objid\n";
2713 $here{$fullrefname} = $objid;
2715 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2716 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2717 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2718 printdebug "offered $lref=$objid\n";
2719 if (!defined $here{$lref}) {
2720 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2721 runcmd_ordryrun_local @upd;
2722 lrfetchref_used $fullrefname;
2723 } elsif ($here{$lref} eq $objid) {
2724 lrfetchref_used $fullrefname;
2727 "Not updateting $lref from $here{$lref} to $objid.\n";
2732 #---------- dsc and archive handling ----------
2734 sub mergeinfo_getclogp ($) {
2735 # Ensures thit $mi->{Clogp} exists and returns it
2737 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2740 sub mergeinfo_version ($) {
2741 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2744 sub fetch_from_archive_record_1 ($) {
2746 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2747 'DGIT_ARCHIVE', $hash;
2748 cmdoutput @git, qw(log -n2), $hash;
2749 # ... gives git a chance to complain if our commit is malformed
2752 sub fetch_from_archive_record_2 ($) {
2754 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2758 dryrun_report @upd_cmd;
2762 sub parse_dsc_field ($$) {
2763 my ($dsc, $what) = @_;
2765 foreach my $field (@ourdscfield) {
2766 $f = $dsc->{$field};
2770 progress "$what: NO git hash";
2771 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2772 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2773 progress "$what: specified git info ($dsc_distro)";
2774 $dsc_hint_tag = [ $dsc_hint_tag ];
2775 } elsif ($f =~ m/^\w+\s*$/) {
2777 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2778 dgit.default.distro);
2779 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2781 progress "$what: specified git hash";
2783 fail "$what: invalid Dgit info";
2787 sub resolve_dsc_field_commit ($$) {
2788 my ($already_distro, $already_mapref) = @_;
2790 return unless defined $dsc_hash;
2793 defined $already_mapref &&
2794 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2795 ? $already_mapref : undef;
2799 my ($what, @fetch) = @_;
2801 local $idistro = $dsc_distro;
2802 my $lrf = lrfetchrefs;
2804 if (!$chase_dsc_distro) {
2806 "not chasing .dsc distro $dsc_distro: not fetching $what";
2811 ".dsc names distro $dsc_distro: fetching $what";
2813 my $url = access_giturl();
2814 if (!defined $url) {
2815 defined $dsc_hint_url or fail <<END;
2816 .dsc Dgit metadata is in context of distro $dsc_distro
2817 for which we have no configured url and .dsc provides no hint
2820 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2821 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2822 parse_cfg_bool "dsc-url-proto-ok", 'false',
2823 cfg("dgit.dsc-url-proto-ok.$proto",
2824 "dgit.default.dsc-url-proto-ok")
2826 .dsc Dgit metadata is in context of distro $dsc_distro
2827 for which we have no configured url;
2828 .dsc provices hinted url with protocol $proto which is unsafe.
2829 (can be overridden by config - consult documentation)
2831 $url = $dsc_hint_url;
2834 git_lrfetch_sane 1, @fetch;
2839 my $rewrite_enable = do {
2840 local $idistro = $dsc_distro;
2841 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2844 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2845 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2846 $mapref = $lrf.'/'.$rewritemap;
2847 my $rewritemapdata = git_cat_file $mapref.':map';
2848 if (defined $rewritemapdata
2849 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2851 "server's git history rewrite map contains a relevant entry!";
2854 if (defined $dsc_hash) {
2855 progress "using rewritten git hash in place of .dsc value";
2857 progress "server data says .dsc hash is to be disregarded";
2862 if (!defined git_cat_file $dsc_hash) {
2863 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2864 my $lrf = $do_fetch->("additional commits", @tags) &&
2865 defined git_cat_file $dsc_hash
2867 .dsc Dgit metadata requires commit $dsc_hash
2868 but we could not obtain that object anywhere.
2870 foreach my $t (@tags) {
2871 my $fullrefname = $lrf.'/'.$t;
2872 print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2873 next unless $lrfetchrefs_f{$fullrefname};
2874 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2875 lrfetchref_used $fullrefname;
2880 sub fetch_from_archive () {
2881 ensure_setup_existing_tree();
2883 # Ensures that lrref() is what is actually in the archive, one way
2884 # or another, according to us - ie this client's
2885 # appropritaely-updated archive view. Also returns the commit id.
2886 # If there is nothing in the archive, leaves lrref alone and
2887 # returns undef. git_fetch_us must have already been called.
2891 parse_dsc_field($dsc, 'last upload to archive');
2892 resolve_dsc_field_commit access_basedistro,
2893 lrfetchrefs."/".$rewritemap
2895 progress "no version available from the archive";
2898 # If the archive's .dsc has a Dgit field, there are three
2899 # relevant git commitids we need to choose between and/or merge
2901 # 1. $dsc_hash: the Dgit field from the archive
2902 # 2. $lastpush_hash: the suite branch on the dgit git server
2903 # 3. $lastfetch_hash: our local tracking brach for the suite
2905 # These may all be distinct and need not be in any fast forward
2908 # If the dsc was pushed to this suite, then the server suite
2909 # branch will have been updated; but it might have been pushed to
2910 # a different suite and copied by the archive. Conversely a more
2911 # recent version may have been pushed with dgit but not appeared
2912 # in the archive (yet).
2914 # $lastfetch_hash may be awkward because archive imports
2915 # (particularly, imports of Dgit-less .dscs) are performed only as
2916 # needed on individual clients, so different clients may perform a
2917 # different subset of them - and these imports are only made
2918 # public during push. So $lastfetch_hash may represent a set of
2919 # imports different to a subsequent upload by a different dgit
2922 # Our approach is as follows:
2924 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2925 # descendant of $dsc_hash, then it was pushed by a dgit user who
2926 # had based their work on $dsc_hash, so we should prefer it.
2927 # Otherwise, $dsc_hash was installed into this suite in the
2928 # archive other than by a dgit push, and (necessarily) after the
2929 # last dgit push into that suite (since a dgit push would have
2930 # been descended from the dgit server git branch); thus, in that
2931 # case, we prefer the archive's version (and produce a
2932 # pseudo-merge to overwrite the dgit server git branch).
2934 # (If there is no Dgit field in the archive's .dsc then
2935 # generate_commit_from_dsc uses the version numbers to decide
2936 # whether the suite branch or the archive is newer. If the suite
2937 # branch is newer it ignores the archive's .dsc; otherwise it
2938 # generates an import of the .dsc, and produces a pseudo-merge to
2939 # overwrite the suite branch with the archive contents.)
2941 # The outcome of that part of the algorithm is the `public view',
2942 # and is same for all dgit clients: it does not depend on any
2943 # unpublished history in the local tracking branch.
2945 # As between the public view and the local tracking branch: The
2946 # local tracking branch is only updated by dgit fetch, and
2947 # whenever dgit fetch runs it includes the public view in the
2948 # local tracking branch. Therefore if the public view is not
2949 # descended from the local tracking branch, the local tracking
2950 # branch must contain history which was imported from the archive
2951 # but never pushed; and, its tip is now out of date. So, we make
2952 # a pseudo-merge to overwrite the old imports and stitch the old
2955 # Finally: we do not necessarily reify the public view (as
2956 # described above). This is so that we do not end up stacking two
2957 # pseudo-merges. So what we actually do is figure out the inputs
2958 # to any public view pseudo-merge and put them in @mergeinputs.
2961 # $mergeinputs[]{Commit}
2962 # $mergeinputs[]{Info}
2963 # $mergeinputs[0] is the one whose tree we use
2964 # @mergeinputs is in the order we use in the actual commit)
2967 # $mergeinputs[]{Message} is a commit message to use
2968 # $mergeinputs[]{ReverseParents} if def specifies that parent
2969 # list should be in opposite order
2970 # Such an entry has no Commit or Info. It applies only when found
2971 # in the last entry. (This ugliness is to support making
2972 # identical imports to previous dgit versions.)
2974 my $lastpush_hash = git_get_ref(lrfetchref());
2975 printdebug "previous reference hash=$lastpush_hash\n";
2976 $lastpush_mergeinput = $lastpush_hash && {
2977 Commit => $lastpush_hash,
2978 Info => "dgit suite branch on dgit git server",
2981 my $lastfetch_hash = git_get_ref(lrref());
2982 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2983 my $lastfetch_mergeinput = $lastfetch_hash && {
2984 Commit => $lastfetch_hash,
2985 Info => "dgit client's archive history view",
2988 my $dsc_mergeinput = $dsc_hash && {
2989 Commit => $dsc_hash,
2990 Info => "Dgit field in .dsc from archive",
2994 my $del_lrfetchrefs = sub {
2997 printdebug "del_lrfetchrefs...\n";
2998 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2999 my $objid = $lrfetchrefs_d{$fullrefname};
3000 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3002 $gur ||= new IO::Handle;
3003 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3005 printf $gur "delete %s %s\n", $fullrefname, $objid;
3008 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3012 if (defined $dsc_hash) {
3013 ensure_we_have_orig();
3014 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3015 @mergeinputs = $dsc_mergeinput
3016 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3017 print STDERR <<END or die $!;
3019 Git commit in archive is behind the last version allegedly pushed/uploaded.
3020 Commit referred to by archive: $dsc_hash
3021 Last version pushed with dgit: $lastpush_hash
3024 @mergeinputs = ($lastpush_mergeinput);
3026 # Archive has .dsc which is not a descendant of the last dgit
3027 # push. This can happen if the archive moves .dscs about.
3028 # Just follow its lead.
3029 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3030 progress "archive .dsc names newer git commit";
3031 @mergeinputs = ($dsc_mergeinput);
3033 progress "archive .dsc names other git commit, fixing up";
3034 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3038 @mergeinputs = generate_commits_from_dsc();
3039 # We have just done an import. Now, our import algorithm might
3040 # have been improved. But even so we do not want to generate
3041 # a new different import of the same package. So if the
3042 # version numbers are the same, just use our existing version.
3043 # If the version numbers are different, the archive has changed
3044 # (perhaps, rewound).
3045 if ($lastfetch_mergeinput &&
3046 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3047 (mergeinfo_version $mergeinputs[0]) )) {
3048 @mergeinputs = ($lastfetch_mergeinput);
3050 } elsif ($lastpush_hash) {
3051 # only in git, not in the archive yet
3052 @mergeinputs = ($lastpush_mergeinput);
3053 print STDERR <<END or die $!;
3055 Package not found in the archive, but has allegedly been pushed using dgit.
3059 printdebug "nothing found!\n";
3060 if (defined $skew_warning_vsn) {
3061 print STDERR <<END or die $!;
3063 Warning: relevant archive skew detected.
3064 Archive allegedly contains $skew_warning_vsn
3065 But we were not able to obtain any version from the archive or git.
3069 unshift @end, $del_lrfetchrefs;
3073 if ($lastfetch_hash &&
3075 my $h = $_->{Commit};
3076 $h and is_fast_fwd($lastfetch_hash, $h);
3077 # If true, one of the existing parents of this commit
3078 # is a descendant of the $lastfetch_hash, so we'll
3079 # be ff from that automatically.
3083 push @mergeinputs, $lastfetch_mergeinput;
3086 printdebug "fetch mergeinfos:\n";
3087 foreach my $mi (@mergeinputs) {
3089 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3091 printdebug sprintf " ReverseParents=%d Message=%s",
3092 $mi->{ReverseParents}, $mi->{Message};
3096 my $compat_info= pop @mergeinputs
3097 if $mergeinputs[$#mergeinputs]{Message};
3099 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3102 if (@mergeinputs > 1) {
3104 my $tree_commit = $mergeinputs[0]{Commit};
3106 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3107 $tree =~ m/\n\n/; $tree = $`;
3108 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3111 # We use the changelog author of the package in question the
3112 # author of this pseudo-merge. This is (roughly) correct if
3113 # this commit is simply representing aa non-dgit upload.
3114 # (Roughly because it does not record sponsorship - but we
3115 # don't have sponsorship info because that's in the .changes,
3116 # which isn't in the archivw.)
3118 # But, it might be that we are representing archive history
3119 # updates (including in-archive copies). These are not really
3120 # the responsibility of the person who created the .dsc, but
3121 # there is no-one whose name we should better use. (The
3122 # author of the .dsc-named commit is clearly worse.)
3124 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3125 my $author = clogp_authline $useclogp;
3126 my $cversion = getfield $useclogp, 'Version';
3128 my $mcf = ".git/dgit/mergecommit";
3129 open MC, ">", $mcf or die "$mcf $!";
3130 print MC <<END or die $!;
3134 my @parents = grep { $_->{Commit} } @mergeinputs;
3135 @parents = reverse @parents if $compat_info->{ReverseParents};
3136 print MC <<END or die $! foreach @parents;
3140 print MC <<END or die $!;
3146 if (defined $compat_info->{Message}) {
3147 print MC $compat_info->{Message} or die $!;
3149 print MC <<END or die $!;
3150 Record $package ($cversion) in archive suite $csuite
3154 my $message_add_info = sub {
3156 my $mversion = mergeinfo_version $mi;
3157 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3161 $message_add_info->($mergeinputs[0]);
3162 print MC <<END or die $!;
3163 should be treated as descended from
3165 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3169 $hash = make_commit $mcf;
3171 $hash = $mergeinputs[0]{Commit};
3173 printdebug "fetch hash=$hash\n";
3176 my ($lasth, $what) = @_;
3177 return unless $lasth;
3178 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3181 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3183 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3185 fetch_from_archive_record_1($hash);
3187 if (defined $skew_warning_vsn) {
3189 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3190 my $gotclogp = commit_getclogp($hash);
3191 my $got_vsn = getfield $gotclogp, 'Version';
3192 printdebug "SKEW CHECK GOT $got_vsn\n";
3193 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3194 print STDERR <<END or die $!;
3196 Warning: archive skew detected. Using the available version:
3197 Archive allegedly contains $skew_warning_vsn
3198 We were able to obtain only $got_vsn
3204 if ($lastfetch_hash ne $hash) {
3205 fetch_from_archive_record_2($hash);
3208 lrfetchref_used lrfetchref();
3210 unshift @end, $del_lrfetchrefs;
3214 sub set_local_git_config ($$) {
3216 runcmd @git, qw(config), $k, $v;
3219 sub setup_mergechangelogs (;$) {
3221 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3223 my $driver = 'dpkg-mergechangelogs';
3224 my $cb = "merge.$driver";
3225 my $attrs = '.git/info/attributes';
3226 ensuredir '.git/info';
3228 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3229 if (!open ATTRS, "<", $attrs) {
3230 $!==ENOENT or die "$attrs: $!";
3234 next if m{^debian/changelog\s};
3235 print NATTRS $_, "\n" or die $!;
3237 ATTRS->error and die $!;
3240 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3243 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3244 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3246 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3249 sub setup_useremail (;$) {
3251 return unless $always || access_cfg_bool(1, 'setup-useremail');
3254 my ($k, $envvar) = @_;
3255 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3256 return unless defined $v;
3257 set_local_git_config "user.$k", $v;
3260 $setup->('email', 'DEBEMAIL');
3261 $setup->('name', 'DEBFULLNAME');
3264 sub ensure_setup_existing_tree () {
3265 my $k = "remote.$remotename.skipdefaultupdate";
3266 my $c = git_get_config $k;
3267 return if defined $c;
3268 set_local_git_config $k, 'true';
3271 sub setup_new_tree () {
3272 setup_mergechangelogs();
3276 sub multisuite_suite_child ($$$) {
3277 my ($tsuite, $merginputs, $fn) = @_;
3278 # in child, sets things up, calls $fn->(), and returns undef
3279 # in parent, returns canonical suite name for $tsuite
3280 my $canonsuitefh = IO::File::new_tmpfile;
3281 my $pid = fork // die $!;
3284 $us .= " [$isuite]";
3285 $debugprefix .= " ";
3286 progress "fetching $tsuite...";
3287 canonicalise_suite();
3288 print $canonsuitefh $csuite, "\n" or die $!;
3289 close $canonsuitefh or die $!;
3293 waitpid $pid,0 == $pid or die $!;
3294 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3295 seek $canonsuitefh,0,0 or die $!;
3296 local $csuite = <$canonsuitefh>;
3297 die $! unless defined $csuite && chomp $csuite;
3299 printdebug "multisuite $tsuite missing\n";
3302 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3303 push @$merginputs, {
3310 sub fork_for_multisuite ($) {
3311 my ($before_fetch_merge) = @_;
3312 # if nothing unusual, just returns ''
3315 # returns 0 to caller in child, to do first of the specified suites
3316 # in child, $csuite is not yet set
3318 # returns 1 to caller in parent, to finish up anything needed after
3319 # in parent, $csuite is set to canonicalised portmanteau
3321 my $org_isuite = $isuite;
3322 my @suites = split /\,/, $isuite;
3323 return '' unless @suites > 1;
3324 printdebug "fork_for_multisuite: @suites\n";
3328 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3330 return 0 unless defined $cbasesuite;
3332 fail "package $package missing in (base suite) $cbasesuite"
3333 unless @mergeinputs;
3335 my @csuites = ($cbasesuite);
3337 $before_fetch_merge->();
3339 foreach my $tsuite (@suites[1..$#suites]) {
3340 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3346 # xxx collecte the ref here
3348 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3349 push @csuites, $csubsuite;
3352 foreach my $mi (@mergeinputs) {
3353 my $ref = git_get_ref $mi->{Ref};
3354 die "$mi->{Ref} ?" unless length $ref;
3355 $mi->{Commit} = $ref;
3358 $csuite = join ",", @csuites;
3360 my $previous = git_get_ref lrref;
3362 unshift @mergeinputs, {
3363 Commit => $previous,
3364 Info => "local combined tracking branch",
3366 "archive seems to have rewound: local tracking branch is ahead!",
3370 foreach my $ix (0..$#mergeinputs) {
3371 $mergeinputs[$ix]{Index} = $ix;
3374 @mergeinputs = sort {
3375 -version_compare(mergeinfo_version $a,
3376 mergeinfo_version $b) # highest version first
3378 $a->{Index} <=> $b->{Index}; # earliest in spec first
3384 foreach my $mi (@mergeinputs) {
3385 printdebug "multisuite merge check $mi->{Info}\n";
3386 foreach my $previous (@needed) {
3387 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3388 printdebug "multisuite merge un-needed $previous->{Info}\n";
3392 printdebug "multisuite merge this-needed\n";
3393 $mi->{Character} = '+';
3396 $needed[0]{Character} = '*';
3398 my $output = $needed[0]{Commit};
3401 printdebug "multisuite merge nontrivial\n";
3402 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3404 my $commit = "tree $tree\n";
3405 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3406 "Input branches:\n";
3408 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3409 printdebug "multisuite merge include $mi->{Info}\n";
3410 $mi->{Character} //= ' ';
3411 $commit .= "parent $mi->{Commit}\n";
3412 $msg .= sprintf " %s %-25s %s\n",
3414 (mergeinfo_version $mi),
3417 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3419 " * marks the highest version branch, which choose to use\n".
3420 " + marks each branch which was not already an ancestor\n\n".
3421 "[dgit multi-suite $csuite]\n";
3423 "author $authline\n".
3424 "committer $authline\n\n";
3425 $output = make_commit_text $commit.$msg;
3426 printdebug "multisuite merge generated $output\n";
3429 fetch_from_archive_record_1($output);
3430 fetch_from_archive_record_2($output);
3432 progress "calculated combined tracking suite $csuite";
3437 sub clone_set_head () {
3438 open H, "> .git/HEAD" or die $!;
3439 print H "ref: ".lref()."\n" or die $!;
3442 sub clone_finish ($) {
3444 runcmd @git, qw(reset --hard), lrref();
3445 runcmd qw(bash -ec), <<'END';
3447 git ls-tree -r --name-only -z HEAD | \
3448 xargs -0r touch -h -r . --
3450 printdone "ready for work in $dstdir";
3455 badusage "dry run makes no sense with clone" unless act_local();
3457 my $multi_fetched = fork_for_multisuite(sub {
3458 printdebug "multi clone before fetch merge\n";
3461 if ($multi_fetched) {
3462 printdebug "multi clone after fetch merge\n";
3464 clone_finish($dstdir);
3467 printdebug "clone main body\n";
3469 canonicalise_suite();
3470 my $hasgit = check_for_git();
3471 mkdir $dstdir or fail "create \`$dstdir': $!";
3473 runcmd @git, qw(init -q);
3475 my $giturl = access_giturl(1);
3476 if (defined $giturl) {
3477 runcmd @git, qw(remote add), 'origin', $giturl;
3480 progress "fetching existing git history";
3482 runcmd_ordryrun_local @git, qw(fetch origin);
3484 progress "starting new git history";
3486 fetch_from_archive() or no_such_package;
3487 my $vcsgiturl = $dsc->{'Vcs-Git'};
3488 if (length $vcsgiturl) {
3489 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3490 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3493 clone_finish($dstdir);
3497 canonicalise_suite();
3498 if (check_for_git()) {
3501 fetch_from_archive() or no_such_package();
3502 printdone "fetched into ".lrref();
3506 my $multi_fetched = fork_for_multisuite(sub { });
3507 fetch() unless $multi_fetched; # parent
3508 return if $multi_fetched eq '0'; # child
3509 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3511 printdone "fetched to ".lrref()." and merged into HEAD";
3514 sub check_not_dirty () {
3515 foreach my $f (qw(local-options local-patch-header)) {
3516 if (stat_exists "debian/source/$f") {
3517 fail "git tree contains debian/source/$f";
3521 return if $ignoredirty;
3523 my @cmd = (@git, qw(diff --quiet HEAD));
3525 $!=0; $?=-1; system @cmd;
3528 fail "working tree is dirty (does not match HEAD)";
3534 sub commit_admin ($) {
3537 runcmd_ordryrun_local @git, qw(commit -m), $m;
3540 sub commit_quilty_patch () {
3541 my $output = cmdoutput @git, qw(status --porcelain);
3543 foreach my $l (split /\n/, $output) {
3544 next unless $l =~ m/\S/;
3545 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3549 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3551 progress "nothing quilty to commit, ok.";
3554 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3555 runcmd_ordryrun_local @git, qw(add -f), @adds;
3557 Commit Debian 3.0 (quilt) metadata
3559 [dgit ($our_version) quilt-fixup]
3563 sub get_source_format () {
3565 if (open F, "debian/source/options") {
3569 s/\s+$//; # ignore missing final newline
3571 my ($k, $v) = ($`, $'); #');
3572 $v =~ s/^"(.*)"$/$1/;
3578 F->error and die $!;
3581 die $! unless $!==&ENOENT;
3584 if (!open F, "debian/source/format") {
3585 die $! unless $!==&ENOENT;
3589 F->error and die $!;
3591 return ($_, \%options);
3594 sub madformat_wantfixup ($) {
3596 return 0 unless $format eq '3.0 (quilt)';
3597 our $quilt_mode_warned;
3598 if ($quilt_mode eq 'nocheck') {
3599 progress "Not doing any fixup of \`$format' due to".
3600 " ----no-quilt-fixup or --quilt=nocheck"
3601 unless $quilt_mode_warned++;
3604 progress "Format \`$format', need to check/update patch stack"
3605 unless $quilt_mode_warned++;
3609 sub maybe_split_brain_save ($$$) {
3610 my ($headref, $dgitview, $msg) = @_;
3611 # => message fragment "$saved" describing disposition of $dgitview
3612 return "commit id $dgitview" unless defined $split_brain_save;
3613 my @cmd = (shell_cmd "cd ../../../..",
3614 @git, qw(update-ref -m),
3615 "dgit --dgit-view-save $msg HEAD=$headref",
3616 $split_brain_save, $dgitview);
3618 return "and left in $split_brain_save";
3621 # An "infopair" is a tuple [ $thing, $what ]
3622 # (often $thing is a commit hash; $what is a description)
3624 sub infopair_cond_equal ($$) {
3626 $x->[0] eq $y->[0] or fail <<END;
3627 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3631 sub infopair_lrf_tag_lookup ($$) {
3632 my ($tagnames, $what) = @_;
3633 # $tagname may be an array ref
3634 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3635 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3636 foreach my $tagname (@tagnames) {
3637 my $lrefname = lrfetchrefs."/tags/$tagname";
3638 my $tagobj = $lrfetchrefs_f{$lrefname};
3639 next unless defined $tagobj;
3640 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3641 return [ git_rev_parse($tagobj), $what ];
3643 fail @tagnames==1 ? <<END : <<END;
3644 Wanted tag $what (@tagnames) on dgit server, but not found
3646 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3650 sub infopair_cond_ff ($$) {
3651 my ($anc,$desc) = @_;
3652 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3653 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3657 sub pseudomerge_version_check ($$) {
3658 my ($clogp, $archive_hash) = @_;
3660 my $arch_clogp = commit_getclogp $archive_hash;
3661 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3662 'version currently in archive' ];
3663 if (defined $overwrite_version) {
3664 if (length $overwrite_version) {
3665 infopair_cond_equal([ $overwrite_version,
3666 '--overwrite= version' ],
3669 my $v = $i_arch_v->[0];
3670 progress "Checking package changelog for archive version $v ...";
3672 my @xa = ("-f$v", "-t$v");
3673 my $vclogp = parsechangelog @xa;
3674 my $cv = [ (getfield $vclogp, 'Version'),
3675 "Version field from dpkg-parsechangelog @xa" ];
3676 infopair_cond_equal($i_arch_v, $cv);
3679 $@ =~ s/^dgit: //gm;
3681 "Perhaps debian/changelog does not mention $v ?";
3686 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3690 sub pseudomerge_make_commit ($$$$ $$) {
3691 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3692 $msg_cmd, $msg_msg) = @_;
3693 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3695 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3696 my $authline = clogp_authline $clogp;
3700 !defined $overwrite_version ? ""
3701 : !length $overwrite_version ? " --overwrite"
3702 : " --overwrite=".$overwrite_version;
3705 my $pmf = ".git/dgit/pseudomerge";
3706 open MC, ">", $pmf or die "$pmf $!";
3707 print MC <<END or die $!;
3710 parent $archive_hash
3720 return make_commit($pmf);
3723 sub splitbrain_pseudomerge ($$$$) {
3724 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3725 # => $merged_dgitview
3726 printdebug "splitbrain_pseudomerge...\n";
3728 # We: debian/PREVIOUS HEAD($maintview)
3729 # expect: o ----------------- o
3732 # a/d/PREVIOUS $dgitview
3735 # we do: `------------------ o
3739 return $dgitview unless defined $archive_hash;
3741 printdebug "splitbrain_pseudomerge...\n";
3743 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3745 if (!defined $overwrite_version) {
3746 progress "Checking that HEAD inciudes all changes in archive...";
3749 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3751 if (defined $overwrite_version) {
3753 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3754 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3755 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3756 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3757 my $i_archive = [ $archive_hash, "current archive contents" ];
3759 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3761 infopair_cond_equal($i_dgit, $i_archive);
3762 infopair_cond_ff($i_dep14, $i_dgit);
3763 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3767 $us: check failed (maybe --overwrite is needed, consult documentation)
3772 my $r = pseudomerge_make_commit
3773 $clogp, $dgitview, $archive_hash, $i_arch_v,
3774 "dgit --quilt=$quilt_mode",
3775 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3776 Declare fast forward from $i_arch_v->[0]
3778 Make fast forward from $i_arch_v->[0]
3781 maybe_split_brain_save $maintview, $r, "pseudomerge";
3783 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3787 sub plain_overwrite_pseudomerge ($$$) {
3788 my ($clogp, $head, $archive_hash) = @_;
3790 printdebug "plain_overwrite_pseudomerge...";
3792 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3794 return $head if is_fast_fwd $archive_hash, $head;
3796 my $m = "Declare fast forward from $i_arch_v->[0]";
3798 my $r = pseudomerge_make_commit
3799 $clogp, $head, $archive_hash, $i_arch_v,
3802 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3804 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3808 sub push_parse_changelog ($) {
3811 my $clogp = Dpkg::Control::Hash->new();
3812 $clogp->load($clogpfn) or die;
3814 my $clogpackage = getfield $clogp, 'Source';
3815 $package //= $clogpackage;
3816 fail "-p specified $package but changelog specified $clogpackage"
3817 unless $package eq $clogpackage;
3818 my $cversion = getfield $clogp, 'Version';
3819 my $tag = debiantag($cversion, access_nomdistro);
3820 runcmd @git, qw(check-ref-format), $tag;
3822 my $dscfn = dscfn($cversion);
3824 return ($clogp, $cversion, $dscfn);
3827 sub push_parse_dsc ($$$) {
3828 my ($dscfn,$dscfnwhat, $cversion) = @_;
3829 $dsc = parsecontrol($dscfn,$dscfnwhat);
3830 my $dversion = getfield $dsc, 'Version';
3831 my $dscpackage = getfield $dsc, 'Source';
3832 ($dscpackage eq $package && $dversion eq $cversion) or
3833 fail "$dscfn is for $dscpackage $dversion".
3834 " but debian/changelog is for $package $cversion";
3837 sub push_tagwants ($$$$) {
3838 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3841 TagFn => \&debiantag,
3846 if (defined $maintviewhead) {
3848 TagFn => \&debiantag_maintview,
3849 Objid => $maintviewhead,
3850 TfSuffix => '-maintview',
3853 } elsif ($dodep14tag eq 'no' ? 0
3854 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3855 : $dodep14tag eq 'always'
3856 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3857 --dep14tag-always (or equivalent in config) means server must support
3858 both "new" and "maint" tag formats, but config says it doesn't.
3860 : die "$dodep14tag ?") {
3862 TagFn => \&debiantag_maintview,
3864 TfSuffix => '-dgit',
3868 foreach my $tw (@tagwants) {
3869 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3870 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3872 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3876 sub push_mktags ($$ $$ $) {
3878 $changesfile,$changesfilewhat,
3881 die unless $tagwants->[0]{View} eq 'dgit';
3883 my $declaredistro = access_nomdistro();
3884 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
3885 $dsc->{$ourdscfield[0]} = join " ",
3886 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
3888 $dsc->save("$dscfn.tmp") or die $!;
3890 my $changes = parsecontrol($changesfile,$changesfilewhat);
3891 foreach my $field (qw(Source Distribution Version)) {
3892 $changes->{$field} eq $clogp->{$field} or
3893 fail "changes field $field \`$changes->{$field}'".
3894 " does not match changelog \`$clogp->{$field}'";
3897 my $cversion = getfield $clogp, 'Version';
3898 my $clogsuite = getfield $clogp, 'Distribution';
3900 # We make the git tag by hand because (a) that makes it easier
3901 # to control the "tagger" (b) we can do remote signing
3902 my $authline = clogp_authline $clogp;
3903 my $delibs = join(" ", "",@deliberatelies);
3907 my $tfn = $tw->{Tfn};
3908 my $head = $tw->{Objid};
3909 my $tag = $tw->{Tag};
3911 open TO, '>', $tfn->('.tmp') or die $!;
3912 print TO <<END or die $!;
3919 if ($tw->{View} eq 'dgit') {
3920 print TO <<END or die $!;
3921 $package release $cversion for $clogsuite ($csuite) [dgit]
3922 [dgit distro=$declaredistro$delibs]
3924 foreach my $ref (sort keys %previously) {
3925 print TO <<END or die $!;
3926 [dgit previously:$ref=$previously{$ref}]
3929 } elsif ($tw->{View} eq 'maint') {
3930 print TO <<END or die $!;
3931 $package release $cversion for $clogsuite ($csuite)
3932 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3935 die Dumper($tw)."?";
3940 my $tagobjfn = $tfn->('.tmp');
3942 if (!defined $keyid) {
3943 $keyid = access_cfg('keyid','RETURN-UNDEF');
3945 if (!defined $keyid) {
3946 $keyid = getfield $clogp, 'Maintainer';
3948 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3949 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3950 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3951 push @sign_cmd, $tfn->('.tmp');
3952 runcmd_ordryrun @sign_cmd;
3954 $tagobjfn = $tfn->('.signed.tmp');
3955 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3956 $tfn->('.tmp'), $tfn->('.tmp.asc');
3962 my @r = map { $mktag->($_); } @$tagwants;
3966 sub sign_changes ($) {
3967 my ($changesfile) = @_;
3969 my @debsign_cmd = @debsign;
3970 push @debsign_cmd, "-k$keyid" if defined $keyid;
3971 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3972 push @debsign_cmd, $changesfile;
3973 runcmd_ordryrun @debsign_cmd;
3978 printdebug "actually entering push\n";
3980 supplementary_message(<<'END');
3981 Push failed, while checking state of the archive.
3982 You can retry the push, after fixing the problem, if you like.
3984 if (check_for_git()) {
3987 my $archive_hash = fetch_from_archive();
3988 if (!$archive_hash) {
3990 fail "package appears to be new in this suite;".
3991 " if this is intentional, use --new";
3994 supplementary_message(<<'END');
3995 Push failed, while preparing your push.
3996 You can retry the push, after fixing the problem, if you like.
3999 need_tagformat 'new', "quilt mode $quilt_mode"
4000 if quiltmode_splitbrain;
4004 access_giturl(); # check that success is vaguely likely
4007 my $clogpfn = ".git/dgit/changelog.822.tmp";
4008 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4010 responder_send_file('parsed-changelog', $clogpfn);
4012 my ($clogp, $cversion, $dscfn) =
4013 push_parse_changelog("$clogpfn");
4015 my $dscpath = "$buildproductsdir/$dscfn";
4016 stat_exists $dscpath or
4017 fail "looked for .dsc $dscpath, but $!;".
4018 " maybe you forgot to build";
4020 responder_send_file('dsc', $dscpath);
4022 push_parse_dsc($dscpath, $dscfn, $cversion);
4024 my $format = getfield $dsc, 'Format';
4025 printdebug "format $format\n";
4027 my $actualhead = git_rev_parse('HEAD');
4028 my $dgithead = $actualhead;
4029 my $maintviewhead = undef;
4031 my $upstreamversion = upstreamversion $clogp->{Version};
4033 if (madformat_wantfixup($format)) {
4034 # user might have not used dgit build, so maybe do this now:
4035 if (quiltmode_splitbrain()) {
4037 quilt_make_fake_dsc($upstreamversion);
4039 ($dgithead, $cachekey) =
4040 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4042 "--quilt=$quilt_mode but no cached dgit view:
4043 perhaps tree changed since dgit build[-source] ?";
4045 $dgithead = splitbrain_pseudomerge($clogp,
4046 $actualhead, $dgithead,
4048 $maintviewhead = $actualhead;
4049 changedir '../../../..';
4050 prep_ud(); # so _only_subdir() works, below
4052 commit_quilty_patch();
4056 if (defined $overwrite_version && !defined $maintviewhead) {
4057 $dgithead = plain_overwrite_pseudomerge($clogp,
4065 if ($archive_hash) {
4066 if (is_fast_fwd($archive_hash, $dgithead)) {
4068 } elsif (deliberately_not_fast_forward) {
4071 fail "dgit push: HEAD is not a descendant".
4072 " of the archive's version.\n".
4073 "To overwrite the archive's contents,".
4074 " pass --overwrite[=VERSION].\n".
4075 "To rewind history, if permitted by the archive,".
4076 " use --deliberately-not-fast-forward.";
4081 progress "checking that $dscfn corresponds to HEAD";
4082 runcmd qw(dpkg-source -x --),
4083 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
4084 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4085 check_for_vendor_patches() if madformat($dsc->{format});
4086 changedir '../../../..';
4087 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4088 debugcmd "+",@diffcmd;
4090 my $r = system @diffcmd;
4093 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4095 HEAD specifies a different tree to $dscfn:
4097 Perhaps you forgot to build. Or perhaps there is a problem with your
4098 source tree (see dgit(7) for some hints). To see a full diff, run
4105 if (!$changesfile) {
4106 my $pat = changespat $cversion;
4107 my @cs = glob "$buildproductsdir/$pat";
4108 fail "failed to find unique changes file".
4109 " (looked for $pat in $buildproductsdir);".
4110 " perhaps you need to use dgit -C"
4112 ($changesfile) = @cs;
4114 $changesfile = "$buildproductsdir/$changesfile";
4117 # Check that changes and .dsc agree enough
4118 $changesfile =~ m{[^/]*$};
4119 my $changes = parsecontrol($changesfile,$&);
4120 files_compare_inputs($dsc, $changes)
4121 unless forceing [qw(dsc-changes-mismatch)];
4123 # Perhaps adjust .dsc to contain right set of origs
4124 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4126 unless forceing [qw(changes-origs-exactly)];
4128 # Checks complete, we're going to try and go ahead:
4130 responder_send_file('changes',$changesfile);
4131 responder_send_command("param head $dgithead");
4132 responder_send_command("param csuite $csuite");
4133 responder_send_command("param tagformat $tagformat");
4134 if (defined $maintviewhead) {
4135 die unless ($protovsn//4) >= 4;
4136 responder_send_command("param maint-view $maintviewhead");
4139 if (deliberately_not_fast_forward) {
4140 git_for_each_ref(lrfetchrefs, sub {
4141 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4142 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4143 responder_send_command("previously $rrefname=$objid");
4144 $previously{$rrefname} = $objid;
4148 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4152 supplementary_message(<<'END');
4153 Push failed, while signing the tag.
4154 You can retry the push, after fixing the problem, if you like.
4156 # If we manage to sign but fail to record it anywhere, it's fine.
4157 if ($we_are_responder) {
4158 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4159 responder_receive_files('signed-tag', @tagobjfns);
4161 @tagobjfns = push_mktags($clogp,$dscpath,
4162 $changesfile,$changesfile,
4165 supplementary_message(<<'END');
4166 Push failed, *after* signing the tag.
4167 If you want to try again, you should use a new version number.
4170 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4172 foreach my $tw (@tagwants) {
4173 my $tag = $tw->{Tag};
4174 my $tagobjfn = $tw->{TagObjFn};
4176 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4177 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4178 runcmd_ordryrun_local
4179 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4182 supplementary_message(<<'END');
4183 Push failed, while updating the remote git repository - see messages above.
4184 If you want to try again, you should use a new version number.
4186 if (!check_for_git()) {
4187 create_remote_git_repo();
4190 my @pushrefs = $forceflag.$dgithead.":".rrref();
4191 foreach my $tw (@tagwants) {
4192 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4195 runcmd_ordryrun @git,
4196 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4197 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4199 supplementary_message(<<'END');
4200 Push failed, while obtaining signatures on the .changes and .dsc.
4201 If it was just that the signature failed, you may try again by using
4202 debsign by hand to sign the changes
4204 and then dput to complete the upload.
4205 If you need to change the package, you must use a new version number.
4207 if ($we_are_responder) {
4208 my $dryrunsuffix = act_local() ? "" : ".tmp";
4209 responder_receive_files('signed-dsc-changes',
4210 "$dscpath$dryrunsuffix",
4211 "$changesfile$dryrunsuffix");
4214 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4216 progress "[new .dsc left in $dscpath.tmp]";
4218 sign_changes $changesfile;
4221 supplementary_message(<<END);
4222 Push failed, while uploading package(s) to the archive server.
4223 You can retry the upload of exactly these same files with dput of:
4225 If that .changes file is broken, you will need to use a new version
4226 number for your next attempt at the upload.
4228 my $host = access_cfg('upload-host','RETURN-UNDEF');
4229 my @hostarg = defined($host) ? ($host,) : ();
4230 runcmd_ordryrun @dput, @hostarg, $changesfile;
4231 printdone "pushed and uploaded $cversion";
4233 supplementary_message('');
4234 responder_send_command("complete");
4240 badusage "-p is not allowed with clone; specify as argument instead"
4241 if defined $package;
4244 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4245 ($package,$isuite) = @ARGV;
4246 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4247 ($package,$dstdir) = @ARGV;
4248 } elsif (@ARGV==3) {
4249 ($package,$isuite,$dstdir) = @ARGV;
4251 badusage "incorrect arguments to dgit clone";
4255 $dstdir ||= "$package";
4256 if (stat_exists $dstdir) {
4257 fail "$dstdir already exists";
4261 if ($rmonerror && !$dryrun_level) {
4262 $cwd_remove= getcwd();
4264 return unless defined $cwd_remove;
4265 if (!chdir "$cwd_remove") {
4266 return if $!==&ENOENT;
4267 die "chdir $cwd_remove: $!";
4269 printdebug "clone rmonerror removing $dstdir\n";
4271 rmtree($dstdir) or die "remove $dstdir: $!\n";
4272 } elsif (grep { $! == $_ }
4273 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4275 print STDERR "check whether to remove $dstdir: $!\n";
4281 $cwd_remove = undef;
4284 sub branchsuite () {
4285 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4286 if ($branch =~ m#$lbranch_re#o) {
4293 sub fetchpullargs () {
4294 if (!defined $package) {
4295 my $sourcep = parsecontrol('debian/control','debian/control');
4296 $package = getfield $sourcep, 'Source';
4299 $isuite = branchsuite();
4301 my $clogp = parsechangelog();
4302 my $clogsuite = getfield $clogp, 'Distribution';
4303 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4305 } elsif (@ARGV==1) {
4308 badusage "incorrect arguments to dgit fetch or dgit pull";
4316 my $multi_fetched = fork_for_multisuite(sub { });
4317 exit 0 if $multi_fetched;
4324 if (quiltmode_splitbrain()) {
4325 my ($format, $fopts) = get_source_format();
4326 madformat($format) and fail <<END
4327 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4336 badusage "-p is not allowed with dgit push" if defined $package;
4338 my $clogp = parsechangelog();
4339 $package = getfield $clogp, 'Source';
4342 } elsif (@ARGV==1) {
4343 ($specsuite) = (@ARGV);
4345 badusage "incorrect arguments to dgit push";
4347 $isuite = getfield $clogp, 'Distribution';
4349 local ($package) = $existing_package; # this is a hack
4350 canonicalise_suite();
4352 canonicalise_suite();
4354 if (defined $specsuite &&
4355 $specsuite ne $isuite &&
4356 $specsuite ne $csuite) {
4357 fail "dgit push: changelog specifies $isuite ($csuite)".
4358 " but command line specifies $specsuite";
4363 #---------- remote commands' implementation ----------
4365 sub cmd_remote_push_build_host {
4366 my ($nrargs) = shift @ARGV;
4367 my (@rargs) = @ARGV[0..$nrargs-1];
4368 @ARGV = @ARGV[$nrargs..$#ARGV];
4370 my ($dir,$vsnwant) = @rargs;
4371 # vsnwant is a comma-separated list; we report which we have
4372 # chosen in our ready response (so other end can tell if they
4375 $we_are_responder = 1;
4376 $us .= " (build host)";
4380 open PI, "<&STDIN" or die $!;
4381 open STDIN, "/dev/null" or die $!;
4382 open PO, ">&STDOUT" or die $!;
4384 open STDOUT, ">&STDERR" or die $!;
4388 ($protovsn) = grep {
4389 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4390 } @rpushprotovsn_support;
4392 fail "build host has dgit rpush protocol versions ".
4393 (join ",", @rpushprotovsn_support).
4394 " but invocation host has $vsnwant"
4395 unless defined $protovsn;
4397 responder_send_command("dgit-remote-push-ready $protovsn");
4398 rpush_handle_protovsn_bothends();
4403 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4404 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4405 # a good error message)
4407 sub rpush_handle_protovsn_bothends () {
4408 if ($protovsn < 4) {
4409 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4418 my $report = i_child_report();
4419 if (defined $report) {
4420 printdebug "($report)\n";
4421 } elsif ($i_child_pid) {
4422 printdebug "(killing build host child $i_child_pid)\n";
4423 kill 15, $i_child_pid;
4425 if (defined $i_tmp && !defined $initiator_tempdir) {
4427 eval { rmtree $i_tmp; };
4431 END { i_cleanup(); }
4434 my ($base,$selector,@args) = @_;
4435 $selector =~ s/\-/_/g;
4436 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4443 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4451 push @rargs, join ",", @rpushprotovsn_support;
4454 push @rdgit, @ropts;
4455 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4457 my @cmd = (@ssh, $host, shellquote @rdgit);
4460 if (defined $initiator_tempdir) {
4461 rmtree $initiator_tempdir;
4462 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4463 $i_tmp = $initiator_tempdir;
4467 $i_child_pid = open2(\*RO, \*RI, @cmd);
4469 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4470 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4471 $supplementary_message = '' unless $protovsn >= 3;
4473 fail "rpush negotiated protocol version $protovsn".
4474 " which does not support quilt mode $quilt_mode"
4475 if quiltmode_splitbrain;
4477 rpush_handle_protovsn_bothends();
4479 my ($icmd,$iargs) = initiator_expect {
4480 m/^(\S+)(?: (.*))?$/;
4483 i_method "i_resp", $icmd, $iargs;
4487 sub i_resp_progress ($) {
4489 my $msg = protocol_read_bytes \*RO, $rhs;
4493 sub i_resp_supplementary_message ($) {
4495 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4498 sub i_resp_complete {
4499 my $pid = $i_child_pid;
4500 $i_child_pid = undef; # prevents killing some other process with same pid
4501 printdebug "waiting for build host child $pid...\n";
4502 my $got = waitpid $pid, 0;
4503 die $! unless $got == $pid;
4504 die "build host child failed $?" if $?;
4507 printdebug "all done\n";
4511 sub i_resp_file ($) {
4513 my $localname = i_method "i_localname", $keyword;
4514 my $localpath = "$i_tmp/$localname";
4515 stat_exists $localpath and
4516 badproto \*RO, "file $keyword ($localpath) twice";
4517 protocol_receive_file \*RO, $localpath;
4518 i_method "i_file", $keyword;
4523 sub i_resp_param ($) {
4524 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4528 sub i_resp_previously ($) {
4529 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4530 or badproto \*RO, "bad previously spec";
4531 my $r = system qw(git check-ref-format), $1;
4532 die "bad previously ref spec ($r)" if $r;
4533 $previously{$1} = $2;
4538 sub i_resp_want ($) {
4540 die "$keyword ?" if $i_wanted{$keyword}++;
4541 my @localpaths = i_method "i_want", $keyword;
4542 printdebug "[[ $keyword @localpaths\n";
4543 foreach my $localpath (@localpaths) {
4544 protocol_send_file \*RI, $localpath;
4546 print RI "files-end\n" or die $!;
4549 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4551 sub i_localname_parsed_changelog {
4552 return "remote-changelog.822";
4554 sub i_file_parsed_changelog {
4555 ($i_clogp, $i_version, $i_dscfn) =
4556 push_parse_changelog "$i_tmp/remote-changelog.822";
4557 die if $i_dscfn =~ m#/|^\W#;
4560 sub i_localname_dsc {
4561 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4566 sub i_localname_changes {
4567 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4568 $i_changesfn = $i_dscfn;
4569 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4570 return $i_changesfn;
4572 sub i_file_changes { }
4574 sub i_want_signed_tag {
4575 printdebug Dumper(\%i_param, $i_dscfn);
4576 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4577 && defined $i_param{'csuite'}
4578 or badproto \*RO, "premature desire for signed-tag";
4579 my $head = $i_param{'head'};
4580 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4582 my $maintview = $i_param{'maint-view'};
4583 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4586 if ($protovsn >= 4) {
4587 my $p = $i_param{'tagformat'} // '<undef>';
4589 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4592 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4594 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4596 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4599 push_mktags $i_clogp, $i_dscfn,
4600 $i_changesfn, 'remote changes',
4604 sub i_want_signed_dsc_changes {
4605 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4606 sign_changes $i_changesfn;
4607 return ($i_dscfn, $i_changesfn);
4610 #---------- building etc. ----------
4616 #----- `3.0 (quilt)' handling -----
4618 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4620 sub quiltify_dpkg_commit ($$$;$) {
4621 my ($patchname,$author,$msg, $xinfo) = @_;
4625 my $descfn = ".git/dgit/quilt-description.tmp";
4626 open O, '>', $descfn or die "$descfn: $!";
4627 $msg =~ s/\n+/\n\n/;
4628 print O <<END or die $!;
4630 ${xinfo}Subject: $msg
4637 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4638 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4639 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4640 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4644 sub quiltify_trees_differ ($$;$$$) {
4645 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4646 # returns true iff the two tree objects differ other than in debian/
4647 # with $finegrained,
4648 # returns bitmask 01 - differ in upstream files except .gitignore
4649 # 02 - differ in .gitignore
4650 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4651 # is set for each modified .gitignore filename $fn
4652 # if $unrepres is defined, array ref to which is appeneded
4653 # a list of unrepresentable changes (removals of upstream files
4656 my @cmd = (@git, qw(diff-tree -z));
4657 push @cmd, qw(--name-only) unless $unrepres;
4658 push @cmd, qw(-r) if $finegrained || $unrepres;
4660 my $diffs= cmdoutput @cmd;
4663 foreach my $f (split /\0/, $diffs) {
4664 if ($unrepres && !@lmodes) {
4665 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4668 my ($oldmode,$newmode) = @lmodes;
4671 next if $f =~ m#^debian(?:/.*)?$#s;
4675 die "not a plain file\n"
4676 unless $newmode =~ m/^10\d{4}$/ ||
4677 $oldmode =~ m/^10\d{4}$/;
4678 if ($oldmode =~ m/[^0]/ &&
4679 $newmode =~ m/[^0]/) {
4680 die "mode changed\n" if $oldmode ne $newmode;
4682 die "non-default mode\n"
4683 unless $newmode =~ m/^100644$/ ||
4684 $oldmode =~ m/^100644$/;
4688 local $/="\n"; chomp $@;
4689 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4693 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4694 $r |= $isignore ? 02 : 01;
4695 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4697 printdebug "quiltify_trees_differ $x $y => $r\n";
4701 sub quiltify_tree_sentinelfiles ($) {
4702 # lists the `sentinel' files present in the tree
4704 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4705 qw(-- debian/rules debian/control);
4710 sub quiltify_splitbrain_needed () {
4711 if (!$split_brain) {
4712 progress "dgit view: changes are required...";
4713 runcmd @git, qw(checkout -q -b dgit-view);
4718 sub quiltify_splitbrain ($$$$$$) {
4719 my ($clogp, $unapplied, $headref, $diffbits,
4720 $editedignores, $cachekey) = @_;
4721 if ($quilt_mode !~ m/gbp|dpm/) {
4722 # treat .gitignore just like any other upstream file
4723 $diffbits = { %$diffbits };
4724 $_ = !!$_ foreach values %$diffbits;
4726 # We would like any commits we generate to be reproducible
4727 my @authline = clogp_authline($clogp);
4728 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4729 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4730 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4731 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4732 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4733 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4735 if ($quilt_mode =~ m/gbp|unapplied/ &&
4736 ($diffbits->{O2H} & 01)) {
4738 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4739 " but git tree differs from orig in upstream files.";
4740 if (!stat_exists "debian/patches") {
4742 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4746 if ($quilt_mode =~ m/dpm/ &&
4747 ($diffbits->{H2A} & 01)) {
4749 --quilt=$quilt_mode specified, implying patches-applied git tree
4750 but git tree differs from result of applying debian/patches to upstream
4753 if ($quilt_mode =~ m/gbp|unapplied/ &&
4754 ($diffbits->{O2A} & 01)) { # some patches
4755 quiltify_splitbrain_needed();
4756 progress "dgit view: creating patches-applied version using gbp pq";
4757 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4758 # gbp pq import creates a fresh branch; push back to dgit-view
4759 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4760 runcmd @git, qw(checkout -q dgit-view);
4762 if ($quilt_mode =~ m/gbp|dpm/ &&
4763 ($diffbits->{O2A} & 02)) {
4765 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4766 tool which does not create patches for changes to upstream
4767 .gitignores: but, such patches exist in debian/patches.
4770 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4771 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4772 quiltify_splitbrain_needed();
4773 progress "dgit view: creating patch to represent .gitignore changes";
4774 ensuredir "debian/patches";
4775 my $gipatch = "debian/patches/auto-gitignore";
4776 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4777 stat GIPATCH or die "$gipatch: $!";
4778 fail "$gipatch already exists; but want to create it".
4779 " to record .gitignore changes" if (stat _)[7];
4780 print GIPATCH <<END or die "$gipatch: $!";
4781 Subject: Update .gitignore from Debian packaging branch
4783 The Debian packaging git branch contains these updates to the upstream
4784 .gitignore file(s). This patch is autogenerated, to provide these
4785 updates to users of the official Debian archive view of the package.
4787 [dgit ($our_version) update-gitignore]
4790 close GIPATCH or die "$gipatch: $!";
4791 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4792 $unapplied, $headref, "--", sort keys %$editedignores;
4793 open SERIES, "+>>", "debian/patches/series" or die $!;
4794 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4796 defined read SERIES, $newline, 1 or die $!;
4797 print SERIES "\n" or die $! unless $newline eq "\n";
4798 print SERIES "auto-gitignore\n" or die $!;
4799 close SERIES or die $!;
4800 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4802 Commit patch to update .gitignore
4804 [dgit ($our_version) update-gitignore-quilt-fixup]
4808 my $dgitview = git_rev_parse 'HEAD';
4810 changedir '../../../..';
4811 # When we no longer need to support squeeze, use --create-reflog
4813 ensuredir ".git/logs/refs/dgit-intern";
4814 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4817 my $oldcache = git_get_ref "refs/$splitbraincache";
4818 if ($oldcache eq $dgitview) {
4819 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4820 # git update-ref doesn't always update, in this case. *sigh*
4821 my $dummy = make_commit_text <<END;
4824 author Dgit <dgit\@example.com> 1000000000 +0000
4825 committer Dgit <dgit\@example.com> 1000000000 +0000
4827 Dummy commit - do not use
4829 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4830 "refs/$splitbraincache", $dummy;
4832 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4835 changedir '.git/dgit/unpack/work';
4837 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4838 progress "dgit view: created ($saved)";
4841 sub quiltify ($$$$) {
4842 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4844 # Quilt patchification algorithm
4846 # We search backwards through the history of the main tree's HEAD
4847 # (T) looking for a start commit S whose tree object is identical
4848 # to to the patch tip tree (ie the tree corresponding to the
4849 # current dpkg-committed patch series). For these purposes
4850 # `identical' disregards anything in debian/ - this wrinkle is
4851 # necessary because dpkg-source treates debian/ specially.
4853 # We can only traverse edges where at most one of the ancestors'
4854 # trees differs (in changes outside in debian/). And we cannot
4855 # handle edges which change .pc/ or debian/patches. To avoid
4856 # going down a rathole we avoid traversing edges which introduce
4857 # debian/rules or debian/control. And we set a limit on the
4858 # number of edges we are willing to look at.
4860 # If we succeed, we walk forwards again. For each traversed edge
4861 # PC (with P parent, C child) (starting with P=S and ending with
4862 # C=T) to we do this:
4864 # - dpkg-source --commit with a patch name and message derived from C
4865 # After traversing PT, we git commit the changes which
4866 # should be contained within debian/patches.
4868 # The search for the path S..T is breadth-first. We maintain a
4869 # todo list containing search nodes. A search node identifies a
4870 # commit, and looks something like this:
4872 # Commit => $git_commit_id,
4873 # Child => $c, # or undef if P=T
4874 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4875 # Nontrivial => true iff $p..$c has relevant changes
4882 my %considered; # saves being exponential on some weird graphs
4884 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4887 my ($search,$whynot) = @_;
4888 printdebug " search NOT $search->{Commit} $whynot\n";
4889 $search->{Whynot} = $whynot;
4890 push @nots, $search;
4891 no warnings qw(exiting);
4900 my $c = shift @todo;
4901 next if $considered{$c->{Commit}}++;
4903 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4905 printdebug "quiltify investigate $c->{Commit}\n";
4908 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4909 printdebug " search finished hooray!\n";
4914 if ($quilt_mode eq 'nofix') {
4915 fail "quilt fixup required but quilt mode is \`nofix'\n".
4916 "HEAD commit $c->{Commit} differs from tree implied by ".
4917 " debian/patches (tree object $oldtiptree)";
4919 if ($quilt_mode eq 'smash') {
4920 printdebug " search quitting smash\n";
4924 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4925 $not->($c, "has $c_sentinels not $t_sentinels")
4926 if $c_sentinels ne $t_sentinels;
4928 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4929 $commitdata =~ m/\n\n/;
4931 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4932 @parents = map { { Commit => $_, Child => $c } } @parents;
4934 $not->($c, "root commit") if !@parents;
4936 foreach my $p (@parents) {
4937 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4939 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4940 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4942 foreach my $p (@parents) {
4943 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4945 my @cmd= (@git, qw(diff-tree -r --name-only),
4946 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4947 my $patchstackchange = cmdoutput @cmd;
4948 if (length $patchstackchange) {
4949 $patchstackchange =~ s/\n/,/g;
4950 $not->($p, "changed $patchstackchange");
4953 printdebug " search queue P=$p->{Commit} ",
4954 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4960 printdebug "quiltify want to smash\n";
4963 my $x = $_[0]{Commit};
4964 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4967 my $reportnot = sub {
4969 my $s = $abbrev->($notp);
4970 my $c = $notp->{Child};
4971 $s .= "..".$abbrev->($c) if $c;
4972 $s .= ": ".$notp->{Whynot};
4975 if ($quilt_mode eq 'linear') {
4976 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4977 foreach my $notp (@nots) {
4978 print STDERR "$us: ", $reportnot->($notp), "\n";
4980 print STDERR "$us: $_\n" foreach @$failsuggestion;
4981 fail "quilt fixup naive history linearisation failed.\n".
4982 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4983 } elsif ($quilt_mode eq 'smash') {
4984 } elsif ($quilt_mode eq 'auto') {
4985 progress "quilt fixup cannot be linear, smashing...";
4987 die "$quilt_mode ?";
4990 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4991 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4993 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4995 quiltify_dpkg_commit "auto-$version-$target-$time",
4996 (getfield $clogp, 'Maintainer'),
4997 "Automatically generated patch ($clogp->{Version})\n".
4998 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5002 progress "quiltify linearisation planning successful, executing...";
5004 for (my $p = $sref_S;
5005 my $c = $p->{Child};
5007 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5008 next unless $p->{Nontrivial};
5010 my $cc = $c->{Commit};
5012 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5013 $commitdata =~ m/\n\n/ or die "$c ?";
5016 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5019 my $commitdate = cmdoutput
5020 @git, qw(log -n1 --pretty=format:%aD), $cc;
5022 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5024 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5031 my $gbp_check_suitable = sub {
5036 die "contains unexpected slashes\n" if m{//} || m{/$};
5037 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5038 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5039 die "too long" if length > 200;
5041 return $_ unless $@;
5042 print STDERR "quiltifying commit $cc:".
5043 " ignoring/dropping Gbp-Pq $what: $@";
5047 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5049 (\S+) \s* \n //ixm) {
5050 $patchname = $gbp_check_suitable->($1, 'Name');
5052 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5054 (\S+) \s* \n //ixm) {
5055 $patchdir = $gbp_check_suitable->($1, 'Topic');
5060 if (!defined $patchname) {
5061 $patchname = $title;
5062 $patchname =~ s/[.:]$//;
5065 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5066 my $translitname = $converter->convert($patchname);
5067 die unless defined $translitname;
5068 $patchname = $translitname;
5071 "dgit: patch title transliteration error: $@"
5073 $patchname =~ y/ A-Z/-a-z/;
5074 $patchname =~ y/-a-z0-9_.+=~//cd;
5075 $patchname =~ s/^\W/x-$&/;
5076 $patchname = substr($patchname,0,40);
5078 if (!defined $patchdir) {
5081 if (length $patchdir) {
5082 $patchname = "$patchdir/$patchname";
5084 if ($patchname =~ m{^(.*)/}) {
5085 mkpath "debian/patches/$1";
5090 stat "debian/patches/$patchname$index";
5092 $!==ENOENT or die "$patchname$index $!";
5094 runcmd @git, qw(checkout -q), $cc;
5096 # We use the tip's changelog so that dpkg-source doesn't
5097 # produce complaining messages from dpkg-parsechangelog. None
5098 # of the information dpkg-source gets from the changelog is
5099 # actually relevant - it gets put into the original message
5100 # which dpkg-source provides our stunt editor, and then
5102 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5104 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5105 "Date: $commitdate\n".
5106 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5108 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5111 runcmd @git, qw(checkout -q master);
5114 sub build_maybe_quilt_fixup () {
5115 my ($format,$fopts) = get_source_format;
5116 return unless madformat_wantfixup $format;
5119 check_for_vendor_patches();
5121 if (quiltmode_splitbrain) {
5122 fail <<END unless access_cfg_tagformats_can_splitbrain;
5123 quilt mode $quilt_mode requires split view so server needs to support
5124 both "new" and "maint" tag formats, but config says it doesn't.
5128 my $clogp = parsechangelog();
5129 my $headref = git_rev_parse('HEAD');
5134 my $upstreamversion = upstreamversion $version;
5136 if ($fopts->{'single-debian-patch'}) {
5137 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5139 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5142 die 'bug' if $split_brain && !$need_split_build_invocation;
5144 changedir '../../../..';
5145 runcmd_ordryrun_local
5146 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5149 sub quilt_fixup_mkwork ($) {
5152 mkdir "work" or die $!;
5154 mktree_in_ud_here();
5155 runcmd @git, qw(reset -q --hard), $headref;
5158 sub quilt_fixup_linkorigs ($$) {
5159 my ($upstreamversion, $fn) = @_;
5160 # calls $fn->($leafname);
5162 foreach my $f (<../../../../*>) { #/){
5163 my $b=$f; $b =~ s{.*/}{};
5165 local ($debuglevel) = $debuglevel-1;
5166 printdebug "QF linkorigs $b, $f ?\n";
5168 next unless is_orig_file_of_vsn $b, $upstreamversion;
5169 printdebug "QF linkorigs $b, $f Y\n";
5170 link_ltarget $f, $b or die "$b $!";
5175 sub quilt_fixup_delete_pc () {
5176 runcmd @git, qw(rm -rqf .pc);
5178 Commit removal of .pc (quilt series tracking data)
5180 [dgit ($our_version) upgrade quilt-remove-pc]
5184 sub quilt_fixup_singlepatch ($$$) {
5185 my ($clogp, $headref, $upstreamversion) = @_;
5187 progress "starting quiltify (single-debian-patch)";
5189 # dpkg-source --commit generates new patches even if
5190 # single-debian-patch is in debian/source/options. In order to
5191 # get it to generate debian/patches/debian-changes, it is
5192 # necessary to build the source package.
5194 quilt_fixup_linkorigs($upstreamversion, sub { });
5195 quilt_fixup_mkwork($headref);
5197 rmtree("debian/patches");
5199 runcmd @dpkgsource, qw(-b .);
5201 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5202 rename srcfn("$upstreamversion", "/debian/patches"),
5203 "work/debian/patches";
5206 commit_quilty_patch();
5209 sub quilt_make_fake_dsc ($) {
5210 my ($upstreamversion) = @_;
5212 my $fakeversion="$upstreamversion-~~DGITFAKE";
5214 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5215 print $fakedsc <<END or die $!;
5218 Version: $fakeversion
5222 my $dscaddfile=sub {
5225 my $md = new Digest::MD5;
5227 my $fh = new IO::File $b, '<' or die "$b $!";
5232 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5235 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5237 my @files=qw(debian/source/format debian/rules
5238 debian/control debian/changelog);
5239 foreach my $maybe (qw(debian/patches debian/source/options
5240 debian/tests/control)) {
5241 next unless stat_exists "../../../$maybe";
5242 push @files, $maybe;
5245 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5246 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5248 $dscaddfile->($debtar);
5249 close $fakedsc or die $!;
5252 sub quilt_check_splitbrain_cache ($$) {
5253 my ($headref, $upstreamversion) = @_;
5254 # Called only if we are in (potentially) split brain mode.
5256 # Computes the cache key and looks in the cache.
5257 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5259 my $splitbrain_cachekey;
5262 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5263 # we look in the reflog of dgit-intern/quilt-cache
5264 # we look for an entry whose message is the key for the cache lookup
5265 my @cachekey = (qw(dgit), $our_version);
5266 push @cachekey, $upstreamversion;
5267 push @cachekey, $quilt_mode;
5268 push @cachekey, $headref;
5270 push @cachekey, hashfile('fake.dsc');
5272 my $srcshash = Digest::SHA->new(256);
5273 my %sfs = ( %INC, '$0(dgit)' => $0 );
5274 foreach my $sfk (sort keys %sfs) {
5275 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5276 $srcshash->add($sfk," ");
5277 $srcshash->add(hashfile($sfs{$sfk}));
5278 $srcshash->add("\n");
5280 push @cachekey, $srcshash->hexdigest();
5281 $splitbrain_cachekey = "@cachekey";
5283 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5285 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5286 debugcmd "|(probably)",@cmd;
5287 my $child = open GC, "-|"; defined $child or die $!;
5289 chdir '../../..' or die $!;
5290 if (!stat ".git/logs/refs/$splitbraincache") {
5291 $! == ENOENT or die $!;
5292 printdebug ">(no reflog)\n";
5299 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5300 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5303 quilt_fixup_mkwork($headref);
5304 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5305 if ($cachehit ne $headref) {
5306 progress "dgit view: found cached ($saved)";
5307 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5309 return ($cachehit, $splitbrain_cachekey);
5311 progress "dgit view: found cached, no changes required";
5312 return ($headref, $splitbrain_cachekey);
5314 die $! if GC->error;
5315 failedcmd unless close GC;
5317 printdebug "splitbrain cache miss\n";
5318 return (undef, $splitbrain_cachekey);
5321 sub quilt_fixup_multipatch ($$$) {
5322 my ($clogp, $headref, $upstreamversion) = @_;
5324 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5327 # - honour any existing .pc in case it has any strangeness
5328 # - determine the git commit corresponding to the tip of
5329 # the patch stack (if there is one)
5330 # - if there is such a git commit, convert each subsequent
5331 # git commit into a quilt patch with dpkg-source --commit
5332 # - otherwise convert all the differences in the tree into
5333 # a single git commit
5337 # Our git tree doesn't necessarily contain .pc. (Some versions of
5338 # dgit would include the .pc in the git tree.) If there isn't
5339 # one, we need to generate one by unpacking the patches that we
5342 # We first look for a .pc in the git tree. If there is one, we
5343 # will use it. (This is not the normal case.)
5345 # Otherwise need to regenerate .pc so that dpkg-source --commit
5346 # can work. We do this as follows:
5347 # 1. Collect all relevant .orig from parent directory
5348 # 2. Generate a debian.tar.gz out of
5349 # debian/{patches,rules,source/format,source/options}
5350 # 3. Generate a fake .dsc containing just these fields:
5351 # Format Source Version Files
5352 # 4. Extract the fake .dsc
5353 # Now the fake .dsc has a .pc directory.
5354 # (In fact we do this in every case, because in future we will
5355 # want to search for a good base commit for generating patches.)
5357 # Then we can actually do the dpkg-source --commit
5358 # 1. Make a new working tree with the same object
5359 # store as our main tree and check out the main
5361 # 2. Copy .pc from the fake's extraction, if necessary
5362 # 3. Run dpkg-source --commit
5363 # 4. If the result has changes to debian/, then
5364 # - git add them them
5365 # - git add .pc if we had a .pc in-tree
5367 # 5. If we had a .pc in-tree, delete it, and git commit
5368 # 6. Back in the main tree, fast forward to the new HEAD
5370 # Another situation we may have to cope with is gbp-style
5371 # patches-unapplied trees.
5373 # We would want to detect these, so we know to escape into
5374 # quilt_fixup_gbp. However, this is in general not possible.
5375 # Consider a package with a one patch which the dgit user reverts
5376 # (with git revert or the moral equivalent).
5378 # That is indistinguishable in contents from a patches-unapplied
5379 # tree. And looking at the history to distinguish them is not
5380 # useful because the user might have made a confusing-looking git
5381 # history structure (which ought to produce an error if dgit can't
5382 # cope, not a silent reintroduction of an unwanted patch).
5384 # So gbp users will have to pass an option. But we can usually
5385 # detect their failure to do so: if the tree is not a clean
5386 # patches-applied tree, quilt linearisation fails, but the tree
5387 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5388 # they want --quilt=unapplied.
5390 # To help detect this, when we are extracting the fake dsc, we
5391 # first extract it with --skip-patches, and then apply the patches
5392 # afterwards with dpkg-source --before-build. That lets us save a
5393 # tree object corresponding to .origs.
5395 my $splitbrain_cachekey;
5397 quilt_make_fake_dsc($upstreamversion);
5399 if (quiltmode_splitbrain()) {
5401 ($cachehit, $splitbrain_cachekey) =
5402 quilt_check_splitbrain_cache($headref, $upstreamversion);
5403 return if $cachehit;
5407 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5409 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5410 rename $fakexdir, "fake" or die "$fakexdir $!";
5414 remove_stray_gits("source package");
5415 mktree_in_ud_here();
5419 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5420 my $unapplied=git_add_write_tree();
5421 printdebug "fake orig tree object $unapplied\n";
5425 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5427 if (system @bbcmd) {
5428 failedcmd @bbcmd if $? < 0;
5430 failed to apply your git tree's patch stack (from debian/patches/) to
5431 the corresponding upstream tarball(s). Your source tree and .orig
5432 are probably too inconsistent. dgit can only fix up certain kinds of
5433 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5439 quilt_fixup_mkwork($headref);
5442 if (stat_exists ".pc") {
5444 progress "Tree already contains .pc - will use it then delete it.";
5447 rename '../fake/.pc','.pc' or die $!;
5450 changedir '../fake';
5452 my $oldtiptree=git_add_write_tree();
5453 printdebug "fake o+d/p tree object $unapplied\n";
5454 changedir '../work';
5457 # We calculate some guesswork now about what kind of tree this might
5458 # be. This is mostly for error reporting.
5464 # O = orig, without patches applied
5465 # A = "applied", ie orig with H's debian/patches applied
5466 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5467 \%editedignores, \@unrepres),
5468 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5469 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5473 foreach my $b (qw(01 02)) {
5474 foreach my $v (qw(O2H O2A H2A)) {
5475 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5478 printdebug "differences \@dl @dl.\n";
5481 "$us: base trees orig=%.20s o+d/p=%.20s",
5482 $unapplied, $oldtiptree;
5484 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5485 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5486 $dl[0], $dl[1], $dl[3], $dl[4],
5490 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5492 forceable_fail [qw(unrepresentable)], <<END;
5493 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5498 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5499 push @failsuggestion, "This might be a patches-unapplied branch.";
5500 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5501 push @failsuggestion, "This might be a patches-applied branch.";
5503 push @failsuggestion, "Maybe you need to specify one of".
5504 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5506 if (quiltmode_splitbrain()) {
5507 quiltify_splitbrain($clogp, $unapplied, $headref,
5508 $diffbits, \%editedignores,
5509 $splitbrain_cachekey);
5513 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5514 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5516 if (!open P, '>>', ".pc/applied-patches") {
5517 $!==&ENOENT or die $!;
5522 commit_quilty_patch();
5524 if ($mustdeletepc) {
5525 quilt_fixup_delete_pc();
5529 sub quilt_fixup_editor () {
5530 my $descfn = $ENV{$fakeeditorenv};
5531 my $editing = $ARGV[$#ARGV];
5532 open I1, '<', $descfn or die "$descfn: $!";
5533 open I2, '<', $editing or die "$editing: $!";
5534 unlink $editing or die "$editing: $!";
5535 open O, '>', $editing or die "$editing: $!";
5536 while (<I1>) { print O or die $!; } I1->error and die $!;
5539 $copying ||= m/^\-\-\- /;
5540 next unless $copying;
5543 I2->error and die $!;
5548 sub maybe_apply_patches_dirtily () {
5549 return unless $quilt_mode =~ m/gbp|unapplied/;
5550 print STDERR <<END or die $!;
5552 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5553 dgit: Have to apply the patches - making the tree dirty.
5554 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5557 $patches_applied_dirtily = 01;
5558 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5559 runcmd qw(dpkg-source --before-build .);
5562 sub maybe_unapply_patches_again () {
5563 progress "dgit: Unapplying patches again to tidy up the tree."
5564 if $patches_applied_dirtily;
5565 runcmd qw(dpkg-source --after-build .)
5566 if $patches_applied_dirtily & 01;
5568 if $patches_applied_dirtily & 02;
5569 $patches_applied_dirtily = 0;
5572 #----- other building -----
5574 our $clean_using_builder;
5575 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5576 # clean the tree before building (perhaps invoked indirectly by
5577 # whatever we are using to run the build), rather than separately
5578 # and explicitly by us.
5581 return if $clean_using_builder;
5582 if ($cleanmode eq 'dpkg-source') {
5583 maybe_apply_patches_dirtily();
5584 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5585 } elsif ($cleanmode eq 'dpkg-source-d') {
5586 maybe_apply_patches_dirtily();
5587 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5588 } elsif ($cleanmode eq 'git') {
5589 runcmd_ordryrun_local @git, qw(clean -xdf);
5590 } elsif ($cleanmode eq 'git-ff') {
5591 runcmd_ordryrun_local @git, qw(clean -xdff);
5592 } elsif ($cleanmode eq 'check') {
5593 my $leftovers = cmdoutput @git, qw(clean -xdn);
5594 if (length $leftovers) {
5595 print STDERR $leftovers, "\n" or die $!;
5596 fail "tree contains uncommitted files and --clean=check specified";
5598 } elsif ($cleanmode eq 'none') {
5605 badusage "clean takes no additional arguments" if @ARGV;
5608 maybe_unapply_patches_again();
5611 sub build_prep_early () {
5612 our $build_prep_early_done //= 0;
5613 return if $build_prep_early_done++;
5615 badusage "-p is not allowed when building" if defined $package;
5616 my $clogp = parsechangelog();
5617 $isuite = getfield $clogp, 'Distribution';
5618 $package = getfield $clogp, 'Source';
5619 $version = getfield $clogp, 'Version';
5626 build_maybe_quilt_fixup();
5628 my $pat = changespat $version;
5629 foreach my $f (glob "$buildproductsdir/$pat") {
5631 unlink $f or fail "remove old changes file $f: $!";
5633 progress "would remove $f";
5639 sub changesopts_initial () {
5640 my @opts =@changesopts[1..$#changesopts];
5643 sub changesopts_version () {
5644 if (!defined $changes_since_version) {
5645 my @vsns = archive_query('archive_query');
5646 my @quirk = access_quirk();
5647 if ($quirk[0] eq 'backports') {
5648 local $isuite = $quirk[2];
5650 canonicalise_suite();
5651 push @vsns, archive_query('archive_query');
5654 @vsns = map { $_->[0] } @vsns;
5655 @vsns = sort { -version_compare($a, $b) } @vsns;
5656 $changes_since_version = $vsns[0];
5657 progress "changelog will contain changes since $vsns[0]";
5659 $changes_since_version = '_';
5660 progress "package seems new, not specifying -v<version>";
5663 if ($changes_since_version ne '_') {
5664 return ("-v$changes_since_version");
5670 sub changesopts () {
5671 return (changesopts_initial(), changesopts_version());
5674 sub massage_dbp_args ($;$) {
5675 my ($cmd,$xargs) = @_;
5678 # - if we're going to split the source build out so we can
5679 # do strange things to it, massage the arguments to dpkg-buildpackage
5680 # so that the main build doessn't build source (or add an argument
5681 # to stop it building source by default).
5683 # - add -nc to stop dpkg-source cleaning the source tree,
5684 # unless we're not doing a split build and want dpkg-source
5685 # as cleanmode, in which case we can do nothing
5688 # 0 - source will NOT need to be built separately by caller
5689 # +1 - source will need to be built separately by caller
5690 # +2 - source will need to be built separately by caller AND
5691 # dpkg-buildpackage should not in fact be run at all!
5692 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5693 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5694 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5695 $clean_using_builder = 1;
5698 # -nc has the side effect of specifying -b if nothing else specified
5699 # and some combinations of -S, -b, et al, are errors, rather than
5700 # later simply overriding earlie. So we need to:
5701 # - search the command line for these options
5702 # - pick the last one
5703 # - perhaps add our own as a default
5704 # - perhaps adjust it to the corresponding non-source-building version
5706 foreach my $l ($cmd, $xargs) {
5708 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5711 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5713 if ($need_split_build_invocation) {
5714 printdebug "massage split $dmode.\n";
5715 $r = $dmode =~ m/[S]/ ? +2 :
5716 $dmode =~ y/gGF/ABb/ ? +1 :
5717 $dmode =~ m/[ABb]/ ? 0 :
5720 printdebug "massage done $r $dmode.\n";
5722 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5728 my $wasdir = must_getcwd();
5734 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5735 my ($msg_if_onlyone) = @_;
5736 # If there is only one .changes file, fail with $msg_if_onlyone,
5737 # or if that is undef, be a no-op.
5738 # Returns the changes file to report to the user.
5739 my $pat = changespat $version;
5740 my @changesfiles = glob $pat;
5741 @changesfiles = sort {
5742 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5746 if (@changesfiles==1) {
5747 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5748 only one changes file from build (@changesfiles)
5750 $result = $changesfiles[0];
5751 } elsif (@changesfiles==2) {
5752 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5753 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5754 fail "$l found in binaries changes file $binchanges"
5757 runcmd_ordryrun_local @mergechanges, @changesfiles;
5758 my $multichanges = changespat $version,'multi';
5760 stat_exists $multichanges or fail "$multichanges: $!";
5761 foreach my $cf (glob $pat) {
5762 next if $cf eq $multichanges;
5763 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5766 $result = $multichanges;
5768 fail "wrong number of different changes files (@changesfiles)";
5770 printdone "build successful, results in $result\n" or die $!;
5773 sub midbuild_checkchanges () {
5774 my $pat = changespat $version;
5775 return if $rmchanges;
5776 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5777 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5779 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5780 Suggest you delete @unwanted.
5785 sub midbuild_checkchanges_vanilla ($) {
5787 midbuild_checkchanges() if $wantsrc == 1;
5790 sub postbuild_mergechanges_vanilla ($) {
5792 if ($wantsrc == 1) {
5794 postbuild_mergechanges(undef);
5797 printdone "build successful\n";
5803 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5804 my $wantsrc = massage_dbp_args \@dbp;
5807 midbuild_checkchanges_vanilla $wantsrc;
5812 push @dbp, changesopts_version();
5813 maybe_apply_patches_dirtily();
5814 runcmd_ordryrun_local @dbp;
5816 maybe_unapply_patches_again();
5817 postbuild_mergechanges_vanilla $wantsrc;
5821 $quilt_mode //= 'gbp';
5827 # gbp can make .origs out of thin air. In my tests it does this
5828 # even for a 1.0 format package, with no origs present. So I
5829 # guess it keys off just the version number. We don't know
5830 # exactly what .origs ought to exist, but let's assume that we
5831 # should run gbp if: the version has an upstream part and the main
5833 my $upstreamversion = upstreamversion $version;
5834 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5835 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5837 if ($gbp_make_orig) {
5839 $cleanmode = 'none'; # don't do it again
5840 $need_split_build_invocation = 1;
5843 my @dbp = @dpkgbuildpackage;
5845 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5847 if (!length $gbp_build[0]) {
5848 if (length executable_on_path('git-buildpackage')) {
5849 $gbp_build[0] = qw(git-buildpackage);
5851 $gbp_build[0] = 'gbp buildpackage';
5854 my @cmd = opts_opt_multi_cmd @gbp_build;
5856 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5858 if ($gbp_make_orig) {
5859 ensuredir '.git/dgit';
5860 my $ok = '.git/dgit/origs-gen-ok';
5861 unlink $ok or $!==&ENOENT or die $!;
5862 my @origs_cmd = @cmd;
5863 push @origs_cmd, qw(--git-cleaner=true);
5864 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5865 push @origs_cmd, @ARGV;
5867 debugcmd @origs_cmd;
5869 do { local $!; stat_exists $ok; }
5870 or failedcmd @origs_cmd;
5872 dryrun_report @origs_cmd;
5878 midbuild_checkchanges_vanilla $wantsrc;
5880 if (!$clean_using_builder) {
5881 push @cmd, '--git-cleaner=true';
5885 maybe_unapply_patches_again();
5887 push @cmd, changesopts();
5888 runcmd_ordryrun_local @cmd, @ARGV;
5890 postbuild_mergechanges_vanilla $wantsrc;
5892 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5896 my $our_cleanmode = $cleanmode;
5897 if ($need_split_build_invocation) {
5898 # Pretend that clean is being done some other way. This
5899 # forces us not to try to use dpkg-buildpackage to clean and
5900 # build source all in one go; and instead we run dpkg-source
5901 # (and build_prep() will do the clean since $clean_using_builder
5903 $our_cleanmode = 'ELSEWHERE';
5905 if ($our_cleanmode =~ m/^dpkg-source/) {
5906 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5907 $clean_using_builder = 1;
5910 $sourcechanges = changespat $version,'source';
5912 unlink "../$sourcechanges" or $!==ENOENT
5913 or fail "remove $sourcechanges: $!";
5915 $dscfn = dscfn($version);
5916 if ($our_cleanmode eq 'dpkg-source') {
5917 maybe_apply_patches_dirtily();
5918 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5920 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5921 maybe_apply_patches_dirtily();
5922 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5925 my @cmd = (@dpkgsource, qw(-b --));
5928 runcmd_ordryrun_local @cmd, "work";
5929 my @udfiles = <${package}_*>;
5930 changedir "../../..";
5931 foreach my $f (@udfiles) {
5932 printdebug "source copy, found $f\n";
5935 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5936 $f eq srcfn($version, $&));
5937 printdebug "source copy, found $f - renaming\n";
5938 rename "$ud/$f", "../$f" or $!==ENOENT
5939 or fail "put in place new source file ($f): $!";
5942 my $pwd = must_getcwd();
5943 my $leafdir = basename $pwd;
5945 runcmd_ordryrun_local @cmd, $leafdir;
5948 runcmd_ordryrun_local qw(sh -ec),
5949 'exec >$1; shift; exec "$@"','x',
5950 "../$sourcechanges",
5951 @dpkggenchanges, qw(-S), changesopts();
5955 sub cmd_build_source {
5957 badusage "build-source takes no additional arguments" if @ARGV;
5959 maybe_unapply_patches_again();
5960 printdone "source built, results in $dscfn and $sourcechanges";
5965 midbuild_checkchanges();
5968 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5969 stat_exists $sourcechanges
5970 or fail "$sourcechanges (in parent directory): $!";
5972 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5974 maybe_unapply_patches_again();
5976 postbuild_mergechanges(<<END);
5977 perhaps you need to pass -A ? (sbuild's default is to build only
5978 arch-specific binaries; dgit 1.4 used to override that.)
5983 sub cmd_quilt_fixup {
5984 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5987 build_maybe_quilt_fixup();
5990 sub cmd_import_dsc {
5994 last unless $ARGV[0] =~ m/^-/;
5997 if (m/^--require-valid-signature$/) {
6000 badusage "unknown dgit import-dsc sub-option \`$_'";
6004 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6005 my ($dscfn, $dstbranch) = @ARGV;
6007 badusage "dry run makes no sense with import-dsc" unless act_local();
6009 my $force = $dstbranch =~ s/^\+// ? +1 :
6010 $dstbranch =~ s/^\.\.// ? -1 :
6012 my $info = $force ? " $&" : '';
6013 $info = "$dscfn$info";
6015 my $specbranch = $dstbranch;
6016 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6017 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6019 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6020 my $chead = cmdoutput_errok @symcmd;
6021 defined $chead or $?==256 or failedcmd @symcmd;
6023 fail "$dstbranch is checked out - will not update it"
6024 if defined $chead and $chead eq $dstbranch;
6026 my $oldhash = git_get_ref $dstbranch;
6028 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6029 $dscdata = do { local $/ = undef; <D>; };
6030 D->error and fail "read $dscfn: $!";
6033 # we don't normally need this so import it here
6034 use Dpkg::Source::Package;
6035 my $dp = new Dpkg::Source::Package filename => $dscfn,
6036 require_valid_signature => $needsig;
6038 local $SIG{__WARN__} = sub {
6040 return unless $needsig;
6041 fail "import-dsc signature check failed";
6043 if (!$dp->is_signed()) {
6044 warn "$us: warning: importing unsigned .dsc\n";
6046 my $r = $dp->check_signature();
6047 die "->check_signature => $r" if $needsig && $r;
6053 $package = getfield $dsc, 'Source';
6055 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6056 unless forceing [qw(import-dsc-with-dgit-field)];
6058 if (defined $dsc_hash) {
6059 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6060 resolve_dsc_field_commit undef, undef;
6062 if (defined $dsc_hash) {
6063 my @cmd = (qw(sh -ec),
6064 "echo $dsc_hash | git cat-file --batch-check");
6065 my $objgot = cmdoutput @cmd;
6066 if ($objgot =~ m#^\w+ missing\b#) {
6068 .dsc contains Dgit field referring to object $dsc_hash
6069 Your git tree does not have that object. Try `git fetch' from a
6070 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6073 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6075 progress "Not fast forward, forced update.";
6077 fail "Not fast forward to $dsc_hash";
6080 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
6081 $dstbranch, $dsc_hash);
6083 progress "dgit: import-dsc updated git ref $dstbranch";
6088 Branch $dstbranch already exists
6089 Specify ..$specbranch for a pseudo-merge, binding in existing history
6090 Specify +$specbranch to overwrite, discarding existing history
6092 if $oldhash && !$force;
6094 my @dfi = dsc_files_info();
6095 foreach my $fi (@dfi) {
6096 my $f = $fi->{Filename};
6098 next if lstat $here;
6099 fail "stat $here: $!" unless $! == ENOENT;
6101 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6103 } elsif ($dscfn =~ m#^/#) {
6106 fail "cannot import $dscfn which seems to be inside working tree!";
6108 $there =~ s#/+[^/]+$## or
6109 fail "cannot import $dscfn which seems to not have a basename";
6111 symlink $there, $here or fail "symlink $there to $here: $!";
6112 progress "made symlink $here -> $there";
6113 # print STDERR Dumper($fi);
6115 my @mergeinputs = generate_commits_from_dsc();
6116 die unless @mergeinputs == 1;
6118 my $newhash = $mergeinputs[0]{Commit};
6122 progress "Import, forced update - synthetic orphan git history.";
6123 } elsif ($force < 0) {
6124 progress "Import, merging.";
6125 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6126 my $version = getfield $dsc, 'Version';
6127 my $clogp = commit_getclogp $newhash;
6128 my $authline = clogp_authline $clogp;
6129 $newhash = make_commit_text <<END;
6136 Merge $package ($version) import into $dstbranch
6139 die; # caught earlier
6143 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
6144 $dstbranch, $newhash);
6146 progress "dgit: import-dsc results are in in git ref $dstbranch";
6149 sub cmd_archive_api_query {
6150 badusage "need only 1 subpath argument" unless @ARGV==1;
6151 my ($subpath) = @ARGV;
6152 my @cmd = archive_api_query_cmd($subpath);
6155 exec @cmd or fail "exec curl: $!\n";
6158 sub cmd_clone_dgit_repos_server {
6159 badusage "need destination argument" unless @ARGV==1;
6160 my ($destdir) = @ARGV;
6161 $package = '_dgit-repos-server';
6162 local $access_forpush = 0;
6163 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6165 exec @cmd or fail "exec git clone: $!\n";
6168 sub cmd_print_dgit_repos_server_source_url {
6169 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6171 $package = '_dgit-repos-server';
6172 local $access_forpush = 0;
6173 my $url = access_giturl();
6174 print $url, "\n" or die $!;
6177 sub cmd_setup_mergechangelogs {
6178 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6179 setup_mergechangelogs(1);
6182 sub cmd_setup_useremail {
6183 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6187 sub cmd_setup_new_tree {
6188 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6192 #---------- argument parsing and main program ----------
6195 print "dgit version $our_version\n" or die $!;
6199 our (%valopts_long, %valopts_short);
6202 sub defvalopt ($$$$) {
6203 my ($long,$short,$val_re,$how) = @_;
6204 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6205 $valopts_long{$long} = $oi;
6206 $valopts_short{$short} = $oi;
6207 # $how subref should:
6208 # do whatever assignemnt or thing it likes with $_[0]
6209 # if the option should not be passed on to remote, @rvalopts=()
6210 # or $how can be a scalar ref, meaning simply assign the value
6213 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6214 defvalopt '--distro', '-d', '.+', \$idistro;
6215 defvalopt '', '-k', '.+', \$keyid;
6216 defvalopt '--existing-package','', '.*', \$existing_package;
6217 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6218 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6219 defvalopt '--package', '-p', $package_re, \$package;
6220 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6222 defvalopt '', '-C', '.+', sub {
6223 ($changesfile) = (@_);
6224 if ($changesfile =~ s#^(.*)/##) {
6225 $buildproductsdir = $1;
6229 defvalopt '--initiator-tempdir','','.*', sub {
6230 ($initiator_tempdir) = (@_);
6231 $initiator_tempdir =~ m#^/# or
6232 badusage "--initiator-tempdir must be used specify an".
6233 " absolute, not relative, directory."
6239 if (defined $ENV{'DGIT_SSH'}) {
6240 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6241 } elsif (defined $ENV{'GIT_SSH'}) {
6242 @ssh = ($ENV{'GIT_SSH'});
6250 if (!defined $val) {
6251 badusage "$what needs a value" unless @ARGV;
6253 push @rvalopts, $val;
6255 badusage "bad value \`$val' for $what" unless
6256 $val =~ m/^$oi->{Re}$(?!\n)/s;
6257 my $how = $oi->{How};
6258 if (ref($how) eq 'SCALAR') {
6263 push @ropts, @rvalopts;
6267 last unless $ARGV[0] =~ m/^-/;
6271 if (m/^--dry-run$/) {
6274 } elsif (m/^--damp-run$/) {
6277 } elsif (m/^--no-sign$/) {
6280 } elsif (m/^--help$/) {
6282 } elsif (m/^--version$/) {
6284 } elsif (m/^--new$/) {
6287 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6288 ($om = $opts_opt_map{$1}) &&
6292 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6293 !$opts_opt_cmdonly{$1} &&
6294 ($om = $opts_opt_map{$1})) {
6297 } elsif (m/^--(gbp|dpm)$/s) {
6298 push @ropts, "--quilt=$1";
6300 } elsif (m/^--ignore-dirty$/s) {
6303 } elsif (m/^--no-quilt-fixup$/s) {
6305 $quilt_mode = 'nocheck';
6306 } elsif (m/^--no-rm-on-error$/s) {
6309 } elsif (m/^--no-chase-dsc-distro$/s) {
6311 $chase_dsc_distro = 0;
6312 } elsif (m/^--overwrite$/s) {
6314 $overwrite_version = '';
6315 } elsif (m/^--overwrite=(.+)$/s) {
6317 $overwrite_version = $1;
6318 } elsif (m/^--dep14tag$/s) {
6320 $dodep14tag= 'want';
6321 } elsif (m/^--no-dep14tag$/s) {
6324 } elsif (m/^--always-dep14tag$/s) {
6326 $dodep14tag= 'always';
6327 } elsif (m/^--delayed=(\d+)$/s) {
6330 } elsif (m/^--dgit-view-save=(.+)$/s) {
6332 $split_brain_save = $1;
6333 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6334 } elsif (m/^--(no-)?rm-old-changes$/s) {
6337 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6339 push @deliberatelies, $&;
6340 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6344 } elsif (m/^--force-/) {
6346 "$us: warning: ignoring unknown force option $_\n";
6348 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6349 # undocumented, for testing
6351 $tagformat_want = [ $1, 'command line', 1 ];
6352 # 1 menas overrides distro configuration
6353 } elsif (m/^--always-split-source-build$/s) {
6354 # undocumented, for testing
6356 $need_split_build_invocation = 1;
6357 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6358 # undocumented, for testing
6360 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6361 # ^ it's supposed to be an array ref
6362 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6363 $val = $2 ? $' : undef; #';
6364 $valopt->($oi->{Long});
6366 badusage "unknown long option \`$_'";
6373 } elsif (s/^-L/-/) {
6376 } elsif (s/^-h/-/) {
6378 } elsif (s/^-D/-/) {
6382 } elsif (s/^-N/-/) {
6387 push @changesopts, $_;
6389 } elsif (s/^-wn$//s) {
6391 $cleanmode = 'none';
6392 } elsif (s/^-wg$//s) {
6395 } elsif (s/^-wgf$//s) {
6397 $cleanmode = 'git-ff';
6398 } elsif (s/^-wd$//s) {
6400 $cleanmode = 'dpkg-source';
6401 } elsif (s/^-wdd$//s) {
6403 $cleanmode = 'dpkg-source-d';
6404 } elsif (s/^-wc$//s) {
6406 $cleanmode = 'check';
6407 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6408 push @git, '-c', $&;
6409 $gitcfgs{cmdline}{$1} = [ $2 ];
6410 } elsif (s/^-c([^=]+)$//s) {
6411 push @git, '-c', $&;
6412 $gitcfgs{cmdline}{$1} = [ 'true' ];
6413 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6415 $val = undef unless length $val;
6416 $valopt->($oi->{Short});
6419 badusage "unknown short option \`$_'";
6426 sub check_env_sanity () {
6427 my $blocked = new POSIX::SigSet;
6428 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6431 foreach my $name (qw(PIPE CHLD)) {
6432 my $signame = "SIG$name";
6433 my $signum = eval "POSIX::$signame" // die;
6434 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6435 die "$signame is set to something other than SIG_DFL\n";
6436 $blocked->ismember($signum) and
6437 die "$signame is blocked\n";
6443 On entry to dgit, $@
6444 This is a bug produced by something in in your execution environment.
6450 sub parseopts_late_defaults () {
6451 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6452 if defined $idistro;
6453 $isuite //= cfg('dgit.default.default-suite');
6455 foreach my $k (keys %opts_opt_map) {
6456 my $om = $opts_opt_map{$k};
6458 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6460 badcfg "cannot set command for $k"
6461 unless length $om->[0];
6465 foreach my $c (access_cfg_cfgs("opts-$k")) {
6467 map { $_ ? @$_ : () }
6468 map { $gitcfgs{$_}{$c} }
6469 reverse @gitcfgsources;
6470 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6471 "\n" if $debuglevel >= 4;
6473 badcfg "cannot configure options for $k"
6474 if $opts_opt_cmdonly{$k};
6475 my $insertpos = $opts_cfg_insertpos{$k};
6476 @$om = ( @$om[0..$insertpos-1],
6478 @$om[$insertpos..$#$om] );
6482 if (!defined $rmchanges) {
6483 local $access_forpush;
6484 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6487 if (!defined $quilt_mode) {
6488 local $access_forpush;
6489 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6490 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6492 $quilt_mode =~ m/^($quilt_modes_re)$/
6493 or badcfg "unknown quilt-mode \`$quilt_mode'";
6497 if (!defined $dodep14tag) {
6498 local $access_forpush;
6499 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6500 $dodep14tag =~ m/^($dodep14tag_re)$/
6501 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6505 $need_split_build_invocation ||= quiltmode_splitbrain();
6507 if (!defined $cleanmode) {
6508 local $access_forpush;
6509 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6510 $cleanmode //= 'dpkg-source';
6512 badcfg "unknown clean-mode \`$cleanmode'" unless
6513 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6517 if ($ENV{$fakeeditorenv}) {
6519 quilt_fixup_editor();
6526 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6527 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6528 if $dryrun_level == 1;
6530 print STDERR $helpmsg or die $!;
6533 my $cmd = shift @ARGV;
6536 my $pre_fn = ${*::}{"pre_$cmd"};
6537 $pre_fn->() if $pre_fn;
6539 my $fn = ${*::}{"cmd_$cmd"};
6540 $fn or badusage "unknown operation $cmd";