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 $isuite = getfield $clogp, 'Distribution';
4304 } elsif (@ARGV==1) {
4307 badusage "incorrect arguments to dgit fetch or dgit pull";
4315 my $multi_fetched = fork_for_multisuite(sub { });
4316 exit 0 if $multi_fetched;
4323 if (quiltmode_splitbrain()) {
4324 my ($format, $fopts) = get_source_format();
4325 madformat($format) and fail <<END
4326 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4335 badusage "-p is not allowed with dgit push" if defined $package;
4337 my $clogp = parsechangelog();
4338 $package = getfield $clogp, 'Source';
4341 } elsif (@ARGV==1) {
4342 ($specsuite) = (@ARGV);
4344 badusage "incorrect arguments to dgit push";
4346 $isuite = getfield $clogp, 'Distribution';
4348 local ($package) = $existing_package; # this is a hack
4349 canonicalise_suite();
4351 canonicalise_suite();
4353 if (defined $specsuite &&
4354 $specsuite ne $isuite &&
4355 $specsuite ne $csuite) {
4356 fail "dgit push: changelog specifies $isuite ($csuite)".
4357 " but command line specifies $specsuite";
4362 #---------- remote commands' implementation ----------
4364 sub cmd_remote_push_build_host {
4365 my ($nrargs) = shift @ARGV;
4366 my (@rargs) = @ARGV[0..$nrargs-1];
4367 @ARGV = @ARGV[$nrargs..$#ARGV];
4369 my ($dir,$vsnwant) = @rargs;
4370 # vsnwant is a comma-separated list; we report which we have
4371 # chosen in our ready response (so other end can tell if they
4374 $we_are_responder = 1;
4375 $us .= " (build host)";
4379 open PI, "<&STDIN" or die $!;
4380 open STDIN, "/dev/null" or die $!;
4381 open PO, ">&STDOUT" or die $!;
4383 open STDOUT, ">&STDERR" or die $!;
4387 ($protovsn) = grep {
4388 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4389 } @rpushprotovsn_support;
4391 fail "build host has dgit rpush protocol versions ".
4392 (join ",", @rpushprotovsn_support).
4393 " but invocation host has $vsnwant"
4394 unless defined $protovsn;
4396 responder_send_command("dgit-remote-push-ready $protovsn");
4397 rpush_handle_protovsn_bothends();
4402 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4403 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4404 # a good error message)
4406 sub rpush_handle_protovsn_bothends () {
4407 if ($protovsn < 4) {
4408 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4417 my $report = i_child_report();
4418 if (defined $report) {
4419 printdebug "($report)\n";
4420 } elsif ($i_child_pid) {
4421 printdebug "(killing build host child $i_child_pid)\n";
4422 kill 15, $i_child_pid;
4424 if (defined $i_tmp && !defined $initiator_tempdir) {
4426 eval { rmtree $i_tmp; };
4430 END { i_cleanup(); }
4433 my ($base,$selector,@args) = @_;
4434 $selector =~ s/\-/_/g;
4435 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4442 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4450 push @rargs, join ",", @rpushprotovsn_support;
4453 push @rdgit, @ropts;
4454 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4456 my @cmd = (@ssh, $host, shellquote @rdgit);
4459 if (defined $initiator_tempdir) {
4460 rmtree $initiator_tempdir;
4461 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4462 $i_tmp = $initiator_tempdir;
4466 $i_child_pid = open2(\*RO, \*RI, @cmd);
4468 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4469 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4470 $supplementary_message = '' unless $protovsn >= 3;
4472 fail "rpush negotiated protocol version $protovsn".
4473 " which does not support quilt mode $quilt_mode"
4474 if quiltmode_splitbrain;
4476 rpush_handle_protovsn_bothends();
4478 my ($icmd,$iargs) = initiator_expect {
4479 m/^(\S+)(?: (.*))?$/;
4482 i_method "i_resp", $icmd, $iargs;
4486 sub i_resp_progress ($) {
4488 my $msg = protocol_read_bytes \*RO, $rhs;
4492 sub i_resp_supplementary_message ($) {
4494 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4497 sub i_resp_complete {
4498 my $pid = $i_child_pid;
4499 $i_child_pid = undef; # prevents killing some other process with same pid
4500 printdebug "waiting for build host child $pid...\n";
4501 my $got = waitpid $pid, 0;
4502 die $! unless $got == $pid;
4503 die "build host child failed $?" if $?;
4506 printdebug "all done\n";
4510 sub i_resp_file ($) {
4512 my $localname = i_method "i_localname", $keyword;
4513 my $localpath = "$i_tmp/$localname";
4514 stat_exists $localpath and
4515 badproto \*RO, "file $keyword ($localpath) twice";
4516 protocol_receive_file \*RO, $localpath;
4517 i_method "i_file", $keyword;
4522 sub i_resp_param ($) {
4523 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4527 sub i_resp_previously ($) {
4528 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4529 or badproto \*RO, "bad previously spec";
4530 my $r = system qw(git check-ref-format), $1;
4531 die "bad previously ref spec ($r)" if $r;
4532 $previously{$1} = $2;
4537 sub i_resp_want ($) {
4539 die "$keyword ?" if $i_wanted{$keyword}++;
4540 my @localpaths = i_method "i_want", $keyword;
4541 printdebug "[[ $keyword @localpaths\n";
4542 foreach my $localpath (@localpaths) {
4543 protocol_send_file \*RI, $localpath;
4545 print RI "files-end\n" or die $!;
4548 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4550 sub i_localname_parsed_changelog {
4551 return "remote-changelog.822";
4553 sub i_file_parsed_changelog {
4554 ($i_clogp, $i_version, $i_dscfn) =
4555 push_parse_changelog "$i_tmp/remote-changelog.822";
4556 die if $i_dscfn =~ m#/|^\W#;
4559 sub i_localname_dsc {
4560 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4565 sub i_localname_changes {
4566 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4567 $i_changesfn = $i_dscfn;
4568 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4569 return $i_changesfn;
4571 sub i_file_changes { }
4573 sub i_want_signed_tag {
4574 printdebug Dumper(\%i_param, $i_dscfn);
4575 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4576 && defined $i_param{'csuite'}
4577 or badproto \*RO, "premature desire for signed-tag";
4578 my $head = $i_param{'head'};
4579 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4581 my $maintview = $i_param{'maint-view'};
4582 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4585 if ($protovsn >= 4) {
4586 my $p = $i_param{'tagformat'} // '<undef>';
4588 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4591 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4593 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4595 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4598 push_mktags $i_clogp, $i_dscfn,
4599 $i_changesfn, 'remote changes',
4603 sub i_want_signed_dsc_changes {
4604 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4605 sign_changes $i_changesfn;
4606 return ($i_dscfn, $i_changesfn);
4609 #---------- building etc. ----------
4615 #----- `3.0 (quilt)' handling -----
4617 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4619 sub quiltify_dpkg_commit ($$$;$) {
4620 my ($patchname,$author,$msg, $xinfo) = @_;
4624 my $descfn = ".git/dgit/quilt-description.tmp";
4625 open O, '>', $descfn or die "$descfn: $!";
4626 $msg =~ s/\n+/\n\n/;
4627 print O <<END or die $!;
4629 ${xinfo}Subject: $msg
4636 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4637 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4638 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4639 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4643 sub quiltify_trees_differ ($$;$$$) {
4644 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4645 # returns true iff the two tree objects differ other than in debian/
4646 # with $finegrained,
4647 # returns bitmask 01 - differ in upstream files except .gitignore
4648 # 02 - differ in .gitignore
4649 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4650 # is set for each modified .gitignore filename $fn
4651 # if $unrepres is defined, array ref to which is appeneded
4652 # a list of unrepresentable changes (removals of upstream files
4655 my @cmd = (@git, qw(diff-tree -z));
4656 push @cmd, qw(--name-only) unless $unrepres;
4657 push @cmd, qw(-r) if $finegrained || $unrepres;
4659 my $diffs= cmdoutput @cmd;
4662 foreach my $f (split /\0/, $diffs) {
4663 if ($unrepres && !@lmodes) {
4664 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4667 my ($oldmode,$newmode) = @lmodes;
4670 next if $f =~ m#^debian(?:/.*)?$#s;
4674 die "not a plain file\n"
4675 unless $newmode =~ m/^10\d{4}$/ ||
4676 $oldmode =~ m/^10\d{4}$/;
4677 if ($oldmode =~ m/[^0]/ &&
4678 $newmode =~ m/[^0]/) {
4679 die "mode changed\n" if $oldmode ne $newmode;
4681 die "non-default mode\n"
4682 unless $newmode =~ m/^100644$/ ||
4683 $oldmode =~ m/^100644$/;
4687 local $/="\n"; chomp $@;
4688 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4692 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4693 $r |= $isignore ? 02 : 01;
4694 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4696 printdebug "quiltify_trees_differ $x $y => $r\n";
4700 sub quiltify_tree_sentinelfiles ($) {
4701 # lists the `sentinel' files present in the tree
4703 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4704 qw(-- debian/rules debian/control);
4709 sub quiltify_splitbrain_needed () {
4710 if (!$split_brain) {
4711 progress "dgit view: changes are required...";
4712 runcmd @git, qw(checkout -q -b dgit-view);
4717 sub quiltify_splitbrain ($$$$$$) {
4718 my ($clogp, $unapplied, $headref, $diffbits,
4719 $editedignores, $cachekey) = @_;
4720 if ($quilt_mode !~ m/gbp|dpm/) {
4721 # treat .gitignore just like any other upstream file
4722 $diffbits = { %$diffbits };
4723 $_ = !!$_ foreach values %$diffbits;
4725 # We would like any commits we generate to be reproducible
4726 my @authline = clogp_authline($clogp);
4727 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4728 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4729 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4730 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4731 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4732 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4734 if ($quilt_mode =~ m/gbp|unapplied/ &&
4735 ($diffbits->{O2H} & 01)) {
4737 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4738 " but git tree differs from orig in upstream files.";
4739 if (!stat_exists "debian/patches") {
4741 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4745 if ($quilt_mode =~ m/dpm/ &&
4746 ($diffbits->{H2A} & 01)) {
4748 --quilt=$quilt_mode specified, implying patches-applied git tree
4749 but git tree differs from result of applying debian/patches to upstream
4752 if ($quilt_mode =~ m/gbp|unapplied/ &&
4753 ($diffbits->{O2A} & 01)) { # some patches
4754 quiltify_splitbrain_needed();
4755 progress "dgit view: creating patches-applied version using gbp pq";
4756 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4757 # gbp pq import creates a fresh branch; push back to dgit-view
4758 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4759 runcmd @git, qw(checkout -q dgit-view);
4761 if ($quilt_mode =~ m/gbp|dpm/ &&
4762 ($diffbits->{O2A} & 02)) {
4764 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4765 tool which does not create patches for changes to upstream
4766 .gitignores: but, such patches exist in debian/patches.
4769 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4770 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4771 quiltify_splitbrain_needed();
4772 progress "dgit view: creating patch to represent .gitignore changes";
4773 ensuredir "debian/patches";
4774 my $gipatch = "debian/patches/auto-gitignore";
4775 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4776 stat GIPATCH or die "$gipatch: $!";
4777 fail "$gipatch already exists; but want to create it".
4778 " to record .gitignore changes" if (stat _)[7];
4779 print GIPATCH <<END or die "$gipatch: $!";
4780 Subject: Update .gitignore from Debian packaging branch
4782 The Debian packaging git branch contains these updates to the upstream
4783 .gitignore file(s). This patch is autogenerated, to provide these
4784 updates to users of the official Debian archive view of the package.
4786 [dgit ($our_version) update-gitignore]
4789 close GIPATCH or die "$gipatch: $!";
4790 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4791 $unapplied, $headref, "--", sort keys %$editedignores;
4792 open SERIES, "+>>", "debian/patches/series" or die $!;
4793 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4795 defined read SERIES, $newline, 1 or die $!;
4796 print SERIES "\n" or die $! unless $newline eq "\n";
4797 print SERIES "auto-gitignore\n" or die $!;
4798 close SERIES or die $!;
4799 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4801 Commit patch to update .gitignore
4803 [dgit ($our_version) update-gitignore-quilt-fixup]
4807 my $dgitview = git_rev_parse 'HEAD';
4809 changedir '../../../..';
4810 # When we no longer need to support squeeze, use --create-reflog
4812 ensuredir ".git/logs/refs/dgit-intern";
4813 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4816 my $oldcache = git_get_ref "refs/$splitbraincache";
4817 if ($oldcache eq $dgitview) {
4818 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4819 # git update-ref doesn't always update, in this case. *sigh*
4820 my $dummy = make_commit_text <<END;
4823 author Dgit <dgit\@example.com> 1000000000 +0000
4824 committer Dgit <dgit\@example.com> 1000000000 +0000
4826 Dummy commit - do not use
4828 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4829 "refs/$splitbraincache", $dummy;
4831 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4834 changedir '.git/dgit/unpack/work';
4836 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4837 progress "dgit view: created ($saved)";
4840 sub quiltify ($$$$) {
4841 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4843 # Quilt patchification algorithm
4845 # We search backwards through the history of the main tree's HEAD
4846 # (T) looking for a start commit S whose tree object is identical
4847 # to to the patch tip tree (ie the tree corresponding to the
4848 # current dpkg-committed patch series). For these purposes
4849 # `identical' disregards anything in debian/ - this wrinkle is
4850 # necessary because dpkg-source treates debian/ specially.
4852 # We can only traverse edges where at most one of the ancestors'
4853 # trees differs (in changes outside in debian/). And we cannot
4854 # handle edges which change .pc/ or debian/patches. To avoid
4855 # going down a rathole we avoid traversing edges which introduce
4856 # debian/rules or debian/control. And we set a limit on the
4857 # number of edges we are willing to look at.
4859 # If we succeed, we walk forwards again. For each traversed edge
4860 # PC (with P parent, C child) (starting with P=S and ending with
4861 # C=T) to we do this:
4863 # - dpkg-source --commit with a patch name and message derived from C
4864 # After traversing PT, we git commit the changes which
4865 # should be contained within debian/patches.
4867 # The search for the path S..T is breadth-first. We maintain a
4868 # todo list containing search nodes. A search node identifies a
4869 # commit, and looks something like this:
4871 # Commit => $git_commit_id,
4872 # Child => $c, # or undef if P=T
4873 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4874 # Nontrivial => true iff $p..$c has relevant changes
4881 my %considered; # saves being exponential on some weird graphs
4883 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4886 my ($search,$whynot) = @_;
4887 printdebug " search NOT $search->{Commit} $whynot\n";
4888 $search->{Whynot} = $whynot;
4889 push @nots, $search;
4890 no warnings qw(exiting);
4899 my $c = shift @todo;
4900 next if $considered{$c->{Commit}}++;
4902 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4904 printdebug "quiltify investigate $c->{Commit}\n";
4907 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4908 printdebug " search finished hooray!\n";
4913 if ($quilt_mode eq 'nofix') {
4914 fail "quilt fixup required but quilt mode is \`nofix'\n".
4915 "HEAD commit $c->{Commit} differs from tree implied by ".
4916 " debian/patches (tree object $oldtiptree)";
4918 if ($quilt_mode eq 'smash') {
4919 printdebug " search quitting smash\n";
4923 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4924 $not->($c, "has $c_sentinels not $t_sentinels")
4925 if $c_sentinels ne $t_sentinels;
4927 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4928 $commitdata =~ m/\n\n/;
4930 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4931 @parents = map { { Commit => $_, Child => $c } } @parents;
4933 $not->($c, "root commit") if !@parents;
4935 foreach my $p (@parents) {
4936 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4938 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4939 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4941 foreach my $p (@parents) {
4942 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4944 my @cmd= (@git, qw(diff-tree -r --name-only),
4945 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4946 my $patchstackchange = cmdoutput @cmd;
4947 if (length $patchstackchange) {
4948 $patchstackchange =~ s/\n/,/g;
4949 $not->($p, "changed $patchstackchange");
4952 printdebug " search queue P=$p->{Commit} ",
4953 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4959 printdebug "quiltify want to smash\n";
4962 my $x = $_[0]{Commit};
4963 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4966 my $reportnot = sub {
4968 my $s = $abbrev->($notp);
4969 my $c = $notp->{Child};
4970 $s .= "..".$abbrev->($c) if $c;
4971 $s .= ": ".$notp->{Whynot};
4974 if ($quilt_mode eq 'linear') {
4975 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4976 foreach my $notp (@nots) {
4977 print STDERR "$us: ", $reportnot->($notp), "\n";
4979 print STDERR "$us: $_\n" foreach @$failsuggestion;
4980 fail "quilt fixup naive history linearisation failed.\n".
4981 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4982 } elsif ($quilt_mode eq 'smash') {
4983 } elsif ($quilt_mode eq 'auto') {
4984 progress "quilt fixup cannot be linear, smashing...";
4986 die "$quilt_mode ?";
4989 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4990 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4992 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4994 quiltify_dpkg_commit "auto-$version-$target-$time",
4995 (getfield $clogp, 'Maintainer'),
4996 "Automatically generated patch ($clogp->{Version})\n".
4997 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5001 progress "quiltify linearisation planning successful, executing...";
5003 for (my $p = $sref_S;
5004 my $c = $p->{Child};
5006 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5007 next unless $p->{Nontrivial};
5009 my $cc = $c->{Commit};
5011 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5012 $commitdata =~ m/\n\n/ or die "$c ?";
5015 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5018 my $commitdate = cmdoutput
5019 @git, qw(log -n1 --pretty=format:%aD), $cc;
5021 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5023 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5030 my $gbp_check_suitable = sub {
5035 die "contains unexpected slashes\n" if m{//} || m{/$};
5036 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5037 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5038 die "too long" if length > 200;
5040 return $_ unless $@;
5041 print STDERR "quiltifying commit $cc:".
5042 " ignoring/dropping Gbp-Pq $what: $@";
5046 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5048 (\S+) \s* \n //ixm) {
5049 $patchname = $gbp_check_suitable->($1, 'Name');
5051 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5053 (\S+) \s* \n //ixm) {
5054 $patchdir = $gbp_check_suitable->($1, 'Topic');
5059 if (!defined $patchname) {
5060 $patchname = $title;
5061 $patchname =~ s/[.:]$//;
5064 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5065 my $translitname = $converter->convert($patchname);
5066 die unless defined $translitname;
5067 $patchname = $translitname;
5070 "dgit: patch title transliteration error: $@"
5072 $patchname =~ y/ A-Z/-a-z/;
5073 $patchname =~ y/-a-z0-9_.+=~//cd;
5074 $patchname =~ s/^\W/x-$&/;
5075 $patchname = substr($patchname,0,40);
5077 if (!defined $patchdir) {
5080 if (length $patchdir) {
5081 $patchname = "$patchdir/$patchname";
5083 if ($patchname =~ m{^(.*)/}) {
5084 mkpath "debian/patches/$1";
5089 stat "debian/patches/$patchname$index";
5091 $!==ENOENT or die "$patchname$index $!";
5093 runcmd @git, qw(checkout -q), $cc;
5095 # We use the tip's changelog so that dpkg-source doesn't
5096 # produce complaining messages from dpkg-parsechangelog. None
5097 # of the information dpkg-source gets from the changelog is
5098 # actually relevant - it gets put into the original message
5099 # which dpkg-source provides our stunt editor, and then
5101 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5103 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5104 "Date: $commitdate\n".
5105 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5107 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5110 runcmd @git, qw(checkout -q master);
5113 sub build_maybe_quilt_fixup () {
5114 my ($format,$fopts) = get_source_format;
5115 return unless madformat_wantfixup $format;
5118 check_for_vendor_patches();
5120 if (quiltmode_splitbrain) {
5121 fail <<END unless access_cfg_tagformats_can_splitbrain;
5122 quilt mode $quilt_mode requires split view so server needs to support
5123 both "new" and "maint" tag formats, but config says it doesn't.
5127 my $clogp = parsechangelog();
5128 my $headref = git_rev_parse('HEAD');
5133 my $upstreamversion = upstreamversion $version;
5135 if ($fopts->{'single-debian-patch'}) {
5136 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5138 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5141 die 'bug' if $split_brain && !$need_split_build_invocation;
5143 changedir '../../../..';
5144 runcmd_ordryrun_local
5145 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5148 sub quilt_fixup_mkwork ($) {
5151 mkdir "work" or die $!;
5153 mktree_in_ud_here();
5154 runcmd @git, qw(reset -q --hard), $headref;
5157 sub quilt_fixup_linkorigs ($$) {
5158 my ($upstreamversion, $fn) = @_;
5159 # calls $fn->($leafname);
5161 foreach my $f (<../../../../*>) { #/){
5162 my $b=$f; $b =~ s{.*/}{};
5164 local ($debuglevel) = $debuglevel-1;
5165 printdebug "QF linkorigs $b, $f ?\n";
5167 next unless is_orig_file_of_vsn $b, $upstreamversion;
5168 printdebug "QF linkorigs $b, $f Y\n";
5169 link_ltarget $f, $b or die "$b $!";
5174 sub quilt_fixup_delete_pc () {
5175 runcmd @git, qw(rm -rqf .pc);
5177 Commit removal of .pc (quilt series tracking data)
5179 [dgit ($our_version) upgrade quilt-remove-pc]
5183 sub quilt_fixup_singlepatch ($$$) {
5184 my ($clogp, $headref, $upstreamversion) = @_;
5186 progress "starting quiltify (single-debian-patch)";
5188 # dpkg-source --commit generates new patches even if
5189 # single-debian-patch is in debian/source/options. In order to
5190 # get it to generate debian/patches/debian-changes, it is
5191 # necessary to build the source package.
5193 quilt_fixup_linkorigs($upstreamversion, sub { });
5194 quilt_fixup_mkwork($headref);
5196 rmtree("debian/patches");
5198 runcmd @dpkgsource, qw(-b .);
5200 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5201 rename srcfn("$upstreamversion", "/debian/patches"),
5202 "work/debian/patches";
5205 commit_quilty_patch();
5208 sub quilt_make_fake_dsc ($) {
5209 my ($upstreamversion) = @_;
5211 my $fakeversion="$upstreamversion-~~DGITFAKE";
5213 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5214 print $fakedsc <<END or die $!;
5217 Version: $fakeversion
5221 my $dscaddfile=sub {
5224 my $md = new Digest::MD5;
5226 my $fh = new IO::File $b, '<' or die "$b $!";
5231 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5234 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5236 my @files=qw(debian/source/format debian/rules
5237 debian/control debian/changelog);
5238 foreach my $maybe (qw(debian/patches debian/source/options
5239 debian/tests/control)) {
5240 next unless stat_exists "../../../$maybe";
5241 push @files, $maybe;
5244 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5245 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5247 $dscaddfile->($debtar);
5248 close $fakedsc or die $!;
5251 sub quilt_check_splitbrain_cache ($$) {
5252 my ($headref, $upstreamversion) = @_;
5253 # Called only if we are in (potentially) split brain mode.
5255 # Computes the cache key and looks in the cache.
5256 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5258 my $splitbrain_cachekey;
5261 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5262 # we look in the reflog of dgit-intern/quilt-cache
5263 # we look for an entry whose message is the key for the cache lookup
5264 my @cachekey = (qw(dgit), $our_version);
5265 push @cachekey, $upstreamversion;
5266 push @cachekey, $quilt_mode;
5267 push @cachekey, $headref;
5269 push @cachekey, hashfile('fake.dsc');
5271 my $srcshash = Digest::SHA->new(256);
5272 my %sfs = ( %INC, '$0(dgit)' => $0 );
5273 foreach my $sfk (sort keys %sfs) {
5274 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5275 $srcshash->add($sfk," ");
5276 $srcshash->add(hashfile($sfs{$sfk}));
5277 $srcshash->add("\n");
5279 push @cachekey, $srcshash->hexdigest();
5280 $splitbrain_cachekey = "@cachekey";
5282 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5284 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5285 debugcmd "|(probably)",@cmd;
5286 my $child = open GC, "-|"; defined $child or die $!;
5288 chdir '../../..' or die $!;
5289 if (!stat ".git/logs/refs/$splitbraincache") {
5290 $! == ENOENT or die $!;
5291 printdebug ">(no reflog)\n";
5298 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5299 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5302 quilt_fixup_mkwork($headref);
5303 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5304 if ($cachehit ne $headref) {
5305 progress "dgit view: found cached ($saved)";
5306 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5308 return ($cachehit, $splitbrain_cachekey);
5310 progress "dgit view: found cached, no changes required";
5311 return ($headref, $splitbrain_cachekey);
5313 die $! if GC->error;
5314 failedcmd unless close GC;
5316 printdebug "splitbrain cache miss\n";
5317 return (undef, $splitbrain_cachekey);
5320 sub quilt_fixup_multipatch ($$$) {
5321 my ($clogp, $headref, $upstreamversion) = @_;
5323 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5326 # - honour any existing .pc in case it has any strangeness
5327 # - determine the git commit corresponding to the tip of
5328 # the patch stack (if there is one)
5329 # - if there is such a git commit, convert each subsequent
5330 # git commit into a quilt patch with dpkg-source --commit
5331 # - otherwise convert all the differences in the tree into
5332 # a single git commit
5336 # Our git tree doesn't necessarily contain .pc. (Some versions of
5337 # dgit would include the .pc in the git tree.) If there isn't
5338 # one, we need to generate one by unpacking the patches that we
5341 # We first look for a .pc in the git tree. If there is one, we
5342 # will use it. (This is not the normal case.)
5344 # Otherwise need to regenerate .pc so that dpkg-source --commit
5345 # can work. We do this as follows:
5346 # 1. Collect all relevant .orig from parent directory
5347 # 2. Generate a debian.tar.gz out of
5348 # debian/{patches,rules,source/format,source/options}
5349 # 3. Generate a fake .dsc containing just these fields:
5350 # Format Source Version Files
5351 # 4. Extract the fake .dsc
5352 # Now the fake .dsc has a .pc directory.
5353 # (In fact we do this in every case, because in future we will
5354 # want to search for a good base commit for generating patches.)
5356 # Then we can actually do the dpkg-source --commit
5357 # 1. Make a new working tree with the same object
5358 # store as our main tree and check out the main
5360 # 2. Copy .pc from the fake's extraction, if necessary
5361 # 3. Run dpkg-source --commit
5362 # 4. If the result has changes to debian/, then
5363 # - git add them them
5364 # - git add .pc if we had a .pc in-tree
5366 # 5. If we had a .pc in-tree, delete it, and git commit
5367 # 6. Back in the main tree, fast forward to the new HEAD
5369 # Another situation we may have to cope with is gbp-style
5370 # patches-unapplied trees.
5372 # We would want to detect these, so we know to escape into
5373 # quilt_fixup_gbp. However, this is in general not possible.
5374 # Consider a package with a one patch which the dgit user reverts
5375 # (with git revert or the moral equivalent).
5377 # That is indistinguishable in contents from a patches-unapplied
5378 # tree. And looking at the history to distinguish them is not
5379 # useful because the user might have made a confusing-looking git
5380 # history structure (which ought to produce an error if dgit can't
5381 # cope, not a silent reintroduction of an unwanted patch).
5383 # So gbp users will have to pass an option. But we can usually
5384 # detect their failure to do so: if the tree is not a clean
5385 # patches-applied tree, quilt linearisation fails, but the tree
5386 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5387 # they want --quilt=unapplied.
5389 # To help detect this, when we are extracting the fake dsc, we
5390 # first extract it with --skip-patches, and then apply the patches
5391 # afterwards with dpkg-source --before-build. That lets us save a
5392 # tree object corresponding to .origs.
5394 my $splitbrain_cachekey;
5396 quilt_make_fake_dsc($upstreamversion);
5398 if (quiltmode_splitbrain()) {
5400 ($cachehit, $splitbrain_cachekey) =
5401 quilt_check_splitbrain_cache($headref, $upstreamversion);
5402 return if $cachehit;
5406 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5408 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5409 rename $fakexdir, "fake" or die "$fakexdir $!";
5413 remove_stray_gits("source package");
5414 mktree_in_ud_here();
5418 my $unapplied=git_add_write_tree();
5419 printdebug "fake orig tree object $unapplied\n";
5423 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5425 if (system @bbcmd) {
5426 failedcmd @bbcmd if $? < 0;
5428 failed to apply your git tree's patch stack (from debian/patches/) to
5429 the corresponding upstream tarball(s). Your source tree and .orig
5430 are probably too inconsistent. dgit can only fix up certain kinds of
5431 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5437 quilt_fixup_mkwork($headref);
5440 if (stat_exists ".pc") {
5442 progress "Tree already contains .pc - will use it then delete it.";
5445 rename '../fake/.pc','.pc' or die $!;
5448 changedir '../fake';
5450 my $oldtiptree=git_add_write_tree();
5451 printdebug "fake o+d/p tree object $unapplied\n";
5452 changedir '../work';
5455 # We calculate some guesswork now about what kind of tree this might
5456 # be. This is mostly for error reporting.
5462 # O = orig, without patches applied
5463 # A = "applied", ie orig with H's debian/patches applied
5464 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5465 \%editedignores, \@unrepres),
5466 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5467 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5471 foreach my $b (qw(01 02)) {
5472 foreach my $v (qw(O2H O2A H2A)) {
5473 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5476 printdebug "differences \@dl @dl.\n";
5479 "$us: base trees orig=%.20s o+d/p=%.20s",
5480 $unapplied, $oldtiptree;
5482 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5483 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5484 $dl[0], $dl[1], $dl[3], $dl[4],
5488 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5490 forceable_fail [qw(unrepresentable)], <<END;
5491 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5496 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5497 push @failsuggestion, "This might be a patches-unapplied branch.";
5498 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5499 push @failsuggestion, "This might be a patches-applied branch.";
5501 push @failsuggestion, "Maybe you need to specify one of".
5502 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5504 if (quiltmode_splitbrain()) {
5505 quiltify_splitbrain($clogp, $unapplied, $headref,
5506 $diffbits, \%editedignores,
5507 $splitbrain_cachekey);
5511 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5512 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5514 if (!open P, '>>', ".pc/applied-patches") {
5515 $!==&ENOENT or die $!;
5520 commit_quilty_patch();
5522 if ($mustdeletepc) {
5523 quilt_fixup_delete_pc();
5527 sub quilt_fixup_editor () {
5528 my $descfn = $ENV{$fakeeditorenv};
5529 my $editing = $ARGV[$#ARGV];
5530 open I1, '<', $descfn or die "$descfn: $!";
5531 open I2, '<', $editing or die "$editing: $!";
5532 unlink $editing or die "$editing: $!";
5533 open O, '>', $editing or die "$editing: $!";
5534 while (<I1>) { print O or die $!; } I1->error and die $!;
5537 $copying ||= m/^\-\-\- /;
5538 next unless $copying;
5541 I2->error and die $!;
5546 sub maybe_apply_patches_dirtily () {
5547 return unless $quilt_mode =~ m/gbp|unapplied/;
5548 print STDERR <<END or die $!;
5550 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5551 dgit: Have to apply the patches - making the tree dirty.
5552 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5555 $patches_applied_dirtily = 01;
5556 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5557 runcmd qw(dpkg-source --before-build .);
5560 sub maybe_unapply_patches_again () {
5561 progress "dgit: Unapplying patches again to tidy up the tree."
5562 if $patches_applied_dirtily;
5563 runcmd qw(dpkg-source --after-build .)
5564 if $patches_applied_dirtily & 01;
5566 if $patches_applied_dirtily & 02;
5567 $patches_applied_dirtily = 0;
5570 #----- other building -----
5572 our $clean_using_builder;
5573 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5574 # clean the tree before building (perhaps invoked indirectly by
5575 # whatever we are using to run the build), rather than separately
5576 # and explicitly by us.
5579 return if $clean_using_builder;
5580 if ($cleanmode eq 'dpkg-source') {
5581 maybe_apply_patches_dirtily();
5582 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5583 } elsif ($cleanmode eq 'dpkg-source-d') {
5584 maybe_apply_patches_dirtily();
5585 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5586 } elsif ($cleanmode eq 'git') {
5587 runcmd_ordryrun_local @git, qw(clean -xdf);
5588 } elsif ($cleanmode eq 'git-ff') {
5589 runcmd_ordryrun_local @git, qw(clean -xdff);
5590 } elsif ($cleanmode eq 'check') {
5591 my $leftovers = cmdoutput @git, qw(clean -xdn);
5592 if (length $leftovers) {
5593 print STDERR $leftovers, "\n" or die $!;
5594 fail "tree contains uncommitted files and --clean=check specified";
5596 } elsif ($cleanmode eq 'none') {
5603 badusage "clean takes no additional arguments" if @ARGV;
5606 maybe_unapply_patches_again();
5609 sub build_prep_early () {
5610 our $build_prep_early_done //= 0;
5611 return if $build_prep_early_done++;
5613 badusage "-p is not allowed when building" if defined $package;
5614 my $clogp = parsechangelog();
5615 $isuite = getfield $clogp, 'Distribution';
5616 $package = getfield $clogp, 'Source';
5617 $version = getfield $clogp, 'Version';
5624 build_maybe_quilt_fixup();
5626 my $pat = changespat $version;
5627 foreach my $f (glob "$buildproductsdir/$pat") {
5629 unlink $f or fail "remove old changes file $f: $!";
5631 progress "would remove $f";
5637 sub changesopts_initial () {
5638 my @opts =@changesopts[1..$#changesopts];
5641 sub changesopts_version () {
5642 if (!defined $changes_since_version) {
5643 my @vsns = archive_query('archive_query');
5644 my @quirk = access_quirk();
5645 if ($quirk[0] eq 'backports') {
5646 local $isuite = $quirk[2];
5648 canonicalise_suite();
5649 push @vsns, archive_query('archive_query');
5652 @vsns = map { $_->[0] } @vsns;
5653 @vsns = sort { -version_compare($a, $b) } @vsns;
5654 $changes_since_version = $vsns[0];
5655 progress "changelog will contain changes since $vsns[0]";
5657 $changes_since_version = '_';
5658 progress "package seems new, not specifying -v<version>";
5661 if ($changes_since_version ne '_') {
5662 return ("-v$changes_since_version");
5668 sub changesopts () {
5669 return (changesopts_initial(), changesopts_version());
5672 sub massage_dbp_args ($;$) {
5673 my ($cmd,$xargs) = @_;
5676 # - if we're going to split the source build out so we can
5677 # do strange things to it, massage the arguments to dpkg-buildpackage
5678 # so that the main build doessn't build source (or add an argument
5679 # to stop it building source by default).
5681 # - add -nc to stop dpkg-source cleaning the source tree,
5682 # unless we're not doing a split build and want dpkg-source
5683 # as cleanmode, in which case we can do nothing
5686 # 0 - source will NOT need to be built separately by caller
5687 # +1 - source will need to be built separately by caller
5688 # +2 - source will need to be built separately by caller AND
5689 # dpkg-buildpackage should not in fact be run at all!
5690 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5691 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5692 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5693 $clean_using_builder = 1;
5696 # -nc has the side effect of specifying -b if nothing else specified
5697 # and some combinations of -S, -b, et al, are errors, rather than
5698 # later simply overriding earlie. So we need to:
5699 # - search the command line for these options
5700 # - pick the last one
5701 # - perhaps add our own as a default
5702 # - perhaps adjust it to the corresponding non-source-building version
5704 foreach my $l ($cmd, $xargs) {
5706 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5709 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5711 if ($need_split_build_invocation) {
5712 printdebug "massage split $dmode.\n";
5713 $r = $dmode =~ m/[S]/ ? +2 :
5714 $dmode =~ y/gGF/ABb/ ? +1 :
5715 $dmode =~ m/[ABb]/ ? 0 :
5718 printdebug "massage done $r $dmode.\n";
5720 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5726 my $wasdir = must_getcwd();
5732 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5733 my ($msg_if_onlyone) = @_;
5734 # If there is only one .changes file, fail with $msg_if_onlyone,
5735 # or if that is undef, be a no-op.
5736 # Returns the changes file to report to the user.
5737 my $pat = changespat $version;
5738 my @changesfiles = glob $pat;
5739 @changesfiles = sort {
5740 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5744 if (@changesfiles==1) {
5745 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5746 only one changes file from build (@changesfiles)
5748 $result = $changesfiles[0];
5749 } elsif (@changesfiles==2) {
5750 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5751 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5752 fail "$l found in binaries changes file $binchanges"
5755 runcmd_ordryrun_local @mergechanges, @changesfiles;
5756 my $multichanges = changespat $version,'multi';
5758 stat_exists $multichanges or fail "$multichanges: $!";
5759 foreach my $cf (glob $pat) {
5760 next if $cf eq $multichanges;
5761 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5764 $result = $multichanges;
5766 fail "wrong number of different changes files (@changesfiles)";
5768 printdone "build successful, results in $result\n" or die $!;
5771 sub midbuild_checkchanges () {
5772 my $pat = changespat $version;
5773 return if $rmchanges;
5774 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5775 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5777 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5778 Suggest you delete @unwanted.
5783 sub midbuild_checkchanges_vanilla ($) {
5785 midbuild_checkchanges() if $wantsrc == 1;
5788 sub postbuild_mergechanges_vanilla ($) {
5790 if ($wantsrc == 1) {
5792 postbuild_mergechanges(undef);
5795 printdone "build successful\n";
5801 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5802 my $wantsrc = massage_dbp_args \@dbp;
5805 midbuild_checkchanges_vanilla $wantsrc;
5810 push @dbp, changesopts_version();
5811 maybe_apply_patches_dirtily();
5812 runcmd_ordryrun_local @dbp;
5814 maybe_unapply_patches_again();
5815 postbuild_mergechanges_vanilla $wantsrc;
5819 $quilt_mode //= 'gbp';
5825 # gbp can make .origs out of thin air. In my tests it does this
5826 # even for a 1.0 format package, with no origs present. So I
5827 # guess it keys off just the version number. We don't know
5828 # exactly what .origs ought to exist, but let's assume that we
5829 # should run gbp if: the version has an upstream part and the main
5831 my $upstreamversion = upstreamversion $version;
5832 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5833 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5835 if ($gbp_make_orig) {
5837 $cleanmode = 'none'; # don't do it again
5838 $need_split_build_invocation = 1;
5841 my @dbp = @dpkgbuildpackage;
5843 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5845 if (!length $gbp_build[0]) {
5846 if (length executable_on_path('git-buildpackage')) {
5847 $gbp_build[0] = qw(git-buildpackage);
5849 $gbp_build[0] = 'gbp buildpackage';
5852 my @cmd = opts_opt_multi_cmd @gbp_build;
5854 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5856 if ($gbp_make_orig) {
5857 ensuredir '.git/dgit';
5858 my $ok = '.git/dgit/origs-gen-ok';
5859 unlink $ok or $!==&ENOENT or die $!;
5860 my @origs_cmd = @cmd;
5861 push @origs_cmd, qw(--git-cleaner=true);
5862 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5863 push @origs_cmd, @ARGV;
5865 debugcmd @origs_cmd;
5867 do { local $!; stat_exists $ok; }
5868 or failedcmd @origs_cmd;
5870 dryrun_report @origs_cmd;
5876 midbuild_checkchanges_vanilla $wantsrc;
5878 if (!$clean_using_builder) {
5879 push @cmd, '--git-cleaner=true';
5883 maybe_unapply_patches_again();
5885 push @cmd, changesopts();
5886 runcmd_ordryrun_local @cmd, @ARGV;
5888 postbuild_mergechanges_vanilla $wantsrc;
5890 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5894 my $our_cleanmode = $cleanmode;
5895 if ($need_split_build_invocation) {
5896 # Pretend that clean is being done some other way. This
5897 # forces us not to try to use dpkg-buildpackage to clean and
5898 # build source all in one go; and instead we run dpkg-source
5899 # (and build_prep() will do the clean since $clean_using_builder
5901 $our_cleanmode = 'ELSEWHERE';
5903 if ($our_cleanmode =~ m/^dpkg-source/) {
5904 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5905 $clean_using_builder = 1;
5908 $sourcechanges = changespat $version,'source';
5910 unlink "../$sourcechanges" or $!==ENOENT
5911 or fail "remove $sourcechanges: $!";
5913 $dscfn = dscfn($version);
5914 if ($our_cleanmode eq 'dpkg-source') {
5915 maybe_apply_patches_dirtily();
5916 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5918 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5919 maybe_apply_patches_dirtily();
5920 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5923 my @cmd = (@dpkgsource, qw(-b --));
5926 runcmd_ordryrun_local @cmd, "work";
5927 my @udfiles = <${package}_*>;
5928 changedir "../../..";
5929 foreach my $f (@udfiles) {
5930 printdebug "source copy, found $f\n";
5933 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5934 $f eq srcfn($version, $&));
5935 printdebug "source copy, found $f - renaming\n";
5936 rename "$ud/$f", "../$f" or $!==ENOENT
5937 or fail "put in place new source file ($f): $!";
5940 my $pwd = must_getcwd();
5941 my $leafdir = basename $pwd;
5943 runcmd_ordryrun_local @cmd, $leafdir;
5946 runcmd_ordryrun_local qw(sh -ec),
5947 'exec >$1; shift; exec "$@"','x',
5948 "../$sourcechanges",
5949 @dpkggenchanges, qw(-S), changesopts();
5953 sub cmd_build_source {
5955 badusage "build-source takes no additional arguments" if @ARGV;
5957 maybe_unapply_patches_again();
5958 printdone "source built, results in $dscfn and $sourcechanges";
5963 midbuild_checkchanges();
5966 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5967 stat_exists $sourcechanges
5968 or fail "$sourcechanges (in parent directory): $!";
5970 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5972 maybe_unapply_patches_again();
5974 postbuild_mergechanges(<<END);
5975 perhaps you need to pass -A ? (sbuild's default is to build only
5976 arch-specific binaries; dgit 1.4 used to override that.)
5981 sub cmd_quilt_fixup {
5982 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5985 build_maybe_quilt_fixup();
5988 sub cmd_import_dsc {
5992 last unless $ARGV[0] =~ m/^-/;
5995 if (m/^--require-valid-signature$/) {
5998 badusage "unknown dgit import-dsc sub-option \`$_'";
6002 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6003 my ($dscfn, $dstbranch) = @ARGV;
6005 badusage "dry run makes no sense with import-dsc" unless act_local();
6007 my $force = $dstbranch =~ s/^\+// ? +1 :
6008 $dstbranch =~ s/^\.\.// ? -1 :
6010 my $info = $force ? " $&" : '';
6011 $info = "$dscfn$info";
6013 my $specbranch = $dstbranch;
6014 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6015 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6017 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6018 my $chead = cmdoutput_errok @symcmd;
6019 defined $chead or $?==256 or failedcmd @symcmd;
6021 fail "$dstbranch is checked out - will not update it"
6022 if defined $chead and $chead eq $dstbranch;
6024 my $oldhash = git_get_ref $dstbranch;
6026 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6027 $dscdata = do { local $/ = undef; <D>; };
6028 D->error and fail "read $dscfn: $!";
6031 # we don't normally need this so import it here
6032 use Dpkg::Source::Package;
6033 my $dp = new Dpkg::Source::Package filename => $dscfn,
6034 require_valid_signature => $needsig;
6036 local $SIG{__WARN__} = sub {
6038 return unless $needsig;
6039 fail "import-dsc signature check failed";
6041 if (!$dp->is_signed()) {
6042 warn "$us: warning: importing unsigned .dsc\n";
6044 my $r = $dp->check_signature();
6045 die "->check_signature => $r" if $needsig && $r;
6051 $package = getfield $dsc, 'Source';
6053 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6054 unless forceing [qw(import-dsc-with-dgit-field)];
6056 if (defined $dsc_hash) {
6057 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6058 resolve_dsc_field_commit undef, undef;
6060 if (defined $dsc_hash) {
6061 my @cmd = (qw(sh -ec),
6062 "echo $dsc_hash | git cat-file --batch-check");
6063 my $objgot = cmdoutput @cmd;
6064 if ($objgot =~ m#^\w+ missing\b#) {
6066 .dsc contains Dgit field referring to object $dsc_hash
6067 Your git tree does not have that object. Try `git fetch' from a
6068 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6071 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6073 progress "Not fast forward, forced update.";
6075 fail "Not fast forward to $dsc_hash";
6078 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
6079 $dstbranch, $dsc_hash);
6081 progress "dgit: import-dsc updated git ref $dstbranch";
6086 Branch $dstbranch already exists
6087 Specify ..$specbranch for a pseudo-merge, binding in existing history
6088 Specify +$specbranch to overwrite, discarding existing history
6090 if $oldhash && !$force;
6092 my @dfi = dsc_files_info();
6093 foreach my $fi (@dfi) {
6094 my $f = $fi->{Filename};
6096 next if lstat $here;
6097 fail "stat $here: $!" unless $! == ENOENT;
6099 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6101 } elsif ($dscfn =~ m#^/#) {
6104 fail "cannot import $dscfn which seems to be inside working tree!";
6106 $there =~ s#/+[^/]+$## or
6107 fail "cannot import $dscfn which seems to not have a basename";
6109 symlink $there, $here or fail "symlink $there to $here: $!";
6110 progress "made symlink $here -> $there";
6111 # print STDERR Dumper($fi);
6113 my @mergeinputs = generate_commits_from_dsc();
6114 die unless @mergeinputs == 1;
6116 my $newhash = $mergeinputs[0]{Commit};
6120 progress "Import, forced update - synthetic orphan git history.";
6121 } elsif ($force < 0) {
6122 progress "Import, merging.";
6123 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6124 my $version = getfield $dsc, 'Version';
6125 my $clogp = commit_getclogp $newhash;
6126 my $authline = clogp_authline $clogp;
6127 $newhash = make_commit_text <<END;
6134 Merge $package ($version) import into $dstbranch
6137 die; # caught earlier
6141 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
6142 $dstbranch, $newhash);
6144 progress "dgit: import-dsc results are in in git ref $dstbranch";
6147 sub cmd_archive_api_query {
6148 badusage "need only 1 subpath argument" unless @ARGV==1;
6149 my ($subpath) = @ARGV;
6150 my @cmd = archive_api_query_cmd($subpath);
6153 exec @cmd or fail "exec curl: $!\n";
6156 sub cmd_clone_dgit_repos_server {
6157 badusage "need destination argument" unless @ARGV==1;
6158 my ($destdir) = @ARGV;
6159 $package = '_dgit-repos-server';
6160 local $access_forpush = 0;
6161 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6163 exec @cmd or fail "exec git clone: $!\n";
6166 sub cmd_print_dgit_repos_server_source_url {
6167 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6169 $package = '_dgit-repos-server';
6170 local $access_forpush = 0;
6171 my $url = access_giturl();
6172 print $url, "\n" or die $!;
6175 sub cmd_setup_mergechangelogs {
6176 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6177 setup_mergechangelogs(1);
6180 sub cmd_setup_useremail {
6181 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6185 sub cmd_setup_new_tree {
6186 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6190 #---------- argument parsing and main program ----------
6193 print "dgit version $our_version\n" or die $!;
6197 our (%valopts_long, %valopts_short);
6200 sub defvalopt ($$$$) {
6201 my ($long,$short,$val_re,$how) = @_;
6202 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6203 $valopts_long{$long} = $oi;
6204 $valopts_short{$short} = $oi;
6205 # $how subref should:
6206 # do whatever assignemnt or thing it likes with $_[0]
6207 # if the option should not be passed on to remote, @rvalopts=()
6208 # or $how can be a scalar ref, meaning simply assign the value
6211 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6212 defvalopt '--distro', '-d', '.+', \$idistro;
6213 defvalopt '', '-k', '.+', \$keyid;
6214 defvalopt '--existing-package','', '.*', \$existing_package;
6215 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6216 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6217 defvalopt '--package', '-p', $package_re, \$package;
6218 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6220 defvalopt '', '-C', '.+', sub {
6221 ($changesfile) = (@_);
6222 if ($changesfile =~ s#^(.*)/##) {
6223 $buildproductsdir = $1;
6227 defvalopt '--initiator-tempdir','','.*', sub {
6228 ($initiator_tempdir) = (@_);
6229 $initiator_tempdir =~ m#^/# or
6230 badusage "--initiator-tempdir must be used specify an".
6231 " absolute, not relative, directory."
6237 if (defined $ENV{'DGIT_SSH'}) {
6238 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6239 } elsif (defined $ENV{'GIT_SSH'}) {
6240 @ssh = ($ENV{'GIT_SSH'});
6248 if (!defined $val) {
6249 badusage "$what needs a value" unless @ARGV;
6251 push @rvalopts, $val;
6253 badusage "bad value \`$val' for $what" unless
6254 $val =~ m/^$oi->{Re}$(?!\n)/s;
6255 my $how = $oi->{How};
6256 if (ref($how) eq 'SCALAR') {
6261 push @ropts, @rvalopts;
6265 last unless $ARGV[0] =~ m/^-/;
6269 if (m/^--dry-run$/) {
6272 } elsif (m/^--damp-run$/) {
6275 } elsif (m/^--no-sign$/) {
6278 } elsif (m/^--help$/) {
6280 } elsif (m/^--version$/) {
6282 } elsif (m/^--new$/) {
6285 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6286 ($om = $opts_opt_map{$1}) &&
6290 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6291 !$opts_opt_cmdonly{$1} &&
6292 ($om = $opts_opt_map{$1})) {
6295 } elsif (m/^--(gbp|dpm)$/s) {
6296 push @ropts, "--quilt=$1";
6298 } elsif (m/^--ignore-dirty$/s) {
6301 } elsif (m/^--no-quilt-fixup$/s) {
6303 $quilt_mode = 'nocheck';
6304 } elsif (m/^--no-rm-on-error$/s) {
6307 } elsif (m/^--no-chase-dsc-distro$/s) {
6309 $chase_dsc_distro = 0;
6310 } elsif (m/^--overwrite$/s) {
6312 $overwrite_version = '';
6313 } elsif (m/^--overwrite=(.+)$/s) {
6315 $overwrite_version = $1;
6316 } elsif (m/^--dep14tag$/s) {
6318 $dodep14tag= 'want';
6319 } elsif (m/^--no-dep14tag$/s) {
6322 } elsif (m/^--always-dep14tag$/s) {
6324 $dodep14tag= 'always';
6325 } elsif (m/^--delayed=(\d+)$/s) {
6328 } elsif (m/^--dgit-view-save=(.+)$/s) {
6330 $split_brain_save = $1;
6331 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6332 } elsif (m/^--(no-)?rm-old-changes$/s) {
6335 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6337 push @deliberatelies, $&;
6338 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6342 } elsif (m/^--force-/) {
6344 "$us: warning: ignoring unknown force option $_\n";
6346 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6347 # undocumented, for testing
6349 $tagformat_want = [ $1, 'command line', 1 ];
6350 # 1 menas overrides distro configuration
6351 } elsif (m/^--always-split-source-build$/s) {
6352 # undocumented, for testing
6354 $need_split_build_invocation = 1;
6355 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6356 # undocumented, for testing
6358 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6359 # ^ it's supposed to be an array ref
6360 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6361 $val = $2 ? $' : undef; #';
6362 $valopt->($oi->{Long});
6364 badusage "unknown long option \`$_'";
6371 } elsif (s/^-L/-/) {
6374 } elsif (s/^-h/-/) {
6376 } elsif (s/^-D/-/) {
6380 } elsif (s/^-N/-/) {
6385 push @changesopts, $_;
6387 } elsif (s/^-wn$//s) {
6389 $cleanmode = 'none';
6390 } elsif (s/^-wg$//s) {
6393 } elsif (s/^-wgf$//s) {
6395 $cleanmode = 'git-ff';
6396 } elsif (s/^-wd$//s) {
6398 $cleanmode = 'dpkg-source';
6399 } elsif (s/^-wdd$//s) {
6401 $cleanmode = 'dpkg-source-d';
6402 } elsif (s/^-wc$//s) {
6404 $cleanmode = 'check';
6405 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6406 push @git, '-c', $&;
6407 $gitcfgs{cmdline}{$1} = [ $2 ];
6408 } elsif (s/^-c([^=]+)$//s) {
6409 push @git, '-c', $&;
6410 $gitcfgs{cmdline}{$1} = [ 'true' ];
6411 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6413 $val = undef unless length $val;
6414 $valopt->($oi->{Short});
6417 badusage "unknown short option \`$_'";
6424 sub check_env_sanity () {
6425 my $blocked = new POSIX::SigSet;
6426 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6429 foreach my $name (qw(PIPE CHLD)) {
6430 my $signame = "SIG$name";
6431 my $signum = eval "POSIX::$signame" // die;
6432 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6433 die "$signame is set to something other than SIG_DFL\n";
6434 $blocked->ismember($signum) and
6435 die "$signame is blocked\n";
6441 On entry to dgit, $@
6442 This is a bug produced by something in in your execution environment.
6448 sub parseopts_late_defaults () {
6449 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6450 if defined $idistro;
6451 $isuite //= cfg('dgit.default.default-suite');
6453 foreach my $k (keys %opts_opt_map) {
6454 my $om = $opts_opt_map{$k};
6456 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6458 badcfg "cannot set command for $k"
6459 unless length $om->[0];
6463 foreach my $c (access_cfg_cfgs("opts-$k")) {
6465 map { $_ ? @$_ : () }
6466 map { $gitcfgs{$_}{$c} }
6467 reverse @gitcfgsources;
6468 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6469 "\n" if $debuglevel >= 4;
6471 badcfg "cannot configure options for $k"
6472 if $opts_opt_cmdonly{$k};
6473 my $insertpos = $opts_cfg_insertpos{$k};
6474 @$om = ( @$om[0..$insertpos-1],
6476 @$om[$insertpos..$#$om] );
6480 if (!defined $rmchanges) {
6481 local $access_forpush;
6482 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6485 if (!defined $quilt_mode) {
6486 local $access_forpush;
6487 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6488 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6490 $quilt_mode =~ m/^($quilt_modes_re)$/
6491 or badcfg "unknown quilt-mode \`$quilt_mode'";
6495 if (!defined $dodep14tag) {
6496 local $access_forpush;
6497 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6498 $dodep14tag =~ m/^($dodep14tag_re)$/
6499 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6503 $need_split_build_invocation ||= quiltmode_splitbrain();
6505 if (!defined $cleanmode) {
6506 local $access_forpush;
6507 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6508 $cleanmode //= 'dpkg-source';
6510 badcfg "unknown clean-mode \`$cleanmode'" unless
6511 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6515 if ($ENV{$fakeeditorenv}) {
6517 quilt_fixup_editor();
6524 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6525 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6526 if $dryrun_level == 1;
6528 print STDERR $helpmsg or die $!;
6531 my $cmd = shift @ARGV;
6534 my $pre_fn = ${*::}{"pre_$cmd"};
6535 $pre_fn->() if $pre_fn;
6537 my $fn = ${*::}{"cmd_$cmd"};
6538 $fn or badusage "unknown operation $cmd";