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::MoreUtils qw(pairwise);
38 use Text::Glob qw(match_glob);
39 use Fcntl qw(:DEFAULT :flock);
44 our $our_version = 'UNRELEASED'; ###substituted###
45 our $absurdity = undef; ###substituted###
47 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
56 our $dryrun_level = 0;
58 our $buildproductsdir = '..';
64 our $existing_package = 'dpkg';
66 our $changes_since_version;
68 our $overwrite_version; # undef: not specified; '': check changelog
70 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
72 our $split_brain_save;
73 our $we_are_responder;
74 our $we_are_initiator;
75 our $initiator_tempdir;
76 our $patches_applied_dirtily = 00;
80 our $chase_dsc_distro=1;
82 our %forceopts = map { $_=>0 }
83 qw(unrepresentable unsupported-source-format
84 dsc-changes-mismatch changes-origs-exactly
85 import-gitapply-absurd
86 import-gitapply-no-absurd
87 import-dsc-with-dgit-field);
89 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
91 our $suite_re = '[-+.0-9a-z]+';
92 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
93 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
94 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
95 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
97 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
98 our $splitbraincache = 'dgit-intern/quilt-cache';
99 our $rewritemap = 'dgit-rewrite/map';
101 our (@git) = qw(git);
102 our (@dget) = qw(dget);
103 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
104 our (@dput) = qw(dput);
105 our (@debsign) = qw(debsign);
106 our (@gpg) = qw(gpg);
107 our (@sbuild) = qw(sbuild);
109 our (@dgit) = qw(dgit);
110 our (@aptget) = qw(apt-get);
111 our (@aptcache) = qw(apt-cache);
112 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
113 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
114 our (@dpkggenchanges) = qw(dpkg-genchanges);
115 our (@mergechanges) = qw(mergechanges -f);
116 our (@gbp_build) = ('');
117 our (@gbp_pq) = ('gbp pq');
118 our (@changesopts) = ('');
120 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
123 'debsign' => \@debsign,
125 'sbuild' => \@sbuild,
129 'apt-get' => \@aptget,
130 'apt-cache' => \@aptcache,
131 'dpkg-source' => \@dpkgsource,
132 'dpkg-buildpackage' => \@dpkgbuildpackage,
133 'dpkg-genchanges' => \@dpkggenchanges,
134 'gbp-build' => \@gbp_build,
135 'gbp-pq' => \@gbp_pq,
136 'ch' => \@changesopts,
137 'mergechanges' => \@mergechanges);
139 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
140 our %opts_cfg_insertpos = map {
142 scalar @{ $opts_opt_map{$_} }
143 } keys %opts_opt_map;
145 sub parseopts_late_defaults();
146 sub setup_gitattrs(;$);
147 sub check_gitattrs($$);
153 our $supplementary_message = '';
154 our $need_split_build_invocation = 0;
155 our $split_brain = 0;
159 return unless forkcheck_mainprocess();
160 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
163 our $remotename = 'dgit';
164 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
168 if (!defined $absurdity) {
170 $absurdity =~ s{/[^/]+$}{/absurd} or die;
174 my ($v,$distro) = @_;
175 return $tagformatfn->($v, $distro);
178 sub debiantag_maintview ($$) {
179 my ($v,$distro) = @_;
180 return "$distro/".dep14_version_mangle $v;
183 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
185 sub lbranch () { return "$branchprefix/$csuite"; }
186 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
187 sub lref () { return "refs/heads/".lbranch(); }
188 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
189 sub rrref () { return server_ref($csuite); }
199 return "${package}_".(stripepoch $vsn).$sfx
204 return srcfn($vsn,".dsc");
207 sub changespat ($;$) {
208 my ($vsn, $arch) = @_;
209 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
212 sub upstreamversion ($) {
224 return unless forkcheck_mainprocess();
225 foreach my $f (@end) {
227 print STDERR "$us: cleanup: $@" if length $@;
231 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
233 sub forceable_fail ($$) {
234 my ($forceoptsl, $msg) = @_;
235 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
236 print STDERR "warning: overriding problem due to --force:\n". $msg;
240 my ($forceoptsl) = @_;
241 my @got = grep { $forceopts{$_} } @$forceoptsl;
242 return 0 unless @got;
244 "warning: skipping checks or functionality due to --force-$got[0]\n";
247 sub no_such_package () {
248 print STDERR "$us: package $package does not exist in suite $isuite\n";
254 printdebug "CD $newdir\n";
255 chdir $newdir or confess "chdir: $newdir: $!";
258 sub deliberately ($) {
260 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
263 sub deliberately_not_fast_forward () {
264 foreach (qw(not-fast-forward fresh-repo)) {
265 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
269 sub quiltmode_splitbrain () {
270 $quilt_mode =~ m/gbp|dpm|unapplied/;
273 sub opts_opt_multi_cmd {
275 push @cmd, split /\s+/, shift @_;
281 return opts_opt_multi_cmd @gbp_pq;
284 #---------- remote protocol support, common ----------
286 # remote push initiator/responder protocol:
287 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
288 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
289 # < dgit-remote-push-ready <actual-proto-vsn>
296 # > supplementary-message NBYTES # $protovsn >= 3
301 # > file parsed-changelog
302 # [indicates that output of dpkg-parsechangelog follows]
303 # > data-block NBYTES
304 # > [NBYTES bytes of data (no newline)]
305 # [maybe some more blocks]
314 # > param head DGIT-VIEW-HEAD
315 # > param csuite SUITE
316 # > param tagformat old|new
317 # > param maint-view MAINT-VIEW-HEAD
319 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
320 # > file buildinfo # for buildinfos to sign
322 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
323 # # goes into tag, for replay prevention
326 # [indicates that signed tag is wanted]
327 # < data-block NBYTES
328 # < [NBYTES bytes of data (no newline)]
329 # [maybe some more blocks]
333 # > want signed-dsc-changes
334 # < data-block NBYTES [transfer of signed dsc]
336 # < data-block NBYTES [transfer of signed changes]
338 # < data-block NBYTES [transfer of each signed buildinfo
339 # [etc] same number and order as "file buildinfo"]
347 sub i_child_report () {
348 # Sees if our child has died, and reap it if so. Returns a string
349 # describing how it died if it failed, or undef otherwise.
350 return undef unless $i_child_pid;
351 my $got = waitpid $i_child_pid, WNOHANG;
352 return undef if $got <= 0;
353 die unless $got == $i_child_pid;
354 $i_child_pid = undef;
355 return undef unless $?;
356 return "build host child ".waitstatusmsg();
361 fail "connection lost: $!" if $fh->error;
362 fail "protocol violation; $m not expected";
365 sub badproto_badread ($$) {
367 fail "connection lost: $!" if $!;
368 my $report = i_child_report();
369 fail $report if defined $report;
370 badproto $fh, "eof (reading $wh)";
373 sub protocol_expect (&$) {
374 my ($match, $fh) = @_;
377 defined && chomp or badproto_badread $fh, "protocol message";
385 badproto $fh, "\`$_'";
388 sub protocol_send_file ($$) {
389 my ($fh, $ourfn) = @_;
390 open PF, "<", $ourfn or die "$ourfn: $!";
393 my $got = read PF, $d, 65536;
394 die "$ourfn: $!" unless defined $got;
396 print $fh "data-block ".length($d)."\n" or die $!;
397 print $fh $d or die $!;
399 PF->error and die "$ourfn $!";
400 print $fh "data-end\n" or die $!;
404 sub protocol_read_bytes ($$) {
405 my ($fh, $nbytes) = @_;
406 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
408 my $got = read $fh, $d, $nbytes;
409 $got==$nbytes or badproto_badread $fh, "data block";
413 sub protocol_receive_file ($$) {
414 my ($fh, $ourfn) = @_;
415 printdebug "() $ourfn\n";
416 open PF, ">", $ourfn or die "$ourfn: $!";
418 my ($y,$l) = protocol_expect {
419 m/^data-block (.*)$/ ? (1,$1) :
420 m/^data-end$/ ? (0,) :
424 my $d = protocol_read_bytes $fh, $l;
425 print PF $d or die $!;
430 #---------- remote protocol support, responder ----------
432 sub responder_send_command ($) {
434 return unless $we_are_responder;
435 # called even without $we_are_responder
436 printdebug ">> $command\n";
437 print PO $command, "\n" or die $!;
440 sub responder_send_file ($$) {
441 my ($keyword, $ourfn) = @_;
442 return unless $we_are_responder;
443 printdebug "]] $keyword $ourfn\n";
444 responder_send_command "file $keyword";
445 protocol_send_file \*PO, $ourfn;
448 sub responder_receive_files ($@) {
449 my ($keyword, @ourfns) = @_;
450 die unless $we_are_responder;
451 printdebug "[[ $keyword @ourfns\n";
452 responder_send_command "want $keyword";
453 foreach my $fn (@ourfns) {
454 protocol_receive_file \*PI, $fn;
457 protocol_expect { m/^files-end$/ } \*PI;
460 #---------- remote protocol support, initiator ----------
462 sub initiator_expect (&) {
464 protocol_expect { &$match } \*RO;
467 #---------- end remote code ----------
470 if ($we_are_responder) {
472 responder_send_command "progress ".length($m) or die $!;
473 print PO $m or die $!;
483 $ua = LWP::UserAgent->new();
487 progress "downloading $what...";
488 my $r = $ua->get(@_) or die $!;
489 return undef if $r->code == 404;
490 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
491 return $r->decoded_content(charset => 'none');
494 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
499 failedcmd @_ if system @_;
502 sub act_local () { return $dryrun_level <= 1; }
503 sub act_scary () { return !$dryrun_level; }
506 if (!$dryrun_level) {
507 progress "$us ok: @_";
509 progress "would be ok: @_ (but dry run only)";
514 printcmd(\*STDERR,$debugprefix."#",@_);
517 sub runcmd_ordryrun {
525 sub runcmd_ordryrun_local {
534 my ($first_shell, @cmd) = @_;
535 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
538 our $helpmsg = <<END;
540 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
541 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
542 dgit [dgit-opts] build [dpkg-buildpackage-opts]
543 dgit [dgit-opts] sbuild [sbuild-opts]
544 dgit [dgit-opts] push [dgit-opts] [suite]
545 dgit [dgit-opts] rpush build-host:build-dir ...
546 important dgit options:
547 -k<keyid> sign tag and package with <keyid> instead of default
548 --dry-run -n do not change anything, but go through the motions
549 --damp-run -L like --dry-run but make local changes, without signing
550 --new -N allow introducing a new package
551 --debug -D increase debug level
552 -c<name>=<value> set git config option (used directly by dgit too)
555 our $later_warning_msg = <<END;
556 Perhaps the upload is stuck in incoming. Using the version from git.
560 print STDERR "$us: @_\n", $helpmsg or die $!;
565 @ARGV or badusage "too few arguments";
566 return scalar shift @ARGV;
570 print $helpmsg or die $!;
574 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
576 our %defcfg = ('dgit.default.distro' => 'debian',
577 'dgit.default.default-suite' => 'unstable',
578 'dgit.default.old-dsc-distro' => 'debian',
579 'dgit-suite.*-security.distro' => 'debian-security',
580 'dgit.default.username' => '',
581 'dgit.default.archive-query-default-component' => 'main',
582 'dgit.default.ssh' => 'ssh',
583 'dgit.default.archive-query' => 'madison:',
584 'dgit.default.sshpsql-dbname' => 'service=projectb',
585 'dgit.default.aptget-components' => 'main',
586 'dgit.default.dgit-tag-format' => 'new,old,maint',
587 'dgit.dsc-url-proto-ok.http' => 'true',
588 'dgit.dsc-url-proto-ok.https' => 'true',
589 'dgit.dsc-url-proto-ok.git' => 'true',
590 'dgit.default.dsc-url-proto-ok' => 'false',
591 # old means "repo server accepts pushes with old dgit tags"
592 # new means "repo server accepts pushes with new dgit tags"
593 # maint means "repo server accepts split brain pushes"
594 # hist means "repo server may have old pushes without new tag"
595 # ("hist" is implied by "old")
596 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
597 'dgit-distro.debian.git-check' => 'url',
598 'dgit-distro.debian.git-check-suffix' => '/info/refs',
599 'dgit-distro.debian.new-private-pushers' => 't',
600 'dgit-distro.debian/push.git-url' => '',
601 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
602 'dgit-distro.debian/push.git-user-force' => 'dgit',
603 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
604 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
605 'dgit-distro.debian/push.git-create' => 'true',
606 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
607 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
608 # 'dgit-distro.debian.archive-query-tls-key',
609 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
610 # ^ this does not work because curl is broken nowadays
611 # Fixing #790093 properly will involve providing providing the key
612 # in some pacagke and maybe updating these paths.
614 # 'dgit-distro.debian.archive-query-tls-curl-args',
615 # '--ca-path=/etc/ssl/ca-debian',
616 # ^ this is a workaround but works (only) on DSA-administered machines
617 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
618 'dgit-distro.debian.git-url-suffix' => '',
619 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
620 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
621 'dgit-distro.debian-security.archive-query' => 'aptget:',
622 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
623 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
624 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
625 'dgit-distro.debian-security.nominal-distro' => 'debian',
626 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
627 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
628 'dgit-distro.ubuntu.git-check' => 'false',
629 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
630 'dgit-distro.test-dummy.ssh' => "$td/ssh",
631 'dgit-distro.test-dummy.username' => "alice",
632 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
633 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
634 'dgit-distro.test-dummy.git-url' => "$td/git",
635 'dgit-distro.test-dummy.git-host' => "git",
636 'dgit-distro.test-dummy.git-path' => "$td/git",
637 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
638 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
639 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
640 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
644 our @gitcfgsources = qw(cmdline local global system);
646 sub git_slurp_config () {
647 local ($debuglevel) = $debuglevel-2;
650 # This algoritm is a bit subtle, but this is needed so that for
651 # options which we want to be single-valued, we allow the
652 # different config sources to override properly. See #835858.
653 foreach my $src (@gitcfgsources) {
654 next if $src eq 'cmdline';
655 # we do this ourselves since git doesn't handle it
657 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
660 open GITS, "-|", @cmd or die $!;
663 printdebug "=> ", (messagequote $_), "\n";
665 push @{ $gitcfgs{$src}{$`} }, $'; #';
669 or ($!==0 && $?==256)
674 sub git_get_config ($) {
676 foreach my $src (@gitcfgsources) {
677 my $l = $gitcfgs{$src}{$c};
678 confess "internal error ($l $c)" if $l && !ref $l;
679 printdebug"C $c ".(defined $l ?
680 join " ", map { messagequote "'$_'" } @$l :
684 @$l==1 or badcfg "multiple values for $c".
685 " (in $src git config)" if @$l > 1;
693 return undef if $c =~ /RETURN-UNDEF/;
694 printdebug "C? $c\n" if $debuglevel >= 5;
695 my $v = git_get_config($c);
696 return $v if defined $v;
697 my $dv = $defcfg{$c};
699 printdebug "CD $c $dv\n" if $debuglevel >= 4;
703 badcfg "need value for one of: @_\n".
704 "$us: distro or suite appears not to be (properly) supported";
707 sub access_basedistro__noalias () {
708 if (defined $idistro) {
711 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
712 return $def if defined $def;
713 foreach my $src (@gitcfgsources, 'internal') {
714 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
716 foreach my $k (keys %$kl) {
717 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
719 next unless match_glob $dpat, $isuite;
723 return cfg("dgit.default.distro");
727 sub access_basedistro () {
728 my $noalias = access_basedistro__noalias();
729 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
730 return $canon // $noalias;
733 sub access_nomdistro () {
734 my $base = access_basedistro();
735 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
736 $r =~ m/^$distro_re$/ or badcfg
737 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
741 sub access_quirk () {
742 # returns (quirk name, distro to use instead or undef, quirk-specific info)
743 my $basedistro = access_basedistro();
744 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
746 if (defined $backports_quirk) {
747 my $re = $backports_quirk;
748 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
750 $re =~ s/\%/([-0-9a-z_]+)/
751 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
752 if ($isuite =~ m/^$re$/) {
753 return ('backports',"$basedistro-backports",$1);
756 return ('none',undef);
761 sub parse_cfg_bool ($$$) {
762 my ($what,$def,$v) = @_;
765 $v =~ m/^[ty1]/ ? 1 :
766 $v =~ m/^[fn0]/ ? 0 :
767 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
770 sub access_forpush_config () {
771 my $d = access_basedistro();
775 parse_cfg_bool('new-private-pushers', 0,
776 cfg("dgit-distro.$d.new-private-pushers",
779 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
782 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
783 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
784 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
785 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
788 sub access_forpush () {
789 $access_forpush //= access_forpush_config();
790 return $access_forpush;
794 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
795 badcfg "pushing but distro is configured readonly"
796 if access_forpush_config() eq '0';
798 $supplementary_message = <<'END' unless $we_are_responder;
799 Push failed, before we got started.
800 You can retry the push, after fixing the problem, if you like.
802 parseopts_late_defaults();
806 parseopts_late_defaults();
809 sub supplementary_message ($) {
811 if (!$we_are_responder) {
812 $supplementary_message = $msg;
814 } elsif ($protovsn >= 3) {
815 responder_send_command "supplementary-message ".length($msg)
817 print PO $msg or die $!;
821 sub access_distros () {
822 # Returns list of distros to try, in order
825 # 0. `instead of' distro name(s) we have been pointed to
826 # 1. the access_quirk distro, if any
827 # 2a. the user's specified distro, or failing that } basedistro
828 # 2b. the distro calculated from the suite }
829 my @l = access_basedistro();
831 my (undef,$quirkdistro) = access_quirk();
832 unshift @l, $quirkdistro;
833 unshift @l, $instead_distro;
834 @l = grep { defined } @l;
836 push @l, access_nomdistro();
838 if (access_forpush()) {
839 @l = map { ("$_/push", $_) } @l;
844 sub access_cfg_cfgs (@) {
847 # The nesting of these loops determines the search order. We put
848 # the key loop on the outside so that we search all the distros
849 # for each key, before going on to the next key. That means that
850 # if access_cfg is called with a more specific, and then a less
851 # specific, key, an earlier distro can override the less specific
852 # without necessarily overriding any more specific keys. (If the
853 # distro wants to override the more specific keys it can simply do
854 # so; whereas if we did the loop the other way around, it would be
855 # impossible to for an earlier distro to override a less specific
856 # key but not the more specific ones without restating the unknown
857 # values of the more specific keys.
860 # We have to deal with RETURN-UNDEF specially, so that we don't
861 # terminate the search prematurely.
863 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
866 foreach my $d (access_distros()) {
867 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
869 push @cfgs, map { "dgit.default.$_" } @realkeys;
876 my (@cfgs) = access_cfg_cfgs(@keys);
877 my $value = cfg(@cfgs);
881 sub access_cfg_bool ($$) {
882 my ($def, @keys) = @_;
883 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
886 sub string_to_ssh ($) {
888 if ($spec =~ m/\s/) {
889 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
895 sub access_cfg_ssh () {
896 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
897 if (!defined $gitssh) {
900 return string_to_ssh $gitssh;
904 sub access_runeinfo ($) {
906 return ": dgit ".access_basedistro()." $info ;";
909 sub access_someuserhost ($) {
911 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
912 defined($user) && length($user) or
913 $user = access_cfg("$some-user",'username');
914 my $host = access_cfg("$some-host");
915 return length($user) ? "$user\@$host" : $host;
918 sub access_gituserhost () {
919 return access_someuserhost('git');
922 sub access_giturl (;$) {
924 my $url = access_cfg('git-url','RETURN-UNDEF');
927 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
928 return undef unless defined $proto;
931 access_gituserhost().
932 access_cfg('git-path');
934 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
937 return "$url/$package$suffix";
940 sub parsecontrolfh ($$;$) {
941 my ($fh, $desc, $allowsigned) = @_;
942 our $dpkgcontrolhash_noissigned;
945 my %opts = ('name' => $desc);
946 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
947 $c = Dpkg::Control::Hash->new(%opts);
948 $c->parse($fh,$desc) or die "parsing of $desc failed";
949 last if $allowsigned;
950 last if $dpkgcontrolhash_noissigned;
951 my $issigned= $c->get_option('is_pgp_signed');
952 if (!defined $issigned) {
953 $dpkgcontrolhash_noissigned= 1;
954 seek $fh, 0,0 or die "seek $desc: $!";
955 } elsif ($issigned) {
956 fail "control file $desc is (already) PGP-signed. ".
957 " Note that dgit push needs to modify the .dsc and then".
958 " do the signature itself";
967 my ($file, $desc, $allowsigned) = @_;
968 my $fh = new IO::Handle;
969 open $fh, '<', $file or die "$file: $!";
970 my $c = parsecontrolfh($fh,$desc,$allowsigned);
971 $fh->error and die $!;
977 my ($dctrl,$field) = @_;
978 my $v = $dctrl->{$field};
979 return $v if defined $v;
980 fail "missing field $field in ".$dctrl->get_option('name');
984 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
985 my $p = new IO::Handle;
986 my @cmd = (qw(dpkg-parsechangelog), @_);
987 open $p, '-|', @cmd or die $!;
989 $?=0; $!=0; close $p or failedcmd @cmd;
993 sub commit_getclogp ($) {
994 # Returns the parsed changelog hashref for a particular commit
996 our %commit_getclogp_memo;
997 my $memo = $commit_getclogp_memo{$objid};
998 return $memo if $memo;
1000 my $mclog = ".git/dgit/clog-$objid";
1001 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
1002 "$objid:debian/changelog";
1003 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
1006 sub must_getcwd () {
1008 defined $d or fail "getcwd failed: $!";
1012 sub parse_dscdata () {
1013 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1014 printdebug Dumper($dscdata) if $debuglevel>1;
1015 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1016 printdebug Dumper($dsc) if $debuglevel>1;
1021 sub archive_query ($;@) {
1022 my ($method) = shift @_;
1023 fail "this operation does not support multiple comma-separated suites"
1025 my $query = access_cfg('archive-query','RETURN-UNDEF');
1026 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1029 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1032 sub archive_query_prepend_mirror {
1033 my $m = access_cfg('mirror');
1034 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1037 sub pool_dsc_subpath ($$) {
1038 my ($vsn,$component) = @_; # $package is implict arg
1039 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1040 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1043 sub cfg_apply_map ($$$) {
1044 my ($varref, $what, $mapspec) = @_;
1045 return unless $mapspec;
1047 printdebug "config $what EVAL{ $mapspec; }\n";
1049 eval "package Dgit::Config; $mapspec;";
1054 #---------- `ftpmasterapi' archive query method (nascent) ----------
1056 sub archive_api_query_cmd ($) {
1058 my @cmd = (@curl, qw(-sS));
1059 my $url = access_cfg('archive-query-url');
1060 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1062 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1063 foreach my $key (split /\:/, $keys) {
1064 $key =~ s/\%HOST\%/$host/g;
1066 fail "for $url: stat $key: $!" unless $!==ENOENT;
1069 fail "config requested specific TLS key but do not know".
1070 " how to get curl to use exactly that EE key ($key)";
1071 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1072 # # Sadly the above line does not work because of changes
1073 # # to gnutls. The real fix for #790093 may involve
1074 # # new curl options.
1077 # Fixing #790093 properly will involve providing a value
1078 # for this on clients.
1079 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1080 push @cmd, split / /, $kargs if defined $kargs;
1082 push @cmd, $url.$subpath;
1086 sub api_query ($$;$) {
1088 my ($data, $subpath, $ok404) = @_;
1089 badcfg "ftpmasterapi archive query method takes no data part"
1091 my @cmd = archive_api_query_cmd($subpath);
1092 my $url = $cmd[$#cmd];
1093 push @cmd, qw(-w %{http_code});
1094 my $json = cmdoutput @cmd;
1095 unless ($json =~ s/\d+\d+\d$//) {
1096 failedcmd_report_cmd undef, @cmd;
1097 fail "curl failed to print 3-digit HTTP code";
1100 return undef if $code eq '404' && $ok404;
1101 fail "fetch of $url gave HTTP code $code"
1102 unless $url =~ m#^file://# or $code =~ m/^2/;
1103 return decode_json($json);
1106 sub canonicalise_suite_ftpmasterapi {
1107 my ($proto,$data) = @_;
1108 my $suites = api_query($data, 'suites');
1110 foreach my $entry (@$suites) {
1112 my $v = $entry->{$_};
1113 defined $v && $v eq $isuite;
1114 } qw(codename name);
1115 push @matched, $entry;
1117 fail "unknown suite $isuite" unless @matched;
1120 @matched==1 or die "multiple matches for suite $isuite\n";
1121 $cn = "$matched[0]{codename}";
1122 defined $cn or die "suite $isuite info has no codename\n";
1123 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1125 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1130 sub archive_query_ftpmasterapi {
1131 my ($proto,$data) = @_;
1132 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1134 my $digester = Digest::SHA->new(256);
1135 foreach my $entry (@$info) {
1137 my $vsn = "$entry->{version}";
1138 my ($ok,$msg) = version_check $vsn;
1139 die "bad version: $msg\n" unless $ok;
1140 my $component = "$entry->{component}";
1141 $component =~ m/^$component_re$/ or die "bad component";
1142 my $filename = "$entry->{filename}";
1143 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1144 or die "bad filename";
1145 my $sha256sum = "$entry->{sha256sum}";
1146 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1147 push @rows, [ $vsn, "/pool/$component/$filename",
1148 $digester, $sha256sum ];
1150 die "bad ftpmaster api response: $@\n".Dumper($entry)
1153 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1154 return archive_query_prepend_mirror @rows;
1157 sub file_in_archive_ftpmasterapi {
1158 my ($proto,$data,$filename) = @_;
1159 my $pat = $filename;
1162 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1163 my $info = api_query($data, "file_in_archive/$pat", 1);
1166 #---------- `aptget' archive query method ----------
1169 our $aptget_releasefile;
1170 our $aptget_configpath;
1172 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1173 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1175 sub aptget_cache_clean {
1176 runcmd_ordryrun_local qw(sh -ec),
1177 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1181 sub aptget_lock_acquire () {
1182 my $lockfile = "$aptget_base/lock";
1183 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1184 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1187 sub aptget_prep ($) {
1189 return if defined $aptget_base;
1191 badcfg "aptget archive query method takes no data part"
1194 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1197 ensuredir "$cache/dgit";
1199 access_cfg('aptget-cachekey','RETURN-UNDEF')
1200 // access_nomdistro();
1202 $aptget_base = "$cache/dgit/aptget";
1203 ensuredir $aptget_base;
1205 my $quoted_base = $aptget_base;
1206 die "$quoted_base contains bad chars, cannot continue"
1207 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1209 ensuredir $aptget_base;
1211 aptget_lock_acquire();
1213 aptget_cache_clean();
1215 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1216 my $sourceslist = "source.list#$cachekey";
1218 my $aptsuites = $isuite;
1219 cfg_apply_map(\$aptsuites, 'suite map',
1220 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1222 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1223 printf SRCS "deb-src %s %s %s\n",
1224 access_cfg('mirror'),
1226 access_cfg('aptget-components')
1229 ensuredir "$aptget_base/cache";
1230 ensuredir "$aptget_base/lists";
1232 open CONF, ">", $aptget_configpath or die $!;
1234 Debug::NoLocking "true";
1235 APT::Get::List-Cleanup "false";
1236 #clear APT::Update::Post-Invoke-Success;
1237 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1238 Dir::State::Lists "$quoted_base/lists";
1239 Dir::Etc::preferences "$quoted_base/preferences";
1240 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1241 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1244 foreach my $key (qw(
1247 Dir::Cache::Archives
1248 Dir::Etc::SourceParts
1249 Dir::Etc::preferencesparts
1251 ensuredir "$aptget_base/$key";
1252 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1255 my $oldatime = (time // die $!) - 1;
1256 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1257 next unless stat_exists $oldlist;
1258 my ($mtime) = (stat _)[9];
1259 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1262 runcmd_ordryrun_local aptget_aptget(), qw(update);
1265 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1266 next unless stat_exists $oldlist;
1267 my ($atime) = (stat _)[8];
1268 next if $atime == $oldatime;
1269 push @releasefiles, $oldlist;
1271 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1272 @releasefiles = @inreleasefiles if @inreleasefiles;
1273 die "apt updated wrong number of Release files (@releasefiles), erk"
1274 unless @releasefiles == 1;
1276 ($aptget_releasefile) = @releasefiles;
1279 sub canonicalise_suite_aptget {
1280 my ($proto,$data) = @_;
1283 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1285 foreach my $name (qw(Codename Suite)) {
1286 my $val = $release->{$name};
1288 printdebug "release file $name: $val\n";
1289 $val =~ m/^$suite_re$/o or fail
1290 "Release file ($aptget_releasefile) specifies intolerable $name";
1291 cfg_apply_map(\$val, 'suite rmap',
1292 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1299 sub archive_query_aptget {
1300 my ($proto,$data) = @_;
1303 ensuredir "$aptget_base/source";
1304 foreach my $old (<$aptget_base/source/*.dsc>) {
1305 unlink $old or die "$old: $!";
1308 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1309 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1310 # avoids apt-get source failing with ambiguous error code
1312 runcmd_ordryrun_local
1313 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1314 aptget_aptget(), qw(--download-only --only-source source), $package;
1316 my @dscs = <$aptget_base/source/*.dsc>;
1317 fail "apt-get source did not produce a .dsc" unless @dscs;
1318 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1320 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1323 my $uri = "file://". uri_escape $dscs[0];
1324 $uri =~ s{\%2f}{/}gi;
1325 return [ (getfield $pre_dsc, 'Version'), $uri ];
1328 sub file_in_archive_aptget () { return undef; }
1330 #---------- `dummyapicat' archive query method ----------
1332 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1333 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1335 sub file_in_archive_dummycatapi ($$$) {
1336 my ($proto,$data,$filename) = @_;
1337 my $mirror = access_cfg('mirror');
1338 $mirror =~ s#^file://#/# or die "$mirror ?";
1340 my @cmd = (qw(sh -ec), '
1342 find -name "$2" -print0 |
1344 ', qw(x), $mirror, $filename);
1345 debugcmd "-|", @cmd;
1346 open FIA, "-|", @cmd or die $!;
1349 printdebug "| $_\n";
1350 m/^(\w+) (\S+)$/ or die "$_ ?";
1351 push @out, { sha256sum => $1, filename => $2 };
1353 close FIA or die failedcmd @cmd;
1357 #---------- `madison' archive query method ----------
1359 sub archive_query_madison {
1360 return archive_query_prepend_mirror
1361 map { [ @$_[0..1] ] } madison_get_parse(@_);
1364 sub madison_get_parse {
1365 my ($proto,$data) = @_;
1366 die unless $proto eq 'madison';
1367 if (!length $data) {
1368 $data= access_cfg('madison-distro','RETURN-UNDEF');
1369 $data //= access_basedistro();
1371 $rmad{$proto,$data,$package} ||= cmdoutput
1372 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1373 my $rmad = $rmad{$proto,$data,$package};
1376 foreach my $l (split /\n/, $rmad) {
1377 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1378 \s*( [^ \t|]+ )\s* \|
1379 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1380 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1381 $1 eq $package or die "$rmad $package ?";
1388 $component = access_cfg('archive-query-default-component');
1390 $5 eq 'source' or die "$rmad ?";
1391 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1393 return sort { -version_compare($a->[0],$b->[0]); } @out;
1396 sub canonicalise_suite_madison {
1397 # madison canonicalises for us
1398 my @r = madison_get_parse(@_);
1400 "unable to canonicalise suite using package $package".
1401 " which does not appear to exist in suite $isuite;".
1402 " --existing-package may help";
1406 sub file_in_archive_madison { return undef; }
1408 #---------- `sshpsql' archive query method ----------
1411 my ($data,$runeinfo,$sql) = @_;
1412 if (!length $data) {
1413 $data= access_someuserhost('sshpsql').':'.
1414 access_cfg('sshpsql-dbname');
1416 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1417 my ($userhost,$dbname) = ($`,$'); #';
1419 my @cmd = (access_cfg_ssh, $userhost,
1420 access_runeinfo("ssh-psql $runeinfo").
1421 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1422 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1424 open P, "-|", @cmd or die $!;
1427 printdebug(">|$_|\n");
1430 $!=0; $?=0; close P or failedcmd @cmd;
1432 my $nrows = pop @rows;
1433 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1434 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1435 @rows = map { [ split /\|/, $_ ] } @rows;
1436 my $ncols = scalar @{ shift @rows };
1437 die if grep { scalar @$_ != $ncols } @rows;
1441 sub sql_injection_check {
1442 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1445 sub archive_query_sshpsql ($$) {
1446 my ($proto,$data) = @_;
1447 sql_injection_check $isuite, $package;
1448 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1449 SELECT source.version, component.name, files.filename, files.sha256sum
1451 JOIN src_associations ON source.id = src_associations.source
1452 JOIN suite ON suite.id = src_associations.suite
1453 JOIN dsc_files ON dsc_files.source = source.id
1454 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1455 JOIN component ON component.id = files_archive_map.component_id
1456 JOIN files ON files.id = dsc_files.file
1457 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1458 AND source.source='$package'
1459 AND files.filename LIKE '%.dsc';
1461 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1462 my $digester = Digest::SHA->new(256);
1464 my ($vsn,$component,$filename,$sha256sum) = @$_;
1465 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1467 return archive_query_prepend_mirror @rows;
1470 sub canonicalise_suite_sshpsql ($$) {
1471 my ($proto,$data) = @_;
1472 sql_injection_check $isuite;
1473 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1474 SELECT suite.codename
1475 FROM suite where suite_name='$isuite' or codename='$isuite';
1477 @rows = map { $_->[0] } @rows;
1478 fail "unknown suite $isuite" unless @rows;
1479 die "ambiguous $isuite: @rows ?" if @rows>1;
1483 sub file_in_archive_sshpsql ($$$) { return undef; }
1485 #---------- `dummycat' archive query method ----------
1487 sub canonicalise_suite_dummycat ($$) {
1488 my ($proto,$data) = @_;
1489 my $dpath = "$data/suite.$isuite";
1490 if (!open C, "<", $dpath) {
1491 $!==ENOENT or die "$dpath: $!";
1492 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1496 chomp or die "$dpath: $!";
1498 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1502 sub archive_query_dummycat ($$) {
1503 my ($proto,$data) = @_;
1504 canonicalise_suite();
1505 my $dpath = "$data/package.$csuite.$package";
1506 if (!open C, "<", $dpath) {
1507 $!==ENOENT or die "$dpath: $!";
1508 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1516 printdebug "dummycat query $csuite $package $dpath | $_\n";
1517 my @row = split /\s+/, $_;
1518 @row==2 or die "$dpath: $_ ?";
1521 C->error and die "$dpath: $!";
1523 return archive_query_prepend_mirror
1524 sort { -version_compare($a->[0],$b->[0]); } @rows;
1527 sub file_in_archive_dummycat () { return undef; }
1529 #---------- tag format handling ----------
1531 sub access_cfg_tagformats () {
1532 split /\,/, access_cfg('dgit-tag-format');
1535 sub access_cfg_tagformats_can_splitbrain () {
1536 my %y = map { $_ => 1 } access_cfg_tagformats;
1537 foreach my $needtf (qw(new maint)) {
1538 next if $y{$needtf};
1544 sub need_tagformat ($$) {
1545 my ($fmt, $why) = @_;
1546 fail "need to use tag format $fmt ($why) but also need".
1547 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1548 " - no way to proceed"
1549 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1550 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1553 sub select_tagformat () {
1555 return if $tagformatfn && !$tagformat_want;
1556 die 'bug' if $tagformatfn && $tagformat_want;
1557 # ... $tagformat_want assigned after previous select_tagformat
1559 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1560 printdebug "select_tagformat supported @supported\n";
1562 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1563 printdebug "select_tagformat specified @$tagformat_want\n";
1565 my ($fmt,$why,$override) = @$tagformat_want;
1567 fail "target distro supports tag formats @supported".
1568 " but have to use $fmt ($why)"
1570 or grep { $_ eq $fmt } @supported;
1572 $tagformat_want = undef;
1574 $tagformatfn = ${*::}{"debiantag_$fmt"};
1576 fail "trying to use unknown tag format \`$fmt' ($why) !"
1577 unless $tagformatfn;
1580 #---------- archive query entrypoints and rest of program ----------
1582 sub canonicalise_suite () {
1583 return if defined $csuite;
1584 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1585 $csuite = archive_query('canonicalise_suite');
1586 if ($isuite ne $csuite) {
1587 progress "canonical suite name for $isuite is $csuite";
1589 progress "canonical suite name is $csuite";
1593 sub get_archive_dsc () {
1594 canonicalise_suite();
1595 my @vsns = archive_query('archive_query');
1596 foreach my $vinfo (@vsns) {
1597 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1598 $dscurl = $vsn_dscurl;
1599 $dscdata = url_get($dscurl);
1601 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1606 $digester->add($dscdata);
1607 my $got = $digester->hexdigest();
1609 fail "$dscurl has hash $got but".
1610 " archive told us to expect $digest";
1613 my $fmt = getfield $dsc, 'Format';
1614 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1615 "unsupported source format $fmt, sorry";
1617 $dsc_checked = !!$digester;
1618 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1622 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1625 sub check_for_git ();
1626 sub check_for_git () {
1628 my $how = access_cfg('git-check');
1629 if ($how eq 'ssh-cmd') {
1631 (access_cfg_ssh, access_gituserhost(),
1632 access_runeinfo("git-check $package").
1633 " set -e; cd ".access_cfg('git-path').";".
1634 " if test -d $package.git; then echo 1; else echo 0; fi");
1635 my $r= cmdoutput @cmd;
1636 if (defined $r and $r =~ m/^divert (\w+)$/) {
1638 my ($usedistro,) = access_distros();
1639 # NB that if we are pushing, $usedistro will be $distro/push
1640 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1641 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1642 progress "diverting to $divert (using config for $instead_distro)";
1643 return check_for_git();
1645 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1647 } elsif ($how eq 'url') {
1648 my $prefix = access_cfg('git-check-url','git-url');
1649 my $suffix = access_cfg('git-check-suffix','git-suffix',
1650 'RETURN-UNDEF') // '.git';
1651 my $url = "$prefix/$package$suffix";
1652 my @cmd = (@curl, qw(-sS -I), $url);
1653 my $result = cmdoutput @cmd;
1654 $result =~ s/^\S+ 200 .*\n\r?\n//;
1655 # curl -sS -I with https_proxy prints
1656 # HTTP/1.0 200 Connection established
1657 $result =~ m/^\S+ (404|200) /s or
1658 fail "unexpected results from git check query - ".
1659 Dumper($prefix, $result);
1661 if ($code eq '404') {
1663 } elsif ($code eq '200') {
1668 } elsif ($how eq 'true') {
1670 } elsif ($how eq 'false') {
1673 badcfg "unknown git-check \`$how'";
1677 sub create_remote_git_repo () {
1678 my $how = access_cfg('git-create');
1679 if ($how eq 'ssh-cmd') {
1681 (access_cfg_ssh, access_gituserhost(),
1682 access_runeinfo("git-create $package").
1683 "set -e; cd ".access_cfg('git-path').";".
1684 " cp -a _template $package.git");
1685 } elsif ($how eq 'true') {
1688 badcfg "unknown git-create \`$how'";
1692 our ($dsc_hash,$lastpush_mergeinput);
1693 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1695 our $ud = '.git/dgit/unpack';
1705 sub mktree_in_ud_here () {
1706 runcmd qw(git init -q);
1707 runcmd qw(git config gc.auto 0);
1708 foreach my $copy (qw(user.email user.name user.useConfigOnly)) {
1709 my $v = $gitcfgs{local}{$copy};
1711 runcmd qw(git config), $copy, $_ foreach @$v;
1713 rmtree('.git/objects');
1714 symlink '../../../../objects','.git/objects' or die $!;
1718 sub git_write_tree () {
1719 my $tree = cmdoutput @git, qw(write-tree);
1720 $tree =~ m/^\w+$/ or die "$tree ?";
1724 sub git_add_write_tree () {
1725 runcmd @git, qw(add -Af .);
1726 return git_write_tree();
1729 sub remove_stray_gits ($) {
1731 my @gitscmd = qw(find -name .git -prune -print0);
1732 debugcmd "|",@gitscmd;
1733 open GITS, "-|", @gitscmd or die $!;
1738 print STDERR "$us: warning: removing from $what: ",
1739 (messagequote $_), "\n";
1743 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1746 sub mktree_in_ud_from_only_subdir ($;$) {
1747 my ($what,$raw) = @_;
1749 # changes into the subdir
1751 die "expected one subdir but found @dirs ?" unless @dirs==1;
1752 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1756 remove_stray_gits($what);
1757 mktree_in_ud_here();
1759 my ($format, $fopts) = get_source_format();
1760 if (madformat($format)) {
1765 my $tree=git_add_write_tree();
1766 return ($tree,$dir);
1769 our @files_csum_info_fields =
1770 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1771 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1772 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1774 sub dsc_files_info () {
1775 foreach my $csumi (@files_csum_info_fields) {
1776 my ($fname, $module, $method) = @$csumi;
1777 my $field = $dsc->{$fname};
1778 next unless defined $field;
1779 eval "use $module; 1;" or die $@;
1781 foreach (split /\n/, $field) {
1783 m/^(\w+) (\d+) (\S+)$/ or
1784 fail "could not parse .dsc $fname line \`$_'";
1785 my $digester = eval "$module"."->$method;" or die $@;
1790 Digester => $digester,
1795 fail "missing any supported Checksums-* or Files field in ".
1796 $dsc->get_option('name');
1800 map { $_->{Filename} } dsc_files_info();
1803 sub files_compare_inputs (@) {
1808 my $showinputs = sub {
1809 return join "; ", map { $_->get_option('name') } @$inputs;
1812 foreach my $in (@$inputs) {
1814 my $in_name = $in->get_option('name');
1816 printdebug "files_compare_inputs $in_name\n";
1818 foreach my $csumi (@files_csum_info_fields) {
1819 my ($fname) = @$csumi;
1820 printdebug "files_compare_inputs $in_name $fname\n";
1822 my $field = $in->{$fname};
1823 next unless defined $field;
1826 foreach (split /\n/, $field) {
1829 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1830 fail "could not parse $in_name $fname line \`$_'";
1832 printdebug "files_compare_inputs $in_name $fname $f\n";
1836 my $re = \ $record{$f}{$fname};
1838 $fchecked{$f}{$in_name} = 1;
1840 fail "hash or size of $f varies in $fname fields".
1841 " (between: ".$showinputs->().")";
1846 @files = sort @files;
1847 $expected_files //= \@files;
1848 "@$expected_files" eq "@files" or
1849 fail "file list in $in_name varies between hash fields!";
1852 fail "$in_name has no files list field(s)";
1854 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1857 grep { keys %$_ == @$inputs-1 } values %fchecked
1858 or fail "no file appears in all file lists".
1859 " (looked in: ".$showinputs->().")";
1862 sub is_orig_file_in_dsc ($$) {
1863 my ($f, $dsc_files_info) = @_;
1864 return 0 if @$dsc_files_info <= 1;
1865 # One file means no origs, and the filename doesn't have a "what
1866 # part of dsc" component. (Consider versions ending `.orig'.)
1867 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1871 sub is_orig_file_of_vsn ($$) {
1872 my ($f, $upstreamvsn) = @_;
1873 my $base = srcfn $upstreamvsn, '';
1874 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1878 sub changes_update_origs_from_dsc ($$$$) {
1879 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1881 printdebug "checking origs needed ($upstreamvsn)...\n";
1882 $_ = getfield $changes, 'Files';
1883 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1884 fail "cannot find section/priority from .changes Files field";
1885 my $placementinfo = $1;
1887 printdebug "checking origs needed placement '$placementinfo'...\n";
1888 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1889 $l =~ m/\S+$/ or next;
1891 printdebug "origs $file | $l\n";
1892 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1893 printdebug "origs $file is_orig\n";
1894 my $have = archive_query('file_in_archive', $file);
1895 if (!defined $have) {
1897 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1903 printdebug "origs $file \$#\$have=$#$have\n";
1904 foreach my $h (@$have) {
1907 foreach my $csumi (@files_csum_info_fields) {
1908 my ($fname, $module, $method, $archivefield) = @$csumi;
1909 next unless defined $h->{$archivefield};
1910 $_ = $dsc->{$fname};
1911 next unless defined;
1912 m/^(\w+) .* \Q$file\E$/m or
1913 fail ".dsc $fname missing entry for $file";
1914 if ($h->{$archivefield} eq $1) {
1918 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1921 die "$file ".Dumper($h)." ?!" if $same && @differ;
1924 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1927 printdebug "origs $file f.same=$found_same".
1928 " #f._differ=$#found_differ\n";
1929 if (@found_differ && !$found_same) {
1931 "archive contains $file with different checksum",
1934 # Now we edit the changes file to add or remove it
1935 foreach my $csumi (@files_csum_info_fields) {
1936 my ($fname, $module, $method, $archivefield) = @$csumi;
1937 next unless defined $changes->{$fname};
1939 # in archive, delete from .changes if it's there
1940 $changed{$file} = "removed" if
1941 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1942 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1943 # not in archive, but it's here in the .changes
1945 my $dsc_data = getfield $dsc, $fname;
1946 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1948 $extra =~ s/ \d+ /$&$placementinfo /
1949 or die "$fname $extra >$dsc_data< ?"
1950 if $fname eq 'Files';
1951 $changes->{$fname} .= "\n". $extra;
1952 $changed{$file} = "added";
1957 foreach my $file (keys %changed) {
1959 "edited .changes for archive .orig contents: %s %s",
1960 $changed{$file}, $file;
1962 my $chtmp = "$changesfile.tmp";
1963 $changes->save($chtmp);
1965 rename $chtmp,$changesfile or die "$changesfile $!";
1967 progress "[new .changes left in $changesfile]";
1970 progress "$changesfile already has appropriate .orig(s) (if any)";
1974 sub make_commit ($) {
1976 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1979 sub make_commit_text ($) {
1982 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1984 print Dumper($text) if $debuglevel > 1;
1985 my $child = open2($out, $in, @cmd) or die $!;
1988 print $in $text or die $!;
1989 close $in or die $!;
1991 $h =~ m/^\w+$/ or die;
1993 printdebug "=> $h\n";
1996 waitpid $child, 0 == $child or die "$child $!";
1997 $? and failedcmd @cmd;
2001 sub clogp_authline ($) {
2003 my $author = getfield $clogp, 'Maintainer';
2004 if ($author =~ m/^[^"\@]+\,/) {
2005 # single entry Maintainer field with unquoted comma
2006 $author = ($& =~ y/,//rd).$'; # strip the comma
2008 # git wants a single author; any remaining commas in $author
2009 # are by now preceded by @ (or "). It seems safer to punt on
2010 # "..." for now rather than attempting to dequote or something.
2011 $author =~ s#,.*##ms unless $author =~ m/"/;
2012 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2013 my $authline = "$author $date";
2014 $authline =~ m/$git_authline_re/o or
2015 fail "unexpected commit author line format \`$authline'".
2016 " (was generated from changelog Maintainer field)";
2017 return ($1,$2,$3) if wantarray;
2021 sub vendor_patches_distro ($$) {
2022 my ($checkdistro, $what) = @_;
2023 return unless defined $checkdistro;
2025 my $series = "debian/patches/\L$checkdistro\E.series";
2026 printdebug "checking for vendor-specific $series ($what)\n";
2028 if (!open SERIES, "<", $series) {
2029 die "$series $!" unless $!==ENOENT;
2038 Unfortunately, this source package uses a feature of dpkg-source where
2039 the same source package unpacks to different source code on different
2040 distros. dgit cannot safely operate on such packages on affected
2041 distros, because the meaning of source packages is not stable.
2043 Please ask the distro/maintainer to remove the distro-specific series
2044 files and use a different technique (if necessary, uploading actually
2045 different packages, if different distros are supposed to have
2049 fail "Found active distro-specific series file for".
2050 " $checkdistro ($what): $series, cannot continue";
2052 die "$series $!" if SERIES->error;
2056 sub check_for_vendor_patches () {
2057 # This dpkg-source feature doesn't seem to be documented anywhere!
2058 # But it can be found in the changelog (reformatted):
2060 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2061 # Author: Raphael Hertzog <hertzog@debian.org>
2062 # Date: Sun Oct 3 09:36:48 2010 +0200
2064 # dpkg-source: correctly create .pc/.quilt_series with alternate
2067 # If you have debian/patches/ubuntu.series and you were
2068 # unpacking the source package on ubuntu, quilt was still
2069 # directed to debian/patches/series instead of
2070 # debian/patches/ubuntu.series.
2072 # debian/changelog | 3 +++
2073 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2074 # 2 files changed, 6 insertions(+), 1 deletion(-)
2077 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2078 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2079 "Dpkg::Vendor \`current vendor'");
2080 vendor_patches_distro(access_basedistro(),
2081 "(base) distro being accessed");
2082 vendor_patches_distro(access_nomdistro(),
2083 "(nominal) distro being accessed");
2086 sub generate_commits_from_dsc () {
2087 # See big comment in fetch_from_archive, below.
2088 # See also README.dsc-import.
2092 my @dfi = dsc_files_info();
2093 foreach my $fi (@dfi) {
2094 my $f = $fi->{Filename};
2095 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2096 my $upper_f = "../../../../$f";
2098 printdebug "considering reusing $f: ";
2100 if (link_ltarget "$upper_f,fetch", $f) {
2101 printdebug "linked (using ...,fetch).\n";
2102 } elsif ((printdebug "($!) "),
2104 fail "accessing ../$f,fetch: $!";
2105 } elsif (link_ltarget $upper_f, $f) {
2106 printdebug "linked.\n";
2107 } elsif ((printdebug "($!) "),
2109 fail "accessing ../$f: $!";
2111 printdebug "absent.\n";
2115 complete_file_from_dsc('.', $fi, \$refetched)
2118 printdebug "considering saving $f: ";
2120 if (link $f, $upper_f) {
2121 printdebug "linked.\n";
2122 } elsif ((printdebug "($!) "),
2124 fail "saving ../$f: $!";
2125 } elsif (!$refetched) {
2126 printdebug "no need.\n";
2127 } elsif (link $f, "$upper_f,fetch") {
2128 printdebug "linked (using ...,fetch).\n";
2129 } elsif ((printdebug "($!) "),
2131 fail "saving ../$f,fetch: $!";
2133 printdebug "cannot.\n";
2137 # We unpack and record the orig tarballs first, so that we only
2138 # need disk space for one private copy of the unpacked source.
2139 # But we can't make them into commits until we have the metadata
2140 # from the debian/changelog, so we record the tree objects now and
2141 # make them into commits later.
2143 my $upstreamv = upstreamversion $dsc->{version};
2144 my $orig_f_base = srcfn $upstreamv, '';
2146 foreach my $fi (@dfi) {
2147 # We actually import, and record as a commit, every tarball
2148 # (unless there is only one file, in which case there seems
2151 my $f = $fi->{Filename};
2152 printdebug "import considering $f ";
2153 (printdebug "only one dfi\n"), next if @dfi == 1;
2154 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2155 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2159 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2161 printdebug "Y ", (join ' ', map { $_//"(none)" }
2162 $compr_ext, $orig_f_part
2165 my $input = new IO::File $f, '<' or die "$f $!";
2169 if (defined $compr_ext) {
2171 Dpkg::Compression::compression_guess_from_filename $f;
2172 fail "Dpkg::Compression cannot handle file $f in source package"
2173 if defined $compr_ext && !defined $cname;
2175 new Dpkg::Compression::Process compression => $cname;
2176 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2177 my $compr_fh = new IO::Handle;
2178 my $compr_pid = open $compr_fh, "-|" // die $!;
2180 open STDIN, "<&", $input or die $!;
2182 die "dgit (child): exec $compr_cmd[0]: $!\n";
2187 rmtree "_unpack-tar";
2188 mkdir "_unpack-tar" or die $!;
2189 my @tarcmd = qw(tar -x -f -
2190 --no-same-owner --no-same-permissions
2191 --no-acls --no-xattrs --no-selinux);
2192 my $tar_pid = fork // die $!;
2194 chdir "_unpack-tar" or die $!;
2195 open STDIN, "<&", $input or die $!;
2197 die "dgit (child): exec $tarcmd[0]: $!";
2199 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2200 !$? or failedcmd @tarcmd;
2203 (@compr_cmd ? failedcmd @compr_cmd
2205 # finally, we have the results in "tarball", but maybe
2206 # with the wrong permissions
2208 runcmd qw(chmod -R +rwX _unpack-tar);
2209 changedir "_unpack-tar";
2210 remove_stray_gits($f);
2211 mktree_in_ud_here();
2213 my ($tree) = git_add_write_tree();
2214 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2215 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2217 printdebug "one subtree $1\n";
2219 printdebug "multiple subtrees\n";
2222 rmtree "_unpack-tar";
2224 my $ent = [ $f, $tree ];
2226 Orig => !!$orig_f_part,
2227 Sort => (!$orig_f_part ? 2 :
2228 $orig_f_part =~ m/-/g ? 1 :
2236 # put any without "_" first (spec is not clear whether files
2237 # are always in the usual order). Tarballs without "_" are
2238 # the main orig or the debian tarball.
2239 $a->{Sort} <=> $b->{Sort} or
2243 my $any_orig = grep { $_->{Orig} } @tartrees;
2245 my $dscfn = "$package.dsc";
2247 my $treeimporthow = 'package';
2249 open D, ">", $dscfn or die "$dscfn: $!";
2250 print D $dscdata or die "$dscfn: $!";
2251 close D or die "$dscfn: $!";
2252 my @cmd = qw(dpkg-source);
2253 push @cmd, '--no-check' if $dsc_checked;
2254 if (madformat $dsc->{format}) {
2255 push @cmd, '--skip-patches';
2256 $treeimporthow = 'unpatched';
2258 push @cmd, qw(-x --), $dscfn;
2261 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2262 if (madformat $dsc->{format}) {
2263 check_for_vendor_patches();
2267 if (madformat $dsc->{format}) {
2268 my @pcmd = qw(dpkg-source --before-build .);
2269 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2271 $dappliedtree = git_add_write_tree();
2274 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2275 debugcmd "|",@clogcmd;
2276 open CLOGS, "-|", @clogcmd or die $!;
2281 printdebug "import clog search...\n";
2284 my $stanzatext = do { local $/=""; <CLOGS>; };
2285 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2286 last if !defined $stanzatext;
2288 my $desc = "package changelog, entry no.$.";
2289 open my $stanzafh, "<", \$stanzatext or die;
2290 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2291 $clogp //= $thisstanza;
2293 printdebug "import clog $thisstanza->{version} $desc...\n";
2295 last if !$any_orig; # we don't need $r1clogp
2297 # We look for the first (most recent) changelog entry whose
2298 # version number is lower than the upstream version of this
2299 # package. Then the last (least recent) previous changelog
2300 # entry is treated as the one which introduced this upstream
2301 # version and used for the synthetic commits for the upstream
2304 # One might think that a more sophisticated algorithm would be
2305 # necessary. But: we do not want to scan the whole changelog
2306 # file. Stopping when we see an earlier version, which
2307 # necessarily then is an earlier upstream version, is the only
2308 # realistic way to do that. Then, either the earliest
2309 # changelog entry we have seen so far is indeed the earliest
2310 # upload of this upstream version; or there are only changelog
2311 # entries relating to later upstream versions (which is not
2312 # possible unless the changelog and .dsc disagree about the
2313 # version). Then it remains to choose between the physically
2314 # last entry in the file, and the one with the lowest version
2315 # number. If these are not the same, we guess that the
2316 # versions were created in a non-monotic order rather than
2317 # that the changelog entries have been misordered.
2319 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2321 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2322 $r1clogp = $thisstanza;
2324 printdebug "import clog $r1clogp->{version} becomes r1\n";
2326 die $! if CLOGS->error;
2327 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2329 $clogp or fail "package changelog has no entries!";
2331 my $authline = clogp_authline $clogp;
2332 my $changes = getfield $clogp, 'Changes';
2333 $changes =~ s/^\n//; # Changes: \n
2334 my $cversion = getfield $clogp, 'Version';
2337 $r1clogp //= $clogp; # maybe there's only one entry;
2338 my $r1authline = clogp_authline $r1clogp;
2339 # Strictly, r1authline might now be wrong if it's going to be
2340 # unused because !$any_orig. Whatever.
2342 printdebug "import tartrees authline $authline\n";
2343 printdebug "import tartrees r1authline $r1authline\n";
2345 foreach my $tt (@tartrees) {
2346 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2348 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2351 committer $r1authline
2355 [dgit import orig $tt->{F}]
2363 [dgit import tarball $package $cversion $tt->{F}]
2368 printdebug "import main commit\n";
2370 open C, ">../commit.tmp" or die $!;
2371 print C <<END or die $!;
2374 print C <<END or die $! foreach @tartrees;
2377 print C <<END or die $!;
2383 [dgit import $treeimporthow $package $cversion]
2387 my $rawimport_hash = make_commit qw(../commit.tmp);
2389 if (madformat $dsc->{format}) {
2390 printdebug "import apply patches...\n";
2392 # regularise the state of the working tree so that
2393 # the checkout of $rawimport_hash works nicely.
2394 my $dappliedcommit = make_commit_text(<<END);
2401 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2403 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2405 # We need the answers to be reproducible
2406 my @authline = clogp_authline($clogp);
2407 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2408 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2409 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2410 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2411 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2412 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2414 my $path = $ENV{PATH} or die;
2416 foreach my $use_absurd (qw(0 1)) {
2417 runcmd @git, qw(checkout -q unpa);
2418 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2419 local $ENV{PATH} = $path;
2422 progress "warning: $@";
2423 $path = "$absurdity:$path";
2424 progress "$us: trying slow absurd-git-apply...";
2425 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2430 die "forbid absurd git-apply\n" if $use_absurd
2431 && forceing [qw(import-gitapply-no-absurd)];
2432 die "only absurd git-apply!\n" if !$use_absurd
2433 && forceing [qw(import-gitapply-absurd)];
2435 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2436 local $ENV{PATH} = $path if $use_absurd;
2438 my @showcmd = (gbp_pq, qw(import));
2439 my @realcmd = shell_cmd
2440 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2441 debugcmd "+",@realcmd;
2442 if (system @realcmd) {
2443 die +(shellquote @showcmd).
2445 failedcmd_waitstatus()."\n";
2448 my $gapplied = git_rev_parse('HEAD');
2449 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2450 $gappliedtree eq $dappliedtree or
2452 gbp-pq import and dpkg-source disagree!
2453 gbp-pq import gave commit $gapplied
2454 gbp-pq import gave tree $gappliedtree
2455 dpkg-source --before-build gave tree $dappliedtree
2457 $rawimport_hash = $gapplied;
2462 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2467 progress "synthesised git commit from .dsc $cversion";
2469 my $rawimport_mergeinput = {
2470 Commit => $rawimport_hash,
2471 Info => "Import of source package",
2473 my @output = ($rawimport_mergeinput);
2475 if ($lastpush_mergeinput) {
2476 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2477 my $oversion = getfield $oldclogp, 'Version';
2479 version_compare($oversion, $cversion);
2481 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2482 { Message => <<END, ReverseParents => 1 });
2483 Record $package ($cversion) in archive suite $csuite
2485 } elsif ($vcmp > 0) {
2486 print STDERR <<END or die $!;
2488 Version actually in archive: $cversion (older)
2489 Last version pushed with dgit: $oversion (newer or same)
2492 @output = $lastpush_mergeinput;
2494 # Same version. Use what's in the server git branch,
2495 # discarding our own import. (This could happen if the
2496 # server automatically imports all packages into git.)
2497 @output = $lastpush_mergeinput;
2500 changedir '../../../..';
2505 sub complete_file_from_dsc ($$;$) {
2506 our ($dstdir, $fi, $refetched) = @_;
2507 # Ensures that we have, in $dstdir, the file $fi, with the correct
2508 # contents. (Downloading it from alongside $dscurl if necessary.)
2509 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2510 # and will set $$refetched=1 if it did so (or tried to).
2512 my $f = $fi->{Filename};
2513 my $tf = "$dstdir/$f";
2517 my $checkhash = sub {
2518 open F, "<", "$tf" or die "$tf: $!";
2519 $fi->{Digester}->reset();
2520 $fi->{Digester}->addfile(*F);
2521 F->error and die $!;
2522 $got = $fi->{Digester}->hexdigest();
2523 return $got eq $fi->{Hash};
2526 if (stat_exists $tf) {
2527 if ($checkhash->()) {
2528 progress "using existing $f";
2532 fail "file $f has hash $got but .dsc".
2533 " demands hash $fi->{Hash} ".
2534 "(perhaps you should delete this file?)";
2536 progress "need to fetch correct version of $f";
2537 unlink $tf or die "$tf $!";
2540 printdebug "$tf does not exist, need to fetch\n";
2544 $furl =~ s{/[^/]+$}{};
2546 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2547 die "$f ?" if $f =~ m#/#;
2548 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2549 return 0 if !act_local();
2552 fail "file $f has hash $got but .dsc".
2553 " demands hash $fi->{Hash} ".
2554 "(got wrong file from archive!)";
2559 sub ensure_we_have_orig () {
2560 my @dfi = dsc_files_info();
2561 foreach my $fi (@dfi) {
2562 my $f = $fi->{Filename};
2563 next unless is_orig_file_in_dsc($f, \@dfi);
2564 complete_file_from_dsc('..', $fi)
2569 #---------- git fetch ----------
2571 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2572 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2574 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2575 # locally fetched refs because they have unhelpful names and clutter
2576 # up gitk etc. So we track whether we have "used up" head ref (ie,
2577 # whether we have made another local ref which refers to this object).
2579 # (If we deleted them unconditionally, then we might end up
2580 # re-fetching the same git objects each time dgit fetch was run.)
2582 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2583 # in git_fetch_us to fetch the refs in question, and possibly a call
2584 # to lrfetchref_used.
2586 our (%lrfetchrefs_f, %lrfetchrefs_d);
2587 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2589 sub lrfetchref_used ($) {
2590 my ($fullrefname) = @_;
2591 my $objid = $lrfetchrefs_f{$fullrefname};
2592 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2595 sub git_lrfetch_sane {
2596 my ($url, $supplementary, @specs) = @_;
2597 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2598 # at least as regards @specs. Also leave the results in
2599 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2600 # able to clean these up.
2602 # With $supplementary==1, @specs must not contain wildcards
2603 # and we add to our previous fetches (non-atomically).
2605 # This is rather miserable:
2606 # When git fetch --prune is passed a fetchspec ending with a *,
2607 # it does a plausible thing. If there is no * then:
2608 # - it matches subpaths too, even if the supplied refspec
2609 # starts refs, and behaves completely madly if the source
2610 # has refs/refs/something. (See, for example, Debian #NNNN.)
2611 # - if there is no matching remote ref, it bombs out the whole
2613 # We want to fetch a fixed ref, and we don't know in advance
2614 # if it exists, so this is not suitable.
2616 # Our workaround is to use git ls-remote. git ls-remote has its
2617 # own qairks. Notably, it has the absurd multi-tail-matching
2618 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2619 # refs/refs/foo etc.
2621 # Also, we want an idempotent snapshot, but we have to make two
2622 # calls to the remote: one to git ls-remote and to git fetch. The
2623 # solution is use git ls-remote to obtain a target state, and
2624 # git fetch to try to generate it. If we don't manage to generate
2625 # the target state, we try again.
2627 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2629 my $specre = join '|', map {
2632 my $wildcard = $x =~ s/\\\*$/.*/;
2633 die if $wildcard && $supplementary;
2636 printdebug "git_lrfetch_sane specre=$specre\n";
2637 my $wanted_rref = sub {
2639 return m/^(?:$specre)$/;
2642 my $fetch_iteration = 0;
2645 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2646 if (++$fetch_iteration > 10) {
2647 fail "too many iterations trying to get sane fetch!";
2650 my @look = map { "refs/$_" } @specs;
2651 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2655 open GITLS, "-|", @lcmd or die $!;
2657 printdebug "=> ", $_;
2658 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2659 my ($objid,$rrefname) = ($1,$2);
2660 if (!$wanted_rref->($rrefname)) {
2662 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2666 $wantr{$rrefname} = $objid;
2669 close GITLS or failedcmd @lcmd;
2671 # OK, now %want is exactly what we want for refs in @specs
2673 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2674 "+refs/$_:".lrfetchrefs."/$_";
2677 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2679 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2680 runcmd_ordryrun_local @fcmd if @fspecs;
2682 if (!$supplementary) {
2683 %lrfetchrefs_f = ();
2687 git_for_each_ref(lrfetchrefs, sub {
2688 my ($objid,$objtype,$lrefname,$reftail) = @_;
2689 $lrfetchrefs_f{$lrefname} = $objid;
2690 $objgot{$objid} = 1;
2693 if ($supplementary) {
2697 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2698 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2699 if (!exists $wantr{$rrefname}) {
2700 if ($wanted_rref->($rrefname)) {
2702 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2706 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2709 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2710 delete $lrfetchrefs_f{$lrefname};
2714 foreach my $rrefname (sort keys %wantr) {
2715 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2716 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2717 my $want = $wantr{$rrefname};
2718 next if $got eq $want;
2719 if (!defined $objgot{$want}) {
2721 warning: git ls-remote suggests we want $lrefname
2722 warning: and it should refer to $want
2723 warning: but git fetch didn't fetch that object to any relevant ref.
2724 warning: This may be due to a race with someone updating the server.
2725 warning: Will try again...
2727 next FETCH_ITERATION;
2730 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2732 runcmd_ordryrun_local @git, qw(update-ref -m),
2733 "dgit fetch git fetch fixup", $lrefname, $want;
2734 $lrfetchrefs_f{$lrefname} = $want;
2739 if (defined $csuite) {
2740 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2741 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2742 my ($objid,$objtype,$lrefname,$reftail) = @_;
2743 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2744 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2748 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2749 Dumper(\%lrfetchrefs_f);
2752 sub git_fetch_us () {
2753 # Want to fetch only what we are going to use, unless
2754 # deliberately-not-ff, in which case we must fetch everything.
2756 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2758 (quiltmode_splitbrain
2759 ? (map { $_->('*',access_nomdistro) }
2760 \&debiantag_new, \&debiantag_maintview)
2761 : debiantags('*',access_nomdistro));
2762 push @specs, server_branch($csuite);
2763 push @specs, $rewritemap;
2764 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2766 my $url = access_giturl();
2767 git_lrfetch_sane $url, 0, @specs;
2770 my @tagpats = debiantags('*',access_nomdistro);
2772 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2773 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2774 printdebug "currently $fullrefname=$objid\n";
2775 $here{$fullrefname} = $objid;
2777 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2778 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2779 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2780 printdebug "offered $lref=$objid\n";
2781 if (!defined $here{$lref}) {
2782 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2783 runcmd_ordryrun_local @upd;
2784 lrfetchref_used $fullrefname;
2785 } elsif ($here{$lref} eq $objid) {
2786 lrfetchref_used $fullrefname;
2789 "Not updating $lref from $here{$lref} to $objid.\n";
2794 #---------- dsc and archive handling ----------
2796 sub mergeinfo_getclogp ($) {
2797 # Ensures thit $mi->{Clogp} exists and returns it
2799 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2802 sub mergeinfo_version ($) {
2803 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2806 sub fetch_from_archive_record_1 ($) {
2808 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2809 'DGIT_ARCHIVE', $hash;
2810 cmdoutput @git, qw(log -n2), $hash;
2811 # ... gives git a chance to complain if our commit is malformed
2814 sub fetch_from_archive_record_2 ($) {
2816 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2820 dryrun_report @upd_cmd;
2824 sub parse_dsc_field_def_dsc_distro () {
2825 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2826 dgit.default.distro);
2829 sub parse_dsc_field ($$) {
2830 my ($dsc, $what) = @_;
2832 foreach my $field (@ourdscfield) {
2833 $f = $dsc->{$field};
2838 progress "$what: NO git hash";
2839 parse_dsc_field_def_dsc_distro();
2840 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2841 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2842 progress "$what: specified git info ($dsc_distro)";
2843 $dsc_hint_tag = [ $dsc_hint_tag ];
2844 } elsif ($f =~ m/^\w+\s*$/) {
2846 parse_dsc_field_def_dsc_distro();
2847 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2849 progress "$what: specified git hash";
2851 fail "$what: invalid Dgit info";
2855 sub resolve_dsc_field_commit ($$) {
2856 my ($already_distro, $already_mapref) = @_;
2858 return unless defined $dsc_hash;
2861 defined $already_mapref &&
2862 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2863 ? $already_mapref : undef;
2867 my ($what, @fetch) = @_;
2869 local $idistro = $dsc_distro;
2870 my $lrf = lrfetchrefs;
2872 if (!$chase_dsc_distro) {
2874 "not chasing .dsc distro $dsc_distro: not fetching $what";
2879 ".dsc names distro $dsc_distro: fetching $what";
2881 my $url = access_giturl();
2882 if (!defined $url) {
2883 defined $dsc_hint_url or fail <<END;
2884 .dsc Dgit metadata is in context of distro $dsc_distro
2885 for which we have no configured url and .dsc provides no hint
2888 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2889 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2890 parse_cfg_bool "dsc-url-proto-ok", 'false',
2891 cfg("dgit.dsc-url-proto-ok.$proto",
2892 "dgit.default.dsc-url-proto-ok")
2894 .dsc Dgit metadata is in context of distro $dsc_distro
2895 for which we have no configured url;
2896 .dsc provides hinted url with protocol $proto which is unsafe.
2897 (can be overridden by config - consult documentation)
2899 $url = $dsc_hint_url;
2902 git_lrfetch_sane $url, 1, @fetch;
2907 my $rewrite_enable = do {
2908 local $idistro = $dsc_distro;
2909 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2912 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2913 if (!defined $mapref) {
2914 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2915 $mapref = $lrf.'/'.$rewritemap;
2917 my $rewritemapdata = git_cat_file $mapref.':map';
2918 if (defined $rewritemapdata
2919 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2921 "server's git history rewrite map contains a relevant entry!";
2924 if (defined $dsc_hash) {
2925 progress "using rewritten git hash in place of .dsc value";
2927 progress "server data says .dsc hash is to be disregarded";
2932 if (!defined git_cat_file $dsc_hash) {
2933 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2934 my $lrf = $do_fetch->("additional commits", @tags) &&
2935 defined git_cat_file $dsc_hash
2937 .dsc Dgit metadata requires commit $dsc_hash
2938 but we could not obtain that object anywhere.
2940 foreach my $t (@tags) {
2941 my $fullrefname = $lrf.'/'.$t;
2942 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2943 next unless $lrfetchrefs_f{$fullrefname};
2944 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2945 lrfetchref_used $fullrefname;
2950 sub fetch_from_archive () {
2951 ensure_setup_existing_tree();
2953 # Ensures that lrref() is what is actually in the archive, one way
2954 # or another, according to us - ie this client's
2955 # appropritaely-updated archive view. Also returns the commit id.
2956 # If there is nothing in the archive, leaves lrref alone and
2957 # returns undef. git_fetch_us must have already been called.
2961 parse_dsc_field($dsc, 'last upload to archive');
2962 resolve_dsc_field_commit access_basedistro,
2963 lrfetchrefs."/".$rewritemap
2965 progress "no version available from the archive";
2968 # If the archive's .dsc has a Dgit field, there are three
2969 # relevant git commitids we need to choose between and/or merge
2971 # 1. $dsc_hash: the Dgit field from the archive
2972 # 2. $lastpush_hash: the suite branch on the dgit git server
2973 # 3. $lastfetch_hash: our local tracking brach for the suite
2975 # These may all be distinct and need not be in any fast forward
2978 # If the dsc was pushed to this suite, then the server suite
2979 # branch will have been updated; but it might have been pushed to
2980 # a different suite and copied by the archive. Conversely a more
2981 # recent version may have been pushed with dgit but not appeared
2982 # in the archive (yet).
2984 # $lastfetch_hash may be awkward because archive imports
2985 # (particularly, imports of Dgit-less .dscs) are performed only as
2986 # needed on individual clients, so different clients may perform a
2987 # different subset of them - and these imports are only made
2988 # public during push. So $lastfetch_hash may represent a set of
2989 # imports different to a subsequent upload by a different dgit
2992 # Our approach is as follows:
2994 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2995 # descendant of $dsc_hash, then it was pushed by a dgit user who
2996 # had based their work on $dsc_hash, so we should prefer it.
2997 # Otherwise, $dsc_hash was installed into this suite in the
2998 # archive other than by a dgit push, and (necessarily) after the
2999 # last dgit push into that suite (since a dgit push would have
3000 # been descended from the dgit server git branch); thus, in that
3001 # case, we prefer the archive's version (and produce a
3002 # pseudo-merge to overwrite the dgit server git branch).
3004 # (If there is no Dgit field in the archive's .dsc then
3005 # generate_commit_from_dsc uses the version numbers to decide
3006 # whether the suite branch or the archive is newer. If the suite
3007 # branch is newer it ignores the archive's .dsc; otherwise it
3008 # generates an import of the .dsc, and produces a pseudo-merge to
3009 # overwrite the suite branch with the archive contents.)
3011 # The outcome of that part of the algorithm is the `public view',
3012 # and is same for all dgit clients: it does not depend on any
3013 # unpublished history in the local tracking branch.
3015 # As between the public view and the local tracking branch: The
3016 # local tracking branch is only updated by dgit fetch, and
3017 # whenever dgit fetch runs it includes the public view in the
3018 # local tracking branch. Therefore if the public view is not
3019 # descended from the local tracking branch, the local tracking
3020 # branch must contain history which was imported from the archive
3021 # but never pushed; and, its tip is now out of date. So, we make
3022 # a pseudo-merge to overwrite the old imports and stitch the old
3025 # Finally: we do not necessarily reify the public view (as
3026 # described above). This is so that we do not end up stacking two
3027 # pseudo-merges. So what we actually do is figure out the inputs
3028 # to any public view pseudo-merge and put them in @mergeinputs.
3031 # $mergeinputs[]{Commit}
3032 # $mergeinputs[]{Info}
3033 # $mergeinputs[0] is the one whose tree we use
3034 # @mergeinputs is in the order we use in the actual commit)
3037 # $mergeinputs[]{Message} is a commit message to use
3038 # $mergeinputs[]{ReverseParents} if def specifies that parent
3039 # list should be in opposite order
3040 # Such an entry has no Commit or Info. It applies only when found
3041 # in the last entry. (This ugliness is to support making
3042 # identical imports to previous dgit versions.)
3044 my $lastpush_hash = git_get_ref(lrfetchref());
3045 printdebug "previous reference hash=$lastpush_hash\n";
3046 $lastpush_mergeinput = $lastpush_hash && {
3047 Commit => $lastpush_hash,
3048 Info => "dgit suite branch on dgit git server",
3051 my $lastfetch_hash = git_get_ref(lrref());
3052 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3053 my $lastfetch_mergeinput = $lastfetch_hash && {
3054 Commit => $lastfetch_hash,
3055 Info => "dgit client's archive history view",
3058 my $dsc_mergeinput = $dsc_hash && {
3059 Commit => $dsc_hash,
3060 Info => "Dgit field in .dsc from archive",
3064 my $del_lrfetchrefs = sub {
3067 printdebug "del_lrfetchrefs...\n";
3068 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3069 my $objid = $lrfetchrefs_d{$fullrefname};
3070 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3072 $gur ||= new IO::Handle;
3073 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3075 printf $gur "delete %s %s\n", $fullrefname, $objid;
3078 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3082 if (defined $dsc_hash) {
3083 ensure_we_have_orig();
3084 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3085 @mergeinputs = $dsc_mergeinput
3086 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3087 print STDERR <<END or die $!;
3089 Git commit in archive is behind the last version allegedly pushed/uploaded.
3090 Commit referred to by archive: $dsc_hash
3091 Last version pushed with dgit: $lastpush_hash
3094 @mergeinputs = ($lastpush_mergeinput);
3096 # Archive has .dsc which is not a descendant of the last dgit
3097 # push. This can happen if the archive moves .dscs about.
3098 # Just follow its lead.
3099 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3100 progress "archive .dsc names newer git commit";
3101 @mergeinputs = ($dsc_mergeinput);
3103 progress "archive .dsc names other git commit, fixing up";
3104 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3108 @mergeinputs = generate_commits_from_dsc();
3109 # We have just done an import. Now, our import algorithm might
3110 # have been improved. But even so we do not want to generate
3111 # a new different import of the same package. So if the
3112 # version numbers are the same, just use our existing version.
3113 # If the version numbers are different, the archive has changed
3114 # (perhaps, rewound).
3115 if ($lastfetch_mergeinput &&
3116 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3117 (mergeinfo_version $mergeinputs[0]) )) {
3118 @mergeinputs = ($lastfetch_mergeinput);
3120 } elsif ($lastpush_hash) {
3121 # only in git, not in the archive yet
3122 @mergeinputs = ($lastpush_mergeinput);
3123 print STDERR <<END or die $!;
3125 Package not found in the archive, but has allegedly been pushed using dgit.
3129 printdebug "nothing found!\n";
3130 if (defined $skew_warning_vsn) {
3131 print STDERR <<END or die $!;
3133 Warning: relevant archive skew detected.
3134 Archive allegedly contains $skew_warning_vsn
3135 But we were not able to obtain any version from the archive or git.
3139 unshift @end, $del_lrfetchrefs;
3143 if ($lastfetch_hash &&
3145 my $h = $_->{Commit};
3146 $h and is_fast_fwd($lastfetch_hash, $h);
3147 # If true, one of the existing parents of this commit
3148 # is a descendant of the $lastfetch_hash, so we'll
3149 # be ff from that automatically.
3153 push @mergeinputs, $lastfetch_mergeinput;
3156 printdebug "fetch mergeinfos:\n";
3157 foreach my $mi (@mergeinputs) {
3159 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3161 printdebug sprintf " ReverseParents=%d Message=%s",
3162 $mi->{ReverseParents}, $mi->{Message};
3166 my $compat_info= pop @mergeinputs
3167 if $mergeinputs[$#mergeinputs]{Message};
3169 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3172 if (@mergeinputs > 1) {
3174 my $tree_commit = $mergeinputs[0]{Commit};
3176 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3177 $tree =~ m/\n\n/; $tree = $`;
3178 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3181 # We use the changelog author of the package in question the
3182 # author of this pseudo-merge. This is (roughly) correct if
3183 # this commit is simply representing aa non-dgit upload.
3184 # (Roughly because it does not record sponsorship - but we
3185 # don't have sponsorship info because that's in the .changes,
3186 # which isn't in the archivw.)
3188 # But, it might be that we are representing archive history
3189 # updates (including in-archive copies). These are not really
3190 # the responsibility of the person who created the .dsc, but
3191 # there is no-one whose name we should better use. (The
3192 # author of the .dsc-named commit is clearly worse.)
3194 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3195 my $author = clogp_authline $useclogp;
3196 my $cversion = getfield $useclogp, 'Version';
3198 my $mcf = ".git/dgit/mergecommit";
3199 open MC, ">", $mcf or die "$mcf $!";
3200 print MC <<END or die $!;
3204 my @parents = grep { $_->{Commit} } @mergeinputs;
3205 @parents = reverse @parents if $compat_info->{ReverseParents};
3206 print MC <<END or die $! foreach @parents;
3210 print MC <<END or die $!;
3216 if (defined $compat_info->{Message}) {
3217 print MC $compat_info->{Message} or die $!;
3219 print MC <<END or die $!;
3220 Record $package ($cversion) in archive suite $csuite
3224 my $message_add_info = sub {
3226 my $mversion = mergeinfo_version $mi;
3227 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3231 $message_add_info->($mergeinputs[0]);
3232 print MC <<END or die $!;
3233 should be treated as descended from
3235 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3239 $hash = make_commit $mcf;
3241 $hash = $mergeinputs[0]{Commit};
3243 printdebug "fetch hash=$hash\n";
3246 my ($lasth, $what) = @_;
3247 return unless $lasth;
3248 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3251 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3253 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3255 fetch_from_archive_record_1($hash);
3257 if (defined $skew_warning_vsn) {
3259 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3260 my $gotclogp = commit_getclogp($hash);
3261 my $got_vsn = getfield $gotclogp, 'Version';
3262 printdebug "SKEW CHECK GOT $got_vsn\n";
3263 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3264 print STDERR <<END or die $!;
3266 Warning: archive skew detected. Using the available version:
3267 Archive allegedly contains $skew_warning_vsn
3268 We were able to obtain only $got_vsn
3274 if ($lastfetch_hash ne $hash) {
3275 fetch_from_archive_record_2($hash);
3278 lrfetchref_used lrfetchref();
3280 check_gitattrs($hash, "fetched source tree");
3282 unshift @end, $del_lrfetchrefs;
3286 sub set_local_git_config ($$) {
3288 runcmd @git, qw(config), $k, $v;
3291 sub setup_mergechangelogs (;$) {
3293 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3295 my $driver = 'dpkg-mergechangelogs';
3296 my $cb = "merge.$driver";
3297 my $attrs = '.git/info/attributes';
3298 ensuredir '.git/info';
3300 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3301 if (!open ATTRS, "<", $attrs) {
3302 $!==ENOENT or die "$attrs: $!";
3306 next if m{^debian/changelog\s};
3307 print NATTRS $_, "\n" or die $!;
3309 ATTRS->error and die $!;
3312 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3315 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3316 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3318 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3321 sub setup_useremail (;$) {
3323 return unless $always || access_cfg_bool(1, 'setup-useremail');
3326 my ($k, $envvar) = @_;
3327 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3328 return unless defined $v;
3329 set_local_git_config "user.$k", $v;
3332 $setup->('email', 'DEBEMAIL');
3333 $setup->('name', 'DEBFULLNAME');
3336 sub ensure_setup_existing_tree () {
3337 my $k = "remote.$remotename.skipdefaultupdate";
3338 my $c = git_get_config $k;
3339 return if defined $c;
3340 set_local_git_config $k, 'true';
3343 sub open_gitattrs () {
3344 my $gai = new IO::File ".git/info/attributes"
3346 or die "open .git/info/attributes: $!";
3350 sub is_gitattrs_setup () {
3351 my $gai = open_gitattrs();
3352 return 0 unless $gai;
3354 return 1 if m{^\[attr\]dgit-defuse-attrs\s};
3356 $gai->error and die $!;
3360 sub setup_gitattrs (;$) {
3362 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3364 if (is_gitattrs_setup()) {
3366 [attr]dgit-defuse-attrs already found in .git/info/attributes
3367 not doing further gitattributes setup
3371 my $af = ".git/info/attributes";
3372 open GAO, "> $af.new" or die $!;
3373 print GAO <<END or die $!;
3375 [attr]dgit-defuse-attrs -text -eol -crlf -ident -filter
3376 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3378 my $gai = open_gitattrs();
3382 print GAO $_, "\n" or die $!;
3384 $gai->error and die $!;
3386 close GAO or die $!;
3387 rename "$af.new", "$af" or die "install $af: $!";
3390 sub setup_new_tree () {
3391 setup_mergechangelogs();
3396 sub check_gitattrs ($$) {
3397 my ($treeish, $what) = @_;
3399 return if is_gitattrs_setup;
3402 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3404 my $gafl = new IO::File;
3405 open $gafl, "-|", @cmd or die $!;
3408 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3410 next unless m{(?:^|/)\.gitattributes$};
3412 # oh dear, found one
3414 dgit: warning: $what contains .gitattributes
3415 dgit: .gitattributes have not been defused. Recommended: dgit setup-new-tree.
3420 # tree contains no .gitattributes files
3421 $?=0; $!=0; close $gafl or failedcmd @cmd;
3425 sub multisuite_suite_child ($$$) {
3426 my ($tsuite, $merginputs, $fn) = @_;
3427 # in child, sets things up, calls $fn->(), and returns undef
3428 # in parent, returns canonical suite name for $tsuite
3429 my $canonsuitefh = IO::File::new_tmpfile;
3430 my $pid = fork // die $!;
3434 $us .= " [$isuite]";
3435 $debugprefix .= " ";
3436 progress "fetching $tsuite...";
3437 canonicalise_suite();
3438 print $canonsuitefh $csuite, "\n" or die $!;
3439 close $canonsuitefh or die $!;
3443 waitpid $pid,0 == $pid or die $!;
3444 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3445 seek $canonsuitefh,0,0 or die $!;
3446 local $csuite = <$canonsuitefh>;
3447 die $! unless defined $csuite && chomp $csuite;
3449 printdebug "multisuite $tsuite missing\n";
3452 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3453 push @$merginputs, {
3460 sub fork_for_multisuite ($) {
3461 my ($before_fetch_merge) = @_;
3462 # if nothing unusual, just returns ''
3465 # returns 0 to caller in child, to do first of the specified suites
3466 # in child, $csuite is not yet set
3468 # returns 1 to caller in parent, to finish up anything needed after
3469 # in parent, $csuite is set to canonicalised portmanteau
3471 my $org_isuite = $isuite;
3472 my @suites = split /\,/, $isuite;
3473 return '' unless @suites > 1;
3474 printdebug "fork_for_multisuite: @suites\n";
3478 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3480 return 0 unless defined $cbasesuite;
3482 fail "package $package missing in (base suite) $cbasesuite"
3483 unless @mergeinputs;
3485 my @csuites = ($cbasesuite);
3487 $before_fetch_merge->();
3489 foreach my $tsuite (@suites[1..$#suites]) {
3490 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3496 # xxx collecte the ref here
3498 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3499 push @csuites, $csubsuite;
3502 foreach my $mi (@mergeinputs) {
3503 my $ref = git_get_ref $mi->{Ref};
3504 die "$mi->{Ref} ?" unless length $ref;
3505 $mi->{Commit} = $ref;
3508 $csuite = join ",", @csuites;
3510 my $previous = git_get_ref lrref;
3512 unshift @mergeinputs, {
3513 Commit => $previous,
3514 Info => "local combined tracking branch",
3516 "archive seems to have rewound: local tracking branch is ahead!",
3520 foreach my $ix (0..$#mergeinputs) {
3521 $mergeinputs[$ix]{Index} = $ix;
3524 @mergeinputs = sort {
3525 -version_compare(mergeinfo_version $a,
3526 mergeinfo_version $b) # highest version first
3528 $a->{Index} <=> $b->{Index}; # earliest in spec first
3534 foreach my $mi (@mergeinputs) {
3535 printdebug "multisuite merge check $mi->{Info}\n";
3536 foreach my $previous (@needed) {
3537 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3538 printdebug "multisuite merge un-needed $previous->{Info}\n";
3542 printdebug "multisuite merge this-needed\n";
3543 $mi->{Character} = '+';
3546 $needed[0]{Character} = '*';
3548 my $output = $needed[0]{Commit};
3551 printdebug "multisuite merge nontrivial\n";
3552 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3554 my $commit = "tree $tree\n";
3555 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3556 "Input branches:\n";
3558 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3559 printdebug "multisuite merge include $mi->{Info}\n";
3560 $mi->{Character} //= ' ';
3561 $commit .= "parent $mi->{Commit}\n";
3562 $msg .= sprintf " %s %-25s %s\n",
3564 (mergeinfo_version $mi),
3567 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3569 " * marks the highest version branch, which choose to use\n".
3570 " + marks each branch which was not already an ancestor\n\n".
3571 "[dgit multi-suite $csuite]\n";
3573 "author $authline\n".
3574 "committer $authline\n\n";
3575 $output = make_commit_text $commit.$msg;
3576 printdebug "multisuite merge generated $output\n";
3579 fetch_from_archive_record_1($output);
3580 fetch_from_archive_record_2($output);
3582 progress "calculated combined tracking suite $csuite";
3587 sub clone_set_head () {
3588 open H, "> .git/HEAD" or die $!;
3589 print H "ref: ".lref()."\n" or die $!;
3592 sub clone_finish ($) {
3594 runcmd @git, qw(reset --hard), lrref();
3595 runcmd qw(bash -ec), <<'END';
3597 git ls-tree -r --name-only -z HEAD | \
3598 xargs -0r touch -h -r . --
3600 printdone "ready for work in $dstdir";
3605 badusage "dry run makes no sense with clone" unless act_local();
3607 my $multi_fetched = fork_for_multisuite(sub {
3608 printdebug "multi clone before fetch merge\n";
3611 if ($multi_fetched) {
3612 printdebug "multi clone after fetch merge\n";
3614 clone_finish($dstdir);
3617 printdebug "clone main body\n";
3619 canonicalise_suite();
3620 my $hasgit = check_for_git();
3621 mkdir $dstdir or fail "create \`$dstdir': $!";
3623 runcmd @git, qw(init -q);
3626 my $giturl = access_giturl(1);
3627 if (defined $giturl) {
3628 runcmd @git, qw(remote add), 'origin', $giturl;
3631 progress "fetching existing git history";
3633 runcmd_ordryrun_local @git, qw(fetch origin);
3635 progress "starting new git history";
3637 fetch_from_archive() or no_such_package;
3638 my $vcsgiturl = $dsc->{'Vcs-Git'};
3639 if (length $vcsgiturl) {
3640 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3641 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3643 clone_finish($dstdir);
3647 canonicalise_suite();
3648 if (check_for_git()) {
3651 fetch_from_archive() or no_such_package();
3652 printdone "fetched into ".lrref();
3656 my $multi_fetched = fork_for_multisuite(sub { });
3657 fetch() unless $multi_fetched; # parent
3658 return if $multi_fetched eq '0'; # child
3659 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3661 printdone "fetched to ".lrref()." and merged into HEAD";
3664 sub check_not_dirty () {
3665 foreach my $f (qw(local-options local-patch-header)) {
3666 if (stat_exists "debian/source/$f") {
3667 fail "git tree contains debian/source/$f";
3671 return if $ignoredirty;
3673 my @cmd = (@git, qw(diff --quiet HEAD));
3675 $!=0; $?=-1; system @cmd;
3678 fail "working tree is dirty (does not match HEAD)";
3684 sub commit_admin ($) {
3687 runcmd_ordryrun_local @git, qw(commit -m), $m;
3690 sub commit_quilty_patch () {
3691 my $output = cmdoutput @git, qw(status --porcelain);
3693 foreach my $l (split /\n/, $output) {
3694 next unless $l =~ m/\S/;
3695 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3699 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3701 progress "nothing quilty to commit, ok.";
3704 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3705 runcmd_ordryrun_local @git, qw(add -f), @adds;
3707 Commit Debian 3.0 (quilt) metadata
3709 [dgit ($our_version) quilt-fixup]
3713 sub get_source_format () {
3715 if (open F, "debian/source/options") {
3719 s/\s+$//; # ignore missing final newline
3721 my ($k, $v) = ($`, $'); #');
3722 $v =~ s/^"(.*)"$/$1/;
3728 F->error and die $!;
3731 die $! unless $!==&ENOENT;
3734 if (!open F, "debian/source/format") {
3735 die $! unless $!==&ENOENT;
3739 F->error and die $!;
3741 return ($_, \%options);
3744 sub madformat_wantfixup ($) {
3746 return 0 unless $format eq '3.0 (quilt)';
3747 our $quilt_mode_warned;
3748 if ($quilt_mode eq 'nocheck') {
3749 progress "Not doing any fixup of \`$format' due to".
3750 " ----no-quilt-fixup or --quilt=nocheck"
3751 unless $quilt_mode_warned++;
3754 progress "Format \`$format', need to check/update patch stack"
3755 unless $quilt_mode_warned++;
3759 sub maybe_split_brain_save ($$$) {
3760 my ($headref, $dgitview, $msg) = @_;
3761 # => message fragment "$saved" describing disposition of $dgitview
3762 return "commit id $dgitview" unless defined $split_brain_save;
3763 my @cmd = (shell_cmd "cd ../../../..",
3764 @git, qw(update-ref -m),
3765 "dgit --dgit-view-save $msg HEAD=$headref",
3766 $split_brain_save, $dgitview);
3768 return "and left in $split_brain_save";
3771 # An "infopair" is a tuple [ $thing, $what ]
3772 # (often $thing is a commit hash; $what is a description)
3774 sub infopair_cond_equal ($$) {
3776 $x->[0] eq $y->[0] or fail <<END;
3777 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3781 sub infopair_lrf_tag_lookup ($$) {
3782 my ($tagnames, $what) = @_;
3783 # $tagname may be an array ref
3784 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3785 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3786 foreach my $tagname (@tagnames) {
3787 my $lrefname = lrfetchrefs."/tags/$tagname";
3788 my $tagobj = $lrfetchrefs_f{$lrefname};
3789 next unless defined $tagobj;
3790 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3791 return [ git_rev_parse($tagobj), $what ];
3793 fail @tagnames==1 ? <<END : <<END;
3794 Wanted tag $what (@tagnames) on dgit server, but not found
3796 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3800 sub infopair_cond_ff ($$) {
3801 my ($anc,$desc) = @_;
3802 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3803 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3807 sub pseudomerge_version_check ($$) {
3808 my ($clogp, $archive_hash) = @_;
3810 my $arch_clogp = commit_getclogp $archive_hash;
3811 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3812 'version currently in archive' ];
3813 if (defined $overwrite_version) {
3814 if (length $overwrite_version) {
3815 infopair_cond_equal([ $overwrite_version,
3816 '--overwrite= version' ],
3819 my $v = $i_arch_v->[0];
3820 progress "Checking package changelog for archive version $v ...";
3823 my @xa = ("-f$v", "-t$v");
3824 my $vclogp = parsechangelog @xa;
3827 [ (getfield $vclogp, $fn),
3828 "$fn field from dpkg-parsechangelog @xa" ];
3830 my $cv = $gf->('Version');
3831 infopair_cond_equal($i_arch_v, $cv);
3832 $cd = $gf->('Distribution');
3835 $@ =~ s/^dgit: //gm;
3837 "Perhaps debian/changelog does not mention $v ?";
3839 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3840 $cd->[1] is $cd->[0]
3841 Your tree seems to based on earlier (not uploaded) $v.
3846 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3850 sub pseudomerge_make_commit ($$$$ $$) {
3851 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3852 $msg_cmd, $msg_msg) = @_;
3853 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3855 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3856 my $authline = clogp_authline $clogp;
3860 !defined $overwrite_version ? ""
3861 : !length $overwrite_version ? " --overwrite"
3862 : " --overwrite=".$overwrite_version;
3865 my $pmf = ".git/dgit/pseudomerge";
3866 open MC, ">", $pmf or die "$pmf $!";
3867 print MC <<END or die $!;
3870 parent $archive_hash
3880 return make_commit($pmf);
3883 sub splitbrain_pseudomerge ($$$$) {
3884 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3885 # => $merged_dgitview
3886 printdebug "splitbrain_pseudomerge...\n";
3888 # We: debian/PREVIOUS HEAD($maintview)
3889 # expect: o ----------------- o
3892 # a/d/PREVIOUS $dgitview
3895 # we do: `------------------ o
3899 return $dgitview unless defined $archive_hash;
3901 printdebug "splitbrain_pseudomerge...\n";
3903 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3905 if (!defined $overwrite_version) {
3906 progress "Checking that HEAD inciudes all changes in archive...";
3909 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3911 if (defined $overwrite_version) {
3913 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3914 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3915 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3916 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3917 my $i_archive = [ $archive_hash, "current archive contents" ];
3919 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3921 infopair_cond_equal($i_dgit, $i_archive);
3922 infopair_cond_ff($i_dep14, $i_dgit);
3923 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3927 $us: check failed (maybe --overwrite is needed, consult documentation)
3932 my $r = pseudomerge_make_commit
3933 $clogp, $dgitview, $archive_hash, $i_arch_v,
3934 "dgit --quilt=$quilt_mode",
3935 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3936 Declare fast forward from $i_arch_v->[0]
3938 Make fast forward from $i_arch_v->[0]
3941 maybe_split_brain_save $maintview, $r, "pseudomerge";
3943 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3947 sub plain_overwrite_pseudomerge ($$$) {
3948 my ($clogp, $head, $archive_hash) = @_;
3950 printdebug "plain_overwrite_pseudomerge...";
3952 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3954 return $head if is_fast_fwd $archive_hash, $head;
3956 my $m = "Declare fast forward from $i_arch_v->[0]";
3958 my $r = pseudomerge_make_commit
3959 $clogp, $head, $archive_hash, $i_arch_v,
3962 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3964 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3968 sub push_parse_changelog ($) {
3971 my $clogp = Dpkg::Control::Hash->new();
3972 $clogp->load($clogpfn) or die;
3974 my $clogpackage = getfield $clogp, 'Source';
3975 $package //= $clogpackage;
3976 fail "-p specified $package but changelog specified $clogpackage"
3977 unless $package eq $clogpackage;
3978 my $cversion = getfield $clogp, 'Version';
3980 if (!$we_are_initiator) {
3981 # rpush initiator can't do this because it doesn't have $isuite yet
3982 my $tag = debiantag($cversion, access_nomdistro);
3983 runcmd @git, qw(check-ref-format), $tag;
3986 my $dscfn = dscfn($cversion);
3988 return ($clogp, $cversion, $dscfn);
3991 sub push_parse_dsc ($$$) {
3992 my ($dscfn,$dscfnwhat, $cversion) = @_;
3993 $dsc = parsecontrol($dscfn,$dscfnwhat);
3994 my $dversion = getfield $dsc, 'Version';
3995 my $dscpackage = getfield $dsc, 'Source';
3996 ($dscpackage eq $package && $dversion eq $cversion) or
3997 fail "$dscfn is for $dscpackage $dversion".
3998 " but debian/changelog is for $package $cversion";
4001 sub push_tagwants ($$$$) {
4002 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
4005 TagFn => \&debiantag,
4010 if (defined $maintviewhead) {
4012 TagFn => \&debiantag_maintview,
4013 Objid => $maintviewhead,
4014 TfSuffix => '-maintview',
4017 } elsif ($dodep14tag eq 'no' ? 0
4018 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
4019 : $dodep14tag eq 'always'
4020 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
4021 --dep14tag-always (or equivalent in config) means server must support
4022 both "new" and "maint" tag formats, but config says it doesn't.
4024 : die "$dodep14tag ?") {
4026 TagFn => \&debiantag_maintview,
4028 TfSuffix => '-dgit',
4032 foreach my $tw (@tagwants) {
4033 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4034 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4036 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4040 sub push_mktags ($$ $$ $) {
4042 $changesfile,$changesfilewhat,
4045 die unless $tagwants->[0]{View} eq 'dgit';
4047 my $declaredistro = access_nomdistro();
4048 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4049 $dsc->{$ourdscfield[0]} = join " ",
4050 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4052 $dsc->save("$dscfn.tmp") or die $!;
4054 my $changes = parsecontrol($changesfile,$changesfilewhat);
4055 foreach my $field (qw(Source Distribution Version)) {
4056 $changes->{$field} eq $clogp->{$field} or
4057 fail "changes field $field \`$changes->{$field}'".
4058 " does not match changelog \`$clogp->{$field}'";
4061 my $cversion = getfield $clogp, 'Version';
4062 my $clogsuite = getfield $clogp, 'Distribution';
4064 # We make the git tag by hand because (a) that makes it easier
4065 # to control the "tagger" (b) we can do remote signing
4066 my $authline = clogp_authline $clogp;
4067 my $delibs = join(" ", "",@deliberatelies);
4071 my $tfn = $tw->{Tfn};
4072 my $head = $tw->{Objid};
4073 my $tag = $tw->{Tag};
4075 open TO, '>', $tfn->('.tmp') or die $!;
4076 print TO <<END or die $!;
4083 if ($tw->{View} eq 'dgit') {
4084 print TO <<END or die $!;
4085 $package release $cversion for $clogsuite ($csuite) [dgit]
4086 [dgit distro=$declaredistro$delibs]
4088 foreach my $ref (sort keys %previously) {
4089 print TO <<END or die $!;
4090 [dgit previously:$ref=$previously{$ref}]
4093 } elsif ($tw->{View} eq 'maint') {
4094 print TO <<END or die $!;
4095 $package release $cversion for $clogsuite ($csuite)
4096 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4099 die Dumper($tw)."?";
4104 my $tagobjfn = $tfn->('.tmp');
4106 if (!defined $keyid) {
4107 $keyid = access_cfg('keyid','RETURN-UNDEF');
4109 if (!defined $keyid) {
4110 $keyid = getfield $clogp, 'Maintainer';
4112 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4113 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4114 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4115 push @sign_cmd, $tfn->('.tmp');
4116 runcmd_ordryrun @sign_cmd;
4118 $tagobjfn = $tfn->('.signed.tmp');
4119 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4120 $tfn->('.tmp'), $tfn->('.tmp.asc');
4126 my @r = map { $mktag->($_); } @$tagwants;
4130 sub sign_changes ($) {
4131 my ($changesfile) = @_;
4133 my @debsign_cmd = @debsign;
4134 push @debsign_cmd, "-k$keyid" if defined $keyid;
4135 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4136 push @debsign_cmd, $changesfile;
4137 runcmd_ordryrun @debsign_cmd;
4142 printdebug "actually entering push\n";
4144 supplementary_message(<<'END');
4145 Push failed, while checking state of the archive.
4146 You can retry the push, after fixing the problem, if you like.
4148 if (check_for_git()) {
4151 my $archive_hash = fetch_from_archive();
4152 if (!$archive_hash) {
4154 fail "package appears to be new in this suite;".
4155 " if this is intentional, use --new";
4158 supplementary_message(<<'END');
4159 Push failed, while preparing your push.
4160 You can retry the push, after fixing the problem, if you like.
4163 need_tagformat 'new', "quilt mode $quilt_mode"
4164 if quiltmode_splitbrain;
4168 access_giturl(); # check that success is vaguely likely
4169 rpush_handle_protovsn_bothends() if $we_are_initiator;
4172 my $clogpfn = ".git/dgit/changelog.822.tmp";
4173 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4175 responder_send_file('parsed-changelog', $clogpfn);
4177 my ($clogp, $cversion, $dscfn) =
4178 push_parse_changelog("$clogpfn");
4180 my $dscpath = "$buildproductsdir/$dscfn";
4181 stat_exists $dscpath or
4182 fail "looked for .dsc $dscpath, but $!;".
4183 " maybe you forgot to build";
4185 responder_send_file('dsc', $dscpath);
4187 push_parse_dsc($dscpath, $dscfn, $cversion);
4189 my $format = getfield $dsc, 'Format';
4190 printdebug "format $format\n";
4192 my $actualhead = git_rev_parse('HEAD');
4193 my $dgithead = $actualhead;
4194 my $maintviewhead = undef;
4196 my $upstreamversion = upstreamversion $clogp->{Version};
4198 if (madformat_wantfixup($format)) {
4199 # user might have not used dgit build, so maybe do this now:
4200 if (quiltmode_splitbrain()) {
4202 quilt_make_fake_dsc($upstreamversion);
4204 ($dgithead, $cachekey) =
4205 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4207 "--quilt=$quilt_mode but no cached dgit view:
4208 perhaps tree changed since dgit build[-source] ?";
4210 $dgithead = splitbrain_pseudomerge($clogp,
4211 $actualhead, $dgithead,
4213 $maintviewhead = $actualhead;
4214 changedir '../../../..';
4215 prep_ud(); # so _only_subdir() works, below
4217 commit_quilty_patch();
4221 if (defined $overwrite_version && !defined $maintviewhead) {
4222 $dgithead = plain_overwrite_pseudomerge($clogp,
4230 if ($archive_hash) {
4231 if (is_fast_fwd($archive_hash, $dgithead)) {
4233 } elsif (deliberately_not_fast_forward) {
4236 fail "dgit push: HEAD is not a descendant".
4237 " of the archive's version.\n".
4238 "To overwrite the archive's contents,".
4239 " pass --overwrite[=VERSION].\n".
4240 "To rewind history, if permitted by the archive,".
4241 " use --deliberately-not-fast-forward.";
4246 progress "checking that $dscfn corresponds to HEAD";
4247 runcmd qw(dpkg-source -x --),
4248 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
4249 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4250 check_for_vendor_patches() if madformat($dsc->{format});
4251 changedir '../../../..';
4252 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4253 debugcmd "+",@diffcmd;
4255 my $r = system @diffcmd;
4258 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4260 HEAD specifies a different tree to $dscfn:
4262 Perhaps you forgot to build. Or perhaps there is a problem with your
4263 source tree (see dgit(7) for some hints). To see a full diff, run
4270 if (!$changesfile) {
4271 my $pat = changespat $cversion;
4272 my @cs = glob "$buildproductsdir/$pat";
4273 fail "failed to find unique changes file".
4274 " (looked for $pat in $buildproductsdir);".
4275 " perhaps you need to use dgit -C"
4277 ($changesfile) = @cs;
4279 $changesfile = "$buildproductsdir/$changesfile";
4282 # Check that changes and .dsc agree enough
4283 $changesfile =~ m{[^/]*$};
4284 my $changes = parsecontrol($changesfile,$&);
4285 files_compare_inputs($dsc, $changes)
4286 unless forceing [qw(dsc-changes-mismatch)];
4288 # Perhaps adjust .dsc to contain right set of origs
4289 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4291 unless forceing [qw(changes-origs-exactly)];
4293 # Checks complete, we're going to try and go ahead:
4295 responder_send_file('changes',$changesfile);
4296 responder_send_command("param head $dgithead");
4297 responder_send_command("param csuite $csuite");
4298 responder_send_command("param isuite $isuite");
4299 responder_send_command("param tagformat $tagformat");
4300 if (defined $maintviewhead) {
4301 die unless ($protovsn//4) >= 4;
4302 responder_send_command("param maint-view $maintviewhead");
4305 # Perhaps send buildinfo(s) for signing
4306 my $changes_files = getfield $changes, 'Files';
4307 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4308 foreach my $bi (@buildinfos) {
4309 responder_send_command("param buildinfo-filename $bi");
4310 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4313 if (deliberately_not_fast_forward) {
4314 git_for_each_ref(lrfetchrefs, sub {
4315 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4316 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4317 responder_send_command("previously $rrefname=$objid");
4318 $previously{$rrefname} = $objid;
4322 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4326 supplementary_message(<<'END');
4327 Push failed, while signing the tag.
4328 You can retry the push, after fixing the problem, if you like.
4330 # If we manage to sign but fail to record it anywhere, it's fine.
4331 if ($we_are_responder) {
4332 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4333 responder_receive_files('signed-tag', @tagobjfns);
4335 @tagobjfns = push_mktags($clogp,$dscpath,
4336 $changesfile,$changesfile,
4339 supplementary_message(<<'END');
4340 Push failed, *after* signing the tag.
4341 If you want to try again, you should use a new version number.
4344 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4346 foreach my $tw (@tagwants) {
4347 my $tag = $tw->{Tag};
4348 my $tagobjfn = $tw->{TagObjFn};
4350 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4351 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4352 runcmd_ordryrun_local
4353 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4356 supplementary_message(<<'END');
4357 Push failed, while updating the remote git repository - see messages above.
4358 If you want to try again, you should use a new version number.
4360 if (!check_for_git()) {
4361 create_remote_git_repo();
4364 my @pushrefs = $forceflag.$dgithead.":".rrref();
4365 foreach my $tw (@tagwants) {
4366 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4369 runcmd_ordryrun @git,
4370 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4371 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4373 supplementary_message(<<'END');
4374 Push failed, while obtaining signatures on the .changes and .dsc.
4375 If it was just that the signature failed, you may try again by using
4376 debsign by hand to sign the changes
4378 and then dput to complete the upload.
4379 If you need to change the package, you must use a new version number.
4381 if ($we_are_responder) {
4382 my $dryrunsuffix = act_local() ? "" : ".tmp";
4383 my @rfiles = ($dscpath, $changesfile);
4384 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4385 responder_receive_files('signed-dsc-changes',
4386 map { "$_$dryrunsuffix" } @rfiles);
4389 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4391 progress "[new .dsc left in $dscpath.tmp]";
4393 sign_changes $changesfile;
4396 supplementary_message(<<END);
4397 Push failed, while uploading package(s) to the archive server.
4398 You can retry the upload of exactly these same files with dput of:
4400 If that .changes file is broken, you will need to use a new version
4401 number for your next attempt at the upload.
4403 my $host = access_cfg('upload-host','RETURN-UNDEF');
4404 my @hostarg = defined($host) ? ($host,) : ();
4405 runcmd_ordryrun @dput, @hostarg, $changesfile;
4406 printdone "pushed and uploaded $cversion";
4408 supplementary_message('');
4409 responder_send_command("complete");
4415 badusage "-p is not allowed with clone; specify as argument instead"
4416 if defined $package;
4419 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4420 ($package,$isuite) = @ARGV;
4421 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4422 ($package,$dstdir) = @ARGV;
4423 } elsif (@ARGV==3) {
4424 ($package,$isuite,$dstdir) = @ARGV;
4426 badusage "incorrect arguments to dgit clone";
4430 $dstdir ||= "$package";
4431 if (stat_exists $dstdir) {
4432 fail "$dstdir already exists";
4436 if ($rmonerror && !$dryrun_level) {
4437 $cwd_remove= getcwd();
4439 return unless defined $cwd_remove;
4440 if (!chdir "$cwd_remove") {
4441 return if $!==&ENOENT;
4442 die "chdir $cwd_remove: $!";
4444 printdebug "clone rmonerror removing $dstdir\n";
4446 rmtree($dstdir) or die "remove $dstdir: $!\n";
4447 } elsif (grep { $! == $_ }
4448 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4450 print STDERR "check whether to remove $dstdir: $!\n";
4456 $cwd_remove = undef;
4459 sub branchsuite () {
4460 my @cmd = (@git, qw(symbolic-ref -q HEAD));
4461 my $branch = cmdoutput_errok @cmd;
4462 if (!defined $branch) {
4463 $?==256 or failedcmd @cmd;
4466 if ($branch =~ m#$lbranch_re#o) {
4473 sub fetchpullargs () {
4474 if (!defined $package) {
4475 my $sourcep = parsecontrol('debian/control','debian/control');
4476 $package = getfield $sourcep, 'Source';
4479 $isuite = branchsuite();
4481 my $clogp = parsechangelog();
4482 my $clogsuite = getfield $clogp, 'Distribution';
4483 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4485 } elsif (@ARGV==1) {
4488 badusage "incorrect arguments to dgit fetch or dgit pull";
4496 my $multi_fetched = fork_for_multisuite(sub { });
4497 exit 0 if $multi_fetched;
4504 if (quiltmode_splitbrain()) {
4505 my ($format, $fopts) = get_source_format();
4506 madformat($format) and fail <<END
4507 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4515 badusage "-p is not allowed with dgit push" if defined $package;
4517 my $clogp = parsechangelog();
4518 $package = getfield $clogp, 'Source';
4521 } elsif (@ARGV==1) {
4522 ($specsuite) = (@ARGV);
4524 badusage "incorrect arguments to dgit push";
4526 $isuite = getfield $clogp, 'Distribution';
4529 local ($package) = $existing_package; # this is a hack
4530 canonicalise_suite();
4532 canonicalise_suite();
4534 if (defined $specsuite &&
4535 $specsuite ne $isuite &&
4536 $specsuite ne $csuite) {
4537 fail "dgit push: changelog specifies $isuite ($csuite)".
4538 " but command line specifies $specsuite";
4543 #---------- remote commands' implementation ----------
4545 sub cmd_remote_push_build_host {
4546 my ($nrargs) = shift @ARGV;
4547 my (@rargs) = @ARGV[0..$nrargs-1];
4548 @ARGV = @ARGV[$nrargs..$#ARGV];
4550 my ($dir,$vsnwant) = @rargs;
4551 # vsnwant is a comma-separated list; we report which we have
4552 # chosen in our ready response (so other end can tell if they
4555 $we_are_responder = 1;
4556 $us .= " (build host)";
4558 open PI, "<&STDIN" or die $!;
4559 open STDIN, "/dev/null" or die $!;
4560 open PO, ">&STDOUT" or die $!;
4562 open STDOUT, ">&STDERR" or die $!;
4566 ($protovsn) = grep {
4567 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4568 } @rpushprotovsn_support;
4570 fail "build host has dgit rpush protocol versions ".
4571 (join ",", @rpushprotovsn_support).
4572 " but invocation host has $vsnwant"
4573 unless defined $protovsn;
4575 responder_send_command("dgit-remote-push-ready $protovsn");
4580 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4581 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4582 # a good error message)
4584 sub rpush_handle_protovsn_bothends () {
4585 if ($protovsn < 4) {
4586 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4595 my $report = i_child_report();
4596 if (defined $report) {
4597 printdebug "($report)\n";
4598 } elsif ($i_child_pid) {
4599 printdebug "(killing build host child $i_child_pid)\n";
4600 kill 15, $i_child_pid;
4602 if (defined $i_tmp && !defined $initiator_tempdir) {
4604 eval { rmtree $i_tmp; };
4609 return unless forkcheck_mainprocess();
4614 my ($base,$selector,@args) = @_;
4615 $selector =~ s/\-/_/g;
4616 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4622 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4630 push @rargs, join ",", @rpushprotovsn_support;
4633 push @rdgit, @ropts;
4634 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4636 my @cmd = (@ssh, $host, shellquote @rdgit);
4639 $we_are_initiator=1;
4641 if (defined $initiator_tempdir) {
4642 rmtree $initiator_tempdir;
4643 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4644 $i_tmp = $initiator_tempdir;
4648 $i_child_pid = open2(\*RO, \*RI, @cmd);
4650 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4651 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4652 $supplementary_message = '' unless $protovsn >= 3;
4655 my ($icmd,$iargs) = initiator_expect {
4656 m/^(\S+)(?: (.*))?$/;
4659 i_method "i_resp", $icmd, $iargs;
4663 sub i_resp_progress ($) {
4665 my $msg = protocol_read_bytes \*RO, $rhs;
4669 sub i_resp_supplementary_message ($) {
4671 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4674 sub i_resp_complete {
4675 my $pid = $i_child_pid;
4676 $i_child_pid = undef; # prevents killing some other process with same pid
4677 printdebug "waiting for build host child $pid...\n";
4678 my $got = waitpid $pid, 0;
4679 die $! unless $got == $pid;
4680 die "build host child failed $?" if $?;
4683 printdebug "all done\n";
4687 sub i_resp_file ($) {
4689 my $localname = i_method "i_localname", $keyword;
4690 my $localpath = "$i_tmp/$localname";
4691 stat_exists $localpath and
4692 badproto \*RO, "file $keyword ($localpath) twice";
4693 protocol_receive_file \*RO, $localpath;
4694 i_method "i_file", $keyword;
4699 sub i_resp_param ($) {
4700 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4704 sub i_resp_previously ($) {
4705 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4706 or badproto \*RO, "bad previously spec";
4707 my $r = system qw(git check-ref-format), $1;
4708 die "bad previously ref spec ($r)" if $r;
4709 $previously{$1} = $2;
4714 sub i_resp_want ($) {
4716 die "$keyword ?" if $i_wanted{$keyword}++;
4718 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4719 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4720 die unless $isuite =~ m/^$suite_re$/;
4723 rpush_handle_protovsn_bothends();
4725 fail "rpush negotiated protocol version $protovsn".
4726 " which does not support quilt mode $quilt_mode"
4727 if quiltmode_splitbrain;
4729 my @localpaths = i_method "i_want", $keyword;
4730 printdebug "[[ $keyword @localpaths\n";
4731 foreach my $localpath (@localpaths) {
4732 protocol_send_file \*RI, $localpath;
4734 print RI "files-end\n" or die $!;
4737 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4739 sub i_localname_parsed_changelog {
4740 return "remote-changelog.822";
4742 sub i_file_parsed_changelog {
4743 ($i_clogp, $i_version, $i_dscfn) =
4744 push_parse_changelog "$i_tmp/remote-changelog.822";
4745 die if $i_dscfn =~ m#/|^\W#;
4748 sub i_localname_dsc {
4749 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4754 sub i_localname_buildinfo ($) {
4755 my $bi = $i_param{'buildinfo-filename'};
4756 defined $bi or badproto \*RO, "buildinfo before filename";
4757 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4758 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4759 or badproto \*RO, "improper buildinfo filename";
4762 sub i_file_buildinfo {
4763 my $bi = $i_param{'buildinfo-filename'};
4764 my $bd = parsecontrol "$i_tmp/$bi", $bi;
4765 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4766 if (!forceing [qw(buildinfo-changes-mismatch)]) {
4767 files_compare_inputs($bd, $ch);
4768 (getfield $bd, $_) eq (getfield $ch, $_) or
4769 fail "buildinfo mismatch $_"
4770 foreach qw(Source Version);
4771 !defined $bd->{$_} or
4772 fail "buildinfo contains $_"
4773 foreach qw(Changes Changed-by Distribution);
4775 push @i_buildinfos, $bi;
4776 delete $i_param{'buildinfo-filename'};
4779 sub i_localname_changes {
4780 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4781 $i_changesfn = $i_dscfn;
4782 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4783 return $i_changesfn;
4785 sub i_file_changes { }
4787 sub i_want_signed_tag {
4788 printdebug Dumper(\%i_param, $i_dscfn);
4789 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4790 && defined $i_param{'csuite'}
4791 or badproto \*RO, "premature desire for signed-tag";
4792 my $head = $i_param{'head'};
4793 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4795 my $maintview = $i_param{'maint-view'};
4796 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4799 if ($protovsn >= 4) {
4800 my $p = $i_param{'tagformat'} // '<undef>';
4802 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4805 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4807 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4809 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4812 push_mktags $i_clogp, $i_dscfn,
4813 $i_changesfn, 'remote changes',
4817 sub i_want_signed_dsc_changes {
4818 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4819 sign_changes $i_changesfn;
4820 return ($i_dscfn, $i_changesfn, @i_buildinfos);
4823 #---------- building etc. ----------
4829 #----- `3.0 (quilt)' handling -----
4831 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4833 sub quiltify_dpkg_commit ($$$;$) {
4834 my ($patchname,$author,$msg, $xinfo) = @_;
4838 my $descfn = ".git/dgit/quilt-description.tmp";
4839 open O, '>', $descfn or die "$descfn: $!";
4840 $msg =~ s/\n+/\n\n/;
4841 print O <<END or die $!;
4843 ${xinfo}Subject: $msg
4850 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4851 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4852 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4853 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4857 sub quiltify_trees_differ ($$;$$$) {
4858 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4859 # returns true iff the two tree objects differ other than in debian/
4860 # with $finegrained,
4861 # returns bitmask 01 - differ in upstream files except .gitignore
4862 # 02 - differ in .gitignore
4863 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4864 # is set for each modified .gitignore filename $fn
4865 # if $unrepres is defined, array ref to which is appeneded
4866 # a list of unrepresentable changes (removals of upstream files
4869 my @cmd = (@git, qw(diff-tree -z));
4870 push @cmd, qw(--name-only) unless $unrepres;
4871 push @cmd, qw(-r) if $finegrained || $unrepres;
4873 my $diffs= cmdoutput @cmd;
4876 foreach my $f (split /\0/, $diffs) {
4877 if ($unrepres && !@lmodes) {
4878 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4881 my ($oldmode,$newmode) = @lmodes;
4884 next if $f =~ m#^debian(?:/.*)?$#s;
4888 die "not a plain file\n"
4889 unless $newmode =~ m/^10\d{4}$/ ||
4890 $oldmode =~ m/^10\d{4}$/;
4891 if ($oldmode =~ m/[^0]/ &&
4892 $newmode =~ m/[^0]/) {
4893 die "mode changed\n" if $oldmode ne $newmode;
4895 die "non-default mode\n"
4896 unless $newmode =~ m/^100644$/ ||
4897 $oldmode =~ m/^100644$/;
4901 local $/="\n"; chomp $@;
4902 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4906 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4907 $r |= $isignore ? 02 : 01;
4908 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4910 printdebug "quiltify_trees_differ $x $y => $r\n";
4914 sub quiltify_tree_sentinelfiles ($) {
4915 # lists the `sentinel' files present in the tree
4917 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4918 qw(-- debian/rules debian/control);
4923 sub quiltify_splitbrain_needed () {
4924 if (!$split_brain) {
4925 progress "dgit view: changes are required...";
4926 runcmd @git, qw(checkout -q -b dgit-view);
4931 sub quiltify_splitbrain ($$$$$$) {
4932 my ($clogp, $unapplied, $headref, $diffbits,
4933 $editedignores, $cachekey) = @_;
4934 if ($quilt_mode !~ m/gbp|dpm/) {
4935 # treat .gitignore just like any other upstream file
4936 $diffbits = { %$diffbits };
4937 $_ = !!$_ foreach values %$diffbits;
4939 # We would like any commits we generate to be reproducible
4940 my @authline = clogp_authline($clogp);
4941 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4942 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4943 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4944 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4945 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4946 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4948 if ($quilt_mode =~ m/gbp|unapplied/ &&
4949 ($diffbits->{O2H} & 01)) {
4951 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4952 " but git tree differs from orig in upstream files.";
4953 if (!stat_exists "debian/patches") {
4955 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4959 if ($quilt_mode =~ m/dpm/ &&
4960 ($diffbits->{H2A} & 01)) {
4962 --quilt=$quilt_mode specified, implying patches-applied git tree
4963 but git tree differs from result of applying debian/patches to upstream
4966 if ($quilt_mode =~ m/gbp|unapplied/ &&
4967 ($diffbits->{O2A} & 01)) { # some patches
4968 quiltify_splitbrain_needed();
4969 progress "dgit view: creating patches-applied version using gbp pq";
4970 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4971 # gbp pq import creates a fresh branch; push back to dgit-view
4972 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4973 runcmd @git, qw(checkout -q dgit-view);
4975 if ($quilt_mode =~ m/gbp|dpm/ &&
4976 ($diffbits->{O2A} & 02)) {
4978 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4979 tool which does not create patches for changes to upstream
4980 .gitignores: but, such patches exist in debian/patches.
4983 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4984 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4985 quiltify_splitbrain_needed();
4986 progress "dgit view: creating patch to represent .gitignore changes";
4987 ensuredir "debian/patches";
4988 my $gipatch = "debian/patches/auto-gitignore";
4989 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4990 stat GIPATCH or die "$gipatch: $!";
4991 fail "$gipatch already exists; but want to create it".
4992 " to record .gitignore changes" if (stat _)[7];
4993 print GIPATCH <<END or die "$gipatch: $!";
4994 Subject: Update .gitignore from Debian packaging branch
4996 The Debian packaging git branch contains these updates to the upstream
4997 .gitignore file(s). This patch is autogenerated, to provide these
4998 updates to users of the official Debian archive view of the package.
5000 [dgit ($our_version) update-gitignore]
5003 close GIPATCH or die "$gipatch: $!";
5004 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5005 $unapplied, $headref, "--", sort keys %$editedignores;
5006 open SERIES, "+>>", "debian/patches/series" or die $!;
5007 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5009 defined read SERIES, $newline, 1 or die $!;
5010 print SERIES "\n" or die $! unless $newline eq "\n";
5011 print SERIES "auto-gitignore\n" or die $!;
5012 close SERIES or die $!;
5013 runcmd @git, qw(add -- debian/patches/series), $gipatch;
5015 Commit patch to update .gitignore
5017 [dgit ($our_version) update-gitignore-quilt-fixup]
5021 my $dgitview = git_rev_parse 'HEAD';
5023 changedir '../../../..';
5024 # When we no longer need to support squeeze, use --create-reflog
5026 ensuredir ".git/logs/refs/dgit-intern";
5027 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
5030 my $oldcache = git_get_ref "refs/$splitbraincache";
5031 if ($oldcache eq $dgitview) {
5032 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5033 # git update-ref doesn't always update, in this case. *sigh*
5034 my $dummy = make_commit_text <<END;
5037 author Dgit <dgit\@example.com> 1000000000 +0000
5038 committer Dgit <dgit\@example.com> 1000000000 +0000
5040 Dummy commit - do not use
5042 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5043 "refs/$splitbraincache", $dummy;
5045 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5048 changedir '.git/dgit/unpack/work';
5050 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5051 progress "dgit view: created ($saved)";
5054 sub quiltify ($$$$) {
5055 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5057 # Quilt patchification algorithm
5059 # We search backwards through the history of the main tree's HEAD
5060 # (T) looking for a start commit S whose tree object is identical
5061 # to to the patch tip tree (ie the tree corresponding to the
5062 # current dpkg-committed patch series). For these purposes
5063 # `identical' disregards anything in debian/ - this wrinkle is
5064 # necessary because dpkg-source treates debian/ specially.
5066 # We can only traverse edges where at most one of the ancestors'
5067 # trees differs (in changes outside in debian/). And we cannot
5068 # handle edges which change .pc/ or debian/patches. To avoid
5069 # going down a rathole we avoid traversing edges which introduce
5070 # debian/rules or debian/control. And we set a limit on the
5071 # number of edges we are willing to look at.
5073 # If we succeed, we walk forwards again. For each traversed edge
5074 # PC (with P parent, C child) (starting with P=S and ending with
5075 # C=T) to we do this:
5077 # - dpkg-source --commit with a patch name and message derived from C
5078 # After traversing PT, we git commit the changes which
5079 # should be contained within debian/patches.
5081 # The search for the path S..T is breadth-first. We maintain a
5082 # todo list containing search nodes. A search node identifies a
5083 # commit, and looks something like this:
5085 # Commit => $git_commit_id,
5086 # Child => $c, # or undef if P=T
5087 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5088 # Nontrivial => true iff $p..$c has relevant changes
5095 my %considered; # saves being exponential on some weird graphs
5097 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5100 my ($search,$whynot) = @_;
5101 printdebug " search NOT $search->{Commit} $whynot\n";
5102 $search->{Whynot} = $whynot;
5103 push @nots, $search;
5104 no warnings qw(exiting);
5113 my $c = shift @todo;
5114 next if $considered{$c->{Commit}}++;
5116 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5118 printdebug "quiltify investigate $c->{Commit}\n";
5121 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5122 printdebug " search finished hooray!\n";
5127 if ($quilt_mode eq 'nofix') {
5128 fail "quilt fixup required but quilt mode is \`nofix'\n".
5129 "HEAD commit $c->{Commit} differs from tree implied by ".
5130 " debian/patches (tree object $oldtiptree)";
5132 if ($quilt_mode eq 'smash') {
5133 printdebug " search quitting smash\n";
5137 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5138 $not->($c, "has $c_sentinels not $t_sentinels")
5139 if $c_sentinels ne $t_sentinels;
5141 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5142 $commitdata =~ m/\n\n/;
5144 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5145 @parents = map { { Commit => $_, Child => $c } } @parents;
5147 $not->($c, "root commit") if !@parents;
5149 foreach my $p (@parents) {
5150 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5152 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5153 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5155 foreach my $p (@parents) {
5156 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5158 my @cmd= (@git, qw(diff-tree -r --name-only),
5159 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5160 my $patchstackchange = cmdoutput @cmd;
5161 if (length $patchstackchange) {
5162 $patchstackchange =~ s/\n/,/g;
5163 $not->($p, "changed $patchstackchange");
5166 printdebug " search queue P=$p->{Commit} ",
5167 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5173 printdebug "quiltify want to smash\n";
5176 my $x = $_[0]{Commit};
5177 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5180 my $reportnot = sub {
5182 my $s = $abbrev->($notp);
5183 my $c = $notp->{Child};
5184 $s .= "..".$abbrev->($c) if $c;
5185 $s .= ": ".$notp->{Whynot};
5188 if ($quilt_mode eq 'linear') {
5189 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
5190 foreach my $notp (@nots) {
5191 print STDERR "$us: ", $reportnot->($notp), "\n";
5193 print STDERR "$us: $_\n" foreach @$failsuggestion;
5194 fail "quilt fixup naive history linearisation failed.\n".
5195 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5196 } elsif ($quilt_mode eq 'smash') {
5197 } elsif ($quilt_mode eq 'auto') {
5198 progress "quilt fixup cannot be linear, smashing...";
5200 die "$quilt_mode ?";
5203 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5204 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5206 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5208 quiltify_dpkg_commit "auto-$version-$target-$time",
5209 (getfield $clogp, 'Maintainer'),
5210 "Automatically generated patch ($clogp->{Version})\n".
5211 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5215 progress "quiltify linearisation planning successful, executing...";
5217 for (my $p = $sref_S;
5218 my $c = $p->{Child};
5220 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5221 next unless $p->{Nontrivial};
5223 my $cc = $c->{Commit};
5225 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5226 $commitdata =~ m/\n\n/ or die "$c ?";
5229 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5232 my $commitdate = cmdoutput
5233 @git, qw(log -n1 --pretty=format:%aD), $cc;
5235 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5237 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5244 my $gbp_check_suitable = sub {
5249 die "contains unexpected slashes\n" if m{//} || m{/$};
5250 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5251 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5252 die "too long" if length > 200;
5254 return $_ unless $@;
5255 print STDERR "quiltifying commit $cc:".
5256 " ignoring/dropping Gbp-Pq $what: $@";
5260 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5262 (\S+) \s* \n //ixm) {
5263 $patchname = $gbp_check_suitable->($1, 'Name');
5265 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5267 (\S+) \s* \n //ixm) {
5268 $patchdir = $gbp_check_suitable->($1, 'Topic');
5273 if (!defined $patchname) {
5274 $patchname = $title;
5275 $patchname =~ s/[.:]$//;
5278 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5279 my $translitname = $converter->convert($patchname);
5280 die unless defined $translitname;
5281 $patchname = $translitname;
5284 "dgit: patch title transliteration error: $@"
5286 $patchname =~ y/ A-Z/-a-z/;
5287 $patchname =~ y/-a-z0-9_.+=~//cd;
5288 $patchname =~ s/^\W/x-$&/;
5289 $patchname = substr($patchname,0,40);
5291 if (!defined $patchdir) {
5294 if (length $patchdir) {
5295 $patchname = "$patchdir/$patchname";
5297 if ($patchname =~ m{^(.*)/}) {
5298 mkpath "debian/patches/$1";
5303 stat "debian/patches/$patchname$index";
5305 $!==ENOENT or die "$patchname$index $!";
5307 runcmd @git, qw(checkout -q), $cc;
5309 # We use the tip's changelog so that dpkg-source doesn't
5310 # produce complaining messages from dpkg-parsechangelog. None
5311 # of the information dpkg-source gets from the changelog is
5312 # actually relevant - it gets put into the original message
5313 # which dpkg-source provides our stunt editor, and then
5315 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5317 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5318 "Date: $commitdate\n".
5319 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5321 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5324 runcmd @git, qw(checkout -q master);
5327 sub build_maybe_quilt_fixup () {
5328 my ($format,$fopts) = get_source_format;
5329 return unless madformat_wantfixup $format;
5332 check_for_vendor_patches();
5334 if (quiltmode_splitbrain) {
5335 fail <<END unless access_cfg_tagformats_can_splitbrain;
5336 quilt mode $quilt_mode requires split view so server needs to support
5337 both "new" and "maint" tag formats, but config says it doesn't.
5341 my $clogp = parsechangelog();
5342 my $headref = git_rev_parse('HEAD');
5347 my $upstreamversion = upstreamversion $version;
5349 if ($fopts->{'single-debian-patch'}) {
5350 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5352 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5355 die 'bug' if $split_brain && !$need_split_build_invocation;
5357 changedir '../../../..';
5358 runcmd_ordryrun_local
5359 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5362 sub quilt_fixup_mkwork ($) {
5365 mkdir "work" or die $!;
5367 mktree_in_ud_here();
5368 runcmd @git, qw(reset -q --hard), $headref;
5371 sub quilt_fixup_linkorigs ($$) {
5372 my ($upstreamversion, $fn) = @_;
5373 # calls $fn->($leafname);
5375 foreach my $f (<../../../../*>) { #/){
5376 my $b=$f; $b =~ s{.*/}{};
5378 local ($debuglevel) = $debuglevel-1;
5379 printdebug "QF linkorigs $b, $f ?\n";
5381 next unless is_orig_file_of_vsn $b, $upstreamversion;
5382 printdebug "QF linkorigs $b, $f Y\n";
5383 link_ltarget $f, $b or die "$b $!";
5388 sub quilt_fixup_delete_pc () {
5389 runcmd @git, qw(rm -rqf .pc);
5391 Commit removal of .pc (quilt series tracking data)
5393 [dgit ($our_version) upgrade quilt-remove-pc]
5397 sub quilt_fixup_singlepatch ($$$) {
5398 my ($clogp, $headref, $upstreamversion) = @_;
5400 progress "starting quiltify (single-debian-patch)";
5402 # dpkg-source --commit generates new patches even if
5403 # single-debian-patch is in debian/source/options. In order to
5404 # get it to generate debian/patches/debian-changes, it is
5405 # necessary to build the source package.
5407 quilt_fixup_linkorigs($upstreamversion, sub { });
5408 quilt_fixup_mkwork($headref);
5410 rmtree("debian/patches");
5412 runcmd @dpkgsource, qw(-b .);
5414 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5415 rename srcfn("$upstreamversion", "/debian/patches"),
5416 "work/debian/patches";
5419 commit_quilty_patch();
5422 sub quilt_make_fake_dsc ($) {
5423 my ($upstreamversion) = @_;
5425 my $fakeversion="$upstreamversion-~~DGITFAKE";
5427 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5428 print $fakedsc <<END or die $!;
5431 Version: $fakeversion
5435 my $dscaddfile=sub {
5438 my $md = new Digest::MD5;
5440 my $fh = new IO::File $b, '<' or die "$b $!";
5445 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5448 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5450 my @files=qw(debian/source/format debian/rules
5451 debian/control debian/changelog);
5452 foreach my $maybe (qw(debian/patches debian/source/options
5453 debian/tests/control)) {
5454 next unless stat_exists "../../../$maybe";
5455 push @files, $maybe;
5458 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5459 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5461 $dscaddfile->($debtar);
5462 close $fakedsc or die $!;
5465 sub quilt_check_splitbrain_cache ($$) {
5466 my ($headref, $upstreamversion) = @_;
5467 # Called only if we are in (potentially) split brain mode.
5469 # Computes the cache key and looks in the cache.
5470 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5472 my $splitbrain_cachekey;
5475 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5476 # we look in the reflog of dgit-intern/quilt-cache
5477 # we look for an entry whose message is the key for the cache lookup
5478 my @cachekey = (qw(dgit), $our_version);
5479 push @cachekey, $upstreamversion;
5480 push @cachekey, $quilt_mode;
5481 push @cachekey, $headref;
5483 push @cachekey, hashfile('fake.dsc');
5485 my $srcshash = Digest::SHA->new(256);
5486 my %sfs = ( %INC, '$0(dgit)' => $0 );
5487 foreach my $sfk (sort keys %sfs) {
5488 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5489 $srcshash->add($sfk," ");
5490 $srcshash->add(hashfile($sfs{$sfk}));
5491 $srcshash->add("\n");
5493 push @cachekey, $srcshash->hexdigest();
5494 $splitbrain_cachekey = "@cachekey";
5496 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5498 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5499 debugcmd "|(probably)",@cmd;
5500 my $child = open GC, "-|"; defined $child or die $!;
5502 chdir '../../..' or die $!;
5503 if (!stat ".git/logs/refs/$splitbraincache") {
5504 $! == ENOENT or die $!;
5505 printdebug ">(no reflog)\n";
5512 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5513 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5516 quilt_fixup_mkwork($headref);
5517 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5518 if ($cachehit ne $headref) {
5519 progress "dgit view: found cached ($saved)";
5520 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5522 return ($cachehit, $splitbrain_cachekey);
5524 progress "dgit view: found cached, no changes required";
5525 return ($headref, $splitbrain_cachekey);
5527 die $! if GC->error;
5528 failedcmd unless close GC;
5530 printdebug "splitbrain cache miss\n";
5531 return (undef, $splitbrain_cachekey);
5534 sub quilt_fixup_multipatch ($$$) {
5535 my ($clogp, $headref, $upstreamversion) = @_;
5537 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5540 # - honour any existing .pc in case it has any strangeness
5541 # - determine the git commit corresponding to the tip of
5542 # the patch stack (if there is one)
5543 # - if there is such a git commit, convert each subsequent
5544 # git commit into a quilt patch with dpkg-source --commit
5545 # - otherwise convert all the differences in the tree into
5546 # a single git commit
5550 # Our git tree doesn't necessarily contain .pc. (Some versions of
5551 # dgit would include the .pc in the git tree.) If there isn't
5552 # one, we need to generate one by unpacking the patches that we
5555 # We first look for a .pc in the git tree. If there is one, we
5556 # will use it. (This is not the normal case.)
5558 # Otherwise need to regenerate .pc so that dpkg-source --commit
5559 # can work. We do this as follows:
5560 # 1. Collect all relevant .orig from parent directory
5561 # 2. Generate a debian.tar.gz out of
5562 # debian/{patches,rules,source/format,source/options}
5563 # 3. Generate a fake .dsc containing just these fields:
5564 # Format Source Version Files
5565 # 4. Extract the fake .dsc
5566 # Now the fake .dsc has a .pc directory.
5567 # (In fact we do this in every case, because in future we will
5568 # want to search for a good base commit for generating patches.)
5570 # Then we can actually do the dpkg-source --commit
5571 # 1. Make a new working tree with the same object
5572 # store as our main tree and check out the main
5574 # 2. Copy .pc from the fake's extraction, if necessary
5575 # 3. Run dpkg-source --commit
5576 # 4. If the result has changes to debian/, then
5577 # - git add them them
5578 # - git add .pc if we had a .pc in-tree
5580 # 5. If we had a .pc in-tree, delete it, and git commit
5581 # 6. Back in the main tree, fast forward to the new HEAD
5583 # Another situation we may have to cope with is gbp-style
5584 # patches-unapplied trees.
5586 # We would want to detect these, so we know to escape into
5587 # quilt_fixup_gbp. However, this is in general not possible.
5588 # Consider a package with a one patch which the dgit user reverts
5589 # (with git revert or the moral equivalent).
5591 # That is indistinguishable in contents from a patches-unapplied
5592 # tree. And looking at the history to distinguish them is not
5593 # useful because the user might have made a confusing-looking git
5594 # history structure (which ought to produce an error if dgit can't
5595 # cope, not a silent reintroduction of an unwanted patch).
5597 # So gbp users will have to pass an option. But we can usually
5598 # detect their failure to do so: if the tree is not a clean
5599 # patches-applied tree, quilt linearisation fails, but the tree
5600 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5601 # they want --quilt=unapplied.
5603 # To help detect this, when we are extracting the fake dsc, we
5604 # first extract it with --skip-patches, and then apply the patches
5605 # afterwards with dpkg-source --before-build. That lets us save a
5606 # tree object corresponding to .origs.
5608 my $splitbrain_cachekey;
5610 quilt_make_fake_dsc($upstreamversion);
5612 if (quiltmode_splitbrain()) {
5614 ($cachehit, $splitbrain_cachekey) =
5615 quilt_check_splitbrain_cache($headref, $upstreamversion);
5616 return if $cachehit;
5620 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5622 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5623 rename $fakexdir, "fake" or die "$fakexdir $!";
5627 remove_stray_gits("source package");
5628 mktree_in_ud_here();
5632 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5633 my $unapplied=git_add_write_tree();
5634 printdebug "fake orig tree object $unapplied\n";
5638 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5640 if (system @bbcmd) {
5641 failedcmd @bbcmd if $? < 0;
5643 failed to apply your git tree's patch stack (from debian/patches/) to
5644 the corresponding upstream tarball(s). Your source tree and .orig
5645 are probably too inconsistent. dgit can only fix up certain kinds of
5646 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5652 quilt_fixup_mkwork($headref);
5655 if (stat_exists ".pc") {
5657 progress "Tree already contains .pc - will use it then delete it.";
5660 rename '../fake/.pc','.pc' or die $!;
5663 changedir '../fake';
5665 my $oldtiptree=git_add_write_tree();
5666 printdebug "fake o+d/p tree object $unapplied\n";
5667 changedir '../work';
5670 # We calculate some guesswork now about what kind of tree this might
5671 # be. This is mostly for error reporting.
5677 # O = orig, without patches applied
5678 # A = "applied", ie orig with H's debian/patches applied
5679 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5680 \%editedignores, \@unrepres),
5681 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5682 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5686 foreach my $b (qw(01 02)) {
5687 foreach my $v (qw(O2H O2A H2A)) {
5688 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5691 printdebug "differences \@dl @dl.\n";
5694 "$us: base trees orig=%.20s o+d/p=%.20s",
5695 $unapplied, $oldtiptree;
5697 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5698 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5699 $dl[0], $dl[1], $dl[3], $dl[4],
5703 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5705 forceable_fail [qw(unrepresentable)], <<END;
5706 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5711 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5712 push @failsuggestion, "This might be a patches-unapplied branch.";
5713 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5714 push @failsuggestion, "This might be a patches-applied branch.";
5716 push @failsuggestion, "Maybe you need to specify one of".
5717 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5719 if (quiltmode_splitbrain()) {
5720 quiltify_splitbrain($clogp, $unapplied, $headref,
5721 $diffbits, \%editedignores,
5722 $splitbrain_cachekey);
5726 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5727 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5729 if (!open P, '>>', ".pc/applied-patches") {
5730 $!==&ENOENT or die $!;
5735 commit_quilty_patch();
5737 if ($mustdeletepc) {
5738 quilt_fixup_delete_pc();
5742 sub quilt_fixup_editor () {
5743 my $descfn = $ENV{$fakeeditorenv};
5744 my $editing = $ARGV[$#ARGV];
5745 open I1, '<', $descfn or die "$descfn: $!";
5746 open I2, '<', $editing or die "$editing: $!";
5747 unlink $editing or die "$editing: $!";
5748 open O, '>', $editing or die "$editing: $!";
5749 while (<I1>) { print O or die $!; } I1->error and die $!;
5752 $copying ||= m/^\-\-\- /;
5753 next unless $copying;
5756 I2->error and die $!;
5761 sub maybe_apply_patches_dirtily () {
5762 return unless $quilt_mode =~ m/gbp|unapplied/;
5763 print STDERR <<END or die $!;
5765 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5766 dgit: Have to apply the patches - making the tree dirty.
5767 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5770 $patches_applied_dirtily = 01;
5771 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5772 runcmd qw(dpkg-source --before-build .);
5775 sub maybe_unapply_patches_again () {
5776 progress "dgit: Unapplying patches again to tidy up the tree."
5777 if $patches_applied_dirtily;
5778 runcmd qw(dpkg-source --after-build .)
5779 if $patches_applied_dirtily & 01;
5781 if $patches_applied_dirtily & 02;
5782 $patches_applied_dirtily = 0;
5785 #----- other building -----
5787 our $clean_using_builder;
5788 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5789 # clean the tree before building (perhaps invoked indirectly by
5790 # whatever we are using to run the build), rather than separately
5791 # and explicitly by us.
5794 return if $clean_using_builder;
5795 if ($cleanmode eq 'dpkg-source') {
5796 maybe_apply_patches_dirtily();
5797 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5798 } elsif ($cleanmode eq 'dpkg-source-d') {
5799 maybe_apply_patches_dirtily();
5800 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5801 } elsif ($cleanmode eq 'git') {
5802 runcmd_ordryrun_local @git, qw(clean -xdf);
5803 } elsif ($cleanmode eq 'git-ff') {
5804 runcmd_ordryrun_local @git, qw(clean -xdff);
5805 } elsif ($cleanmode eq 'check') {
5806 my $leftovers = cmdoutput @git, qw(clean -xdn);
5807 if (length $leftovers) {
5808 print STDERR $leftovers, "\n" or die $!;
5809 fail "tree contains uncommitted files and --clean=check specified";
5811 } elsif ($cleanmode eq 'none') {
5818 badusage "clean takes no additional arguments" if @ARGV;
5821 maybe_unapply_patches_again();
5824 sub build_prep_early () {
5825 our $build_prep_early_done //= 0;
5826 return if $build_prep_early_done++;
5827 badusage "-p is not allowed when building" if defined $package;
5828 my $clogp = parsechangelog();
5829 $isuite = getfield $clogp, 'Distribution';
5830 $package = getfield $clogp, 'Source';
5831 $version = getfield $clogp, 'Version';
5839 build_maybe_quilt_fixup();
5841 my $pat = changespat $version;
5842 foreach my $f (glob "$buildproductsdir/$pat") {
5844 unlink $f or fail "remove old changes file $f: $!";
5846 progress "would remove $f";
5852 sub changesopts_initial () {
5853 my @opts =@changesopts[1..$#changesopts];
5856 sub changesopts_version () {
5857 if (!defined $changes_since_version) {
5858 my @vsns = archive_query('archive_query');
5859 my @quirk = access_quirk();
5860 if ($quirk[0] eq 'backports') {
5861 local $isuite = $quirk[2];
5863 canonicalise_suite();
5864 push @vsns, archive_query('archive_query');
5867 @vsns = map { $_->[0] } @vsns;
5868 @vsns = sort { -version_compare($a, $b) } @vsns;
5869 $changes_since_version = $vsns[0];
5870 progress "changelog will contain changes since $vsns[0]";
5872 $changes_since_version = '_';
5873 progress "package seems new, not specifying -v<version>";
5876 if ($changes_since_version ne '_') {
5877 return ("-v$changes_since_version");
5883 sub changesopts () {
5884 return (changesopts_initial(), changesopts_version());
5887 sub massage_dbp_args ($;$) {
5888 my ($cmd,$xargs) = @_;
5891 # - if we're going to split the source build out so we can
5892 # do strange things to it, massage the arguments to dpkg-buildpackage
5893 # so that the main build doessn't build source (or add an argument
5894 # to stop it building source by default).
5896 # - add -nc to stop dpkg-source cleaning the source tree,
5897 # unless we're not doing a split build and want dpkg-source
5898 # as cleanmode, in which case we can do nothing
5901 # 0 - source will NOT need to be built separately by caller
5902 # +1 - source will need to be built separately by caller
5903 # +2 - source will need to be built separately by caller AND
5904 # dpkg-buildpackage should not in fact be run at all!
5905 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5906 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5907 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5908 $clean_using_builder = 1;
5911 # -nc has the side effect of specifying -b if nothing else specified
5912 # and some combinations of -S, -b, et al, are errors, rather than
5913 # later simply overriding earlie. So we need to:
5914 # - search the command line for these options
5915 # - pick the last one
5916 # - perhaps add our own as a default
5917 # - perhaps adjust it to the corresponding non-source-building version
5919 foreach my $l ($cmd, $xargs) {
5921 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5924 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5926 if ($need_split_build_invocation) {
5927 printdebug "massage split $dmode.\n";
5928 $r = $dmode =~ m/[S]/ ? +2 :
5929 $dmode =~ y/gGF/ABb/ ? +1 :
5930 $dmode =~ m/[ABb]/ ? 0 :
5933 printdebug "massage done $r $dmode.\n";
5935 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5941 my $wasdir = must_getcwd();
5947 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5948 my ($msg_if_onlyone) = @_;
5949 # If there is only one .changes file, fail with $msg_if_onlyone,
5950 # or if that is undef, be a no-op.
5951 # Returns the changes file to report to the user.
5952 my $pat = changespat $version;
5953 my @changesfiles = glob $pat;
5954 @changesfiles = sort {
5955 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5959 if (@changesfiles==1) {
5960 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5961 only one changes file from build (@changesfiles)
5963 $result = $changesfiles[0];
5964 } elsif (@changesfiles==2) {
5965 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5966 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5967 fail "$l found in binaries changes file $binchanges"
5970 runcmd_ordryrun_local @mergechanges, @changesfiles;
5971 my $multichanges = changespat $version,'multi';
5973 stat_exists $multichanges or fail "$multichanges: $!";
5974 foreach my $cf (glob $pat) {
5975 next if $cf eq $multichanges;
5976 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5979 $result = $multichanges;
5981 fail "wrong number of different changes files (@changesfiles)";
5983 printdone "build successful, results in $result\n" or die $!;
5986 sub midbuild_checkchanges () {
5987 my $pat = changespat $version;
5988 return if $rmchanges;
5989 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5990 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5992 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5993 Suggest you delete @unwanted.
5998 sub midbuild_checkchanges_vanilla ($) {
6000 midbuild_checkchanges() if $wantsrc == 1;
6003 sub postbuild_mergechanges_vanilla ($) {
6005 if ($wantsrc == 1) {
6007 postbuild_mergechanges(undef);
6010 printdone "build successful\n";
6016 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6017 my $wantsrc = massage_dbp_args \@dbp;
6020 midbuild_checkchanges_vanilla $wantsrc;
6025 push @dbp, changesopts_version();
6026 maybe_apply_patches_dirtily();
6027 runcmd_ordryrun_local @dbp;
6029 maybe_unapply_patches_again();
6030 postbuild_mergechanges_vanilla $wantsrc;
6034 $quilt_mode //= 'gbp';
6040 # gbp can make .origs out of thin air. In my tests it does this
6041 # even for a 1.0 format package, with no origs present. So I
6042 # guess it keys off just the version number. We don't know
6043 # exactly what .origs ought to exist, but let's assume that we
6044 # should run gbp if: the version has an upstream part and the main
6046 my $upstreamversion = upstreamversion $version;
6047 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6048 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6050 if ($gbp_make_orig) {
6052 $cleanmode = 'none'; # don't do it again
6053 $need_split_build_invocation = 1;
6056 my @dbp = @dpkgbuildpackage;
6058 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6060 if (!length $gbp_build[0]) {
6061 if (length executable_on_path('git-buildpackage')) {
6062 $gbp_build[0] = qw(git-buildpackage);
6064 $gbp_build[0] = 'gbp buildpackage';
6067 my @cmd = opts_opt_multi_cmd @gbp_build;
6069 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
6071 if ($gbp_make_orig) {
6072 ensuredir '.git/dgit';
6073 my $ok = '.git/dgit/origs-gen-ok';
6074 unlink $ok or $!==&ENOENT or die $!;
6075 my @origs_cmd = @cmd;
6076 push @origs_cmd, qw(--git-cleaner=true);
6077 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
6078 push @origs_cmd, @ARGV;
6080 debugcmd @origs_cmd;
6082 do { local $!; stat_exists $ok; }
6083 or failedcmd @origs_cmd;
6085 dryrun_report @origs_cmd;
6091 midbuild_checkchanges_vanilla $wantsrc;
6093 if (!$clean_using_builder) {
6094 push @cmd, '--git-cleaner=true';
6098 maybe_unapply_patches_again();
6100 push @cmd, changesopts();
6101 runcmd_ordryrun_local @cmd, @ARGV;
6103 postbuild_mergechanges_vanilla $wantsrc;
6105 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6109 my $our_cleanmode = $cleanmode;
6110 if ($need_split_build_invocation) {
6111 # Pretend that clean is being done some other way. This
6112 # forces us not to try to use dpkg-buildpackage to clean and
6113 # build source all in one go; and instead we run dpkg-source
6114 # (and build_prep() will do the clean since $clean_using_builder
6116 $our_cleanmode = 'ELSEWHERE';
6118 if ($our_cleanmode =~ m/^dpkg-source/) {
6119 # dpkg-source invocation (below) will clean, so build_prep shouldn't
6120 $clean_using_builder = 1;
6123 $sourcechanges = changespat $version,'source';
6125 unlink "../$sourcechanges" or $!==ENOENT
6126 or fail "remove $sourcechanges: $!";
6128 $dscfn = dscfn($version);
6129 if ($our_cleanmode eq 'dpkg-source') {
6130 maybe_apply_patches_dirtily();
6131 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
6133 } elsif ($our_cleanmode eq 'dpkg-source-d') {
6134 maybe_apply_patches_dirtily();
6135 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
6138 my @cmd = (@dpkgsource, qw(-b --));
6141 runcmd_ordryrun_local @cmd, "work";
6142 my @udfiles = <${package}_*>;
6143 changedir "../../..";
6144 foreach my $f (@udfiles) {
6145 printdebug "source copy, found $f\n";
6148 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6149 $f eq srcfn($version, $&));
6150 printdebug "source copy, found $f - renaming\n";
6151 rename "$ud/$f", "../$f" or $!==ENOENT
6152 or fail "put in place new source file ($f): $!";
6155 my $pwd = must_getcwd();
6156 my $leafdir = basename $pwd;
6158 runcmd_ordryrun_local @cmd, $leafdir;
6161 runcmd_ordryrun_local qw(sh -ec),
6162 'exec >$1; shift; exec "$@"','x',
6163 "../$sourcechanges",
6164 @dpkggenchanges, qw(-S), changesopts();
6168 sub cmd_build_source {
6170 badusage "build-source takes no additional arguments" if @ARGV;
6172 maybe_unapply_patches_again();
6173 printdone "source built, results in $dscfn and $sourcechanges";
6178 midbuild_checkchanges();
6181 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6182 stat_exists $sourcechanges
6183 or fail "$sourcechanges (in parent directory): $!";
6185 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6187 maybe_unapply_patches_again();
6189 postbuild_mergechanges(<<END);
6190 perhaps you need to pass -A ? (sbuild's default is to build only
6191 arch-specific binaries; dgit 1.4 used to override that.)
6196 sub cmd_quilt_fixup {
6197 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6200 build_maybe_quilt_fixup();
6203 sub import_dsc_result {
6204 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6205 my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
6207 check_gitattrs($newhash, "source tree");
6209 progress "dgit: import-dsc: $what_msg";
6212 sub cmd_import_dsc {
6216 last unless $ARGV[0] =~ m/^-/;
6219 if (m/^--require-valid-signature$/) {
6222 badusage "unknown dgit import-dsc sub-option \`$_'";
6226 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6227 my ($dscfn, $dstbranch) = @ARGV;
6229 badusage "dry run makes no sense with import-dsc" unless act_local();
6231 my $force = $dstbranch =~ s/^\+// ? +1 :
6232 $dstbranch =~ s/^\.\.// ? -1 :
6234 my $info = $force ? " $&" : '';
6235 $info = "$dscfn$info";
6237 my $specbranch = $dstbranch;
6238 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6239 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6241 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6242 my $chead = cmdoutput_errok @symcmd;
6243 defined $chead or $?==256 or failedcmd @symcmd;
6245 fail "$dstbranch is checked out - will not update it"
6246 if defined $chead and $chead eq $dstbranch;
6248 my $oldhash = git_get_ref $dstbranch;
6250 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6251 $dscdata = do { local $/ = undef; <D>; };
6252 D->error and fail "read $dscfn: $!";
6255 # we don't normally need this so import it here
6256 use Dpkg::Source::Package;
6257 my $dp = new Dpkg::Source::Package filename => $dscfn,
6258 require_valid_signature => $needsig;
6260 local $SIG{__WARN__} = sub {
6262 return unless $needsig;
6263 fail "import-dsc signature check failed";
6265 if (!$dp->is_signed()) {
6266 warn "$us: warning: importing unsigned .dsc\n";
6268 my $r = $dp->check_signature();
6269 die "->check_signature => $r" if $needsig && $r;
6275 $package = getfield $dsc, 'Source';
6277 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6278 unless forceing [qw(import-dsc-with-dgit-field)];
6279 parse_dsc_field_def_dsc_distro();
6281 $isuite = 'DGIT-IMPORT-DSC';
6282 $idistro //= $dsc_distro;
6286 if (defined $dsc_hash) {
6287 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6288 resolve_dsc_field_commit undef, undef;
6290 if (defined $dsc_hash) {
6291 my @cmd = (qw(sh -ec),
6292 "echo $dsc_hash | git cat-file --batch-check");
6293 my $objgot = cmdoutput @cmd;
6294 if ($objgot =~ m#^\w+ missing\b#) {
6296 .dsc contains Dgit field referring to object $dsc_hash
6297 Your git tree does not have that object. Try `git fetch' from a
6298 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6301 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6303 progress "Not fast forward, forced update.";
6305 fail "Not fast forward to $dsc_hash";
6308 import_dsc_result $dstbranch, $dsc_hash,
6309 "dgit import-dsc (Dgit): $info",
6310 "updated git ref $dstbranch";
6315 Branch $dstbranch already exists
6316 Specify ..$specbranch for a pseudo-merge, binding in existing history
6317 Specify +$specbranch to overwrite, discarding existing history
6319 if $oldhash && !$force;
6321 my @dfi = dsc_files_info();
6322 foreach my $fi (@dfi) {
6323 my $f = $fi->{Filename};
6325 next if lstat $here;
6326 fail "stat $here: $!" unless $! == ENOENT;
6328 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6330 } elsif ($dscfn =~ m#^/#) {
6333 fail "cannot import $dscfn which seems to be inside working tree!";
6335 $there =~ s#/+[^/]+$## or
6336 fail "cannot import $dscfn which seems to not have a basename";
6338 symlink $there, $here or fail "symlink $there to $here: $!";
6339 progress "made symlink $here -> $there";
6340 # print STDERR Dumper($fi);
6342 my @mergeinputs = generate_commits_from_dsc();
6343 die unless @mergeinputs == 1;
6345 my $newhash = $mergeinputs[0]{Commit};
6349 progress "Import, forced update - synthetic orphan git history.";
6350 } elsif ($force < 0) {
6351 progress "Import, merging.";
6352 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6353 my $version = getfield $dsc, 'Version';
6354 my $clogp = commit_getclogp $newhash;
6355 my $authline = clogp_authline $clogp;
6356 $newhash = make_commit_text <<END;
6363 Merge $package ($version) import into $dstbranch
6366 die; # caught earlier
6370 import_dsc_result $dstbranch, $newhash,
6371 "dgit import-dsc: $info",
6372 "results are in in git ref $dstbranch";
6375 sub cmd_archive_api_query {
6376 badusage "need only 1 subpath argument" unless @ARGV==1;
6377 my ($subpath) = @ARGV;
6378 my @cmd = archive_api_query_cmd($subpath);
6381 exec @cmd or fail "exec curl: $!\n";
6384 sub repos_server_url () {
6385 $package = '_dgit-repos-server';
6386 local $access_forpush = 1;
6387 local $isuite = 'DGIT-REPOS-SERVER';
6388 my $url = access_giturl();
6391 sub cmd_clone_dgit_repos_server {
6392 badusage "need destination argument" unless @ARGV==1;
6393 my ($destdir) = @ARGV;
6394 my $url = repos_server_url();
6395 my @cmd = (@git, qw(clone), $url, $destdir);
6397 exec @cmd or fail "exec git clone: $!\n";
6400 sub cmd_print_dgit_repos_server_source_url {
6401 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6403 my $url = repos_server_url();
6404 print $url, "\n" or die $!;
6407 sub cmd_setup_mergechangelogs {
6408 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6409 local $isuite = 'DGIT-SETUP-TREE';
6410 setup_mergechangelogs(1);
6413 sub cmd_setup_useremail {
6414 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6415 local $isuite = 'DGIT-SETUP-TREE';
6419 sub cmd_setup_gitattributes {
6420 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6421 local $isuite = 'DGIT-SETUP-TREE';
6425 sub cmd_setup_new_tree {
6426 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6427 local $isuite = 'DGIT-SETUP-TREE';
6431 #---------- argument parsing and main program ----------
6434 print "dgit version $our_version\n" or die $!;
6438 our (%valopts_long, %valopts_short);
6439 our (%funcopts_long);
6441 our (@modeopt_cfgs);
6443 sub defvalopt ($$$$) {
6444 my ($long,$short,$val_re,$how) = @_;
6445 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6446 $valopts_long{$long} = $oi;
6447 $valopts_short{$short} = $oi;
6448 # $how subref should:
6449 # do whatever assignemnt or thing it likes with $_[0]
6450 # if the option should not be passed on to remote, @rvalopts=()
6451 # or $how can be a scalar ref, meaning simply assign the value
6454 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6455 defvalopt '--distro', '-d', '.+', \$idistro;
6456 defvalopt '', '-k', '.+', \$keyid;
6457 defvalopt '--existing-package','', '.*', \$existing_package;
6458 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6459 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6460 defvalopt '--package', '-p', $package_re, \$package;
6461 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6463 defvalopt '', '-C', '.+', sub {
6464 ($changesfile) = (@_);
6465 if ($changesfile =~ s#^(.*)/##) {
6466 $buildproductsdir = $1;
6470 defvalopt '--initiator-tempdir','','.*', sub {
6471 ($initiator_tempdir) = (@_);
6472 $initiator_tempdir =~ m#^/# or
6473 badusage "--initiator-tempdir must be used specify an".
6474 " absolute, not relative, directory."
6477 sub defoptmodes ($@) {
6478 my ($varref, $cfgkey, $default, %optmap) = @_;
6480 while (my ($opt,$val) = each %optmap) {
6481 $funcopts_long{$opt} = sub { $$varref = $val; };
6482 $permit{$val} = $val;
6484 push @modeopt_cfgs, {
6487 Default => $default,
6492 defoptmodes \$dodep14tag, qw( dep14tag want
6495 --always-dep14tag always );
6500 if (defined $ENV{'DGIT_SSH'}) {
6501 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6502 } elsif (defined $ENV{'GIT_SSH'}) {
6503 @ssh = ($ENV{'GIT_SSH'});
6511 if (!defined $val) {
6512 badusage "$what needs a value" unless @ARGV;
6514 push @rvalopts, $val;
6516 badusage "bad value \`$val' for $what" unless
6517 $val =~ m/^$oi->{Re}$(?!\n)/s;
6518 my $how = $oi->{How};
6519 if (ref($how) eq 'SCALAR') {
6524 push @ropts, @rvalopts;
6528 last unless $ARGV[0] =~ m/^-/;
6532 if (m/^--dry-run$/) {
6535 } elsif (m/^--damp-run$/) {
6538 } elsif (m/^--no-sign$/) {
6541 } elsif (m/^--help$/) {
6543 } elsif (m/^--version$/) {
6545 } elsif (m/^--new$/) {
6548 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6549 ($om = $opts_opt_map{$1}) &&
6553 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6554 !$opts_opt_cmdonly{$1} &&
6555 ($om = $opts_opt_map{$1})) {
6558 } elsif (m/^--(gbp|dpm)$/s) {
6559 push @ropts, "--quilt=$1";
6561 } elsif (m/^--ignore-dirty$/s) {
6564 } elsif (m/^--no-quilt-fixup$/s) {
6566 $quilt_mode = 'nocheck';
6567 } elsif (m/^--no-rm-on-error$/s) {
6570 } elsif (m/^--no-chase-dsc-distro$/s) {
6572 $chase_dsc_distro = 0;
6573 } elsif (m/^--overwrite$/s) {
6575 $overwrite_version = '';
6576 } elsif (m/^--overwrite=(.+)$/s) {
6578 $overwrite_version = $1;
6579 } elsif (m/^--delayed=(\d+)$/s) {
6582 } elsif (m/^--dgit-view-save=(.+)$/s) {
6584 $split_brain_save = $1;
6585 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6586 } elsif (m/^--(no-)?rm-old-changes$/s) {
6589 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6591 push @deliberatelies, $&;
6592 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6596 } elsif (m/^--force-/) {
6598 "$us: warning: ignoring unknown force option $_\n";
6600 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6601 # undocumented, for testing
6603 $tagformat_want = [ $1, 'command line', 1 ];
6604 # 1 menas overrides distro configuration
6605 } elsif (m/^--always-split-source-build$/s) {
6606 # undocumented, for testing
6608 $need_split_build_invocation = 1;
6609 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6610 # undocumented, for testing
6612 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6613 # ^ it's supposed to be an array ref
6614 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6615 $val = $2 ? $' : undef; #';
6616 $valopt->($oi->{Long});
6617 } elsif ($funcopts_long{$_}) {
6619 $funcopts_long{$_}();
6621 badusage "unknown long option \`$_'";
6628 } elsif (s/^-L/-/) {
6631 } elsif (s/^-h/-/) {
6633 } elsif (s/^-D/-/) {
6637 } elsif (s/^-N/-/) {
6642 push @changesopts, $_;
6644 } elsif (s/^-wn$//s) {
6646 $cleanmode = 'none';
6647 } elsif (s/^-wg$//s) {
6650 } elsif (s/^-wgf$//s) {
6652 $cleanmode = 'git-ff';
6653 } elsif (s/^-wd$//s) {
6655 $cleanmode = 'dpkg-source';
6656 } elsif (s/^-wdd$//s) {
6658 $cleanmode = 'dpkg-source-d';
6659 } elsif (s/^-wc$//s) {
6661 $cleanmode = 'check';
6662 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6663 push @git, '-c', $&;
6664 $gitcfgs{cmdline}{$1} = [ $2 ];
6665 } elsif (s/^-c([^=]+)$//s) {
6666 push @git, '-c', $&;
6667 $gitcfgs{cmdline}{$1} = [ 'true' ];
6668 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6670 $val = undef unless length $val;
6671 $valopt->($oi->{Short});
6674 badusage "unknown short option \`$_'";
6681 sub check_env_sanity () {
6682 my $blocked = new POSIX::SigSet;
6683 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6686 foreach my $name (qw(PIPE CHLD)) {
6687 my $signame = "SIG$name";
6688 my $signum = eval "POSIX::$signame" // die;
6689 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6690 die "$signame is set to something other than SIG_DFL\n";
6691 $blocked->ismember($signum) and
6692 die "$signame is blocked\n";
6698 On entry to dgit, $@
6699 This is a bug produced by something in in your execution environment.
6705 sub parseopts_late_defaults () {
6706 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6707 if defined $idistro;
6708 $isuite //= cfg('dgit.default.default-suite');
6710 foreach my $k (keys %opts_opt_map) {
6711 my $om = $opts_opt_map{$k};
6713 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6715 badcfg "cannot set command for $k"
6716 unless length $om->[0];
6720 foreach my $c (access_cfg_cfgs("opts-$k")) {
6722 map { $_ ? @$_ : () }
6723 map { $gitcfgs{$_}{$c} }
6724 reverse @gitcfgsources;
6725 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6726 "\n" if $debuglevel >= 4;
6728 badcfg "cannot configure options for $k"
6729 if $opts_opt_cmdonly{$k};
6730 my $insertpos = $opts_cfg_insertpos{$k};
6731 @$om = ( @$om[0..$insertpos-1],
6733 @$om[$insertpos..$#$om] );
6737 if (!defined $rmchanges) {
6738 local $access_forpush;
6739 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6742 if (!defined $quilt_mode) {
6743 local $access_forpush;
6744 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6745 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6747 $quilt_mode =~ m/^($quilt_modes_re)$/
6748 or badcfg "unknown quilt-mode \`$quilt_mode'";
6752 foreach my $moc (@modeopt_cfgs) {
6753 local $access_forpush;
6754 my $vr = $moc->{Var};
6755 next if defined $$vr;
6756 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
6757 my $v = $moc->{Vals}{$$vr};
6758 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
6762 $need_split_build_invocation ||= quiltmode_splitbrain();
6764 if (!defined $cleanmode) {
6765 local $access_forpush;
6766 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6767 $cleanmode //= 'dpkg-source';
6769 badcfg "unknown clean-mode \`$cleanmode'" unless
6770 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6774 if ($ENV{$fakeeditorenv}) {
6776 quilt_fixup_editor();
6783 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6784 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6785 if $dryrun_level == 1;
6787 print STDERR $helpmsg or die $!;
6790 my $cmd = shift @ARGV;
6793 my $pre_fn = ${*::}{"pre_$cmd"};
6794 $pre_fn->() if $pre_fn;
6796 my $fn = ${*::}{"cmd_$cmd"};
6797 $fn or badusage "unknown operation $cmd";