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 pre_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;
4577 sub cmd_remote_push_build_host {
4578 responder_send_command("dgit-remote-push-ready $protovsn");
4582 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4583 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4584 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4585 # a good error message)
4587 sub rpush_handle_protovsn_bothends () {
4588 if ($protovsn < 4) {
4589 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4598 my $report = i_child_report();
4599 if (defined $report) {
4600 printdebug "($report)\n";
4601 } elsif ($i_child_pid) {
4602 printdebug "(killing build host child $i_child_pid)\n";
4603 kill 15, $i_child_pid;
4605 if (defined $i_tmp && !defined $initiator_tempdir) {
4607 eval { rmtree $i_tmp; };
4612 return unless forkcheck_mainprocess();
4617 my ($base,$selector,@args) = @_;
4618 $selector =~ s/\-/_/g;
4619 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4625 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4633 push @rargs, join ",", @rpushprotovsn_support;
4636 push @rdgit, @ropts;
4637 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4639 my @cmd = (@ssh, $host, shellquote @rdgit);
4642 $we_are_initiator=1;
4644 if (defined $initiator_tempdir) {
4645 rmtree $initiator_tempdir;
4646 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4647 $i_tmp = $initiator_tempdir;
4651 $i_child_pid = open2(\*RO, \*RI, @cmd);
4653 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4654 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4655 $supplementary_message = '' unless $protovsn >= 3;
4658 my ($icmd,$iargs) = initiator_expect {
4659 m/^(\S+)(?: (.*))?$/;
4662 i_method "i_resp", $icmd, $iargs;
4666 sub i_resp_progress ($) {
4668 my $msg = protocol_read_bytes \*RO, $rhs;
4672 sub i_resp_supplementary_message ($) {
4674 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4677 sub i_resp_complete {
4678 my $pid = $i_child_pid;
4679 $i_child_pid = undef; # prevents killing some other process with same pid
4680 printdebug "waiting for build host child $pid...\n";
4681 my $got = waitpid $pid, 0;
4682 die $! unless $got == $pid;
4683 die "build host child failed $?" if $?;
4686 printdebug "all done\n";
4690 sub i_resp_file ($) {
4692 my $localname = i_method "i_localname", $keyword;
4693 my $localpath = "$i_tmp/$localname";
4694 stat_exists $localpath and
4695 badproto \*RO, "file $keyword ($localpath) twice";
4696 protocol_receive_file \*RO, $localpath;
4697 i_method "i_file", $keyword;
4702 sub i_resp_param ($) {
4703 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4707 sub i_resp_previously ($) {
4708 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4709 or badproto \*RO, "bad previously spec";
4710 my $r = system qw(git check-ref-format), $1;
4711 die "bad previously ref spec ($r)" if $r;
4712 $previously{$1} = $2;
4717 sub i_resp_want ($) {
4719 die "$keyword ?" if $i_wanted{$keyword}++;
4721 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4722 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4723 die unless $isuite =~ m/^$suite_re$/;
4726 rpush_handle_protovsn_bothends();
4728 fail "rpush negotiated protocol version $protovsn".
4729 " which does not support quilt mode $quilt_mode"
4730 if quiltmode_splitbrain;
4732 my @localpaths = i_method "i_want", $keyword;
4733 printdebug "[[ $keyword @localpaths\n";
4734 foreach my $localpath (@localpaths) {
4735 protocol_send_file \*RI, $localpath;
4737 print RI "files-end\n" or die $!;
4740 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4742 sub i_localname_parsed_changelog {
4743 return "remote-changelog.822";
4745 sub i_file_parsed_changelog {
4746 ($i_clogp, $i_version, $i_dscfn) =
4747 push_parse_changelog "$i_tmp/remote-changelog.822";
4748 die if $i_dscfn =~ m#/|^\W#;
4751 sub i_localname_dsc {
4752 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4757 sub i_localname_buildinfo ($) {
4758 my $bi = $i_param{'buildinfo-filename'};
4759 defined $bi or badproto \*RO, "buildinfo before filename";
4760 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4761 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4762 or badproto \*RO, "improper buildinfo filename";
4765 sub i_file_buildinfo {
4766 my $bi = $i_param{'buildinfo-filename'};
4767 my $bd = parsecontrol "$i_tmp/$bi", $bi;
4768 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4769 if (!forceing [qw(buildinfo-changes-mismatch)]) {
4770 files_compare_inputs($bd, $ch);
4771 (getfield $bd, $_) eq (getfield $ch, $_) or
4772 fail "buildinfo mismatch $_"
4773 foreach qw(Source Version);
4774 !defined $bd->{$_} or
4775 fail "buildinfo contains $_"
4776 foreach qw(Changes Changed-by Distribution);
4778 push @i_buildinfos, $bi;
4779 delete $i_param{'buildinfo-filename'};
4782 sub i_localname_changes {
4783 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4784 $i_changesfn = $i_dscfn;
4785 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4786 return $i_changesfn;
4788 sub i_file_changes { }
4790 sub i_want_signed_tag {
4791 printdebug Dumper(\%i_param, $i_dscfn);
4792 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4793 && defined $i_param{'csuite'}
4794 or badproto \*RO, "premature desire for signed-tag";
4795 my $head = $i_param{'head'};
4796 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4798 my $maintview = $i_param{'maint-view'};
4799 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4802 if ($protovsn >= 4) {
4803 my $p = $i_param{'tagformat'} // '<undef>';
4805 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4808 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4810 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4812 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4815 push_mktags $i_clogp, $i_dscfn,
4816 $i_changesfn, 'remote changes',
4820 sub i_want_signed_dsc_changes {
4821 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4822 sign_changes $i_changesfn;
4823 return ($i_dscfn, $i_changesfn, @i_buildinfos);
4826 #---------- building etc. ----------
4832 #----- `3.0 (quilt)' handling -----
4834 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4836 sub quiltify_dpkg_commit ($$$;$) {
4837 my ($patchname,$author,$msg, $xinfo) = @_;
4841 my $descfn = ".git/dgit/quilt-description.tmp";
4842 open O, '>', $descfn or die "$descfn: $!";
4843 $msg =~ s/\n+/\n\n/;
4844 print O <<END or die $!;
4846 ${xinfo}Subject: $msg
4853 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4854 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4855 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4856 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4860 sub quiltify_trees_differ ($$;$$$) {
4861 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4862 # returns true iff the two tree objects differ other than in debian/
4863 # with $finegrained,
4864 # returns bitmask 01 - differ in upstream files except .gitignore
4865 # 02 - differ in .gitignore
4866 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4867 # is set for each modified .gitignore filename $fn
4868 # if $unrepres is defined, array ref to which is appeneded
4869 # a list of unrepresentable changes (removals of upstream files
4872 my @cmd = (@git, qw(diff-tree -z));
4873 push @cmd, qw(--name-only) unless $unrepres;
4874 push @cmd, qw(-r) if $finegrained || $unrepres;
4876 my $diffs= cmdoutput @cmd;
4879 foreach my $f (split /\0/, $diffs) {
4880 if ($unrepres && !@lmodes) {
4881 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4884 my ($oldmode,$newmode) = @lmodes;
4887 next if $f =~ m#^debian(?:/.*)?$#s;
4891 die "not a plain file\n"
4892 unless $newmode =~ m/^10\d{4}$/ ||
4893 $oldmode =~ m/^10\d{4}$/;
4894 if ($oldmode =~ m/[^0]/ &&
4895 $newmode =~ m/[^0]/) {
4896 die "mode changed\n" if $oldmode ne $newmode;
4898 die "non-default mode\n"
4899 unless $newmode =~ m/^100644$/ ||
4900 $oldmode =~ m/^100644$/;
4904 local $/="\n"; chomp $@;
4905 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4909 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4910 $r |= $isignore ? 02 : 01;
4911 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4913 printdebug "quiltify_trees_differ $x $y => $r\n";
4917 sub quiltify_tree_sentinelfiles ($) {
4918 # lists the `sentinel' files present in the tree
4920 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4921 qw(-- debian/rules debian/control);
4926 sub quiltify_splitbrain_needed () {
4927 if (!$split_brain) {
4928 progress "dgit view: changes are required...";
4929 runcmd @git, qw(checkout -q -b dgit-view);
4934 sub quiltify_splitbrain ($$$$$$) {
4935 my ($clogp, $unapplied, $headref, $diffbits,
4936 $editedignores, $cachekey) = @_;
4937 if ($quilt_mode !~ m/gbp|dpm/) {
4938 # treat .gitignore just like any other upstream file
4939 $diffbits = { %$diffbits };
4940 $_ = !!$_ foreach values %$diffbits;
4942 # We would like any commits we generate to be reproducible
4943 my @authline = clogp_authline($clogp);
4944 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4945 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4946 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4947 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4948 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4949 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4951 if ($quilt_mode =~ m/gbp|unapplied/ &&
4952 ($diffbits->{O2H} & 01)) {
4954 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4955 " but git tree differs from orig in upstream files.";
4956 if (!stat_exists "debian/patches") {
4958 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4962 if ($quilt_mode =~ m/dpm/ &&
4963 ($diffbits->{H2A} & 01)) {
4965 --quilt=$quilt_mode specified, implying patches-applied git tree
4966 but git tree differs from result of applying debian/patches to upstream
4969 if ($quilt_mode =~ m/gbp|unapplied/ &&
4970 ($diffbits->{O2A} & 01)) { # some patches
4971 quiltify_splitbrain_needed();
4972 progress "dgit view: creating patches-applied version using gbp pq";
4973 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4974 # gbp pq import creates a fresh branch; push back to dgit-view
4975 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4976 runcmd @git, qw(checkout -q dgit-view);
4978 if ($quilt_mode =~ m/gbp|dpm/ &&
4979 ($diffbits->{O2A} & 02)) {
4981 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4982 tool which does not create patches for changes to upstream
4983 .gitignores: but, such patches exist in debian/patches.
4986 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4987 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4988 quiltify_splitbrain_needed();
4989 progress "dgit view: creating patch to represent .gitignore changes";
4990 ensuredir "debian/patches";
4991 my $gipatch = "debian/patches/auto-gitignore";
4992 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4993 stat GIPATCH or die "$gipatch: $!";
4994 fail "$gipatch already exists; but want to create it".
4995 " to record .gitignore changes" if (stat _)[7];
4996 print GIPATCH <<END or die "$gipatch: $!";
4997 Subject: Update .gitignore from Debian packaging branch
4999 The Debian packaging git branch contains these updates to the upstream
5000 .gitignore file(s). This patch is autogenerated, to provide these
5001 updates to users of the official Debian archive view of the package.
5003 [dgit ($our_version) update-gitignore]
5006 close GIPATCH or die "$gipatch: $!";
5007 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
5008 $unapplied, $headref, "--", sort keys %$editedignores;
5009 open SERIES, "+>>", "debian/patches/series" or die $!;
5010 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
5012 defined read SERIES, $newline, 1 or die $!;
5013 print SERIES "\n" or die $! unless $newline eq "\n";
5014 print SERIES "auto-gitignore\n" or die $!;
5015 close SERIES or die $!;
5016 runcmd @git, qw(add -- debian/patches/series), $gipatch;
5018 Commit patch to update .gitignore
5020 [dgit ($our_version) update-gitignore-quilt-fixup]
5024 my $dgitview = git_rev_parse 'HEAD';
5026 changedir '../../../..';
5027 # When we no longer need to support squeeze, use --create-reflog
5029 ensuredir ".git/logs/refs/dgit-intern";
5030 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
5033 my $oldcache = git_get_ref "refs/$splitbraincache";
5034 if ($oldcache eq $dgitview) {
5035 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5036 # git update-ref doesn't always update, in this case. *sigh*
5037 my $dummy = make_commit_text <<END;
5040 author Dgit <dgit\@example.com> 1000000000 +0000
5041 committer Dgit <dgit\@example.com> 1000000000 +0000
5043 Dummy commit - do not use
5045 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5046 "refs/$splitbraincache", $dummy;
5048 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5051 changedir '.git/dgit/unpack/work';
5053 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5054 progress "dgit view: created ($saved)";
5057 sub quiltify ($$$$) {
5058 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5060 # Quilt patchification algorithm
5062 # We search backwards through the history of the main tree's HEAD
5063 # (T) looking for a start commit S whose tree object is identical
5064 # to to the patch tip tree (ie the tree corresponding to the
5065 # current dpkg-committed patch series). For these purposes
5066 # `identical' disregards anything in debian/ - this wrinkle is
5067 # necessary because dpkg-source treates debian/ specially.
5069 # We can only traverse edges where at most one of the ancestors'
5070 # trees differs (in changes outside in debian/). And we cannot
5071 # handle edges which change .pc/ or debian/patches. To avoid
5072 # going down a rathole we avoid traversing edges which introduce
5073 # debian/rules or debian/control. And we set a limit on the
5074 # number of edges we are willing to look at.
5076 # If we succeed, we walk forwards again. For each traversed edge
5077 # PC (with P parent, C child) (starting with P=S and ending with
5078 # C=T) to we do this:
5080 # - dpkg-source --commit with a patch name and message derived from C
5081 # After traversing PT, we git commit the changes which
5082 # should be contained within debian/patches.
5084 # The search for the path S..T is breadth-first. We maintain a
5085 # todo list containing search nodes. A search node identifies a
5086 # commit, and looks something like this:
5088 # Commit => $git_commit_id,
5089 # Child => $c, # or undef if P=T
5090 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5091 # Nontrivial => true iff $p..$c has relevant changes
5098 my %considered; # saves being exponential on some weird graphs
5100 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5103 my ($search,$whynot) = @_;
5104 printdebug " search NOT $search->{Commit} $whynot\n";
5105 $search->{Whynot} = $whynot;
5106 push @nots, $search;
5107 no warnings qw(exiting);
5116 my $c = shift @todo;
5117 next if $considered{$c->{Commit}}++;
5119 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5121 printdebug "quiltify investigate $c->{Commit}\n";
5124 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5125 printdebug " search finished hooray!\n";
5130 if ($quilt_mode eq 'nofix') {
5131 fail "quilt fixup required but quilt mode is \`nofix'\n".
5132 "HEAD commit $c->{Commit} differs from tree implied by ".
5133 " debian/patches (tree object $oldtiptree)";
5135 if ($quilt_mode eq 'smash') {
5136 printdebug " search quitting smash\n";
5140 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5141 $not->($c, "has $c_sentinels not $t_sentinels")
5142 if $c_sentinels ne $t_sentinels;
5144 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5145 $commitdata =~ m/\n\n/;
5147 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5148 @parents = map { { Commit => $_, Child => $c } } @parents;
5150 $not->($c, "root commit") if !@parents;
5152 foreach my $p (@parents) {
5153 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5155 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5156 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5158 foreach my $p (@parents) {
5159 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5161 my @cmd= (@git, qw(diff-tree -r --name-only),
5162 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5163 my $patchstackchange = cmdoutput @cmd;
5164 if (length $patchstackchange) {
5165 $patchstackchange =~ s/\n/,/g;
5166 $not->($p, "changed $patchstackchange");
5169 printdebug " search queue P=$p->{Commit} ",
5170 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5176 printdebug "quiltify want to smash\n";
5179 my $x = $_[0]{Commit};
5180 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5183 my $reportnot = sub {
5185 my $s = $abbrev->($notp);
5186 my $c = $notp->{Child};
5187 $s .= "..".$abbrev->($c) if $c;
5188 $s .= ": ".$notp->{Whynot};
5191 if ($quilt_mode eq 'linear') {
5192 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
5193 foreach my $notp (@nots) {
5194 print STDERR "$us: ", $reportnot->($notp), "\n";
5196 print STDERR "$us: $_\n" foreach @$failsuggestion;
5197 fail "quilt fixup naive history linearisation failed.\n".
5198 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5199 } elsif ($quilt_mode eq 'smash') {
5200 } elsif ($quilt_mode eq 'auto') {
5201 progress "quilt fixup cannot be linear, smashing...";
5203 die "$quilt_mode ?";
5206 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5207 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5209 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5211 quiltify_dpkg_commit "auto-$version-$target-$time",
5212 (getfield $clogp, 'Maintainer'),
5213 "Automatically generated patch ($clogp->{Version})\n".
5214 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5218 progress "quiltify linearisation planning successful, executing...";
5220 for (my $p = $sref_S;
5221 my $c = $p->{Child};
5223 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5224 next unless $p->{Nontrivial};
5226 my $cc = $c->{Commit};
5228 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5229 $commitdata =~ m/\n\n/ or die "$c ?";
5232 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5235 my $commitdate = cmdoutput
5236 @git, qw(log -n1 --pretty=format:%aD), $cc;
5238 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5240 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5247 my $gbp_check_suitable = sub {
5252 die "contains unexpected slashes\n" if m{//} || m{/$};
5253 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5254 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5255 die "too long" if length > 200;
5257 return $_ unless $@;
5258 print STDERR "quiltifying commit $cc:".
5259 " ignoring/dropping Gbp-Pq $what: $@";
5263 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5265 (\S+) \s* \n //ixm) {
5266 $patchname = $gbp_check_suitable->($1, 'Name');
5268 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5270 (\S+) \s* \n //ixm) {
5271 $patchdir = $gbp_check_suitable->($1, 'Topic');
5276 if (!defined $patchname) {
5277 $patchname = $title;
5278 $patchname =~ s/[.:]$//;
5281 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5282 my $translitname = $converter->convert($patchname);
5283 die unless defined $translitname;
5284 $patchname = $translitname;
5287 "dgit: patch title transliteration error: $@"
5289 $patchname =~ y/ A-Z/-a-z/;
5290 $patchname =~ y/-a-z0-9_.+=~//cd;
5291 $patchname =~ s/^\W/x-$&/;
5292 $patchname = substr($patchname,0,40);
5294 if (!defined $patchdir) {
5297 if (length $patchdir) {
5298 $patchname = "$patchdir/$patchname";
5300 if ($patchname =~ m{^(.*)/}) {
5301 mkpath "debian/patches/$1";
5306 stat "debian/patches/$patchname$index";
5308 $!==ENOENT or die "$patchname$index $!";
5310 runcmd @git, qw(checkout -q), $cc;
5312 # We use the tip's changelog so that dpkg-source doesn't
5313 # produce complaining messages from dpkg-parsechangelog. None
5314 # of the information dpkg-source gets from the changelog is
5315 # actually relevant - it gets put into the original message
5316 # which dpkg-source provides our stunt editor, and then
5318 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5320 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5321 "Date: $commitdate\n".
5322 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5324 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5327 runcmd @git, qw(checkout -q master);
5330 sub build_maybe_quilt_fixup () {
5331 my ($format,$fopts) = get_source_format;
5332 return unless madformat_wantfixup $format;
5335 check_for_vendor_patches();
5337 if (quiltmode_splitbrain) {
5338 fail <<END unless access_cfg_tagformats_can_splitbrain;
5339 quilt mode $quilt_mode requires split view so server needs to support
5340 both "new" and "maint" tag formats, but config says it doesn't.
5344 my $clogp = parsechangelog();
5345 my $headref = git_rev_parse('HEAD');
5350 my $upstreamversion = upstreamversion $version;
5352 if ($fopts->{'single-debian-patch'}) {
5353 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5355 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5358 die 'bug' if $split_brain && !$need_split_build_invocation;
5360 changedir '../../../..';
5361 runcmd_ordryrun_local
5362 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5365 sub quilt_fixup_mkwork ($) {
5368 mkdir "work" or die $!;
5370 mktree_in_ud_here();
5371 runcmd @git, qw(reset -q --hard), $headref;
5374 sub quilt_fixup_linkorigs ($$) {
5375 my ($upstreamversion, $fn) = @_;
5376 # calls $fn->($leafname);
5378 foreach my $f (<../../../../*>) { #/){
5379 my $b=$f; $b =~ s{.*/}{};
5381 local ($debuglevel) = $debuglevel-1;
5382 printdebug "QF linkorigs $b, $f ?\n";
5384 next unless is_orig_file_of_vsn $b, $upstreamversion;
5385 printdebug "QF linkorigs $b, $f Y\n";
5386 link_ltarget $f, $b or die "$b $!";
5391 sub quilt_fixup_delete_pc () {
5392 runcmd @git, qw(rm -rqf .pc);
5394 Commit removal of .pc (quilt series tracking data)
5396 [dgit ($our_version) upgrade quilt-remove-pc]
5400 sub quilt_fixup_singlepatch ($$$) {
5401 my ($clogp, $headref, $upstreamversion) = @_;
5403 progress "starting quiltify (single-debian-patch)";
5405 # dpkg-source --commit generates new patches even if
5406 # single-debian-patch is in debian/source/options. In order to
5407 # get it to generate debian/patches/debian-changes, it is
5408 # necessary to build the source package.
5410 quilt_fixup_linkorigs($upstreamversion, sub { });
5411 quilt_fixup_mkwork($headref);
5413 rmtree("debian/patches");
5415 runcmd @dpkgsource, qw(-b .);
5417 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5418 rename srcfn("$upstreamversion", "/debian/patches"),
5419 "work/debian/patches";
5422 commit_quilty_patch();
5425 sub quilt_make_fake_dsc ($) {
5426 my ($upstreamversion) = @_;
5428 my $fakeversion="$upstreamversion-~~DGITFAKE";
5430 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5431 print $fakedsc <<END or die $!;
5434 Version: $fakeversion
5438 my $dscaddfile=sub {
5441 my $md = new Digest::MD5;
5443 my $fh = new IO::File $b, '<' or die "$b $!";
5448 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5451 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5453 my @files=qw(debian/source/format debian/rules
5454 debian/control debian/changelog);
5455 foreach my $maybe (qw(debian/patches debian/source/options
5456 debian/tests/control)) {
5457 next unless stat_exists "../../../$maybe";
5458 push @files, $maybe;
5461 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5462 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5464 $dscaddfile->($debtar);
5465 close $fakedsc or die $!;
5468 sub quilt_check_splitbrain_cache ($$) {
5469 my ($headref, $upstreamversion) = @_;
5470 # Called only if we are in (potentially) split brain mode.
5472 # Computes the cache key and looks in the cache.
5473 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5475 my $splitbrain_cachekey;
5478 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5479 # we look in the reflog of dgit-intern/quilt-cache
5480 # we look for an entry whose message is the key for the cache lookup
5481 my @cachekey = (qw(dgit), $our_version);
5482 push @cachekey, $upstreamversion;
5483 push @cachekey, $quilt_mode;
5484 push @cachekey, $headref;
5486 push @cachekey, hashfile('fake.dsc');
5488 my $srcshash = Digest::SHA->new(256);
5489 my %sfs = ( %INC, '$0(dgit)' => $0 );
5490 foreach my $sfk (sort keys %sfs) {
5491 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5492 $srcshash->add($sfk," ");
5493 $srcshash->add(hashfile($sfs{$sfk}));
5494 $srcshash->add("\n");
5496 push @cachekey, $srcshash->hexdigest();
5497 $splitbrain_cachekey = "@cachekey";
5499 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5501 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5502 debugcmd "|(probably)",@cmd;
5503 my $child = open GC, "-|"; defined $child or die $!;
5505 chdir '../../..' or die $!;
5506 if (!stat ".git/logs/refs/$splitbraincache") {
5507 $! == ENOENT or die $!;
5508 printdebug ">(no reflog)\n";
5515 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5516 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5519 quilt_fixup_mkwork($headref);
5520 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5521 if ($cachehit ne $headref) {
5522 progress "dgit view: found cached ($saved)";
5523 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5525 return ($cachehit, $splitbrain_cachekey);
5527 progress "dgit view: found cached, no changes required";
5528 return ($headref, $splitbrain_cachekey);
5530 die $! if GC->error;
5531 failedcmd unless close GC;
5533 printdebug "splitbrain cache miss\n";
5534 return (undef, $splitbrain_cachekey);
5537 sub quilt_fixup_multipatch ($$$) {
5538 my ($clogp, $headref, $upstreamversion) = @_;
5540 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5543 # - honour any existing .pc in case it has any strangeness
5544 # - determine the git commit corresponding to the tip of
5545 # the patch stack (if there is one)
5546 # - if there is such a git commit, convert each subsequent
5547 # git commit into a quilt patch with dpkg-source --commit
5548 # - otherwise convert all the differences in the tree into
5549 # a single git commit
5553 # Our git tree doesn't necessarily contain .pc. (Some versions of
5554 # dgit would include the .pc in the git tree.) If there isn't
5555 # one, we need to generate one by unpacking the patches that we
5558 # We first look for a .pc in the git tree. If there is one, we
5559 # will use it. (This is not the normal case.)
5561 # Otherwise need to regenerate .pc so that dpkg-source --commit
5562 # can work. We do this as follows:
5563 # 1. Collect all relevant .orig from parent directory
5564 # 2. Generate a debian.tar.gz out of
5565 # debian/{patches,rules,source/format,source/options}
5566 # 3. Generate a fake .dsc containing just these fields:
5567 # Format Source Version Files
5568 # 4. Extract the fake .dsc
5569 # Now the fake .dsc has a .pc directory.
5570 # (In fact we do this in every case, because in future we will
5571 # want to search for a good base commit for generating patches.)
5573 # Then we can actually do the dpkg-source --commit
5574 # 1. Make a new working tree with the same object
5575 # store as our main tree and check out the main
5577 # 2. Copy .pc from the fake's extraction, if necessary
5578 # 3. Run dpkg-source --commit
5579 # 4. If the result has changes to debian/, then
5580 # - git add them them
5581 # - git add .pc if we had a .pc in-tree
5583 # 5. If we had a .pc in-tree, delete it, and git commit
5584 # 6. Back in the main tree, fast forward to the new HEAD
5586 # Another situation we may have to cope with is gbp-style
5587 # patches-unapplied trees.
5589 # We would want to detect these, so we know to escape into
5590 # quilt_fixup_gbp. However, this is in general not possible.
5591 # Consider a package with a one patch which the dgit user reverts
5592 # (with git revert or the moral equivalent).
5594 # That is indistinguishable in contents from a patches-unapplied
5595 # tree. And looking at the history to distinguish them is not
5596 # useful because the user might have made a confusing-looking git
5597 # history structure (which ought to produce an error if dgit can't
5598 # cope, not a silent reintroduction of an unwanted patch).
5600 # So gbp users will have to pass an option. But we can usually
5601 # detect their failure to do so: if the tree is not a clean
5602 # patches-applied tree, quilt linearisation fails, but the tree
5603 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5604 # they want --quilt=unapplied.
5606 # To help detect this, when we are extracting the fake dsc, we
5607 # first extract it with --skip-patches, and then apply the patches
5608 # afterwards with dpkg-source --before-build. That lets us save a
5609 # tree object corresponding to .origs.
5611 my $splitbrain_cachekey;
5613 quilt_make_fake_dsc($upstreamversion);
5615 if (quiltmode_splitbrain()) {
5617 ($cachehit, $splitbrain_cachekey) =
5618 quilt_check_splitbrain_cache($headref, $upstreamversion);
5619 return if $cachehit;
5623 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5625 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5626 rename $fakexdir, "fake" or die "$fakexdir $!";
5630 remove_stray_gits("source package");
5631 mktree_in_ud_here();
5635 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5636 my $unapplied=git_add_write_tree();
5637 printdebug "fake orig tree object $unapplied\n";
5641 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5643 if (system @bbcmd) {
5644 failedcmd @bbcmd if $? < 0;
5646 failed to apply your git tree's patch stack (from debian/patches/) to
5647 the corresponding upstream tarball(s). Your source tree and .orig
5648 are probably too inconsistent. dgit can only fix up certain kinds of
5649 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5655 quilt_fixup_mkwork($headref);
5658 if (stat_exists ".pc") {
5660 progress "Tree already contains .pc - will use it then delete it.";
5663 rename '../fake/.pc','.pc' or die $!;
5666 changedir '../fake';
5668 my $oldtiptree=git_add_write_tree();
5669 printdebug "fake o+d/p tree object $unapplied\n";
5670 changedir '../work';
5673 # We calculate some guesswork now about what kind of tree this might
5674 # be. This is mostly for error reporting.
5680 # O = orig, without patches applied
5681 # A = "applied", ie orig with H's debian/patches applied
5682 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5683 \%editedignores, \@unrepres),
5684 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5685 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5689 foreach my $b (qw(01 02)) {
5690 foreach my $v (qw(O2H O2A H2A)) {
5691 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5694 printdebug "differences \@dl @dl.\n";
5697 "$us: base trees orig=%.20s o+d/p=%.20s",
5698 $unapplied, $oldtiptree;
5700 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5701 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5702 $dl[0], $dl[1], $dl[3], $dl[4],
5706 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5708 forceable_fail [qw(unrepresentable)], <<END;
5709 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5714 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5715 push @failsuggestion, "This might be a patches-unapplied branch.";
5716 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5717 push @failsuggestion, "This might be a patches-applied branch.";
5719 push @failsuggestion, "Maybe you need to specify one of".
5720 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5722 if (quiltmode_splitbrain()) {
5723 quiltify_splitbrain($clogp, $unapplied, $headref,
5724 $diffbits, \%editedignores,
5725 $splitbrain_cachekey);
5729 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5730 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5732 if (!open P, '>>', ".pc/applied-patches") {
5733 $!==&ENOENT or die $!;
5738 commit_quilty_patch();
5740 if ($mustdeletepc) {
5741 quilt_fixup_delete_pc();
5745 sub quilt_fixup_editor () {
5746 my $descfn = $ENV{$fakeeditorenv};
5747 my $editing = $ARGV[$#ARGV];
5748 open I1, '<', $descfn or die "$descfn: $!";
5749 open I2, '<', $editing or die "$editing: $!";
5750 unlink $editing or die "$editing: $!";
5751 open O, '>', $editing or die "$editing: $!";
5752 while (<I1>) { print O or die $!; } I1->error and die $!;
5755 $copying ||= m/^\-\-\- /;
5756 next unless $copying;
5759 I2->error and die $!;
5764 sub maybe_apply_patches_dirtily () {
5765 return unless $quilt_mode =~ m/gbp|unapplied/;
5766 print STDERR <<END or die $!;
5768 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5769 dgit: Have to apply the patches - making the tree dirty.
5770 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5773 $patches_applied_dirtily = 01;
5774 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5775 runcmd qw(dpkg-source --before-build .);
5778 sub maybe_unapply_patches_again () {
5779 progress "dgit: Unapplying patches again to tidy up the tree."
5780 if $patches_applied_dirtily;
5781 runcmd qw(dpkg-source --after-build .)
5782 if $patches_applied_dirtily & 01;
5784 if $patches_applied_dirtily & 02;
5785 $patches_applied_dirtily = 0;
5788 #----- other building -----
5790 our $clean_using_builder;
5791 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5792 # clean the tree before building (perhaps invoked indirectly by
5793 # whatever we are using to run the build), rather than separately
5794 # and explicitly by us.
5797 return if $clean_using_builder;
5798 if ($cleanmode eq 'dpkg-source') {
5799 maybe_apply_patches_dirtily();
5800 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5801 } elsif ($cleanmode eq 'dpkg-source-d') {
5802 maybe_apply_patches_dirtily();
5803 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5804 } elsif ($cleanmode eq 'git') {
5805 runcmd_ordryrun_local @git, qw(clean -xdf);
5806 } elsif ($cleanmode eq 'git-ff') {
5807 runcmd_ordryrun_local @git, qw(clean -xdff);
5808 } elsif ($cleanmode eq 'check') {
5809 my $leftovers = cmdoutput @git, qw(clean -xdn);
5810 if (length $leftovers) {
5811 print STDERR $leftovers, "\n" or die $!;
5812 fail "tree contains uncommitted files and --clean=check specified";
5814 } elsif ($cleanmode eq 'none') {
5821 badusage "clean takes no additional arguments" if @ARGV;
5824 maybe_unapply_patches_again();
5827 sub build_prep_early () {
5828 our $build_prep_early_done //= 0;
5829 return if $build_prep_early_done++;
5830 badusage "-p is not allowed when building" if defined $package;
5831 my $clogp = parsechangelog();
5832 $isuite = getfield $clogp, 'Distribution';
5833 $package = getfield $clogp, 'Source';
5834 $version = getfield $clogp, 'Version';
5842 build_maybe_quilt_fixup();
5844 my $pat = changespat $version;
5845 foreach my $f (glob "$buildproductsdir/$pat") {
5847 unlink $f or fail "remove old changes file $f: $!";
5849 progress "would remove $f";
5855 sub changesopts_initial () {
5856 my @opts =@changesopts[1..$#changesopts];
5859 sub changesopts_version () {
5860 if (!defined $changes_since_version) {
5861 my @vsns = archive_query('archive_query');
5862 my @quirk = access_quirk();
5863 if ($quirk[0] eq 'backports') {
5864 local $isuite = $quirk[2];
5866 canonicalise_suite();
5867 push @vsns, archive_query('archive_query');
5870 @vsns = map { $_->[0] } @vsns;
5871 @vsns = sort { -version_compare($a, $b) } @vsns;
5872 $changes_since_version = $vsns[0];
5873 progress "changelog will contain changes since $vsns[0]";
5875 $changes_since_version = '_';
5876 progress "package seems new, not specifying -v<version>";
5879 if ($changes_since_version ne '_') {
5880 return ("-v$changes_since_version");
5886 sub changesopts () {
5887 return (changesopts_initial(), changesopts_version());
5890 sub massage_dbp_args ($;$) {
5891 my ($cmd,$xargs) = @_;
5894 # - if we're going to split the source build out so we can
5895 # do strange things to it, massage the arguments to dpkg-buildpackage
5896 # so that the main build doessn't build source (or add an argument
5897 # to stop it building source by default).
5899 # - add -nc to stop dpkg-source cleaning the source tree,
5900 # unless we're not doing a split build and want dpkg-source
5901 # as cleanmode, in which case we can do nothing
5904 # 0 - source will NOT need to be built separately by caller
5905 # +1 - source will need to be built separately by caller
5906 # +2 - source will need to be built separately by caller AND
5907 # dpkg-buildpackage should not in fact be run at all!
5908 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5909 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5910 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5911 $clean_using_builder = 1;
5914 # -nc has the side effect of specifying -b if nothing else specified
5915 # and some combinations of -S, -b, et al, are errors, rather than
5916 # later simply overriding earlie. So we need to:
5917 # - search the command line for these options
5918 # - pick the last one
5919 # - perhaps add our own as a default
5920 # - perhaps adjust it to the corresponding non-source-building version
5922 foreach my $l ($cmd, $xargs) {
5924 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5927 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5929 if ($need_split_build_invocation) {
5930 printdebug "massage split $dmode.\n";
5931 $r = $dmode =~ m/[S]/ ? +2 :
5932 $dmode =~ y/gGF/ABb/ ? +1 :
5933 $dmode =~ m/[ABb]/ ? 0 :
5936 printdebug "massage done $r $dmode.\n";
5938 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5944 my $wasdir = must_getcwd();
5950 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5951 my ($msg_if_onlyone) = @_;
5952 # If there is only one .changes file, fail with $msg_if_onlyone,
5953 # or if that is undef, be a no-op.
5954 # Returns the changes file to report to the user.
5955 my $pat = changespat $version;
5956 my @changesfiles = glob $pat;
5957 @changesfiles = sort {
5958 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5962 if (@changesfiles==1) {
5963 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5964 only one changes file from build (@changesfiles)
5966 $result = $changesfiles[0];
5967 } elsif (@changesfiles==2) {
5968 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5969 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5970 fail "$l found in binaries changes file $binchanges"
5973 runcmd_ordryrun_local @mergechanges, @changesfiles;
5974 my $multichanges = changespat $version,'multi';
5976 stat_exists $multichanges or fail "$multichanges: $!";
5977 foreach my $cf (glob $pat) {
5978 next if $cf eq $multichanges;
5979 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5982 $result = $multichanges;
5984 fail "wrong number of different changes files (@changesfiles)";
5986 printdone "build successful, results in $result\n" or die $!;
5989 sub midbuild_checkchanges () {
5990 my $pat = changespat $version;
5991 return if $rmchanges;
5992 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5993 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5995 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5996 Suggest you delete @unwanted.
6001 sub midbuild_checkchanges_vanilla ($) {
6003 midbuild_checkchanges() if $wantsrc == 1;
6006 sub postbuild_mergechanges_vanilla ($) {
6008 if ($wantsrc == 1) {
6010 postbuild_mergechanges(undef);
6013 printdone "build successful\n";
6019 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6020 my $wantsrc = massage_dbp_args \@dbp;
6023 midbuild_checkchanges_vanilla $wantsrc;
6028 push @dbp, changesopts_version();
6029 maybe_apply_patches_dirtily();
6030 runcmd_ordryrun_local @dbp;
6032 maybe_unapply_patches_again();
6033 postbuild_mergechanges_vanilla $wantsrc;
6037 $quilt_mode //= 'gbp';
6043 # gbp can make .origs out of thin air. In my tests it does this
6044 # even for a 1.0 format package, with no origs present. So I
6045 # guess it keys off just the version number. We don't know
6046 # exactly what .origs ought to exist, but let's assume that we
6047 # should run gbp if: the version has an upstream part and the main
6049 my $upstreamversion = upstreamversion $version;
6050 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6051 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6053 if ($gbp_make_orig) {
6055 $cleanmode = 'none'; # don't do it again
6056 $need_split_build_invocation = 1;
6059 my @dbp = @dpkgbuildpackage;
6061 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6063 if (!length $gbp_build[0]) {
6064 if (length executable_on_path('git-buildpackage')) {
6065 $gbp_build[0] = qw(git-buildpackage);
6067 $gbp_build[0] = 'gbp buildpackage';
6070 my @cmd = opts_opt_multi_cmd @gbp_build;
6072 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
6074 if ($gbp_make_orig) {
6075 ensuredir '.git/dgit';
6076 my $ok = '.git/dgit/origs-gen-ok';
6077 unlink $ok or $!==&ENOENT or die $!;
6078 my @origs_cmd = @cmd;
6079 push @origs_cmd, qw(--git-cleaner=true);
6080 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
6081 push @origs_cmd, @ARGV;
6083 debugcmd @origs_cmd;
6085 do { local $!; stat_exists $ok; }
6086 or failedcmd @origs_cmd;
6088 dryrun_report @origs_cmd;
6094 midbuild_checkchanges_vanilla $wantsrc;
6096 if (!$clean_using_builder) {
6097 push @cmd, '--git-cleaner=true';
6101 maybe_unapply_patches_again();
6103 push @cmd, changesopts();
6104 runcmd_ordryrun_local @cmd, @ARGV;
6106 postbuild_mergechanges_vanilla $wantsrc;
6108 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6112 my $our_cleanmode = $cleanmode;
6113 if ($need_split_build_invocation) {
6114 # Pretend that clean is being done some other way. This
6115 # forces us not to try to use dpkg-buildpackage to clean and
6116 # build source all in one go; and instead we run dpkg-source
6117 # (and build_prep() will do the clean since $clean_using_builder
6119 $our_cleanmode = 'ELSEWHERE';
6121 if ($our_cleanmode =~ m/^dpkg-source/) {
6122 # dpkg-source invocation (below) will clean, so build_prep shouldn't
6123 $clean_using_builder = 1;
6126 $sourcechanges = changespat $version,'source';
6128 unlink "../$sourcechanges" or $!==ENOENT
6129 or fail "remove $sourcechanges: $!";
6131 $dscfn = dscfn($version);
6132 if ($our_cleanmode eq 'dpkg-source') {
6133 maybe_apply_patches_dirtily();
6134 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
6136 } elsif ($our_cleanmode eq 'dpkg-source-d') {
6137 maybe_apply_patches_dirtily();
6138 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
6141 my @cmd = (@dpkgsource, qw(-b --));
6144 runcmd_ordryrun_local @cmd, "work";
6145 my @udfiles = <${package}_*>;
6146 changedir "../../..";
6147 foreach my $f (@udfiles) {
6148 printdebug "source copy, found $f\n";
6151 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6152 $f eq srcfn($version, $&));
6153 printdebug "source copy, found $f - renaming\n";
6154 rename "$ud/$f", "../$f" or $!==ENOENT
6155 or fail "put in place new source file ($f): $!";
6158 my $pwd = must_getcwd();
6159 my $leafdir = basename $pwd;
6161 runcmd_ordryrun_local @cmd, $leafdir;
6164 runcmd_ordryrun_local qw(sh -ec),
6165 'exec >$1; shift; exec "$@"','x',
6166 "../$sourcechanges",
6167 @dpkggenchanges, qw(-S), changesopts();
6171 sub cmd_build_source {
6173 badusage "build-source takes no additional arguments" if @ARGV;
6175 maybe_unapply_patches_again();
6176 printdone "source built, results in $dscfn and $sourcechanges";
6181 midbuild_checkchanges();
6184 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6185 stat_exists $sourcechanges
6186 or fail "$sourcechanges (in parent directory): $!";
6188 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6190 maybe_unapply_patches_again();
6192 postbuild_mergechanges(<<END);
6193 perhaps you need to pass -A ? (sbuild's default is to build only
6194 arch-specific binaries; dgit 1.4 used to override that.)
6199 sub cmd_quilt_fixup {
6200 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6203 build_maybe_quilt_fixup();
6206 sub import_dsc_result {
6207 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6208 my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
6210 check_gitattrs($newhash, "source tree");
6212 progress "dgit: import-dsc: $what_msg";
6215 sub cmd_import_dsc {
6219 last unless $ARGV[0] =~ m/^-/;
6222 if (m/^--require-valid-signature$/) {
6225 badusage "unknown dgit import-dsc sub-option \`$_'";
6229 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6230 my ($dscfn, $dstbranch) = @ARGV;
6232 badusage "dry run makes no sense with import-dsc" unless act_local();
6234 my $force = $dstbranch =~ s/^\+// ? +1 :
6235 $dstbranch =~ s/^\.\.// ? -1 :
6237 my $info = $force ? " $&" : '';
6238 $info = "$dscfn$info";
6240 my $specbranch = $dstbranch;
6241 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6242 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6244 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6245 my $chead = cmdoutput_errok @symcmd;
6246 defined $chead or $?==256 or failedcmd @symcmd;
6248 fail "$dstbranch is checked out - will not update it"
6249 if defined $chead and $chead eq $dstbranch;
6251 my $oldhash = git_get_ref $dstbranch;
6253 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6254 $dscdata = do { local $/ = undef; <D>; };
6255 D->error and fail "read $dscfn: $!";
6258 # we don't normally need this so import it here
6259 use Dpkg::Source::Package;
6260 my $dp = new Dpkg::Source::Package filename => $dscfn,
6261 require_valid_signature => $needsig;
6263 local $SIG{__WARN__} = sub {
6265 return unless $needsig;
6266 fail "import-dsc signature check failed";
6268 if (!$dp->is_signed()) {
6269 warn "$us: warning: importing unsigned .dsc\n";
6271 my $r = $dp->check_signature();
6272 die "->check_signature => $r" if $needsig && $r;
6278 $package = getfield $dsc, 'Source';
6280 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6281 unless forceing [qw(import-dsc-with-dgit-field)];
6282 parse_dsc_field_def_dsc_distro();
6284 $isuite = 'DGIT-IMPORT-DSC';
6285 $idistro //= $dsc_distro;
6289 if (defined $dsc_hash) {
6290 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6291 resolve_dsc_field_commit undef, undef;
6293 if (defined $dsc_hash) {
6294 my @cmd = (qw(sh -ec),
6295 "echo $dsc_hash | git cat-file --batch-check");
6296 my $objgot = cmdoutput @cmd;
6297 if ($objgot =~ m#^\w+ missing\b#) {
6299 .dsc contains Dgit field referring to object $dsc_hash
6300 Your git tree does not have that object. Try `git fetch' from a
6301 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6304 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6306 progress "Not fast forward, forced update.";
6308 fail "Not fast forward to $dsc_hash";
6311 import_dsc_result $dstbranch, $dsc_hash,
6312 "dgit import-dsc (Dgit): $info",
6313 "updated git ref $dstbranch";
6318 Branch $dstbranch already exists
6319 Specify ..$specbranch for a pseudo-merge, binding in existing history
6320 Specify +$specbranch to overwrite, discarding existing history
6322 if $oldhash && !$force;
6324 my @dfi = dsc_files_info();
6325 foreach my $fi (@dfi) {
6326 my $f = $fi->{Filename};
6328 next if lstat $here;
6329 fail "stat $here: $!" unless $! == ENOENT;
6331 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6333 } elsif ($dscfn =~ m#^/#) {
6336 fail "cannot import $dscfn which seems to be inside working tree!";
6338 $there =~ s#/+[^/]+$## or
6339 fail "cannot import $dscfn which seems to not have a basename";
6341 symlink $there, $here or fail "symlink $there to $here: $!";
6342 progress "made symlink $here -> $there";
6343 # print STDERR Dumper($fi);
6345 my @mergeinputs = generate_commits_from_dsc();
6346 die unless @mergeinputs == 1;
6348 my $newhash = $mergeinputs[0]{Commit};
6352 progress "Import, forced update - synthetic orphan git history.";
6353 } elsif ($force < 0) {
6354 progress "Import, merging.";
6355 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6356 my $version = getfield $dsc, 'Version';
6357 my $clogp = commit_getclogp $newhash;
6358 my $authline = clogp_authline $clogp;
6359 $newhash = make_commit_text <<END;
6366 Merge $package ($version) import into $dstbranch
6369 die; # caught earlier
6373 import_dsc_result $dstbranch, $newhash,
6374 "dgit import-dsc: $info",
6375 "results are in in git ref $dstbranch";
6378 sub cmd_archive_api_query {
6379 badusage "need only 1 subpath argument" unless @ARGV==1;
6380 my ($subpath) = @ARGV;
6381 my @cmd = archive_api_query_cmd($subpath);
6384 exec @cmd or fail "exec curl: $!\n";
6387 sub repos_server_url () {
6388 $package = '_dgit-repos-server';
6389 local $access_forpush = 1;
6390 local $isuite = 'DGIT-REPOS-SERVER';
6391 my $url = access_giturl();
6394 sub cmd_clone_dgit_repos_server {
6395 badusage "need destination argument" unless @ARGV==1;
6396 my ($destdir) = @ARGV;
6397 my $url = repos_server_url();
6398 my @cmd = (@git, qw(clone), $url, $destdir);
6400 exec @cmd or fail "exec git clone: $!\n";
6403 sub cmd_print_dgit_repos_server_source_url {
6404 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6406 my $url = repos_server_url();
6407 print $url, "\n" or die $!;
6410 sub cmd_setup_mergechangelogs {
6411 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6412 local $isuite = 'DGIT-SETUP-TREE';
6413 setup_mergechangelogs(1);
6416 sub cmd_setup_useremail {
6417 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6418 local $isuite = 'DGIT-SETUP-TREE';
6422 sub cmd_setup_gitattributes {
6423 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6424 local $isuite = 'DGIT-SETUP-TREE';
6428 sub cmd_setup_new_tree {
6429 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6430 local $isuite = 'DGIT-SETUP-TREE';
6434 #---------- argument parsing and main program ----------
6437 print "dgit version $our_version\n" or die $!;
6441 our (%valopts_long, %valopts_short);
6442 our (%funcopts_long);
6444 our (@modeopt_cfgs);
6446 sub defvalopt ($$$$) {
6447 my ($long,$short,$val_re,$how) = @_;
6448 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6449 $valopts_long{$long} = $oi;
6450 $valopts_short{$short} = $oi;
6451 # $how subref should:
6452 # do whatever assignemnt or thing it likes with $_[0]
6453 # if the option should not be passed on to remote, @rvalopts=()
6454 # or $how can be a scalar ref, meaning simply assign the value
6457 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6458 defvalopt '--distro', '-d', '.+', \$idistro;
6459 defvalopt '', '-k', '.+', \$keyid;
6460 defvalopt '--existing-package','', '.*', \$existing_package;
6461 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6462 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6463 defvalopt '--package', '-p', $package_re, \$package;
6464 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6466 defvalopt '', '-C', '.+', sub {
6467 ($changesfile) = (@_);
6468 if ($changesfile =~ s#^(.*)/##) {
6469 $buildproductsdir = $1;
6473 defvalopt '--initiator-tempdir','','.*', sub {
6474 ($initiator_tempdir) = (@_);
6475 $initiator_tempdir =~ m#^/# or
6476 badusage "--initiator-tempdir must be used specify an".
6477 " absolute, not relative, directory."
6480 sub defoptmodes ($@) {
6481 my ($varref, $cfgkey, $default, %optmap) = @_;
6483 while (my ($opt,$val) = each %optmap) {
6484 $funcopts_long{$opt} = sub { $$varref = $val; };
6485 $permit{$val} = $val;
6487 push @modeopt_cfgs, {
6490 Default => $default,
6495 defoptmodes \$dodep14tag, qw( dep14tag want
6498 --always-dep14tag always );
6503 if (defined $ENV{'DGIT_SSH'}) {
6504 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6505 } elsif (defined $ENV{'GIT_SSH'}) {
6506 @ssh = ($ENV{'GIT_SSH'});
6514 if (!defined $val) {
6515 badusage "$what needs a value" unless @ARGV;
6517 push @rvalopts, $val;
6519 badusage "bad value \`$val' for $what" unless
6520 $val =~ m/^$oi->{Re}$(?!\n)/s;
6521 my $how = $oi->{How};
6522 if (ref($how) eq 'SCALAR') {
6527 push @ropts, @rvalopts;
6531 last unless $ARGV[0] =~ m/^-/;
6535 if (m/^--dry-run$/) {
6538 } elsif (m/^--damp-run$/) {
6541 } elsif (m/^--no-sign$/) {
6544 } elsif (m/^--help$/) {
6546 } elsif (m/^--version$/) {
6548 } elsif (m/^--new$/) {
6551 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6552 ($om = $opts_opt_map{$1}) &&
6556 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6557 !$opts_opt_cmdonly{$1} &&
6558 ($om = $opts_opt_map{$1})) {
6561 } elsif (m/^--(gbp|dpm)$/s) {
6562 push @ropts, "--quilt=$1";
6564 } elsif (m/^--ignore-dirty$/s) {
6567 } elsif (m/^--no-quilt-fixup$/s) {
6569 $quilt_mode = 'nocheck';
6570 } elsif (m/^--no-rm-on-error$/s) {
6573 } elsif (m/^--no-chase-dsc-distro$/s) {
6575 $chase_dsc_distro = 0;
6576 } elsif (m/^--overwrite$/s) {
6578 $overwrite_version = '';
6579 } elsif (m/^--overwrite=(.+)$/s) {
6581 $overwrite_version = $1;
6582 } elsif (m/^--delayed=(\d+)$/s) {
6585 } elsif (m/^--dgit-view-save=(.+)$/s) {
6587 $split_brain_save = $1;
6588 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6589 } elsif (m/^--(no-)?rm-old-changes$/s) {
6592 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6594 push @deliberatelies, $&;
6595 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6599 } elsif (m/^--force-/) {
6601 "$us: warning: ignoring unknown force option $_\n";
6603 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6604 # undocumented, for testing
6606 $tagformat_want = [ $1, 'command line', 1 ];
6607 # 1 menas overrides distro configuration
6608 } elsif (m/^--always-split-source-build$/s) {
6609 # undocumented, for testing
6611 $need_split_build_invocation = 1;
6612 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6613 # undocumented, for testing
6615 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6616 # ^ it's supposed to be an array ref
6617 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6618 $val = $2 ? $' : undef; #';
6619 $valopt->($oi->{Long});
6620 } elsif ($funcopts_long{$_}) {
6622 $funcopts_long{$_}();
6624 badusage "unknown long option \`$_'";
6631 } elsif (s/^-L/-/) {
6634 } elsif (s/^-h/-/) {
6636 } elsif (s/^-D/-/) {
6640 } elsif (s/^-N/-/) {
6645 push @changesopts, $_;
6647 } elsif (s/^-wn$//s) {
6649 $cleanmode = 'none';
6650 } elsif (s/^-wg$//s) {
6653 } elsif (s/^-wgf$//s) {
6655 $cleanmode = 'git-ff';
6656 } elsif (s/^-wd$//s) {
6658 $cleanmode = 'dpkg-source';
6659 } elsif (s/^-wdd$//s) {
6661 $cleanmode = 'dpkg-source-d';
6662 } elsif (s/^-wc$//s) {
6664 $cleanmode = 'check';
6665 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6666 push @git, '-c', $&;
6667 $gitcfgs{cmdline}{$1} = [ $2 ];
6668 } elsif (s/^-c([^=]+)$//s) {
6669 push @git, '-c', $&;
6670 $gitcfgs{cmdline}{$1} = [ 'true' ];
6671 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6673 $val = undef unless length $val;
6674 $valopt->($oi->{Short});
6677 badusage "unknown short option \`$_'";
6684 sub check_env_sanity () {
6685 my $blocked = new POSIX::SigSet;
6686 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6689 foreach my $name (qw(PIPE CHLD)) {
6690 my $signame = "SIG$name";
6691 my $signum = eval "POSIX::$signame" // die;
6692 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6693 die "$signame is set to something other than SIG_DFL\n";
6694 $blocked->ismember($signum) and
6695 die "$signame is blocked\n";
6701 On entry to dgit, $@
6702 This is a bug produced by something in in your execution environment.
6708 sub parseopts_late_defaults () {
6709 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6710 if defined $idistro;
6711 $isuite //= cfg('dgit.default.default-suite');
6713 foreach my $k (keys %opts_opt_map) {
6714 my $om = $opts_opt_map{$k};
6716 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6718 badcfg "cannot set command for $k"
6719 unless length $om->[0];
6723 foreach my $c (access_cfg_cfgs("opts-$k")) {
6725 map { $_ ? @$_ : () }
6726 map { $gitcfgs{$_}{$c} }
6727 reverse @gitcfgsources;
6728 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6729 "\n" if $debuglevel >= 4;
6731 badcfg "cannot configure options for $k"
6732 if $opts_opt_cmdonly{$k};
6733 my $insertpos = $opts_cfg_insertpos{$k};
6734 @$om = ( @$om[0..$insertpos-1],
6736 @$om[$insertpos..$#$om] );
6740 if (!defined $rmchanges) {
6741 local $access_forpush;
6742 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6745 if (!defined $quilt_mode) {
6746 local $access_forpush;
6747 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6748 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6750 $quilt_mode =~ m/^($quilt_modes_re)$/
6751 or badcfg "unknown quilt-mode \`$quilt_mode'";
6755 foreach my $moc (@modeopt_cfgs) {
6756 local $access_forpush;
6757 my $vr = $moc->{Var};
6758 next if defined $$vr;
6759 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
6760 my $v = $moc->{Vals}{$$vr};
6761 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
6765 $need_split_build_invocation ||= quiltmode_splitbrain();
6767 if (!defined $cleanmode) {
6768 local $access_forpush;
6769 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6770 $cleanmode //= 'dpkg-source';
6772 badcfg "unknown clean-mode \`$cleanmode'" unless
6773 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6777 if ($ENV{$fakeeditorenv}) {
6779 quilt_fixup_editor();
6785 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6786 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6787 if $dryrun_level == 1;
6789 print STDERR $helpmsg or die $!;
6792 my $cmd = shift @ARGV;
6795 my $pre_fn = ${*::}{"pre_$cmd"};
6796 $pre_fn->() if $pre_fn;
6800 my $fn = ${*::}{"cmd_$cmd"};
6801 $fn or badusage "unknown operation $cmd";