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
58 our $dryrun_level = 0;
60 our $buildproductsdir = '..';
66 our $existing_package = 'dpkg';
68 our $changes_since_version;
70 our $overwrite_version; # undef: not specified; '': check changelog
72 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
74 our $split_brain_save;
75 our $we_are_responder;
76 our $we_are_initiator;
77 our $initiator_tempdir;
78 our $patches_applied_dirtily = 00;
82 our $chase_dsc_distro=1;
84 our %forceopts = map { $_=>0 }
85 qw(unrepresentable unsupported-source-format
86 dsc-changes-mismatch changes-origs-exactly
87 import-gitapply-absurd
88 import-gitapply-no-absurd
89 import-dsc-with-dgit-field);
91 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
93 our $suite_re = '[-+.0-9a-z]+';
94 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
95 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
96 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
97 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
99 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
100 our $splitbraincache = 'dgit-intern/quilt-cache';
101 our $rewritemap = 'dgit-rewrite/map';
103 our (@git) = qw(git);
104 our (@dget) = qw(dget);
105 our (@curl) = (qw(curl --proto-redir), '-all,http,https', qw(-L));
106 our (@dput) = qw(dput);
107 our (@debsign) = qw(debsign);
108 our (@gpg) = qw(gpg);
109 our (@sbuild) = qw(sbuild);
111 our (@dgit) = qw(dgit);
112 our (@aptget) = qw(apt-get);
113 our (@aptcache) = qw(apt-cache);
114 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
115 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
116 our (@dpkggenchanges) = qw(dpkg-genchanges);
117 our (@mergechanges) = qw(mergechanges -f);
118 our (@gbp_build) = ('');
119 our (@gbp_pq) = ('gbp pq');
120 our (@changesopts) = ('');
122 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
125 'debsign' => \@debsign,
127 'sbuild' => \@sbuild,
131 'apt-get' => \@aptget,
132 'apt-cache' => \@aptcache,
133 'dpkg-source' => \@dpkgsource,
134 'dpkg-buildpackage' => \@dpkgbuildpackage,
135 'dpkg-genchanges' => \@dpkggenchanges,
136 'gbp-build' => \@gbp_build,
137 'gbp-pq' => \@gbp_pq,
138 'ch' => \@changesopts,
139 'mergechanges' => \@mergechanges);
141 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
142 our %opts_cfg_insertpos = map {
144 scalar @{ $opts_opt_map{$_} }
145 } keys %opts_opt_map;
147 sub parseopts_late_defaults();
148 sub setup_gitattrs(;$);
149 sub check_gitattrs($$);
155 our $supplementary_message = '';
156 our $need_split_build_invocation = 0;
157 our $split_brain = 0;
161 return unless forkcheck_mainprocess();
162 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
165 our $remotename = 'dgit';
166 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
170 if (!defined $absurdity) {
172 $absurdity =~ s{/[^/]+$}{/absurd} or die;
176 my ($v,$distro) = @_;
177 return $tagformatfn->($v, $distro);
180 sub debiantag_maintview ($$) {
181 my ($v,$distro) = @_;
182 return "$distro/".dep14_version_mangle $v;
185 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
187 sub lbranch () { return "$branchprefix/$csuite"; }
188 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
189 sub lref () { return "refs/heads/".lbranch(); }
190 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
191 sub rrref () { return server_ref($csuite); }
201 return "${package}_".(stripepoch $vsn).$sfx
206 return srcfn($vsn,".dsc");
209 sub changespat ($;$) {
210 my ($vsn, $arch) = @_;
211 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
214 sub upstreamversion ($) {
226 return unless forkcheck_mainprocess();
227 foreach my $f (@end) {
229 print STDERR "$us: cleanup: $@" if length $@;
233 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
235 sub forceable_fail ($$) {
236 my ($forceoptsl, $msg) = @_;
237 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
238 print STDERR "warning: overriding problem due to --force:\n". $msg;
242 my ($forceoptsl) = @_;
243 my @got = grep { $forceopts{$_} } @$forceoptsl;
244 return 0 unless @got;
246 "warning: skipping checks or functionality due to --force-$got[0]\n";
249 sub no_such_package () {
250 print STDERR "$us: package $package does not exist in suite $isuite\n";
254 sub deliberately ($) {
256 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
259 sub deliberately_not_fast_forward () {
260 foreach (qw(not-fast-forward fresh-repo)) {
261 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
265 sub quiltmode_splitbrain () {
266 $quilt_mode =~ m/gbp|dpm|unapplied/;
269 sub opts_opt_multi_cmd {
271 push @cmd, split /\s+/, shift @_;
277 return opts_opt_multi_cmd @gbp_pq;
280 #---------- remote protocol support, common ----------
282 # remote push initiator/responder protocol:
283 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
284 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
285 # < dgit-remote-push-ready <actual-proto-vsn>
292 # > supplementary-message NBYTES # $protovsn >= 3
297 # > file parsed-changelog
298 # [indicates that output of dpkg-parsechangelog follows]
299 # > data-block NBYTES
300 # > [NBYTES bytes of data (no newline)]
301 # [maybe some more blocks]
310 # > param head DGIT-VIEW-HEAD
311 # > param csuite SUITE
312 # > param tagformat old|new
313 # > param maint-view MAINT-VIEW-HEAD
315 # > param buildinfo-filename P_V_X.buildinfo # zero or more times
316 # > file buildinfo # for buildinfos to sign
318 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
319 # # goes into tag, for replay prevention
322 # [indicates that signed tag is wanted]
323 # < data-block NBYTES
324 # < [NBYTES bytes of data (no newline)]
325 # [maybe some more blocks]
329 # > want signed-dsc-changes
330 # < data-block NBYTES [transfer of signed dsc]
332 # < data-block NBYTES [transfer of signed changes]
334 # < data-block NBYTES [transfer of each signed buildinfo
335 # [etc] same number and order as "file buildinfo"]
343 sub i_child_report () {
344 # Sees if our child has died, and reap it if so. Returns a string
345 # describing how it died if it failed, or undef otherwise.
346 return undef unless $i_child_pid;
347 my $got = waitpid $i_child_pid, WNOHANG;
348 return undef if $got <= 0;
349 die unless $got == $i_child_pid;
350 $i_child_pid = undef;
351 return undef unless $?;
352 return "build host child ".waitstatusmsg();
357 fail "connection lost: $!" if $fh->error;
358 fail "protocol violation; $m not expected";
361 sub badproto_badread ($$) {
363 fail "connection lost: $!" if $!;
364 my $report = i_child_report();
365 fail $report if defined $report;
366 badproto $fh, "eof (reading $wh)";
369 sub protocol_expect (&$) {
370 my ($match, $fh) = @_;
373 defined && chomp or badproto_badread $fh, "protocol message";
381 badproto $fh, "\`$_'";
384 sub protocol_send_file ($$) {
385 my ($fh, $ourfn) = @_;
386 open PF, "<", $ourfn or die "$ourfn: $!";
389 my $got = read PF, $d, 65536;
390 die "$ourfn: $!" unless defined $got;
392 print $fh "data-block ".length($d)."\n" or die $!;
393 print $fh $d or die $!;
395 PF->error and die "$ourfn $!";
396 print $fh "data-end\n" or die $!;
400 sub protocol_read_bytes ($$) {
401 my ($fh, $nbytes) = @_;
402 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
404 my $got = read $fh, $d, $nbytes;
405 $got==$nbytes or badproto_badread $fh, "data block";
409 sub protocol_receive_file ($$) {
410 my ($fh, $ourfn) = @_;
411 printdebug "() $ourfn\n";
412 open PF, ">", $ourfn or die "$ourfn: $!";
414 my ($y,$l) = protocol_expect {
415 m/^data-block (.*)$/ ? (1,$1) :
416 m/^data-end$/ ? (0,) :
420 my $d = protocol_read_bytes $fh, $l;
421 print PF $d or die $!;
426 #---------- remote protocol support, responder ----------
428 sub responder_send_command ($) {
430 return unless $we_are_responder;
431 # called even without $we_are_responder
432 printdebug ">> $command\n";
433 print PO $command, "\n" or die $!;
436 sub responder_send_file ($$) {
437 my ($keyword, $ourfn) = @_;
438 return unless $we_are_responder;
439 printdebug "]] $keyword $ourfn\n";
440 responder_send_command "file $keyword";
441 protocol_send_file \*PO, $ourfn;
444 sub responder_receive_files ($@) {
445 my ($keyword, @ourfns) = @_;
446 die unless $we_are_responder;
447 printdebug "[[ $keyword @ourfns\n";
448 responder_send_command "want $keyword";
449 foreach my $fn (@ourfns) {
450 protocol_receive_file \*PI, $fn;
453 protocol_expect { m/^files-end$/ } \*PI;
456 #---------- remote protocol support, initiator ----------
458 sub initiator_expect (&) {
460 protocol_expect { &$match } \*RO;
463 #---------- end remote code ----------
466 if ($we_are_responder) {
468 responder_send_command "progress ".length($m) or die $!;
469 print PO $m or die $!;
479 $ua = LWP::UserAgent->new();
483 progress "downloading $what...";
484 my $r = $ua->get(@_) or die $!;
485 return undef if $r->code == 404;
486 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
487 return $r->decoded_content(charset => 'none');
490 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
492 sub act_local () { return $dryrun_level <= 1; }
493 sub act_scary () { return !$dryrun_level; }
496 if (!$dryrun_level) {
497 progress "$us ok: @_";
499 progress "would be ok: @_ (but dry run only)";
504 printcmd(\*STDERR,$debugprefix."#",@_);
507 sub runcmd_ordryrun {
515 sub runcmd_ordryrun_local {
524 my ($first_shell, @cmd) = @_;
525 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
528 our $helpmsg = <<END;
530 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
531 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
532 dgit [dgit-opts] build [dpkg-buildpackage-opts]
533 dgit [dgit-opts] sbuild [sbuild-opts]
534 dgit [dgit-opts] push [dgit-opts] [suite]
535 dgit [dgit-opts] rpush build-host:build-dir ...
536 important dgit options:
537 -k<keyid> sign tag and package with <keyid> instead of default
538 --dry-run -n do not change anything, but go through the motions
539 --damp-run -L like --dry-run but make local changes, without signing
540 --new -N allow introducing a new package
541 --debug -D increase debug level
542 -c<name>=<value> set git config option (used directly by dgit too)
545 our $later_warning_msg = <<END;
546 Perhaps the upload is stuck in incoming. Using the version from git.
550 print STDERR "$us: @_\n", $helpmsg or die $!;
555 @ARGV or badusage "too few arguments";
556 return scalar shift @ARGV;
563 print $helpmsg or die $!;
567 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
569 our %defcfg = ('dgit.default.distro' => 'debian',
570 'dgit.default.default-suite' => 'unstable',
571 'dgit.default.old-dsc-distro' => 'debian',
572 'dgit-suite.*-security.distro' => 'debian-security',
573 'dgit.default.username' => '',
574 'dgit.default.archive-query-default-component' => 'main',
575 'dgit.default.ssh' => 'ssh',
576 'dgit.default.archive-query' => 'madison:',
577 'dgit.default.sshpsql-dbname' => 'service=projectb',
578 'dgit.default.aptget-components' => 'main',
579 'dgit.default.dgit-tag-format' => 'new,old,maint',
580 'dgit.dsc-url-proto-ok.http' => 'true',
581 'dgit.dsc-url-proto-ok.https' => 'true',
582 'dgit.dsc-url-proto-ok.git' => 'true',
583 'dgit.default.dsc-url-proto-ok' => 'false',
584 # old means "repo server accepts pushes with old dgit tags"
585 # new means "repo server accepts pushes with new dgit tags"
586 # maint means "repo server accepts split brain pushes"
587 # hist means "repo server may have old pushes without new tag"
588 # ("hist" is implied by "old")
589 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
590 'dgit-distro.debian.git-check' => 'url',
591 'dgit-distro.debian.git-check-suffix' => '/info/refs',
592 'dgit-distro.debian.new-private-pushers' => 't',
593 'dgit-distro.debian/push.git-url' => '',
594 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
595 'dgit-distro.debian/push.git-user-force' => 'dgit',
596 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
597 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
598 'dgit-distro.debian/push.git-create' => 'true',
599 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
600 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
601 # 'dgit-distro.debian.archive-query-tls-key',
602 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
603 # ^ this does not work because curl is broken nowadays
604 # Fixing #790093 properly will involve providing providing the key
605 # in some pacagke and maybe updating these paths.
607 # 'dgit-distro.debian.archive-query-tls-curl-args',
608 # '--ca-path=/etc/ssl/ca-debian',
609 # ^ this is a workaround but works (only) on DSA-administered machines
610 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
611 'dgit-distro.debian.git-url-suffix' => '',
612 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
613 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
614 'dgit-distro.debian-security.archive-query' => 'aptget:',
615 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
616 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
617 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
618 'dgit-distro.debian-security.nominal-distro' => 'debian',
619 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
620 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
621 'dgit-distro.ubuntu.git-check' => 'false',
622 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
623 'dgit-distro.test-dummy.ssh' => "$td/ssh",
624 'dgit-distro.test-dummy.username' => "alice",
625 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
626 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
627 'dgit-distro.test-dummy.git-url' => "$td/git",
628 'dgit-distro.test-dummy.git-host' => "git",
629 'dgit-distro.test-dummy.git-path' => "$td/git",
630 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
631 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
632 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
633 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
637 our @gitcfgsources = qw(cmdline local global system);
639 sub git_slurp_config () {
640 # This algoritm is a bit subtle, but this is needed so that for
641 # options which we want to be single-valued, we allow the
642 # different config sources to override properly. See #835858.
643 foreach my $src (@gitcfgsources) {
644 next if $src eq 'cmdline';
645 # we do this ourselves since git doesn't handle it
647 $gitcfgs{$src} = git_slurp_config_src $src;
651 sub git_get_config ($) {
653 foreach my $src (@gitcfgsources) {
654 my $l = $gitcfgs{$src}{$c};
655 confess "internal error ($l $c)" if $l && !ref $l;
656 printdebug"C $c ".(defined $l ?
657 join " ", map { messagequote "'$_'" } @$l :
661 @$l==1 or badcfg "multiple values for $c".
662 " (in $src git config)" if @$l > 1;
670 return undef if $c =~ /RETURN-UNDEF/;
671 printdebug "C? $c\n" if $debuglevel >= 5;
672 my $v = git_get_config($c);
673 return $v if defined $v;
674 my $dv = $defcfg{$c};
676 printdebug "CD $c $dv\n" if $debuglevel >= 4;
680 badcfg "need value for one of: @_\n".
681 "$us: distro or suite appears not to be (properly) supported";
684 sub no_local_git_cfg () {
685 # needs to be called from pre_*
686 @gitcfgsources = grep { $_ ne 'local' } @gitcfgsources;
689 sub access_basedistro__noalias () {
690 if (defined $idistro) {
693 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
694 return $def if defined $def;
695 foreach my $src (@gitcfgsources, 'internal') {
696 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
698 foreach my $k (keys %$kl) {
699 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
701 next unless match_glob $dpat, $isuite;
705 return cfg("dgit.default.distro");
709 sub access_basedistro () {
710 my $noalias = access_basedistro__noalias();
711 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
712 return $canon // $noalias;
715 sub access_nomdistro () {
716 my $base = access_basedistro();
717 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
718 $r =~ m/^$distro_re$/ or badcfg
719 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
723 sub access_quirk () {
724 # returns (quirk name, distro to use instead or undef, quirk-specific info)
725 my $basedistro = access_basedistro();
726 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
728 if (defined $backports_quirk) {
729 my $re = $backports_quirk;
730 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
732 $re =~ s/\%/([-0-9a-z_]+)/
733 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
734 if ($isuite =~ m/^$re$/) {
735 return ('backports',"$basedistro-backports",$1);
738 return ('none',undef);
743 sub parse_cfg_bool ($$$) {
744 my ($what,$def,$v) = @_;
747 $v =~ m/^[ty1]/ ? 1 :
748 $v =~ m/^[fn0]/ ? 0 :
749 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
752 sub access_forpush_config () {
753 my $d = access_basedistro();
757 parse_cfg_bool('new-private-pushers', 0,
758 cfg("dgit-distro.$d.new-private-pushers",
761 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
764 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
765 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
766 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
767 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
770 sub access_forpush () {
771 $access_forpush //= access_forpush_config();
772 return $access_forpush;
776 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
777 badcfg "pushing but distro is configured readonly"
778 if access_forpush_config() eq '0';
780 $supplementary_message = <<'END' unless $we_are_responder;
781 Push failed, before we got started.
782 You can retry the push, after fixing the problem, if you like.
784 parseopts_late_defaults();
788 parseopts_late_defaults();
791 sub supplementary_message ($) {
793 if (!$we_are_responder) {
794 $supplementary_message = $msg;
796 } elsif ($protovsn >= 3) {
797 responder_send_command "supplementary-message ".length($msg)
799 print PO $msg or die $!;
803 sub access_distros () {
804 # Returns list of distros to try, in order
807 # 0. `instead of' distro name(s) we have been pointed to
808 # 1. the access_quirk distro, if any
809 # 2a. the user's specified distro, or failing that } basedistro
810 # 2b. the distro calculated from the suite }
811 my @l = access_basedistro();
813 my (undef,$quirkdistro) = access_quirk();
814 unshift @l, $quirkdistro;
815 unshift @l, $instead_distro;
816 @l = grep { defined } @l;
818 push @l, access_nomdistro();
820 if (access_forpush()) {
821 @l = map { ("$_/push", $_) } @l;
826 sub access_cfg_cfgs (@) {
829 # The nesting of these loops determines the search order. We put
830 # the key loop on the outside so that we search all the distros
831 # for each key, before going on to the next key. That means that
832 # if access_cfg is called with a more specific, and then a less
833 # specific, key, an earlier distro can override the less specific
834 # without necessarily overriding any more specific keys. (If the
835 # distro wants to override the more specific keys it can simply do
836 # so; whereas if we did the loop the other way around, it would be
837 # impossible to for an earlier distro to override a less specific
838 # key but not the more specific ones without restating the unknown
839 # values of the more specific keys.
842 # We have to deal with RETURN-UNDEF specially, so that we don't
843 # terminate the search prematurely.
845 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
848 foreach my $d (access_distros()) {
849 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
851 push @cfgs, map { "dgit.default.$_" } @realkeys;
858 my (@cfgs) = access_cfg_cfgs(@keys);
859 my $value = cfg(@cfgs);
863 sub access_cfg_bool ($$) {
864 my ($def, @keys) = @_;
865 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
868 sub string_to_ssh ($) {
870 if ($spec =~ m/\s/) {
871 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
877 sub access_cfg_ssh () {
878 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
879 if (!defined $gitssh) {
882 return string_to_ssh $gitssh;
886 sub access_runeinfo ($) {
888 return ": dgit ".access_basedistro()." $info ;";
891 sub access_someuserhost ($) {
893 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
894 defined($user) && length($user) or
895 $user = access_cfg("$some-user",'username');
896 my $host = access_cfg("$some-host");
897 return length($user) ? "$user\@$host" : $host;
900 sub access_gituserhost () {
901 return access_someuserhost('git');
904 sub access_giturl (;$) {
906 my $url = access_cfg('git-url','RETURN-UNDEF');
909 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
910 return undef unless defined $proto;
913 access_gituserhost().
914 access_cfg('git-path');
916 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
919 return "$url/$package$suffix";
922 sub parsecontrolfh ($$;$) {
923 my ($fh, $desc, $allowsigned) = @_;
924 our $dpkgcontrolhash_noissigned;
927 my %opts = ('name' => $desc);
928 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
929 $c = Dpkg::Control::Hash->new(%opts);
930 $c->parse($fh,$desc) or die "parsing of $desc failed";
931 last if $allowsigned;
932 last if $dpkgcontrolhash_noissigned;
933 my $issigned= $c->get_option('is_pgp_signed');
934 if (!defined $issigned) {
935 $dpkgcontrolhash_noissigned= 1;
936 seek $fh, 0,0 or die "seek $desc: $!";
937 } elsif ($issigned) {
938 fail "control file $desc is (already) PGP-signed. ".
939 " Note that dgit push needs to modify the .dsc and then".
940 " do the signature itself";
949 my ($file, $desc, $allowsigned) = @_;
950 my $fh = new IO::Handle;
951 open $fh, '<', $file or die "$file: $!";
952 my $c = parsecontrolfh($fh,$desc,$allowsigned);
953 $fh->error and die $!;
959 my ($dctrl,$field) = @_;
960 my $v = $dctrl->{$field};
961 return $v if defined $v;
962 fail "missing field $field in ".$dctrl->get_option('name');
966 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
967 my $p = new IO::Handle;
968 my @cmd = (qw(dpkg-parsechangelog), @_);
969 open $p, '-|', @cmd or die $!;
971 $?=0; $!=0; close $p or failedcmd @cmd;
975 sub commit_getclogp ($) {
976 # Returns the parsed changelog hashref for a particular commit
978 our %commit_getclogp_memo;
979 my $memo = $commit_getclogp_memo{$objid};
980 return $memo if $memo;
982 my $mclog = ".git/dgit/clog-$objid";
983 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
984 "$objid:debian/changelog";
985 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
988 sub parse_dscdata () {
989 my $dscfh = new IO::File \$dscdata, '<' or die $!;
990 printdebug Dumper($dscdata) if $debuglevel>1;
991 $dsc = parsecontrolfh($dscfh,$dscurl,1);
992 printdebug Dumper($dsc) if $debuglevel>1;
997 sub archive_query ($;@) {
998 my ($method) = shift @_;
999 fail "this operation does not support multiple comma-separated suites"
1001 my $query = access_cfg('archive-query','RETURN-UNDEF');
1002 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1005 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1008 sub archive_query_prepend_mirror {
1009 my $m = access_cfg('mirror');
1010 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1013 sub pool_dsc_subpath ($$) {
1014 my ($vsn,$component) = @_; # $package is implict arg
1015 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1016 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1019 sub cfg_apply_map ($$$) {
1020 my ($varref, $what, $mapspec) = @_;
1021 return unless $mapspec;
1023 printdebug "config $what EVAL{ $mapspec; }\n";
1025 eval "package Dgit::Config; $mapspec;";
1030 #---------- `ftpmasterapi' archive query method (nascent) ----------
1032 sub archive_api_query_cmd ($) {
1034 my @cmd = (@curl, qw(-sS));
1035 my $url = access_cfg('archive-query-url');
1036 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1038 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1039 foreach my $key (split /\:/, $keys) {
1040 $key =~ s/\%HOST\%/$host/g;
1042 fail "for $url: stat $key: $!" unless $!==ENOENT;
1045 fail "config requested specific TLS key but do not know".
1046 " how to get curl to use exactly that EE key ($key)";
1047 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1048 # # Sadly the above line does not work because of changes
1049 # # to gnutls. The real fix for #790093 may involve
1050 # # new curl options.
1053 # Fixing #790093 properly will involve providing a value
1054 # for this on clients.
1055 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1056 push @cmd, split / /, $kargs if defined $kargs;
1058 push @cmd, $url.$subpath;
1062 sub api_query ($$;$) {
1064 my ($data, $subpath, $ok404) = @_;
1065 badcfg "ftpmasterapi archive query method takes no data part"
1067 my @cmd = archive_api_query_cmd($subpath);
1068 my $url = $cmd[$#cmd];
1069 push @cmd, qw(-w %{http_code});
1070 my $json = cmdoutput @cmd;
1071 unless ($json =~ s/\d+\d+\d$//) {
1072 failedcmd_report_cmd undef, @cmd;
1073 fail "curl failed to print 3-digit HTTP code";
1076 return undef if $code eq '404' && $ok404;
1077 fail "fetch of $url gave HTTP code $code"
1078 unless $url =~ m#^file://# or $code =~ m/^2/;
1079 return decode_json($json);
1082 sub canonicalise_suite_ftpmasterapi {
1083 my ($proto,$data) = @_;
1084 my $suites = api_query($data, 'suites');
1086 foreach my $entry (@$suites) {
1088 my $v = $entry->{$_};
1089 defined $v && $v eq $isuite;
1090 } qw(codename name);
1091 push @matched, $entry;
1093 fail "unknown suite $isuite" unless @matched;
1096 @matched==1 or die "multiple matches for suite $isuite\n";
1097 $cn = "$matched[0]{codename}";
1098 defined $cn or die "suite $isuite info has no codename\n";
1099 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1101 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1106 sub archive_query_ftpmasterapi {
1107 my ($proto,$data) = @_;
1108 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1110 my $digester = Digest::SHA->new(256);
1111 foreach my $entry (@$info) {
1113 my $vsn = "$entry->{version}";
1114 my ($ok,$msg) = version_check $vsn;
1115 die "bad version: $msg\n" unless $ok;
1116 my $component = "$entry->{component}";
1117 $component =~ m/^$component_re$/ or die "bad component";
1118 my $filename = "$entry->{filename}";
1119 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1120 or die "bad filename";
1121 my $sha256sum = "$entry->{sha256sum}";
1122 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1123 push @rows, [ $vsn, "/pool/$component/$filename",
1124 $digester, $sha256sum ];
1126 die "bad ftpmaster api response: $@\n".Dumper($entry)
1129 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1130 return archive_query_prepend_mirror @rows;
1133 sub file_in_archive_ftpmasterapi {
1134 my ($proto,$data,$filename) = @_;
1135 my $pat = $filename;
1138 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1139 my $info = api_query($data, "file_in_archive/$pat", 1);
1142 #---------- `aptget' archive query method ----------
1145 our $aptget_releasefile;
1146 our $aptget_configpath;
1148 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1149 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1151 sub aptget_cache_clean {
1152 runcmd_ordryrun_local qw(sh -ec),
1153 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1157 sub aptget_lock_acquire () {
1158 my $lockfile = "$aptget_base/lock";
1159 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1160 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1163 sub aptget_prep ($) {
1165 return if defined $aptget_base;
1167 badcfg "aptget archive query method takes no data part"
1170 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1173 ensuredir "$cache/dgit";
1175 access_cfg('aptget-cachekey','RETURN-UNDEF')
1176 // access_nomdistro();
1178 $aptget_base = "$cache/dgit/aptget";
1179 ensuredir $aptget_base;
1181 my $quoted_base = $aptget_base;
1182 die "$quoted_base contains bad chars, cannot continue"
1183 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1185 ensuredir $aptget_base;
1187 aptget_lock_acquire();
1189 aptget_cache_clean();
1191 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1192 my $sourceslist = "source.list#$cachekey";
1194 my $aptsuites = $isuite;
1195 cfg_apply_map(\$aptsuites, 'suite map',
1196 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1198 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1199 printf SRCS "deb-src %s %s %s\n",
1200 access_cfg('mirror'),
1202 access_cfg('aptget-components')
1205 ensuredir "$aptget_base/cache";
1206 ensuredir "$aptget_base/lists";
1208 open CONF, ">", $aptget_configpath or die $!;
1210 Debug::NoLocking "true";
1211 APT::Get::List-Cleanup "false";
1212 #clear APT::Update::Post-Invoke-Success;
1213 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1214 Dir::State::Lists "$quoted_base/lists";
1215 Dir::Etc::preferences "$quoted_base/preferences";
1216 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1217 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1220 foreach my $key (qw(
1223 Dir::Cache::Archives
1224 Dir::Etc::SourceParts
1225 Dir::Etc::preferencesparts
1227 ensuredir "$aptget_base/$key";
1228 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1231 my $oldatime = (time // die $!) - 1;
1232 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1233 next unless stat_exists $oldlist;
1234 my ($mtime) = (stat _)[9];
1235 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1238 runcmd_ordryrun_local aptget_aptget(), qw(update);
1241 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1242 next unless stat_exists $oldlist;
1243 my ($atime) = (stat _)[8];
1244 next if $atime == $oldatime;
1245 push @releasefiles, $oldlist;
1247 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1248 @releasefiles = @inreleasefiles if @inreleasefiles;
1249 die "apt updated wrong number of Release files (@releasefiles), erk"
1250 unless @releasefiles == 1;
1252 ($aptget_releasefile) = @releasefiles;
1255 sub canonicalise_suite_aptget {
1256 my ($proto,$data) = @_;
1259 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1261 foreach my $name (qw(Codename Suite)) {
1262 my $val = $release->{$name};
1264 printdebug "release file $name: $val\n";
1265 $val =~ m/^$suite_re$/o or fail
1266 "Release file ($aptget_releasefile) specifies intolerable $name";
1267 cfg_apply_map(\$val, 'suite rmap',
1268 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1275 sub archive_query_aptget {
1276 my ($proto,$data) = @_;
1279 ensuredir "$aptget_base/source";
1280 foreach my $old (<$aptget_base/source/*.dsc>) {
1281 unlink $old or die "$old: $!";
1284 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1285 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1286 # avoids apt-get source failing with ambiguous error code
1288 runcmd_ordryrun_local
1289 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1290 aptget_aptget(), qw(--download-only --only-source source), $package;
1292 my @dscs = <$aptget_base/source/*.dsc>;
1293 fail "apt-get source did not produce a .dsc" unless @dscs;
1294 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1296 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1299 my $uri = "file://". uri_escape $dscs[0];
1300 $uri =~ s{\%2f}{/}gi;
1301 return [ (getfield $pre_dsc, 'Version'), $uri ];
1304 sub file_in_archive_aptget () { return undef; }
1306 #---------- `dummyapicat' archive query method ----------
1308 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1309 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1311 sub file_in_archive_dummycatapi ($$$) {
1312 my ($proto,$data,$filename) = @_;
1313 my $mirror = access_cfg('mirror');
1314 $mirror =~ s#^file://#/# or die "$mirror ?";
1316 my @cmd = (qw(sh -ec), '
1318 find -name "$2" -print0 |
1320 ', qw(x), $mirror, $filename);
1321 debugcmd "-|", @cmd;
1322 open FIA, "-|", @cmd or die $!;
1325 printdebug "| $_\n";
1326 m/^(\w+) (\S+)$/ or die "$_ ?";
1327 push @out, { sha256sum => $1, filename => $2 };
1329 close FIA or die failedcmd @cmd;
1333 #---------- `madison' archive query method ----------
1335 sub archive_query_madison {
1336 return archive_query_prepend_mirror
1337 map { [ @$_[0..1] ] } madison_get_parse(@_);
1340 sub madison_get_parse {
1341 my ($proto,$data) = @_;
1342 die unless $proto eq 'madison';
1343 if (!length $data) {
1344 $data= access_cfg('madison-distro','RETURN-UNDEF');
1345 $data //= access_basedistro();
1347 $rmad{$proto,$data,$package} ||= cmdoutput
1348 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1349 my $rmad = $rmad{$proto,$data,$package};
1352 foreach my $l (split /\n/, $rmad) {
1353 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1354 \s*( [^ \t|]+ )\s* \|
1355 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1356 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1357 $1 eq $package or die "$rmad $package ?";
1364 $component = access_cfg('archive-query-default-component');
1366 $5 eq 'source' or die "$rmad ?";
1367 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1369 return sort { -version_compare($a->[0],$b->[0]); } @out;
1372 sub canonicalise_suite_madison {
1373 # madison canonicalises for us
1374 my @r = madison_get_parse(@_);
1376 "unable to canonicalise suite using package $package".
1377 " which does not appear to exist in suite $isuite;".
1378 " --existing-package may help";
1382 sub file_in_archive_madison { return undef; }
1384 #---------- `sshpsql' archive query method ----------
1387 my ($data,$runeinfo,$sql) = @_;
1388 if (!length $data) {
1389 $data= access_someuserhost('sshpsql').':'.
1390 access_cfg('sshpsql-dbname');
1392 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1393 my ($userhost,$dbname) = ($`,$'); #';
1395 my @cmd = (access_cfg_ssh, $userhost,
1396 access_runeinfo("ssh-psql $runeinfo").
1397 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1398 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1400 open P, "-|", @cmd or die $!;
1403 printdebug(">|$_|\n");
1406 $!=0; $?=0; close P or failedcmd @cmd;
1408 my $nrows = pop @rows;
1409 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1410 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1411 @rows = map { [ split /\|/, $_ ] } @rows;
1412 my $ncols = scalar @{ shift @rows };
1413 die if grep { scalar @$_ != $ncols } @rows;
1417 sub sql_injection_check {
1418 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1421 sub archive_query_sshpsql ($$) {
1422 my ($proto,$data) = @_;
1423 sql_injection_check $isuite, $package;
1424 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1425 SELECT source.version, component.name, files.filename, files.sha256sum
1427 JOIN src_associations ON source.id = src_associations.source
1428 JOIN suite ON suite.id = src_associations.suite
1429 JOIN dsc_files ON dsc_files.source = source.id
1430 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1431 JOIN component ON component.id = files_archive_map.component_id
1432 JOIN files ON files.id = dsc_files.file
1433 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1434 AND source.source='$package'
1435 AND files.filename LIKE '%.dsc';
1437 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1438 my $digester = Digest::SHA->new(256);
1440 my ($vsn,$component,$filename,$sha256sum) = @$_;
1441 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1443 return archive_query_prepend_mirror @rows;
1446 sub canonicalise_suite_sshpsql ($$) {
1447 my ($proto,$data) = @_;
1448 sql_injection_check $isuite;
1449 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1450 SELECT suite.codename
1451 FROM suite where suite_name='$isuite' or codename='$isuite';
1453 @rows = map { $_->[0] } @rows;
1454 fail "unknown suite $isuite" unless @rows;
1455 die "ambiguous $isuite: @rows ?" if @rows>1;
1459 sub file_in_archive_sshpsql ($$$) { return undef; }
1461 #---------- `dummycat' archive query method ----------
1463 sub canonicalise_suite_dummycat ($$) {
1464 my ($proto,$data) = @_;
1465 my $dpath = "$data/suite.$isuite";
1466 if (!open C, "<", $dpath) {
1467 $!==ENOENT or die "$dpath: $!";
1468 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1472 chomp or die "$dpath: $!";
1474 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1478 sub archive_query_dummycat ($$) {
1479 my ($proto,$data) = @_;
1480 canonicalise_suite();
1481 my $dpath = "$data/package.$csuite.$package";
1482 if (!open C, "<", $dpath) {
1483 $!==ENOENT or die "$dpath: $!";
1484 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1492 printdebug "dummycat query $csuite $package $dpath | $_\n";
1493 my @row = split /\s+/, $_;
1494 @row==2 or die "$dpath: $_ ?";
1497 C->error and die "$dpath: $!";
1499 return archive_query_prepend_mirror
1500 sort { -version_compare($a->[0],$b->[0]); } @rows;
1503 sub file_in_archive_dummycat () { return undef; }
1505 #---------- tag format handling ----------
1507 sub access_cfg_tagformats () {
1508 split /\,/, access_cfg('dgit-tag-format');
1511 sub access_cfg_tagformats_can_splitbrain () {
1512 my %y = map { $_ => 1 } access_cfg_tagformats;
1513 foreach my $needtf (qw(new maint)) {
1514 next if $y{$needtf};
1520 sub need_tagformat ($$) {
1521 my ($fmt, $why) = @_;
1522 fail "need to use tag format $fmt ($why) but also need".
1523 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1524 " - no way to proceed"
1525 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1526 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1529 sub select_tagformat () {
1531 return if $tagformatfn && !$tagformat_want;
1532 die 'bug' if $tagformatfn && $tagformat_want;
1533 # ... $tagformat_want assigned after previous select_tagformat
1535 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1536 printdebug "select_tagformat supported @supported\n";
1538 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1539 printdebug "select_tagformat specified @$tagformat_want\n";
1541 my ($fmt,$why,$override) = @$tagformat_want;
1543 fail "target distro supports tag formats @supported".
1544 " but have to use $fmt ($why)"
1546 or grep { $_ eq $fmt } @supported;
1548 $tagformat_want = undef;
1550 $tagformatfn = ${*::}{"debiantag_$fmt"};
1552 fail "trying to use unknown tag format \`$fmt' ($why) !"
1553 unless $tagformatfn;
1556 #---------- archive query entrypoints and rest of program ----------
1558 sub canonicalise_suite () {
1559 return if defined $csuite;
1560 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1561 $csuite = archive_query('canonicalise_suite');
1562 if ($isuite ne $csuite) {
1563 progress "canonical suite name for $isuite is $csuite";
1565 progress "canonical suite name is $csuite";
1569 sub get_archive_dsc () {
1570 canonicalise_suite();
1571 my @vsns = archive_query('archive_query');
1572 foreach my $vinfo (@vsns) {
1573 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1574 $dscurl = $vsn_dscurl;
1575 $dscdata = url_get($dscurl);
1577 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1582 $digester->add($dscdata);
1583 my $got = $digester->hexdigest();
1585 fail "$dscurl has hash $got but".
1586 " archive told us to expect $digest";
1589 my $fmt = getfield $dsc, 'Format';
1590 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1591 "unsupported source format $fmt, sorry";
1593 $dsc_checked = !!$digester;
1594 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1598 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1601 sub check_for_git ();
1602 sub check_for_git () {
1604 my $how = access_cfg('git-check');
1605 if ($how eq 'ssh-cmd') {
1607 (access_cfg_ssh, access_gituserhost(),
1608 access_runeinfo("git-check $package").
1609 " set -e; cd ".access_cfg('git-path').";".
1610 " if test -d $package.git; then echo 1; else echo 0; fi");
1611 my $r= cmdoutput @cmd;
1612 if (defined $r and $r =~ m/^divert (\w+)$/) {
1614 my ($usedistro,) = access_distros();
1615 # NB that if we are pushing, $usedistro will be $distro/push
1616 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1617 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1618 progress "diverting to $divert (using config for $instead_distro)";
1619 return check_for_git();
1621 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1623 } elsif ($how eq 'url') {
1624 my $prefix = access_cfg('git-check-url','git-url');
1625 my $suffix = access_cfg('git-check-suffix','git-suffix',
1626 'RETURN-UNDEF') // '.git';
1627 my $url = "$prefix/$package$suffix";
1628 my @cmd = (@curl, qw(-sS -I), $url);
1629 my $result = cmdoutput @cmd;
1630 $result =~ s/^\S+ 200 .*\n\r?\n//;
1631 # curl -sS -I with https_proxy prints
1632 # HTTP/1.0 200 Connection established
1633 $result =~ m/^\S+ (404|200) /s or
1634 fail "unexpected results from git check query - ".
1635 Dumper($prefix, $result);
1637 if ($code eq '404') {
1639 } elsif ($code eq '200') {
1644 } elsif ($how eq 'true') {
1646 } elsif ($how eq 'false') {
1649 badcfg "unknown git-check \`$how'";
1653 sub create_remote_git_repo () {
1654 my $how = access_cfg('git-create');
1655 if ($how eq 'ssh-cmd') {
1657 (access_cfg_ssh, access_gituserhost(),
1658 access_runeinfo("git-create $package").
1659 "set -e; cd ".access_cfg('git-path').";".
1660 " cp -a _template $package.git");
1661 } elsif ($how eq 'true') {
1664 badcfg "unknown git-create \`$how'";
1668 our ($dsc_hash,$lastpush_mergeinput);
1669 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1671 our $ud = '.git/dgit/unpack';
1681 sub mktree_in_ud_here () {
1682 workarea_setup $gitcfgs{local};
1685 sub git_write_tree () {
1686 my $tree = cmdoutput @git, qw(write-tree);
1687 $tree =~ m/^\w+$/ or die "$tree ?";
1691 sub git_add_write_tree () {
1692 runcmd @git, qw(add -Af .);
1693 return git_write_tree();
1696 sub remove_stray_gits ($) {
1698 my @gitscmd = qw(find -name .git -prune -print0);
1699 debugcmd "|",@gitscmd;
1700 open GITS, "-|", @gitscmd or die $!;
1705 print STDERR "$us: warning: removing from $what: ",
1706 (messagequote $_), "\n";
1710 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1713 sub mktree_in_ud_from_only_subdir ($;$) {
1714 my ($what,$raw) = @_;
1716 # changes into the subdir
1718 die "expected one subdir but found @dirs ?" unless @dirs==1;
1719 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1723 remove_stray_gits($what);
1724 mktree_in_ud_here();
1726 my ($format, $fopts) = get_source_format();
1727 if (madformat($format)) {
1732 my $tree=git_add_write_tree();
1733 return ($tree,$dir);
1736 our @files_csum_info_fields =
1737 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1738 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1739 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1741 sub dsc_files_info () {
1742 foreach my $csumi (@files_csum_info_fields) {
1743 my ($fname, $module, $method) = @$csumi;
1744 my $field = $dsc->{$fname};
1745 next unless defined $field;
1746 eval "use $module; 1;" or die $@;
1748 foreach (split /\n/, $field) {
1750 m/^(\w+) (\d+) (\S+)$/ or
1751 fail "could not parse .dsc $fname line \`$_'";
1752 my $digester = eval "$module"."->$method;" or die $@;
1757 Digester => $digester,
1762 fail "missing any supported Checksums-* or Files field in ".
1763 $dsc->get_option('name');
1767 map { $_->{Filename} } dsc_files_info();
1770 sub files_compare_inputs (@) {
1775 my $showinputs = sub {
1776 return join "; ", map { $_->get_option('name') } @$inputs;
1779 foreach my $in (@$inputs) {
1781 my $in_name = $in->get_option('name');
1783 printdebug "files_compare_inputs $in_name\n";
1785 foreach my $csumi (@files_csum_info_fields) {
1786 my ($fname) = @$csumi;
1787 printdebug "files_compare_inputs $in_name $fname\n";
1789 my $field = $in->{$fname};
1790 next unless defined $field;
1793 foreach (split /\n/, $field) {
1796 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1797 fail "could not parse $in_name $fname line \`$_'";
1799 printdebug "files_compare_inputs $in_name $fname $f\n";
1803 my $re = \ $record{$f}{$fname};
1805 $fchecked{$f}{$in_name} = 1;
1807 fail "hash or size of $f varies in $fname fields".
1808 " (between: ".$showinputs->().")";
1813 @files = sort @files;
1814 $expected_files //= \@files;
1815 "@$expected_files" eq "@files" or
1816 fail "file list in $in_name varies between hash fields!";
1819 fail "$in_name has no files list field(s)";
1821 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1824 grep { keys %$_ == @$inputs-1 } values %fchecked
1825 or fail "no file appears in all file lists".
1826 " (looked in: ".$showinputs->().")";
1829 sub is_orig_file_in_dsc ($$) {
1830 my ($f, $dsc_files_info) = @_;
1831 return 0 if @$dsc_files_info <= 1;
1832 # One file means no origs, and the filename doesn't have a "what
1833 # part of dsc" component. (Consider versions ending `.orig'.)
1834 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1838 sub is_orig_file_of_vsn ($$) {
1839 my ($f, $upstreamvsn) = @_;
1840 my $base = srcfn $upstreamvsn, '';
1841 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1845 sub changes_update_origs_from_dsc ($$$$) {
1846 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1848 printdebug "checking origs needed ($upstreamvsn)...\n";
1849 $_ = getfield $changes, 'Files';
1850 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1851 fail "cannot find section/priority from .changes Files field";
1852 my $placementinfo = $1;
1854 printdebug "checking origs needed placement '$placementinfo'...\n";
1855 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1856 $l =~ m/\S+$/ or next;
1858 printdebug "origs $file | $l\n";
1859 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1860 printdebug "origs $file is_orig\n";
1861 my $have = archive_query('file_in_archive', $file);
1862 if (!defined $have) {
1864 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1870 printdebug "origs $file \$#\$have=$#$have\n";
1871 foreach my $h (@$have) {
1874 foreach my $csumi (@files_csum_info_fields) {
1875 my ($fname, $module, $method, $archivefield) = @$csumi;
1876 next unless defined $h->{$archivefield};
1877 $_ = $dsc->{$fname};
1878 next unless defined;
1879 m/^(\w+) .* \Q$file\E$/m or
1880 fail ".dsc $fname missing entry for $file";
1881 if ($h->{$archivefield} eq $1) {
1885 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1888 die "$file ".Dumper($h)." ?!" if $same && @differ;
1891 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1894 printdebug "origs $file f.same=$found_same".
1895 " #f._differ=$#found_differ\n";
1896 if (@found_differ && !$found_same) {
1898 "archive contains $file with different checksum",
1901 # Now we edit the changes file to add or remove it
1902 foreach my $csumi (@files_csum_info_fields) {
1903 my ($fname, $module, $method, $archivefield) = @$csumi;
1904 next unless defined $changes->{$fname};
1906 # in archive, delete from .changes if it's there
1907 $changed{$file} = "removed" if
1908 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1909 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1910 # not in archive, but it's here in the .changes
1912 my $dsc_data = getfield $dsc, $fname;
1913 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1915 $extra =~ s/ \d+ /$&$placementinfo /
1916 or die "$fname $extra >$dsc_data< ?"
1917 if $fname eq 'Files';
1918 $changes->{$fname} .= "\n". $extra;
1919 $changed{$file} = "added";
1924 foreach my $file (keys %changed) {
1926 "edited .changes for archive .orig contents: %s %s",
1927 $changed{$file}, $file;
1929 my $chtmp = "$changesfile.tmp";
1930 $changes->save($chtmp);
1932 rename $chtmp,$changesfile or die "$changesfile $!";
1934 progress "[new .changes left in $changesfile]";
1937 progress "$changesfile already has appropriate .orig(s) (if any)";
1941 sub make_commit ($) {
1943 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1946 sub make_commit_text ($) {
1949 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1951 print Dumper($text) if $debuglevel > 1;
1952 my $child = open2($out, $in, @cmd) or die $!;
1955 print $in $text or die $!;
1956 close $in or die $!;
1958 $h =~ m/^\w+$/ or die;
1960 printdebug "=> $h\n";
1963 waitpid $child, 0 == $child or die "$child $!";
1964 $? and failedcmd @cmd;
1968 sub clogp_authline ($) {
1970 my $author = getfield $clogp, 'Maintainer';
1971 if ($author =~ m/^[^"\@]+\,/) {
1972 # single entry Maintainer field with unquoted comma
1973 $author = ($& =~ y/,//rd).$'; # strip the comma
1975 # git wants a single author; any remaining commas in $author
1976 # are by now preceded by @ (or "). It seems safer to punt on
1977 # "..." for now rather than attempting to dequote or something.
1978 $author =~ s#,.*##ms unless $author =~ m/"/;
1979 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1980 my $authline = "$author $date";
1981 $authline =~ m/$git_authline_re/o or
1982 fail "unexpected commit author line format \`$authline'".
1983 " (was generated from changelog Maintainer field)";
1984 return ($1,$2,$3) if wantarray;
1988 sub vendor_patches_distro ($$) {
1989 my ($checkdistro, $what) = @_;
1990 return unless defined $checkdistro;
1992 my $series = "debian/patches/\L$checkdistro\E.series";
1993 printdebug "checking for vendor-specific $series ($what)\n";
1995 if (!open SERIES, "<", $series) {
1996 die "$series $!" unless $!==ENOENT;
2005 Unfortunately, this source package uses a feature of dpkg-source where
2006 the same source package unpacks to different source code on different
2007 distros. dgit cannot safely operate on such packages on affected
2008 distros, because the meaning of source packages is not stable.
2010 Please ask the distro/maintainer to remove the distro-specific series
2011 files and use a different technique (if necessary, uploading actually
2012 different packages, if different distros are supposed to have
2016 fail "Found active distro-specific series file for".
2017 " $checkdistro ($what): $series, cannot continue";
2019 die "$series $!" if SERIES->error;
2023 sub check_for_vendor_patches () {
2024 # This dpkg-source feature doesn't seem to be documented anywhere!
2025 # But it can be found in the changelog (reformatted):
2027 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2028 # Author: Raphael Hertzog <hertzog@debian.org>
2029 # Date: Sun Oct 3 09:36:48 2010 +0200
2031 # dpkg-source: correctly create .pc/.quilt_series with alternate
2034 # If you have debian/patches/ubuntu.series and you were
2035 # unpacking the source package on ubuntu, quilt was still
2036 # directed to debian/patches/series instead of
2037 # debian/patches/ubuntu.series.
2039 # debian/changelog | 3 +++
2040 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2041 # 2 files changed, 6 insertions(+), 1 deletion(-)
2044 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2045 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2046 "Dpkg::Vendor \`current vendor'");
2047 vendor_patches_distro(access_basedistro(),
2048 "(base) distro being accessed");
2049 vendor_patches_distro(access_nomdistro(),
2050 "(nominal) distro being accessed");
2053 sub generate_commits_from_dsc () {
2054 # See big comment in fetch_from_archive, below.
2055 # See also README.dsc-import.
2059 my @dfi = dsc_files_info();
2060 foreach my $fi (@dfi) {
2061 my $f = $fi->{Filename};
2062 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2063 my $upper_f = "../../../../$f";
2065 printdebug "considering reusing $f: ";
2067 if (link_ltarget "$upper_f,fetch", $f) {
2068 printdebug "linked (using ...,fetch).\n";
2069 } elsif ((printdebug "($!) "),
2071 fail "accessing ../$f,fetch: $!";
2072 } elsif (link_ltarget $upper_f, $f) {
2073 printdebug "linked.\n";
2074 } elsif ((printdebug "($!) "),
2076 fail "accessing ../$f: $!";
2078 printdebug "absent.\n";
2082 complete_file_from_dsc('.', $fi, \$refetched)
2085 printdebug "considering saving $f: ";
2087 if (link $f, $upper_f) {
2088 printdebug "linked.\n";
2089 } elsif ((printdebug "($!) "),
2091 fail "saving ../$f: $!";
2092 } elsif (!$refetched) {
2093 printdebug "no need.\n";
2094 } elsif (link $f, "$upper_f,fetch") {
2095 printdebug "linked (using ...,fetch).\n";
2096 } elsif ((printdebug "($!) "),
2098 fail "saving ../$f,fetch: $!";
2100 printdebug "cannot.\n";
2104 # We unpack and record the orig tarballs first, so that we only
2105 # need disk space for one private copy of the unpacked source.
2106 # But we can't make them into commits until we have the metadata
2107 # from the debian/changelog, so we record the tree objects now and
2108 # make them into commits later.
2110 my $upstreamv = upstreamversion $dsc->{version};
2111 my $orig_f_base = srcfn $upstreamv, '';
2113 foreach my $fi (@dfi) {
2114 # We actually import, and record as a commit, every tarball
2115 # (unless there is only one file, in which case there seems
2118 my $f = $fi->{Filename};
2119 printdebug "import considering $f ";
2120 (printdebug "only one dfi\n"), next if @dfi == 1;
2121 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2122 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2126 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2128 printdebug "Y ", (join ' ', map { $_//"(none)" }
2129 $compr_ext, $orig_f_part
2132 my $input = new IO::File $f, '<' or die "$f $!";
2136 if (defined $compr_ext) {
2138 Dpkg::Compression::compression_guess_from_filename $f;
2139 fail "Dpkg::Compression cannot handle file $f in source package"
2140 if defined $compr_ext && !defined $cname;
2142 new Dpkg::Compression::Process compression => $cname;
2143 @compr_cmd = $compr_proc->get_uncompress_cmdline();
2144 my $compr_fh = new IO::Handle;
2145 my $compr_pid = open $compr_fh, "-|" // die $!;
2147 open STDIN, "<&", $input or die $!;
2149 die "dgit (child): exec $compr_cmd[0]: $!\n";
2154 rmtree "_unpack-tar";
2155 mkdir "_unpack-tar" or die $!;
2156 my @tarcmd = qw(tar -x -f -
2157 --no-same-owner --no-same-permissions
2158 --no-acls --no-xattrs --no-selinux);
2159 my $tar_pid = fork // die $!;
2161 chdir "_unpack-tar" or die $!;
2162 open STDIN, "<&", $input or die $!;
2164 die "dgit (child): exec $tarcmd[0]: $!";
2166 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2167 !$? or failedcmd @tarcmd;
2170 (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2172 # finally, we have the results in "tarball", but maybe
2173 # with the wrong permissions
2175 runcmd qw(chmod -R +rwX _unpack-tar);
2176 changedir "_unpack-tar";
2177 remove_stray_gits($f);
2178 mktree_in_ud_here();
2180 my ($tree) = git_add_write_tree();
2181 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2182 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2184 printdebug "one subtree $1\n";
2186 printdebug "multiple subtrees\n";
2189 rmtree "_unpack-tar";
2191 my $ent = [ $f, $tree ];
2193 Orig => !!$orig_f_part,
2194 Sort => (!$orig_f_part ? 2 :
2195 $orig_f_part =~ m/-/g ? 1 :
2203 # put any without "_" first (spec is not clear whether files
2204 # are always in the usual order). Tarballs without "_" are
2205 # the main orig or the debian tarball.
2206 $a->{Sort} <=> $b->{Sort} or
2210 my $any_orig = grep { $_->{Orig} } @tartrees;
2212 my $dscfn = "$package.dsc";
2214 my $treeimporthow = 'package';
2216 open D, ">", $dscfn or die "$dscfn: $!";
2217 print D $dscdata or die "$dscfn: $!";
2218 close D or die "$dscfn: $!";
2219 my @cmd = qw(dpkg-source);
2220 push @cmd, '--no-check' if $dsc_checked;
2221 if (madformat $dsc->{format}) {
2222 push @cmd, '--skip-patches';
2223 $treeimporthow = 'unpatched';
2225 push @cmd, qw(-x --), $dscfn;
2228 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2229 if (madformat $dsc->{format}) {
2230 check_for_vendor_patches();
2234 if (madformat $dsc->{format}) {
2235 my @pcmd = qw(dpkg-source --before-build .);
2236 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2238 $dappliedtree = git_add_write_tree();
2241 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2242 debugcmd "|",@clogcmd;
2243 open CLOGS, "-|", @clogcmd or die $!;
2248 printdebug "import clog search...\n";
2251 my $stanzatext = do { local $/=""; <CLOGS>; };
2252 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2253 last if !defined $stanzatext;
2255 my $desc = "package changelog, entry no.$.";
2256 open my $stanzafh, "<", \$stanzatext or die;
2257 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2258 $clogp //= $thisstanza;
2260 printdebug "import clog $thisstanza->{version} $desc...\n";
2262 last if !$any_orig; # we don't need $r1clogp
2264 # We look for the first (most recent) changelog entry whose
2265 # version number is lower than the upstream version of this
2266 # package. Then the last (least recent) previous changelog
2267 # entry is treated as the one which introduced this upstream
2268 # version and used for the synthetic commits for the upstream
2271 # One might think that a more sophisticated algorithm would be
2272 # necessary. But: we do not want to scan the whole changelog
2273 # file. Stopping when we see an earlier version, which
2274 # necessarily then is an earlier upstream version, is the only
2275 # realistic way to do that. Then, either the earliest
2276 # changelog entry we have seen so far is indeed the earliest
2277 # upload of this upstream version; or there are only changelog
2278 # entries relating to later upstream versions (which is not
2279 # possible unless the changelog and .dsc disagree about the
2280 # version). Then it remains to choose between the physically
2281 # last entry in the file, and the one with the lowest version
2282 # number. If these are not the same, we guess that the
2283 # versions were created in a non-monotic order rather than
2284 # that the changelog entries have been misordered.
2286 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2288 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2289 $r1clogp = $thisstanza;
2291 printdebug "import clog $r1clogp->{version} becomes r1\n";
2293 die $! if CLOGS->error;
2294 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2296 $clogp or fail "package changelog has no entries!";
2298 my $authline = clogp_authline $clogp;
2299 my $changes = getfield $clogp, 'Changes';
2300 $changes =~ s/^\n//; # Changes: \n
2301 my $cversion = getfield $clogp, 'Version';
2304 $r1clogp //= $clogp; # maybe there's only one entry;
2305 my $r1authline = clogp_authline $r1clogp;
2306 # Strictly, r1authline might now be wrong if it's going to be
2307 # unused because !$any_orig. Whatever.
2309 printdebug "import tartrees authline $authline\n";
2310 printdebug "import tartrees r1authline $r1authline\n";
2312 foreach my $tt (@tartrees) {
2313 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2315 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2318 committer $r1authline
2322 [dgit import orig $tt->{F}]
2330 [dgit import tarball $package $cversion $tt->{F}]
2335 printdebug "import main commit\n";
2337 open C, ">../commit.tmp" or die $!;
2338 print C <<END or die $!;
2341 print C <<END or die $! foreach @tartrees;
2344 print C <<END or die $!;
2350 [dgit import $treeimporthow $package $cversion]
2354 my $rawimport_hash = make_commit qw(../commit.tmp);
2356 if (madformat $dsc->{format}) {
2357 printdebug "import apply patches...\n";
2359 # regularise the state of the working tree so that
2360 # the checkout of $rawimport_hash works nicely.
2361 my $dappliedcommit = make_commit_text(<<END);
2368 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2370 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2372 # We need the answers to be reproducible
2373 my @authline = clogp_authline($clogp);
2374 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2375 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2376 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2377 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2378 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2379 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2381 my $path = $ENV{PATH} or die;
2383 foreach my $use_absurd (qw(0 1)) {
2384 runcmd @git, qw(checkout -q unpa);
2385 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2386 local $ENV{PATH} = $path;
2389 progress "warning: $@";
2390 $path = "$absurdity:$path";
2391 progress "$us: trying slow absurd-git-apply...";
2392 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2397 die "forbid absurd git-apply\n" if $use_absurd
2398 && forceing [qw(import-gitapply-no-absurd)];
2399 die "only absurd git-apply!\n" if !$use_absurd
2400 && forceing [qw(import-gitapply-absurd)];
2402 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2403 local $ENV{PATH} = $path if $use_absurd;
2405 my @showcmd = (gbp_pq, qw(import));
2406 my @realcmd = shell_cmd
2407 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2408 debugcmd "+",@realcmd;
2409 if (system @realcmd) {
2410 die +(shellquote @showcmd).
2412 failedcmd_waitstatus()."\n";
2415 my $gapplied = git_rev_parse('HEAD');
2416 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2417 $gappliedtree eq $dappliedtree or
2419 gbp-pq import and dpkg-source disagree!
2420 gbp-pq import gave commit $gapplied
2421 gbp-pq import gave tree $gappliedtree
2422 dpkg-source --before-build gave tree $dappliedtree
2424 $rawimport_hash = $gapplied;
2429 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2434 progress "synthesised git commit from .dsc $cversion";
2436 my $rawimport_mergeinput = {
2437 Commit => $rawimport_hash,
2438 Info => "Import of source package",
2440 my @output = ($rawimport_mergeinput);
2442 if ($lastpush_mergeinput) {
2443 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2444 my $oversion = getfield $oldclogp, 'Version';
2446 version_compare($oversion, $cversion);
2448 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2449 { Message => <<END, ReverseParents => 1 });
2450 Record $package ($cversion) in archive suite $csuite
2452 } elsif ($vcmp > 0) {
2453 print STDERR <<END or die $!;
2455 Version actually in archive: $cversion (older)
2456 Last version pushed with dgit: $oversion (newer or same)
2459 @output = $lastpush_mergeinput;
2461 # Same version. Use what's in the server git branch,
2462 # discarding our own import. (This could happen if the
2463 # server automatically imports all packages into git.)
2464 @output = $lastpush_mergeinput;
2467 changedir '../../../..';
2472 sub complete_file_from_dsc ($$;$) {
2473 our ($dstdir, $fi, $refetched) = @_;
2474 # Ensures that we have, in $dstdir, the file $fi, with the correct
2475 # contents. (Downloading it from alongside $dscurl if necessary.)
2476 # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2477 # and will set $$refetched=1 if it did so (or tried to).
2479 my $f = $fi->{Filename};
2480 my $tf = "$dstdir/$f";
2484 my $checkhash = sub {
2485 open F, "<", "$tf" or die "$tf: $!";
2486 $fi->{Digester}->reset();
2487 $fi->{Digester}->addfile(*F);
2488 F->error and die $!;
2489 $got = $fi->{Digester}->hexdigest();
2490 return $got eq $fi->{Hash};
2493 if (stat_exists $tf) {
2494 if ($checkhash->()) {
2495 progress "using existing $f";
2499 fail "file $f has hash $got but .dsc".
2500 " demands hash $fi->{Hash} ".
2501 "(perhaps you should delete this file?)";
2503 progress "need to fetch correct version of $f";
2504 unlink $tf or die "$tf $!";
2507 printdebug "$tf does not exist, need to fetch\n";
2511 $furl =~ s{/[^/]+$}{};
2513 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2514 die "$f ?" if $f =~ m#/#;
2515 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2516 return 0 if !act_local();
2519 fail "file $f has hash $got but .dsc".
2520 " demands hash $fi->{Hash} ".
2521 "(got wrong file from archive!)";
2526 sub ensure_we_have_orig () {
2527 my @dfi = dsc_files_info();
2528 foreach my $fi (@dfi) {
2529 my $f = $fi->{Filename};
2530 next unless is_orig_file_in_dsc($f, \@dfi);
2531 complete_file_from_dsc('..', $fi)
2536 #---------- git fetch ----------
2538 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2539 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2541 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2542 # locally fetched refs because they have unhelpful names and clutter
2543 # up gitk etc. So we track whether we have "used up" head ref (ie,
2544 # whether we have made another local ref which refers to this object).
2546 # (If we deleted them unconditionally, then we might end up
2547 # re-fetching the same git objects each time dgit fetch was run.)
2549 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2550 # in git_fetch_us to fetch the refs in question, and possibly a call
2551 # to lrfetchref_used.
2553 our (%lrfetchrefs_f, %lrfetchrefs_d);
2554 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2556 sub lrfetchref_used ($) {
2557 my ($fullrefname) = @_;
2558 my $objid = $lrfetchrefs_f{$fullrefname};
2559 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2562 sub git_lrfetch_sane {
2563 my ($url, $supplementary, @specs) = @_;
2564 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2565 # at least as regards @specs. Also leave the results in
2566 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2567 # able to clean these up.
2569 # With $supplementary==1, @specs must not contain wildcards
2570 # and we add to our previous fetches (non-atomically).
2572 # This is rather miserable:
2573 # When git fetch --prune is passed a fetchspec ending with a *,
2574 # it does a plausible thing. If there is no * then:
2575 # - it matches subpaths too, even if the supplied refspec
2576 # starts refs, and behaves completely madly if the source
2577 # has refs/refs/something. (See, for example, Debian #NNNN.)
2578 # - if there is no matching remote ref, it bombs out the whole
2580 # We want to fetch a fixed ref, and we don't know in advance
2581 # if it exists, so this is not suitable.
2583 # Our workaround is to use git ls-remote. git ls-remote has its
2584 # own qairks. Notably, it has the absurd multi-tail-matching
2585 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2586 # refs/refs/foo etc.
2588 # Also, we want an idempotent snapshot, but we have to make two
2589 # calls to the remote: one to git ls-remote and to git fetch. The
2590 # solution is use git ls-remote to obtain a target state, and
2591 # git fetch to try to generate it. If we don't manage to generate
2592 # the target state, we try again.
2594 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2596 my $specre = join '|', map {
2599 my $wildcard = $x =~ s/\\\*$/.*/;
2600 die if $wildcard && $supplementary;
2603 printdebug "git_lrfetch_sane specre=$specre\n";
2604 my $wanted_rref = sub {
2606 return m/^(?:$specre)$/;
2609 my $fetch_iteration = 0;
2612 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2613 if (++$fetch_iteration > 10) {
2614 fail "too many iterations trying to get sane fetch!";
2617 my @look = map { "refs/$_" } @specs;
2618 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2622 open GITLS, "-|", @lcmd or die $!;
2624 printdebug "=> ", $_;
2625 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2626 my ($objid,$rrefname) = ($1,$2);
2627 if (!$wanted_rref->($rrefname)) {
2629 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2633 $wantr{$rrefname} = $objid;
2636 close GITLS or failedcmd @lcmd;
2638 # OK, now %want is exactly what we want for refs in @specs
2640 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2641 "+refs/$_:".lrfetchrefs."/$_";
2644 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2646 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2647 runcmd_ordryrun_local @fcmd if @fspecs;
2649 if (!$supplementary) {
2650 %lrfetchrefs_f = ();
2654 git_for_each_ref(lrfetchrefs, sub {
2655 my ($objid,$objtype,$lrefname,$reftail) = @_;
2656 $lrfetchrefs_f{$lrefname} = $objid;
2657 $objgot{$objid} = 1;
2660 if ($supplementary) {
2664 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2665 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2666 if (!exists $wantr{$rrefname}) {
2667 if ($wanted_rref->($rrefname)) {
2669 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2673 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2676 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2677 delete $lrfetchrefs_f{$lrefname};
2681 foreach my $rrefname (sort keys %wantr) {
2682 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2683 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2684 my $want = $wantr{$rrefname};
2685 next if $got eq $want;
2686 if (!defined $objgot{$want}) {
2688 warning: git ls-remote suggests we want $lrefname
2689 warning: and it should refer to $want
2690 warning: but git fetch didn't fetch that object to any relevant ref.
2691 warning: This may be due to a race with someone updating the server.
2692 warning: Will try again...
2694 next FETCH_ITERATION;
2697 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2699 runcmd_ordryrun_local @git, qw(update-ref -m),
2700 "dgit fetch git fetch fixup", $lrefname, $want;
2701 $lrfetchrefs_f{$lrefname} = $want;
2706 if (defined $csuite) {
2707 printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2708 git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2709 my ($objid,$objtype,$lrefname,$reftail) = @_;
2710 next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2711 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2715 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2716 Dumper(\%lrfetchrefs_f);
2719 sub git_fetch_us () {
2720 # Want to fetch only what we are going to use, unless
2721 # deliberately-not-ff, in which case we must fetch everything.
2723 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2725 (quiltmode_splitbrain
2726 ? (map { $_->('*',access_nomdistro) }
2727 \&debiantag_new, \&debiantag_maintview)
2728 : debiantags('*',access_nomdistro));
2729 push @specs, server_branch($csuite);
2730 push @specs, $rewritemap;
2731 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2733 my $url = access_giturl();
2734 git_lrfetch_sane $url, 0, @specs;
2737 my @tagpats = debiantags('*',access_nomdistro);
2739 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2740 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2741 printdebug "currently $fullrefname=$objid\n";
2742 $here{$fullrefname} = $objid;
2744 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2745 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2746 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2747 printdebug "offered $lref=$objid\n";
2748 if (!defined $here{$lref}) {
2749 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2750 runcmd_ordryrun_local @upd;
2751 lrfetchref_used $fullrefname;
2752 } elsif ($here{$lref} eq $objid) {
2753 lrfetchref_used $fullrefname;
2756 "Not updating $lref from $here{$lref} to $objid.\n";
2761 #---------- dsc and archive handling ----------
2763 sub mergeinfo_getclogp ($) {
2764 # Ensures thit $mi->{Clogp} exists and returns it
2766 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2769 sub mergeinfo_version ($) {
2770 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2773 sub fetch_from_archive_record_1 ($) {
2775 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2776 'DGIT_ARCHIVE', $hash;
2777 cmdoutput @git, qw(log -n2), $hash;
2778 # ... gives git a chance to complain if our commit is malformed
2781 sub fetch_from_archive_record_2 ($) {
2783 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2787 dryrun_report @upd_cmd;
2791 sub parse_dsc_field_def_dsc_distro () {
2792 $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2793 dgit.default.distro);
2796 sub parse_dsc_field ($$) {
2797 my ($dsc, $what) = @_;
2799 foreach my $field (@ourdscfield) {
2800 $f = $dsc->{$field};
2805 progress "$what: NO git hash";
2806 parse_dsc_field_def_dsc_distro();
2807 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2808 = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2809 progress "$what: specified git info ($dsc_distro)";
2810 $dsc_hint_tag = [ $dsc_hint_tag ];
2811 } elsif ($f =~ m/^\w+\s*$/) {
2813 parse_dsc_field_def_dsc_distro();
2814 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2816 progress "$what: specified git hash";
2818 fail "$what: invalid Dgit info";
2822 sub resolve_dsc_field_commit ($$) {
2823 my ($already_distro, $already_mapref) = @_;
2825 return unless defined $dsc_hash;
2828 defined $already_mapref &&
2829 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2830 ? $already_mapref : undef;
2834 my ($what, @fetch) = @_;
2836 local $idistro = $dsc_distro;
2837 my $lrf = lrfetchrefs;
2839 if (!$chase_dsc_distro) {
2841 "not chasing .dsc distro $dsc_distro: not fetching $what";
2846 ".dsc names distro $dsc_distro: fetching $what";
2848 my $url = access_giturl();
2849 if (!defined $url) {
2850 defined $dsc_hint_url or fail <<END;
2851 .dsc Dgit metadata is in context of distro $dsc_distro
2852 for which we have no configured url and .dsc provides no hint
2855 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2856 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2857 parse_cfg_bool "dsc-url-proto-ok", 'false',
2858 cfg("dgit.dsc-url-proto-ok.$proto",
2859 "dgit.default.dsc-url-proto-ok")
2861 .dsc Dgit metadata is in context of distro $dsc_distro
2862 for which we have no configured url;
2863 .dsc provides hinted url with protocol $proto which is unsafe.
2864 (can be overridden by config - consult documentation)
2866 $url = $dsc_hint_url;
2869 git_lrfetch_sane $url, 1, @fetch;
2874 my $rewrite_enable = do {
2875 local $idistro = $dsc_distro;
2876 access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2879 if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2880 if (!defined $mapref) {
2881 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2882 $mapref = $lrf.'/'.$rewritemap;
2884 my $rewritemapdata = git_cat_file $mapref.':map';
2885 if (defined $rewritemapdata
2886 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2888 "server's git history rewrite map contains a relevant entry!";
2891 if (defined $dsc_hash) {
2892 progress "using rewritten git hash in place of .dsc value";
2894 progress "server data says .dsc hash is to be disregarded";
2899 if (!defined git_cat_file $dsc_hash) {
2900 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2901 my $lrf = $do_fetch->("additional commits", @tags) &&
2902 defined git_cat_file $dsc_hash
2904 .dsc Dgit metadata requires commit $dsc_hash
2905 but we could not obtain that object anywhere.
2907 foreach my $t (@tags) {
2908 my $fullrefname = $lrf.'/'.$t;
2909 # print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2910 next unless $lrfetchrefs_f{$fullrefname};
2911 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2912 lrfetchref_used $fullrefname;
2917 sub fetch_from_archive () {
2918 ensure_setup_existing_tree();
2920 # Ensures that lrref() is what is actually in the archive, one way
2921 # or another, according to us - ie this client's
2922 # appropritaely-updated archive view. Also returns the commit id.
2923 # If there is nothing in the archive, leaves lrref alone and
2924 # returns undef. git_fetch_us must have already been called.
2928 parse_dsc_field($dsc, 'last upload to archive');
2929 resolve_dsc_field_commit access_basedistro,
2930 lrfetchrefs."/".$rewritemap
2932 progress "no version available from the archive";
2935 # If the archive's .dsc has a Dgit field, there are three
2936 # relevant git commitids we need to choose between and/or merge
2938 # 1. $dsc_hash: the Dgit field from the archive
2939 # 2. $lastpush_hash: the suite branch on the dgit git server
2940 # 3. $lastfetch_hash: our local tracking brach for the suite
2942 # These may all be distinct and need not be in any fast forward
2945 # If the dsc was pushed to this suite, then the server suite
2946 # branch will have been updated; but it might have been pushed to
2947 # a different suite and copied by the archive. Conversely a more
2948 # recent version may have been pushed with dgit but not appeared
2949 # in the archive (yet).
2951 # $lastfetch_hash may be awkward because archive imports
2952 # (particularly, imports of Dgit-less .dscs) are performed only as
2953 # needed on individual clients, so different clients may perform a
2954 # different subset of them - and these imports are only made
2955 # public during push. So $lastfetch_hash may represent a set of
2956 # imports different to a subsequent upload by a different dgit
2959 # Our approach is as follows:
2961 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2962 # descendant of $dsc_hash, then it was pushed by a dgit user who
2963 # had based their work on $dsc_hash, so we should prefer it.
2964 # Otherwise, $dsc_hash was installed into this suite in the
2965 # archive other than by a dgit push, and (necessarily) after the
2966 # last dgit push into that suite (since a dgit push would have
2967 # been descended from the dgit server git branch); thus, in that
2968 # case, we prefer the archive's version (and produce a
2969 # pseudo-merge to overwrite the dgit server git branch).
2971 # (If there is no Dgit field in the archive's .dsc then
2972 # generate_commit_from_dsc uses the version numbers to decide
2973 # whether the suite branch or the archive is newer. If the suite
2974 # branch is newer it ignores the archive's .dsc; otherwise it
2975 # generates an import of the .dsc, and produces a pseudo-merge to
2976 # overwrite the suite branch with the archive contents.)
2978 # The outcome of that part of the algorithm is the `public view',
2979 # and is same for all dgit clients: it does not depend on any
2980 # unpublished history in the local tracking branch.
2982 # As between the public view and the local tracking branch: The
2983 # local tracking branch is only updated by dgit fetch, and
2984 # whenever dgit fetch runs it includes the public view in the
2985 # local tracking branch. Therefore if the public view is not
2986 # descended from the local tracking branch, the local tracking
2987 # branch must contain history which was imported from the archive
2988 # but never pushed; and, its tip is now out of date. So, we make
2989 # a pseudo-merge to overwrite the old imports and stitch the old
2992 # Finally: we do not necessarily reify the public view (as
2993 # described above). This is so that we do not end up stacking two
2994 # pseudo-merges. So what we actually do is figure out the inputs
2995 # to any public view pseudo-merge and put them in @mergeinputs.
2998 # $mergeinputs[]{Commit}
2999 # $mergeinputs[]{Info}
3000 # $mergeinputs[0] is the one whose tree we use
3001 # @mergeinputs is in the order we use in the actual commit)
3004 # $mergeinputs[]{Message} is a commit message to use
3005 # $mergeinputs[]{ReverseParents} if def specifies that parent
3006 # list should be in opposite order
3007 # Such an entry has no Commit or Info. It applies only when found
3008 # in the last entry. (This ugliness is to support making
3009 # identical imports to previous dgit versions.)
3011 my $lastpush_hash = git_get_ref(lrfetchref());
3012 printdebug "previous reference hash=$lastpush_hash\n";
3013 $lastpush_mergeinput = $lastpush_hash && {
3014 Commit => $lastpush_hash,
3015 Info => "dgit suite branch on dgit git server",
3018 my $lastfetch_hash = git_get_ref(lrref());
3019 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3020 my $lastfetch_mergeinput = $lastfetch_hash && {
3021 Commit => $lastfetch_hash,
3022 Info => "dgit client's archive history view",
3025 my $dsc_mergeinput = $dsc_hash && {
3026 Commit => $dsc_hash,
3027 Info => "Dgit field in .dsc from archive",
3031 my $del_lrfetchrefs = sub {
3034 printdebug "del_lrfetchrefs...\n";
3035 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3036 my $objid = $lrfetchrefs_d{$fullrefname};
3037 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3039 $gur ||= new IO::Handle;
3040 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3042 printf $gur "delete %s %s\n", $fullrefname, $objid;
3045 close $gur or failedcmd "git update-ref delete lrfetchrefs";
3049 if (defined $dsc_hash) {
3050 ensure_we_have_orig();
3051 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3052 @mergeinputs = $dsc_mergeinput
3053 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3054 print STDERR <<END or die $!;
3056 Git commit in archive is behind the last version allegedly pushed/uploaded.
3057 Commit referred to by archive: $dsc_hash
3058 Last version pushed with dgit: $lastpush_hash
3061 @mergeinputs = ($lastpush_mergeinput);
3063 # Archive has .dsc which is not a descendant of the last dgit
3064 # push. This can happen if the archive moves .dscs about.
3065 # Just follow its lead.
3066 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3067 progress "archive .dsc names newer git commit";
3068 @mergeinputs = ($dsc_mergeinput);
3070 progress "archive .dsc names other git commit, fixing up";
3071 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3075 @mergeinputs = generate_commits_from_dsc();
3076 # We have just done an import. Now, our import algorithm might
3077 # have been improved. But even so we do not want to generate
3078 # a new different import of the same package. So if the
3079 # version numbers are the same, just use our existing version.
3080 # If the version numbers are different, the archive has changed
3081 # (perhaps, rewound).
3082 if ($lastfetch_mergeinput &&
3083 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3084 (mergeinfo_version $mergeinputs[0]) )) {
3085 @mergeinputs = ($lastfetch_mergeinput);
3087 } elsif ($lastpush_hash) {
3088 # only in git, not in the archive yet
3089 @mergeinputs = ($lastpush_mergeinput);
3090 print STDERR <<END or die $!;
3092 Package not found in the archive, but has allegedly been pushed using dgit.
3096 printdebug "nothing found!\n";
3097 if (defined $skew_warning_vsn) {
3098 print STDERR <<END or die $!;
3100 Warning: relevant archive skew detected.
3101 Archive allegedly contains $skew_warning_vsn
3102 But we were not able to obtain any version from the archive or git.
3106 unshift @end, $del_lrfetchrefs;
3110 if ($lastfetch_hash &&
3112 my $h = $_->{Commit};
3113 $h and is_fast_fwd($lastfetch_hash, $h);
3114 # If true, one of the existing parents of this commit
3115 # is a descendant of the $lastfetch_hash, so we'll
3116 # be ff from that automatically.
3120 push @mergeinputs, $lastfetch_mergeinput;
3123 printdebug "fetch mergeinfos:\n";
3124 foreach my $mi (@mergeinputs) {
3126 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3128 printdebug sprintf " ReverseParents=%d Message=%s",
3129 $mi->{ReverseParents}, $mi->{Message};
3133 my $compat_info= pop @mergeinputs
3134 if $mergeinputs[$#mergeinputs]{Message};
3136 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3139 if (@mergeinputs > 1) {
3141 my $tree_commit = $mergeinputs[0]{Commit};
3143 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3144 $tree =~ m/\n\n/; $tree = $`;
3145 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3148 # We use the changelog author of the package in question the
3149 # author of this pseudo-merge. This is (roughly) correct if
3150 # this commit is simply representing aa non-dgit upload.
3151 # (Roughly because it does not record sponsorship - but we
3152 # don't have sponsorship info because that's in the .changes,
3153 # which isn't in the archivw.)
3155 # But, it might be that we are representing archive history
3156 # updates (including in-archive copies). These are not really
3157 # the responsibility of the person who created the .dsc, but
3158 # there is no-one whose name we should better use. (The
3159 # author of the .dsc-named commit is clearly worse.)
3161 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3162 my $author = clogp_authline $useclogp;
3163 my $cversion = getfield $useclogp, 'Version';
3165 my $mcf = ".git/dgit/mergecommit";
3166 open MC, ">", $mcf or die "$mcf $!";
3167 print MC <<END or die $!;
3171 my @parents = grep { $_->{Commit} } @mergeinputs;
3172 @parents = reverse @parents if $compat_info->{ReverseParents};
3173 print MC <<END or die $! foreach @parents;
3177 print MC <<END or die $!;
3183 if (defined $compat_info->{Message}) {
3184 print MC $compat_info->{Message} or die $!;
3186 print MC <<END or die $!;
3187 Record $package ($cversion) in archive suite $csuite
3191 my $message_add_info = sub {
3193 my $mversion = mergeinfo_version $mi;
3194 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3198 $message_add_info->($mergeinputs[0]);
3199 print MC <<END or die $!;
3200 should be treated as descended from
3202 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3206 $hash = make_commit $mcf;
3208 $hash = $mergeinputs[0]{Commit};
3210 printdebug "fetch hash=$hash\n";
3213 my ($lasth, $what) = @_;
3214 return unless $lasth;
3215 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3218 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3220 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3222 fetch_from_archive_record_1($hash);
3224 if (defined $skew_warning_vsn) {
3226 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3227 my $gotclogp = commit_getclogp($hash);
3228 my $got_vsn = getfield $gotclogp, 'Version';
3229 printdebug "SKEW CHECK GOT $got_vsn\n";
3230 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3231 print STDERR <<END or die $!;
3233 Warning: archive skew detected. Using the available version:
3234 Archive allegedly contains $skew_warning_vsn
3235 We were able to obtain only $got_vsn
3241 if ($lastfetch_hash ne $hash) {
3242 fetch_from_archive_record_2($hash);
3245 lrfetchref_used lrfetchref();
3247 check_gitattrs($hash, "fetched source tree");
3249 unshift @end, $del_lrfetchrefs;
3253 sub set_local_git_config ($$) {
3255 runcmd @git, qw(config), $k, $v;
3258 sub setup_mergechangelogs (;$) {
3260 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3262 my $driver = 'dpkg-mergechangelogs';
3263 my $cb = "merge.$driver";
3264 my $attrs = '.git/info/attributes';
3265 ensuredir '.git/info';
3267 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3268 if (!open ATTRS, "<", $attrs) {
3269 $!==ENOENT or die "$attrs: $!";
3273 next if m{^debian/changelog\s};
3274 print NATTRS $_, "\n" or die $!;
3276 ATTRS->error and die $!;
3279 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3282 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3283 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3285 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3288 sub setup_useremail (;$) {
3290 return unless $always || access_cfg_bool(1, 'setup-useremail');
3293 my ($k, $envvar) = @_;
3294 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3295 return unless defined $v;
3296 set_local_git_config "user.$k", $v;
3299 $setup->('email', 'DEBEMAIL');
3300 $setup->('name', 'DEBFULLNAME');
3303 sub ensure_setup_existing_tree () {
3304 my $k = "remote.$remotename.skipdefaultupdate";
3305 my $c = git_get_config $k;
3306 return if defined $c;
3307 set_local_git_config $k, 'true';
3310 sub open_gitattrs () {
3311 my $gai = new IO::File ".git/info/attributes"
3313 or die "open .git/info/attributes: $!";
3317 sub is_gitattrs_setup () {
3318 my $gai = open_gitattrs();
3319 return 0 unless $gai;
3321 return 1 if m{^\[attr\]dgit-defuse-attrs\s};
3323 $gai->error and die $!;
3327 sub setup_gitattrs (;$) {
3329 return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3331 if (is_gitattrs_setup()) {
3333 [attr]dgit-defuse-attrs already found in .git/info/attributes
3334 not doing further gitattributes setup
3338 my $af = ".git/info/attributes";
3339 ensuredir '.git/info';
3340 open GAO, "> $af.new" or die $!;
3341 print GAO <<END or die $!;
3343 [attr]dgit-defuse-attrs $negate_harmful_gitattrs
3344 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3346 my $gai = open_gitattrs();
3350 print GAO $_, "\n" or die $!;
3352 $gai->error and die $!;
3354 close GAO or die $!;
3355 rename "$af.new", "$af" or die "install $af: $!";
3358 sub setup_new_tree () {
3359 setup_mergechangelogs();
3364 sub check_gitattrs ($$) {
3365 my ($treeish, $what) = @_;
3367 return if is_gitattrs_setup;
3370 my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3372 my $gafl = new IO::File;
3373 open $gafl, "-|", @cmd or die $!;
3376 s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3378 next unless m{(?:^|/)\.gitattributes$};
3380 # oh dear, found one
3382 dgit: warning: $what contains .gitattributes
3383 dgit: .gitattributes have not been defused. Recommended: dgit setup-new-tree.
3388 # tree contains no .gitattributes files
3389 $?=0; $!=0; close $gafl or failedcmd @cmd;
3393 sub multisuite_suite_child ($$$) {
3394 my ($tsuite, $merginputs, $fn) = @_;
3395 # in child, sets things up, calls $fn->(), and returns undef
3396 # in parent, returns canonical suite name for $tsuite
3397 my $canonsuitefh = IO::File::new_tmpfile;
3398 my $pid = fork // die $!;
3402 $us .= " [$isuite]";
3403 $debugprefix .= " ";
3404 progress "fetching $tsuite...";
3405 canonicalise_suite();
3406 print $canonsuitefh $csuite, "\n" or die $!;
3407 close $canonsuitefh or die $!;
3411 waitpid $pid,0 == $pid or die $!;
3412 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3413 seek $canonsuitefh,0,0 or die $!;
3414 local $csuite = <$canonsuitefh>;
3415 die $! unless defined $csuite && chomp $csuite;
3417 printdebug "multisuite $tsuite missing\n";
3420 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3421 push @$merginputs, {
3428 sub fork_for_multisuite ($) {
3429 my ($before_fetch_merge) = @_;
3430 # if nothing unusual, just returns ''
3433 # returns 0 to caller in child, to do first of the specified suites
3434 # in child, $csuite is not yet set
3436 # returns 1 to caller in parent, to finish up anything needed after
3437 # in parent, $csuite is set to canonicalised portmanteau
3439 my $org_isuite = $isuite;
3440 my @suites = split /\,/, $isuite;
3441 return '' unless @suites > 1;
3442 printdebug "fork_for_multisuite: @suites\n";
3446 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3448 return 0 unless defined $cbasesuite;
3450 fail "package $package missing in (base suite) $cbasesuite"
3451 unless @mergeinputs;
3453 my @csuites = ($cbasesuite);
3455 $before_fetch_merge->();
3457 foreach my $tsuite (@suites[1..$#suites]) {
3458 $tsuite =~ s/^-/$cbasesuite-/;
3459 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3465 # xxx collecte the ref here
3467 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3468 push @csuites, $csubsuite;
3471 foreach my $mi (@mergeinputs) {
3472 my $ref = git_get_ref $mi->{Ref};
3473 die "$mi->{Ref} ?" unless length $ref;
3474 $mi->{Commit} = $ref;
3477 $csuite = join ",", @csuites;
3479 my $previous = git_get_ref lrref;
3481 unshift @mergeinputs, {
3482 Commit => $previous,
3483 Info => "local combined tracking branch",
3485 "archive seems to have rewound: local tracking branch is ahead!",
3489 foreach my $ix (0..$#mergeinputs) {
3490 $mergeinputs[$ix]{Index} = $ix;
3493 @mergeinputs = sort {
3494 -version_compare(mergeinfo_version $a,
3495 mergeinfo_version $b) # highest version first
3497 $a->{Index} <=> $b->{Index}; # earliest in spec first
3503 foreach my $mi (@mergeinputs) {
3504 printdebug "multisuite merge check $mi->{Info}\n";
3505 foreach my $previous (@needed) {
3506 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3507 printdebug "multisuite merge un-needed $previous->{Info}\n";
3511 printdebug "multisuite merge this-needed\n";
3512 $mi->{Character} = '+';
3515 $needed[0]{Character} = '*';
3517 my $output = $needed[0]{Commit};
3520 printdebug "multisuite merge nontrivial\n";
3521 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3523 my $commit = "tree $tree\n";
3524 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3525 "Input branches:\n";
3527 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3528 printdebug "multisuite merge include $mi->{Info}\n";
3529 $mi->{Character} //= ' ';
3530 $commit .= "parent $mi->{Commit}\n";
3531 $msg .= sprintf " %s %-25s %s\n",
3533 (mergeinfo_version $mi),
3536 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3538 " * marks the highest version branch, which choose to use\n".
3539 " + marks each branch which was not already an ancestor\n\n".
3540 "[dgit multi-suite $csuite]\n";
3542 "author $authline\n".
3543 "committer $authline\n\n";
3544 $output = make_commit_text $commit.$msg;
3545 printdebug "multisuite merge generated $output\n";
3548 fetch_from_archive_record_1($output);
3549 fetch_from_archive_record_2($output);
3551 progress "calculated combined tracking suite $csuite";
3556 sub clone_set_head () {
3557 open H, "> .git/HEAD" or die $!;
3558 print H "ref: ".lref()."\n" or die $!;
3561 sub clone_finish ($) {
3563 runcmd @git, qw(reset --hard), lrref();
3564 runcmd qw(bash -ec), <<'END';
3566 git ls-tree -r --name-only -z HEAD | \
3567 xargs -0r touch -h -r . --
3569 printdone "ready for work in $dstdir";
3573 # in multisuite, returns twice!
3574 # once in parent after first suite fetched,
3575 # and then again in child after everything is finished
3577 badusage "dry run makes no sense with clone" unless act_local();
3579 my $multi_fetched = fork_for_multisuite(sub {
3580 printdebug "multi clone before fetch merge\n";
3583 if ($multi_fetched) {
3584 printdebug "multi clone after fetch merge\n";
3586 clone_finish($dstdir);
3589 printdebug "clone main body\n";
3591 canonicalise_suite();
3592 my $hasgit = check_for_git();
3593 mkdir $dstdir or fail "create \`$dstdir': $!";
3595 runcmd @git, qw(init -q);
3598 my $giturl = access_giturl(1);
3599 if (defined $giturl) {
3600 runcmd @git, qw(remote add), 'origin', $giturl;
3603 progress "fetching existing git history";
3605 runcmd_ordryrun_local @git, qw(fetch origin);
3607 progress "starting new git history";
3609 fetch_from_archive() or no_such_package;
3610 my $vcsgiturl = $dsc->{'Vcs-Git'};
3611 if (length $vcsgiturl) {
3612 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3613 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3615 clone_finish($dstdir);
3619 canonicalise_suite();
3620 if (check_for_git()) {
3623 fetch_from_archive() or no_such_package();
3624 printdone "fetched into ".lrref();
3628 my $multi_fetched = fork_for_multisuite(sub { });
3629 fetch() unless $multi_fetched; # parent
3630 return if $multi_fetched eq '0'; # child
3631 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3633 printdone "fetched to ".lrref()." and merged into HEAD";
3636 sub check_not_dirty () {
3637 foreach my $f (qw(local-options local-patch-header)) {
3638 if (stat_exists "debian/source/$f") {
3639 fail "git tree contains debian/source/$f";
3643 return if $ignoredirty;
3645 my @cmd = (@git, qw(diff --quiet HEAD));
3647 $!=0; $?=-1; system @cmd;
3650 fail "working tree is dirty (does not match HEAD)";
3656 sub commit_admin ($) {
3659 runcmd_ordryrun_local @git, qw(commit -m), $m;
3662 sub commit_quilty_patch () {
3663 my $output = cmdoutput @git, qw(status --porcelain);
3665 foreach my $l (split /\n/, $output) {
3666 next unless $l =~ m/\S/;
3667 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3671 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3673 progress "nothing quilty to commit, ok.";
3676 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3677 runcmd_ordryrun_local @git, qw(add -f), @adds;
3679 Commit Debian 3.0 (quilt) metadata
3681 [dgit ($our_version) quilt-fixup]
3685 sub get_source_format () {
3687 if (open F, "debian/source/options") {
3691 s/\s+$//; # ignore missing final newline
3693 my ($k, $v) = ($`, $'); #');
3694 $v =~ s/^"(.*)"$/$1/;
3700 F->error and die $!;
3703 die $! unless $!==&ENOENT;
3706 if (!open F, "debian/source/format") {
3707 die $! unless $!==&ENOENT;
3711 F->error and die $!;
3713 return ($_, \%options);
3716 sub madformat_wantfixup ($) {
3718 return 0 unless $format eq '3.0 (quilt)';
3719 our $quilt_mode_warned;
3720 if ($quilt_mode eq 'nocheck') {
3721 progress "Not doing any fixup of \`$format' due to".
3722 " ----no-quilt-fixup or --quilt=nocheck"
3723 unless $quilt_mode_warned++;
3726 progress "Format \`$format', need to check/update patch stack"
3727 unless $quilt_mode_warned++;
3731 sub maybe_split_brain_save ($$$) {
3732 my ($headref, $dgitview, $msg) = @_;
3733 # => message fragment "$saved" describing disposition of $dgitview
3734 return "commit id $dgitview" unless defined $split_brain_save;
3735 my @cmd = (shell_cmd "cd ../../../..",
3736 @git, qw(update-ref -m),
3737 "dgit --dgit-view-save $msg HEAD=$headref",
3738 $split_brain_save, $dgitview);
3740 return "and left in $split_brain_save";
3743 # An "infopair" is a tuple [ $thing, $what ]
3744 # (often $thing is a commit hash; $what is a description)
3746 sub infopair_cond_equal ($$) {
3748 $x->[0] eq $y->[0] or fail <<END;
3749 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3753 sub infopair_lrf_tag_lookup ($$) {
3754 my ($tagnames, $what) = @_;
3755 # $tagname may be an array ref
3756 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3757 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3758 foreach my $tagname (@tagnames) {
3759 my $lrefname = lrfetchrefs."/tags/$tagname";
3760 my $tagobj = $lrfetchrefs_f{$lrefname};
3761 next unless defined $tagobj;
3762 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3763 return [ git_rev_parse($tagobj), $what ];
3765 fail @tagnames==1 ? <<END : <<END;
3766 Wanted tag $what (@tagnames) on dgit server, but not found
3768 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3772 sub infopair_cond_ff ($$) {
3773 my ($anc,$desc) = @_;
3774 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3775 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3779 sub pseudomerge_version_check ($$) {
3780 my ($clogp, $archive_hash) = @_;
3782 my $arch_clogp = commit_getclogp $archive_hash;
3783 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3784 'version currently in archive' ];
3785 if (defined $overwrite_version) {
3786 if (length $overwrite_version) {
3787 infopair_cond_equal([ $overwrite_version,
3788 '--overwrite= version' ],
3791 my $v = $i_arch_v->[0];
3792 progress "Checking package changelog for archive version $v ...";
3795 my @xa = ("-f$v", "-t$v");
3796 my $vclogp = parsechangelog @xa;
3799 [ (getfield $vclogp, $fn),
3800 "$fn field from dpkg-parsechangelog @xa" ];
3802 my $cv = $gf->('Version');
3803 infopair_cond_equal($i_arch_v, $cv);
3804 $cd = $gf->('Distribution');
3807 $@ =~ s/^dgit: //gm;
3809 "Perhaps debian/changelog does not mention $v ?";
3811 fail <<END if $cd->[0] =~ m/UNRELEASED/;
3812 $cd->[1] is $cd->[0]
3813 Your tree seems to based on earlier (not uploaded) $v.
3818 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3822 sub pseudomerge_make_commit ($$$$ $$) {
3823 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3824 $msg_cmd, $msg_msg) = @_;
3825 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3827 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3828 my $authline = clogp_authline $clogp;
3832 !defined $overwrite_version ? ""
3833 : !length $overwrite_version ? " --overwrite"
3834 : " --overwrite=".$overwrite_version;
3837 my $pmf = ".git/dgit/pseudomerge";
3838 open MC, ">", $pmf or die "$pmf $!";
3839 print MC <<END or die $!;
3842 parent $archive_hash
3852 return make_commit($pmf);
3855 sub splitbrain_pseudomerge ($$$$) {
3856 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3857 # => $merged_dgitview
3858 printdebug "splitbrain_pseudomerge...\n";
3860 # We: debian/PREVIOUS HEAD($maintview)
3861 # expect: o ----------------- o
3864 # a/d/PREVIOUS $dgitview
3867 # we do: `------------------ o
3871 return $dgitview unless defined $archive_hash;
3872 return $dgitview if deliberately_not_fast_forward();
3874 printdebug "splitbrain_pseudomerge...\n";
3876 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3878 if (!defined $overwrite_version) {
3879 progress "Checking that HEAD inciudes all changes in archive...";
3882 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3884 if (defined $overwrite_version) {
3886 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3887 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3888 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3889 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3890 my $i_archive = [ $archive_hash, "current archive contents" ];
3892 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3894 infopair_cond_equal($i_dgit, $i_archive);
3895 infopair_cond_ff($i_dep14, $i_dgit);
3896 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3900 $us: check failed (maybe --overwrite is needed, consult documentation)
3905 my $r = pseudomerge_make_commit
3906 $clogp, $dgitview, $archive_hash, $i_arch_v,
3907 "dgit --quilt=$quilt_mode",
3908 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3909 Declare fast forward from $i_arch_v->[0]
3911 Make fast forward from $i_arch_v->[0]
3914 maybe_split_brain_save $maintview, $r, "pseudomerge";
3916 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3920 sub plain_overwrite_pseudomerge ($$$) {
3921 my ($clogp, $head, $archive_hash) = @_;
3923 printdebug "plain_overwrite_pseudomerge...";
3925 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3927 return $head if is_fast_fwd $archive_hash, $head;
3929 my $m = "Declare fast forward from $i_arch_v->[0]";
3931 my $r = pseudomerge_make_commit
3932 $clogp, $head, $archive_hash, $i_arch_v,
3935 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3937 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3941 sub push_parse_changelog ($) {
3944 my $clogp = Dpkg::Control::Hash->new();
3945 $clogp->load($clogpfn) or die;
3947 my $clogpackage = getfield $clogp, 'Source';
3948 $package //= $clogpackage;
3949 fail "-p specified $package but changelog specified $clogpackage"
3950 unless $package eq $clogpackage;
3951 my $cversion = getfield $clogp, 'Version';
3953 if (!$we_are_initiator) {
3954 # rpush initiator can't do this because it doesn't have $isuite yet
3955 my $tag = debiantag($cversion, access_nomdistro);
3956 runcmd @git, qw(check-ref-format), $tag;
3959 my $dscfn = dscfn($cversion);
3961 return ($clogp, $cversion, $dscfn);
3964 sub push_parse_dsc ($$$) {
3965 my ($dscfn,$dscfnwhat, $cversion) = @_;
3966 $dsc = parsecontrol($dscfn,$dscfnwhat);
3967 my $dversion = getfield $dsc, 'Version';
3968 my $dscpackage = getfield $dsc, 'Source';
3969 ($dscpackage eq $package && $dversion eq $cversion) or
3970 fail "$dscfn is for $dscpackage $dversion".
3971 " but debian/changelog is for $package $cversion";
3974 sub push_tagwants ($$$$) {
3975 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3978 TagFn => \&debiantag,
3983 if (defined $maintviewhead) {
3985 TagFn => \&debiantag_maintview,
3986 Objid => $maintviewhead,
3987 TfSuffix => '-maintview',
3990 } elsif ($dodep14tag eq 'no' ? 0
3991 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3992 : $dodep14tag eq 'always'
3993 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3994 --dep14tag-always (or equivalent in config) means server must support
3995 both "new" and "maint" tag formats, but config says it doesn't.
3997 : die "$dodep14tag ?") {
3999 TagFn => \&debiantag_maintview,
4001 TfSuffix => '-dgit',
4005 foreach my $tw (@tagwants) {
4006 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
4007 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
4009 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
4013 sub push_mktags ($$ $$ $) {
4015 $changesfile,$changesfilewhat,
4018 die unless $tagwants->[0]{View} eq 'dgit';
4020 my $declaredistro = access_nomdistro();
4021 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
4022 $dsc->{$ourdscfield[0]} = join " ",
4023 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
4025 $dsc->save("$dscfn.tmp") or die $!;
4027 my $changes = parsecontrol($changesfile,$changesfilewhat);
4028 foreach my $field (qw(Source Distribution Version)) {
4029 $changes->{$field} eq $clogp->{$field} or
4030 fail "changes field $field \`$changes->{$field}'".
4031 " does not match changelog \`$clogp->{$field}'";
4034 my $cversion = getfield $clogp, 'Version';
4035 my $clogsuite = getfield $clogp, 'Distribution';
4037 # We make the git tag by hand because (a) that makes it easier
4038 # to control the "tagger" (b) we can do remote signing
4039 my $authline = clogp_authline $clogp;
4040 my $delibs = join(" ", "",@deliberatelies);
4044 my $tfn = $tw->{Tfn};
4045 my $head = $tw->{Objid};
4046 my $tag = $tw->{Tag};
4048 open TO, '>', $tfn->('.tmp') or die $!;
4049 print TO <<END or die $!;
4056 if ($tw->{View} eq 'dgit') {
4057 print TO <<END or die $!;
4058 $package release $cversion for $clogsuite ($csuite) [dgit]
4059 [dgit distro=$declaredistro$delibs]
4061 foreach my $ref (sort keys %previously) {
4062 print TO <<END or die $!;
4063 [dgit previously:$ref=$previously{$ref}]
4066 } elsif ($tw->{View} eq 'maint') {
4067 print TO <<END or die $!;
4068 $package release $cversion for $clogsuite ($csuite)
4069 (maintainer view tag generated by dgit --quilt=$quilt_mode)
4072 die Dumper($tw)."?";
4077 my $tagobjfn = $tfn->('.tmp');
4079 if (!defined $keyid) {
4080 $keyid = access_cfg('keyid','RETURN-UNDEF');
4082 if (!defined $keyid) {
4083 $keyid = getfield $clogp, 'Maintainer';
4085 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
4086 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
4087 push @sign_cmd, qw(-u),$keyid if defined $keyid;
4088 push @sign_cmd, $tfn->('.tmp');
4089 runcmd_ordryrun @sign_cmd;
4091 $tagobjfn = $tfn->('.signed.tmp');
4092 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
4093 $tfn->('.tmp'), $tfn->('.tmp.asc');
4099 my @r = map { $mktag->($_); } @$tagwants;
4103 sub sign_changes ($) {
4104 my ($changesfile) = @_;
4106 my @debsign_cmd = @debsign;
4107 push @debsign_cmd, "-k$keyid" if defined $keyid;
4108 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
4109 push @debsign_cmd, $changesfile;
4110 runcmd_ordryrun @debsign_cmd;
4115 printdebug "actually entering push\n";
4117 supplementary_message(<<'END');
4118 Push failed, while checking state of the archive.
4119 You can retry the push, after fixing the problem, if you like.
4121 if (check_for_git()) {
4124 my $archive_hash = fetch_from_archive();
4125 if (!$archive_hash) {
4127 fail "package appears to be new in this suite;".
4128 " if this is intentional, use --new";
4131 supplementary_message(<<'END');
4132 Push failed, while preparing your push.
4133 You can retry the push, after fixing the problem, if you like.
4136 need_tagformat 'new', "quilt mode $quilt_mode"
4137 if quiltmode_splitbrain;
4141 access_giturl(); # check that success is vaguely likely
4142 rpush_handle_protovsn_bothends() if $we_are_initiator;
4145 my $clogpfn = ".git/dgit/changelog.822.tmp";
4146 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
4148 responder_send_file('parsed-changelog', $clogpfn);
4150 my ($clogp, $cversion, $dscfn) =
4151 push_parse_changelog("$clogpfn");
4153 my $dscpath = "$buildproductsdir/$dscfn";
4154 stat_exists $dscpath or
4155 fail "looked for .dsc $dscpath, but $!;".
4156 " maybe you forgot to build";
4158 responder_send_file('dsc', $dscpath);
4160 push_parse_dsc($dscpath, $dscfn, $cversion);
4162 my $format = getfield $dsc, 'Format';
4163 printdebug "format $format\n";
4165 my $actualhead = git_rev_parse('HEAD');
4166 my $dgithead = $actualhead;
4167 my $maintviewhead = undef;
4169 my $upstreamversion = upstreamversion $clogp->{Version};
4171 if (madformat_wantfixup($format)) {
4172 # user might have not used dgit build, so maybe do this now:
4173 if (quiltmode_splitbrain()) {
4175 quilt_make_fake_dsc($upstreamversion);
4177 ($dgithead, $cachekey) =
4178 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4180 "--quilt=$quilt_mode but no cached dgit view:
4181 perhaps tree changed since dgit build[-source] ?";
4183 $dgithead = splitbrain_pseudomerge($clogp,
4184 $actualhead, $dgithead,
4186 $maintviewhead = $actualhead;
4187 changedir '../../../..';
4188 prep_ud(); # so _only_subdir() works, below
4190 commit_quilty_patch();
4194 if (defined $overwrite_version && !defined $maintviewhead) {
4195 $dgithead = plain_overwrite_pseudomerge($clogp,
4203 if ($archive_hash) {
4204 if (is_fast_fwd($archive_hash, $dgithead)) {
4206 } elsif (deliberately_not_fast_forward) {
4209 fail "dgit push: HEAD is not a descendant".
4210 " of the archive's version.\n".
4211 "To overwrite the archive's contents,".
4212 " pass --overwrite[=VERSION].\n".
4213 "To rewind history, if permitted by the archive,".
4214 " use --deliberately-not-fast-forward.";
4219 progress "checking that $dscfn corresponds to HEAD";
4220 runcmd qw(dpkg-source -x --),
4221 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
4222 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4223 check_for_vendor_patches() if madformat($dsc->{format});
4224 changedir '../../../..';
4225 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4226 debugcmd "+",@diffcmd;
4228 my $r = system @diffcmd;
4231 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4233 HEAD specifies a different tree to $dscfn:
4235 Perhaps you forgot to build. Or perhaps there is a problem with your
4236 source tree (see dgit(7) for some hints). To see a full diff, run
4243 if (!$changesfile) {
4244 my $pat = changespat $cversion;
4245 my @cs = glob "$buildproductsdir/$pat";
4246 fail "failed to find unique changes file".
4247 " (looked for $pat in $buildproductsdir);".
4248 " perhaps you need to use dgit -C"
4250 ($changesfile) = @cs;
4252 $changesfile = "$buildproductsdir/$changesfile";
4255 # Check that changes and .dsc agree enough
4256 $changesfile =~ m{[^/]*$};
4257 my $changes = parsecontrol($changesfile,$&);
4258 files_compare_inputs($dsc, $changes)
4259 unless forceing [qw(dsc-changes-mismatch)];
4261 # Perhaps adjust .dsc to contain right set of origs
4262 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4264 unless forceing [qw(changes-origs-exactly)];
4266 # Checks complete, we're going to try and go ahead:
4268 responder_send_file('changes',$changesfile);
4269 responder_send_command("param head $dgithead");
4270 responder_send_command("param csuite $csuite");
4271 responder_send_command("param isuite $isuite");
4272 responder_send_command("param tagformat $tagformat");
4273 if (defined $maintviewhead) {
4274 die unless ($protovsn//4) >= 4;
4275 responder_send_command("param maint-view $maintviewhead");
4278 # Perhaps send buildinfo(s) for signing
4279 my $changes_files = getfield $changes, 'Files';
4280 my @buildinfos = ($changes_files =~ m/ .* (\S+\.buildinfo)$/mg);
4281 foreach my $bi (@buildinfos) {
4282 responder_send_command("param buildinfo-filename $bi");
4283 responder_send_file('buildinfo', "$buildproductsdir/$bi");
4286 if (deliberately_not_fast_forward) {
4287 git_for_each_ref(lrfetchrefs, sub {
4288 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4289 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4290 responder_send_command("previously $rrefname=$objid");
4291 $previously{$rrefname} = $objid;
4295 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4299 supplementary_message(<<'END');
4300 Push failed, while signing the tag.
4301 You can retry the push, after fixing the problem, if you like.
4303 # If we manage to sign but fail to record it anywhere, it's fine.
4304 if ($we_are_responder) {
4305 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4306 responder_receive_files('signed-tag', @tagobjfns);
4308 @tagobjfns = push_mktags($clogp,$dscpath,
4309 $changesfile,$changesfile,
4312 supplementary_message(<<'END');
4313 Push failed, *after* signing the tag.
4314 If you want to try again, you should use a new version number.
4317 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4319 foreach my $tw (@tagwants) {
4320 my $tag = $tw->{Tag};
4321 my $tagobjfn = $tw->{TagObjFn};
4323 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4324 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4325 runcmd_ordryrun_local
4326 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4329 supplementary_message(<<'END');
4330 Push failed, while updating the remote git repository - see messages above.
4331 If you want to try again, you should use a new version number.
4333 if (!check_for_git()) {
4334 create_remote_git_repo();
4337 my @pushrefs = $forceflag.$dgithead.":".rrref();
4338 foreach my $tw (@tagwants) {
4339 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4342 runcmd_ordryrun @git,
4343 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4344 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4346 supplementary_message(<<'END');
4347 Push failed, while obtaining signatures on the .changes and .dsc.
4348 If it was just that the signature failed, you may try again by using
4349 debsign by hand to sign the changes
4351 and then dput to complete the upload.
4352 If you need to change the package, you must use a new version number.
4354 if ($we_are_responder) {
4355 my $dryrunsuffix = act_local() ? "" : ".tmp";
4356 my @rfiles = ($dscpath, $changesfile);
4357 push @rfiles, map { "$buildproductsdir/$_" } @buildinfos;
4358 responder_receive_files('signed-dsc-changes',
4359 map { "$_$dryrunsuffix" } @rfiles);
4362 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4364 progress "[new .dsc left in $dscpath.tmp]";
4366 sign_changes $changesfile;
4369 supplementary_message(<<END);
4370 Push failed, while uploading package(s) to the archive server.
4371 You can retry the upload of exactly these same files with dput of:
4373 If that .changes file is broken, you will need to use a new version
4374 number for your next attempt at the upload.
4376 my $host = access_cfg('upload-host','RETURN-UNDEF');
4377 my @hostarg = defined($host) ? ($host,) : ();
4378 runcmd_ordryrun @dput, @hostarg, $changesfile;
4379 printdone "pushed and uploaded $cversion";
4381 supplementary_message('');
4382 responder_send_command("complete");
4391 badusage "-p is not allowed with clone; specify as argument instead"
4392 if defined $package;
4395 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4396 ($package,$isuite) = @ARGV;
4397 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4398 ($package,$dstdir) = @ARGV;
4399 } elsif (@ARGV==3) {
4400 ($package,$isuite,$dstdir) = @ARGV;
4402 badusage "incorrect arguments to dgit clone";
4406 $dstdir ||= "$package";
4407 if (stat_exists $dstdir) {
4408 fail "$dstdir already exists";
4412 if ($rmonerror && !$dryrun_level) {
4413 $cwd_remove= getcwd();
4415 return unless defined $cwd_remove;
4416 if (!chdir "$cwd_remove") {
4417 return if $!==&ENOENT;
4418 die "chdir $cwd_remove: $!";
4420 printdebug "clone rmonerror removing $dstdir\n";
4422 rmtree($dstdir) or die "remove $dstdir: $!\n";
4423 } elsif (grep { $! == $_ }
4424 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4426 print STDERR "check whether to remove $dstdir: $!\n";
4432 $cwd_remove = undef;
4435 sub branchsuite () {
4436 my @cmd = (@git, qw(symbolic-ref -q HEAD));
4437 my $branch = cmdoutput_errok @cmd;
4438 if (!defined $branch) {
4439 $?==256 or failedcmd @cmd;
4442 if ($branch =~ m#$lbranch_re#o) {
4449 sub fetchpullargs () {
4450 if (!defined $package) {
4451 my $sourcep = parsecontrol('debian/control','debian/control');
4452 $package = getfield $sourcep, 'Source';
4455 $isuite = branchsuite();
4457 my $clogp = parsechangelog();
4458 my $clogsuite = getfield $clogp, 'Distribution';
4459 $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
4461 } elsif (@ARGV==1) {
4464 badusage "incorrect arguments to dgit fetch or dgit pull";
4472 my $multi_fetched = fork_for_multisuite(sub { });
4473 exit 0 if $multi_fetched;
4480 if (quiltmode_splitbrain()) {
4481 my ($format, $fopts) = get_source_format();
4482 madformat($format) and fail <<END
4483 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4491 build_or_push_prep_early();
4496 } elsif (@ARGV==1) {
4497 ($specsuite) = (@ARGV);
4499 badusage "incorrect arguments to dgit $subcommand";
4502 local ($package) = $existing_package; # this is a hack
4503 canonicalise_suite();
4505 canonicalise_suite();
4507 if (defined $specsuite &&
4508 $specsuite ne $isuite &&
4509 $specsuite ne $csuite) {
4510 fail "dgit $subcommand: changelog specifies $isuite ($csuite)".
4511 " but command line specifies $specsuite";
4520 #---------- remote commands' implementation ----------
4522 sub pre_remote_push_build_host {
4523 my ($nrargs) = shift @ARGV;
4524 my (@rargs) = @ARGV[0..$nrargs-1];
4525 @ARGV = @ARGV[$nrargs..$#ARGV];
4527 my ($dir,$vsnwant) = @rargs;
4528 # vsnwant is a comma-separated list; we report which we have
4529 # chosen in our ready response (so other end can tell if they
4532 $we_are_responder = 1;
4533 $us .= " (build host)";
4535 open PI, "<&STDIN" or die $!;
4536 open STDIN, "/dev/null" or die $!;
4537 open PO, ">&STDOUT" or die $!;
4539 open STDOUT, ">&STDERR" or die $!;
4543 ($protovsn) = grep {
4544 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4545 } @rpushprotovsn_support;
4547 fail "build host has dgit rpush protocol versions ".
4548 (join ",", @rpushprotovsn_support).
4549 " but invocation host has $vsnwant"
4550 unless defined $protovsn;
4554 sub cmd_remote_push_build_host {
4555 responder_send_command("dgit-remote-push-ready $protovsn");
4559 sub pre_remote_push_responder { pre_remote_push_build_host(); }
4560 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4561 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4562 # a good error message)
4564 sub rpush_handle_protovsn_bothends () {
4565 if ($protovsn < 4) {
4566 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4575 my $report = i_child_report();
4576 if (defined $report) {
4577 printdebug "($report)\n";
4578 } elsif ($i_child_pid) {
4579 printdebug "(killing build host child $i_child_pid)\n";
4580 kill 15, $i_child_pid;
4582 if (defined $i_tmp && !defined $initiator_tempdir) {
4584 eval { rmtree $i_tmp; };
4589 return unless forkcheck_mainprocess();
4594 my ($base,$selector,@args) = @_;
4595 $selector =~ s/\-/_/g;
4596 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4605 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4613 push @rargs, join ",", @rpushprotovsn_support;
4616 push @rdgit, @ropts;
4617 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4619 my @cmd = (@ssh, $host, shellquote @rdgit);
4622 $we_are_initiator=1;
4624 if (defined $initiator_tempdir) {
4625 rmtree $initiator_tempdir;
4626 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4627 $i_tmp = $initiator_tempdir;
4631 $i_child_pid = open2(\*RO, \*RI, @cmd);
4633 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4634 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4635 $supplementary_message = '' unless $protovsn >= 3;
4638 my ($icmd,$iargs) = initiator_expect {
4639 m/^(\S+)(?: (.*))?$/;
4642 i_method "i_resp", $icmd, $iargs;
4646 sub i_resp_progress ($) {
4648 my $msg = protocol_read_bytes \*RO, $rhs;
4652 sub i_resp_supplementary_message ($) {
4654 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4657 sub i_resp_complete {
4658 my $pid = $i_child_pid;
4659 $i_child_pid = undef; # prevents killing some other process with same pid
4660 printdebug "waiting for build host child $pid...\n";
4661 my $got = waitpid $pid, 0;
4662 die $! unless $got == $pid;
4663 die "build host child failed $?" if $?;
4666 printdebug "all done\n";
4670 sub i_resp_file ($) {
4672 my $localname = i_method "i_localname", $keyword;
4673 my $localpath = "$i_tmp/$localname";
4674 stat_exists $localpath and
4675 badproto \*RO, "file $keyword ($localpath) twice";
4676 protocol_receive_file \*RO, $localpath;
4677 i_method "i_file", $keyword;
4682 sub i_resp_param ($) {
4683 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4687 sub i_resp_previously ($) {
4688 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4689 or badproto \*RO, "bad previously spec";
4690 my $r = system qw(git check-ref-format), $1;
4691 die "bad previously ref spec ($r)" if $r;
4692 $previously{$1} = $2;
4697 sub i_resp_want ($) {
4699 die "$keyword ?" if $i_wanted{$keyword}++;
4701 defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
4702 $isuite = $i_param{'isuite'} // $i_param{'csuite'};
4703 die unless $isuite =~ m/^$suite_re$/;
4706 rpush_handle_protovsn_bothends();
4708 fail "rpush negotiated protocol version $protovsn".
4709 " which does not support quilt mode $quilt_mode"
4710 if quiltmode_splitbrain;
4712 my @localpaths = i_method "i_want", $keyword;
4713 printdebug "[[ $keyword @localpaths\n";
4714 foreach my $localpath (@localpaths) {
4715 protocol_send_file \*RI, $localpath;
4717 print RI "files-end\n" or die $!;
4720 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn, @i_buildinfos);
4722 sub i_localname_parsed_changelog {
4723 return "remote-changelog.822";
4725 sub i_file_parsed_changelog {
4726 ($i_clogp, $i_version, $i_dscfn) =
4727 push_parse_changelog "$i_tmp/remote-changelog.822";
4728 die if $i_dscfn =~ m#/|^\W#;
4731 sub i_localname_dsc {
4732 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4737 sub i_localname_buildinfo ($) {
4738 my $bi = $i_param{'buildinfo-filename'};
4739 defined $bi or badproto \*RO, "buildinfo before filename";
4740 defined $i_changesfn or badproto \*RO, "buildinfo before changes";
4741 $bi =~ m{^\Q$package\E_[!-.0-~]*\.buildinfo$}s
4742 or badproto \*RO, "improper buildinfo filename";
4745 sub i_file_buildinfo {
4746 my $bi = $i_param{'buildinfo-filename'};
4747 my $bd = parsecontrol "$i_tmp/$bi", $bi;
4748 my $ch = parsecontrol "$i_tmp/$i_changesfn", 'changes';
4749 if (!forceing [qw(buildinfo-changes-mismatch)]) {
4750 files_compare_inputs($bd, $ch);
4751 (getfield $bd, $_) eq (getfield $ch, $_) or
4752 fail "buildinfo mismatch $_"
4753 foreach qw(Source Version);
4754 !defined $bd->{$_} or
4755 fail "buildinfo contains $_"
4756 foreach qw(Changes Changed-by Distribution);
4758 push @i_buildinfos, $bi;
4759 delete $i_param{'buildinfo-filename'};
4762 sub i_localname_changes {
4763 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4764 $i_changesfn = $i_dscfn;
4765 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4766 return $i_changesfn;
4768 sub i_file_changes { }
4770 sub i_want_signed_tag {
4771 printdebug Dumper(\%i_param, $i_dscfn);
4772 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4773 && defined $i_param{'csuite'}
4774 or badproto \*RO, "premature desire for signed-tag";
4775 my $head = $i_param{'head'};
4776 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4778 my $maintview = $i_param{'maint-view'};
4779 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4782 if ($protovsn >= 4) {
4783 my $p = $i_param{'tagformat'} // '<undef>';
4785 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4788 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4790 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4792 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4795 push_mktags $i_clogp, $i_dscfn,
4796 $i_changesfn, 'remote changes',
4800 sub i_want_signed_dsc_changes {
4801 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4802 sign_changes $i_changesfn;
4803 return ($i_dscfn, $i_changesfn, @i_buildinfos);
4806 #---------- building etc. ----------
4812 #----- `3.0 (quilt)' handling -----
4814 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4816 sub quiltify_dpkg_commit ($$$;$) {
4817 my ($patchname,$author,$msg, $xinfo) = @_;
4821 my $descfn = ".git/dgit/quilt-description.tmp";
4822 open O, '>', $descfn or die "$descfn: $!";
4823 $msg =~ s/\n+/\n\n/;
4824 print O <<END or die $!;
4826 ${xinfo}Subject: $msg
4833 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4834 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4835 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4836 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4840 sub quiltify_trees_differ ($$;$$$) {
4841 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4842 # returns true iff the two tree objects differ other than in debian/
4843 # with $finegrained,
4844 # returns bitmask 01 - differ in upstream files except .gitignore
4845 # 02 - differ in .gitignore
4846 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4847 # is set for each modified .gitignore filename $fn
4848 # if $unrepres is defined, array ref to which is appeneded
4849 # a list of unrepresentable changes (removals of upstream files
4852 my @cmd = (@git, qw(diff-tree -z --no-renames));
4853 push @cmd, qw(--name-only) unless $unrepres;
4854 push @cmd, qw(-r) if $finegrained || $unrepres;
4856 my $diffs= cmdoutput @cmd;
4859 foreach my $f (split /\0/, $diffs) {
4860 if ($unrepres && !@lmodes) {
4861 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4864 my ($oldmode,$newmode) = @lmodes;
4867 next if $f =~ m#^debian(?:/.*)?$#s;
4871 die "not a plain file or symlink\n"
4872 unless $newmode =~ m/^(?:10|12)\d{4}$/ ||
4873 $oldmode =~ m/^(?:10|12)\d{4}$/;
4874 if ($oldmode =~ m/[^0]/ &&
4875 $newmode =~ m/[^0]/) {
4876 # both old and new files exist
4877 die "mode or type changed\n" if $oldmode ne $newmode;
4878 die "modified symlink\n" unless $newmode =~ m/^10/;
4879 } elsif ($oldmode =~ m/[^0]/) {
4881 die "deletion of symlink\n"
4882 unless $oldmode =~ m/^10/;
4885 die "creation with non-default mode\n"
4886 unless $newmode =~ m/^100644$/ or
4887 $newmode =~ m/^120000$/;
4891 local $/="\n"; chomp $@;
4892 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4896 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4897 $r |= $isignore ? 02 : 01;
4898 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4900 printdebug "quiltify_trees_differ $x $y => $r\n";
4904 sub quiltify_tree_sentinelfiles ($) {
4905 # lists the `sentinel' files present in the tree
4907 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4908 qw(-- debian/rules debian/control);
4913 sub quiltify_splitbrain_needed () {
4914 if (!$split_brain) {
4915 progress "dgit view: changes are required...";
4916 runcmd @git, qw(checkout -q -b dgit-view);
4921 sub quiltify_splitbrain ($$$$$$) {
4922 my ($clogp, $unapplied, $headref, $diffbits,
4923 $editedignores, $cachekey) = @_;
4924 if ($quilt_mode !~ m/gbp|dpm/) {
4925 # treat .gitignore just like any other upstream file
4926 $diffbits = { %$diffbits };
4927 $_ = !!$_ foreach values %$diffbits;
4929 # We would like any commits we generate to be reproducible
4930 my @authline = clogp_authline($clogp);
4931 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4932 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4933 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4934 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4935 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4936 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4938 if ($quilt_mode =~ m/gbp|unapplied/ &&
4939 ($diffbits->{O2H} & 01)) {
4941 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4942 " but git tree differs from orig in upstream files.";
4943 if (!stat_exists "debian/patches") {
4945 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4949 if ($quilt_mode =~ m/dpm/ &&
4950 ($diffbits->{H2A} & 01)) {
4952 --quilt=$quilt_mode specified, implying patches-applied git tree
4953 but git tree differs from result of applying debian/patches to upstream
4956 if ($quilt_mode =~ m/gbp|unapplied/ &&
4957 ($diffbits->{O2A} & 01)) { # some patches
4958 quiltify_splitbrain_needed();
4959 progress "dgit view: creating patches-applied version using gbp pq";
4960 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4961 # gbp pq import creates a fresh branch; push back to dgit-view
4962 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4963 runcmd @git, qw(checkout -q dgit-view);
4965 if ($quilt_mode =~ m/gbp|dpm/ &&
4966 ($diffbits->{O2A} & 02)) {
4968 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4969 tool which does not create patches for changes to upstream
4970 .gitignores: but, such patches exist in debian/patches.
4973 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4974 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4975 quiltify_splitbrain_needed();
4976 progress "dgit view: creating patch to represent .gitignore changes";
4977 ensuredir "debian/patches";
4978 my $gipatch = "debian/patches/auto-gitignore";
4979 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4980 stat GIPATCH or die "$gipatch: $!";
4981 fail "$gipatch already exists; but want to create it".
4982 " to record .gitignore changes" if (stat _)[7];
4983 print GIPATCH <<END or die "$gipatch: $!";
4984 Subject: Update .gitignore from Debian packaging branch
4986 The Debian packaging git branch contains these updates to the upstream
4987 .gitignore file(s). This patch is autogenerated, to provide these
4988 updates to users of the official Debian archive view of the package.
4990 [dgit ($our_version) update-gitignore]
4993 close GIPATCH or die "$gipatch: $!";
4994 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4995 $unapplied, $headref, "--", sort keys %$editedignores;
4996 open SERIES, "+>>", "debian/patches/series" or die $!;
4997 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4999 defined read SERIES, $newline, 1 or die $!;
5000 print SERIES "\n" or die $! unless $newline eq "\n";
5001 print SERIES "auto-gitignore\n" or die $!;
5002 close SERIES or die $!;
5003 runcmd @git, qw(add -- debian/patches/series), $gipatch;
5005 Commit patch to update .gitignore
5007 [dgit ($our_version) update-gitignore-quilt-fixup]
5011 my $dgitview = git_rev_parse 'HEAD';
5013 changedir '../../../..';
5014 # When we no longer need to support squeeze, use --create-reflog
5016 ensuredir ".git/logs/refs/dgit-intern";
5017 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
5020 my $oldcache = git_get_ref "refs/$splitbraincache";
5021 if ($oldcache eq $dgitview) {
5022 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
5023 # git update-ref doesn't always update, in this case. *sigh*
5024 my $dummy = make_commit_text <<END;
5027 author Dgit <dgit\@example.com> 1000000000 +0000
5028 committer Dgit <dgit\@example.com> 1000000000 +0000
5030 Dummy commit - do not use
5032 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
5033 "refs/$splitbraincache", $dummy;
5035 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
5038 changedir '.git/dgit/unpack/work';
5040 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
5041 progress "dgit view: created ($saved)";
5044 sub quiltify ($$$$) {
5045 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
5047 # Quilt patchification algorithm
5049 # We search backwards through the history of the main tree's HEAD
5050 # (T) looking for a start commit S whose tree object is identical
5051 # to to the patch tip tree (ie the tree corresponding to the
5052 # current dpkg-committed patch series). For these purposes
5053 # `identical' disregards anything in debian/ - this wrinkle is
5054 # necessary because dpkg-source treates debian/ specially.
5056 # We can only traverse edges where at most one of the ancestors'
5057 # trees differs (in changes outside in debian/). And we cannot
5058 # handle edges which change .pc/ or debian/patches. To avoid
5059 # going down a rathole we avoid traversing edges which introduce
5060 # debian/rules or debian/control. And we set a limit on the
5061 # number of edges we are willing to look at.
5063 # If we succeed, we walk forwards again. For each traversed edge
5064 # PC (with P parent, C child) (starting with P=S and ending with
5065 # C=T) to we do this:
5067 # - dpkg-source --commit with a patch name and message derived from C
5068 # After traversing PT, we git commit the changes which
5069 # should be contained within debian/patches.
5071 # The search for the path S..T is breadth-first. We maintain a
5072 # todo list containing search nodes. A search node identifies a
5073 # commit, and looks something like this:
5075 # Commit => $git_commit_id,
5076 # Child => $c, # or undef if P=T
5077 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
5078 # Nontrivial => true iff $p..$c has relevant changes
5085 my %considered; # saves being exponential on some weird graphs
5087 my $t_sentinels = quiltify_tree_sentinelfiles $target;
5090 my ($search,$whynot) = @_;
5091 printdebug " search NOT $search->{Commit} $whynot\n";
5092 $search->{Whynot} = $whynot;
5093 push @nots, $search;
5094 no warnings qw(exiting);
5103 my $c = shift @todo;
5104 next if $considered{$c->{Commit}}++;
5106 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
5108 printdebug "quiltify investigate $c->{Commit}\n";
5111 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
5112 printdebug " search finished hooray!\n";
5117 if ($quilt_mode eq 'nofix') {
5118 fail "quilt fixup required but quilt mode is \`nofix'\n".
5119 "HEAD commit $c->{Commit} differs from tree implied by ".
5120 " debian/patches (tree object $oldtiptree)";
5122 if ($quilt_mode eq 'smash') {
5123 printdebug " search quitting smash\n";
5127 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
5128 $not->($c, "has $c_sentinels not $t_sentinels")
5129 if $c_sentinels ne $t_sentinels;
5131 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
5132 $commitdata =~ m/\n\n/;
5134 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
5135 @parents = map { { Commit => $_, Child => $c } } @parents;
5137 $not->($c, "root commit") if !@parents;
5139 foreach my $p (@parents) {
5140 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
5142 my $ndiffers = grep { $_->{Nontrivial} } @parents;
5143 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
5145 foreach my $p (@parents) {
5146 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
5148 my @cmd= (@git, qw(diff-tree -r --name-only),
5149 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
5150 my $patchstackchange = cmdoutput @cmd;
5151 if (length $patchstackchange) {
5152 $patchstackchange =~ s/\n/,/g;
5153 $not->($p, "changed $patchstackchange");
5156 printdebug " search queue P=$p->{Commit} ",
5157 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
5163 printdebug "quiltify want to smash\n";
5166 my $x = $_[0]{Commit};
5167 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
5170 my $reportnot = sub {
5172 my $s = $abbrev->($notp);
5173 my $c = $notp->{Child};
5174 $s .= "..".$abbrev->($c) if $c;
5175 $s .= ": ".$notp->{Whynot};
5178 if ($quilt_mode eq 'linear') {
5179 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
5180 foreach my $notp (@nots) {
5181 print STDERR "$us: ", $reportnot->($notp), "\n";
5183 print STDERR "$us: $_\n" foreach @$failsuggestion;
5184 fail "quilt fixup naive history linearisation failed.\n".
5185 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
5186 } elsif ($quilt_mode eq 'smash') {
5187 } elsif ($quilt_mode eq 'auto') {
5188 progress "quilt fixup cannot be linear, smashing...";
5190 die "$quilt_mode ?";
5193 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
5194 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
5196 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
5198 quiltify_dpkg_commit "auto-$version-$target-$time",
5199 (getfield $clogp, 'Maintainer'),
5200 "Automatically generated patch ($clogp->{Version})\n".
5201 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
5205 progress "quiltify linearisation planning successful, executing...";
5207 for (my $p = $sref_S;
5208 my $c = $p->{Child};
5210 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
5211 next unless $p->{Nontrivial};
5213 my $cc = $c->{Commit};
5215 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
5216 $commitdata =~ m/\n\n/ or die "$c ?";
5219 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
5222 my $commitdate = cmdoutput
5223 @git, qw(log -n1 --pretty=format:%aD), $cc;
5225 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5227 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5234 my $gbp_check_suitable = sub {
5239 die "contains unexpected slashes\n" if m{//} || m{/$};
5240 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5241 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5242 die "is series file\n" if m{$series_filename_re}o;
5243 die "too long" if length > 200;
5245 return $_ unless $@;
5246 print STDERR "quiltifying commit $cc:".
5247 " ignoring/dropping Gbp-Pq $what: $@";
5251 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5253 (\S+) \s* \n //ixm) {
5254 $patchname = $gbp_check_suitable->($1, 'Name');
5256 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5258 (\S+) \s* \n //ixm) {
5259 $patchdir = $gbp_check_suitable->($1, 'Topic');
5264 if (!defined $patchname) {
5265 $patchname = $title;
5266 $patchname =~ s/[.:]$//;
5269 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5270 my $translitname = $converter->convert($patchname);
5271 die unless defined $translitname;
5272 $patchname = $translitname;
5275 "dgit: patch title transliteration error: $@"
5277 $patchname =~ y/ A-Z/-a-z/;
5278 $patchname =~ y/-a-z0-9_.+=~//cd;
5279 $patchname =~ s/^\W/x-$&/;
5280 $patchname = substr($patchname,0,40);
5281 $patchname .= ".patch";
5283 if (!defined $patchdir) {
5286 if (length $patchdir) {
5287 $patchname = "$patchdir/$patchname";
5289 if ($patchname =~ m{^(.*)/}) {
5290 mkpath "debian/patches/$1";
5295 stat "debian/patches/$patchname$index";
5297 $!==ENOENT or die "$patchname$index $!";
5299 runcmd @git, qw(checkout -q), $cc;
5301 # We use the tip's changelog so that dpkg-source doesn't
5302 # produce complaining messages from dpkg-parsechangelog. None
5303 # of the information dpkg-source gets from the changelog is
5304 # actually relevant - it gets put into the original message
5305 # which dpkg-source provides our stunt editor, and then
5307 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5309 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5310 "Date: $commitdate\n".
5311 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5313 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5316 runcmd @git, qw(checkout -q master);
5319 sub build_maybe_quilt_fixup () {
5320 my ($format,$fopts) = get_source_format;
5321 return unless madformat_wantfixup $format;
5324 check_for_vendor_patches();
5326 if (quiltmode_splitbrain) {
5327 fail <<END unless access_cfg_tagformats_can_splitbrain;
5328 quilt mode $quilt_mode requires split view so server needs to support
5329 both "new" and "maint" tag formats, but config says it doesn't.
5333 my $clogp = parsechangelog();
5334 my $headref = git_rev_parse('HEAD');
5339 my $upstreamversion = upstreamversion $version;
5341 if ($fopts->{'single-debian-patch'}) {
5342 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5344 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5347 die 'bug' if $split_brain && !$need_split_build_invocation;
5349 changedir '../../../..';
5350 runcmd_ordryrun_local
5351 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5354 sub quilt_fixup_mkwork ($) {
5357 mkdir "work" or die $!;
5359 mktree_in_ud_here();
5360 runcmd @git, qw(reset -q --hard), $headref;
5363 sub quilt_fixup_linkorigs ($$) {
5364 my ($upstreamversion, $fn) = @_;
5365 # calls $fn->($leafname);
5367 foreach my $f (<../../../../*>) { #/){
5368 my $b=$f; $b =~ s{.*/}{};
5370 local ($debuglevel) = $debuglevel-1;
5371 printdebug "QF linkorigs $b, $f ?\n";
5373 next unless is_orig_file_of_vsn $b, $upstreamversion;
5374 printdebug "QF linkorigs $b, $f Y\n";
5375 link_ltarget $f, $b or die "$b $!";
5380 sub quilt_fixup_delete_pc () {
5381 runcmd @git, qw(rm -rqf .pc);
5383 Commit removal of .pc (quilt series tracking data)
5385 [dgit ($our_version) upgrade quilt-remove-pc]
5389 sub quilt_fixup_singlepatch ($$$) {
5390 my ($clogp, $headref, $upstreamversion) = @_;
5392 progress "starting quiltify (single-debian-patch)";
5394 # dpkg-source --commit generates new patches even if
5395 # single-debian-patch is in debian/source/options. In order to
5396 # get it to generate debian/patches/debian-changes, it is
5397 # necessary to build the source package.
5399 quilt_fixup_linkorigs($upstreamversion, sub { });
5400 quilt_fixup_mkwork($headref);
5402 rmtree("debian/patches");
5404 runcmd @dpkgsource, qw(-b .);
5406 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5407 rename srcfn("$upstreamversion", "/debian/patches"),
5408 "work/debian/patches";
5411 commit_quilty_patch();
5414 sub quilt_make_fake_dsc ($) {
5415 my ($upstreamversion) = @_;
5417 my $fakeversion="$upstreamversion-~~DGITFAKE";
5419 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5420 print $fakedsc <<END or die $!;
5423 Version: $fakeversion
5427 my $dscaddfile=sub {
5430 my $md = new Digest::MD5;
5432 my $fh = new IO::File $b, '<' or die "$b $!";
5437 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5440 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5442 my @files=qw(debian/source/format debian/rules
5443 debian/control debian/changelog);
5444 foreach my $maybe (qw(debian/patches debian/source/options
5445 debian/tests/control)) {
5446 next unless stat_exists "../../../$maybe";
5447 push @files, $maybe;
5450 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5451 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5453 $dscaddfile->($debtar);
5454 close $fakedsc or die $!;
5457 sub quilt_check_splitbrain_cache ($$) {
5458 my ($headref, $upstreamversion) = @_;
5459 # Called only if we are in (potentially) split brain mode.
5461 # Computes the cache key and looks in the cache.
5462 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5464 my $splitbrain_cachekey;
5467 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5468 # we look in the reflog of dgit-intern/quilt-cache
5469 # we look for an entry whose message is the key for the cache lookup
5470 my @cachekey = (qw(dgit), $our_version);
5471 push @cachekey, $upstreamversion;
5472 push @cachekey, $quilt_mode;
5473 push @cachekey, $headref;
5475 push @cachekey, hashfile('fake.dsc');
5477 my $srcshash = Digest::SHA->new(256);
5478 my %sfs = ( %INC, '$0(dgit)' => $0 );
5479 foreach my $sfk (sort keys %sfs) {
5480 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5481 $srcshash->add($sfk," ");
5482 $srcshash->add(hashfile($sfs{$sfk}));
5483 $srcshash->add("\n");
5485 push @cachekey, $srcshash->hexdigest();
5486 $splitbrain_cachekey = "@cachekey";
5488 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5490 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5491 debugcmd "|(probably)",@cmd;
5492 my $child = open GC, "-|"; defined $child or die $!;
5494 chdir '../../..' or die $!;
5495 if (!stat ".git/logs/refs/$splitbraincache") {
5496 $! == ENOENT or die $!;
5497 printdebug ">(no reflog)\n";
5504 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5505 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5508 quilt_fixup_mkwork($headref);
5509 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5510 if ($cachehit ne $headref) {
5511 progress "dgit view: found cached ($saved)";
5512 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5514 return ($cachehit, $splitbrain_cachekey);
5516 progress "dgit view: found cached, no changes required";
5517 return ($headref, $splitbrain_cachekey);
5519 die $! if GC->error;
5520 failedcmd unless close GC;
5522 printdebug "splitbrain cache miss\n";
5523 return (undef, $splitbrain_cachekey);
5526 sub quilt_fixup_multipatch ($$$) {
5527 my ($clogp, $headref, $upstreamversion) = @_;
5529 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5532 # - honour any existing .pc in case it has any strangeness
5533 # - determine the git commit corresponding to the tip of
5534 # the patch stack (if there is one)
5535 # - if there is such a git commit, convert each subsequent
5536 # git commit into a quilt patch with dpkg-source --commit
5537 # - otherwise convert all the differences in the tree into
5538 # a single git commit
5542 # Our git tree doesn't necessarily contain .pc. (Some versions of
5543 # dgit would include the .pc in the git tree.) If there isn't
5544 # one, we need to generate one by unpacking the patches that we
5547 # We first look for a .pc in the git tree. If there is one, we
5548 # will use it. (This is not the normal case.)
5550 # Otherwise need to regenerate .pc so that dpkg-source --commit
5551 # can work. We do this as follows:
5552 # 1. Collect all relevant .orig from parent directory
5553 # 2. Generate a debian.tar.gz out of
5554 # debian/{patches,rules,source/format,source/options}
5555 # 3. Generate a fake .dsc containing just these fields:
5556 # Format Source Version Files
5557 # 4. Extract the fake .dsc
5558 # Now the fake .dsc has a .pc directory.
5559 # (In fact we do this in every case, because in future we will
5560 # want to search for a good base commit for generating patches.)
5562 # Then we can actually do the dpkg-source --commit
5563 # 1. Make a new working tree with the same object
5564 # store as our main tree and check out the main
5566 # 2. Copy .pc from the fake's extraction, if necessary
5567 # 3. Run dpkg-source --commit
5568 # 4. If the result has changes to debian/, then
5569 # - git add them them
5570 # - git add .pc if we had a .pc in-tree
5572 # 5. If we had a .pc in-tree, delete it, and git commit
5573 # 6. Back in the main tree, fast forward to the new HEAD
5575 # Another situation we may have to cope with is gbp-style
5576 # patches-unapplied trees.
5578 # We would want to detect these, so we know to escape into
5579 # quilt_fixup_gbp. However, this is in general not possible.
5580 # Consider a package with a one patch which the dgit user reverts
5581 # (with git revert or the moral equivalent).
5583 # That is indistinguishable in contents from a patches-unapplied
5584 # tree. And looking at the history to distinguish them is not
5585 # useful because the user might have made a confusing-looking git
5586 # history structure (which ought to produce an error if dgit can't
5587 # cope, not a silent reintroduction of an unwanted patch).
5589 # So gbp users will have to pass an option. But we can usually
5590 # detect their failure to do so: if the tree is not a clean
5591 # patches-applied tree, quilt linearisation fails, but the tree
5592 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5593 # they want --quilt=unapplied.
5595 # To help detect this, when we are extracting the fake dsc, we
5596 # first extract it with --skip-patches, and then apply the patches
5597 # afterwards with dpkg-source --before-build. That lets us save a
5598 # tree object corresponding to .origs.
5600 my $splitbrain_cachekey;
5602 quilt_make_fake_dsc($upstreamversion);
5604 if (quiltmode_splitbrain()) {
5606 ($cachehit, $splitbrain_cachekey) =
5607 quilt_check_splitbrain_cache($headref, $upstreamversion);
5608 return if $cachehit;
5612 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5614 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5615 rename $fakexdir, "fake" or die "$fakexdir $!";
5619 remove_stray_gits("source package");
5620 mktree_in_ud_here();
5624 runcmd @git, qw(checkout -f), $headref, qw(-- debian);
5625 my $unapplied=git_add_write_tree();
5626 printdebug "fake orig tree object $unapplied\n";
5630 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5632 if (system @bbcmd) {
5633 failedcmd @bbcmd if $? < 0;
5635 failed to apply your git tree's patch stack (from debian/patches/) to
5636 the corresponding upstream tarball(s). Your source tree and .orig
5637 are probably too inconsistent. dgit can only fix up certain kinds of
5638 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5644 quilt_fixup_mkwork($headref);
5647 if (stat_exists ".pc") {
5649 progress "Tree already contains .pc - will use it then delete it.";
5652 rename '../fake/.pc','.pc' or die $!;
5655 changedir '../fake';
5657 my $oldtiptree=git_add_write_tree();
5658 printdebug "fake o+d/p tree object $unapplied\n";
5659 changedir '../work';
5662 # We calculate some guesswork now about what kind of tree this might
5663 # be. This is mostly for error reporting.
5669 # O = orig, without patches applied
5670 # A = "applied", ie orig with H's debian/patches applied
5671 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5672 \%editedignores, \@unrepres),
5673 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5674 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5678 foreach my $b (qw(01 02)) {
5679 foreach my $v (qw(O2H O2A H2A)) {
5680 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5683 printdebug "differences \@dl @dl.\n";
5686 "$us: base trees orig=%.20s o+d/p=%.20s",
5687 $unapplied, $oldtiptree;
5689 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5690 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5691 $dl[0], $dl[1], $dl[3], $dl[4],
5695 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5697 forceable_fail [qw(unrepresentable)], <<END;
5698 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5703 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5704 push @failsuggestion, "This might be a patches-unapplied branch.";
5705 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5706 push @failsuggestion, "This might be a patches-applied branch.";
5708 push @failsuggestion, "Maybe you need to specify one of".
5709 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5711 if (quiltmode_splitbrain()) {
5712 quiltify_splitbrain($clogp, $unapplied, $headref,
5713 $diffbits, \%editedignores,
5714 $splitbrain_cachekey);
5718 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5719 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5721 if (!open P, '>>', ".pc/applied-patches") {
5722 $!==&ENOENT or die $!;
5727 commit_quilty_patch();
5729 if ($mustdeletepc) {
5730 quilt_fixup_delete_pc();
5734 sub quilt_fixup_editor () {
5735 my $descfn = $ENV{$fakeeditorenv};
5736 my $editing = $ARGV[$#ARGV];
5737 open I1, '<', $descfn or die "$descfn: $!";
5738 open I2, '<', $editing or die "$editing: $!";
5739 unlink $editing or die "$editing: $!";
5740 open O, '>', $editing or die "$editing: $!";
5741 while (<I1>) { print O or die $!; } I1->error and die $!;
5744 $copying ||= m/^\-\-\- /;
5745 next unless $copying;
5748 I2->error and die $!;
5753 sub maybe_apply_patches_dirtily () {
5754 return unless $quilt_mode =~ m/gbp|unapplied/;
5755 print STDERR <<END or die $!;
5757 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5758 dgit: Have to apply the patches - making the tree dirty.
5759 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5762 $patches_applied_dirtily = 01;
5763 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5764 runcmd qw(dpkg-source --before-build .);
5767 sub maybe_unapply_patches_again () {
5768 progress "dgit: Unapplying patches again to tidy up the tree."
5769 if $patches_applied_dirtily;
5770 runcmd qw(dpkg-source --after-build .)
5771 if $patches_applied_dirtily & 01;
5773 if $patches_applied_dirtily & 02;
5774 $patches_applied_dirtily = 0;
5777 #----- other building -----
5779 our $clean_using_builder;
5780 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5781 # clean the tree before building (perhaps invoked indirectly by
5782 # whatever we are using to run the build), rather than separately
5783 # and explicitly by us.
5786 return if $clean_using_builder;
5787 if ($cleanmode eq 'dpkg-source') {
5788 maybe_apply_patches_dirtily();
5789 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5790 } elsif ($cleanmode eq 'dpkg-source-d') {
5791 maybe_apply_patches_dirtily();
5792 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5793 } elsif ($cleanmode eq 'git') {
5794 runcmd_ordryrun_local @git, qw(clean -xdf);
5795 } elsif ($cleanmode eq 'git-ff') {
5796 runcmd_ordryrun_local @git, qw(clean -xdff);
5797 } elsif ($cleanmode eq 'check') {
5798 my $leftovers = cmdoutput @git, qw(clean -xdn);
5799 if (length $leftovers) {
5800 print STDERR $leftovers, "\n" or die $!;
5801 fail "tree contains uncommitted files and --clean=check specified";
5803 } elsif ($cleanmode eq 'none') {
5810 badusage "clean takes no additional arguments" if @ARGV;
5813 maybe_unapply_patches_again();
5816 sub build_or_push_prep_early () {
5817 our $build_or_push_prep_early_done //= 0;
5818 return if $build_or_push_prep_early_done++;
5819 badusage "-p is not allowed with dgit $subcommand" if defined $package;
5820 my $clogp = parsechangelog();
5821 $isuite = getfield $clogp, 'Distribution';
5822 $package = getfield $clogp, 'Source';
5823 $version = getfield $clogp, 'Version';
5826 sub build_prep_early () {
5827 build_or_push_prep_early();
5835 build_maybe_quilt_fixup();
5837 my $pat = changespat $version;
5838 foreach my $f (glob "$buildproductsdir/$pat") {
5840 unlink $f or fail "remove old changes file $f: $!";
5842 progress "would remove $f";
5848 sub changesopts_initial () {
5849 my @opts =@changesopts[1..$#changesopts];
5852 sub changesopts_version () {
5853 if (!defined $changes_since_version) {
5854 my @vsns = archive_query('archive_query');
5855 my @quirk = access_quirk();
5856 if ($quirk[0] eq 'backports') {
5857 local $isuite = $quirk[2];
5859 canonicalise_suite();
5860 push @vsns, archive_query('archive_query');
5863 @vsns = map { $_->[0] } @vsns;
5864 @vsns = sort { -version_compare($a, $b) } @vsns;
5865 $changes_since_version = $vsns[0];
5866 progress "changelog will contain changes since $vsns[0]";
5868 $changes_since_version = '_';
5869 progress "package seems new, not specifying -v<version>";
5872 if ($changes_since_version ne '_') {
5873 return ("-v$changes_since_version");
5879 sub changesopts () {
5880 return (changesopts_initial(), changesopts_version());
5883 sub massage_dbp_args ($;$) {
5884 my ($cmd,$xargs) = @_;
5887 # - if we're going to split the source build out so we can
5888 # do strange things to it, massage the arguments to dpkg-buildpackage
5889 # so that the main build doessn't build source (or add an argument
5890 # to stop it building source by default).
5892 # - add -nc to stop dpkg-source cleaning the source tree,
5893 # unless we're not doing a split build and want dpkg-source
5894 # as cleanmode, in which case we can do nothing
5897 # 0 - source will NOT need to be built separately by caller
5898 # +1 - source will need to be built separately by caller
5899 # +2 - source will need to be built separately by caller AND
5900 # dpkg-buildpackage should not in fact be run at all!
5901 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5902 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5903 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5904 $clean_using_builder = 1;
5907 # -nc has the side effect of specifying -b if nothing else specified
5908 # and some combinations of -S, -b, et al, are errors, rather than
5909 # later simply overriding earlie. So we need to:
5910 # - search the command line for these options
5911 # - pick the last one
5912 # - perhaps add our own as a default
5913 # - perhaps adjust it to the corresponding non-source-building version
5915 foreach my $l ($cmd, $xargs) {
5917 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5920 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5922 if ($need_split_build_invocation) {
5923 printdebug "massage split $dmode.\n";
5924 $r = $dmode =~ m/[S]/ ? +2 :
5925 $dmode =~ y/gGF/ABb/ ? +1 :
5926 $dmode =~ m/[ABb]/ ? 0 :
5929 printdebug "massage done $r $dmode.\n";
5931 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5937 my $wasdir = must_getcwd();
5943 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5944 my ($msg_if_onlyone) = @_;
5945 # If there is only one .changes file, fail with $msg_if_onlyone,
5946 # or if that is undef, be a no-op.
5947 # Returns the changes file to report to the user.
5948 my $pat = changespat $version;
5949 my @changesfiles = glob $pat;
5950 @changesfiles = sort {
5951 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5955 if (@changesfiles==1) {
5956 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5957 only one changes file from build (@changesfiles)
5959 $result = $changesfiles[0];
5960 } elsif (@changesfiles==2) {
5961 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5962 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5963 fail "$l found in binaries changes file $binchanges"
5966 runcmd_ordryrun_local @mergechanges, @changesfiles;
5967 my $multichanges = changespat $version,'multi';
5969 stat_exists $multichanges or fail "$multichanges: $!";
5970 foreach my $cf (glob $pat) {
5971 next if $cf eq $multichanges;
5972 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5975 $result = $multichanges;
5977 fail "wrong number of different changes files (@changesfiles)";
5979 printdone "build successful, results in $result\n" or die $!;
5982 sub midbuild_checkchanges () {
5983 my $pat = changespat $version;
5984 return if $rmchanges;
5985 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5986 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5988 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5989 Suggest you delete @unwanted.
5994 sub midbuild_checkchanges_vanilla ($) {
5996 midbuild_checkchanges() if $wantsrc == 1;
5999 sub postbuild_mergechanges_vanilla ($) {
6001 if ($wantsrc == 1) {
6003 postbuild_mergechanges(undef);
6006 printdone "build successful\n";
6012 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
6013 my $wantsrc = massage_dbp_args \@dbp;
6016 midbuild_checkchanges_vanilla $wantsrc;
6021 push @dbp, changesopts_version();
6022 maybe_apply_patches_dirtily();
6023 runcmd_ordryrun_local @dbp;
6025 maybe_unapply_patches_again();
6026 postbuild_mergechanges_vanilla $wantsrc;
6030 $quilt_mode //= 'gbp';
6036 # gbp can make .origs out of thin air. In my tests it does this
6037 # even for a 1.0 format package, with no origs present. So I
6038 # guess it keys off just the version number. We don't know
6039 # exactly what .origs ought to exist, but let's assume that we
6040 # should run gbp if: the version has an upstream part and the main
6042 my $upstreamversion = upstreamversion $version;
6043 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
6044 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
6046 if ($gbp_make_orig) {
6048 $cleanmode = 'none'; # don't do it again
6049 $need_split_build_invocation = 1;
6052 my @dbp = @dpkgbuildpackage;
6054 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
6056 if (!length $gbp_build[0]) {
6057 if (length executable_on_path('git-buildpackage')) {
6058 $gbp_build[0] = qw(git-buildpackage);
6060 $gbp_build[0] = 'gbp buildpackage';
6063 my @cmd = opts_opt_multi_cmd @gbp_build;
6065 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
6067 if ($gbp_make_orig) {
6068 ensuredir '.git/dgit';
6069 my $ok = '.git/dgit/origs-gen-ok';
6070 unlink $ok or $!==&ENOENT or die $!;
6071 my @origs_cmd = @cmd;
6072 push @origs_cmd, qw(--git-cleaner=true);
6073 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
6074 push @origs_cmd, @ARGV;
6076 debugcmd @origs_cmd;
6078 do { local $!; stat_exists $ok; }
6079 or failedcmd @origs_cmd;
6081 dryrun_report @origs_cmd;
6087 midbuild_checkchanges_vanilla $wantsrc;
6089 if (!$clean_using_builder) {
6090 push @cmd, '--git-cleaner=true';
6094 maybe_unapply_patches_again();
6096 push @cmd, changesopts();
6097 runcmd_ordryrun_local @cmd, @ARGV;
6099 postbuild_mergechanges_vanilla $wantsrc;
6101 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
6105 my $our_cleanmode = $cleanmode;
6106 if ($need_split_build_invocation) {
6107 # Pretend that clean is being done some other way. This
6108 # forces us not to try to use dpkg-buildpackage to clean and
6109 # build source all in one go; and instead we run dpkg-source
6110 # (and build_prep() will do the clean since $clean_using_builder
6112 $our_cleanmode = 'ELSEWHERE';
6114 if ($our_cleanmode =~ m/^dpkg-source/) {
6115 # dpkg-source invocation (below) will clean, so build_prep shouldn't
6116 $clean_using_builder = 1;
6119 $sourcechanges = changespat $version,'source';
6121 unlink "../$sourcechanges" or $!==ENOENT
6122 or fail "remove $sourcechanges: $!";
6124 $dscfn = dscfn($version);
6125 if ($our_cleanmode eq 'dpkg-source') {
6126 maybe_apply_patches_dirtily();
6127 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
6129 } elsif ($our_cleanmode eq 'dpkg-source-d') {
6130 maybe_apply_patches_dirtily();
6131 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
6134 my @cmd = (@dpkgsource, qw(-b --));
6137 runcmd_ordryrun_local @cmd, "work";
6138 my @udfiles = <${package}_*>;
6139 changedir "../../..";
6140 foreach my $f (@udfiles) {
6141 printdebug "source copy, found $f\n";
6144 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
6145 $f eq srcfn($version, $&));
6146 printdebug "source copy, found $f - renaming\n";
6147 rename "$ud/$f", "../$f" or $!==ENOENT
6148 or fail "put in place new source file ($f): $!";
6151 my $pwd = must_getcwd();
6152 my $leafdir = basename $pwd;
6154 runcmd_ordryrun_local @cmd, $leafdir;
6157 runcmd_ordryrun_local qw(sh -ec),
6158 'exec >$1; shift; exec "$@"','x',
6159 "../$sourcechanges",
6160 @dpkggenchanges, qw(-S), changesopts();
6164 sub cmd_build_source {
6166 badusage "build-source takes no additional arguments" if @ARGV;
6168 maybe_unapply_patches_again();
6169 printdone "source built, results in $dscfn and $sourcechanges";
6174 midbuild_checkchanges();
6177 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
6178 stat_exists $sourcechanges
6179 or fail "$sourcechanges (in parent directory): $!";
6181 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
6183 maybe_unapply_patches_again();
6185 postbuild_mergechanges(<<END);
6186 perhaps you need to pass -A ? (sbuild's default is to build only
6187 arch-specific binaries; dgit 1.4 used to override that.)
6192 sub cmd_quilt_fixup {
6193 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
6196 build_maybe_quilt_fixup();
6199 sub import_dsc_result {
6200 my ($dstref, $newhash, $what_log, $what_msg) = @_;
6201 my @cmd = (@git, qw(update-ref -m), $what_log, $dstref, $newhash);
6203 check_gitattrs($newhash, "source tree");
6205 progress "dgit: import-dsc: $what_msg";
6208 sub cmd_import_dsc {
6212 last unless $ARGV[0] =~ m/^-/;
6215 if (m/^--require-valid-signature$/) {
6218 badusage "unknown dgit import-dsc sub-option \`$_'";
6222 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
6223 my ($dscfn, $dstbranch) = @ARGV;
6225 badusage "dry run makes no sense with import-dsc" unless act_local();
6227 my $force = $dstbranch =~ s/^\+// ? +1 :
6228 $dstbranch =~ s/^\.\.// ? -1 :
6230 my $info = $force ? " $&" : '';
6231 $info = "$dscfn$info";
6233 my $specbranch = $dstbranch;
6234 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
6235 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
6237 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
6238 my $chead = cmdoutput_errok @symcmd;
6239 defined $chead or $?==256 or failedcmd @symcmd;
6241 fail "$dstbranch is checked out - will not update it"
6242 if defined $chead and $chead eq $dstbranch;
6244 my $oldhash = git_get_ref $dstbranch;
6246 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6247 $dscdata = do { local $/ = undef; <D>; };
6248 D->error and fail "read $dscfn: $!";
6251 # we don't normally need this so import it here
6252 use Dpkg::Source::Package;
6253 my $dp = new Dpkg::Source::Package filename => $dscfn,
6254 require_valid_signature => $needsig;
6256 local $SIG{__WARN__} = sub {
6258 return unless $needsig;
6259 fail "import-dsc signature check failed";
6261 if (!$dp->is_signed()) {
6262 warn "$us: warning: importing unsigned .dsc\n";
6264 my $r = $dp->check_signature();
6265 die "->check_signature => $r" if $needsig && $r;
6271 $package = getfield $dsc, 'Source';
6273 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6274 unless forceing [qw(import-dsc-with-dgit-field)];
6275 parse_dsc_field_def_dsc_distro();
6277 $isuite = 'DGIT-IMPORT-DSC';
6278 $idistro //= $dsc_distro;
6282 if (defined $dsc_hash) {
6283 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6284 resolve_dsc_field_commit undef, undef;
6286 if (defined $dsc_hash) {
6287 my @cmd = (qw(sh -ec),
6288 "echo $dsc_hash | git cat-file --batch-check");
6289 my $objgot = cmdoutput @cmd;
6290 if ($objgot =~ m#^\w+ missing\b#) {
6292 .dsc contains Dgit field referring to object $dsc_hash
6293 Your git tree does not have that object. Try `git fetch' from a
6294 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6297 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6299 progress "Not fast forward, forced update.";
6301 fail "Not fast forward to $dsc_hash";
6304 import_dsc_result $dstbranch, $dsc_hash,
6305 "dgit import-dsc (Dgit): $info",
6306 "updated git ref $dstbranch";
6311 Branch $dstbranch already exists
6312 Specify ..$specbranch for a pseudo-merge, binding in existing history
6313 Specify +$specbranch to overwrite, discarding existing history
6315 if $oldhash && !$force;
6317 my @dfi = dsc_files_info();
6318 foreach my $fi (@dfi) {
6319 my $f = $fi->{Filename};
6323 fail "lstat $here works but stat gives $! !";
6325 fail "stat $here: $!" unless $! == ENOENT;
6327 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6329 } elsif ($dscfn =~ m#^/#) {
6332 fail "cannot import $dscfn which seems to be inside working tree!";
6334 $there =~ s#/+[^/]+$## or
6335 fail "import $dscfn requires ../$f, but it does not exist";
6337 my $test = $there =~ m{^/} ? $there : "../$there";
6338 stat $test or fail "import $dscfn requires $test, but: $!";
6339 symlink $there, $here or fail "symlink $there to $here: $!";
6340 progress "made symlink $here -> $there";
6341 # print STDERR Dumper($fi);
6343 my @mergeinputs = generate_commits_from_dsc();
6344 die unless @mergeinputs == 1;
6346 my $newhash = $mergeinputs[0]{Commit};
6350 progress "Import, forced update - synthetic orphan git history.";
6351 } elsif ($force < 0) {
6352 progress "Import, merging.";
6353 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6354 my $version = getfield $dsc, 'Version';
6355 my $clogp = commit_getclogp $newhash;
6356 my $authline = clogp_authline $clogp;
6357 $newhash = make_commit_text <<END;
6364 Merge $package ($version) import into $dstbranch
6367 die; # caught earlier
6371 import_dsc_result $dstbranch, $newhash,
6372 "dgit import-dsc: $info",
6373 "results are in in git ref $dstbranch";
6376 sub pre_archive_api_query () {
6379 sub cmd_archive_api_query {
6380 badusage "need only 1 subpath argument" unless @ARGV==1;
6381 my ($subpath) = @ARGV;
6382 my @cmd = archive_api_query_cmd($subpath);
6385 exec @cmd or fail "exec curl: $!\n";
6388 sub repos_server_url () {
6389 $package = '_dgit-repos-server';
6390 local $access_forpush = 1;
6391 local $isuite = 'DGIT-REPOS-SERVER';
6392 my $url = access_giturl();
6395 sub pre_clone_dgit_repos_server () {
6398 sub cmd_clone_dgit_repos_server {
6399 badusage "need destination argument" unless @ARGV==1;
6400 my ($destdir) = @ARGV;
6401 my $url = repos_server_url();
6402 my @cmd = (@git, qw(clone), $url, $destdir);
6404 exec @cmd or fail "exec git clone: $!\n";
6407 sub pre_print_dgit_repos_server_source_url () {
6410 sub cmd_print_dgit_repos_server_source_url {
6411 badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
6413 my $url = repos_server_url();
6414 print $url, "\n" or die $!;
6417 sub cmd_setup_mergechangelogs {
6418 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6419 local $isuite = 'DGIT-SETUP-TREE';
6420 setup_mergechangelogs(1);
6423 sub cmd_setup_useremail {
6424 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6425 local $isuite = 'DGIT-SETUP-TREE';
6429 sub cmd_setup_gitattributes {
6430 badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
6431 local $isuite = 'DGIT-SETUP-TREE';
6435 sub cmd_setup_new_tree {
6436 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6437 local $isuite = 'DGIT-SETUP-TREE';
6441 #---------- argument parsing and main program ----------
6444 print "dgit version $our_version\n" or die $!;
6448 our (%valopts_long, %valopts_short);
6449 our (%funcopts_long);
6451 our (@modeopt_cfgs);
6453 sub defvalopt ($$$$) {
6454 my ($long,$short,$val_re,$how) = @_;
6455 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6456 $valopts_long{$long} = $oi;
6457 $valopts_short{$short} = $oi;
6458 # $how subref should:
6459 # do whatever assignemnt or thing it likes with $_[0]
6460 # if the option should not be passed on to remote, @rvalopts=()
6461 # or $how can be a scalar ref, meaning simply assign the value
6464 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6465 defvalopt '--distro', '-d', '.+', \$idistro;
6466 defvalopt '', '-k', '.+', \$keyid;
6467 defvalopt '--existing-package','', '.*', \$existing_package;
6468 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6469 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6470 defvalopt '--package', '-p', $package_re, \$package;
6471 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6473 defvalopt '', '-C', '.+', sub {
6474 ($changesfile) = (@_);
6475 if ($changesfile =~ s#^(.*)/##) {
6476 $buildproductsdir = $1;
6480 defvalopt '--initiator-tempdir','','.*', sub {
6481 ($initiator_tempdir) = (@_);
6482 $initiator_tempdir =~ m#^/# or
6483 badusage "--initiator-tempdir must be used specify an".
6484 " absolute, not relative, directory."
6487 sub defoptmodes ($@) {
6488 my ($varref, $cfgkey, $default, %optmap) = @_;
6490 while (my ($opt,$val) = each %optmap) {
6491 $funcopts_long{$opt} = sub { $$varref = $val; };
6492 $permit{$val} = $val;
6494 push @modeopt_cfgs, {
6497 Default => $default,
6502 defoptmodes \$dodep14tag, qw( dep14tag want
6505 --always-dep14tag always );
6510 if (defined $ENV{'DGIT_SSH'}) {
6511 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6512 } elsif (defined $ENV{'GIT_SSH'}) {
6513 @ssh = ($ENV{'GIT_SSH'});
6521 if (!defined $val) {
6522 badusage "$what needs a value" unless @ARGV;
6524 push @rvalopts, $val;
6526 badusage "bad value \`$val' for $what" unless
6527 $val =~ m/^$oi->{Re}$(?!\n)/s;
6528 my $how = $oi->{How};
6529 if (ref($how) eq 'SCALAR') {
6534 push @ropts, @rvalopts;
6538 last unless $ARGV[0] =~ m/^-/;
6542 if (m/^--dry-run$/) {
6545 } elsif (m/^--damp-run$/) {
6548 } elsif (m/^--no-sign$/) {
6551 } elsif (m/^--help$/) {
6553 } elsif (m/^--version$/) {
6555 } elsif (m/^--new$/) {
6558 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6559 ($om = $opts_opt_map{$1}) &&
6563 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6564 !$opts_opt_cmdonly{$1} &&
6565 ($om = $opts_opt_map{$1})) {
6568 } elsif (m/^--(gbp|dpm)$/s) {
6569 push @ropts, "--quilt=$1";
6571 } elsif (m/^--ignore-dirty$/s) {
6574 } elsif (m/^--no-quilt-fixup$/s) {
6576 $quilt_mode = 'nocheck';
6577 } elsif (m/^--no-rm-on-error$/s) {
6580 } elsif (m/^--no-chase-dsc-distro$/s) {
6582 $chase_dsc_distro = 0;
6583 } elsif (m/^--overwrite$/s) {
6585 $overwrite_version = '';
6586 } elsif (m/^--overwrite=(.+)$/s) {
6588 $overwrite_version = $1;
6589 } elsif (m/^--delayed=(\d+)$/s) {
6592 } elsif (m/^--dgit-view-save=(.+)$/s) {
6594 $split_brain_save = $1;
6595 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6596 } elsif (m/^--(no-)?rm-old-changes$/s) {
6599 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6601 push @deliberatelies, $&;
6602 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6606 } elsif (m/^--force-/) {
6608 "$us: warning: ignoring unknown force option $_\n";
6610 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6611 # undocumented, for testing
6613 $tagformat_want = [ $1, 'command line', 1 ];
6614 # 1 menas overrides distro configuration
6615 } elsif (m/^--always-split-source-build$/s) {
6616 # undocumented, for testing
6618 $need_split_build_invocation = 1;
6619 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6620 # undocumented, for testing
6622 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6623 # ^ it's supposed to be an array ref
6624 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6625 $val = $2 ? $' : undef; #';
6626 $valopt->($oi->{Long});
6627 } elsif ($funcopts_long{$_}) {
6629 $funcopts_long{$_}();
6631 badusage "unknown long option \`$_'";
6638 } elsif (s/^-L/-/) {
6641 } elsif (s/^-h/-/) {
6643 } elsif (s/^-D/-/) {
6647 } elsif (s/^-N/-/) {
6652 push @changesopts, $_;
6654 } elsif (s/^-wn$//s) {
6656 $cleanmode = 'none';
6657 } elsif (s/^-wg$//s) {
6660 } elsif (s/^-wgf$//s) {
6662 $cleanmode = 'git-ff';
6663 } elsif (s/^-wd$//s) {
6665 $cleanmode = 'dpkg-source';
6666 } elsif (s/^-wdd$//s) {
6668 $cleanmode = 'dpkg-source-d';
6669 } elsif (s/^-wc$//s) {
6671 $cleanmode = 'check';
6672 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6673 push @git, '-c', $&;
6674 $gitcfgs{cmdline}{$1} = [ $2 ];
6675 } elsif (s/^-c([^=]+)$//s) {
6676 push @git, '-c', $&;
6677 $gitcfgs{cmdline}{$1} = [ 'true' ];
6678 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6680 $val = undef unless length $val;
6681 $valopt->($oi->{Short});
6684 badusage "unknown short option \`$_'";
6691 sub check_env_sanity () {
6692 my $blocked = new POSIX::SigSet;
6693 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6696 foreach my $name (qw(PIPE CHLD)) {
6697 my $signame = "SIG$name";
6698 my $signum = eval "POSIX::$signame" // die;
6699 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6700 die "$signame is set to something other than SIG_DFL\n";
6701 $blocked->ismember($signum) and
6702 die "$signame is blocked\n";
6708 On entry to dgit, $@
6709 This is a bug produced by something in in your execution environment.
6715 sub parseopts_late_defaults () {
6716 $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
6717 if defined $idistro;
6718 $isuite //= cfg('dgit.default.default-suite');
6720 foreach my $k (keys %opts_opt_map) {
6721 my $om = $opts_opt_map{$k};
6723 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6725 badcfg "cannot set command for $k"
6726 unless length $om->[0];
6730 foreach my $c (access_cfg_cfgs("opts-$k")) {
6732 map { $_ ? @$_ : () }
6733 map { $gitcfgs{$_}{$c} }
6734 reverse @gitcfgsources;
6735 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6736 "\n" if $debuglevel >= 4;
6738 badcfg "cannot configure options for $k"
6739 if $opts_opt_cmdonly{$k};
6740 my $insertpos = $opts_cfg_insertpos{$k};
6741 @$om = ( @$om[0..$insertpos-1],
6743 @$om[$insertpos..$#$om] );
6747 if (!defined $rmchanges) {
6748 local $access_forpush;
6749 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6752 if (!defined $quilt_mode) {
6753 local $access_forpush;
6754 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6755 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6757 $quilt_mode =~ m/^($quilt_modes_re)$/
6758 or badcfg "unknown quilt-mode \`$quilt_mode'";
6762 foreach my $moc (@modeopt_cfgs) {
6763 local $access_forpush;
6764 my $vr = $moc->{Var};
6765 next if defined $$vr;
6766 $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
6767 my $v = $moc->{Vals}{$$vr};
6768 badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
6772 $need_split_build_invocation ||= quiltmode_splitbrain();
6774 if (!defined $cleanmode) {
6775 local $access_forpush;
6776 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6777 $cleanmode //= 'dpkg-source';
6779 badcfg "unknown clean-mode \`$cleanmode'" unless
6780 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6784 if ($ENV{$fakeeditorenv}) {
6786 quilt_fixup_editor();
6792 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6793 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6794 if $dryrun_level == 1;
6796 print STDERR $helpmsg or die $!;
6799 $cmd = $subcommand = shift @ARGV;
6802 my $pre_fn = ${*::}{"pre_$cmd"};
6803 $pre_fn->() if $pre_fn;
6807 my $fn = ${*::}{"cmd_$cmd"};
6808 $fn or badusage "unknown operation $cmd";