3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
39 use Text::Glob qw(match_glob);
40 use Fcntl qw(:DEFAULT :flock);
45 our $our_version = 'UNRELEASED'; ###substituted###
46 our $absurdity = undef; ###substituted###
48 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
51 our $isuite = 'unstable';
57 our $dryrun_level = 0;
59 our $buildproductsdir = '..';
65 our $existing_package = 'dpkg';
67 our $changes_since_version;
69 our $overwrite_version; # undef: not specified; '': check changelog
71 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
72 our $split_brain_save;
73 our $we_are_responder;
74 our $initiator_tempdir;
75 our $patches_applied_dirtily = 00;
80 our %forceopts = map { $_=>0 }
81 qw(unrepresentable unsupported-source-format
82 dsc-changes-mismatch changes-origs-exactly
83 import-gitapply-absurd
84 import-gitapply-no-absurd
85 import-dsc-with-dgit-field);
87 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
89 our $suite_re = '[-+.0-9a-z]+';
90 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
91 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
92 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
93 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
95 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
96 our $splitbraincache = 'dgit-intern/quilt-cache';
99 our (@dget) = qw(dget);
100 our (@curl) = qw(curl);
101 our (@dput) = qw(dput);
102 our (@debsign) = qw(debsign);
103 our (@gpg) = qw(gpg);
104 our (@sbuild) = qw(sbuild);
106 our (@dgit) = qw(dgit);
107 our (@aptget) = qw(apt-get);
108 our (@aptcache) = qw(apt-cache);
109 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
110 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
111 our (@dpkggenchanges) = qw(dpkg-genchanges);
112 our (@mergechanges) = qw(mergechanges -f);
113 our (@gbp_build) = ('');
114 our (@gbp_pq) = ('gbp pq');
115 our (@changesopts) = ('');
117 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
120 'debsign' => \@debsign,
122 'sbuild' => \@sbuild,
126 'apt-get' => \@aptget,
127 'apt-cache' => \@aptcache,
128 'dpkg-source' => \@dpkgsource,
129 'dpkg-buildpackage' => \@dpkgbuildpackage,
130 'dpkg-genchanges' => \@dpkggenchanges,
131 'gbp-build' => \@gbp_build,
132 'gbp-pq' => \@gbp_pq,
133 'ch' => \@changesopts,
134 'mergechanges' => \@mergechanges);
136 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
137 our %opts_cfg_insertpos = map {
139 scalar @{ $opts_opt_map{$_} }
140 } keys %opts_opt_map;
142 sub finalise_opts_opts();
148 our $supplementary_message = '';
149 our $need_split_build_invocation = 0;
150 our $split_brain = 0;
154 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
157 our $remotename = 'dgit';
158 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
162 if (!defined $absurdity) {
164 $absurdity =~ s{/[^/]+$}{/absurd} or die;
168 my ($v,$distro) = @_;
169 return $tagformatfn->($v, $distro);
172 sub debiantag_maintview ($$) {
173 my ($v,$distro) = @_;
178 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
180 sub lbranch () { return "$branchprefix/$csuite"; }
181 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
182 sub lref () { return "refs/heads/".lbranch(); }
183 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
184 sub rrref () { return server_ref($csuite); }
186 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
187 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
189 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
190 # locally fetched refs because they have unhelpful names and clutter
191 # up gitk etc. So we track whether we have "used up" head ref (ie,
192 # whether we have made another local ref which refers to this object).
194 # (If we deleted them unconditionally, then we might end up
195 # re-fetching the same git objects each time dgit fetch was run.)
197 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
198 # in git_fetch_us to fetch the refs in question, and possibly a call
199 # to lrfetchref_used.
201 our (%lrfetchrefs_f, %lrfetchrefs_d);
202 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
204 sub lrfetchref_used ($) {
205 my ($fullrefname) = @_;
206 my $objid = $lrfetchrefs_f{$fullrefname};
207 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
218 return "${package}_".(stripepoch $vsn).$sfx
223 return srcfn($vsn,".dsc");
226 sub changespat ($;$) {
227 my ($vsn, $arch) = @_;
228 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
231 sub upstreamversion ($) {
243 foreach my $f (@end) {
245 print STDERR "$us: cleanup: $@" if length $@;
249 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
251 sub forceable_fail ($$) {
252 my ($forceoptsl, $msg) = @_;
253 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
254 print STDERR "warning: overriding problem due to --force:\n". $msg;
258 my ($forceoptsl) = @_;
259 my @got = grep { $forceopts{$_} } @$forceoptsl;
260 return 0 unless @got;
262 "warning: skipping checks or functionality due to --force-$got[0]\n";
265 sub no_such_package () {
266 print STDERR "$us: package $package does not exist in suite $isuite\n";
272 printdebug "CD $newdir\n";
273 chdir $newdir or confess "chdir: $newdir: $!";
276 sub deliberately ($) {
278 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
281 sub deliberately_not_fast_forward () {
282 foreach (qw(not-fast-forward fresh-repo)) {
283 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
287 sub quiltmode_splitbrain () {
288 $quilt_mode =~ m/gbp|dpm|unapplied/;
291 sub opts_opt_multi_cmd {
293 push @cmd, split /\s+/, shift @_;
299 return opts_opt_multi_cmd @gbp_pq;
302 #---------- remote protocol support, common ----------
304 # remote push initiator/responder protocol:
305 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
306 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
307 # < dgit-remote-push-ready <actual-proto-vsn>
314 # > supplementary-message NBYTES # $protovsn >= 3
319 # > file parsed-changelog
320 # [indicates that output of dpkg-parsechangelog follows]
321 # > data-block NBYTES
322 # > [NBYTES bytes of data (no newline)]
323 # [maybe some more blocks]
332 # > param head DGIT-VIEW-HEAD
333 # > param csuite SUITE
334 # > param tagformat old|new
335 # > param maint-view MAINT-VIEW-HEAD
337 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
338 # # goes into tag, for replay prevention
341 # [indicates that signed tag is wanted]
342 # < data-block NBYTES
343 # < [NBYTES bytes of data (no newline)]
344 # [maybe some more blocks]
348 # > want signed-dsc-changes
349 # < data-block NBYTES [transfer of signed dsc]
351 # < data-block NBYTES [transfer of signed changes]
359 sub i_child_report () {
360 # Sees if our child has died, and reap it if so. Returns a string
361 # describing how it died if it failed, or undef otherwise.
362 return undef unless $i_child_pid;
363 my $got = waitpid $i_child_pid, WNOHANG;
364 return undef if $got <= 0;
365 die unless $got == $i_child_pid;
366 $i_child_pid = undef;
367 return undef unless $?;
368 return "build host child ".waitstatusmsg();
373 fail "connection lost: $!" if $fh->error;
374 fail "protocol violation; $m not expected";
377 sub badproto_badread ($$) {
379 fail "connection lost: $!" if $!;
380 my $report = i_child_report();
381 fail $report if defined $report;
382 badproto $fh, "eof (reading $wh)";
385 sub protocol_expect (&$) {
386 my ($match, $fh) = @_;
389 defined && chomp or badproto_badread $fh, "protocol message";
397 badproto $fh, "\`$_'";
400 sub protocol_send_file ($$) {
401 my ($fh, $ourfn) = @_;
402 open PF, "<", $ourfn or die "$ourfn: $!";
405 my $got = read PF, $d, 65536;
406 die "$ourfn: $!" unless defined $got;
408 print $fh "data-block ".length($d)."\n" or die $!;
409 print $fh $d or die $!;
411 PF->error and die "$ourfn $!";
412 print $fh "data-end\n" or die $!;
416 sub protocol_read_bytes ($$) {
417 my ($fh, $nbytes) = @_;
418 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
420 my $got = read $fh, $d, $nbytes;
421 $got==$nbytes or badproto_badread $fh, "data block";
425 sub protocol_receive_file ($$) {
426 my ($fh, $ourfn) = @_;
427 printdebug "() $ourfn\n";
428 open PF, ">", $ourfn or die "$ourfn: $!";
430 my ($y,$l) = protocol_expect {
431 m/^data-block (.*)$/ ? (1,$1) :
432 m/^data-end$/ ? (0,) :
436 my $d = protocol_read_bytes $fh, $l;
437 print PF $d or die $!;
442 #---------- remote protocol support, responder ----------
444 sub responder_send_command ($) {
446 return unless $we_are_responder;
447 # called even without $we_are_responder
448 printdebug ">> $command\n";
449 print PO $command, "\n" or die $!;
452 sub responder_send_file ($$) {
453 my ($keyword, $ourfn) = @_;
454 return unless $we_are_responder;
455 printdebug "]] $keyword $ourfn\n";
456 responder_send_command "file $keyword";
457 protocol_send_file \*PO, $ourfn;
460 sub responder_receive_files ($@) {
461 my ($keyword, @ourfns) = @_;
462 die unless $we_are_responder;
463 printdebug "[[ $keyword @ourfns\n";
464 responder_send_command "want $keyword";
465 foreach my $fn (@ourfns) {
466 protocol_receive_file \*PI, $fn;
469 protocol_expect { m/^files-end$/ } \*PI;
472 #---------- remote protocol support, initiator ----------
474 sub initiator_expect (&) {
476 protocol_expect { &$match } \*RO;
479 #---------- end remote code ----------
482 if ($we_are_responder) {
484 responder_send_command "progress ".length($m) or die $!;
485 print PO $m or die $!;
495 $ua = LWP::UserAgent->new();
499 progress "downloading $what...";
500 my $r = $ua->get(@_) or die $!;
501 return undef if $r->code == 404;
502 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
503 return $r->decoded_content(charset => 'none');
506 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
511 failedcmd @_ if system @_;
514 sub act_local () { return $dryrun_level <= 1; }
515 sub act_scary () { return !$dryrun_level; }
518 if (!$dryrun_level) {
519 progress "dgit ok: @_";
521 progress "would be ok: @_ (but dry run only)";
526 printcmd(\*STDERR,$debugprefix."#",@_);
529 sub runcmd_ordryrun {
537 sub runcmd_ordryrun_local {
546 my ($first_shell, @cmd) = @_;
547 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
550 our $helpmsg = <<END;
552 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
553 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
554 dgit [dgit-opts] build [dpkg-buildpackage-opts]
555 dgit [dgit-opts] sbuild [sbuild-opts]
556 dgit [dgit-opts] push [dgit-opts] [suite]
557 dgit [dgit-opts] rpush build-host:build-dir ...
558 important dgit options:
559 -k<keyid> sign tag and package with <keyid> instead of default
560 --dry-run -n do not change anything, but go through the motions
561 --damp-run -L like --dry-run but make local changes, without signing
562 --new -N allow introducing a new package
563 --debug -D increase debug level
564 -c<name>=<value> set git config option (used directly by dgit too)
567 our $later_warning_msg = <<END;
568 Perhaps the upload is stuck in incoming. Using the version from git.
572 print STDERR "$us: @_\n", $helpmsg or die $!;
577 @ARGV or badusage "too few arguments";
578 return scalar shift @ARGV;
582 print $helpmsg or die $!;
586 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
588 our %defcfg = ('dgit.default.distro' => 'debian',
589 'dgit-suite.*-security.distro' => 'debian-security',
590 'dgit.default.username' => '',
591 'dgit.default.archive-query-default-component' => 'main',
592 'dgit.default.ssh' => 'ssh',
593 'dgit.default.archive-query' => 'madison:',
594 'dgit.default.sshpsql-dbname' => 'service=projectb',
595 'dgit.default.aptget-components' => 'main',
596 'dgit.default.dgit-tag-format' => 'new,old,maint',
597 # old means "repo server accepts pushes with old dgit tags"
598 # new means "repo server accepts pushes with new dgit tags"
599 # maint means "repo server accepts split brain pushes"
600 # hist means "repo server may have old pushes without new tag"
601 # ("hist" is implied by "old")
602 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
603 'dgit-distro.debian.git-check' => 'url',
604 'dgit-distro.debian.git-check-suffix' => '/info/refs',
605 'dgit-distro.debian.new-private-pushers' => 't',
606 'dgit-distro.debian/push.git-url' => '',
607 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
608 'dgit-distro.debian/push.git-user-force' => 'dgit',
609 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
610 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
611 'dgit-distro.debian/push.git-create' => 'true',
612 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
613 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
614 # 'dgit-distro.debian.archive-query-tls-key',
615 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
616 # ^ this does not work because curl is broken nowadays
617 # Fixing #790093 properly will involve providing providing the key
618 # in some pacagke and maybe updating these paths.
620 # 'dgit-distro.debian.archive-query-tls-curl-args',
621 # '--ca-path=/etc/ssl/ca-debian',
622 # ^ this is a workaround but works (only) on DSA-administered machines
623 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
624 'dgit-distro.debian.git-url-suffix' => '',
625 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
626 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
627 'dgit-distro.debian-security.archive-query' => 'aptget:',
628 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
629 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
630 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
631 'dgit-distro.debian-security.nominal-distro' => 'debian',
632 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
633 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
634 'dgit-distro.ubuntu.git-check' => 'false',
635 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
636 'dgit-distro.test-dummy.ssh' => "$td/ssh",
637 'dgit-distro.test-dummy.username' => "alice",
638 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
639 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
640 'dgit-distro.test-dummy.git-url' => "$td/git",
641 'dgit-distro.test-dummy.git-host' => "git",
642 'dgit-distro.test-dummy.git-path' => "$td/git",
643 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
644 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
645 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
646 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
650 our @gitcfgsources = qw(cmdline local global system);
652 sub git_slurp_config () {
653 local ($debuglevel) = $debuglevel-2;
656 # This algoritm is a bit subtle, but this is needed so that for
657 # options which we want to be single-valued, we allow the
658 # different config sources to override properly. See #835858.
659 foreach my $src (@gitcfgsources) {
660 next if $src eq 'cmdline';
661 # we do this ourselves since git doesn't handle it
663 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
666 open GITS, "-|", @cmd or die $!;
669 printdebug "=> ", (messagequote $_), "\n";
671 push @{ $gitcfgs{$src}{$`} }, $'; #';
675 or ($!==0 && $?==256)
680 sub git_get_config ($) {
682 foreach my $src (@gitcfgsources) {
683 my $l = $gitcfgs{$src}{$c};
684 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
687 @$l==1 or badcfg "multiple values for $c".
688 " (in $src git config)" if @$l > 1;
696 return undef if $c =~ /RETURN-UNDEF/;
697 my $v = git_get_config($c);
698 return $v if defined $v;
699 my $dv = $defcfg{$c};
700 return $dv if defined $dv;
702 badcfg "need value for one of: @_\n".
703 "$us: distro or suite appears not to be (properly) supported";
706 sub access_basedistro () {
707 if (defined $idistro) {
710 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
711 return $def if defined $def;
712 foreach my $src (@gitcfgsources, 'internal') {
713 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
715 foreach my $k (keys %$kl) {
716 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
718 next unless match_glob $dpat, $isuite;
722 return cfg("dgit.default.distro");
726 sub access_nomdistro () {
727 my $base = access_basedistro();
728 return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
731 sub access_quirk () {
732 # returns (quirk name, distro to use instead or undef, quirk-specific info)
733 my $basedistro = access_basedistro();
734 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
736 if (defined $backports_quirk) {
737 my $re = $backports_quirk;
738 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
740 $re =~ s/\%/([-0-9a-z_]+)/
741 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
742 if ($isuite =~ m/^$re$/) {
743 return ('backports',"$basedistro-backports",$1);
746 return ('none',undef);
751 sub parse_cfg_bool ($$$) {
752 my ($what,$def,$v) = @_;
755 $v =~ m/^[ty1]/ ? 1 :
756 $v =~ m/^[fn0]/ ? 0 :
757 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
760 sub access_forpush_config () {
761 my $d = access_basedistro();
765 parse_cfg_bool('new-private-pushers', 0,
766 cfg("dgit-distro.$d.new-private-pushers",
769 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
772 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
773 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
774 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
775 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
778 sub access_forpush () {
779 $access_forpush //= access_forpush_config();
780 return $access_forpush;
784 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
785 badcfg "pushing but distro is configured readonly"
786 if access_forpush_config() eq '0';
788 $supplementary_message = <<'END' unless $we_are_responder;
789 Push failed, before we got started.
790 You can retry the push, after fixing the problem, if you like.
792 finalise_opts_opts();
796 finalise_opts_opts();
799 sub supplementary_message ($) {
801 if (!$we_are_responder) {
802 $supplementary_message = $msg;
804 } elsif ($protovsn >= 3) {
805 responder_send_command "supplementary-message ".length($msg)
807 print PO $msg or die $!;
811 sub access_distros () {
812 # Returns list of distros to try, in order
815 # 0. `instead of' distro name(s) we have been pointed to
816 # 1. the access_quirk distro, if any
817 # 2a. the user's specified distro, or failing that } basedistro
818 # 2b. the distro calculated from the suite }
819 my @l = access_basedistro();
821 my (undef,$quirkdistro) = access_quirk();
822 unshift @l, $quirkdistro;
823 unshift @l, $instead_distro;
824 @l = grep { defined } @l;
826 push @l, access_nomdistro();
828 if (access_forpush()) {
829 @l = map { ("$_/push", $_) } @l;
834 sub access_cfg_cfgs (@) {
837 # The nesting of these loops determines the search order. We put
838 # the key loop on the outside so that we search all the distros
839 # for each key, before going on to the next key. That means that
840 # if access_cfg is called with a more specific, and then a less
841 # specific, key, an earlier distro can override the less specific
842 # without necessarily overriding any more specific keys. (If the
843 # distro wants to override the more specific keys it can simply do
844 # so; whereas if we did the loop the other way around, it would be
845 # impossible to for an earlier distro to override a less specific
846 # key but not the more specific ones without restating the unknown
847 # values of the more specific keys.
850 # We have to deal with RETURN-UNDEF specially, so that we don't
851 # terminate the search prematurely.
853 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
856 foreach my $d (access_distros()) {
857 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
859 push @cfgs, map { "dgit.default.$_" } @realkeys;
866 my (@cfgs) = access_cfg_cfgs(@keys);
867 my $value = cfg(@cfgs);
871 sub access_cfg_bool ($$) {
872 my ($def, @keys) = @_;
873 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
876 sub string_to_ssh ($) {
878 if ($spec =~ m/\s/) {
879 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
885 sub access_cfg_ssh () {
886 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
887 if (!defined $gitssh) {
890 return string_to_ssh $gitssh;
894 sub access_runeinfo ($) {
896 return ": dgit ".access_basedistro()." $info ;";
899 sub access_someuserhost ($) {
901 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
902 defined($user) && length($user) or
903 $user = access_cfg("$some-user",'username');
904 my $host = access_cfg("$some-host");
905 return length($user) ? "$user\@$host" : $host;
908 sub access_gituserhost () {
909 return access_someuserhost('git');
912 sub access_giturl (;$) {
914 my $url = access_cfg('git-url','RETURN-UNDEF');
917 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
918 return undef unless defined $proto;
921 access_gituserhost().
922 access_cfg('git-path');
924 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
927 return "$url/$package$suffix";
930 sub parsecontrolfh ($$;$) {
931 my ($fh, $desc, $allowsigned) = @_;
932 our $dpkgcontrolhash_noissigned;
935 my %opts = ('name' => $desc);
936 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
937 $c = Dpkg::Control::Hash->new(%opts);
938 $c->parse($fh,$desc) or die "parsing of $desc failed";
939 last if $allowsigned;
940 last if $dpkgcontrolhash_noissigned;
941 my $issigned= $c->get_option('is_pgp_signed');
942 if (!defined $issigned) {
943 $dpkgcontrolhash_noissigned= 1;
944 seek $fh, 0,0 or die "seek $desc: $!";
945 } elsif ($issigned) {
946 fail "control file $desc is (already) PGP-signed. ".
947 " Note that dgit push needs to modify the .dsc and then".
948 " do the signature itself";
957 my ($file, $desc, $allowsigned) = @_;
958 my $fh = new IO::Handle;
959 open $fh, '<', $file or die "$file: $!";
960 my $c = parsecontrolfh($fh,$desc,$allowsigned);
961 $fh->error and die $!;
967 my ($dctrl,$field) = @_;
968 my $v = $dctrl->{$field};
969 return $v if defined $v;
970 fail "missing field $field in ".$dctrl->get_option('name');
974 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
975 my $p = new IO::Handle;
976 my @cmd = (qw(dpkg-parsechangelog), @_);
977 open $p, '-|', @cmd or die $!;
979 $?=0; $!=0; close $p or failedcmd @cmd;
983 sub commit_getclogp ($) {
984 # Returns the parsed changelog hashref for a particular commit
986 our %commit_getclogp_memo;
987 my $memo = $commit_getclogp_memo{$objid};
988 return $memo if $memo;
990 my $mclog = ".git/dgit/clog-$objid";
991 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
992 "$objid:debian/changelog";
993 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
998 defined $d or fail "getcwd failed: $!";
1002 sub parse_dscdata () {
1003 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1004 printdebug Dumper($dscdata) if $debuglevel>1;
1005 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1006 printdebug Dumper($dsc) if $debuglevel>1;
1011 sub archive_query ($;@) {
1012 my ($method) = shift @_;
1013 my $query = access_cfg('archive-query','RETURN-UNDEF');
1014 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1017 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1020 sub archive_query_prepend_mirror {
1021 my $m = access_cfg('mirror');
1022 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1025 sub pool_dsc_subpath ($$) {
1026 my ($vsn,$component) = @_; # $package is implict arg
1027 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1028 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1031 sub cfg_apply_map ($$$) {
1032 my ($varref, $what, $mapspec) = @_;
1033 return unless $mapspec;
1035 printdebug "config $what EVAL{ $mapspec; }\n";
1037 eval "package Dgit::Config; $mapspec;";
1042 #---------- `ftpmasterapi' archive query method (nascent) ----------
1044 sub archive_api_query_cmd ($) {
1046 my @cmd = (@curl, qw(-sS));
1047 my $url = access_cfg('archive-query-url');
1048 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1050 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1051 foreach my $key (split /\:/, $keys) {
1052 $key =~ s/\%HOST\%/$host/g;
1054 fail "for $url: stat $key: $!" unless $!==ENOENT;
1057 fail "config requested specific TLS key but do not know".
1058 " how to get curl to use exactly that EE key ($key)";
1059 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1060 # # Sadly the above line does not work because of changes
1061 # # to gnutls. The real fix for #790093 may involve
1062 # # new curl options.
1065 # Fixing #790093 properly will involve providing a value
1066 # for this on clients.
1067 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1068 push @cmd, split / /, $kargs if defined $kargs;
1070 push @cmd, $url.$subpath;
1074 sub api_query ($$;$) {
1076 my ($data, $subpath, $ok404) = @_;
1077 badcfg "ftpmasterapi archive query method takes no data part"
1079 my @cmd = archive_api_query_cmd($subpath);
1080 my $url = $cmd[$#cmd];
1081 push @cmd, qw(-w %{http_code});
1082 my $json = cmdoutput @cmd;
1083 unless ($json =~ s/\d+\d+\d$//) {
1084 failedcmd_report_cmd undef, @cmd;
1085 fail "curl failed to print 3-digit HTTP code";
1088 return undef if $code eq '404' && $ok404;
1089 fail "fetch of $url gave HTTP code $code"
1090 unless $url =~ m#^file://# or $code =~ m/^2/;
1091 return decode_json($json);
1094 sub canonicalise_suite_ftpmasterapi {
1095 my ($proto,$data) = @_;
1096 my $suites = api_query($data, 'suites');
1098 foreach my $entry (@$suites) {
1100 my $v = $entry->{$_};
1101 defined $v && $v eq $isuite;
1102 } qw(codename name);
1103 push @matched, $entry;
1105 fail "unknown suite $isuite" unless @matched;
1108 @matched==1 or die "multiple matches for suite $isuite\n";
1109 $cn = "$matched[0]{codename}";
1110 defined $cn or die "suite $isuite info has no codename\n";
1111 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1113 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1118 sub archive_query_ftpmasterapi {
1119 my ($proto,$data) = @_;
1120 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1122 my $digester = Digest::SHA->new(256);
1123 foreach my $entry (@$info) {
1125 my $vsn = "$entry->{version}";
1126 my ($ok,$msg) = version_check $vsn;
1127 die "bad version: $msg\n" unless $ok;
1128 my $component = "$entry->{component}";
1129 $component =~ m/^$component_re$/ or die "bad component";
1130 my $filename = "$entry->{filename}";
1131 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1132 or die "bad filename";
1133 my $sha256sum = "$entry->{sha256sum}";
1134 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1135 push @rows, [ $vsn, "/pool/$component/$filename",
1136 $digester, $sha256sum ];
1138 die "bad ftpmaster api response: $@\n".Dumper($entry)
1141 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1142 return archive_query_prepend_mirror @rows;
1145 sub file_in_archive_ftpmasterapi {
1146 my ($proto,$data,$filename) = @_;
1147 my $pat = $filename;
1150 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1151 my $info = api_query($data, "file_in_archive/$pat", 1);
1154 #---------- `aptget' archive query method ----------
1157 our $aptget_releasefile;
1158 our $aptget_configpath;
1160 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1161 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1163 sub aptget_cache_clean {
1164 runcmd_ordryrun_local qw(sh -ec),
1165 'cd "$1"; pwd; find -atime +30 -type f -print0 | xargs -0r echo rm --',
1169 sub aptget_lock_acquire () {
1170 my $lockfile = "$aptget_base/lock";
1171 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1172 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1175 sub aptget_prep ($) {
1177 return if defined $aptget_base;
1179 badcfg "aptget archive query method takes no data part"
1182 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1185 ensuredir "$cache/dgit";
1187 access_cfg('aptget-cachekey','RETURN-UNDEF')
1188 // access_nomdistro();
1190 $aptget_base = "$cache/dgit/aptget";
1191 ensuredir $aptget_base;
1193 my $quoted_base = $aptget_base;
1194 die "$quoted_base contains bad chars, cannot continue"
1195 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1197 ensuredir $aptget_base;
1199 aptget_lock_acquire();
1201 aptget_cache_clean();
1203 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1204 my $sourceslist = "source.list#$cachekey";
1206 my $aptsuites = $isuite;
1207 cfg_apply_map(\$aptsuites, 'suite map',
1208 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1210 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1211 printf SRCS "deb-src %s %s %s\n",
1212 access_cfg('mirror'),
1214 access_cfg('aptget-components')
1217 ensuredir "$aptget_base/cache";
1218 ensuredir "$aptget_base/lists";
1220 open CONF, ">", $aptget_configpath or die $!;
1222 Debug::NoLocking "true";
1223 APT::Get::List-Cleanup "false";
1224 #clear APT::Update::Post-Invoke-Success;
1225 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1226 Dir::State::Lists "$quoted_base/lists";
1227 Dir::Etc::preferences "$quoted_base/preferences";
1228 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1229 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1232 foreach my $key (qw(
1235 Dir::Cache::Archives
1236 Dir::Etc::SourceParts
1237 Dir::Etc::preferencesparts
1239 ensuredir "$aptget_base/$key";
1240 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1243 my $oldatime = (time // die $!) - 1;
1244 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1245 next unless stat_exists $oldlist;
1246 my ($mtime) = (stat _)[9];
1247 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1250 runcmd_ordryrun_local aptget_aptget(), qw(update);
1253 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1254 next unless stat_exists $oldlist;
1255 my ($atime) = (stat _)[8];
1256 next if $atime == $oldatime;
1257 push @releasefiles, $oldlist;
1259 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1260 @releasefiles = @inreleasefiles if @inreleasefiles;
1261 die "apt updated wrong number of Release files (@releasefiles), erk"
1262 unless @releasefiles == 1;
1264 ($aptget_releasefile) = @releasefiles;
1267 sub canonicalise_suite_aptget {
1268 my ($proto,$data) = @_;
1271 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1273 foreach my $name (qw(Codename Suite)) {
1274 my $val = $release->{$name};
1276 $val =~ m/^$suite_re$/o or fail
1277 "Release file ($aptget_releasefile) specifies intolerable $name";
1278 cfg_apply_map(\$val, 'suite rmap',
1279 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1286 sub archive_query_aptget {
1287 my ($proto,$data) = @_;
1290 ensuredir "$aptget_base/source";
1291 foreach my $old (<$aptget_base/source/*.dsc>) {
1292 unlink $old or die "$old: $!";
1295 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1296 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1297 # avoids apt-get source failing with ambiguous error code
1299 runcmd_ordryrun_local
1300 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1301 aptget_aptget(), qw(--download-only --only-source source), $package;
1303 my @dscs = <$aptget_base/source/*.dsc>;
1304 fail "apt-get source did not produce a .dsc" unless @dscs;
1305 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1307 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1310 my $uri = "file://". uri_escape $dscs[0];
1311 $uri =~ s{\%2f}{/}gi;
1312 return [ (getfield $pre_dsc, 'Version'), $uri ];
1315 #---------- `dummyapicat' archive query method ----------
1317 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1318 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1320 sub file_in_archive_dummycatapi ($$$) {
1321 my ($proto,$data,$filename) = @_;
1322 my $mirror = access_cfg('mirror');
1323 $mirror =~ s#^file://#/# or die "$mirror ?";
1325 my @cmd = (qw(sh -ec), '
1327 find -name "$2" -print0 |
1329 ', qw(x), $mirror, $filename);
1330 debugcmd "-|", @cmd;
1331 open FIA, "-|", @cmd or die $!;
1334 printdebug "| $_\n";
1335 m/^(\w+) (\S+)$/ or die "$_ ?";
1336 push @out, { sha256sum => $1, filename => $2 };
1338 close FIA or die failedcmd @cmd;
1342 #---------- `madison' archive query method ----------
1344 sub archive_query_madison {
1345 return archive_query_prepend_mirror
1346 map { [ @$_[0..1] ] } madison_get_parse(@_);
1349 sub madison_get_parse {
1350 my ($proto,$data) = @_;
1351 die unless $proto eq 'madison';
1352 if (!length $data) {
1353 $data= access_cfg('madison-distro','RETURN-UNDEF');
1354 $data //= access_basedistro();
1356 $rmad{$proto,$data,$package} ||= cmdoutput
1357 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1358 my $rmad = $rmad{$proto,$data,$package};
1361 foreach my $l (split /\n/, $rmad) {
1362 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1363 \s*( [^ \t|]+ )\s* \|
1364 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1365 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1366 $1 eq $package or die "$rmad $package ?";
1373 $component = access_cfg('archive-query-default-component');
1375 $5 eq 'source' or die "$rmad ?";
1376 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1378 return sort { -version_compare($a->[0],$b->[0]); } @out;
1381 sub canonicalise_suite_madison {
1382 # madison canonicalises for us
1383 my @r = madison_get_parse(@_);
1385 "unable to canonicalise suite using package $package".
1386 " which does not appear to exist in suite $isuite;".
1387 " --existing-package may help";
1391 sub file_in_archive_madison { return undef; }
1393 #---------- `sshpsql' archive query method ----------
1396 my ($data,$runeinfo,$sql) = @_;
1397 if (!length $data) {
1398 $data= access_someuserhost('sshpsql').':'.
1399 access_cfg('sshpsql-dbname');
1401 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1402 my ($userhost,$dbname) = ($`,$'); #';
1404 my @cmd = (access_cfg_ssh, $userhost,
1405 access_runeinfo("ssh-psql $runeinfo").
1406 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1407 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1409 open P, "-|", @cmd or die $!;
1412 printdebug(">|$_|\n");
1415 $!=0; $?=0; close P or failedcmd @cmd;
1417 my $nrows = pop @rows;
1418 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1419 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1420 @rows = map { [ split /\|/, $_ ] } @rows;
1421 my $ncols = scalar @{ shift @rows };
1422 die if grep { scalar @$_ != $ncols } @rows;
1426 sub sql_injection_check {
1427 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1430 sub archive_query_sshpsql ($$) {
1431 my ($proto,$data) = @_;
1432 sql_injection_check $isuite, $package;
1433 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1434 SELECT source.version, component.name, files.filename, files.sha256sum
1436 JOIN src_associations ON source.id = src_associations.source
1437 JOIN suite ON suite.id = src_associations.suite
1438 JOIN dsc_files ON dsc_files.source = source.id
1439 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1440 JOIN component ON component.id = files_archive_map.component_id
1441 JOIN files ON files.id = dsc_files.file
1442 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1443 AND source.source='$package'
1444 AND files.filename LIKE '%.dsc';
1446 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1447 my $digester = Digest::SHA->new(256);
1449 my ($vsn,$component,$filename,$sha256sum) = @$_;
1450 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1452 return archive_query_prepend_mirror @rows;
1455 sub canonicalise_suite_sshpsql ($$) {
1456 my ($proto,$data) = @_;
1457 sql_injection_check $isuite;
1458 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1459 SELECT suite.codename
1460 FROM suite where suite_name='$isuite' or codename='$isuite';
1462 @rows = map { $_->[0] } @rows;
1463 fail "unknown suite $isuite" unless @rows;
1464 die "ambiguous $isuite: @rows ?" if @rows>1;
1468 sub file_in_archive_sshpsql ($$$) { return undef; }
1470 #---------- `dummycat' archive query method ----------
1472 sub canonicalise_suite_dummycat ($$) {
1473 my ($proto,$data) = @_;
1474 my $dpath = "$data/suite.$isuite";
1475 if (!open C, "<", $dpath) {
1476 $!==ENOENT or die "$dpath: $!";
1477 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1481 chomp or die "$dpath: $!";
1483 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1487 sub archive_query_dummycat ($$) {
1488 my ($proto,$data) = @_;
1489 canonicalise_suite();
1490 my $dpath = "$data/package.$csuite.$package";
1491 if (!open C, "<", $dpath) {
1492 $!==ENOENT or die "$dpath: $!";
1493 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1501 printdebug "dummycat query $csuite $package $dpath | $_\n";
1502 my @row = split /\s+/, $_;
1503 @row==2 or die "$dpath: $_ ?";
1506 C->error and die "$dpath: $!";
1508 return archive_query_prepend_mirror
1509 sort { -version_compare($a->[0],$b->[0]); } @rows;
1512 sub file_in_archive_dummycat () { return undef; }
1514 #---------- tag format handling ----------
1516 sub access_cfg_tagformats () {
1517 split /\,/, access_cfg('dgit-tag-format');
1520 sub 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";
1567 sub get_archive_dsc () {
1568 canonicalise_suite();
1569 my @vsns = archive_query('archive_query');
1570 foreach my $vinfo (@vsns) {
1571 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1572 $dscurl = $vsn_dscurl;
1573 $dscdata = url_get($dscurl);
1575 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1580 $digester->add($dscdata);
1581 my $got = $digester->hexdigest();
1583 fail "$dscurl has hash $got but".
1584 " archive told us to expect $digest";
1587 my $fmt = getfield $dsc, 'Format';
1588 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1589 "unsupported source format $fmt, sorry";
1591 $dsc_checked = !!$digester;
1592 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1596 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1599 sub check_for_git ();
1600 sub check_for_git () {
1602 my $how = access_cfg('git-check');
1603 if ($how eq 'ssh-cmd') {
1605 (access_cfg_ssh, access_gituserhost(),
1606 access_runeinfo("git-check $package").
1607 " set -e; cd ".access_cfg('git-path').";".
1608 " if test -d $package.git; then echo 1; else echo 0; fi");
1609 my $r= cmdoutput @cmd;
1610 if (defined $r and $r =~ m/^divert (\w+)$/) {
1612 my ($usedistro,) = access_distros();
1613 # NB that if we are pushing, $usedistro will be $distro/push
1614 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1615 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1616 progress "diverting to $divert (using config for $instead_distro)";
1617 return check_for_git();
1619 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1621 } elsif ($how eq 'url') {
1622 my $prefix = access_cfg('git-check-url','git-url');
1623 my $suffix = access_cfg('git-check-suffix','git-suffix',
1624 'RETURN-UNDEF') // '.git';
1625 my $url = "$prefix/$package$suffix";
1626 my @cmd = (@curl, qw(-sS -I), $url);
1627 my $result = cmdoutput @cmd;
1628 $result =~ s/^\S+ 200 .*\n\r?\n//;
1629 # curl -sS -I with https_proxy prints
1630 # HTTP/1.0 200 Connection established
1631 $result =~ m/^\S+ (404|200) /s or
1632 fail "unexpected results from git check query - ".
1633 Dumper($prefix, $result);
1635 if ($code eq '404') {
1637 } elsif ($code eq '200') {
1642 } elsif ($how eq 'true') {
1644 } elsif ($how eq 'false') {
1647 badcfg "unknown git-check \`$how'";
1651 sub create_remote_git_repo () {
1652 my $how = access_cfg('git-create');
1653 if ($how eq 'ssh-cmd') {
1655 (access_cfg_ssh, access_gituserhost(),
1656 access_runeinfo("git-create $package").
1657 "set -e; cd ".access_cfg('git-path').";".
1658 " cp -a _template $package.git");
1659 } elsif ($how eq 'true') {
1662 badcfg "unknown git-create \`$how'";
1666 our ($dsc_hash,$lastpush_mergeinput);
1668 our $ud = '.git/dgit/unpack';
1678 sub mktree_in_ud_here () {
1679 runcmd qw(git init -q);
1680 runcmd qw(git config gc.auto 0);
1681 rmtree('.git/objects');
1682 symlink '../../../../objects','.git/objects' or die $!;
1685 sub git_write_tree () {
1686 my $tree = cmdoutput @git, qw(write-tree);
1687 $tree =~ m/^\w+$/ or die "$tree ?";
1691 sub remove_stray_gits () {
1692 my @gitscmd = qw(find -name .git -prune -print0);
1693 debugcmd "|",@gitscmd;
1694 open GITS, "-|", @gitscmd or die $!;
1699 print STDERR "$us: warning: removing from source package: ",
1700 (messagequote $_), "\n";
1704 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1707 sub mktree_in_ud_from_only_subdir (;$) {
1710 # changes into the subdir
1712 die "expected one subdir but found @dirs ?" unless @dirs==1;
1713 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1717 remove_stray_gits();
1718 mktree_in_ud_here();
1720 my ($format, $fopts) = get_source_format();
1721 if (madformat($format)) {
1726 runcmd @git, qw(add -Af);
1727 my $tree=git_write_tree();
1728 return ($tree,$dir);
1731 our @files_csum_info_fields =
1732 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1733 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1734 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1736 sub dsc_files_info () {
1737 foreach my $csumi (@files_csum_info_fields) {
1738 my ($fname, $module, $method) = @$csumi;
1739 my $field = $dsc->{$fname};
1740 next unless defined $field;
1741 eval "use $module; 1;" or die $@;
1743 foreach (split /\n/, $field) {
1745 m/^(\w+) (\d+) (\S+)$/ or
1746 fail "could not parse .dsc $fname line \`$_'";
1747 my $digester = eval "$module"."->$method;" or die $@;
1752 Digester => $digester,
1757 fail "missing any supported Checksums-* or Files field in ".
1758 $dsc->get_option('name');
1762 map { $_->{Filename} } dsc_files_info();
1765 sub files_compare_inputs (@) {
1770 my $showinputs = sub {
1771 return join "; ", map { $_->get_option('name') } @$inputs;
1774 foreach my $in (@$inputs) {
1776 my $in_name = $in->get_option('name');
1778 printdebug "files_compare_inputs $in_name\n";
1780 foreach my $csumi (@files_csum_info_fields) {
1781 my ($fname) = @$csumi;
1782 printdebug "files_compare_inputs $in_name $fname\n";
1784 my $field = $in->{$fname};
1785 next unless defined $field;
1788 foreach (split /\n/, $field) {
1791 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1792 fail "could not parse $in_name $fname line \`$_'";
1794 printdebug "files_compare_inputs $in_name $fname $f\n";
1798 my $re = \ $record{$f}{$fname};
1800 $fchecked{$f}{$in_name} = 1;
1802 fail "hash or size of $f varies in $fname fields".
1803 " (between: ".$showinputs->().")";
1808 @files = sort @files;
1809 $expected_files //= \@files;
1810 "@$expected_files" eq "@files" or
1811 fail "file list in $in_name varies between hash fields!";
1814 fail "$in_name has no files list field(s)";
1816 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1819 grep { keys %$_ == @$inputs-1 } values %fchecked
1820 or fail "no file appears in all file lists".
1821 " (looked in: ".$showinputs->().")";
1824 sub is_orig_file_in_dsc ($$) {
1825 my ($f, $dsc_files_info) = @_;
1826 return 0 if @$dsc_files_info <= 1;
1827 # One file means no origs, and the filename doesn't have a "what
1828 # part of dsc" component. (Consider versions ending `.orig'.)
1829 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1833 sub is_orig_file_of_vsn ($$) {
1834 my ($f, $upstreamvsn) = @_;
1835 my $base = srcfn $upstreamvsn, '';
1836 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1840 sub changes_update_origs_from_dsc ($$$$) {
1841 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1843 printdebug "checking origs needed ($upstreamvsn)...\n";
1844 $_ = getfield $changes, 'Files';
1845 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1846 fail "cannot find section/priority from .changes Files field";
1847 my $placementinfo = $1;
1849 printdebug "checking origs needed placement '$placementinfo'...\n";
1850 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1851 $l =~ m/\S+$/ or next;
1853 printdebug "origs $file | $l\n";
1854 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1855 printdebug "origs $file is_orig\n";
1856 my $have = archive_query('file_in_archive', $file);
1857 if (!defined $have) {
1859 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1865 printdebug "origs $file \$#\$have=$#$have\n";
1866 foreach my $h (@$have) {
1869 foreach my $csumi (@files_csum_info_fields) {
1870 my ($fname, $module, $method, $archivefield) = @$csumi;
1871 next unless defined $h->{$archivefield};
1872 $_ = $dsc->{$fname};
1873 next unless defined;
1874 m/^(\w+) .* \Q$file\E$/m or
1875 fail ".dsc $fname missing entry for $file";
1876 if ($h->{$archivefield} eq $1) {
1880 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1883 die "$file ".Dumper($h)." ?!" if $same && @differ;
1886 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1889 print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1890 if (@found_differ && !$found_same) {
1892 "archive contains $file with different checksum",
1895 # Now we edit the changes file to add or remove it
1896 foreach my $csumi (@files_csum_info_fields) {
1897 my ($fname, $module, $method, $archivefield) = @$csumi;
1898 next unless defined $changes->{$fname};
1900 # in archive, delete from .changes if it's there
1901 $changed{$file} = "removed" if
1902 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1903 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1904 # not in archive, but it's here in the .changes
1906 my $dsc_data = getfield $dsc, $fname;
1907 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1909 $extra =~ s/ \d+ /$&$placementinfo /
1910 or die "$fname $extra >$dsc_data< ?"
1911 if $fname eq 'Files';
1912 $changes->{$fname} .= "\n". $extra;
1913 $changed{$file} = "added";
1918 foreach my $file (keys %changed) {
1920 "edited .changes for archive .orig contents: %s %s",
1921 $changed{$file}, $file;
1923 my $chtmp = "$changesfile.tmp";
1924 $changes->save($chtmp);
1926 rename $chtmp,$changesfile or die "$changesfile $!";
1928 progress "[new .changes left in $changesfile]";
1931 progress "$changesfile already has appropriate .orig(s) (if any)";
1935 sub make_commit ($) {
1937 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1940 sub make_commit_text ($) {
1943 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1945 print Dumper($text) if $debuglevel > 1;
1946 my $child = open2($out, $in, @cmd) or die $!;
1949 print $in $text or die $!;
1950 close $in or die $!;
1952 $h =~ m/^\w+$/ or die;
1954 printdebug "=> $h\n";
1957 waitpid $child, 0 == $child or die "$child $!";
1958 $? and failedcmd @cmd;
1962 sub clogp_authline ($) {
1964 my $author = getfield $clogp, 'Maintainer';
1965 $author =~ s#,.*##ms;
1966 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1967 my $authline = "$author $date";
1968 $authline =~ m/$git_authline_re/o or
1969 fail "unexpected commit author line format \`$authline'".
1970 " (was generated from changelog Maintainer field)";
1971 return ($1,$2,$3) if wantarray;
1975 sub vendor_patches_distro ($$) {
1976 my ($checkdistro, $what) = @_;
1977 return unless defined $checkdistro;
1979 my $series = "debian/patches/\L$checkdistro\E.series";
1980 printdebug "checking for vendor-specific $series ($what)\n";
1982 if (!open SERIES, "<", $series) {
1983 die "$series $!" unless $!==ENOENT;
1992 Unfortunately, this source package uses a feature of dpkg-source where
1993 the same source package unpacks to different source code on different
1994 distros. dgit cannot safely operate on such packages on affected
1995 distros, because the meaning of source packages is not stable.
1997 Please ask the distro/maintainer to remove the distro-specific series
1998 files and use a different technique (if necessary, uploading actually
1999 different packages, if different distros are supposed to have
2003 fail "Found active distro-specific series file for".
2004 " $checkdistro ($what): $series, cannot continue";
2006 die "$series $!" if SERIES->error;
2010 sub check_for_vendor_patches () {
2011 # This dpkg-source feature doesn't seem to be documented anywhere!
2012 # But it can be found in the changelog (reformatted):
2014 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2015 # Author: Raphael Hertzog <hertzog@debian.org>
2016 # Date: Sun Oct 3 09:36:48 2010 +0200
2018 # dpkg-source: correctly create .pc/.quilt_series with alternate
2021 # If you have debian/patches/ubuntu.series and you were
2022 # unpacking the source package on ubuntu, quilt was still
2023 # directed to debian/patches/series instead of
2024 # debian/patches/ubuntu.series.
2026 # debian/changelog | 3 +++
2027 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2028 # 2 files changed, 6 insertions(+), 1 deletion(-)
2031 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2032 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2033 "Dpkg::Vendor \`current vendor'");
2034 vendor_patches_distro(access_basedistro(),
2035 "(base) distro being accessed");
2036 vendor_patches_distro(access_nomdistro(),
2037 "(nominal) distro being accessed");
2040 sub generate_commits_from_dsc () {
2041 # See big comment in fetch_from_archive, below.
2042 # See also README.dsc-import.
2046 my @dfi = dsc_files_info();
2047 foreach my $fi (@dfi) {
2048 my $f = $fi->{Filename};
2049 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2051 printdebug "considering linking $f: ";
2053 link_ltarget "../../../../$f", $f
2054 or ((printdebug "($!) "), 0)
2058 printdebug "linked.\n";
2060 complete_file_from_dsc('.', $fi)
2063 if (is_orig_file_in_dsc($f, \@dfi)) {
2064 link $f, "../../../../$f"
2070 # We unpack and record the orig tarballs first, so that we only
2071 # need disk space for one private copy of the unpacked source.
2072 # But we can't make them into commits until we have the metadata
2073 # from the debian/changelog, so we record the tree objects now and
2074 # make them into commits later.
2076 my $upstreamv = upstreamversion $dsc->{version};
2077 my $orig_f_base = srcfn $upstreamv, '';
2079 foreach my $fi (@dfi) {
2080 # We actually import, and record as a commit, every tarball
2081 # (unless there is only one file, in which case there seems
2084 my $f = $fi->{Filename};
2085 printdebug "import considering $f ";
2086 (printdebug "only one dfi\n"), next if @dfi == 1;
2087 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2088 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2092 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2094 printdebug "Y ", (join ' ', map { $_//"(none)" }
2095 $compr_ext, $orig_f_part
2098 my $input = new IO::File $f, '<' or die "$f $!";
2102 if (defined $compr_ext) {
2104 Dpkg::Compression::compression_guess_from_filename $f;
2105 fail "Dpkg::Compression cannot handle file $f in source package"
2106 if defined $compr_ext && !defined $cname;
2108 new Dpkg::Compression::Process compression => $cname;
2109 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2110 my $compr_fh = new IO::Handle;
2111 my $compr_pid = open $compr_fh, "-|" // die $!;
2113 open STDIN, "<&", $input or die $!;
2115 die "dgit (child): exec $compr_cmd[0]: $!\n";
2120 rmtree "../unpack-tar";
2121 mkdir "../unpack-tar" or die $!;
2122 my @tarcmd = qw(tar -x -f -
2123 --no-same-owner --no-same-permissions
2124 --no-acls --no-xattrs --no-selinux);
2125 my $tar_pid = fork // die $!;
2127 chdir "../unpack-tar" or die $!;
2128 open STDIN, "<&", $input or die $!;
2130 die "dgit (child): exec $tarcmd[0]: $!";
2132 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2133 !$? or failedcmd @tarcmd;
2136 (@compr_cmd ? failedcmd @compr_cmd
2138 # finally, we have the results in "tarball", but maybe
2139 # with the wrong permissions
2141 runcmd qw(chmod -R +rwX ../unpack-tar);
2142 changedir "../unpack-tar";
2143 my ($tree) = mktree_in_ud_from_only_subdir(1);
2144 changedir "../../unpack";
2145 rmtree "../unpack-tar";
2147 my $ent = [ $f, $tree ];
2149 Orig => !!$orig_f_part,
2150 Sort => (!$orig_f_part ? 2 :
2151 $orig_f_part =~ m/-/g ? 1 :
2159 # put any without "_" first (spec is not clear whether files
2160 # are always in the usual order). Tarballs without "_" are
2161 # the main orig or the debian tarball.
2162 $a->{Sort} <=> $b->{Sort} or
2166 my $any_orig = grep { $_->{Orig} } @tartrees;
2168 my $dscfn = "$package.dsc";
2170 my $treeimporthow = 'package';
2172 open D, ">", $dscfn or die "$dscfn: $!";
2173 print D $dscdata or die "$dscfn: $!";
2174 close D or die "$dscfn: $!";
2175 my @cmd = qw(dpkg-source);
2176 push @cmd, '--no-check' if $dsc_checked;
2177 if (madformat $dsc->{format}) {
2178 push @cmd, '--skip-patches';
2179 $treeimporthow = 'unpatched';
2181 push @cmd, qw(-x --), $dscfn;
2184 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2185 if (madformat $dsc->{format}) {
2186 check_for_vendor_patches();
2190 if (madformat $dsc->{format}) {
2191 my @pcmd = qw(dpkg-source --before-build .);
2192 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2194 runcmd @git, qw(add -Af);
2195 $dappliedtree = git_write_tree();
2198 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2199 debugcmd "|",@clogcmd;
2200 open CLOGS, "-|", @clogcmd or die $!;
2205 printdebug "import clog search...\n";
2208 my $stanzatext = do { local $/=""; <CLOGS>; };
2209 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2210 last if !defined $stanzatext;
2212 my $desc = "package changelog, entry no.$.";
2213 open my $stanzafh, "<", \$stanzatext or die;
2214 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2215 $clogp //= $thisstanza;
2217 printdebug "import clog $thisstanza->{version} $desc...\n";
2219 last if !$any_orig; # we don't need $r1clogp
2221 # We look for the first (most recent) changelog entry whose
2222 # version number is lower than the upstream version of this
2223 # package. Then the last (least recent) previous changelog
2224 # entry is treated as the one which introduced this upstream
2225 # version and used for the synthetic commits for the upstream
2228 # One might think that a more sophisticated algorithm would be
2229 # necessary. But: we do not want to scan the whole changelog
2230 # file. Stopping when we see an earlier version, which
2231 # necessarily then is an earlier upstream version, is the only
2232 # realistic way to do that. Then, either the earliest
2233 # changelog entry we have seen so far is indeed the earliest
2234 # upload of this upstream version; or there are only changelog
2235 # entries relating to later upstream versions (which is not
2236 # possible unless the changelog and .dsc disagree about the
2237 # version). Then it remains to choose between the physically
2238 # last entry in the file, and the one with the lowest version
2239 # number. If these are not the same, we guess that the
2240 # versions were created in a non-monotic order rather than
2241 # that the changelog entries have been misordered.
2243 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2245 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2246 $r1clogp = $thisstanza;
2248 printdebug "import clog $r1clogp->{version} becomes r1\n";
2250 die $! if CLOGS->error;
2251 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2253 $clogp or fail "package changelog has no entries!";
2255 my $authline = clogp_authline $clogp;
2256 my $changes = getfield $clogp, 'Changes';
2257 my $cversion = getfield $clogp, 'Version';
2260 $r1clogp //= $clogp; # maybe there's only one entry;
2261 my $r1authline = clogp_authline $r1clogp;
2262 # Strictly, r1authline might now be wrong if it's going to be
2263 # unused because !$any_orig. Whatever.
2265 printdebug "import tartrees authline $authline\n";
2266 printdebug "import tartrees r1authline $r1authline\n";
2268 foreach my $tt (@tartrees) {
2269 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2271 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2274 committer $r1authline
2278 [dgit import orig $tt->{F}]
2286 [dgit import tarball $package $cversion $tt->{F}]
2291 printdebug "import main commit\n";
2293 open C, ">../commit.tmp" or die $!;
2294 print C <<END or die $!;
2297 print C <<END or die $! foreach @tartrees;
2300 print C <<END or die $!;
2306 [dgit import $treeimporthow $package $cversion]
2310 my $rawimport_hash = make_commit qw(../commit.tmp);
2312 if (madformat $dsc->{format}) {
2313 printdebug "import apply patches...\n";
2315 # regularise the state of the working tree so that
2316 # the checkout of $rawimport_hash works nicely.
2317 my $dappliedcommit = make_commit_text(<<END);
2324 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2326 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2328 # We need the answers to be reproducible
2329 my @authline = clogp_authline($clogp);
2330 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2331 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2332 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2333 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2334 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2335 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2337 my $path = $ENV{PATH} or die;
2339 foreach my $use_absurd (qw(0 1)) {
2340 local $ENV{PATH} = $path;
2343 progress "warning: $@";
2344 $path = "$absurdity:$path";
2345 progress "$us: trying slow absurd-git-apply...";
2346 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2351 die "forbid absurd git-apply\n" if $use_absurd
2352 && forceing [qw(import-gitapply-no-absurd)];
2353 die "only absurd git-apply!\n" if !$use_absurd
2354 && forceing [qw(import-gitapply-absurd)];
2356 local $ENV{PATH} = $path if $use_absurd;
2358 my @showcmd = (gbp_pq, qw(import));
2359 my @realcmd = shell_cmd
2360 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2361 debugcmd "+",@realcmd;
2362 if (system @realcmd) {
2363 die +(shellquote @showcmd).
2365 failedcmd_waitstatus()."\n";
2368 my $gapplied = git_rev_parse('HEAD');
2369 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2370 $gappliedtree eq $dappliedtree or
2372 gbp-pq import and dpkg-source disagree!
2373 gbp-pq import gave commit $gapplied
2374 gbp-pq import gave tree $gappliedtree
2375 dpkg-source --before-build gave tree $dappliedtree
2377 $rawimport_hash = $gapplied;
2382 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2387 progress "synthesised git commit from .dsc $cversion";
2389 my $rawimport_mergeinput = {
2390 Commit => $rawimport_hash,
2391 Info => "Import of source package",
2393 my @output = ($rawimport_mergeinput);
2395 if ($lastpush_mergeinput) {
2396 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2397 my $oversion = getfield $oldclogp, 'Version';
2399 version_compare($oversion, $cversion);
2401 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2402 { Message => <<END, ReverseParents => 1 });
2403 Record $package ($cversion) in archive suite $csuite
2405 } elsif ($vcmp > 0) {
2406 print STDERR <<END or die $!;
2408 Version actually in archive: $cversion (older)
2409 Last version pushed with dgit: $oversion (newer or same)
2412 @output = $lastpush_mergeinput;
2414 # Same version. Use what's in the server git branch,
2415 # discarding our own import. (This could happen if the
2416 # server automatically imports all packages into git.)
2417 @output = $lastpush_mergeinput;
2420 changedir '../../../..';
2425 sub complete_file_from_dsc ($$) {
2426 our ($dstdir, $fi) = @_;
2427 # Ensures that we have, in $dir, the file $fi, with the correct
2428 # contents. (Downloading it from alongside $dscurl if necessary.)
2430 my $f = $fi->{Filename};
2431 my $tf = "$dstdir/$f";
2434 if (stat_exists $tf) {
2435 progress "using existing $f";
2437 printdebug "$tf does not exist, need to fetch\n";
2439 $furl =~ s{/[^/]+$}{};
2441 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2442 die "$f ?" if $f =~ m#/#;
2443 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2444 return 0 if !act_local();
2448 open F, "<", "$tf" or die "$tf: $!";
2449 $fi->{Digester}->reset();
2450 $fi->{Digester}->addfile(*F);
2451 F->error and die $!;
2452 my $got = $fi->{Digester}->hexdigest();
2453 $got eq $fi->{Hash} or
2454 fail "file $f has hash $got but .dsc".
2455 " demands hash $fi->{Hash} ".
2456 ($downloaded ? "(got wrong file from archive!)"
2457 : "(perhaps you should delete this file?)");
2462 sub ensure_we_have_orig () {
2463 my @dfi = dsc_files_info();
2464 foreach my $fi (@dfi) {
2465 my $f = $fi->{Filename};
2466 next unless is_orig_file_in_dsc($f, \@dfi);
2467 complete_file_from_dsc('..', $fi)
2472 sub git_fetch_us () {
2473 # Want to fetch only what we are going to use, unless
2474 # deliberately-not-ff, in which case we must fetch everything.
2476 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2478 (quiltmode_splitbrain
2479 ? (map { $_->('*',access_nomdistro) }
2480 \&debiantag_new, \&debiantag_maintview)
2481 : debiantags('*',access_nomdistro));
2482 push @specs, server_branch($csuite);
2483 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2485 # This is rather miserable:
2486 # When git fetch --prune is passed a fetchspec ending with a *,
2487 # it does a plausible thing. If there is no * then:
2488 # - it matches subpaths too, even if the supplied refspec
2489 # starts refs, and behaves completely madly if the source
2490 # has refs/refs/something. (See, for example, Debian #NNNN.)
2491 # - if there is no matching remote ref, it bombs out the whole
2493 # We want to fetch a fixed ref, and we don't know in advance
2494 # if it exists, so this is not suitable.
2496 # Our workaround is to use git ls-remote. git ls-remote has its
2497 # own qairks. Notably, it has the absurd multi-tail-matching
2498 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2499 # refs/refs/foo etc.
2501 # Also, we want an idempotent snapshot, but we have to make two
2502 # calls to the remote: one to git ls-remote and to git fetch. The
2503 # solution is use git ls-remote to obtain a target state, and
2504 # git fetch to try to generate it. If we don't manage to generate
2505 # the target state, we try again.
2507 printdebug "git_fetch_us specs @specs\n";
2509 my $specre = join '|', map {
2515 printdebug "git_fetch_us specre=$specre\n";
2516 my $wanted_rref = sub {
2518 return m/^(?:$specre)$/o;
2521 my $fetch_iteration = 0;
2524 printdebug "git_fetch_us iteration $fetch_iteration\n";
2525 if (++$fetch_iteration > 10) {
2526 fail "too many iterations trying to get sane fetch!";
2529 my @look = map { "refs/$_" } @specs;
2530 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2534 open GITLS, "-|", @lcmd or die $!;
2536 printdebug "=> ", $_;
2537 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2538 my ($objid,$rrefname) = ($1,$2);
2539 if (!$wanted_rref->($rrefname)) {
2541 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2545 $wantr{$rrefname} = $objid;
2548 close GITLS or failedcmd @lcmd;
2550 # OK, now %want is exactly what we want for refs in @specs
2552 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2553 "+refs/$_:".lrfetchrefs."/$_";
2556 printdebug "git_fetch_us fspecs @fspecs\n";
2558 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2559 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2562 %lrfetchrefs_f = ();
2565 git_for_each_ref(lrfetchrefs, sub {
2566 my ($objid,$objtype,$lrefname,$reftail) = @_;
2567 $lrfetchrefs_f{$lrefname} = $objid;
2568 $objgot{$objid} = 1;
2571 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2572 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2573 if (!exists $wantr{$rrefname}) {
2574 if ($wanted_rref->($rrefname)) {
2576 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2580 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2583 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2584 delete $lrfetchrefs_f{$lrefname};
2588 foreach my $rrefname (sort keys %wantr) {
2589 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2590 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2591 my $want = $wantr{$rrefname};
2592 next if $got eq $want;
2593 if (!defined $objgot{$want}) {
2595 warning: git ls-remote suggests we want $lrefname
2596 warning: and it should refer to $want
2597 warning: but git fetch didn't fetch that object to any relevant ref.
2598 warning: This may be due to a race with someone updating the server.
2599 warning: Will try again...
2601 next FETCH_ITERATION;
2604 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2606 runcmd_ordryrun_local @git, qw(update-ref -m),
2607 "dgit fetch git fetch fixup", $lrefname, $want;
2608 $lrfetchrefs_f{$lrefname} = $want;
2612 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2613 Dumper(\%lrfetchrefs_f);
2616 my @tagpats = debiantags('*',access_nomdistro);
2618 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2619 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2620 printdebug "currently $fullrefname=$objid\n";
2621 $here{$fullrefname} = $objid;
2623 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2624 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2625 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2626 printdebug "offered $lref=$objid\n";
2627 if (!defined $here{$lref}) {
2628 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2629 runcmd_ordryrun_local @upd;
2630 lrfetchref_used $fullrefname;
2631 } elsif ($here{$lref} eq $objid) {
2632 lrfetchref_used $fullrefname;
2635 "Not updateting $lref from $here{$lref} to $objid.\n";
2640 sub mergeinfo_getclogp ($) {
2641 # Ensures thit $mi->{Clogp} exists and returns it
2643 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2646 sub mergeinfo_version ($) {
2647 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2650 sub fetch_from_archive () {
2651 ensure_setup_existing_tree();
2653 # Ensures that lrref() is what is actually in the archive, one way
2654 # or another, according to us - ie this client's
2655 # appropritaely-updated archive view. Also returns the commit id.
2656 # If there is nothing in the archive, leaves lrref alone and
2657 # returns undef. git_fetch_us must have already been called.
2661 foreach my $field (@ourdscfield) {
2662 $dsc_hash = $dsc->{$field};
2663 last if defined $dsc_hash;
2665 if (defined $dsc_hash) {
2666 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2668 progress "last upload to archive specified git hash";
2670 progress "last upload to archive has NO git hash";
2673 progress "no version available from the archive";
2676 # If the archive's .dsc has a Dgit field, there are three
2677 # relevant git commitids we need to choose between and/or merge
2679 # 1. $dsc_hash: the Dgit field from the archive
2680 # 2. $lastpush_hash: the suite branch on the dgit git server
2681 # 3. $lastfetch_hash: our local tracking brach for the suite
2683 # These may all be distinct and need not be in any fast forward
2686 # If the dsc was pushed to this suite, then the server suite
2687 # branch will have been updated; but it might have been pushed to
2688 # a different suite and copied by the archive. Conversely a more
2689 # recent version may have been pushed with dgit but not appeared
2690 # in the archive (yet).
2692 # $lastfetch_hash may be awkward because archive imports
2693 # (particularly, imports of Dgit-less .dscs) are performed only as
2694 # needed on individual clients, so different clients may perform a
2695 # different subset of them - and these imports are only made
2696 # public during push. So $lastfetch_hash may represent a set of
2697 # imports different to a subsequent upload by a different dgit
2700 # Our approach is as follows:
2702 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2703 # descendant of $dsc_hash, then it was pushed by a dgit user who
2704 # had based their work on $dsc_hash, so we should prefer it.
2705 # Otherwise, $dsc_hash was installed into this suite in the
2706 # archive other than by a dgit push, and (necessarily) after the
2707 # last dgit push into that suite (since a dgit push would have
2708 # been descended from the dgit server git branch); thus, in that
2709 # case, we prefer the archive's version (and produce a
2710 # pseudo-merge to overwrite the dgit server git branch).
2712 # (If there is no Dgit field in the archive's .dsc then
2713 # generate_commit_from_dsc uses the version numbers to decide
2714 # whether the suite branch or the archive is newer. If the suite
2715 # branch is newer it ignores the archive's .dsc; otherwise it
2716 # generates an import of the .dsc, and produces a pseudo-merge to
2717 # overwrite the suite branch with the archive contents.)
2719 # The outcome of that part of the algorithm is the `public view',
2720 # and is same for all dgit clients: it does not depend on any
2721 # unpublished history in the local tracking branch.
2723 # As between the public view and the local tracking branch: The
2724 # local tracking branch is only updated by dgit fetch, and
2725 # whenever dgit fetch runs it includes the public view in the
2726 # local tracking branch. Therefore if the public view is not
2727 # descended from the local tracking branch, the local tracking
2728 # branch must contain history which was imported from the archive
2729 # but never pushed; and, its tip is now out of date. So, we make
2730 # a pseudo-merge to overwrite the old imports and stitch the old
2733 # Finally: we do not necessarily reify the public view (as
2734 # described above). This is so that we do not end up stacking two
2735 # pseudo-merges. So what we actually do is figure out the inputs
2736 # to any public view pseudo-merge and put them in @mergeinputs.
2739 # $mergeinputs[]{Commit}
2740 # $mergeinputs[]{Info}
2741 # $mergeinputs[0] is the one whose tree we use
2742 # @mergeinputs is in the order we use in the actual commit)
2745 # $mergeinputs[]{Message} is a commit message to use
2746 # $mergeinputs[]{ReverseParents} if def specifies that parent
2747 # list should be in opposite order
2748 # Such an entry has no Commit or Info. It applies only when found
2749 # in the last entry. (This ugliness is to support making
2750 # identical imports to previous dgit versions.)
2752 my $lastpush_hash = git_get_ref(lrfetchref());
2753 printdebug "previous reference hash=$lastpush_hash\n";
2754 $lastpush_mergeinput = $lastpush_hash && {
2755 Commit => $lastpush_hash,
2756 Info => "dgit suite branch on dgit git server",
2759 my $lastfetch_hash = git_get_ref(lrref());
2760 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2761 my $lastfetch_mergeinput = $lastfetch_hash && {
2762 Commit => $lastfetch_hash,
2763 Info => "dgit client's archive history view",
2766 my $dsc_mergeinput = $dsc_hash && {
2767 Commit => $dsc_hash,
2768 Info => "Dgit field in .dsc from archive",
2772 my $del_lrfetchrefs = sub {
2775 printdebug "del_lrfetchrefs...\n";
2776 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2777 my $objid = $lrfetchrefs_d{$fullrefname};
2778 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2780 $gur ||= new IO::Handle;
2781 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2783 printf $gur "delete %s %s\n", $fullrefname, $objid;
2786 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2790 if (defined $dsc_hash) {
2791 ensure_we_have_orig();
2792 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2793 @mergeinputs = $dsc_mergeinput
2794 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2795 print STDERR <<END or die $!;
2797 Git commit in archive is behind the last version allegedly pushed/uploaded.
2798 Commit referred to by archive: $dsc_hash
2799 Last version pushed with dgit: $lastpush_hash
2802 @mergeinputs = ($lastpush_mergeinput);
2804 # Archive has .dsc which is not a descendant of the last dgit
2805 # push. This can happen if the archive moves .dscs about.
2806 # Just follow its lead.
2807 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2808 progress "archive .dsc names newer git commit";
2809 @mergeinputs = ($dsc_mergeinput);
2811 progress "archive .dsc names other git commit, fixing up";
2812 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2816 @mergeinputs = generate_commits_from_dsc();
2817 # We have just done an import. Now, our import algorithm might
2818 # have been improved. But even so we do not want to generate
2819 # a new different import of the same package. So if the
2820 # version numbers are the same, just use our existing version.
2821 # If the version numbers are different, the archive has changed
2822 # (perhaps, rewound).
2823 if ($lastfetch_mergeinput &&
2824 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2825 (mergeinfo_version $mergeinputs[0]) )) {
2826 @mergeinputs = ($lastfetch_mergeinput);
2828 } elsif ($lastpush_hash) {
2829 # only in git, not in the archive yet
2830 @mergeinputs = ($lastpush_mergeinput);
2831 print STDERR <<END or die $!;
2833 Package not found in the archive, but has allegedly been pushed using dgit.
2837 printdebug "nothing found!\n";
2838 if (defined $skew_warning_vsn) {
2839 print STDERR <<END or die $!;
2841 Warning: relevant archive skew detected.
2842 Archive allegedly contains $skew_warning_vsn
2843 But we were not able to obtain any version from the archive or git.
2847 unshift @end, $del_lrfetchrefs;
2851 if ($lastfetch_hash &&
2853 my $h = $_->{Commit};
2854 $h and is_fast_fwd($lastfetch_hash, $h);
2855 # If true, one of the existing parents of this commit
2856 # is a descendant of the $lastfetch_hash, so we'll
2857 # be ff from that automatically.
2861 push @mergeinputs, $lastfetch_mergeinput;
2864 printdebug "fetch mergeinfos:\n";
2865 foreach my $mi (@mergeinputs) {
2867 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2869 printdebug sprintf " ReverseParents=%d Message=%s",
2870 $mi->{ReverseParents}, $mi->{Message};
2874 my $compat_info= pop @mergeinputs
2875 if $mergeinputs[$#mergeinputs]{Message};
2877 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2880 if (@mergeinputs > 1) {
2882 my $tree_commit = $mergeinputs[0]{Commit};
2884 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2885 $tree =~ m/\n\n/; $tree = $`;
2886 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2889 # We use the changelog author of the package in question the
2890 # author of this pseudo-merge. This is (roughly) correct if
2891 # this commit is simply representing aa non-dgit upload.
2892 # (Roughly because it does not record sponsorship - but we
2893 # don't have sponsorship info because that's in the .changes,
2894 # which isn't in the archivw.)
2896 # But, it might be that we are representing archive history
2897 # updates (including in-archive copies). These are not really
2898 # the responsibility of the person who created the .dsc, but
2899 # there is no-one whose name we should better use. (The
2900 # author of the .dsc-named commit is clearly worse.)
2902 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2903 my $author = clogp_authline $useclogp;
2904 my $cversion = getfield $useclogp, 'Version';
2906 my $mcf = ".git/dgit/mergecommit";
2907 open MC, ">", $mcf or die "$mcf $!";
2908 print MC <<END or die $!;
2912 my @parents = grep { $_->{Commit} } @mergeinputs;
2913 @parents = reverse @parents if $compat_info->{ReverseParents};
2914 print MC <<END or die $! foreach @parents;
2918 print MC <<END or die $!;
2924 if (defined $compat_info->{Message}) {
2925 print MC $compat_info->{Message} or die $!;
2927 print MC <<END or die $!;
2928 Record $package ($cversion) in archive suite $csuite
2932 my $message_add_info = sub {
2934 my $mversion = mergeinfo_version $mi;
2935 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2939 $message_add_info->($mergeinputs[0]);
2940 print MC <<END or die $!;
2941 should be treated as descended from
2943 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2947 $hash = make_commit $mcf;
2949 $hash = $mergeinputs[0]{Commit};
2951 printdebug "fetch hash=$hash\n";
2954 my ($lasth, $what) = @_;
2955 return unless $lasth;
2956 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2959 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2961 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2963 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2964 'DGIT_ARCHIVE', $hash;
2965 cmdoutput @git, qw(log -n2), $hash;
2966 # ... gives git a chance to complain if our commit is malformed
2968 if (defined $skew_warning_vsn) {
2970 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2971 my $gotclogp = commit_getclogp($hash);
2972 my $got_vsn = getfield $gotclogp, 'Version';
2973 printdebug "SKEW CHECK GOT $got_vsn\n";
2974 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2975 print STDERR <<END or die $!;
2977 Warning: archive skew detected. Using the available version:
2978 Archive allegedly contains $skew_warning_vsn
2979 We were able to obtain only $got_vsn
2985 if ($lastfetch_hash ne $hash) {
2986 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2990 dryrun_report @upd_cmd;
2994 lrfetchref_used lrfetchref();
2996 unshift @end, $del_lrfetchrefs;
3000 sub set_local_git_config ($$) {
3002 runcmd @git, qw(config), $k, $v;
3005 sub setup_mergechangelogs (;$) {
3007 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3009 my $driver = 'dpkg-mergechangelogs';
3010 my $cb = "merge.$driver";
3011 my $attrs = '.git/info/attributes';
3012 ensuredir '.git/info';
3014 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3015 if (!open ATTRS, "<", $attrs) {
3016 $!==ENOENT or die "$attrs: $!";
3020 next if m{^debian/changelog\s};
3021 print NATTRS $_, "\n" or die $!;
3023 ATTRS->error and die $!;
3026 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3029 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3030 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3032 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3035 sub setup_useremail (;$) {
3037 return unless $always || access_cfg_bool(1, 'setup-useremail');
3040 my ($k, $envvar) = @_;
3041 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3042 return unless defined $v;
3043 set_local_git_config "user.$k", $v;
3046 $setup->('email', 'DEBEMAIL');
3047 $setup->('name', 'DEBFULLNAME');
3050 sub ensure_setup_existing_tree () {
3051 my $k = "remote.$remotename.skipdefaultupdate";
3052 my $c = git_get_config $k;
3053 return if defined $c;
3054 set_local_git_config $k, 'true';
3057 sub setup_new_tree () {
3058 setup_mergechangelogs();
3064 canonicalise_suite();
3065 badusage "dry run makes no sense with clone" unless act_local();
3066 my $hasgit = check_for_git();
3067 mkdir $dstdir or fail "create \`$dstdir': $!";
3069 runcmd @git, qw(init -q);
3070 my $giturl = access_giturl(1);
3071 if (defined $giturl) {
3072 open H, "> .git/HEAD" or die $!;
3073 print H "ref: ".lref()."\n" or die $!;
3075 runcmd @git, qw(remote add), 'origin', $giturl;
3078 progress "fetching existing git history";
3080 runcmd_ordryrun_local @git, qw(fetch origin);
3082 progress "starting new git history";
3084 fetch_from_archive() or no_such_package;
3085 my $vcsgiturl = $dsc->{'Vcs-Git'};
3086 if (length $vcsgiturl) {
3087 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3088 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3091 runcmd @git, qw(reset --hard), lrref();
3092 runcmd qw(bash -ec), <<'END';
3094 git ls-tree -r --name-only -z HEAD | \
3095 xargs -0r touch -r . --
3097 printdone "ready for work in $dstdir";
3101 if (check_for_git()) {
3104 fetch_from_archive() or no_such_package();
3105 printdone "fetched into ".lrref();
3110 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3112 printdone "fetched to ".lrref()." and merged into HEAD";
3115 sub check_not_dirty () {
3116 foreach my $f (qw(local-options local-patch-header)) {
3117 if (stat_exists "debian/source/$f") {
3118 fail "git tree contains debian/source/$f";
3122 return if $ignoredirty;
3124 my @cmd = (@git, qw(diff --quiet HEAD));
3126 $!=0; $?=-1; system @cmd;
3129 fail "working tree is dirty (does not match HEAD)";
3135 sub commit_admin ($) {
3138 runcmd_ordryrun_local @git, qw(commit -m), $m;
3141 sub commit_quilty_patch () {
3142 my $output = cmdoutput @git, qw(status --porcelain);
3144 foreach my $l (split /\n/, $output) {
3145 next unless $l =~ m/\S/;
3146 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3150 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3152 progress "nothing quilty to commit, ok.";
3155 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3156 runcmd_ordryrun_local @git, qw(add -f), @adds;
3158 Commit Debian 3.0 (quilt) metadata
3160 [dgit ($our_version) quilt-fixup]
3164 sub get_source_format () {
3166 if (open F, "debian/source/options") {
3170 s/\s+$//; # ignore missing final newline
3172 my ($k, $v) = ($`, $'); #');
3173 $v =~ s/^"(.*)"$/$1/;
3179 F->error and die $!;
3182 die $! unless $!==&ENOENT;
3185 if (!open F, "debian/source/format") {
3186 die $! unless $!==&ENOENT;
3190 F->error and die $!;
3192 return ($_, \%options);
3195 sub madformat_wantfixup ($) {
3197 return 0 unless $format eq '3.0 (quilt)';
3198 our $quilt_mode_warned;
3199 if ($quilt_mode eq 'nocheck') {
3200 progress "Not doing any fixup of \`$format' due to".
3201 " ----no-quilt-fixup or --quilt=nocheck"
3202 unless $quilt_mode_warned++;
3205 progress "Format \`$format', need to check/update patch stack"
3206 unless $quilt_mode_warned++;
3210 sub maybe_split_brain_save ($$$) {
3211 my ($headref, $dgitview, $msg) = @_;
3212 # => message fragment "$saved" describing disposition of $dgitview
3213 return "commit id $dgitview" unless defined $split_brain_save;
3214 my @cmd = (shell_cmd "cd ../../../..",
3215 @git, qw(update-ref -m),
3216 "dgit --dgit-view-save $msg HEAD=$headref",
3217 $split_brain_save, $dgitview);
3219 return "and left in $split_brain_save";
3222 # An "infopair" is a tuple [ $thing, $what ]
3223 # (often $thing is a commit hash; $what is a description)
3225 sub infopair_cond_equal ($$) {
3227 $x->[0] eq $y->[0] or fail <<END;
3228 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3232 sub infopair_lrf_tag_lookup ($$) {
3233 my ($tagnames, $what) = @_;
3234 # $tagname may be an array ref
3235 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3236 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3237 foreach my $tagname (@tagnames) {
3238 my $lrefname = lrfetchrefs."/tags/$tagname";
3239 my $tagobj = $lrfetchrefs_f{$lrefname};
3240 next unless defined $tagobj;
3241 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3242 return [ git_rev_parse($tagobj), $what ];
3244 fail @tagnames==1 ? <<END : <<END;
3245 Wanted tag $what (@tagnames) on dgit server, but not found
3247 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3251 sub infopair_cond_ff ($$) {
3252 my ($anc,$desc) = @_;
3253 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3254 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3258 sub pseudomerge_version_check ($$) {
3259 my ($clogp, $archive_hash) = @_;
3261 my $arch_clogp = commit_getclogp $archive_hash;
3262 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3263 'version currently in archive' ];
3264 if (defined $overwrite_version) {
3265 if (length $overwrite_version) {
3266 infopair_cond_equal([ $overwrite_version,
3267 '--overwrite= version' ],
3270 my $v = $i_arch_v->[0];
3271 progress "Checking package changelog for archive version $v ...";
3273 my @xa = ("-f$v", "-t$v");
3274 my $vclogp = parsechangelog @xa;
3275 my $cv = [ (getfield $vclogp, 'Version'),
3276 "Version field from dpkg-parsechangelog @xa" ];
3277 infopair_cond_equal($i_arch_v, $cv);
3280 $@ =~ s/^dgit: //gm;
3282 "Perhaps debian/changelog does not mention $v ?";
3287 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3291 sub pseudomerge_make_commit ($$$$ $$) {
3292 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3293 $msg_cmd, $msg_msg) = @_;
3294 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3296 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3297 my $authline = clogp_authline $clogp;
3301 !defined $overwrite_version ? ""
3302 : !length $overwrite_version ? " --overwrite"
3303 : " --overwrite=".$overwrite_version;
3306 my $pmf = ".git/dgit/pseudomerge";
3307 open MC, ">", $pmf or die "$pmf $!";
3308 print MC <<END or die $!;
3311 parent $archive_hash
3321 return make_commit($pmf);
3324 sub splitbrain_pseudomerge ($$$$) {
3325 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3326 # => $merged_dgitview
3327 printdebug "splitbrain_pseudomerge...\n";
3329 # We: debian/PREVIOUS HEAD($maintview)
3330 # expect: o ----------------- o
3333 # a/d/PREVIOUS $dgitview
3336 # we do: `------------------ o
3340 return $dgitview unless defined $archive_hash;
3342 printdebug "splitbrain_pseudomerge...\n";
3344 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3346 if (!defined $overwrite_version) {
3347 progress "Checking that HEAD inciudes all changes in archive...";
3350 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3352 if (defined $overwrite_version) {
3354 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3355 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3356 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3357 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3358 my $i_archive = [ $archive_hash, "current archive contents" ];
3360 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3362 infopair_cond_equal($i_dgit, $i_archive);
3363 infopair_cond_ff($i_dep14, $i_dgit);
3364 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3368 $us: check failed (maybe --overwrite is needed, consult documentation)
3373 my $r = pseudomerge_make_commit
3374 $clogp, $dgitview, $archive_hash, $i_arch_v,
3375 "dgit --quilt=$quilt_mode",
3376 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3377 Declare fast forward from $i_arch_v->[0]
3379 Make fast forward from $i_arch_v->[0]
3382 maybe_split_brain_save $maintview, $r, "pseudomerge";
3384 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3388 sub plain_overwrite_pseudomerge ($$$) {
3389 my ($clogp, $head, $archive_hash) = @_;
3391 printdebug "plain_overwrite_pseudomerge...";
3393 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3395 return $head if is_fast_fwd $archive_hash, $head;
3397 my $m = "Declare fast forward from $i_arch_v->[0]";
3399 my $r = pseudomerge_make_commit
3400 $clogp, $head, $archive_hash, $i_arch_v,
3403 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3405 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3409 sub push_parse_changelog ($) {
3412 my $clogp = Dpkg::Control::Hash->new();
3413 $clogp->load($clogpfn) or die;
3415 my $clogpackage = getfield $clogp, 'Source';
3416 $package //= $clogpackage;
3417 fail "-p specified $package but changelog specified $clogpackage"
3418 unless $package eq $clogpackage;
3419 my $cversion = getfield $clogp, 'Version';
3420 my $tag = debiantag($cversion, access_nomdistro);
3421 runcmd @git, qw(check-ref-format), $tag;
3423 my $dscfn = dscfn($cversion);
3425 return ($clogp, $cversion, $dscfn);
3428 sub push_parse_dsc ($$$) {
3429 my ($dscfn,$dscfnwhat, $cversion) = @_;
3430 $dsc = parsecontrol($dscfn,$dscfnwhat);
3431 my $dversion = getfield $dsc, 'Version';
3432 my $dscpackage = getfield $dsc, 'Source';
3433 ($dscpackage eq $package && $dversion eq $cversion) or
3434 fail "$dscfn is for $dscpackage $dversion".
3435 " but debian/changelog is for $package $cversion";
3438 sub push_tagwants ($$$$) {
3439 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3442 TagFn => \&debiantag,
3447 if (defined $maintviewhead) {
3449 TagFn => \&debiantag_maintview,
3450 Objid => $maintviewhead,
3451 TfSuffix => '-maintview',
3455 foreach my $tw (@tagwants) {
3456 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3457 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3459 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3463 sub push_mktags ($$ $$ $) {
3465 $changesfile,$changesfilewhat,
3468 die unless $tagwants->[0]{View} eq 'dgit';
3470 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3471 $dsc->save("$dscfn.tmp") or die $!;
3473 my $changes = parsecontrol($changesfile,$changesfilewhat);
3474 foreach my $field (qw(Source Distribution Version)) {
3475 $changes->{$field} eq $clogp->{$field} or
3476 fail "changes field $field \`$changes->{$field}'".
3477 " does not match changelog \`$clogp->{$field}'";
3480 my $cversion = getfield $clogp, 'Version';
3481 my $clogsuite = getfield $clogp, 'Distribution';
3483 # We make the git tag by hand because (a) that makes it easier
3484 # to control the "tagger" (b) we can do remote signing
3485 my $authline = clogp_authline $clogp;
3486 my $delibs = join(" ", "",@deliberatelies);
3487 my $declaredistro = access_nomdistro();
3491 my $tfn = $tw->{Tfn};
3492 my $head = $tw->{Objid};
3493 my $tag = $tw->{Tag};
3495 open TO, '>', $tfn->('.tmp') or die $!;
3496 print TO <<END or die $!;
3503 if ($tw->{View} eq 'dgit') {
3504 print TO <<END or die $!;
3505 $package release $cversion for $clogsuite ($csuite) [dgit]
3506 [dgit distro=$declaredistro$delibs]
3508 foreach my $ref (sort keys %previously) {
3509 print TO <<END or die $!;
3510 [dgit previously:$ref=$previously{$ref}]
3513 } elsif ($tw->{View} eq 'maint') {
3514 print TO <<END or die $!;
3515 $package release $cversion for $clogsuite ($csuite)
3516 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3519 die Dumper($tw)."?";
3524 my $tagobjfn = $tfn->('.tmp');
3526 if (!defined $keyid) {
3527 $keyid = access_cfg('keyid','RETURN-UNDEF');
3529 if (!defined $keyid) {
3530 $keyid = getfield $clogp, 'Maintainer';
3532 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3533 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3534 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3535 push @sign_cmd, $tfn->('.tmp');
3536 runcmd_ordryrun @sign_cmd;
3538 $tagobjfn = $tfn->('.signed.tmp');
3539 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3540 $tfn->('.tmp'), $tfn->('.tmp.asc');
3546 my @r = map { $mktag->($_); } @$tagwants;
3550 sub sign_changes ($) {
3551 my ($changesfile) = @_;
3553 my @debsign_cmd = @debsign;
3554 push @debsign_cmd, "-k$keyid" if defined $keyid;
3555 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3556 push @debsign_cmd, $changesfile;
3557 runcmd_ordryrun @debsign_cmd;
3562 printdebug "actually entering push\n";
3564 supplementary_message(<<'END');
3565 Push failed, while checking state of the archive.
3566 You can retry the push, after fixing the problem, if you like.
3568 if (check_for_git()) {
3571 my $archive_hash = fetch_from_archive();
3572 if (!$archive_hash) {
3574 fail "package appears to be new in this suite;".
3575 " if this is intentional, use --new";
3578 supplementary_message(<<'END');
3579 Push failed, while preparing your push.
3580 You can retry the push, after fixing the problem, if you like.
3583 need_tagformat 'new', "quilt mode $quilt_mode"
3584 if quiltmode_splitbrain;
3588 access_giturl(); # check that success is vaguely likely
3591 my $clogpfn = ".git/dgit/changelog.822.tmp";
3592 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3594 responder_send_file('parsed-changelog', $clogpfn);
3596 my ($clogp, $cversion, $dscfn) =
3597 push_parse_changelog("$clogpfn");
3599 my $dscpath = "$buildproductsdir/$dscfn";
3600 stat_exists $dscpath or
3601 fail "looked for .dsc $dscfn, but $!;".
3602 " maybe you forgot to build";
3604 responder_send_file('dsc', $dscpath);
3606 push_parse_dsc($dscpath, $dscfn, $cversion);
3608 my $format = getfield $dsc, 'Format';
3609 printdebug "format $format\n";
3611 my $actualhead = git_rev_parse('HEAD');
3612 my $dgithead = $actualhead;
3613 my $maintviewhead = undef;
3615 my $upstreamversion = upstreamversion $clogp->{Version};
3617 if (madformat_wantfixup($format)) {
3618 # user might have not used dgit build, so maybe do this now:
3619 if (quiltmode_splitbrain()) {
3621 quilt_make_fake_dsc($upstreamversion);
3623 ($dgithead, $cachekey) =
3624 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3626 "--quilt=$quilt_mode but no cached dgit view:
3627 perhaps tree changed since dgit build[-source] ?";
3629 $dgithead = splitbrain_pseudomerge($clogp,
3630 $actualhead, $dgithead,
3632 $maintviewhead = $actualhead;
3633 changedir '../../../..';
3634 prep_ud(); # so _only_subdir() works, below
3636 commit_quilty_patch();
3640 if (defined $overwrite_version && !defined $maintviewhead) {
3641 $dgithead = plain_overwrite_pseudomerge($clogp,
3649 if ($archive_hash) {
3650 if (is_fast_fwd($archive_hash, $dgithead)) {
3652 } elsif (deliberately_not_fast_forward) {
3655 fail "dgit push: HEAD is not a descendant".
3656 " of the archive's version.\n".
3657 "To overwrite the archive's contents,".
3658 " pass --overwrite[=VERSION].\n".
3659 "To rewind history, if permitted by the archive,".
3660 " use --deliberately-not-fast-forward.";
3665 progress "checking that $dscfn corresponds to HEAD";
3666 runcmd qw(dpkg-source -x --),
3667 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3668 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3669 check_for_vendor_patches() if madformat($dsc->{format});
3670 changedir '../../../..';
3671 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3672 debugcmd "+",@diffcmd;
3674 my $r = system @diffcmd;
3677 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3679 HEAD specifies a different tree to $dscfn:
3681 Perhaps you forgot to build. Or perhaps there is a problem with your
3682 source tree (see dgit(7) for some hints). To see a full diff, run
3689 if (!$changesfile) {
3690 my $pat = changespat $cversion;
3691 my @cs = glob "$buildproductsdir/$pat";
3692 fail "failed to find unique changes file".
3693 " (looked for $pat in $buildproductsdir);".
3694 " perhaps you need to use dgit -C"
3696 ($changesfile) = @cs;
3698 $changesfile = "$buildproductsdir/$changesfile";
3701 # Check that changes and .dsc agree enough
3702 $changesfile =~ m{[^/]*$};
3703 my $changes = parsecontrol($changesfile,$&);
3704 files_compare_inputs($dsc, $changes)
3705 unless forceing [qw(dsc-changes-mismatch)];
3707 # Perhaps adjust .dsc to contain right set of origs
3708 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3710 unless forceing [qw(changes-origs-exactly)];
3712 # Checks complete, we're going to try and go ahead:
3714 responder_send_file('changes',$changesfile);
3715 responder_send_command("param head $dgithead");
3716 responder_send_command("param csuite $csuite");
3717 responder_send_command("param tagformat $tagformat");
3718 if (defined $maintviewhead) {
3719 die unless ($protovsn//4) >= 4;
3720 responder_send_command("param maint-view $maintviewhead");
3723 if (deliberately_not_fast_forward) {
3724 git_for_each_ref(lrfetchrefs, sub {
3725 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3726 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3727 responder_send_command("previously $rrefname=$objid");
3728 $previously{$rrefname} = $objid;
3732 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3736 supplementary_message(<<'END');
3737 Push failed, while signing the tag.
3738 You can retry the push, after fixing the problem, if you like.
3740 # If we manage to sign but fail to record it anywhere, it's fine.
3741 if ($we_are_responder) {
3742 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3743 responder_receive_files('signed-tag', @tagobjfns);
3745 @tagobjfns = push_mktags($clogp,$dscpath,
3746 $changesfile,$changesfile,
3749 supplementary_message(<<'END');
3750 Push failed, *after* signing the tag.
3751 If you want to try again, you should use a new version number.
3754 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3756 foreach my $tw (@tagwants) {
3757 my $tag = $tw->{Tag};
3758 my $tagobjfn = $tw->{TagObjFn};
3760 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3761 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3762 runcmd_ordryrun_local
3763 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3766 supplementary_message(<<'END');
3767 Push failed, while updating the remote git repository - see messages above.
3768 If you want to try again, you should use a new version number.
3770 if (!check_for_git()) {
3771 create_remote_git_repo();
3774 my @pushrefs = $forceflag.$dgithead.":".rrref();
3775 foreach my $tw (@tagwants) {
3776 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3779 runcmd_ordryrun @git,
3780 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3781 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3783 supplementary_message(<<'END');
3784 Push failed, after updating the remote git repository.
3785 If you want to try again, you must use a new version number.
3787 if ($we_are_responder) {
3788 my $dryrunsuffix = act_local() ? "" : ".tmp";
3789 responder_receive_files('signed-dsc-changes',
3790 "$dscpath$dryrunsuffix",
3791 "$changesfile$dryrunsuffix");
3794 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3796 progress "[new .dsc left in $dscpath.tmp]";
3798 sign_changes $changesfile;
3801 supplementary_message(<<END);
3802 Push failed, while uploading package(s) to the archive server.
3803 You can retry the upload of exactly these same files with dput of:
3805 If that .changes file is broken, you will need to use a new version
3806 number for your next attempt at the upload.
3808 my $host = access_cfg('upload-host','RETURN-UNDEF');
3809 my @hostarg = defined($host) ? ($host,) : ();
3810 runcmd_ordryrun @dput, @hostarg, $changesfile;
3811 printdone "pushed and uploaded $cversion";
3813 supplementary_message('');
3814 responder_send_command("complete");
3821 badusage "-p is not allowed with clone; specify as argument instead"
3822 if defined $package;
3825 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3826 ($package,$isuite) = @ARGV;
3827 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3828 ($package,$dstdir) = @ARGV;
3829 } elsif (@ARGV==3) {
3830 ($package,$isuite,$dstdir) = @ARGV;
3832 badusage "incorrect arguments to dgit clone";
3834 $dstdir ||= "$package";
3836 if (stat_exists $dstdir) {
3837 fail "$dstdir already exists";
3841 if ($rmonerror && !$dryrun_level) {
3842 $cwd_remove= getcwd();
3844 return unless defined $cwd_remove;
3845 if (!chdir "$cwd_remove") {
3846 return if $!==&ENOENT;
3847 die "chdir $cwd_remove: $!";
3850 rmtree($dstdir) or die "remove $dstdir: $!\n";
3851 } elsif (grep { $! == $_ }
3852 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3854 print STDERR "check whether to remove $dstdir: $!\n";
3860 $cwd_remove = undef;
3863 sub branchsuite () {
3864 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3865 if ($branch =~ m#$lbranch_re#o) {
3872 sub fetchpullargs () {
3874 if (!defined $package) {
3875 my $sourcep = parsecontrol('debian/control','debian/control');
3876 $package = getfield $sourcep, 'Source';
3879 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3881 my $clogp = parsechangelog();
3882 $isuite = getfield $clogp, 'Distribution';
3884 canonicalise_suite();
3885 progress "fetching from suite $csuite";
3886 } elsif (@ARGV==1) {
3888 canonicalise_suite();
3890 badusage "incorrect arguments to dgit fetch or dgit pull";
3903 if (quiltmode_splitbrain()) {
3904 my ($format, $fopts) = get_source_format();
3905 madformat($format) and fail <<END
3906 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
3915 badusage "-p is not allowed with dgit push" if defined $package;
3917 my $clogp = parsechangelog();
3918 $package = getfield $clogp, 'Source';
3921 } elsif (@ARGV==1) {
3922 ($specsuite) = (@ARGV);
3924 badusage "incorrect arguments to dgit push";
3926 $isuite = getfield $clogp, 'Distribution';
3928 local ($package) = $existing_package; # this is a hack
3929 canonicalise_suite();
3931 canonicalise_suite();
3933 if (defined $specsuite &&
3934 $specsuite ne $isuite &&
3935 $specsuite ne $csuite) {
3936 fail "dgit push: changelog specifies $isuite ($csuite)".
3937 " but command line specifies $specsuite";
3942 #---------- remote commands' implementation ----------
3944 sub cmd_remote_push_build_host {
3945 my ($nrargs) = shift @ARGV;
3946 my (@rargs) = @ARGV[0..$nrargs-1];
3947 @ARGV = @ARGV[$nrargs..$#ARGV];
3949 my ($dir,$vsnwant) = @rargs;
3950 # vsnwant is a comma-separated list; we report which we have
3951 # chosen in our ready response (so other end can tell if they
3954 $we_are_responder = 1;
3955 $us .= " (build host)";
3959 open PI, "<&STDIN" or die $!;
3960 open STDIN, "/dev/null" or die $!;
3961 open PO, ">&STDOUT" or die $!;
3963 open STDOUT, ">&STDERR" or die $!;
3967 ($protovsn) = grep {
3968 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3969 } @rpushprotovsn_support;
3971 fail "build host has dgit rpush protocol versions ".
3972 (join ",", @rpushprotovsn_support).
3973 " but invocation host has $vsnwant"
3974 unless defined $protovsn;
3976 responder_send_command("dgit-remote-push-ready $protovsn");
3977 rpush_handle_protovsn_bothends();
3982 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3983 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3984 # a good error message)
3986 sub rpush_handle_protovsn_bothends () {
3987 if ($protovsn < 4) {
3988 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3997 my $report = i_child_report();
3998 if (defined $report) {
3999 printdebug "($report)\n";
4000 } elsif ($i_child_pid) {
4001 printdebug "(killing build host child $i_child_pid)\n";
4002 kill 15, $i_child_pid;
4004 if (defined $i_tmp && !defined $initiator_tempdir) {
4006 eval { rmtree $i_tmp; };
4010 END { i_cleanup(); }
4013 my ($base,$selector,@args) = @_;
4014 $selector =~ s/\-/_/g;
4015 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4022 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4030 push @rargs, join ",", @rpushprotovsn_support;
4033 push @rdgit, @ropts;
4034 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4036 my @cmd = (@ssh, $host, shellquote @rdgit);
4039 if (defined $initiator_tempdir) {
4040 rmtree $initiator_tempdir;
4041 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4042 $i_tmp = $initiator_tempdir;
4046 $i_child_pid = open2(\*RO, \*RI, @cmd);
4048 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4049 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4050 $supplementary_message = '' unless $protovsn >= 3;
4052 fail "rpush negotiated protocol version $protovsn".
4053 " which does not support quilt mode $quilt_mode"
4054 if quiltmode_splitbrain;
4056 rpush_handle_protovsn_bothends();
4058 my ($icmd,$iargs) = initiator_expect {
4059 m/^(\S+)(?: (.*))?$/;
4062 i_method "i_resp", $icmd, $iargs;
4066 sub i_resp_progress ($) {
4068 my $msg = protocol_read_bytes \*RO, $rhs;
4072 sub i_resp_supplementary_message ($) {
4074 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4077 sub i_resp_complete {
4078 my $pid = $i_child_pid;
4079 $i_child_pid = undef; # prevents killing some other process with same pid
4080 printdebug "waiting for build host child $pid...\n";
4081 my $got = waitpid $pid, 0;
4082 die $! unless $got == $pid;
4083 die "build host child failed $?" if $?;
4086 printdebug "all done\n";
4090 sub i_resp_file ($) {
4092 my $localname = i_method "i_localname", $keyword;
4093 my $localpath = "$i_tmp/$localname";
4094 stat_exists $localpath and
4095 badproto \*RO, "file $keyword ($localpath) twice";
4096 protocol_receive_file \*RO, $localpath;
4097 i_method "i_file", $keyword;
4102 sub i_resp_param ($) {
4103 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4107 sub i_resp_previously ($) {
4108 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4109 or badproto \*RO, "bad previously spec";
4110 my $r = system qw(git check-ref-format), $1;
4111 die "bad previously ref spec ($r)" if $r;
4112 $previously{$1} = $2;
4117 sub i_resp_want ($) {
4119 die "$keyword ?" if $i_wanted{$keyword}++;
4120 my @localpaths = i_method "i_want", $keyword;
4121 printdebug "[[ $keyword @localpaths\n";
4122 foreach my $localpath (@localpaths) {
4123 protocol_send_file \*RI, $localpath;
4125 print RI "files-end\n" or die $!;
4128 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4130 sub i_localname_parsed_changelog {
4131 return "remote-changelog.822";
4133 sub i_file_parsed_changelog {
4134 ($i_clogp, $i_version, $i_dscfn) =
4135 push_parse_changelog "$i_tmp/remote-changelog.822";
4136 die if $i_dscfn =~ m#/|^\W#;
4139 sub i_localname_dsc {
4140 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4145 sub i_localname_changes {
4146 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4147 $i_changesfn = $i_dscfn;
4148 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4149 return $i_changesfn;
4151 sub i_file_changes { }
4153 sub i_want_signed_tag {
4154 printdebug Dumper(\%i_param, $i_dscfn);
4155 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4156 && defined $i_param{'csuite'}
4157 or badproto \*RO, "premature desire for signed-tag";
4158 my $head = $i_param{'head'};
4159 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4161 my $maintview = $i_param{'maint-view'};
4162 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4165 if ($protovsn >= 4) {
4166 my $p = $i_param{'tagformat'} // '<undef>';
4168 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4171 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4173 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4175 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4178 push_mktags $i_clogp, $i_dscfn,
4179 $i_changesfn, 'remote changes',
4183 sub i_want_signed_dsc_changes {
4184 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4185 sign_changes $i_changesfn;
4186 return ($i_dscfn, $i_changesfn);
4189 #---------- building etc. ----------
4195 #----- `3.0 (quilt)' handling -----
4197 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4199 sub quiltify_dpkg_commit ($$$;$) {
4200 my ($patchname,$author,$msg, $xinfo) = @_;
4204 my $descfn = ".git/dgit/quilt-description.tmp";
4205 open O, '>', $descfn or die "$descfn: $!";
4206 $msg =~ s/\n+/\n\n/;
4207 print O <<END or die $!;
4209 ${xinfo}Subject: $msg
4216 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4217 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4218 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4219 runcmd @dpkgsource, qw(--commit .), $patchname;
4223 sub quiltify_trees_differ ($$;$$$) {
4224 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4225 # returns true iff the two tree objects differ other than in debian/
4226 # with $finegrained,
4227 # returns bitmask 01 - differ in upstream files except .gitignore
4228 # 02 - differ in .gitignore
4229 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4230 # is set for each modified .gitignore filename $fn
4231 # if $unrepres is defined, array ref to which is appeneded
4232 # a list of unrepresentable changes (removals of upstream files
4235 my @cmd = (@git, qw(diff-tree -z));
4236 push @cmd, qw(--name-only) unless $unrepres;
4237 push @cmd, qw(-r) if $finegrained || $unrepres;
4239 my $diffs= cmdoutput @cmd;
4242 foreach my $f (split /\0/, $diffs) {
4243 if ($unrepres && !@lmodes) {
4244 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4247 my ($oldmode,$newmode) = @lmodes;
4250 next if $f =~ m#^debian(?:/.*)?$#s;
4254 die "deleted\n" unless $newmode =~ m/[^0]/;
4255 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4256 if ($oldmode =~ m/[^0]/) {
4257 die "mode changed\n" if $oldmode ne $newmode;
4259 die "non-default mode\n" unless $newmode =~ m/^100644$/;
4263 local $/="\n"; chomp $@;
4264 push @$unrepres, [ $f, $@ ];
4268 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4269 $r |= $isignore ? 02 : 01;
4270 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4272 printdebug "quiltify_trees_differ $x $y => $r\n";
4276 sub quiltify_tree_sentinelfiles ($) {
4277 # lists the `sentinel' files present in the tree
4279 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4280 qw(-- debian/rules debian/control);
4285 sub quiltify_splitbrain_needed () {
4286 if (!$split_brain) {
4287 progress "dgit view: changes are required...";
4288 runcmd @git, qw(checkout -q -b dgit-view);
4293 sub quiltify_splitbrain ($$$$$$) {
4294 my ($clogp, $unapplied, $headref, $diffbits,
4295 $editedignores, $cachekey) = @_;
4296 if ($quilt_mode !~ m/gbp|dpm/) {
4297 # treat .gitignore just like any other upstream file
4298 $diffbits = { %$diffbits };
4299 $_ = !!$_ foreach values %$diffbits;
4301 # We would like any commits we generate to be reproducible
4302 my @authline = clogp_authline($clogp);
4303 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4304 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4305 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4306 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4307 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4308 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4310 if ($quilt_mode =~ m/gbp|unapplied/ &&
4311 ($diffbits->{O2H} & 01)) {
4313 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4314 " but git tree differs from orig in upstream files.";
4315 if (!stat_exists "debian/patches") {
4317 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4321 if ($quilt_mode =~ m/dpm/ &&
4322 ($diffbits->{H2A} & 01)) {
4324 --quilt=$quilt_mode specified, implying patches-applied git tree
4325 but git tree differs from result of applying debian/patches to upstream
4328 if ($quilt_mode =~ m/gbp|unapplied/ &&
4329 ($diffbits->{O2A} & 01)) { # some patches
4330 quiltify_splitbrain_needed();
4331 progress "dgit view: creating patches-applied version using gbp pq";
4332 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4333 # gbp pq import creates a fresh branch; push back to dgit-view
4334 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4335 runcmd @git, qw(checkout -q dgit-view);
4337 if ($quilt_mode =~ m/gbp|dpm/ &&
4338 ($diffbits->{O2A} & 02)) {
4340 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4341 tool which does not create patches for changes to upstream
4342 .gitignores: but, such patches exist in debian/patches.
4345 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4346 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4347 quiltify_splitbrain_needed();
4348 progress "dgit view: creating patch to represent .gitignore changes";
4349 ensuredir "debian/patches";
4350 my $gipatch = "debian/patches/auto-gitignore";
4351 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4352 stat GIPATCH or die "$gipatch: $!";
4353 fail "$gipatch already exists; but want to create it".
4354 " to record .gitignore changes" if (stat _)[7];
4355 print GIPATCH <<END or die "$gipatch: $!";
4356 Subject: Update .gitignore from Debian packaging branch
4358 The Debian packaging git branch contains these updates to the upstream
4359 .gitignore file(s). This patch is autogenerated, to provide these
4360 updates to users of the official Debian archive view of the package.
4362 [dgit ($our_version) update-gitignore]
4365 close GIPATCH or die "$gipatch: $!";
4366 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4367 $unapplied, $headref, "--", sort keys %$editedignores;
4368 open SERIES, "+>>", "debian/patches/series" or die $!;
4369 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4371 defined read SERIES, $newline, 1 or die $!;
4372 print SERIES "\n" or die $! unless $newline eq "\n";
4373 print SERIES "auto-gitignore\n" or die $!;
4374 close SERIES or die $!;
4375 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4377 Commit patch to update .gitignore
4379 [dgit ($our_version) update-gitignore-quilt-fixup]
4383 my $dgitview = git_rev_parse 'HEAD';
4385 changedir '../../../..';
4386 # When we no longer need to support squeeze, use --create-reflog
4388 ensuredir ".git/logs/refs/dgit-intern";
4389 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4392 my $oldcache = git_get_ref "refs/$splitbraincache";
4393 if ($oldcache eq $dgitview) {
4394 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4395 # git update-ref doesn't always update, in this case. *sigh*
4396 my $dummy = make_commit_text <<END;
4399 author Dgit <dgit\@example.com> 1000000000 +0000
4400 committer Dgit <dgit\@example.com> 1000000000 +0000
4402 Dummy commit - do not use
4404 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4405 "refs/$splitbraincache", $dummy;
4407 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4410 changedir '.git/dgit/unpack/work';
4412 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4413 progress "dgit view: created ($saved)";
4416 sub quiltify ($$$$) {
4417 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4419 # Quilt patchification algorithm
4421 # We search backwards through the history of the main tree's HEAD
4422 # (T) looking for a start commit S whose tree object is identical
4423 # to to the patch tip tree (ie the tree corresponding to the
4424 # current dpkg-committed patch series). For these purposes
4425 # `identical' disregards anything in debian/ - this wrinkle is
4426 # necessary because dpkg-source treates debian/ specially.
4428 # We can only traverse edges where at most one of the ancestors'
4429 # trees differs (in changes outside in debian/). And we cannot
4430 # handle edges which change .pc/ or debian/patches. To avoid
4431 # going down a rathole we avoid traversing edges which introduce
4432 # debian/rules or debian/control. And we set a limit on the
4433 # number of edges we are willing to look at.
4435 # If we succeed, we walk forwards again. For each traversed edge
4436 # PC (with P parent, C child) (starting with P=S and ending with
4437 # C=T) to we do this:
4439 # - dpkg-source --commit with a patch name and message derived from C
4440 # After traversing PT, we git commit the changes which
4441 # should be contained within debian/patches.
4443 # The search for the path S..T is breadth-first. We maintain a
4444 # todo list containing search nodes. A search node identifies a
4445 # commit, and looks something like this:
4447 # Commit => $git_commit_id,
4448 # Child => $c, # or undef if P=T
4449 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4450 # Nontrivial => true iff $p..$c has relevant changes
4457 my %considered; # saves being exponential on some weird graphs
4459 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4462 my ($search,$whynot) = @_;
4463 printdebug " search NOT $search->{Commit} $whynot\n";
4464 $search->{Whynot} = $whynot;
4465 push @nots, $search;
4466 no warnings qw(exiting);
4475 my $c = shift @todo;
4476 next if $considered{$c->{Commit}}++;
4478 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4480 printdebug "quiltify investigate $c->{Commit}\n";
4483 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4484 printdebug " search finished hooray!\n";
4489 if ($quilt_mode eq 'nofix') {
4490 fail "quilt fixup required but quilt mode is \`nofix'\n".
4491 "HEAD commit $c->{Commit} differs from tree implied by ".
4492 " debian/patches (tree object $oldtiptree)";
4494 if ($quilt_mode eq 'smash') {
4495 printdebug " search quitting smash\n";
4499 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4500 $not->($c, "has $c_sentinels not $t_sentinels")
4501 if $c_sentinels ne $t_sentinels;
4503 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4504 $commitdata =~ m/\n\n/;
4506 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4507 @parents = map { { Commit => $_, Child => $c } } @parents;
4509 $not->($c, "root commit") if !@parents;
4511 foreach my $p (@parents) {
4512 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4514 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4515 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4517 foreach my $p (@parents) {
4518 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4520 my @cmd= (@git, qw(diff-tree -r --name-only),
4521 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4522 my $patchstackchange = cmdoutput @cmd;
4523 if (length $patchstackchange) {
4524 $patchstackchange =~ s/\n/,/g;
4525 $not->($p, "changed $patchstackchange");
4528 printdebug " search queue P=$p->{Commit} ",
4529 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4535 printdebug "quiltify want to smash\n";
4538 my $x = $_[0]{Commit};
4539 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4542 my $reportnot = sub {
4544 my $s = $abbrev->($notp);
4545 my $c = $notp->{Child};
4546 $s .= "..".$abbrev->($c) if $c;
4547 $s .= ": ".$notp->{Whynot};
4550 if ($quilt_mode eq 'linear') {
4551 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4552 foreach my $notp (@nots) {
4553 print STDERR "$us: ", $reportnot->($notp), "\n";
4555 print STDERR "$us: $_\n" foreach @$failsuggestion;
4556 fail "quilt fixup naive history linearisation failed.\n".
4557 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4558 } elsif ($quilt_mode eq 'smash') {
4559 } elsif ($quilt_mode eq 'auto') {
4560 progress "quilt fixup cannot be linear, smashing...";
4562 die "$quilt_mode ?";
4565 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4566 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4568 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4570 quiltify_dpkg_commit "auto-$version-$target-$time",
4571 (getfield $clogp, 'Maintainer'),
4572 "Automatically generated patch ($clogp->{Version})\n".
4573 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4577 progress "quiltify linearisation planning successful, executing...";
4579 for (my $p = $sref_S;
4580 my $c = $p->{Child};
4582 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4583 next unless $p->{Nontrivial};
4585 my $cc = $c->{Commit};
4587 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4588 $commitdata =~ m/\n\n/ or die "$c ?";
4591 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4594 my $commitdate = cmdoutput
4595 @git, qw(log -n1 --pretty=format:%aD), $cc;
4597 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4599 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4606 my $gbp_check_suitable = sub {
4611 die "contains unexpected slashes\n" if m{//} || m{/$};
4612 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4613 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4614 die "too long" if length > 200;
4616 return $_ unless $@;
4617 print STDERR "quiltifying commit $cc:".
4618 " ignoring/dropping Gbp-Pq $what: $@";
4622 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4624 (\S+) \s* \n //ixm) {
4625 $patchname = $gbp_check_suitable->($1, 'Name');
4627 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4629 (\S+) \s* \n //ixm) {
4630 $patchdir = $gbp_check_suitable->($1, 'Topic');
4635 if (!defined $patchname) {
4636 $patchname = $title;
4637 $patchname =~ s/[.:]$//;
4640 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4641 my $translitname = $converter->convert($patchname);
4642 die unless defined $translitname;
4643 $patchname = $translitname;
4646 "dgit: patch title transliteration error: $@"
4648 $patchname =~ y/ A-Z/-a-z/;
4649 $patchname =~ y/-a-z0-9_.+=~//cd;
4650 $patchname =~ s/^\W/x-$&/;
4651 $patchname = substr($patchname,0,40);
4653 if (!defined $patchdir) {
4656 if (length $patchdir) {
4657 $patchname = "$patchdir/$patchname";
4659 if ($patchname =~ m{^(.*)/}) {
4660 mkpath "debian/patches/$1";
4665 stat "debian/patches/$patchname$index";
4667 $!==ENOENT or die "$patchname$index $!";
4669 runcmd @git, qw(checkout -q), $cc;
4671 # We use the tip's changelog so that dpkg-source doesn't
4672 # produce complaining messages from dpkg-parsechangelog. None
4673 # of the information dpkg-source gets from the changelog is
4674 # actually relevant - it gets put into the original message
4675 # which dpkg-source provides our stunt editor, and then
4677 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4679 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4680 "Date: $commitdate\n".
4681 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4683 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4686 runcmd @git, qw(checkout -q master);
4689 sub build_maybe_quilt_fixup () {
4690 my ($format,$fopts) = get_source_format;
4691 return unless madformat_wantfixup $format;
4694 check_for_vendor_patches();
4696 if (quiltmode_splitbrain) {
4697 foreach my $needtf (qw(new maint)) {
4698 next if grep { $_ eq $needtf } access_cfg_tagformats;
4700 quilt mode $quilt_mode requires split view so server needs to support
4701 both "new" and "maint" tag formats, but config says it doesn't.
4706 my $clogp = parsechangelog();
4707 my $headref = git_rev_parse('HEAD');
4712 my $upstreamversion = upstreamversion $version;
4714 if ($fopts->{'single-debian-patch'}) {
4715 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4717 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4720 die 'bug' if $split_brain && !$need_split_build_invocation;
4722 changedir '../../../..';
4723 runcmd_ordryrun_local
4724 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4727 sub quilt_fixup_mkwork ($) {
4730 mkdir "work" or die $!;
4732 mktree_in_ud_here();
4733 runcmd @git, qw(reset -q --hard), $headref;
4736 sub quilt_fixup_linkorigs ($$) {
4737 my ($upstreamversion, $fn) = @_;
4738 # calls $fn->($leafname);
4740 foreach my $f (<../../../../*>) { #/){
4741 my $b=$f; $b =~ s{.*/}{};
4743 local ($debuglevel) = $debuglevel-1;
4744 printdebug "QF linkorigs $b, $f ?\n";
4746 next unless is_orig_file_of_vsn $b, $upstreamversion;
4747 printdebug "QF linkorigs $b, $f Y\n";
4748 link_ltarget $f, $b or die "$b $!";
4753 sub quilt_fixup_delete_pc () {
4754 runcmd @git, qw(rm -rqf .pc);
4756 Commit removal of .pc (quilt series tracking data)
4758 [dgit ($our_version) upgrade quilt-remove-pc]
4762 sub quilt_fixup_singlepatch ($$$) {
4763 my ($clogp, $headref, $upstreamversion) = @_;
4765 progress "starting quiltify (single-debian-patch)";
4767 # dpkg-source --commit generates new patches even if
4768 # single-debian-patch is in debian/source/options. In order to
4769 # get it to generate debian/patches/debian-changes, it is
4770 # necessary to build the source package.
4772 quilt_fixup_linkorigs($upstreamversion, sub { });
4773 quilt_fixup_mkwork($headref);
4775 rmtree("debian/patches");
4777 runcmd @dpkgsource, qw(-b .);
4779 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4780 rename srcfn("$upstreamversion", "/debian/patches"),
4781 "work/debian/patches";
4784 commit_quilty_patch();
4787 sub quilt_make_fake_dsc ($) {
4788 my ($upstreamversion) = @_;
4790 my $fakeversion="$upstreamversion-~~DGITFAKE";
4792 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4793 print $fakedsc <<END or die $!;
4796 Version: $fakeversion
4800 my $dscaddfile=sub {
4803 my $md = new Digest::MD5;
4805 my $fh = new IO::File $b, '<' or die "$b $!";
4810 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4813 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4815 my @files=qw(debian/source/format debian/rules
4816 debian/control debian/changelog);
4817 foreach my $maybe (qw(debian/patches debian/source/options
4818 debian/tests/control)) {
4819 next unless stat_exists "../../../$maybe";
4820 push @files, $maybe;
4823 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4824 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4826 $dscaddfile->($debtar);
4827 close $fakedsc or die $!;
4830 sub quilt_check_splitbrain_cache ($$) {
4831 my ($headref, $upstreamversion) = @_;
4832 # Called only if we are in (potentially) split brain mode.
4834 # Computes the cache key and looks in the cache.
4835 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4837 my $splitbrain_cachekey;
4840 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4841 # we look in the reflog of dgit-intern/quilt-cache
4842 # we look for an entry whose message is the key for the cache lookup
4843 my @cachekey = (qw(dgit), $our_version);
4844 push @cachekey, $upstreamversion;
4845 push @cachekey, $quilt_mode;
4846 push @cachekey, $headref;
4848 push @cachekey, hashfile('fake.dsc');
4850 my $srcshash = Digest::SHA->new(256);
4851 my %sfs = ( %INC, '$0(dgit)' => $0 );
4852 foreach my $sfk (sort keys %sfs) {
4853 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4854 $srcshash->add($sfk," ");
4855 $srcshash->add(hashfile($sfs{$sfk}));
4856 $srcshash->add("\n");
4858 push @cachekey, $srcshash->hexdigest();
4859 $splitbrain_cachekey = "@cachekey";
4861 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4863 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4864 debugcmd "|(probably)",@cmd;
4865 my $child = open GC, "-|"; defined $child or die $!;
4867 chdir '../../..' or die $!;
4868 if (!stat ".git/logs/refs/$splitbraincache") {
4869 $! == ENOENT or die $!;
4870 printdebug ">(no reflog)\n";
4877 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4878 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4881 quilt_fixup_mkwork($headref);
4882 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
4883 if ($cachehit ne $headref) {
4884 progress "dgit view: found cached ($saved)";
4885 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4887 return ($cachehit, $splitbrain_cachekey);
4889 progress "dgit view: found cached, no changes required";
4890 return ($headref, $splitbrain_cachekey);
4892 die $! if GC->error;
4893 failedcmd unless close GC;
4895 printdebug "splitbrain cache miss\n";
4896 return (undef, $splitbrain_cachekey);
4899 sub quilt_fixup_multipatch ($$$) {
4900 my ($clogp, $headref, $upstreamversion) = @_;
4902 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4905 # - honour any existing .pc in case it has any strangeness
4906 # - determine the git commit corresponding to the tip of
4907 # the patch stack (if there is one)
4908 # - if there is such a git commit, convert each subsequent
4909 # git commit into a quilt patch with dpkg-source --commit
4910 # - otherwise convert all the differences in the tree into
4911 # a single git commit
4915 # Our git tree doesn't necessarily contain .pc. (Some versions of
4916 # dgit would include the .pc in the git tree.) If there isn't
4917 # one, we need to generate one by unpacking the patches that we
4920 # We first look for a .pc in the git tree. If there is one, we
4921 # will use it. (This is not the normal case.)
4923 # Otherwise need to regenerate .pc so that dpkg-source --commit
4924 # can work. We do this as follows:
4925 # 1. Collect all relevant .orig from parent directory
4926 # 2. Generate a debian.tar.gz out of
4927 # debian/{patches,rules,source/format,source/options}
4928 # 3. Generate a fake .dsc containing just these fields:
4929 # Format Source Version Files
4930 # 4. Extract the fake .dsc
4931 # Now the fake .dsc has a .pc directory.
4932 # (In fact we do this in every case, because in future we will
4933 # want to search for a good base commit for generating patches.)
4935 # Then we can actually do the dpkg-source --commit
4936 # 1. Make a new working tree with the same object
4937 # store as our main tree and check out the main
4939 # 2. Copy .pc from the fake's extraction, if necessary
4940 # 3. Run dpkg-source --commit
4941 # 4. If the result has changes to debian/, then
4942 # - git add them them
4943 # - git add .pc if we had a .pc in-tree
4945 # 5. If we had a .pc in-tree, delete it, and git commit
4946 # 6. Back in the main tree, fast forward to the new HEAD
4948 # Another situation we may have to cope with is gbp-style
4949 # patches-unapplied trees.
4951 # We would want to detect these, so we know to escape into
4952 # quilt_fixup_gbp. However, this is in general not possible.
4953 # Consider a package with a one patch which the dgit user reverts
4954 # (with git revert or the moral equivalent).
4956 # That is indistinguishable in contents from a patches-unapplied
4957 # tree. And looking at the history to distinguish them is not
4958 # useful because the user might have made a confusing-looking git
4959 # history structure (which ought to produce an error if dgit can't
4960 # cope, not a silent reintroduction of an unwanted patch).
4962 # So gbp users will have to pass an option. But we can usually
4963 # detect their failure to do so: if the tree is not a clean
4964 # patches-applied tree, quilt linearisation fails, but the tree
4965 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4966 # they want --quilt=unapplied.
4968 # To help detect this, when we are extracting the fake dsc, we
4969 # first extract it with --skip-patches, and then apply the patches
4970 # afterwards with dpkg-source --before-build. That lets us save a
4971 # tree object corresponding to .origs.
4973 my $splitbrain_cachekey;
4975 quilt_make_fake_dsc($upstreamversion);
4977 if (quiltmode_splitbrain()) {
4979 ($cachehit, $splitbrain_cachekey) =
4980 quilt_check_splitbrain_cache($headref, $upstreamversion);
4981 return if $cachehit;
4985 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4987 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4988 rename $fakexdir, "fake" or die "$fakexdir $!";
4992 remove_stray_gits();
4993 mktree_in_ud_here();
4997 runcmd @git, qw(add -Af .);
4998 my $unapplied=git_write_tree();
4999 printdebug "fake orig tree object $unapplied\n";
5003 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5005 if (system @bbcmd) {
5006 failedcmd @bbcmd if $? < 0;
5008 failed to apply your git tree's patch stack (from debian/patches/) to
5009 the corresponding upstream tarball(s). Your source tree and .orig
5010 are probably too inconsistent. dgit can only fix up certain kinds of
5011 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5017 quilt_fixup_mkwork($headref);
5020 if (stat_exists ".pc") {
5022 progress "Tree already contains .pc - will use it then delete it.";
5025 rename '../fake/.pc','.pc' or die $!;
5028 changedir '../fake';
5030 runcmd @git, qw(add -Af .);
5031 my $oldtiptree=git_write_tree();
5032 printdebug "fake o+d/p tree object $unapplied\n";
5033 changedir '../work';
5036 # We calculate some guesswork now about what kind of tree this might
5037 # be. This is mostly for error reporting.
5043 # O = orig, without patches applied
5044 # A = "applied", ie orig with H's debian/patches applied
5045 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5046 \%editedignores, \@unrepres),
5047 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5048 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5052 foreach my $b (qw(01 02)) {
5053 foreach my $v (qw(O2H O2A H2A)) {
5054 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5057 printdebug "differences \@dl @dl.\n";
5060 "$us: base trees orig=%.20s o+d/p=%.20s",
5061 $unapplied, $oldtiptree;
5063 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5064 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5065 $dl[0], $dl[1], $dl[3], $dl[4],
5069 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5071 forceable_fail [qw(unrepresentable)], <<END;
5072 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5077 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5078 push @failsuggestion, "This might be a patches-unapplied branch.";
5079 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5080 push @failsuggestion, "This might be a patches-applied branch.";
5082 push @failsuggestion, "Maybe you need to specify one of".
5083 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5085 if (quiltmode_splitbrain()) {
5086 quiltify_splitbrain($clogp, $unapplied, $headref,
5087 $diffbits, \%editedignores,
5088 $splitbrain_cachekey);
5092 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5093 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5095 if (!open P, '>>', ".pc/applied-patches") {
5096 $!==&ENOENT or die $!;
5101 commit_quilty_patch();
5103 if ($mustdeletepc) {
5104 quilt_fixup_delete_pc();
5108 sub quilt_fixup_editor () {
5109 my $descfn = $ENV{$fakeeditorenv};
5110 my $editing = $ARGV[$#ARGV];
5111 open I1, '<', $descfn or die "$descfn: $!";
5112 open I2, '<', $editing or die "$editing: $!";
5113 unlink $editing or die "$editing: $!";
5114 open O, '>', $editing or die "$editing: $!";
5115 while (<I1>) { print O or die $!; } I1->error and die $!;
5118 $copying ||= m/^\-\-\- /;
5119 next unless $copying;
5122 I2->error and die $!;
5127 sub maybe_apply_patches_dirtily () {
5128 return unless $quilt_mode =~ m/gbp|unapplied/;
5129 print STDERR <<END or die $!;
5131 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5132 dgit: Have to apply the patches - making the tree dirty.
5133 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5136 $patches_applied_dirtily = 01;
5137 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5138 runcmd qw(dpkg-source --before-build .);
5141 sub maybe_unapply_patches_again () {
5142 progress "dgit: Unapplying patches again to tidy up the tree."
5143 if $patches_applied_dirtily;
5144 runcmd qw(dpkg-source --after-build .)
5145 if $patches_applied_dirtily & 01;
5147 if $patches_applied_dirtily & 02;
5148 $patches_applied_dirtily = 0;
5151 #----- other building -----
5153 our $clean_using_builder;
5154 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5155 # clean the tree before building (perhaps invoked indirectly by
5156 # whatever we are using to run the build), rather than separately
5157 # and explicitly by us.
5160 return if $clean_using_builder;
5161 if ($cleanmode eq 'dpkg-source') {
5162 maybe_apply_patches_dirtily();
5163 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5164 } elsif ($cleanmode eq 'dpkg-source-d') {
5165 maybe_apply_patches_dirtily();
5166 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5167 } elsif ($cleanmode eq 'git') {
5168 runcmd_ordryrun_local @git, qw(clean -xdf);
5169 } elsif ($cleanmode eq 'git-ff') {
5170 runcmd_ordryrun_local @git, qw(clean -xdff);
5171 } elsif ($cleanmode eq 'check') {
5172 my $leftovers = cmdoutput @git, qw(clean -xdn);
5173 if (length $leftovers) {
5174 print STDERR $leftovers, "\n" or die $!;
5175 fail "tree contains uncommitted files and --clean=check specified";
5177 } elsif ($cleanmode eq 'none') {
5184 badusage "clean takes no additional arguments" if @ARGV;
5187 maybe_unapply_patches_again();
5190 sub build_prep_early () {
5191 our $build_prep_early_done //= 0;
5192 return if $build_prep_early_done++;
5194 badusage "-p is not allowed when building" if defined $package;
5195 my $clogp = parsechangelog();
5196 $isuite = getfield $clogp, 'Distribution';
5197 $package = getfield $clogp, 'Source';
5198 $version = getfield $clogp, 'Version';
5205 build_maybe_quilt_fixup();
5207 my $pat = changespat $version;
5208 foreach my $f (glob "$buildproductsdir/$pat") {
5210 unlink $f or fail "remove old changes file $f: $!";
5212 progress "would remove $f";
5218 sub changesopts_initial () {
5219 my @opts =@changesopts[1..$#changesopts];
5222 sub changesopts_version () {
5223 if (!defined $changes_since_version) {
5224 my @vsns = archive_query('archive_query');
5225 my @quirk = access_quirk();
5226 if ($quirk[0] eq 'backports') {
5227 local $isuite = $quirk[2];
5229 canonicalise_suite();
5230 push @vsns, archive_query('archive_query');
5233 @vsns = map { $_->[0] } @vsns;
5234 @vsns = sort { -version_compare($a, $b) } @vsns;
5235 $changes_since_version = $vsns[0];
5236 progress "changelog will contain changes since $vsns[0]";
5238 $changes_since_version = '_';
5239 progress "package seems new, not specifying -v<version>";
5242 if ($changes_since_version ne '_') {
5243 return ("-v$changes_since_version");
5249 sub changesopts () {
5250 return (changesopts_initial(), changesopts_version());
5253 sub massage_dbp_args ($;$) {
5254 my ($cmd,$xargs) = @_;
5257 # - if we're going to split the source build out so we can
5258 # do strange things to it, massage the arguments to dpkg-buildpackage
5259 # so that the main build doessn't build source (or add an argument
5260 # to stop it building source by default).
5262 # - add -nc to stop dpkg-source cleaning the source tree,
5263 # unless we're not doing a split build and want dpkg-source
5264 # as cleanmode, in which case we can do nothing
5267 # 0 - source will NOT need to be built separately by caller
5268 # +1 - source will need to be built separately by caller
5269 # +2 - source will need to be built separately by caller AND
5270 # dpkg-buildpackage should not in fact be run at all!
5271 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5272 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5273 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5274 $clean_using_builder = 1;
5277 # -nc has the side effect of specifying -b if nothing else specified
5278 # and some combinations of -S, -b, et al, are errors, rather than
5279 # later simply overriding earlie. So we need to:
5280 # - search the command line for these options
5281 # - pick the last one
5282 # - perhaps add our own as a default
5283 # - perhaps adjust it to the corresponding non-source-building version
5285 foreach my $l ($cmd, $xargs) {
5287 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5290 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5292 if ($need_split_build_invocation) {
5293 printdebug "massage split $dmode.\n";
5294 $r = $dmode =~ m/[S]/ ? +2 :
5295 $dmode =~ y/gGF/ABb/ ? +1 :
5296 $dmode =~ m/[ABb]/ ? 0 :
5299 printdebug "massage done $r $dmode.\n";
5301 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5307 my $wasdir = must_getcwd();
5313 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5314 my ($msg_if_onlyone) = @_;
5315 # If there is only one .changes file, fail with $msg_if_onlyone,
5316 # or if that is undef, be a no-op.
5317 # Returns the changes file to report to the user.
5318 my $pat = changespat $version;
5319 my @changesfiles = glob $pat;
5320 @changesfiles = sort {
5321 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5325 if (@changesfiles==1) {
5326 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5327 only one changes file from build (@changesfiles)
5329 $result = $changesfiles[0];
5330 } elsif (@changesfiles==2) {
5331 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5332 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5333 fail "$l found in binaries changes file $binchanges"
5336 runcmd_ordryrun_local @mergechanges, @changesfiles;
5337 my $multichanges = changespat $version,'multi';
5339 stat_exists $multichanges or fail "$multichanges: $!";
5340 foreach my $cf (glob $pat) {
5341 next if $cf eq $multichanges;
5342 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5345 $result = $multichanges;
5347 fail "wrong number of different changes files (@changesfiles)";
5349 printdone "build successful, results in $result\n" or die $!;
5352 sub midbuild_checkchanges () {
5353 my $pat = changespat $version;
5354 return if $rmchanges;
5355 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5356 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5358 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5359 Suggest you delete @unwanted.
5364 sub midbuild_checkchanges_vanilla ($) {
5366 midbuild_checkchanges() if $wantsrc == 1;
5369 sub postbuild_mergechanges_vanilla ($) {
5371 if ($wantsrc == 1) {
5373 postbuild_mergechanges(undef);
5376 printdone "build successful\n";
5381 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5382 my $wantsrc = massage_dbp_args \@dbp;
5385 midbuild_checkchanges_vanilla $wantsrc;
5390 push @dbp, changesopts_version();
5391 maybe_apply_patches_dirtily();
5392 runcmd_ordryrun_local @dbp;
5394 maybe_unapply_patches_again();
5395 postbuild_mergechanges_vanilla $wantsrc;
5399 $quilt_mode //= 'gbp';
5405 # gbp can make .origs out of thin air. In my tests it does this
5406 # even for a 1.0 format package, with no origs present. So I
5407 # guess it keys off just the version number. We don't know
5408 # exactly what .origs ought to exist, but let's assume that we
5409 # should run gbp if: the version has an upstream part and the main
5411 my $upstreamversion = upstreamversion $version;
5412 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5413 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5415 if ($gbp_make_orig) {
5417 $cleanmode = 'none'; # don't do it again
5418 $need_split_build_invocation = 1;
5421 my @dbp = @dpkgbuildpackage;
5423 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5425 if (!length $gbp_build[0]) {
5426 if (length executable_on_path('git-buildpackage')) {
5427 $gbp_build[0] = qw(git-buildpackage);
5429 $gbp_build[0] = 'gbp buildpackage';
5432 my @cmd = opts_opt_multi_cmd @gbp_build;
5434 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5436 if ($gbp_make_orig) {
5437 ensuredir '.git/dgit';
5438 my $ok = '.git/dgit/origs-gen-ok';
5439 unlink $ok or $!==&ENOENT or die $!;
5440 my @origs_cmd = @cmd;
5441 push @origs_cmd, qw(--git-cleaner=true);
5442 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5443 push @origs_cmd, @ARGV;
5445 debugcmd @origs_cmd;
5447 do { local $!; stat_exists $ok; }
5448 or failedcmd @origs_cmd;
5450 dryrun_report @origs_cmd;
5456 midbuild_checkchanges_vanilla $wantsrc;
5458 if (!$clean_using_builder) {
5459 push @cmd, '--git-cleaner=true';
5463 maybe_unapply_patches_again();
5465 push @cmd, changesopts();
5466 runcmd_ordryrun_local @cmd, @ARGV;
5468 postbuild_mergechanges_vanilla $wantsrc;
5470 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5473 my $our_cleanmode = $cleanmode;
5474 if ($need_split_build_invocation) {
5475 # Pretend that clean is being done some other way. This
5476 # forces us not to try to use dpkg-buildpackage to clean and
5477 # build source all in one go; and instead we run dpkg-source
5478 # (and build_prep() will do the clean since $clean_using_builder
5480 $our_cleanmode = 'ELSEWHERE';
5482 if ($our_cleanmode =~ m/^dpkg-source/) {
5483 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5484 $clean_using_builder = 1;
5487 $sourcechanges = changespat $version,'source';
5489 unlink "../$sourcechanges" or $!==ENOENT
5490 or fail "remove $sourcechanges: $!";
5492 $dscfn = dscfn($version);
5493 if ($our_cleanmode eq 'dpkg-source') {
5494 maybe_apply_patches_dirtily();
5495 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5497 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5498 maybe_apply_patches_dirtily();
5499 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5502 my @cmd = (@dpkgsource, qw(-b --));
5505 runcmd_ordryrun_local @cmd, "work";
5506 my @udfiles = <${package}_*>;
5507 changedir "../../..";
5508 foreach my $f (@udfiles) {
5509 printdebug "source copy, found $f\n";
5512 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5513 $f eq srcfn($version, $&));
5514 printdebug "source copy, found $f - renaming\n";
5515 rename "$ud/$f", "../$f" or $!==ENOENT
5516 or fail "put in place new source file ($f): $!";
5519 my $pwd = must_getcwd();
5520 my $leafdir = basename $pwd;
5522 runcmd_ordryrun_local @cmd, $leafdir;
5525 runcmd_ordryrun_local qw(sh -ec),
5526 'exec >$1; shift; exec "$@"','x',
5527 "../$sourcechanges",
5528 @dpkggenchanges, qw(-S), changesopts();
5532 sub cmd_build_source {
5533 badusage "build-source takes no additional arguments" if @ARGV;
5535 maybe_unapply_patches_again();
5536 printdone "source built, results in $dscfn and $sourcechanges";
5541 midbuild_checkchanges();
5544 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5545 stat_exists $sourcechanges
5546 or fail "$sourcechanges (in parent directory): $!";
5548 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5550 maybe_unapply_patches_again();
5552 postbuild_mergechanges(<<END);
5553 perhaps you need to pass -A ? (sbuild's default is to build only
5554 arch-specific binaries; dgit 1.4 used to override that.)
5559 sub cmd_quilt_fixup {
5560 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5561 my $clogp = parsechangelog();
5562 $version = getfield $clogp, 'Version';
5563 $package = getfield $clogp, 'Source';
5566 build_maybe_quilt_fixup();
5569 sub cmd_import_dsc {
5573 last unless $ARGV[0] =~ m/^-/;
5576 if (m/^--require-valid-signature$/) {
5579 badusage "unknown dgit import-dsc sub-option \`$_'";
5583 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5584 my ($dscfn, $dstbranch) = @ARGV;
5586 badusage "dry run makes no sense with import-dsc" unless act_local();
5588 my $force = $dstbranch =~ s/^\+// ? +1 :
5589 $dstbranch =~ s/^\.\.// ? -1 :
5591 my $info = $force ? " $&" : '';
5592 $info = "$dscfn$info";
5594 my $specbranch = $dstbranch;
5595 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5596 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5598 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5599 my $chead = cmdoutput_errok @symcmd;
5600 defined $chead or $?==256 or failedcmd @symcmd;
5602 fail "$dstbranch is checked out - will not update it"
5603 if defined $chead and $chead eq $dstbranch;
5605 my $oldhash = git_get_ref $dstbranch;
5607 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
5608 $dscdata = do { local $/ = undef; <D>; };
5609 D->error and fail "read $dscfn: $!";
5612 # we don't normally need this so import it here
5613 use Dpkg::Source::Package;
5614 my $dp = new Dpkg::Source::Package filename => $dscfn,
5615 require_valid_signature => $needsig;
5617 local $SIG{__WARN__} = sub {
5619 return unless $needsig;
5620 fail "import-dsc signature check failed";
5622 if (!$dp->is_signed()) {
5623 warn "$us: warning: importing unsigned .dsc\n";
5625 my $r = $dp->check_signature();
5626 die "->check_signature => $r" if $needsig && $r;
5632 my $dgit_commit = $dsc->{$ourdscfield[0]};
5633 if (defined $dgit_commit &&
5634 !forceing [qw(import-dsc-with-dgit-field)]) {
5635 $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
5636 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
5637 my @cmd = (qw(sh -ec),
5638 "echo $dgit_commit | git cat-file --batch-check");
5639 my $objgot = cmdoutput @cmd;
5640 if ($objgot =~ m#^\w+ missing\b#) {
5642 .dsc contains Dgit field referring to object $dgit_commit
5643 Your git tree does not have that object. Try `git fetch' from a
5644 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
5647 if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
5649 progress "Not fast forward, forced update.";
5651 fail "Not fast forward to $dgit_commit";
5654 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
5655 $dstbranch, $dgit_commit);
5657 progress "dgit: import-dsc updated git ref $dstbranch";
5662 Branch $dstbranch already exists
5663 Specify ..$specbranch for a pseudo-merge, binding in existing history
5664 Specify +$specbranch to overwrite, discarding existing history
5666 if $oldhash && !$force;
5668 $package = getfield $dsc, 'Source';
5669 my @dfi = dsc_files_info();
5670 foreach my $fi (@dfi) {
5671 my $f = $fi->{Filename};
5673 next if lstat $here;
5674 fail "stat $here: $!" unless $! == ENOENT;
5676 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
5678 } elsif ($dscfn =~ m#^/#) {
5681 fail "cannot import $dscfn which seems to be inside working tree!";
5683 $there =~ s#/+[^/]+$## or
5684 fail "cannot import $dscfn which seems to not have a basename";
5686 symlink $there, $here or fail "symlink $there to $here: $!";
5687 progress "made symlink $here -> $there";
5688 print STDERR Dumper($fi);
5690 my @mergeinputs = generate_commits_from_dsc();
5691 die unless @mergeinputs == 1;
5693 my $newhash = $mergeinputs[0]{Commit};
5697 progress "Import, forced update - synthetic orphan git history.";
5698 } elsif ($force < 0) {
5699 progress "Import, merging.";
5700 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
5701 my $version = getfield $dsc, 'Version';
5702 $newhash = make_commit_text <<END;
5707 Merge $package ($version) import into $dstbranch
5710 die; # caught earlier
5714 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
5715 $dstbranch, $newhash);
5717 progress "dgit: import-dsc results are in in git ref $dstbranch";
5720 sub cmd_archive_api_query {
5721 badusage "need only 1 subpath argument" unless @ARGV==1;
5722 my ($subpath) = @ARGV;
5723 my @cmd = archive_api_query_cmd($subpath);
5726 exec @cmd or fail "exec curl: $!\n";
5729 sub cmd_clone_dgit_repos_server {
5730 badusage "need destination argument" unless @ARGV==1;
5731 my ($destdir) = @ARGV;
5732 $package = '_dgit-repos-server';
5733 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5735 exec @cmd or fail "exec git clone: $!\n";
5738 sub cmd_setup_mergechangelogs {
5739 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5740 setup_mergechangelogs(1);
5743 sub cmd_setup_useremail {
5744 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5748 sub cmd_setup_new_tree {
5749 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5753 #---------- argument parsing and main program ----------
5756 print "dgit version $our_version\n" or die $!;
5760 our (%valopts_long, %valopts_short);
5763 sub defvalopt ($$$$) {
5764 my ($long,$short,$val_re,$how) = @_;
5765 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5766 $valopts_long{$long} = $oi;
5767 $valopts_short{$short} = $oi;
5768 # $how subref should:
5769 # do whatever assignemnt or thing it likes with $_[0]
5770 # if the option should not be passed on to remote, @rvalopts=()
5771 # or $how can be a scalar ref, meaning simply assign the value
5774 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5775 defvalopt '--distro', '-d', '.+', \$idistro;
5776 defvalopt '', '-k', '.+', \$keyid;
5777 defvalopt '--existing-package','', '.*', \$existing_package;
5778 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5779 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5780 defvalopt '--package', '-p', $package_re, \$package;
5781 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5783 defvalopt '', '-C', '.+', sub {
5784 ($changesfile) = (@_);
5785 if ($changesfile =~ s#^(.*)/##) {
5786 $buildproductsdir = $1;
5790 defvalopt '--initiator-tempdir','','.*', sub {
5791 ($initiator_tempdir) = (@_);
5792 $initiator_tempdir =~ m#^/# or
5793 badusage "--initiator-tempdir must be used specify an".
5794 " absolute, not relative, directory."
5800 if (defined $ENV{'DGIT_SSH'}) {
5801 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5802 } elsif (defined $ENV{'GIT_SSH'}) {
5803 @ssh = ($ENV{'GIT_SSH'});
5811 if (!defined $val) {
5812 badusage "$what needs a value" unless @ARGV;
5814 push @rvalopts, $val;
5816 badusage "bad value \`$val' for $what" unless
5817 $val =~ m/^$oi->{Re}$(?!\n)/s;
5818 my $how = $oi->{How};
5819 if (ref($how) eq 'SCALAR') {
5824 push @ropts, @rvalopts;
5828 last unless $ARGV[0] =~ m/^-/;
5832 if (m/^--dry-run$/) {
5835 } elsif (m/^--damp-run$/) {
5838 } elsif (m/^--no-sign$/) {
5841 } elsif (m/^--help$/) {
5843 } elsif (m/^--version$/) {
5845 } elsif (m/^--new$/) {
5848 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5849 ($om = $opts_opt_map{$1}) &&
5853 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5854 !$opts_opt_cmdonly{$1} &&
5855 ($om = $opts_opt_map{$1})) {
5858 } elsif (m/^--(gbp|dpm)$/s) {
5859 push @ropts, "--quilt=$1";
5861 } elsif (m/^--ignore-dirty$/s) {
5864 } elsif (m/^--no-quilt-fixup$/s) {
5866 $quilt_mode = 'nocheck';
5867 } elsif (m/^--no-rm-on-error$/s) {
5870 } elsif (m/^--overwrite$/s) {
5872 $overwrite_version = '';
5873 } elsif (m/^--overwrite=(.+)$/s) {
5875 $overwrite_version = $1;
5876 } elsif (m/^--delayed=(\d+)$/s) {
5879 } elsif (m/^--dgit-view-save=(.+)$/s) {
5881 $split_brain_save = $1;
5882 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
5883 } elsif (m/^--(no-)?rm-old-changes$/s) {
5886 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5888 push @deliberatelies, $&;
5889 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5893 } elsif (m/^--force-/) {
5895 "$us: warning: ignoring unknown force option $_\n";
5897 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5898 # undocumented, for testing
5900 $tagformat_want = [ $1, 'command line', 1 ];
5901 # 1 menas overrides distro configuration
5902 } elsif (m/^--always-split-source-build$/s) {
5903 # undocumented, for testing
5905 $need_split_build_invocation = 1;
5906 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5907 $val = $2 ? $' : undef; #';
5908 $valopt->($oi->{Long});
5910 badusage "unknown long option \`$_'";
5917 } elsif (s/^-L/-/) {
5920 } elsif (s/^-h/-/) {
5922 } elsif (s/^-D/-/) {
5926 } elsif (s/^-N/-/) {
5931 push @changesopts, $_;
5933 } elsif (s/^-wn$//s) {
5935 $cleanmode = 'none';
5936 } elsif (s/^-wg$//s) {
5939 } elsif (s/^-wgf$//s) {
5941 $cleanmode = 'git-ff';
5942 } elsif (s/^-wd$//s) {
5944 $cleanmode = 'dpkg-source';
5945 } elsif (s/^-wdd$//s) {
5947 $cleanmode = 'dpkg-source-d';
5948 } elsif (s/^-wc$//s) {
5950 $cleanmode = 'check';
5951 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5952 push @git, '-c', $&;
5953 $gitcfgs{cmdline}{$1} = [ $2 ];
5954 } elsif (s/^-c([^=]+)$//s) {
5955 push @git, '-c', $&;
5956 $gitcfgs{cmdline}{$1} = [ 'true' ];
5957 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5959 $val = undef unless length $val;
5960 $valopt->($oi->{Short});
5963 badusage "unknown short option \`$_'";
5970 sub check_env_sanity () {
5971 my $blocked = new POSIX::SigSet;
5972 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5975 foreach my $name (qw(PIPE CHLD)) {
5976 my $signame = "SIG$name";
5977 my $signum = eval "POSIX::$signame" // die;
5978 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5979 die "$signame is set to something other than SIG_DFL\n";
5980 $blocked->ismember($signum) and
5981 die "$signame is blocked\n";
5987 On entry to dgit, $@
5988 This is a bug produced by something in in your execution environment.
5994 sub finalise_opts_opts () {
5995 foreach my $k (keys %opts_opt_map) {
5996 my $om = $opts_opt_map{$k};
5998 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6000 badcfg "cannot set command for $k"
6001 unless length $om->[0];
6005 foreach my $c (access_cfg_cfgs("opts-$k")) {
6007 map { $_ ? @$_ : () }
6008 map { $gitcfgs{$_}{$c} }
6009 reverse @gitcfgsources;
6010 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6011 "\n" if $debuglevel >= 4;
6013 badcfg "cannot configure options for $k"
6014 if $opts_opt_cmdonly{$k};
6015 my $insertpos = $opts_cfg_insertpos{$k};
6016 @$om = ( @$om[0..$insertpos-1],
6018 @$om[$insertpos..$#$om] );
6023 if ($ENV{$fakeeditorenv}) {
6025 quilt_fixup_editor();
6032 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6033 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6034 if $dryrun_level == 1;
6036 print STDERR $helpmsg or die $!;
6039 my $cmd = shift @ARGV;
6042 my $pre_fn = ${*::}{"pre_$cmd"};
6043 $pre_fn->() if $pre_fn;
6045 if (!defined $rmchanges) {
6046 local $access_forpush;
6047 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6050 if (!defined $quilt_mode) {
6051 local $access_forpush;
6052 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6053 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6055 $quilt_mode =~ m/^($quilt_modes_re)$/
6056 or badcfg "unknown quilt-mode \`$quilt_mode'";
6060 $need_split_build_invocation ||= quiltmode_splitbrain();
6062 if (!defined $cleanmode) {
6063 local $access_forpush;
6064 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6065 $cleanmode //= 'dpkg-source';
6067 badcfg "unknown clean-mode \`$cleanmode'" unless
6068 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6071 my $fn = ${*::}{"cmd_$cmd"};
6072 $fn or badusage "unknown operation $cmd";