3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
39 use Text::Glob qw(match_glob);
40 use Fcntl qw(:DEFAULT :flock);
45 our $our_version = 'UNRELEASED'; ###substituted###
46 our $absurdity = undef; ###substituted###
48 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
51 our $isuite = 'unstable';
57 our $dryrun_level = 0;
59 our $buildproductsdir = '..';
65 our $existing_package = 'dpkg';
67 our $changes_since_version;
69 our $overwrite_version; # undef: not specified; '': check changelog
71 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
73 our $dodep14tag_re = 'want|no|always';
74 our $split_brain_save;
75 our $we_are_responder;
76 our $initiator_tempdir;
77 our $patches_applied_dirtily = 00;
81 our $chase_dsc_distro=1; #xxx configurable
83 our %forceopts = map { $_=>0 }
84 qw(unrepresentable unsupported-source-format
85 dsc-changes-mismatch changes-origs-exactly
86 import-gitapply-absurd
87 import-gitapply-no-absurd
88 import-dsc-with-dgit-field);
90 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
92 our $suite_re = '[-+.0-9a-z]+';
93 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
94 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
95 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
96 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
98 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
99 our $splitbraincache = 'dgit-intern/quilt-cache';
100 our $rewritemap = 'dgit-rewrite/map';
102 our (@git) = qw(git);
103 our (@dget) = qw(dget);
104 our (@curl) = qw(curl);
105 our (@dput) = qw(dput);
106 our (@debsign) = qw(debsign);
107 our (@gpg) = qw(gpg);
108 our (@sbuild) = qw(sbuild);
110 our (@dgit) = qw(dgit);
111 our (@aptget) = qw(apt-get);
112 our (@aptcache) = qw(apt-cache);
113 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
114 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
115 our (@dpkggenchanges) = qw(dpkg-genchanges);
116 our (@mergechanges) = qw(mergechanges -f);
117 our (@gbp_build) = ('');
118 our (@gbp_pq) = ('gbp pq');
119 our (@changesopts) = ('');
121 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
124 'debsign' => \@debsign,
126 'sbuild' => \@sbuild,
130 'apt-get' => \@aptget,
131 'apt-cache' => \@aptcache,
132 'dpkg-source' => \@dpkgsource,
133 'dpkg-buildpackage' => \@dpkgbuildpackage,
134 'dpkg-genchanges' => \@dpkggenchanges,
135 'gbp-build' => \@gbp_build,
136 'gbp-pq' => \@gbp_pq,
137 'ch' => \@changesopts,
138 'mergechanges' => \@mergechanges);
140 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
141 our %opts_cfg_insertpos = map {
143 scalar @{ $opts_opt_map{$_} }
144 } keys %opts_opt_map;
146 sub parseopts_late_defaults();
152 our $supplementary_message = '';
153 our $need_split_build_invocation = 0;
154 our $split_brain = 0;
158 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
161 our $remotename = 'dgit';
162 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
166 if (!defined $absurdity) {
168 $absurdity =~ s{/[^/]+$}{/absurd} or die;
172 my ($v,$distro) = @_;
173 return $tagformatfn->($v, $distro);
176 sub debiantag_maintview ($$) {
177 my ($v,$distro) = @_;
178 return "$distro/".dep14_version_mangle $v;
181 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
183 sub lbranch () { return "$branchprefix/$csuite"; }
184 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
185 sub lref () { return "refs/heads/".lbranch(); }
186 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
187 sub rrref () { return server_ref($csuite); }
197 return "${package}_".(stripepoch $vsn).$sfx
202 return srcfn($vsn,".dsc");
205 sub changespat ($;$) {
206 my ($vsn, $arch) = @_;
207 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
210 sub upstreamversion ($) {
222 foreach my $f (@end) {
224 print STDERR "$us: cleanup: $@" if length $@;
228 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
230 sub forceable_fail ($$) {
231 my ($forceoptsl, $msg) = @_;
232 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
233 print STDERR "warning: overriding problem due to --force:\n". $msg;
237 my ($forceoptsl) = @_;
238 my @got = grep { $forceopts{$_} } @$forceoptsl;
239 return 0 unless @got;
241 "warning: skipping checks or functionality due to --force-$got[0]\n";
244 sub no_such_package () {
245 print STDERR "$us: package $package does not exist in suite $isuite\n";
251 printdebug "CD $newdir\n";
252 chdir $newdir or confess "chdir: $newdir: $!";
255 sub deliberately ($) {
257 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
260 sub deliberately_not_fast_forward () {
261 foreach (qw(not-fast-forward fresh-repo)) {
262 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
266 sub quiltmode_splitbrain () {
267 $quilt_mode =~ m/gbp|dpm|unapplied/;
270 sub opts_opt_multi_cmd {
272 push @cmd, split /\s+/, shift @_;
278 return opts_opt_multi_cmd @gbp_pq;
281 #---------- remote protocol support, common ----------
283 # remote push initiator/responder protocol:
284 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
285 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
286 # < dgit-remote-push-ready <actual-proto-vsn>
293 # > supplementary-message NBYTES # $protovsn >= 3
298 # > file parsed-changelog
299 # [indicates that output of dpkg-parsechangelog follows]
300 # > data-block NBYTES
301 # > [NBYTES bytes of data (no newline)]
302 # [maybe some more blocks]
311 # > param head DGIT-VIEW-HEAD
312 # > param csuite SUITE
313 # > param tagformat old|new
314 # > param maint-view MAINT-VIEW-HEAD
316 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
317 # # goes into tag, for replay prevention
320 # [indicates that signed tag is wanted]
321 # < data-block NBYTES
322 # < [NBYTES bytes of data (no newline)]
323 # [maybe some more blocks]
327 # > want signed-dsc-changes
328 # < data-block NBYTES [transfer of signed dsc]
330 # < data-block NBYTES [transfer of signed changes]
338 sub i_child_report () {
339 # Sees if our child has died, and reap it if so. Returns a string
340 # describing how it died if it failed, or undef otherwise.
341 return undef unless $i_child_pid;
342 my $got = waitpid $i_child_pid, WNOHANG;
343 return undef if $got <= 0;
344 die unless $got == $i_child_pid;
345 $i_child_pid = undef;
346 return undef unless $?;
347 return "build host child ".waitstatusmsg();
352 fail "connection lost: $!" if $fh->error;
353 fail "protocol violation; $m not expected";
356 sub badproto_badread ($$) {
358 fail "connection lost: $!" if $!;
359 my $report = i_child_report();
360 fail $report if defined $report;
361 badproto $fh, "eof (reading $wh)";
364 sub protocol_expect (&$) {
365 my ($match, $fh) = @_;
368 defined && chomp or badproto_badread $fh, "protocol message";
376 badproto $fh, "\`$_'";
379 sub protocol_send_file ($$) {
380 my ($fh, $ourfn) = @_;
381 open PF, "<", $ourfn or die "$ourfn: $!";
384 my $got = read PF, $d, 65536;
385 die "$ourfn: $!" unless defined $got;
387 print $fh "data-block ".length($d)."\n" or die $!;
388 print $fh $d or die $!;
390 PF->error and die "$ourfn $!";
391 print $fh "data-end\n" or die $!;
395 sub protocol_read_bytes ($$) {
396 my ($fh, $nbytes) = @_;
397 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
399 my $got = read $fh, $d, $nbytes;
400 $got==$nbytes or badproto_badread $fh, "data block";
404 sub protocol_receive_file ($$) {
405 my ($fh, $ourfn) = @_;
406 printdebug "() $ourfn\n";
407 open PF, ">", $ourfn or die "$ourfn: $!";
409 my ($y,$l) = protocol_expect {
410 m/^data-block (.*)$/ ? (1,$1) :
411 m/^data-end$/ ? (0,) :
415 my $d = protocol_read_bytes $fh, $l;
416 print PF $d or die $!;
421 #---------- remote protocol support, responder ----------
423 sub responder_send_command ($) {
425 return unless $we_are_responder;
426 # called even without $we_are_responder
427 printdebug ">> $command\n";
428 print PO $command, "\n" or die $!;
431 sub responder_send_file ($$) {
432 my ($keyword, $ourfn) = @_;
433 return unless $we_are_responder;
434 printdebug "]] $keyword $ourfn\n";
435 responder_send_command "file $keyword";
436 protocol_send_file \*PO, $ourfn;
439 sub responder_receive_files ($@) {
440 my ($keyword, @ourfns) = @_;
441 die unless $we_are_responder;
442 printdebug "[[ $keyword @ourfns\n";
443 responder_send_command "want $keyword";
444 foreach my $fn (@ourfns) {
445 protocol_receive_file \*PI, $fn;
448 protocol_expect { m/^files-end$/ } \*PI;
451 #---------- remote protocol support, initiator ----------
453 sub initiator_expect (&) {
455 protocol_expect { &$match } \*RO;
458 #---------- end remote code ----------
461 if ($we_are_responder) {
463 responder_send_command "progress ".length($m) or die $!;
464 print PO $m or die $!;
474 $ua = LWP::UserAgent->new();
478 progress "downloading $what...";
479 my $r = $ua->get(@_) or die $!;
480 return undef if $r->code == 404;
481 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
482 return $r->decoded_content(charset => 'none');
485 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
490 failedcmd @_ if system @_;
493 sub act_local () { return $dryrun_level <= 1; }
494 sub act_scary () { return !$dryrun_level; }
497 if (!$dryrun_level) {
498 progress "$us ok: @_";
500 progress "would be ok: @_ (but dry run only)";
505 printcmd(\*STDERR,$debugprefix."#",@_);
508 sub runcmd_ordryrun {
516 sub runcmd_ordryrun_local {
525 my ($first_shell, @cmd) = @_;
526 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
529 our $helpmsg = <<END;
531 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
532 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
533 dgit [dgit-opts] build [dpkg-buildpackage-opts]
534 dgit [dgit-opts] sbuild [sbuild-opts]
535 dgit [dgit-opts] push [dgit-opts] [suite]
536 dgit [dgit-opts] rpush build-host:build-dir ...
537 important dgit options:
538 -k<keyid> sign tag and package with <keyid> instead of default
539 --dry-run -n do not change anything, but go through the motions
540 --damp-run -L like --dry-run but make local changes, without signing
541 --new -N allow introducing a new package
542 --debug -D increase debug level
543 -c<name>=<value> set git config option (used directly by dgit too)
546 our $later_warning_msg = <<END;
547 Perhaps the upload is stuck in incoming. Using the version from git.
551 print STDERR "$us: @_\n", $helpmsg or die $!;
556 @ARGV or badusage "too few arguments";
557 return scalar shift @ARGV;
561 print $helpmsg or die $!;
565 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
567 our %defcfg = ('dgit.default.distro' => 'debian',
568 'dgit-suite.*-security.distro' => 'debian-security',
569 'dgit.default.username' => '',
570 'dgit.default.archive-query-default-component' => 'main',
571 'dgit.default.ssh' => 'ssh',
572 'dgit.default.archive-query' => 'madison:',
573 'dgit.default.sshpsql-dbname' => 'service=projectb',
574 'dgit.default.aptget-components' => 'main',
575 'dgit.default.dgit-tag-format' => 'new,old,maint',
576 'dgit.dsc-url-proto-ok.http' => 'true',
577 'dgit.dsc-url-proto-ok.https' => 'true',
578 'dgit.dsc-url-proto-ok.git' => 'true',
579 'dgit.default.dsc-url-proto-ok' => 'false',
580 # old means "repo server accepts pushes with old dgit tags"
581 # new means "repo server accepts pushes with new dgit tags"
582 # maint means "repo server accepts split brain pushes"
583 # hist means "repo server may have old pushes without new tag"
584 # ("hist" is implied by "old")
585 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
586 'dgit-distro.debian.git-check' => 'url',
587 'dgit-distro.debian.git-check-suffix' => '/info/refs',
588 'dgit-distro.debian.new-private-pushers' => 't',
589 'dgit-distro.debian/push.git-url' => '',
590 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
591 'dgit-distro.debian/push.git-user-force' => 'dgit',
592 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
593 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
594 'dgit-distro.debian/push.git-create' => 'true',
595 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
596 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
597 # 'dgit-distro.debian.archive-query-tls-key',
598 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
599 # ^ this does not work because curl is broken nowadays
600 # Fixing #790093 properly will involve providing providing the key
601 # in some pacagke and maybe updating these paths.
603 # 'dgit-distro.debian.archive-query-tls-curl-args',
604 # '--ca-path=/etc/ssl/ca-debian',
605 # ^ this is a workaround but works (only) on DSA-administered machines
606 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
607 'dgit-distro.debian.git-url-suffix' => '',
608 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
609 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
610 'dgit-distro.debian-security.archive-query' => 'aptget:',
611 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
612 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
613 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
614 'dgit-distro.debian-security.nominal-distro' => 'debian',
615 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
616 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
617 'dgit-distro.ubuntu.git-check' => 'false',
618 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
619 'dgit-distro.test-dummy.ssh' => "$td/ssh",
620 'dgit-distro.test-dummy.username' => "alice",
621 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
622 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
623 'dgit-distro.test-dummy.git-url' => "$td/git",
624 'dgit-distro.test-dummy.git-host' => "git",
625 'dgit-distro.test-dummy.git-path' => "$td/git",
626 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
627 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
628 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
629 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
633 our @gitcfgsources = qw(cmdline local global system);
635 sub git_slurp_config () {
636 local ($debuglevel) = $debuglevel-2;
639 # This algoritm is a bit subtle, but this is needed so that for
640 # options which we want to be single-valued, we allow the
641 # different config sources to override properly. See #835858.
642 foreach my $src (@gitcfgsources) {
643 next if $src eq 'cmdline';
644 # we do this ourselves since git doesn't handle it
646 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
649 open GITS, "-|", @cmd or die $!;
652 printdebug "=> ", (messagequote $_), "\n";
654 push @{ $gitcfgs{$src}{$`} }, $'; #';
658 or ($!==0 && $?==256)
663 sub git_get_config ($) {
665 foreach my $src (@gitcfgsources) {
666 my $l = $gitcfgs{$src}{$c};
667 printdebug"C $c ".(defined $l ?
668 join " ", map { messagequote "'$_'" } @$l :
672 @$l==1 or badcfg "multiple values for $c".
673 " (in $src git config)" if @$l > 1;
681 return undef if $c =~ /RETURN-UNDEF/;
682 my $v = git_get_config($c);
683 return $v if defined $v;
684 my $dv = $defcfg{$c};
686 printdebug "CD $c $dv\n" if $debuglevel >= 4;
690 badcfg "need value for one of: @_\n".
691 "$us: distro or suite appears not to be (properly) supported";
694 sub access_basedistro__noalias () {
695 if (defined $idistro) {
698 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
699 return $def if defined $def;
700 foreach my $src (@gitcfgsources, 'internal') {
701 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
703 foreach my $k (keys %$kl) {
704 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
706 next unless match_glob $dpat, $isuite;
710 return cfg("dgit.default.distro");
714 sub access_basedistro () {
715 my $noalias = access_basedistro__noalias();
716 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
717 return $canon // $noalias;
720 sub access_nomdistro () {
721 my $base = access_basedistro();
722 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
723 $r =~ m/^$distro_re$/ or badcfg
724 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
728 sub access_quirk () {
729 # returns (quirk name, distro to use instead or undef, quirk-specific info)
730 my $basedistro = access_basedistro();
731 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
733 if (defined $backports_quirk) {
734 my $re = $backports_quirk;
735 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
737 $re =~ s/\%/([-0-9a-z_]+)/
738 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
739 if ($isuite =~ m/^$re$/) {
740 return ('backports',"$basedistro-backports",$1);
743 return ('none',undef);
748 sub parse_cfg_bool ($$$) {
749 my ($what,$def,$v) = @_;
752 $v =~ m/^[ty1]/ ? 1 :
753 $v =~ m/^[fn0]/ ? 0 :
754 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
757 sub access_forpush_config () {
758 my $d = access_basedistro();
762 parse_cfg_bool('new-private-pushers', 0,
763 cfg("dgit-distro.$d.new-private-pushers",
766 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
769 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
770 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
771 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
772 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
775 sub access_forpush () {
776 $access_forpush //= access_forpush_config();
777 return $access_forpush;
781 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
782 badcfg "pushing but distro is configured readonly"
783 if access_forpush_config() eq '0';
785 $supplementary_message = <<'END' unless $we_are_responder;
786 Push failed, before we got started.
787 You can retry the push, after fixing the problem, if you like.
789 parseopts_late_defaults();
793 parseopts_late_defaults();
796 sub supplementary_message ($) {
798 if (!$we_are_responder) {
799 $supplementary_message = $msg;
801 } elsif ($protovsn >= 3) {
802 responder_send_command "supplementary-message ".length($msg)
804 print PO $msg or die $!;
808 sub access_distros () {
809 # Returns list of distros to try, in order
812 # 0. `instead of' distro name(s) we have been pointed to
813 # 1. the access_quirk distro, if any
814 # 2a. the user's specified distro, or failing that } basedistro
815 # 2b. the distro calculated from the suite }
816 my @l = access_basedistro();
818 my (undef,$quirkdistro) = access_quirk();
819 unshift @l, $quirkdistro;
820 unshift @l, $instead_distro;
821 @l = grep { defined } @l;
823 push @l, access_nomdistro();
825 if (access_forpush()) {
826 @l = map { ("$_/push", $_) } @l;
831 sub access_cfg_cfgs (@) {
834 # The nesting of these loops determines the search order. We put
835 # the key loop on the outside so that we search all the distros
836 # for each key, before going on to the next key. That means that
837 # if access_cfg is called with a more specific, and then a less
838 # specific, key, an earlier distro can override the less specific
839 # without necessarily overriding any more specific keys. (If the
840 # distro wants to override the more specific keys it can simply do
841 # so; whereas if we did the loop the other way around, it would be
842 # impossible to for an earlier distro to override a less specific
843 # key but not the more specific ones without restating the unknown
844 # values of the more specific keys.
847 # We have to deal with RETURN-UNDEF specially, so that we don't
848 # terminate the search prematurely.
850 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
853 foreach my $d (access_distros()) {
854 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
856 push @cfgs, map { "dgit.default.$_" } @realkeys;
863 my (@cfgs) = access_cfg_cfgs(@keys);
864 my $value = cfg(@cfgs);
868 sub access_cfg_bool ($$) {
869 my ($def, @keys) = @_;
870 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
873 sub string_to_ssh ($) {
875 if ($spec =~ m/\s/) {
876 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
882 sub access_cfg_ssh () {
883 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
884 if (!defined $gitssh) {
887 return string_to_ssh $gitssh;
891 sub access_runeinfo ($) {
893 return ": dgit ".access_basedistro()." $info ;";
896 sub access_someuserhost ($) {
898 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
899 defined($user) && length($user) or
900 $user = access_cfg("$some-user",'username');
901 my $host = access_cfg("$some-host");
902 return length($user) ? "$user\@$host" : $host;
905 sub access_gituserhost () {
906 return access_someuserhost('git');
909 sub access_giturl (;$) {
911 my $url = access_cfg('git-url','RETURN-UNDEF');
914 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
915 return undef unless defined $proto;
918 access_gituserhost().
919 access_cfg('git-path');
921 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
924 return "$url/$package$suffix";
927 sub parsecontrolfh ($$;$) {
928 my ($fh, $desc, $allowsigned) = @_;
929 our $dpkgcontrolhash_noissigned;
932 my %opts = ('name' => $desc);
933 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
934 $c = Dpkg::Control::Hash->new(%opts);
935 $c->parse($fh,$desc) or die "parsing of $desc failed";
936 last if $allowsigned;
937 last if $dpkgcontrolhash_noissigned;
938 my $issigned= $c->get_option('is_pgp_signed');
939 if (!defined $issigned) {
940 $dpkgcontrolhash_noissigned= 1;
941 seek $fh, 0,0 or die "seek $desc: $!";
942 } elsif ($issigned) {
943 fail "control file $desc is (already) PGP-signed. ".
944 " Note that dgit push needs to modify the .dsc and then".
945 " do the signature itself";
954 my ($file, $desc, $allowsigned) = @_;
955 my $fh = new IO::Handle;
956 open $fh, '<', $file or die "$file: $!";
957 my $c = parsecontrolfh($fh,$desc,$allowsigned);
958 $fh->error and die $!;
964 my ($dctrl,$field) = @_;
965 my $v = $dctrl->{$field};
966 return $v if defined $v;
967 fail "missing field $field in ".$dctrl->get_option('name');
971 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
972 my $p = new IO::Handle;
973 my @cmd = (qw(dpkg-parsechangelog), @_);
974 open $p, '-|', @cmd or die $!;
976 $?=0; $!=0; close $p or failedcmd @cmd;
980 sub commit_getclogp ($) {
981 # Returns the parsed changelog hashref for a particular commit
983 our %commit_getclogp_memo;
984 my $memo = $commit_getclogp_memo{$objid};
985 return $memo if $memo;
987 my $mclog = ".git/dgit/clog-$objid";
988 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
989 "$objid:debian/changelog";
990 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
995 defined $d or fail "getcwd failed: $!";
999 sub parse_dscdata () {
1000 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1001 printdebug Dumper($dscdata) if $debuglevel>1;
1002 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1003 printdebug Dumper($dsc) if $debuglevel>1;
1008 sub archive_query ($;@) {
1009 my ($method) = shift @_;
1010 fail "this operation does not support multiple comma-separated suites"
1012 my $query = access_cfg('archive-query','RETURN-UNDEF');
1013 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1016 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1019 sub archive_query_prepend_mirror {
1020 my $m = access_cfg('mirror');
1021 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1024 sub pool_dsc_subpath ($$) {
1025 my ($vsn,$component) = @_; # $package is implict arg
1026 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1027 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1030 sub cfg_apply_map ($$$) {
1031 my ($varref, $what, $mapspec) = @_;
1032 return unless $mapspec;
1034 printdebug "config $what EVAL{ $mapspec; }\n";
1036 eval "package Dgit::Config; $mapspec;";
1041 #---------- `ftpmasterapi' archive query method (nascent) ----------
1043 sub archive_api_query_cmd ($) {
1045 my @cmd = (@curl, qw(-sS));
1046 my $url = access_cfg('archive-query-url');
1047 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1049 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1050 foreach my $key (split /\:/, $keys) {
1051 $key =~ s/\%HOST\%/$host/g;
1053 fail "for $url: stat $key: $!" unless $!==ENOENT;
1056 fail "config requested specific TLS key but do not know".
1057 " how to get curl to use exactly that EE key ($key)";
1058 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1059 # # Sadly the above line does not work because of changes
1060 # # to gnutls. The real fix for #790093 may involve
1061 # # new curl options.
1064 # Fixing #790093 properly will involve providing a value
1065 # for this on clients.
1066 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1067 push @cmd, split / /, $kargs if defined $kargs;
1069 push @cmd, $url.$subpath;
1073 sub api_query ($$;$) {
1075 my ($data, $subpath, $ok404) = @_;
1076 badcfg "ftpmasterapi archive query method takes no data part"
1078 my @cmd = archive_api_query_cmd($subpath);
1079 my $url = $cmd[$#cmd];
1080 push @cmd, qw(-w %{http_code});
1081 my $json = cmdoutput @cmd;
1082 unless ($json =~ s/\d+\d+\d$//) {
1083 failedcmd_report_cmd undef, @cmd;
1084 fail "curl failed to print 3-digit HTTP code";
1087 return undef if $code eq '404' && $ok404;
1088 fail "fetch of $url gave HTTP code $code"
1089 unless $url =~ m#^file://# or $code =~ m/^2/;
1090 return decode_json($json);
1093 sub canonicalise_suite_ftpmasterapi {
1094 my ($proto,$data) = @_;
1095 my $suites = api_query($data, 'suites');
1097 foreach my $entry (@$suites) {
1099 my $v = $entry->{$_};
1100 defined $v && $v eq $isuite;
1101 } qw(codename name);
1102 push @matched, $entry;
1104 fail "unknown suite $isuite" unless @matched;
1107 @matched==1 or die "multiple matches for suite $isuite\n";
1108 $cn = "$matched[0]{codename}";
1109 defined $cn or die "suite $isuite info has no codename\n";
1110 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1112 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1117 sub archive_query_ftpmasterapi {
1118 my ($proto,$data) = @_;
1119 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1121 my $digester = Digest::SHA->new(256);
1122 foreach my $entry (@$info) {
1124 my $vsn = "$entry->{version}";
1125 my ($ok,$msg) = version_check $vsn;
1126 die "bad version: $msg\n" unless $ok;
1127 my $component = "$entry->{component}";
1128 $component =~ m/^$component_re$/ or die "bad component";
1129 my $filename = "$entry->{filename}";
1130 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1131 or die "bad filename";
1132 my $sha256sum = "$entry->{sha256sum}";
1133 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1134 push @rows, [ $vsn, "/pool/$component/$filename",
1135 $digester, $sha256sum ];
1137 die "bad ftpmaster api response: $@\n".Dumper($entry)
1140 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1141 return archive_query_prepend_mirror @rows;
1144 sub file_in_archive_ftpmasterapi {
1145 my ($proto,$data,$filename) = @_;
1146 my $pat = $filename;
1149 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1150 my $info = api_query($data, "file_in_archive/$pat", 1);
1153 #---------- `aptget' archive query method ----------
1156 our $aptget_releasefile;
1157 our $aptget_configpath;
1159 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1160 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1162 sub aptget_cache_clean {
1163 runcmd_ordryrun_local qw(sh -ec),
1164 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1168 sub aptget_lock_acquire () {
1169 my $lockfile = "$aptget_base/lock";
1170 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1171 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1174 sub aptget_prep ($) {
1176 return if defined $aptget_base;
1178 badcfg "aptget archive query method takes no data part"
1181 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1184 ensuredir "$cache/dgit";
1186 access_cfg('aptget-cachekey','RETURN-UNDEF')
1187 // access_nomdistro();
1189 $aptget_base = "$cache/dgit/aptget";
1190 ensuredir $aptget_base;
1192 my $quoted_base = $aptget_base;
1193 die "$quoted_base contains bad chars, cannot continue"
1194 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1196 ensuredir $aptget_base;
1198 aptget_lock_acquire();
1200 aptget_cache_clean();
1202 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1203 my $sourceslist = "source.list#$cachekey";
1205 my $aptsuites = $isuite;
1206 cfg_apply_map(\$aptsuites, 'suite map',
1207 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1209 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1210 printf SRCS "deb-src %s %s %s\n",
1211 access_cfg('mirror'),
1213 access_cfg('aptget-components')
1216 ensuredir "$aptget_base/cache";
1217 ensuredir "$aptget_base/lists";
1219 open CONF, ">", $aptget_configpath or die $!;
1221 Debug::NoLocking "true";
1222 APT::Get::List-Cleanup "false";
1223 #clear APT::Update::Post-Invoke-Success;
1224 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1225 Dir::State::Lists "$quoted_base/lists";
1226 Dir::Etc::preferences "$quoted_base/preferences";
1227 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1228 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1231 foreach my $key (qw(
1234 Dir::Cache::Archives
1235 Dir::Etc::SourceParts
1236 Dir::Etc::preferencesparts
1238 ensuredir "$aptget_base/$key";
1239 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1242 my $oldatime = (time // die $!) - 1;
1243 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1244 next unless stat_exists $oldlist;
1245 my ($mtime) = (stat _)[9];
1246 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1249 runcmd_ordryrun_local aptget_aptget(), qw(update);
1252 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1253 next unless stat_exists $oldlist;
1254 my ($atime) = (stat _)[8];
1255 next if $atime == $oldatime;
1256 push @releasefiles, $oldlist;
1258 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1259 @releasefiles = @inreleasefiles if @inreleasefiles;
1260 die "apt updated wrong number of Release files (@releasefiles), erk"
1261 unless @releasefiles == 1;
1263 ($aptget_releasefile) = @releasefiles;
1266 sub canonicalise_suite_aptget {
1267 my ($proto,$data) = @_;
1270 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1272 foreach my $name (qw(Codename Suite)) {
1273 my $val = $release->{$name};
1275 printdebug "release file $name: $val\n";
1276 $val =~ m/^$suite_re$/o or fail
1277 "Release file ($aptget_releasefile) specifies intolerable $name";
1278 cfg_apply_map(\$val, 'suite rmap',
1279 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1286 sub archive_query_aptget {
1287 my ($proto,$data) = @_;
1290 ensuredir "$aptget_base/source";
1291 foreach my $old (<$aptget_base/source/*.dsc>) {
1292 unlink $old or die "$old: $!";
1295 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1296 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1297 # avoids apt-get source failing with ambiguous error code
1299 runcmd_ordryrun_local
1300 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1301 aptget_aptget(), qw(--download-only --only-source source), $package;
1303 my @dscs = <$aptget_base/source/*.dsc>;
1304 fail "apt-get source did not produce a .dsc" unless @dscs;
1305 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1307 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1310 my $uri = "file://". uri_escape $dscs[0];
1311 $uri =~ s{\%2f}{/}gi;
1312 return [ (getfield $pre_dsc, 'Version'), $uri ];
1315 #---------- `dummyapicat' archive query method ----------
1317 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1318 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1320 sub file_in_archive_dummycatapi ($$$) {
1321 my ($proto,$data,$filename) = @_;
1322 my $mirror = access_cfg('mirror');
1323 $mirror =~ s#^file://#/# or die "$mirror ?";
1325 my @cmd = (qw(sh -ec), '
1327 find -name "$2" -print0 |
1329 ', qw(x), $mirror, $filename);
1330 debugcmd "-|", @cmd;
1331 open FIA, "-|", @cmd or die $!;
1334 printdebug "| $_\n";
1335 m/^(\w+) (\S+)$/ or die "$_ ?";
1336 push @out, { sha256sum => $1, filename => $2 };
1338 close FIA or die failedcmd @cmd;
1342 #---------- `madison' archive query method ----------
1344 sub archive_query_madison {
1345 return archive_query_prepend_mirror
1346 map { [ @$_[0..1] ] } madison_get_parse(@_);
1349 sub madison_get_parse {
1350 my ($proto,$data) = @_;
1351 die unless $proto eq 'madison';
1352 if (!length $data) {
1353 $data= access_cfg('madison-distro','RETURN-UNDEF');
1354 $data //= access_basedistro();
1356 $rmad{$proto,$data,$package} ||= cmdoutput
1357 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1358 my $rmad = $rmad{$proto,$data,$package};
1361 foreach my $l (split /\n/, $rmad) {
1362 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1363 \s*( [^ \t|]+ )\s* \|
1364 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1365 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1366 $1 eq $package or die "$rmad $package ?";
1373 $component = access_cfg('archive-query-default-component');
1375 $5 eq 'source' or die "$rmad ?";
1376 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1378 return sort { -version_compare($a->[0],$b->[0]); } @out;
1381 sub canonicalise_suite_madison {
1382 # madison canonicalises for us
1383 my @r = madison_get_parse(@_);
1385 "unable to canonicalise suite using package $package".
1386 " which does not appear to exist in suite $isuite;".
1387 " --existing-package may help";
1391 sub file_in_archive_madison { return undef; }
1393 #---------- `sshpsql' archive query method ----------
1396 my ($data,$runeinfo,$sql) = @_;
1397 if (!length $data) {
1398 $data= access_someuserhost('sshpsql').':'.
1399 access_cfg('sshpsql-dbname');
1401 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1402 my ($userhost,$dbname) = ($`,$'); #';
1404 my @cmd = (access_cfg_ssh, $userhost,
1405 access_runeinfo("ssh-psql $runeinfo").
1406 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1407 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1409 open P, "-|", @cmd or die $!;
1412 printdebug(">|$_|\n");
1415 $!=0; $?=0; close P or failedcmd @cmd;
1417 my $nrows = pop @rows;
1418 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1419 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1420 @rows = map { [ split /\|/, $_ ] } @rows;
1421 my $ncols = scalar @{ shift @rows };
1422 die if grep { scalar @$_ != $ncols } @rows;
1426 sub sql_injection_check {
1427 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1430 sub archive_query_sshpsql ($$) {
1431 my ($proto,$data) = @_;
1432 sql_injection_check $isuite, $package;
1433 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1434 SELECT source.version, component.name, files.filename, files.sha256sum
1436 JOIN src_associations ON source.id = src_associations.source
1437 JOIN suite ON suite.id = src_associations.suite
1438 JOIN dsc_files ON dsc_files.source = source.id
1439 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1440 JOIN component ON component.id = files_archive_map.component_id
1441 JOIN files ON files.id = dsc_files.file
1442 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1443 AND source.source='$package'
1444 AND files.filename LIKE '%.dsc';
1446 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1447 my $digester = Digest::SHA->new(256);
1449 my ($vsn,$component,$filename,$sha256sum) = @$_;
1450 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1452 return archive_query_prepend_mirror @rows;
1455 sub canonicalise_suite_sshpsql ($$) {
1456 my ($proto,$data) = @_;
1457 sql_injection_check $isuite;
1458 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1459 SELECT suite.codename
1460 FROM suite where suite_name='$isuite' or codename='$isuite';
1462 @rows = map { $_->[0] } @rows;
1463 fail "unknown suite $isuite" unless @rows;
1464 die "ambiguous $isuite: @rows ?" if @rows>1;
1468 sub file_in_archive_sshpsql ($$$) { return undef; }
1470 #---------- `dummycat' archive query method ----------
1472 sub canonicalise_suite_dummycat ($$) {
1473 my ($proto,$data) = @_;
1474 my $dpath = "$data/suite.$isuite";
1475 if (!open C, "<", $dpath) {
1476 $!==ENOENT or die "$dpath: $!";
1477 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1481 chomp or die "$dpath: $!";
1483 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1487 sub archive_query_dummycat ($$) {
1488 my ($proto,$data) = @_;
1489 canonicalise_suite();
1490 my $dpath = "$data/package.$csuite.$package";
1491 if (!open C, "<", $dpath) {
1492 $!==ENOENT or die "$dpath: $!";
1493 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1501 printdebug "dummycat query $csuite $package $dpath | $_\n";
1502 my @row = split /\s+/, $_;
1503 @row==2 or die "$dpath: $_ ?";
1506 C->error and die "$dpath: $!";
1508 return archive_query_prepend_mirror
1509 sort { -version_compare($a->[0],$b->[0]); } @rows;
1512 sub file_in_archive_dummycat () { return undef; }
1514 #---------- tag format handling ----------
1516 sub access_cfg_tagformats () {
1517 split /\,/, access_cfg('dgit-tag-format');
1520 sub access_cfg_tagformats_can_splitbrain () {
1521 my %y = map { $_ => 1 } access_cfg_tagformats;
1522 foreach my $needtf (qw(new maint)) {
1523 next if $y{$needtf};
1529 sub need_tagformat ($$) {
1530 my ($fmt, $why) = @_;
1531 fail "need to use tag format $fmt ($why) but also need".
1532 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1533 " - no way to proceed"
1534 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1535 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1538 sub select_tagformat () {
1540 return if $tagformatfn && !$tagformat_want;
1541 die 'bug' if $tagformatfn && $tagformat_want;
1542 # ... $tagformat_want assigned after previous select_tagformat
1544 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1545 printdebug "select_tagformat supported @supported\n";
1547 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1548 printdebug "select_tagformat specified @$tagformat_want\n";
1550 my ($fmt,$why,$override) = @$tagformat_want;
1552 fail "target distro supports tag formats @supported".
1553 " but have to use $fmt ($why)"
1555 or grep { $_ eq $fmt } @supported;
1557 $tagformat_want = undef;
1559 $tagformatfn = ${*::}{"debiantag_$fmt"};
1561 fail "trying to use unknown tag format \`$fmt' ($why) !"
1562 unless $tagformatfn;
1565 #---------- archive query entrypoints and rest of program ----------
1567 sub canonicalise_suite () {
1568 return if defined $csuite;
1569 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1570 $csuite = archive_query('canonicalise_suite');
1571 if ($isuite ne $csuite) {
1572 progress "canonical suite name for $isuite is $csuite";
1574 progress "canonical suite name is $csuite";
1578 sub get_archive_dsc () {
1579 canonicalise_suite();
1580 my @vsns = archive_query('archive_query');
1581 foreach my $vinfo (@vsns) {
1582 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1583 $dscurl = $vsn_dscurl;
1584 $dscdata = url_get($dscurl);
1586 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1591 $digester->add($dscdata);
1592 my $got = $digester->hexdigest();
1594 fail "$dscurl has hash $got but".
1595 " archive told us to expect $digest";
1598 my $fmt = getfield $dsc, 'Format';
1599 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1600 "unsupported source format $fmt, sorry";
1602 $dsc_checked = !!$digester;
1603 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1607 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1610 sub check_for_git ();
1611 sub check_for_git () {
1613 my $how = access_cfg('git-check');
1614 if ($how eq 'ssh-cmd') {
1616 (access_cfg_ssh, access_gituserhost(),
1617 access_runeinfo("git-check $package").
1618 " set -e; cd ".access_cfg('git-path').";".
1619 " if test -d $package.git; then echo 1; else echo 0; fi");
1620 my $r= cmdoutput @cmd;
1621 if (defined $r and $r =~ m/^divert (\w+)$/) {
1623 my ($usedistro,) = access_distros();
1624 # NB that if we are pushing, $usedistro will be $distro/push
1625 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1626 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1627 progress "diverting to $divert (using config for $instead_distro)";
1628 return check_for_git();
1630 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1632 } elsif ($how eq 'url') {
1633 my $prefix = access_cfg('git-check-url','git-url');
1634 my $suffix = access_cfg('git-check-suffix','git-suffix',
1635 'RETURN-UNDEF') // '.git';
1636 my $url = "$prefix/$package$suffix";
1637 my @cmd = (@curl, qw(-sS -I), $url);
1638 my $result = cmdoutput @cmd;
1639 $result =~ s/^\S+ 200 .*\n\r?\n//;
1640 # curl -sS -I with https_proxy prints
1641 # HTTP/1.0 200 Connection established
1642 $result =~ m/^\S+ (404|200) /s or
1643 fail "unexpected results from git check query - ".
1644 Dumper($prefix, $result);
1646 if ($code eq '404') {
1648 } elsif ($code eq '200') {
1653 } elsif ($how eq 'true') {
1655 } elsif ($how eq 'false') {
1658 badcfg "unknown git-check \`$how'";
1662 sub create_remote_git_repo () {
1663 my $how = access_cfg('git-create');
1664 if ($how eq 'ssh-cmd') {
1666 (access_cfg_ssh, access_gituserhost(),
1667 access_runeinfo("git-create $package").
1668 "set -e; cd ".access_cfg('git-path').";".
1669 " cp -a _template $package.git");
1670 } elsif ($how eq 'true') {
1673 badcfg "unknown git-create \`$how'";
1677 our ($dsc_hash,$lastpush_mergeinput);
1678 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1680 our $ud = '.git/dgit/unpack';
1690 sub mktree_in_ud_here () {
1691 runcmd qw(git init -q);
1692 runcmd qw(git config gc.auto 0);
1693 rmtree('.git/objects');
1694 symlink '../../../../objects','.git/objects' or die $!;
1697 sub git_write_tree () {
1698 my $tree = cmdoutput @git, qw(write-tree);
1699 $tree =~ m/^\w+$/ or die "$tree ?";
1703 sub git_add_write_tree () {
1704 runcmd @git, qw(add -Af .);
1705 return git_write_tree();
1708 sub remove_stray_gits ($) {
1710 my @gitscmd = qw(find -name .git -prune -print0);
1711 debugcmd "|",@gitscmd;
1712 open GITS, "-|", @gitscmd or die $!;
1717 print STDERR "$us: warning: removing from $what: ",
1718 (messagequote $_), "\n";
1722 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1725 sub mktree_in_ud_from_only_subdir ($;$) {
1726 my ($what,$raw) = @_;
1728 # changes into the subdir
1730 die "expected one subdir but found @dirs ?" unless @dirs==1;
1731 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1735 remove_stray_gits($what);
1736 mktree_in_ud_here();
1738 my ($format, $fopts) = get_source_format();
1739 if (madformat($format)) {
1744 my $tree=git_add_write_tree();
1745 return ($tree,$dir);
1748 our @files_csum_info_fields =
1749 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1750 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1751 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1753 sub dsc_files_info () {
1754 foreach my $csumi (@files_csum_info_fields) {
1755 my ($fname, $module, $method) = @$csumi;
1756 my $field = $dsc->{$fname};
1757 next unless defined $field;
1758 eval "use $module; 1;" or die $@;
1760 foreach (split /\n/, $field) {
1762 m/^(\w+) (\d+) (\S+)$/ or
1763 fail "could not parse .dsc $fname line \`$_'";
1764 my $digester = eval "$module"."->$method;" or die $@;
1769 Digester => $digester,
1774 fail "missing any supported Checksums-* or Files field in ".
1775 $dsc->get_option('name');
1779 map { $_->{Filename} } dsc_files_info();
1782 sub files_compare_inputs (@) {
1787 my $showinputs = sub {
1788 return join "; ", map { $_->get_option('name') } @$inputs;
1791 foreach my $in (@$inputs) {
1793 my $in_name = $in->get_option('name');
1795 printdebug "files_compare_inputs $in_name\n";
1797 foreach my $csumi (@files_csum_info_fields) {
1798 my ($fname) = @$csumi;
1799 printdebug "files_compare_inputs $in_name $fname\n";
1801 my $field = $in->{$fname};
1802 next unless defined $field;
1805 foreach (split /\n/, $field) {
1808 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1809 fail "could not parse $in_name $fname line \`$_'";
1811 printdebug "files_compare_inputs $in_name $fname $f\n";
1815 my $re = \ $record{$f}{$fname};
1817 $fchecked{$f}{$in_name} = 1;
1819 fail "hash or size of $f varies in $fname fields".
1820 " (between: ".$showinputs->().")";
1825 @files = sort @files;
1826 $expected_files //= \@files;
1827 "@$expected_files" eq "@files" or
1828 fail "file list in $in_name varies between hash fields!";
1831 fail "$in_name has no files list field(s)";
1833 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1836 grep { keys %$_ == @$inputs-1 } values %fchecked
1837 or fail "no file appears in all file lists".
1838 " (looked in: ".$showinputs->().")";
1841 sub is_orig_file_in_dsc ($$) {
1842 my ($f, $dsc_files_info) = @_;
1843 return 0 if @$dsc_files_info <= 1;
1844 # One file means no origs, and the filename doesn't have a "what
1845 # part of dsc" component. (Consider versions ending `.orig'.)
1846 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1850 sub is_orig_file_of_vsn ($$) {
1851 my ($f, $upstreamvsn) = @_;
1852 my $base = srcfn $upstreamvsn, '';
1853 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1857 sub changes_update_origs_from_dsc ($$$$) {
1858 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1860 printdebug "checking origs needed ($upstreamvsn)...\n";
1861 $_ = getfield $changes, 'Files';
1862 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1863 fail "cannot find section/priority from .changes Files field";
1864 my $placementinfo = $1;
1866 printdebug "checking origs needed placement '$placementinfo'...\n";
1867 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1868 $l =~ m/\S+$/ or next;
1870 printdebug "origs $file | $l\n";
1871 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1872 printdebug "origs $file is_orig\n";
1873 my $have = archive_query('file_in_archive', $file);
1874 if (!defined $have) {
1876 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1882 printdebug "origs $file \$#\$have=$#$have\n";
1883 foreach my $h (@$have) {
1886 foreach my $csumi (@files_csum_info_fields) {
1887 my ($fname, $module, $method, $archivefield) = @$csumi;
1888 next unless defined $h->{$archivefield};
1889 $_ = $dsc->{$fname};
1890 next unless defined;
1891 m/^(\w+) .* \Q$file\E$/m or
1892 fail ".dsc $fname missing entry for $file";
1893 if ($h->{$archivefield} eq $1) {
1897 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1900 die "$file ".Dumper($h)." ?!" if $same && @differ;
1903 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1906 printdebug "origs $file f.same=$found_same".
1907 " #f._differ=$#found_differ\n";
1908 if (@found_differ && !$found_same) {
1910 "archive contains $file with different checksum",
1913 # Now we edit the changes file to add or remove it
1914 foreach my $csumi (@files_csum_info_fields) {
1915 my ($fname, $module, $method, $archivefield) = @$csumi;
1916 next unless defined $changes->{$fname};
1918 # in archive, delete from .changes if it's there
1919 $changed{$file} = "removed" if
1920 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1921 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1922 # not in archive, but it's here in the .changes
1924 my $dsc_data = getfield $dsc, $fname;
1925 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1927 $extra =~ s/ \d+ /$&$placementinfo /
1928 or die "$fname $extra >$dsc_data< ?"
1929 if $fname eq 'Files';
1930 $changes->{$fname} .= "\n". $extra;
1931 $changed{$file} = "added";
1936 foreach my $file (keys %changed) {
1938 "edited .changes for archive .orig contents: %s %s",
1939 $changed{$file}, $file;
1941 my $chtmp = "$changesfile.tmp";
1942 $changes->save($chtmp);
1944 rename $chtmp,$changesfile or die "$changesfile $!";
1946 progress "[new .changes left in $changesfile]";
1949 progress "$changesfile already has appropriate .orig(s) (if any)";
1953 sub make_commit ($) {
1955 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1958 sub make_commit_text ($) {
1961 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1963 print Dumper($text) if $debuglevel > 1;
1964 my $child = open2($out, $in, @cmd) or die $!;
1967 print $in $text or die $!;
1968 close $in or die $!;
1970 $h =~ m/^\w+$/ or die;
1972 printdebug "=> $h\n";
1975 waitpid $child, 0 == $child or die "$child $!";
1976 $? and failedcmd @cmd;
1980 sub clogp_authline ($) {
1982 my $author = getfield $clogp, 'Maintainer';
1983 $author =~ s#,.*##ms;
1984 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1985 my $authline = "$author $date";
1986 $authline =~ m/$git_authline_re/o or
1987 fail "unexpected commit author line format \`$authline'".
1988 " (was generated from changelog Maintainer field)";
1989 return ($1,$2,$3) if wantarray;
1993 sub vendor_patches_distro ($$) {
1994 my ($checkdistro, $what) = @_;
1995 return unless defined $checkdistro;
1997 my $series = "debian/patches/\L$checkdistro\E.series";
1998 printdebug "checking for vendor-specific $series ($what)\n";
2000 if (!open SERIES, "<", $series) {
2001 die "$series $!" unless $!==ENOENT;
2010 Unfortunately, this source package uses a feature of dpkg-source where
2011 the same source package unpacks to different source code on different
2012 distros. dgit cannot safely operate on such packages on affected
2013 distros, because the meaning of source packages is not stable.
2015 Please ask the distro/maintainer to remove the distro-specific series
2016 files and use a different technique (if necessary, uploading actually
2017 different packages, if different distros are supposed to have
2021 fail "Found active distro-specific series file for".
2022 " $checkdistro ($what): $series, cannot continue";
2024 die "$series $!" if SERIES->error;
2028 sub check_for_vendor_patches () {
2029 # This dpkg-source feature doesn't seem to be documented anywhere!
2030 # But it can be found in the changelog (reformatted):
2032 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2033 # Author: Raphael Hertzog <hertzog@debian.org>
2034 # Date: Sun Oct 3 09:36:48 2010 +0200
2036 # dpkg-source: correctly create .pc/.quilt_series with alternate
2039 # If you have debian/patches/ubuntu.series and you were
2040 # unpacking the source package on ubuntu, quilt was still
2041 # directed to debian/patches/series instead of
2042 # debian/patches/ubuntu.series.
2044 # debian/changelog | 3 +++
2045 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2046 # 2 files changed, 6 insertions(+), 1 deletion(-)
2049 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2050 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2051 "Dpkg::Vendor \`current vendor'");
2052 vendor_patches_distro(access_basedistro(),
2053 "(base) distro being accessed");
2054 vendor_patches_distro(access_nomdistro(),
2055 "(nominal) distro being accessed");
2058 sub generate_commits_from_dsc () {
2059 # See big comment in fetch_from_archive, below.
2060 # See also README.dsc-import.
2064 my @dfi = dsc_files_info();
2065 foreach my $fi (@dfi) {
2066 my $f = $fi->{Filename};
2067 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2069 printdebug "considering linking $f: ";
2071 link_ltarget "../../../../$f", $f
2072 or ((printdebug "($!) "), 0)
2076 printdebug "linked.\n";
2078 complete_file_from_dsc('.', $fi)
2081 if (is_orig_file_in_dsc($f, \@dfi)) {
2082 link $f, "../../../../$f"
2088 # We unpack and record the orig tarballs first, so that we only
2089 # need disk space for one private copy of the unpacked source.
2090 # But we can't make them into commits until we have the metadata
2091 # from the debian/changelog, so we record the tree objects now and
2092 # make them into commits later.
2094 my $upstreamv = upstreamversion $dsc->{version};
2095 my $orig_f_base = srcfn $upstreamv, '';
2097 foreach my $fi (@dfi) {
2098 # We actually import, and record as a commit, every tarball
2099 # (unless there is only one file, in which case there seems
2102 my $f = $fi->{Filename};
2103 printdebug "import considering $f ";
2104 (printdebug "only one dfi\n"), next if @dfi == 1;
2105 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2106 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2110 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2112 printdebug "Y ", (join ' ', map { $_//"(none)" }
2113 $compr_ext, $orig_f_part
2116 my $input = new IO::File $f, '<' or die "$f $!";
2120 if (defined $compr_ext) {
2122 Dpkg::Compression::compression_guess_from_filename $f;
2123 fail "Dpkg::Compression cannot handle file $f in source package"
2124 if defined $compr_ext && !defined $cname;
2126 new Dpkg::Compression::Process compression => $cname;
2127 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2128 my $compr_fh = new IO::Handle;
2129 my $compr_pid = open $compr_fh, "-|" // die $!;
2131 open STDIN, "<&", $input or die $!;
2133 die "dgit (child): exec $compr_cmd[0]: $!\n";
2138 rmtree "_unpack-tar";
2139 mkdir "_unpack-tar" or die $!;
2140 my @tarcmd = qw(tar -x -f -
2141 --no-same-owner --no-same-permissions
2142 --no-acls --no-xattrs --no-selinux);
2143 my $tar_pid = fork // die $!;
2145 chdir "_unpack-tar" or die $!;
2146 open STDIN, "<&", $input or die $!;
2148 die "dgit (child): exec $tarcmd[0]: $!";
2150 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2151 !$? or failedcmd @tarcmd;
2154 (@compr_cmd ? failedcmd @compr_cmd
2156 # finally, we have the results in "tarball", but maybe
2157 # with the wrong permissions
2159 runcmd qw(chmod -R +rwX _unpack-tar);
2160 changedir "_unpack-tar";
2161 remove_stray_gits($f);
2162 mktree_in_ud_here();
2164 my ($tree) = git_add_write_tree();
2165 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2166 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2168 printdebug "one subtree $1\n";
2170 printdebug "multiple subtrees\n";
2173 rmtree "_unpack-tar";
2175 my $ent = [ $f, $tree ];
2177 Orig => !!$orig_f_part,
2178 Sort => (!$orig_f_part ? 2 :
2179 $orig_f_part =~ m/-/g ? 1 :
2187 # put any without "_" first (spec is not clear whether files
2188 # are always in the usual order). Tarballs without "_" are
2189 # the main orig or the debian tarball.
2190 $a->{Sort} <=> $b->{Sort} or
2194 my $any_orig = grep { $_->{Orig} } @tartrees;
2196 my $dscfn = "$package.dsc";
2198 my $treeimporthow = 'package';
2200 open D, ">", $dscfn or die "$dscfn: $!";
2201 print D $dscdata or die "$dscfn: $!";
2202 close D or die "$dscfn: $!";
2203 my @cmd = qw(dpkg-source);
2204 push @cmd, '--no-check' if $dsc_checked;
2205 if (madformat $dsc->{format}) {
2206 push @cmd, '--skip-patches';
2207 $treeimporthow = 'unpatched';
2209 push @cmd, qw(-x --), $dscfn;
2212 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2213 if (madformat $dsc->{format}) {
2214 check_for_vendor_patches();
2218 if (madformat $dsc->{format}) {
2219 my @pcmd = qw(dpkg-source --before-build .);
2220 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2222 $dappliedtree = git_add_write_tree();
2225 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2226 debugcmd "|",@clogcmd;
2227 open CLOGS, "-|", @clogcmd or die $!;
2232 printdebug "import clog search...\n";
2235 my $stanzatext = do { local $/=""; <CLOGS>; };
2236 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2237 last if !defined $stanzatext;
2239 my $desc = "package changelog, entry no.$.";
2240 open my $stanzafh, "<", \$stanzatext or die;
2241 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2242 $clogp //= $thisstanza;
2244 printdebug "import clog $thisstanza->{version} $desc...\n";
2246 last if !$any_orig; # we don't need $r1clogp
2248 # We look for the first (most recent) changelog entry whose
2249 # version number is lower than the upstream version of this
2250 # package. Then the last (least recent) previous changelog
2251 # entry is treated as the one which introduced this upstream
2252 # version and used for the synthetic commits for the upstream
2255 # One might think that a more sophisticated algorithm would be
2256 # necessary. But: we do not want to scan the whole changelog
2257 # file. Stopping when we see an earlier version, which
2258 # necessarily then is an earlier upstream version, is the only
2259 # realistic way to do that. Then, either the earliest
2260 # changelog entry we have seen so far is indeed the earliest
2261 # upload of this upstream version; or there are only changelog
2262 # entries relating to later upstream versions (which is not
2263 # possible unless the changelog and .dsc disagree about the
2264 # version). Then it remains to choose between the physically
2265 # last entry in the file, and the one with the lowest version
2266 # number. If these are not the same, we guess that the
2267 # versions were created in a non-monotic order rather than
2268 # that the changelog entries have been misordered.
2270 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2272 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2273 $r1clogp = $thisstanza;
2275 printdebug "import clog $r1clogp->{version} becomes r1\n";
2277 die $! if CLOGS->error;
2278 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2280 $clogp or fail "package changelog has no entries!";
2282 my $authline = clogp_authline $clogp;
2283 my $changes = getfield $clogp, 'Changes';
2284 my $cversion = getfield $clogp, 'Version';
2287 $r1clogp //= $clogp; # maybe there's only one entry;
2288 my $r1authline = clogp_authline $r1clogp;
2289 # Strictly, r1authline might now be wrong if it's going to be
2290 # unused because !$any_orig. Whatever.
2292 printdebug "import tartrees authline $authline\n";
2293 printdebug "import tartrees r1authline $r1authline\n";
2295 foreach my $tt (@tartrees) {
2296 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2298 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2301 committer $r1authline
2305 [dgit import orig $tt->{F}]
2313 [dgit import tarball $package $cversion $tt->{F}]
2318 printdebug "import main commit\n";
2320 open C, ">../commit.tmp" or die $!;
2321 print C <<END or die $!;
2324 print C <<END or die $! foreach @tartrees;
2327 print C <<END or die $!;
2333 [dgit import $treeimporthow $package $cversion]
2337 my $rawimport_hash = make_commit qw(../commit.tmp);
2339 if (madformat $dsc->{format}) {
2340 printdebug "import apply patches...\n";
2342 # regularise the state of the working tree so that
2343 # the checkout of $rawimport_hash works nicely.
2344 my $dappliedcommit = make_commit_text(<<END);
2351 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2353 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2355 # We need the answers to be reproducible
2356 my @authline = clogp_authline($clogp);
2357 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2358 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2359 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2360 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2361 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2362 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2364 my $path = $ENV{PATH} or die;
2366 foreach my $use_absurd (qw(0 1)) {
2367 runcmd @git, qw(checkout -q unpa);
2368 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2369 local $ENV{PATH} = $path;
2372 progress "warning: $@";
2373 $path = "$absurdity:$path";
2374 progress "$us: trying slow absurd-git-apply...";
2375 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2380 die "forbid absurd git-apply\n" if $use_absurd
2381 && forceing [qw(import-gitapply-no-absurd)];
2382 die "only absurd git-apply!\n" if !$use_absurd
2383 && forceing [qw(import-gitapply-absurd)];
2385 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2386 local $ENV{PATH} = $path if $use_absurd;
2388 my @showcmd = (gbp_pq, qw(import));
2389 my @realcmd = shell_cmd
2390 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2391 debugcmd "+",@realcmd;
2392 if (system @realcmd) {
2393 die +(shellquote @showcmd).
2395 failedcmd_waitstatus()."\n";
2398 my $gapplied = git_rev_parse('HEAD');
2399 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2400 $gappliedtree eq $dappliedtree or
2402 gbp-pq import and dpkg-source disagree!
2403 gbp-pq import gave commit $gapplied
2404 gbp-pq import gave tree $gappliedtree
2405 dpkg-source --before-build gave tree $dappliedtree
2407 $rawimport_hash = $gapplied;
2412 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2417 progress "synthesised git commit from .dsc $cversion";
2419 my $rawimport_mergeinput = {
2420 Commit => $rawimport_hash,
2421 Info => "Import of source package",
2423 my @output = ($rawimport_mergeinput);
2425 if ($lastpush_mergeinput) {
2426 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2427 my $oversion = getfield $oldclogp, 'Version';
2429 version_compare($oversion, $cversion);
2431 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2432 { Message => <<END, ReverseParents => 1 });
2433 Record $package ($cversion) in archive suite $csuite
2435 } elsif ($vcmp > 0) {
2436 print STDERR <<END or die $!;
2438 Version actually in archive: $cversion (older)
2439 Last version pushed with dgit: $oversion (newer or same)
2442 @output = $lastpush_mergeinput;
2444 # Same version. Use what's in the server git branch,
2445 # discarding our own import. (This could happen if the
2446 # server automatically imports all packages into git.)
2447 @output = $lastpush_mergeinput;
2450 changedir '../../../..';
2455 sub complete_file_from_dsc ($$) {
2456 our ($dstdir, $fi) = @_;
2457 # Ensures that we have, in $dir, the file $fi, with the correct
2458 # contents. (Downloading it from alongside $dscurl if necessary.)
2460 my $f = $fi->{Filename};
2461 my $tf = "$dstdir/$f";
2464 if (stat_exists $tf) {
2465 progress "using existing $f";
2467 printdebug "$tf does not exist, need to fetch\n";
2469 $furl =~ s{/[^/]+$}{};
2471 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2472 die "$f ?" if $f =~ m#/#;
2473 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2474 return 0 if !act_local();
2478 open F, "<", "$tf" or die "$tf: $!";
2479 $fi->{Digester}->reset();
2480 $fi->{Digester}->addfile(*F);
2481 F->error and die $!;
2482 my $got = $fi->{Digester}->hexdigest();
2483 $got eq $fi->{Hash} or
2484 fail "file $f has hash $got but .dsc".
2485 " demands hash $fi->{Hash} ".
2486 ($downloaded ? "(got wrong file from archive!)"
2487 : "(perhaps you should delete this file?)");
2492 sub ensure_we_have_orig () {
2493 my @dfi = dsc_files_info();
2494 foreach my $fi (@dfi) {
2495 my $f = $fi->{Filename};
2496 next unless is_orig_file_in_dsc($f, \@dfi);
2497 complete_file_from_dsc('..', $fi)
2502 #---------- git fetch ----------
2504 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2505 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2507 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2508 # locally fetched refs because they have unhelpful names and clutter
2509 # up gitk etc. So we track whether we have "used up" head ref (ie,
2510 # whether we have made another local ref which refers to this object).
2512 # (If we deleted them unconditionally, then we might end up
2513 # re-fetching the same git objects each time dgit fetch was run.)
2515 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
2516 # in git_fetch_us to fetch the refs in question, and possibly a call
2517 # to lrfetchref_used.
2519 our (%lrfetchrefs_f, %lrfetchrefs_d);
2520 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2522 sub lrfetchref_used ($) {
2523 my ($fullrefname) = @_;
2524 my $objid = $lrfetchrefs_f{$fullrefname};
2525 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2528 sub git_lrfetch_sane {
2529 my ($supplementary, @specs) = @_;
2530 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2531 # at least as regards @specs. Also leave the results in
2532 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2533 # able to clean these up.
2535 # With $supplementary==1, @specs must not contain wildcards
2536 # and we add to our previous fetches (non-atomically).
2538 # This is rather miserable:
2539 # When git fetch --prune is passed a fetchspec ending with a *,
2540 # it does a plausible thing. If there is no * then:
2541 # - it matches subpaths too, even if the supplied refspec
2542 # starts refs, and behaves completely madly if the source
2543 # has refs/refs/something. (See, for example, Debian #NNNN.)
2544 # - if there is no matching remote ref, it bombs out the whole
2546 # We want to fetch a fixed ref, and we don't know in advance
2547 # if it exists, so this is not suitable.
2549 # Our workaround is to use git ls-remote. git ls-remote has its
2550 # own qairks. Notably, it has the absurd multi-tail-matching
2551 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2552 # refs/refs/foo etc.
2554 # Also, we want an idempotent snapshot, but we have to make two
2555 # calls to the remote: one to git ls-remote and to git fetch. The
2556 # solution is use git ls-remote to obtain a target state, and
2557 # git fetch to try to generate it. If we don't manage to generate
2558 # the target state, we try again.
2560 my $url = access_giturl();
2562 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2564 my $specre = join '|', map {
2567 my $wildcard = $x =~ s/\\\*$/.*/;
2568 die if $wildcard && $supplementary;
2571 printdebug "git_lrfetch_sane specre=$specre\n";
2572 my $wanted_rref = sub {
2574 return m/^(?:$specre)$/;
2577 my $fetch_iteration = 0;
2580 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2581 if (++$fetch_iteration > 10) {
2582 fail "too many iterations trying to get sane fetch!";
2585 my @look = map { "refs/$_" } @specs;
2586 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2590 open GITLS, "-|", @lcmd or die $!;
2592 printdebug "=> ", $_;
2593 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2594 my ($objid,$rrefname) = ($1,$2);
2595 if (!$wanted_rref->($rrefname)) {
2597 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2601 $wantr{$rrefname} = $objid;
2604 close GITLS or failedcmd @lcmd;
2606 # OK, now %want is exactly what we want for refs in @specs
2608 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2609 "+refs/$_:".lrfetchrefs."/$_";
2612 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2614 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2615 runcmd_ordryrun_local @fcmd if @fspecs;
2617 if (!$supplementary) {
2618 %lrfetchrefs_f = ();
2622 git_for_each_ref(lrfetchrefs, sub {
2623 my ($objid,$objtype,$lrefname,$reftail) = @_;
2624 $lrfetchrefs_f{$lrefname} = $objid;
2625 $objgot{$objid} = 1;
2628 if ($supplementary) {
2632 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2633 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2634 if (!exists $wantr{$rrefname}) {
2635 if ($wanted_rref->($rrefname)) {
2637 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2641 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2644 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2645 delete $lrfetchrefs_f{$lrefname};
2649 foreach my $rrefname (sort keys %wantr) {
2650 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2651 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2652 my $want = $wantr{$rrefname};
2653 next if $got eq $want;
2654 if (!defined $objgot{$want}) {
2656 warning: git ls-remote suggests we want $lrefname
2657 warning: and it should refer to $want
2658 warning: but git fetch didn't fetch that object to any relevant ref.
2659 warning: This may be due to a race with someone updating the server.
2660 warning: Will try again...
2662 next FETCH_ITERATION;
2665 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2667 runcmd_ordryrun_local @git, qw(update-ref -m),
2668 "dgit fetch git fetch fixup", $lrefname, $want;
2669 $lrfetchrefs_f{$lrefname} = $want;
2673 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2674 Dumper(\%lrfetchrefs_f);
2677 sub git_fetch_us () {
2678 # Want to fetch only what we are going to use, unless
2679 # deliberately-not-ff, in which case we must fetch everything.
2681 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2683 (quiltmode_splitbrain
2684 ? (map { $_->('*',access_nomdistro) }
2685 \&debiantag_new, \&debiantag_maintview)
2686 : debiantags('*',access_nomdistro));
2687 push @specs, server_branch($csuite);
2688 push @specs, $rewritemap;
2689 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2691 git_lrfetch_sane 0, @specs;
2694 my @tagpats = debiantags('*',access_nomdistro);
2696 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2697 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2698 printdebug "currently $fullrefname=$objid\n";
2699 $here{$fullrefname} = $objid;
2701 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2702 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2703 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2704 printdebug "offered $lref=$objid\n";
2705 if (!defined $here{$lref}) {
2706 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2707 runcmd_ordryrun_local @upd;
2708 lrfetchref_used $fullrefname;
2709 } elsif ($here{$lref} eq $objid) {
2710 lrfetchref_used $fullrefname;
2713 "Not updateting $lref from $here{$lref} to $objid.\n";
2718 #---------- dsc and archive handling ----------
2720 sub mergeinfo_getclogp ($) {
2721 # Ensures thit $mi->{Clogp} exists and returns it
2723 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2726 sub mergeinfo_version ($) {
2727 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2730 sub fetch_from_archive_record_1 ($) {
2732 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2733 'DGIT_ARCHIVE', $hash;
2734 cmdoutput @git, qw(log -n2), $hash;
2735 # ... gives git a chance to complain if our commit is malformed
2738 sub fetch_from_archive_record_2 ($) {
2740 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2744 dryrun_report @upd_cmd;
2748 sub parse_dsc_field ($$) {
2749 my ($dsc, $what) = @_;
2751 foreach my $field (@ourdscfield) {
2752 $f = $dsc->{$field};
2756 progress "$what: NO git hash";
2757 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2758 = $f =~ m/^(\w+) ($distro_re) ($versiontag_re) (\S+)(?:\s|$)/) {
2759 progress "$what: specified git info ($dsc_distro)";
2760 $dsc_hint_tag = [ $dsc_hint_tag ];
2761 } elsif ($f =~ m/^\w+\s*$/) {
2763 $dsc_distro //= 'debian';
2764 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2766 progress "$what: specified git hash";
2768 fail "$what: invalid Dgit info";
2772 sub resolve_dsc_field_commit ($$) {
2773 my ($already_distro, $already_mapref) = @_;
2775 return unless defined $dsc_hash;
2778 defined $already_mapref &&
2779 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2780 ? $already_mapref : undef;
2784 my ($what, @fetch) = @_;
2786 local $idistro = $dsc_distro;
2787 my $lrf = lrfetchrefs;
2789 if (!$chase_dsc_distro) {
2791 "not chasing .dsc distro $dsc_distro: not fetching $what";
2796 ".dsc names distro $dsc_distro: fetching $what";
2798 my $url = access_giturl();
2799 if (!defined $url) {
2800 defined $dsc_hint_url or fail <<END;
2801 .dsc Dgit metadata is in context of distro $dsc_distro
2802 for which we have no configured url and .dsc provides no hint
2805 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2806 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2807 parse_cfg_bool "dsc-url-proto-ok", 'false',
2808 cfg("dgit.dsc-url-proto-ok.$proto",
2809 "dgit.default.dsc-url-proto-ok")
2811 .dsc Dgit metadata is in context of distro $dsc_distro
2812 for which we have no configured url;
2813 .dsc provices hinted url with protocol $proto which is unsafe.
2814 (can be overridden by config - consult documentation)
2816 $url = $dsc_hint_url;
2819 git_lrfetch_sane 1, @fetch;
2824 if (parse_cfg_bool 'rewrite-map-enable', 'true',
2825 access_cfg('rewrite-map-enable', 'RETURN-UNDEF')) {
2826 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2827 $mapref = $lrf.'/'.$rewritemap;
2828 my $rewritemapdata = git_cat_file $mapref.':map';
2829 if (defined $rewritemapdata
2830 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2832 "server's git history rewrite map contains a relevant entry!";
2835 if (defined $dsc_hash) {
2836 progress "using rewritten git hash in place of .dsc value";
2838 progress "server data says .dsc hash is to be disregarded";
2843 if (!defined git_cat_file $dsc_hash) {
2844 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2845 my $lrf = $do_fetch->("additional commits", @tags) &&
2846 defined git_cat_file $dsc_hash
2848 .dsc Dgit metadata requires commit $dsc_hash
2849 but we could not obtain that object anywhere.
2851 foreach my $t (@tags) {
2852 my $fullrefname = $lrf.'/'.$t;
2853 print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2854 next unless $lrfetchrefs_f{$fullrefname};
2855 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2856 lrfetchref_used $fullrefname;
2861 sub fetch_from_archive () {
2862 ensure_setup_existing_tree();
2864 # Ensures that lrref() is what is actually in the archive, one way
2865 # or another, according to us - ie this client's
2866 # appropritaely-updated archive view. Also returns the commit id.
2867 # If there is nothing in the archive, leaves lrref alone and
2868 # returns undef. git_fetch_us must have already been called.
2872 parse_dsc_field($dsc, 'last upload to archive');
2873 resolve_dsc_field_commit access_basedistro,
2874 lrfetchrefs."/".$rewritemap
2876 progress "no version available from the archive";
2879 # If the archive's .dsc has a Dgit field, there are three
2880 # relevant git commitids we need to choose between and/or merge
2882 # 1. $dsc_hash: the Dgit field from the archive
2883 # 2. $lastpush_hash: the suite branch on the dgit git server
2884 # 3. $lastfetch_hash: our local tracking brach for the suite
2886 # These may all be distinct and need not be in any fast forward
2889 # If the dsc was pushed to this suite, then the server suite
2890 # branch will have been updated; but it might have been pushed to
2891 # a different suite and copied by the archive. Conversely a more
2892 # recent version may have been pushed with dgit but not appeared
2893 # in the archive (yet).
2895 # $lastfetch_hash may be awkward because archive imports
2896 # (particularly, imports of Dgit-less .dscs) are performed only as
2897 # needed on individual clients, so different clients may perform a
2898 # different subset of them - and these imports are only made
2899 # public during push. So $lastfetch_hash may represent a set of
2900 # imports different to a subsequent upload by a different dgit
2903 # Our approach is as follows:
2905 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2906 # descendant of $dsc_hash, then it was pushed by a dgit user who
2907 # had based their work on $dsc_hash, so we should prefer it.
2908 # Otherwise, $dsc_hash was installed into this suite in the
2909 # archive other than by a dgit push, and (necessarily) after the
2910 # last dgit push into that suite (since a dgit push would have
2911 # been descended from the dgit server git branch); thus, in that
2912 # case, we prefer the archive's version (and produce a
2913 # pseudo-merge to overwrite the dgit server git branch).
2915 # (If there is no Dgit field in the archive's .dsc then
2916 # generate_commit_from_dsc uses the version numbers to decide
2917 # whether the suite branch or the archive is newer. If the suite
2918 # branch is newer it ignores the archive's .dsc; otherwise it
2919 # generates an import of the .dsc, and produces a pseudo-merge to
2920 # overwrite the suite branch with the archive contents.)
2922 # The outcome of that part of the algorithm is the `public view',
2923 # and is same for all dgit clients: it does not depend on any
2924 # unpublished history in the local tracking branch.
2926 # As between the public view and the local tracking branch: The
2927 # local tracking branch is only updated by dgit fetch, and
2928 # whenever dgit fetch runs it includes the public view in the
2929 # local tracking branch. Therefore if the public view is not
2930 # descended from the local tracking branch, the local tracking
2931 # branch must contain history which was imported from the archive
2932 # but never pushed; and, its tip is now out of date. So, we make
2933 # a pseudo-merge to overwrite the old imports and stitch the old
2936 # Finally: we do not necessarily reify the public view (as
2937 # described above). This is so that we do not end up stacking two
2938 # pseudo-merges. So what we actually do is figure out the inputs
2939 # to any public view pseudo-merge and put them in @mergeinputs.
2942 # $mergeinputs[]{Commit}
2943 # $mergeinputs[]{Info}
2944 # $mergeinputs[0] is the one whose tree we use
2945 # @mergeinputs is in the order we use in the actual commit)
2948 # $mergeinputs[]{Message} is a commit message to use
2949 # $mergeinputs[]{ReverseParents} if def specifies that parent
2950 # list should be in opposite order
2951 # Such an entry has no Commit or Info. It applies only when found
2952 # in the last entry. (This ugliness is to support making
2953 # identical imports to previous dgit versions.)
2955 my $lastpush_hash = git_get_ref(lrfetchref());
2956 printdebug "previous reference hash=$lastpush_hash\n";
2957 $lastpush_mergeinput = $lastpush_hash && {
2958 Commit => $lastpush_hash,
2959 Info => "dgit suite branch on dgit git server",
2962 my $lastfetch_hash = git_get_ref(lrref());
2963 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2964 my $lastfetch_mergeinput = $lastfetch_hash && {
2965 Commit => $lastfetch_hash,
2966 Info => "dgit client's archive history view",
2969 my $dsc_mergeinput = $dsc_hash && {
2970 Commit => $dsc_hash,
2971 Info => "Dgit field in .dsc from archive",
2975 my $del_lrfetchrefs = sub {
2978 printdebug "del_lrfetchrefs...\n";
2979 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2980 my $objid = $lrfetchrefs_d{$fullrefname};
2981 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2983 $gur ||= new IO::Handle;
2984 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2986 printf $gur "delete %s %s\n", $fullrefname, $objid;
2989 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2993 if (defined $dsc_hash) {
2994 ensure_we_have_orig();
2995 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2996 @mergeinputs = $dsc_mergeinput
2997 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2998 print STDERR <<END or die $!;
3000 Git commit in archive is behind the last version allegedly pushed/uploaded.
3001 Commit referred to by archive: $dsc_hash
3002 Last version pushed with dgit: $lastpush_hash
3005 @mergeinputs = ($lastpush_mergeinput);
3007 # Archive has .dsc which is not a descendant of the last dgit
3008 # push. This can happen if the archive moves .dscs about.
3009 # Just follow its lead.
3010 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3011 progress "archive .dsc names newer git commit";
3012 @mergeinputs = ($dsc_mergeinput);
3014 progress "archive .dsc names other git commit, fixing up";
3015 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3019 @mergeinputs = generate_commits_from_dsc();
3020 # We have just done an import. Now, our import algorithm might
3021 # have been improved. But even so we do not want to generate
3022 # a new different import of the same package. So if the
3023 # version numbers are the same, just use our existing version.
3024 # If the version numbers are different, the archive has changed
3025 # (perhaps, rewound).
3026 if ($lastfetch_mergeinput &&
3027 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3028 (mergeinfo_version $mergeinputs[0]) )) {
3029 @mergeinputs = ($lastfetch_mergeinput);
3031 } elsif ($lastpush_hash) {
3032 # only in git, not in the archive yet
3033 @mergeinputs = ($lastpush_mergeinput);
3034 print STDERR <<END or die $!;
3036 Package not found in the archive, but has allegedly been pushed using dgit.
3040 printdebug "nothing found!\n";
3041 if (defined $skew_warning_vsn) {
3042 print STDERR <<END or die $!;
3044 Warning: relevant archive skew detected.
3045 Archive allegedly contains $skew_warning_vsn
3046 But we were not able to obtain any version from the archive or git.
3050 unshift @end, $del_lrfetchrefs;
3054 if ($lastfetch_hash &&
3056 my $h = $_->{Commit};
3057 $h and is_fast_fwd($lastfetch_hash, $h);
3058 # If true, one of the existing parents of this commit
3059 # is a descendant of the $lastfetch_hash, so we'll
3060 # be ff from that automatically.
3064 push @mergeinputs, $lastfetch_mergeinput;
3067 printdebug "fetch mergeinfos:\n";
3068 foreach my $mi (@mergeinputs) {
3070 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3072 printdebug sprintf " ReverseParents=%d Message=%s",
3073 $mi->{ReverseParents}, $mi->{Message};
3077 my $compat_info= pop @mergeinputs
3078 if $mergeinputs[$#mergeinputs]{Message};
3080 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3083 if (@mergeinputs > 1) {
3085 my $tree_commit = $mergeinputs[0]{Commit};
3087 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3088 $tree =~ m/\n\n/; $tree = $`;
3089 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3092 # We use the changelog author of the package in question the
3093 # author of this pseudo-merge. This is (roughly) correct if
3094 # this commit is simply representing aa non-dgit upload.
3095 # (Roughly because it does not record sponsorship - but we
3096 # don't have sponsorship info because that's in the .changes,
3097 # which isn't in the archivw.)
3099 # But, it might be that we are representing archive history
3100 # updates (including in-archive copies). These are not really
3101 # the responsibility of the person who created the .dsc, but
3102 # there is no-one whose name we should better use. (The
3103 # author of the .dsc-named commit is clearly worse.)
3105 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3106 my $author = clogp_authline $useclogp;
3107 my $cversion = getfield $useclogp, 'Version';
3109 my $mcf = ".git/dgit/mergecommit";
3110 open MC, ">", $mcf or die "$mcf $!";
3111 print MC <<END or die $!;
3115 my @parents = grep { $_->{Commit} } @mergeinputs;
3116 @parents = reverse @parents if $compat_info->{ReverseParents};
3117 print MC <<END or die $! foreach @parents;
3121 print MC <<END or die $!;
3127 if (defined $compat_info->{Message}) {
3128 print MC $compat_info->{Message} or die $!;
3130 print MC <<END or die $!;
3131 Record $package ($cversion) in archive suite $csuite
3135 my $message_add_info = sub {
3137 my $mversion = mergeinfo_version $mi;
3138 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3142 $message_add_info->($mergeinputs[0]);
3143 print MC <<END or die $!;
3144 should be treated as descended from
3146 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3150 $hash = make_commit $mcf;
3152 $hash = $mergeinputs[0]{Commit};
3154 printdebug "fetch hash=$hash\n";
3157 my ($lasth, $what) = @_;
3158 return unless $lasth;
3159 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3162 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3164 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3166 fetch_from_archive_record_1($hash);
3168 if (defined $skew_warning_vsn) {
3170 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3171 my $gotclogp = commit_getclogp($hash);
3172 my $got_vsn = getfield $gotclogp, 'Version';
3173 printdebug "SKEW CHECK GOT $got_vsn\n";
3174 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3175 print STDERR <<END or die $!;
3177 Warning: archive skew detected. Using the available version:
3178 Archive allegedly contains $skew_warning_vsn
3179 We were able to obtain only $got_vsn
3185 if ($lastfetch_hash ne $hash) {
3186 fetch_from_archive_record_2($hash);
3189 lrfetchref_used lrfetchref();
3191 unshift @end, $del_lrfetchrefs;
3195 sub set_local_git_config ($$) {
3197 runcmd @git, qw(config), $k, $v;
3200 sub setup_mergechangelogs (;$) {
3202 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3204 my $driver = 'dpkg-mergechangelogs';
3205 my $cb = "merge.$driver";
3206 my $attrs = '.git/info/attributes';
3207 ensuredir '.git/info';
3209 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3210 if (!open ATTRS, "<", $attrs) {
3211 $!==ENOENT or die "$attrs: $!";
3215 next if m{^debian/changelog\s};
3216 print NATTRS $_, "\n" or die $!;
3218 ATTRS->error and die $!;
3221 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3224 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3225 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3227 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3230 sub setup_useremail (;$) {
3232 return unless $always || access_cfg_bool(1, 'setup-useremail');
3235 my ($k, $envvar) = @_;
3236 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3237 return unless defined $v;
3238 set_local_git_config "user.$k", $v;
3241 $setup->('email', 'DEBEMAIL');
3242 $setup->('name', 'DEBFULLNAME');
3245 sub ensure_setup_existing_tree () {
3246 my $k = "remote.$remotename.skipdefaultupdate";
3247 my $c = git_get_config $k;
3248 return if defined $c;
3249 set_local_git_config $k, 'true';
3252 sub setup_new_tree () {
3253 setup_mergechangelogs();
3257 sub multisuite_suite_child ($$$) {
3258 my ($tsuite, $merginputs, $fn) = @_;
3259 # in child, sets things up, calls $fn->(), and returns undef
3260 # in parent, returns canonical suite name for $tsuite
3261 my $canonsuitefh = IO::File::new_tmpfile;
3262 my $pid = fork // die $!;
3265 $us .= " [$isuite]";
3266 $debugprefix .= " ";
3267 progress "fetching $tsuite...";
3268 canonicalise_suite();
3269 print $canonsuitefh $csuite, "\n" or die $!;
3270 close $canonsuitefh or die $!;
3274 waitpid $pid,0 == $pid or die $!;
3275 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3276 seek $canonsuitefh,0,0 or die $!;
3277 local $csuite = <$canonsuitefh>;
3278 die $! unless defined $csuite && chomp $csuite;
3280 printdebug "multisuite $tsuite missing\n";
3283 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3284 push @$merginputs, {
3291 sub fork_for_multisuite ($) {
3292 my ($before_fetch_merge) = @_;
3293 # if nothing unusual, just returns ''
3296 # returns 0 to caller in child, to do first of the specified suites
3297 # in child, $csuite is not yet set
3299 # returns 1 to caller in parent, to finish up anything needed after
3300 # in parent, $csuite is set to canonicalised portmanteau
3302 my $org_isuite = $isuite;
3303 my @suites = split /\,/, $isuite;
3304 return '' unless @suites > 1;
3305 printdebug "fork_for_multisuite: @suites\n";
3309 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3311 return 0 unless defined $cbasesuite;
3313 fail "package $package missing in (base suite) $cbasesuite"
3314 unless @mergeinputs;
3316 my @csuites = ($cbasesuite);
3318 $before_fetch_merge->();
3320 foreach my $tsuite (@suites[1..$#suites]) {
3321 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3327 # xxx collecte the ref here
3329 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3330 push @csuites, $csubsuite;
3333 foreach my $mi (@mergeinputs) {
3334 my $ref = git_get_ref $mi->{Ref};
3335 die "$mi->{Ref} ?" unless length $ref;
3336 $mi->{Commit} = $ref;
3339 $csuite = join ",", @csuites;
3341 my $previous = git_get_ref lrref;
3343 unshift @mergeinputs, {
3344 Commit => $previous,
3345 Info => "local combined tracking branch",
3347 "archive seems to have rewound: local tracking branch is ahead!",
3351 foreach my $ix (0..$#mergeinputs) {
3352 $mergeinputs[$ix]{Index} = $ix;
3355 @mergeinputs = sort {
3356 -version_compare(mergeinfo_version $a,
3357 mergeinfo_version $b) # highest version first
3359 $a->{Index} <=> $b->{Index}; # earliest in spec first
3365 foreach my $mi (@mergeinputs) {
3366 printdebug "multisuite merge check $mi->{Info}\n";
3367 foreach my $previous (@needed) {
3368 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3369 printdebug "multisuite merge un-needed $previous->{Info}\n";
3373 printdebug "multisuite merge this-needed\n";
3374 $mi->{Character} = '+';
3377 $needed[0]{Character} = '*';
3379 my $output = $needed[0]{Commit};
3382 printdebug "multisuite merge nontrivial\n";
3383 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3385 my $commit = "tree $tree\n";
3386 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3387 "Input branches:\n";
3389 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3390 printdebug "multisuite merge include $mi->{Info}\n";
3391 $mi->{Character} //= ' ';
3392 $commit .= "parent $mi->{Commit}\n";
3393 $msg .= sprintf " %s %-25s %s\n",
3395 (mergeinfo_version $mi),
3398 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3400 " * marks the highest version branch, which choose to use\n".
3401 " + marks each branch which was not already an ancestor\n\n".
3402 "[dgit multi-suite $csuite]\n";
3404 "author $authline\n".
3405 "committer $authline\n\n";
3406 $output = make_commit_text $commit.$msg;
3407 printdebug "multisuite merge generated $output\n";
3410 fetch_from_archive_record_1($output);
3411 fetch_from_archive_record_2($output);
3413 progress "calculated combined tracking suite $csuite";
3418 sub clone_set_head () {
3419 open H, "> .git/HEAD" or die $!;
3420 print H "ref: ".lref()."\n" or die $!;
3423 sub clone_finish ($) {
3425 runcmd @git, qw(reset --hard), lrref();
3426 runcmd qw(bash -ec), <<'END';
3428 git ls-tree -r --name-only -z HEAD | \
3429 xargs -0r touch -h -r . --
3431 printdone "ready for work in $dstdir";
3436 badusage "dry run makes no sense with clone" unless act_local();
3438 my $multi_fetched = fork_for_multisuite(sub {
3439 printdebug "multi clone before fetch merge\n";
3442 if ($multi_fetched) {
3443 printdebug "multi clone after fetch merge\n";
3445 clone_finish($dstdir);
3448 printdebug "clone main body\n";
3450 canonicalise_suite();
3451 my $hasgit = check_for_git();
3452 mkdir $dstdir or fail "create \`$dstdir': $!";
3454 runcmd @git, qw(init -q);
3456 my $giturl = access_giturl(1);
3457 if (defined $giturl) {
3458 runcmd @git, qw(remote add), 'origin', $giturl;
3461 progress "fetching existing git history";
3463 runcmd_ordryrun_local @git, qw(fetch origin);
3465 progress "starting new git history";
3467 fetch_from_archive() or no_such_package;
3468 my $vcsgiturl = $dsc->{'Vcs-Git'};
3469 if (length $vcsgiturl) {
3470 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3471 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3474 clone_finish($dstdir);
3478 canonicalise_suite();
3479 if (check_for_git()) {
3482 fetch_from_archive() or no_such_package();
3483 printdone "fetched into ".lrref();
3487 my $multi_fetched = fork_for_multisuite(sub { });
3488 fetch() unless $multi_fetched; # parent
3489 return if $multi_fetched eq '0'; # child
3490 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3492 printdone "fetched to ".lrref()." and merged into HEAD";
3495 sub check_not_dirty () {
3496 foreach my $f (qw(local-options local-patch-header)) {
3497 if (stat_exists "debian/source/$f") {
3498 fail "git tree contains debian/source/$f";
3502 return if $ignoredirty;
3504 my @cmd = (@git, qw(diff --quiet HEAD));
3506 $!=0; $?=-1; system @cmd;
3509 fail "working tree is dirty (does not match HEAD)";
3515 sub commit_admin ($) {
3518 runcmd_ordryrun_local @git, qw(commit -m), $m;
3521 sub commit_quilty_patch () {
3522 my $output = cmdoutput @git, qw(status --porcelain);
3524 foreach my $l (split /\n/, $output) {
3525 next unless $l =~ m/\S/;
3526 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3530 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3532 progress "nothing quilty to commit, ok.";
3535 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3536 runcmd_ordryrun_local @git, qw(add -f), @adds;
3538 Commit Debian 3.0 (quilt) metadata
3540 [dgit ($our_version) quilt-fixup]
3544 sub get_source_format () {
3546 if (open F, "debian/source/options") {
3550 s/\s+$//; # ignore missing final newline
3552 my ($k, $v) = ($`, $'); #');
3553 $v =~ s/^"(.*)"$/$1/;
3559 F->error and die $!;
3562 die $! unless $!==&ENOENT;
3565 if (!open F, "debian/source/format") {
3566 die $! unless $!==&ENOENT;
3570 F->error and die $!;
3572 return ($_, \%options);
3575 sub madformat_wantfixup ($) {
3577 return 0 unless $format eq '3.0 (quilt)';
3578 our $quilt_mode_warned;
3579 if ($quilt_mode eq 'nocheck') {
3580 progress "Not doing any fixup of \`$format' due to".
3581 " ----no-quilt-fixup or --quilt=nocheck"
3582 unless $quilt_mode_warned++;
3585 progress "Format \`$format', need to check/update patch stack"
3586 unless $quilt_mode_warned++;
3590 sub maybe_split_brain_save ($$$) {
3591 my ($headref, $dgitview, $msg) = @_;
3592 # => message fragment "$saved" describing disposition of $dgitview
3593 return "commit id $dgitview" unless defined $split_brain_save;
3594 my @cmd = (shell_cmd "cd ../../../..",
3595 @git, qw(update-ref -m),
3596 "dgit --dgit-view-save $msg HEAD=$headref",
3597 $split_brain_save, $dgitview);
3599 return "and left in $split_brain_save";
3602 # An "infopair" is a tuple [ $thing, $what ]
3603 # (often $thing is a commit hash; $what is a description)
3605 sub infopair_cond_equal ($$) {
3607 $x->[0] eq $y->[0] or fail <<END;
3608 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3612 sub infopair_lrf_tag_lookup ($$) {
3613 my ($tagnames, $what) = @_;
3614 # $tagname may be an array ref
3615 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3616 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3617 foreach my $tagname (@tagnames) {
3618 my $lrefname = lrfetchrefs."/tags/$tagname";
3619 my $tagobj = $lrfetchrefs_f{$lrefname};
3620 next unless defined $tagobj;
3621 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3622 return [ git_rev_parse($tagobj), $what ];
3624 fail @tagnames==1 ? <<END : <<END;
3625 Wanted tag $what (@tagnames) on dgit server, but not found
3627 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3631 sub infopair_cond_ff ($$) {
3632 my ($anc,$desc) = @_;
3633 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3634 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3638 sub pseudomerge_version_check ($$) {
3639 my ($clogp, $archive_hash) = @_;
3641 my $arch_clogp = commit_getclogp $archive_hash;
3642 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3643 'version currently in archive' ];
3644 if (defined $overwrite_version) {
3645 if (length $overwrite_version) {
3646 infopair_cond_equal([ $overwrite_version,
3647 '--overwrite= version' ],
3650 my $v = $i_arch_v->[0];
3651 progress "Checking package changelog for archive version $v ...";
3653 my @xa = ("-f$v", "-t$v");
3654 my $vclogp = parsechangelog @xa;
3655 my $cv = [ (getfield $vclogp, 'Version'),
3656 "Version field from dpkg-parsechangelog @xa" ];
3657 infopair_cond_equal($i_arch_v, $cv);
3660 $@ =~ s/^dgit: //gm;
3662 "Perhaps debian/changelog does not mention $v ?";
3667 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3671 sub pseudomerge_make_commit ($$$$ $$) {
3672 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3673 $msg_cmd, $msg_msg) = @_;
3674 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3676 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3677 my $authline = clogp_authline $clogp;
3681 !defined $overwrite_version ? ""
3682 : !length $overwrite_version ? " --overwrite"
3683 : " --overwrite=".$overwrite_version;
3686 my $pmf = ".git/dgit/pseudomerge";
3687 open MC, ">", $pmf or die "$pmf $!";
3688 print MC <<END or die $!;
3691 parent $archive_hash
3701 return make_commit($pmf);
3704 sub splitbrain_pseudomerge ($$$$) {
3705 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3706 # => $merged_dgitview
3707 printdebug "splitbrain_pseudomerge...\n";
3709 # We: debian/PREVIOUS HEAD($maintview)
3710 # expect: o ----------------- o
3713 # a/d/PREVIOUS $dgitview
3716 # we do: `------------------ o