3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
39 use Text::Glob qw(match_glob);
40 use Fcntl qw(:DEFAULT :flock);
45 our $our_version = 'UNRELEASED'; ###substituted###
46 our $absurdity = undef; ###substituted###
48 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
51 our $isuite = 'unstable';
57 our $dryrun_level = 0;
59 our $buildproductsdir = '..';
65 our $existing_package = 'dpkg';
67 our $changes_since_version;
69 our $overwrite_version; # undef: not specified; '': check changelog
71 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
73 our $dodep14tag_re = 'want|no|always';
74 our $split_brain_save;
75 our $we_are_responder;
76 our $initiator_tempdir;
77 our $patches_applied_dirtily = 00;
81 our $chase_dsc_distro=1; #xxx configurable
83 our %forceopts = map { $_=>0 }
84 qw(unrepresentable unsupported-source-format
85 dsc-changes-mismatch changes-origs-exactly
86 import-gitapply-absurd
87 import-gitapply-no-absurd
88 import-dsc-with-dgit-field);
90 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
92 our $suite_re = '[-+.0-9a-z]+';
93 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
94 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
95 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
96 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
98 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
99 our $splitbraincache = 'dgit-intern/quilt-cache';
100 our $rewritemap = 'dgit-rewrite/map';
102 our (@git) = qw(git);
103 our (@dget) = qw(dget);
104 our (@curl) = qw(curl);
105 our (@dput) = qw(dput);
106 our (@debsign) = qw(debsign);
107 our (@gpg) = qw(gpg);
108 our (@sbuild) = qw(sbuild);
110 our (@dgit) = qw(dgit);
111 our (@aptget) = qw(apt-get);
112 our (@aptcache) = qw(apt-cache);
113 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
114 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
115 our (@dpkggenchanges) = qw(dpkg-genchanges);
116 our (@mergechanges) = qw(mergechanges -f);
117 our (@gbp_build) = ('');
118 our (@gbp_pq) = ('gbp pq');
119 our (@changesopts) = ('');
121 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
124 'debsign' => \@debsign,
126 'sbuild' => \@sbuild,
130 'apt-get' => \@aptget,
131 'apt-cache' => \@aptcache,
132 'dpkg-source' => \@dpkgsource,
133 'dpkg-buildpackage' => \@dpkgbuildpackage,
134 'dpkg-genchanges' => \@dpkggenchanges,
135 'gbp-build' => \@gbp_build,
136 'gbp-pq' => \@gbp_pq,
137 'ch' => \@changesopts,
138 'mergechanges' => \@mergechanges);
140 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
141 our %opts_cfg_insertpos = map {
143 scalar @{ $opts_opt_map{$_} }
144 } keys %opts_opt_map;
146 sub parseopts_late_defaults();
152 our $supplementary_message = '';
153 our $need_split_build_invocation = 0;
154 our $split_brain = 0;
158 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
161 our $remotename = 'dgit';
162 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
166 if (!defined $absurdity) {
168 $absurdity =~ s{/[^/]+$}{/absurd} or die;
172 my ($v,$distro) = @_;
173 return $tagformatfn->($v, $distro);
176 sub debiantag_maintview ($$) {
177 my ($v,$distro) = @_;
178 return "$distro/".dep14_version_mangle $v;
181 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
183 sub lbranch () { return "$branchprefix/$csuite"; }
184 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
185 sub lref () { return "refs/heads/".lbranch(); }
186 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
187 sub rrref () { return server_ref($csuite); }
197 return "${package}_".(stripepoch $vsn).$sfx
202 return srcfn($vsn,".dsc");
205 sub changespat ($;$) {
206 my ($vsn, $arch) = @_;
207 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
210 sub upstreamversion ($) {
222 foreach my $f (@end) {
224 print STDERR "$us: cleanup: $@" if length $@;
228 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
230 sub forceable_fail ($$) {
231 my ($forceoptsl, $msg) = @_;
232 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
233 print STDERR "warning: overriding problem due to --force:\n". $msg;
237 my ($forceoptsl) = @_;
238 my @got = grep { $forceopts{$_} } @$forceoptsl;
239 return 0 unless @got;
241 "warning: skipping checks or functionality due to --force-$got[0]\n";
244 sub no_such_package () {
245 print STDERR "$us: package $package does not exist in suite $isuite\n";
251 printdebug "CD $newdir\n";
252 chdir $newdir or confess "chdir: $newdir: $!";
255 sub deliberately ($) {
257 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
260 sub deliberately_not_fast_forward () {
261 foreach (qw(not-fast-forward fresh-repo)) {
262 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
266 sub quiltmode_splitbrain () {
267 $quilt_mode =~ m/gbp|dpm|unapplied/;
270 sub opts_opt_multi_cmd {
272 push @cmd, split /\s+/, shift @_;
278 return opts_opt_multi_cmd @gbp_pq;
281 #---------- remote protocol support, common ----------
283 # remote push initiator/responder protocol:
284 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
285 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
286 # < dgit-remote-push-ready <actual-proto-vsn>
293 # > supplementary-message NBYTES # $protovsn >= 3
298 # > file parsed-changelog
299 # [indicates that output of dpkg-parsechangelog follows]
300 # > data-block NBYTES
301 # > [NBYTES bytes of data (no newline)]
302 # [maybe some more blocks]
311 # > param head DGIT-VIEW-HEAD
312 # > param csuite SUITE
313 # > param tagformat old|new
314 # > param maint-view MAINT-VIEW-HEAD
316 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
317 # # goes into tag, for replay prevention
320 # [indicates that signed tag is wanted]
321 # < data-block NBYTES
322 # < [NBYTES bytes of data (no newline)]
323 # [maybe some more blocks]
327 # > want signed-dsc-changes
328 # < data-block NBYTES [transfer of signed dsc]
330 # < data-block NBYTES [transfer of signed changes]
338 sub i_child_report () {
339 # Sees if our child has died, and reap it if so. Returns a string
340 # describing how it died if it failed, or undef otherwise.
341 return undef unless $i_child_pid;
342 my $got = waitpid $i_child_pid, WNOHANG;
343 return undef if $got <= 0;
344 die unless $got == $i_child_pid;
345 $i_child_pid = undef;
346 return undef unless $?;
347 return "build host child ".waitstatusmsg();
352 fail "connection lost: $!" if $fh->error;
353 fail "protocol violation; $m not expected";
356 sub badproto_badread ($$) {
358 fail "connection lost: $!" if $!;
359 my $report = i_child_report();
360 fail $report if defined $report;
361 badproto $fh, "eof (reading $wh)";
364 sub protocol_expect (&$) {
365 my ($match, $fh) = @_;
368 defined && chomp or badproto_badread $fh, "protocol message";
376 badproto $fh, "\`$_'";
379 sub protocol_send_file ($$) {
380 my ($fh, $ourfn) = @_;
381 open PF, "<", $ourfn or die "$ourfn: $!";
384 my $got = read PF, $d, 65536;
385 die "$ourfn: $!" unless defined $got;
387 print $fh "data-block ".length($d)."\n" or die $!;
388 print $fh $d or die $!;
390 PF->error and die "$ourfn $!";
391 print $fh "data-end\n" or die $!;
395 sub protocol_read_bytes ($$) {
396 my ($fh, $nbytes) = @_;
397 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
399 my $got = read $fh, $d, $nbytes;
400 $got==$nbytes or badproto_badread $fh, "data block";
404 sub protocol_receive_file ($$) {
405 my ($fh, $ourfn) = @_;
406 printdebug "() $ourfn\n";
407 open PF, ">", $ourfn or die "$ourfn: $!";
409 my ($y,$l) = protocol_expect {
410 m/^data-block (.*)$/ ? (1,$1) :
411 m/^data-end$/ ? (0,) :
415 my $d = protocol_read_bytes $fh, $l;
416 print PF $d or die $!;
421 #---------- remote protocol support, responder ----------
423 sub responder_send_command ($) {
425 return unless $we_are_responder;
426 # called even without $we_are_responder
427 printdebug ">> $command\n";
428 print PO $command, "\n" or die $!;
431 sub responder_send_file ($$) {
432 my ($keyword, $ourfn) = @_;
433 return unless $we_are_responder;
434 printdebug "]] $keyword $ourfn\n";
435 responder_send_command "file $keyword";
436 protocol_send_file \*PO, $ourfn;
439 sub responder_receive_files ($@) {
440 my ($keyword, @ourfns) = @_;
441 die unless $we_are_responder;
442 printdebug "[[ $keyword @ourfns\n";
443 responder_send_command "want $keyword";
444 foreach my $fn (@ourfns) {
445 protocol_receive_file \*PI, $fn;
448 protocol_expect { m/^files-end$/ } \*PI;
451 #---------- remote protocol support, initiator ----------
453 sub initiator_expect (&) {
455 protocol_expect { &$match } \*RO;
458 #---------- end remote code ----------
461 if ($we_are_responder) {
463 responder_send_command "progress ".length($m) or die $!;
464 print PO $m or die $!;
474 $ua = LWP::UserAgent->new();
478 progress "downloading $what...";
479 my $r = $ua->get(@_) or die $!;
480 return undef if $r->code == 404;
481 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
482 return $r->decoded_content(charset => 'none');
485 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
490 failedcmd @_ if system @_;
493 sub act_local () { return $dryrun_level <= 1; }
494 sub act_scary () { return !$dryrun_level; }
497 if (!$dryrun_level) {
498 progress "$us ok: @_";
500 progress "would be ok: @_ (but dry run only)";
505 printcmd(\*STDERR,$debugprefix."#",@_);
508 sub runcmd_ordryrun {
516 sub runcmd_ordryrun_local {
525 my ($first_shell, @cmd) = @_;
526 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
529 our $helpmsg = <<END;
531 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
532 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
533 dgit [dgit-opts] build [dpkg-buildpackage-opts]
534 dgit [dgit-opts] sbuild [sbuild-opts]
535 dgit [dgit-opts] push [dgit-opts] [suite]
536 dgit [dgit-opts] rpush build-host:build-dir ...
537 important dgit options:
538 -k<keyid> sign tag and package with <keyid> instead of default
539 --dry-run -n do not change anything, but go through the motions
540 --damp-run -L like --dry-run but make local changes, without signing
541 --new -N allow introducing a new package
542 --debug -D increase debug level
543 -c<name>=<value> set git config option (used directly by dgit too)
546 our $later_warning_msg = <<END;
547 Perhaps the upload is stuck in incoming. Using the version from git.
551 print STDERR "$us: @_\n", $helpmsg or die $!;
556 @ARGV or badusage "too few arguments";
557 return scalar shift @ARGV;
561 print $helpmsg or die $!;
565 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
567 our %defcfg = ('dgit.default.distro' => 'debian',
568 'dgit-suite.*-security.distro' => 'debian-security',
569 'dgit.default.username' => '',
570 'dgit.default.archive-query-default-component' => 'main',
571 'dgit.default.ssh' => 'ssh',
572 'dgit.default.archive-query' => 'madison:',
573 'dgit.default.sshpsql-dbname' => 'service=projectb',
574 'dgit.default.aptget-components' => 'main',
575 'dgit.default.dgit-tag-format' => 'new,old,maint',
576 'dgit.dsc-url-proto-ok.http' => 'true',
577 'dgit.dsc-url-proto-ok.https' => 'true',
578 'dgit.dsc-url-proto-ok.git' => 'true',
579 'dgit.default.dsc-url-proto-ok' => 'false',
580 # old means "repo server accepts pushes with old dgit tags"
581 # new means "repo server accepts pushes with new dgit tags"
582 # maint means "repo server accepts split brain pushes"
583 # hist means "repo server may have old pushes without new tag"
584 # ("hist" is implied by "old")
585 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
586 'dgit-distro.debian.git-check' => 'url',
587 'dgit-distro.debian.git-check-suffix' => '/info/refs',
588 'dgit-distro.debian.new-private-pushers' => 't',
589 'dgit-distro.debian/push.git-url' => '',
590 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
591 'dgit-distro.debian/push.git-user-force' => 'dgit',
592 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
593 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
594 'dgit-distro.debian/push.git-create' => 'true',
595 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
596 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
597 # 'dgit-distro.debian.archive-query-tls-key',
598 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
599 # ^ this does not work because curl is broken nowadays
600 # Fixing #790093 properly will involve providing providing the key
601 # in some pacagke and maybe updating these paths.
603 # 'dgit-distro.debian.archive-query-tls-curl-args',
604 # '--ca-path=/etc/ssl/ca-debian',
605 # ^ this is a workaround but works (only) on DSA-administered machines
606 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
607 'dgit-distro.debian.git-url-suffix' => '',
608 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
609 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
610 'dgit-distro.debian-security.archive-query' => 'aptget:',
611 'dgit-distro.debian-security.mirror' => 'http://security.debian.org/debian-security/',
612 'dgit-distro.debian-security.aptget-suite-map' => 's#-security$#/updates#',
613 'dgit-distro.debian-security.aptget-suite-rmap' => 's#$#-security#',
614 'dgit-distro.debian-security.nominal-distro' => 'debian',
615 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
616 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
617 'dgit-distro.ubuntu.git-check' => 'false',
618 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
619 'dgit-distro.test-dummy.ssh' => "$td/ssh",
620 'dgit-distro.test-dummy.username' => "alice",
621 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
622 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
623 'dgit-distro.test-dummy.git-url' => "$td/git",
624 'dgit-distro.test-dummy.git-host' => "git",
625 'dgit-distro.test-dummy.git-path' => "$td/git",
626 'dgit-distro.test-dummy.archive-query' => "dummycatapi:",
627 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
628 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
629 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
633 our @gitcfgsources = qw(cmdline local global system);
635 sub git_slurp_config () {
636 local ($debuglevel) = $debuglevel-2;
639 # This algoritm is a bit subtle, but this is needed so that for
640 # options which we want to be single-valued, we allow the
641 # different config sources to override properly. See #835858.
642 foreach my $src (@gitcfgsources) {
643 next if $src eq 'cmdline';
644 # we do this ourselves since git doesn't handle it
646 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
649 open GITS, "-|", @cmd or die $!;
652 printdebug "=> ", (messagequote $_), "\n";
654 push @{ $gitcfgs{$src}{$`} }, $'; #';
658 or ($!==0 && $?==256)
663 sub git_get_config ($) {
665 foreach my $src (@gitcfgsources) {
666 my $l = $gitcfgs{$src}{$c};
667 printdebug"C $c ".(defined $l ?
668 join " ", map { messagequote "'$_'" } @$l :
672 @$l==1 or badcfg "multiple values for $c".
673 " (in $src git config)" if @$l > 1;
681 return undef if $c =~ /RETURN-UNDEF/;
682 my $v = git_get_config($c);
683 return $v if defined $v;
684 my $dv = $defcfg{$c};
686 printdebug "CD $c $dv\n" if $debuglevel >= 4;
690 badcfg "need value for one of: @_\n".
691 "$us: distro or suite appears not to be (properly) supported";
694 sub access_basedistro__noalias () {
695 if (defined $idistro) {
698 my $def = cfg("dgit-suite.$isuite.distro", 'RETURN-UNDEF');
699 return $def if defined $def;
700 foreach my $src (@gitcfgsources, 'internal') {
701 my $kl = $src eq 'internal' ? \%defcfg : $gitcfgs{$src};
703 foreach my $k (keys %$kl) {
704 next unless $k =~ m#^dgit-suite\.(.*)\.distro$#;
706 next unless match_glob $dpat, $isuite;
710 return cfg("dgit.default.distro");
714 sub access_basedistro () {
715 my $noalias = access_basedistro__noalias();
716 my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
717 return $canon // $noalias;
720 sub access_nomdistro () {
721 my $base = access_basedistro();
722 my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
723 $r =~ m/^$distro_re$/ or badcfg
724 "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
728 sub access_quirk () {
729 # returns (quirk name, distro to use instead or undef, quirk-specific info)
730 my $basedistro = access_basedistro();
731 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
733 if (defined $backports_quirk) {
734 my $re = $backports_quirk;
735 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
737 $re =~ s/\%/([-0-9a-z_]+)/
738 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
739 if ($isuite =~ m/^$re$/) {
740 return ('backports',"$basedistro-backports",$1);
743 return ('none',undef);
748 sub parse_cfg_bool ($$$) {
749 my ($what,$def,$v) = @_;
752 $v =~ m/^[ty1]/ ? 1 :
753 $v =~ m/^[fn0]/ ? 0 :
754 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
757 sub access_forpush_config () {
758 my $d = access_basedistro();
762 parse_cfg_bool('new-private-pushers', 0,
763 cfg("dgit-distro.$d.new-private-pushers",
766 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
769 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
770 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
771 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
772 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
775 sub access_forpush () {
776 $access_forpush //= access_forpush_config();
777 return $access_forpush;
781 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
782 badcfg "pushing but distro is configured readonly"
783 if access_forpush_config() eq '0';
785 $supplementary_message = <<'END' unless $we_are_responder;
786 Push failed, before we got started.
787 You can retry the push, after fixing the problem, if you like.
789 parseopts_late_defaults();
793 parseopts_late_defaults();
796 sub supplementary_message ($) {
798 if (!$we_are_responder) {
799 $supplementary_message = $msg;
801 } elsif ($protovsn >= 3) {
802 responder_send_command "supplementary-message ".length($msg)
804 print PO $msg or die $!;
808 sub access_distros () {
809 # Returns list of distros to try, in order
812 # 0. `instead of' distro name(s) we have been pointed to
813 # 1. the access_quirk distro, if any
814 # 2a. the user's specified distro, or failing that } basedistro
815 # 2b. the distro calculated from the suite }
816 my @l = access_basedistro();
818 my (undef,$quirkdistro) = access_quirk();
819 unshift @l, $quirkdistro;
820 unshift @l, $instead_distro;
821 @l = grep { defined } @l;
823 push @l, access_nomdistro();
825 if (access_forpush()) {
826 @l = map { ("$_/push", $_) } @l;
831 sub access_cfg_cfgs (@) {
834 # The nesting of these loops determines the search order. We put
835 # the key loop on the outside so that we search all the distros
836 # for each key, before going on to the next key. That means that
837 # if access_cfg is called with a more specific, and then a less
838 # specific, key, an earlier distro can override the less specific
839 # without necessarily overriding any more specific keys. (If the
840 # distro wants to override the more specific keys it can simply do
841 # so; whereas if we did the loop the other way around, it would be
842 # impossible to for an earlier distro to override a less specific
843 # key but not the more specific ones without restating the unknown
844 # values of the more specific keys.
847 # We have to deal with RETURN-UNDEF specially, so that we don't
848 # terminate the search prematurely.
850 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
853 foreach my $d (access_distros()) {
854 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
856 push @cfgs, map { "dgit.default.$_" } @realkeys;
863 my (@cfgs) = access_cfg_cfgs(@keys);
864 my $value = cfg(@cfgs);
868 sub access_cfg_bool ($$) {
869 my ($def, @keys) = @_;
870 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
873 sub string_to_ssh ($) {
875 if ($spec =~ m/\s/) {
876 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
882 sub access_cfg_ssh () {
883 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
884 if (!defined $gitssh) {
887 return string_to_ssh $gitssh;
891 sub access_runeinfo ($) {
893 return ": dgit ".access_basedistro()." $info ;";
896 sub access_someuserhost ($) {
898 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
899 defined($user) && length($user) or
900 $user = access_cfg("$some-user",'username');
901 my $host = access_cfg("$some-host");
902 return length($user) ? "$user\@$host" : $host;
905 sub access_gituserhost () {
906 return access_someuserhost('git');
909 sub access_giturl (;$) {
911 my $url = access_cfg('git-url','RETURN-UNDEF');
914 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
915 return undef unless defined $proto;
918 access_gituserhost().
919 access_cfg('git-path');
921 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
924 return "$url/$package$suffix";
927 sub parsecontrolfh ($$;$) {
928 my ($fh, $desc, $allowsigned) = @_;
929 our $dpkgcontrolhash_noissigned;
932 my %opts = ('name' => $desc);
933 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
934 $c = Dpkg::Control::Hash->new(%opts);
935 $c->parse($fh,$desc) or die "parsing of $desc failed";
936 last if $allowsigned;
937 last if $dpkgcontrolhash_noissigned;
938 my $issigned= $c->get_option('is_pgp_signed');
939 if (!defined $issigned) {
940 $dpkgcontrolhash_noissigned= 1;
941 seek $fh, 0,0 or die "seek $desc: $!";
942 } elsif ($issigned) {
943 fail "control file $desc is (already) PGP-signed. ".
944 " Note that dgit push needs to modify the .dsc and then".
945 " do the signature itself";
954 my ($file, $desc, $allowsigned) = @_;
955 my $fh = new IO::Handle;
956 open $fh, '<', $file or die "$file: $!";
957 my $c = parsecontrolfh($fh,$desc,$allowsigned);
958 $fh->error and die $!;
964 my ($dctrl,$field) = @_;
965 my $v = $dctrl->{$field};
966 return $v if defined $v;
967 fail "missing field $field in ".$dctrl->get_option('name');
971 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
972 my $p = new IO::Handle;
973 my @cmd = (qw(dpkg-parsechangelog), @_);
974 open $p, '-|', @cmd or die $!;
976 $?=0; $!=0; close $p or failedcmd @cmd;
980 sub commit_getclogp ($) {
981 # Returns the parsed changelog hashref for a particular commit
983 our %commit_getclogp_memo;
984 my $memo = $commit_getclogp_memo{$objid};
985 return $memo if $memo;
987 my $mclog = ".git/dgit/clog-$objid";
988 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
989 "$objid:debian/changelog";
990 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
995 defined $d or fail "getcwd failed: $!";
999 sub parse_dscdata () {
1000 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1001 printdebug Dumper($dscdata) if $debuglevel>1;
1002 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1003 printdebug Dumper($dsc) if $debuglevel>1;
1008 sub archive_query ($;@) {
1009 my ($method) = shift @_;
1010 fail "this operation does not support multiple comma-separated suites"
1012 my $query = access_cfg('archive-query','RETURN-UNDEF');
1013 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
1016 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
1019 sub archive_query_prepend_mirror {
1020 my $m = access_cfg('mirror');
1021 return map { [ $_->[0], $m.$_->[1], @$_[2..$#$_] ] } @_;
1024 sub pool_dsc_subpath ($$) {
1025 my ($vsn,$component) = @_; # $package is implict arg
1026 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
1027 return "/pool/$component/$prefix/$package/".dscfn($vsn);
1030 sub cfg_apply_map ($$$) {
1031 my ($varref, $what, $mapspec) = @_;
1032 return unless $mapspec;
1034 printdebug "config $what EVAL{ $mapspec; }\n";
1036 eval "package Dgit::Config; $mapspec;";
1041 #---------- `ftpmasterapi' archive query method (nascent) ----------
1043 sub archive_api_query_cmd ($) {
1045 my @cmd = (@curl, qw(-sS));
1046 my $url = access_cfg('archive-query-url');
1047 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
1049 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
1050 foreach my $key (split /\:/, $keys) {
1051 $key =~ s/\%HOST\%/$host/g;
1053 fail "for $url: stat $key: $!" unless $!==ENOENT;
1056 fail "config requested specific TLS key but do not know".
1057 " how to get curl to use exactly that EE key ($key)";
1058 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1059 # # Sadly the above line does not work because of changes
1060 # # to gnutls. The real fix for #790093 may involve
1061 # # new curl options.
1064 # Fixing #790093 properly will involve providing a value
1065 # for this on clients.
1066 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1067 push @cmd, split / /, $kargs if defined $kargs;
1069 push @cmd, $url.$subpath;
1073 sub api_query ($$;$) {
1075 my ($data, $subpath, $ok404) = @_;
1076 badcfg "ftpmasterapi archive query method takes no data part"
1078 my @cmd = archive_api_query_cmd($subpath);
1079 my $url = $cmd[$#cmd];
1080 push @cmd, qw(-w %{http_code});
1081 my $json = cmdoutput @cmd;
1082 unless ($json =~ s/\d+\d+\d$//) {
1083 failedcmd_report_cmd undef, @cmd;
1084 fail "curl failed to print 3-digit HTTP code";
1087 return undef if $code eq '404' && $ok404;
1088 fail "fetch of $url gave HTTP code $code"
1089 unless $url =~ m#^file://# or $code =~ m/^2/;
1090 return decode_json($json);
1093 sub canonicalise_suite_ftpmasterapi {
1094 my ($proto,$data) = @_;
1095 my $suites = api_query($data, 'suites');
1097 foreach my $entry (@$suites) {
1099 my $v = $entry->{$_};
1100 defined $v && $v eq $isuite;
1101 } qw(codename name);
1102 push @matched, $entry;
1104 fail "unknown suite $isuite" unless @matched;
1107 @matched==1 or die "multiple matches for suite $isuite\n";
1108 $cn = "$matched[0]{codename}";
1109 defined $cn or die "suite $isuite info has no codename\n";
1110 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1112 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1117 sub archive_query_ftpmasterapi {
1118 my ($proto,$data) = @_;
1119 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1121 my $digester = Digest::SHA->new(256);
1122 foreach my $entry (@$info) {
1124 my $vsn = "$entry->{version}";
1125 my ($ok,$msg) = version_check $vsn;
1126 die "bad version: $msg\n" unless $ok;
1127 my $component = "$entry->{component}";
1128 $component =~ m/^$component_re$/ or die "bad component";
1129 my $filename = "$entry->{filename}";
1130 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1131 or die "bad filename";
1132 my $sha256sum = "$entry->{sha256sum}";
1133 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1134 push @rows, [ $vsn, "/pool/$component/$filename",
1135 $digester, $sha256sum ];
1137 die "bad ftpmaster api response: $@\n".Dumper($entry)
1140 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1141 return archive_query_prepend_mirror @rows;
1144 sub file_in_archive_ftpmasterapi {
1145 my ($proto,$data,$filename) = @_;
1146 my $pat = $filename;
1149 $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1150 my $info = api_query($data, "file_in_archive/$pat", 1);
1153 #---------- `aptget' archive query method ----------
1156 our $aptget_releasefile;
1157 our $aptget_configpath;
1159 sub aptget_aptget () { return @aptget, qw(-c), $aptget_configpath; }
1160 sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
1162 sub aptget_cache_clean {
1163 runcmd_ordryrun_local qw(sh -ec),
1164 'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
1168 sub aptget_lock_acquire () {
1169 my $lockfile = "$aptget_base/lock";
1170 open APTGET_LOCK, '>', $lockfile or die "open $lockfile: $!";
1171 flock APTGET_LOCK, LOCK_EX or die "lock $lockfile: $!";
1174 sub aptget_prep ($) {
1176 return if defined $aptget_base;
1178 badcfg "aptget archive query method takes no data part"
1181 my $cache = $ENV{XDG_CACHE_DIR} // "$ENV{HOME}/.cache";
1184 ensuredir "$cache/dgit";
1186 access_cfg('aptget-cachekey','RETURN-UNDEF')
1187 // access_nomdistro();
1189 $aptget_base = "$cache/dgit/aptget";
1190 ensuredir $aptget_base;
1192 my $quoted_base = $aptget_base;
1193 die "$quoted_base contains bad chars, cannot continue"
1194 if $quoted_base =~ m/["\\]/; # apt.conf(5) says no escaping :-/
1196 ensuredir $aptget_base;
1198 aptget_lock_acquire();
1200 aptget_cache_clean();
1202 $aptget_configpath = "$aptget_base/apt.conf#$cachekey";
1203 my $sourceslist = "source.list#$cachekey";
1205 my $aptsuites = $isuite;
1206 cfg_apply_map(\$aptsuites, 'suite map',
1207 access_cfg('aptget-suite-map', 'RETURN-UNDEF'));
1209 open SRCS, ">", "$aptget_base/$sourceslist" or die $!;
1210 printf SRCS "deb-src %s %s %s\n",
1211 access_cfg('mirror'),
1213 access_cfg('aptget-components')
1216 ensuredir "$aptget_base/cache";
1217 ensuredir "$aptget_base/lists";
1219 open CONF, ">", $aptget_configpath or die $!;
1221 Debug::NoLocking "true";
1222 APT::Get::List-Cleanup "false";
1223 #clear APT::Update::Post-Invoke-Success;
1224 Dir::Etc::SourceList "$quoted_base/$sourceslist";
1225 Dir::State::Lists "$quoted_base/lists";
1226 Dir::Etc::preferences "$quoted_base/preferences";
1227 Dir::Cache::srcpkgcache "$quoted_base/cache/srcs#$cachekey";
1228 Dir::Cache::pkgcache "$quoted_base/cache/pkgs#$cachekey";
1231 foreach my $key (qw(
1234 Dir::Cache::Archives
1235 Dir::Etc::SourceParts
1236 Dir::Etc::preferencesparts
1238 ensuredir "$aptget_base/$key";
1239 print CONF "$key \"$quoted_base/$key\";\n" or die $!;
1242 my $oldatime = (time // die $!) - 1;
1243 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1244 next unless stat_exists $oldlist;
1245 my ($mtime) = (stat _)[9];
1246 utime $oldatime, $mtime, $oldlist or die "$oldlist $!";
1249 runcmd_ordryrun_local aptget_aptget(), qw(update);
1252 foreach my $oldlist (<$aptget_base/lists/*Release>) {
1253 next unless stat_exists $oldlist;
1254 my ($atime) = (stat _)[8];
1255 next if $atime == $oldatime;
1256 push @releasefiles, $oldlist;
1258 my @inreleasefiles = grep { m#/InRelease$# } @releasefiles;
1259 @releasefiles = @inreleasefiles if @inreleasefiles;
1260 die "apt updated wrong number of Release files (@releasefiles), erk"
1261 unless @releasefiles == 1;
1263 ($aptget_releasefile) = @releasefiles;
1266 sub canonicalise_suite_aptget {
1267 my ($proto,$data) = @_;
1270 my $release = parsecontrol $aptget_releasefile, "Release file", 1;
1272 foreach my $name (qw(Codename Suite)) {
1273 my $val = $release->{$name};
1275 printdebug "release file $name: $val\n";
1276 $val =~ m/^$suite_re$/o or fail
1277 "Release file ($aptget_releasefile) specifies intolerable $name";
1278 cfg_apply_map(\$val, 'suite rmap',
1279 access_cfg('aptget-suite-rmap', 'RETURN-UNDEF'));
1286 sub archive_query_aptget {
1287 my ($proto,$data) = @_;
1290 ensuredir "$aptget_base/source";
1291 foreach my $old (<$aptget_base/source/*.dsc>) {
1292 unlink $old or die "$old: $!";
1295 my $showsrc = cmdoutput aptget_aptcache(), qw(showsrc), $package;
1296 return () unless $showsrc =~ m/^package:\s*\Q$package\E\s*$/mi;
1297 # avoids apt-get source failing with ambiguous error code
1299 runcmd_ordryrun_local
1300 shell_cmd 'cd "$1"/source; shift', $aptget_base,
1301 aptget_aptget(), qw(--download-only --only-source source), $package;
1303 my @dscs = <$aptget_base/source/*.dsc>;
1304 fail "apt-get source did not produce a .dsc" unless @dscs;
1305 fail "apt-get source produced several .dscs (@dscs)" unless @dscs==1;
1307 my $pre_dsc = parsecontrol $dscs[0], $dscs[0], 1;
1310 my $uri = "file://". uri_escape $dscs[0];
1311 $uri =~ s{\%2f}{/}gi;
1312 return [ (getfield $pre_dsc, 'Version'), $uri ];
1315 #---------- `dummyapicat' archive query method ----------
1317 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1318 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1320 sub file_in_archive_dummycatapi ($$$) {
1321 my ($proto,$data,$filename) = @_;
1322 my $mirror = access_cfg('mirror');
1323 $mirror =~ s#^file://#/# or die "$mirror ?";
1325 my @cmd = (qw(sh -ec), '
1327 find -name "$2" -print0 |
1329 ', qw(x), $mirror, $filename);
1330 debugcmd "-|", @cmd;
1331 open FIA, "-|", @cmd or die $!;
1334 printdebug "| $_\n";
1335 m/^(\w+) (\S+)$/ or die "$_ ?";
1336 push @out, { sha256sum => $1, filename => $2 };
1338 close FIA or die failedcmd @cmd;
1342 #---------- `madison' archive query method ----------
1344 sub archive_query_madison {
1345 return archive_query_prepend_mirror
1346 map { [ @$_[0..1] ] } madison_get_parse(@_);
1349 sub madison_get_parse {
1350 my ($proto,$data) = @_;
1351 die unless $proto eq 'madison';
1352 if (!length $data) {
1353 $data= access_cfg('madison-distro','RETURN-UNDEF');
1354 $data //= access_basedistro();
1356 $rmad{$proto,$data,$package} ||= cmdoutput
1357 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1358 my $rmad = $rmad{$proto,$data,$package};
1361 foreach my $l (split /\n/, $rmad) {
1362 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1363 \s*( [^ \t|]+ )\s* \|
1364 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1365 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1366 $1 eq $package or die "$rmad $package ?";
1373 $component = access_cfg('archive-query-default-component');
1375 $5 eq 'source' or die "$rmad ?";
1376 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1378 return sort { -version_compare($a->[0],$b->[0]); } @out;
1381 sub canonicalise_suite_madison {
1382 # madison canonicalises for us
1383 my @r = madison_get_parse(@_);
1385 "unable to canonicalise suite using package $package".
1386 " which does not appear to exist in suite $isuite;".
1387 " --existing-package may help";
1391 sub file_in_archive_madison { return undef; }
1393 #---------- `sshpsql' archive query method ----------
1396 my ($data,$runeinfo,$sql) = @_;
1397 if (!length $data) {
1398 $data= access_someuserhost('sshpsql').':'.
1399 access_cfg('sshpsql-dbname');
1401 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1402 my ($userhost,$dbname) = ($`,$'); #';
1404 my @cmd = (access_cfg_ssh, $userhost,
1405 access_runeinfo("ssh-psql $runeinfo").
1406 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1407 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1409 open P, "-|", @cmd or die $!;
1412 printdebug(">|$_|\n");
1415 $!=0; $?=0; close P or failedcmd @cmd;
1417 my $nrows = pop @rows;
1418 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1419 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1420 @rows = map { [ split /\|/, $_ ] } @rows;
1421 my $ncols = scalar @{ shift @rows };
1422 die if grep { scalar @$_ != $ncols } @rows;
1426 sub sql_injection_check {
1427 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1430 sub archive_query_sshpsql ($$) {
1431 my ($proto,$data) = @_;
1432 sql_injection_check $isuite, $package;
1433 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1434 SELECT source.version, component.name, files.filename, files.sha256sum
1436 JOIN src_associations ON source.id = src_associations.source
1437 JOIN suite ON suite.id = src_associations.suite
1438 JOIN dsc_files ON dsc_files.source = source.id
1439 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1440 JOIN component ON component.id = files_archive_map.component_id
1441 JOIN files ON files.id = dsc_files.file
1442 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1443 AND source.source='$package'
1444 AND files.filename LIKE '%.dsc';
1446 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1447 my $digester = Digest::SHA->new(256);
1449 my ($vsn,$component,$filename,$sha256sum) = @$_;
1450 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1452 return archive_query_prepend_mirror @rows;
1455 sub canonicalise_suite_sshpsql ($$) {
1456 my ($proto,$data) = @_;
1457 sql_injection_check $isuite;
1458 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1459 SELECT suite.codename
1460 FROM suite where suite_name='$isuite' or codename='$isuite';
1462 @rows = map { $_->[0] } @rows;
1463 fail "unknown suite $isuite" unless @rows;
1464 die "ambiguous $isuite: @rows ?" if @rows>1;
1468 sub file_in_archive_sshpsql ($$$) { return undef; }
1470 #---------- `dummycat' archive query method ----------
1472 sub canonicalise_suite_dummycat ($$) {
1473 my ($proto,$data) = @_;
1474 my $dpath = "$data/suite.$isuite";
1475 if (!open C, "<", $dpath) {
1476 $!==ENOENT or die "$dpath: $!";
1477 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1481 chomp or die "$dpath: $!";
1483 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1487 sub archive_query_dummycat ($$) {
1488 my ($proto,$data) = @_;
1489 canonicalise_suite();
1490 my $dpath = "$data/package.$csuite.$package";
1491 if (!open C, "<", $dpath) {
1492 $!==ENOENT or die "$dpath: $!";
1493 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1501 printdebug "dummycat query $csuite $package $dpath | $_\n";
1502 my @row = split /\s+/, $_;
1503 @row==2 or die "$dpath: $_ ?";
1506 C->error and die "$dpath: $!";
1508 return archive_query_prepend_mirror
1509 sort { -version_compare($a->[0],$b->[0]); } @rows;
1512 sub file_in_archive_dummycat () { return undef; }
1514 #---------- tag format handling ----------
1516 sub access_cfg_tagformats () {
1517 split /\,/, access_cfg('dgit-tag-format');
1520 sub access_cfg_tagformats_can_splitbrain () {
1521 my %y = map { $_ => 1 } access_cfg_tagformats;
1522 foreach my $needtf (qw(new maint)) {
1523 next if $y{$needtf};
1529 sub need_tagformat ($$) {
1530 my ($fmt, $why) = @_;
1531 fail "need to use tag format $fmt ($why) but also need".
1532 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1533 " - no way to proceed"
1534 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1535 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1538 sub select_tagformat () {
1540 return if $tagformatfn && !$tagformat_want;
1541 die 'bug' if $tagformatfn && $tagformat_want;
1542 # ... $tagformat_want assigned after previous select_tagformat
1544 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1545 printdebug "select_tagformat supported @supported\n";
1547 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1548 printdebug "select_tagformat specified @$tagformat_want\n";
1550 my ($fmt,$why,$override) = @$tagformat_want;
1552 fail "target distro supports tag formats @supported".
1553 " but have to use $fmt ($why)"
1555 or grep { $_ eq $fmt } @supported;
1557 $tagformat_want = undef;
1559 $tagformatfn = ${*::}{"debiantag_$fmt"};
1561 fail "trying to use unknown tag format \`$fmt' ($why) !"
1562 unless $tagformatfn;
1565 #---------- archive query entrypoints and rest of program ----------
1567 sub canonicalise_suite () {
1568 return if defined $csuite;
1569 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1570 $csuite = archive_query('canonicalise_suite');
1571 if ($isuite ne $csuite) {
1572 progress "canonical suite name for $isuite is $csuite";
1574 progress "canonical suite name is $csuite";
1578 sub get_archive_dsc () {
1579 canonicalise_suite();
1580 my @vsns = archive_query('archive_query');
1581 foreach my $vinfo (@vsns) {
1582 my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1583 $dscurl = $vsn_dscurl;
1584 $dscdata = url_get($dscurl);
1586 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1591 $digester->add($dscdata);
1592 my $got = $digester->hexdigest();
1594 fail "$dscurl has hash $got but".
1595 " archive told us to expect $digest";
1598 my $fmt = getfield $dsc, 'Format';
1599 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1600 "unsupported source format $fmt, sorry";
1602 $dsc_checked = !!$digester;
1603 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1607 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1610 sub check_for_git ();
1611 sub check_for_git () {
1613 my $how = access_cfg('git-check');
1614 if ($how eq 'ssh-cmd') {
1616 (access_cfg_ssh, access_gituserhost(),
1617 access_runeinfo("git-check $package").
1618 " set -e; cd ".access_cfg('git-path').";".
1619 " if test -d $package.git; then echo 1; else echo 0; fi");
1620 my $r= cmdoutput @cmd;
1621 if (defined $r and $r =~ m/^divert (\w+)$/) {
1623 my ($usedistro,) = access_distros();
1624 # NB that if we are pushing, $usedistro will be $distro/push
1625 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1626 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1627 progress "diverting to $divert (using config for $instead_distro)";
1628 return check_for_git();
1630 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1632 } elsif ($how eq 'url') {
1633 my $prefix = access_cfg('git-check-url','git-url');
1634 my $suffix = access_cfg('git-check-suffix','git-suffix',
1635 'RETURN-UNDEF') // '.git';
1636 my $url = "$prefix/$package$suffix";
1637 my @cmd = (@curl, qw(-sS -I), $url);
1638 my $result = cmdoutput @cmd;
1639 $result =~ s/^\S+ 200 .*\n\r?\n//;
1640 # curl -sS -I with https_proxy prints
1641 # HTTP/1.0 200 Connection established
1642 $result =~ m/^\S+ (404|200) /s or
1643 fail "unexpected results from git check query - ".
1644 Dumper($prefix, $result);
1646 if ($code eq '404') {
1648 } elsif ($code eq '200') {
1653 } elsif ($how eq 'true') {
1655 } elsif ($how eq 'false') {
1658 badcfg "unknown git-check \`$how'";
1662 sub create_remote_git_repo () {
1663 my $how = access_cfg('git-create');
1664 if ($how eq 'ssh-cmd') {
1666 (access_cfg_ssh, access_gituserhost(),
1667 access_runeinfo("git-create $package").
1668 "set -e; cd ".access_cfg('git-path').";".
1669 " cp -a _template $package.git");
1670 } elsif ($how eq 'true') {
1673 badcfg "unknown git-create \`$how'";
1677 our ($dsc_hash,$lastpush_mergeinput);
1678 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1680 our $ud = '.git/dgit/unpack';
1690 sub mktree_in_ud_here () {
1691 runcmd qw(git init -q);
1692 runcmd qw(git config gc.auto 0);
1693 rmtree('.git/objects');
1694 symlink '../../../../objects','.git/objects' or die $!;
1697 sub git_write_tree () {
1698 my $tree = cmdoutput @git, qw(write-tree);
1699 $tree =~ m/^\w+$/ or die "$tree ?";
1703 sub git_add_write_tree () {
1704 runcmd @git, qw(add -Af .);
1705 return git_write_tree();
1708 sub remove_stray_gits ($) {
1710 my @gitscmd = qw(find -name .git -prune -print0);
1711 debugcmd "|",@gitscmd;
1712 open GITS, "-|", @gitscmd or die $!;
1717 print STDERR "$us: warning: removing from $what: ",
1718 (messagequote $_), "\n";
1722 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1725 sub mktree_in_ud_from_only_subdir ($;$) {
1726 my ($what,$raw) = @_;
1728 # changes into the subdir
1730 die "expected one subdir but found @dirs ?" unless @dirs==1;
1731 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1735 remove_stray_gits($what);
1736 mktree_in_ud_here();
1738 my ($format, $fopts) = get_source_format();
1739 if (madformat($format)) {
1744 my $tree=git_add_write_tree();
1745 return ($tree,$dir);
1748 our @files_csum_info_fields =
1749 (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1750 ['Checksums-Sha1', 'Digest::SHA', 'new(1)', 'sha1sum'],
1751 ['Files', 'Digest::MD5', 'new()', 'md5sum']);
1753 sub dsc_files_info () {
1754 foreach my $csumi (@files_csum_info_fields) {
1755 my ($fname, $module, $method) = @$csumi;
1756 my $field = $dsc->{$fname};
1757 next unless defined $field;
1758 eval "use $module; 1;" or die $@;
1760 foreach (split /\n/, $field) {
1762 m/^(\w+) (\d+) (\S+)$/ or
1763 fail "could not parse .dsc $fname line \`$_'";
1764 my $digester = eval "$module"."->$method;" or die $@;
1769 Digester => $digester,
1774 fail "missing any supported Checksums-* or Files field in ".
1775 $dsc->get_option('name');
1779 map { $_->{Filename} } dsc_files_info();
1782 sub files_compare_inputs (@) {
1787 my $showinputs = sub {
1788 return join "; ", map { $_->get_option('name') } @$inputs;
1791 foreach my $in (@$inputs) {
1793 my $in_name = $in->get_option('name');
1795 printdebug "files_compare_inputs $in_name\n";
1797 foreach my $csumi (@files_csum_info_fields) {
1798 my ($fname) = @$csumi;
1799 printdebug "files_compare_inputs $in_name $fname\n";
1801 my $field = $in->{$fname};
1802 next unless defined $field;
1805 foreach (split /\n/, $field) {
1808 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1809 fail "could not parse $in_name $fname line \`$_'";
1811 printdebug "files_compare_inputs $in_name $fname $f\n";
1815 my $re = \ $record{$f}{$fname};
1817 $fchecked{$f}{$in_name} = 1;
1819 fail "hash or size of $f varies in $fname fields".
1820 " (between: ".$showinputs->().")";
1825 @files = sort @files;
1826 $expected_files //= \@files;
1827 "@$expected_files" eq "@files" or
1828 fail "file list in $in_name varies between hash fields!";
1831 fail "$in_name has no files list field(s)";
1833 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1836 grep { keys %$_ == @$inputs-1 } values %fchecked
1837 or fail "no file appears in all file lists".
1838 " (looked in: ".$showinputs->().")";
1841 sub is_orig_file_in_dsc ($$) {
1842 my ($f, $dsc_files_info) = @_;
1843 return 0 if @$dsc_files_info <= 1;
1844 # One file means no origs, and the filename doesn't have a "what
1845 # part of dsc" component. (Consider versions ending `.orig'.)
1846 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1850 sub is_orig_file_of_vsn ($$) {
1851 my ($f, $upstreamvsn) = @_;
1852 my $base = srcfn $upstreamvsn, '';
1853 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1857 sub changes_update_origs_from_dsc ($$$$) {
1858 my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1860 printdebug "checking origs needed ($upstreamvsn)...\n";
1861 $_ = getfield $changes, 'Files';
1862 m/^\w+ \d+ (\S+ \S+) \S+$/m or
1863 fail "cannot find section/priority from .changes Files field";
1864 my $placementinfo = $1;
1866 printdebug "checking origs needed placement '$placementinfo'...\n";
1867 foreach my $l (split /\n/, getfield $dsc, 'Files') {
1868 $l =~ m/\S+$/ or next;
1870 printdebug "origs $file | $l\n";
1871 next unless is_orig_file_of_vsn $file, $upstreamvsn;
1872 printdebug "origs $file is_orig\n";
1873 my $have = archive_query('file_in_archive', $file);
1874 if (!defined $have) {
1876 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1882 printdebug "origs $file \$#\$have=$#$have\n";
1883 foreach my $h (@$have) {
1886 foreach my $csumi (@files_csum_info_fields) {
1887 my ($fname, $module, $method, $archivefield) = @$csumi;
1888 next unless defined $h->{$archivefield};
1889 $_ = $dsc->{$fname};
1890 next unless defined;
1891 m/^(\w+) .* \Q$file\E$/m or
1892 fail ".dsc $fname missing entry for $file";
1893 if ($h->{$archivefield} eq $1) {
1897 "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1900 die "$file ".Dumper($h)." ?!" if $same && @differ;
1903 push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1906 printdebug "origs $file f.same=$found_same".
1907 " #f._differ=$#found_differ\n";
1908 if (@found_differ && !$found_same) {
1910 "archive contains $file with different checksum",
1913 # Now we edit the changes file to add or remove it
1914 foreach my $csumi (@files_csum_info_fields) {
1915 my ($fname, $module, $method, $archivefield) = @$csumi;
1916 next unless defined $changes->{$fname};
1918 # in archive, delete from .changes if it's there
1919 $changed{$file} = "removed" if
1920 $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1921 } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1922 # not in archive, but it's here in the .changes
1924 my $dsc_data = getfield $dsc, $fname;
1925 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1927 $extra =~ s/ \d+ /$&$placementinfo /
1928 or die "$fname $extra >$dsc_data< ?"
1929 if $fname eq 'Files';
1930 $changes->{$fname} .= "\n". $extra;
1931 $changed{$file} = "added";
1936 foreach my $file (keys %changed) {
1938 "edited .changes for archive .orig contents: %s %s",
1939 $changed{$file}, $file;
1941 my $chtmp = "$changesfile.tmp";
1942 $changes->save($chtmp);
1944 rename $chtmp,$changesfile or die "$changesfile $!";
1946 progress "[new .changes left in $changesfile]";
1949 progress "$changesfile already has appropriate .orig(s) (if any)";
1953 sub make_commit ($) {
1955 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1958 sub make_commit_text ($) {
1961 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1963 print Dumper($text) if $debuglevel > 1;
1964 my $child = open2($out, $in, @cmd) or die $!;
1967 print $in $text or die $!;
1968 close $in or die $!;
1970 $h =~ m/^\w+$/ or die;
1972 printdebug "=> $h\n";
1975 waitpid $child, 0 == $child or die "$child $!";
1976 $? and failedcmd @cmd;
1980 sub clogp_authline ($) {
1982 my $author = getfield $clogp, 'Maintainer';
1983 $author =~ s#,.*##ms;
1984 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1985 my $authline = "$author $date";
1986 $authline =~ m/$git_authline_re/o or
1987 fail "unexpected commit author line format \`$authline'".
1988 " (was generated from changelog Maintainer field)";
1989 return ($1,$2,$3) if wantarray;
1993 sub vendor_patches_distro ($$) {
1994 my ($checkdistro, $what) = @_;
1995 return unless defined $checkdistro;
1997 my $series = "debian/patches/\L$checkdistro\E.series";
1998 printdebug "checking for vendor-specific $series ($what)\n";
2000 if (!open SERIES, "<", $series) {
2001 die "$series $!" unless $!==ENOENT;
2010 Unfortunately, this source package uses a feature of dpkg-source where
2011 the same source package unpacks to different source code on different
2012 distros. dgit cannot safely operate on such packages on affected
2013 distros, because the meaning of source packages is not stable.
2015 Please ask the distro/maintainer to remove the distro-specific series
2016 files and use a different technique (if necessary, uploading actually
2017 different packages, if different distros are supposed to have
2021 fail "Found active distro-specific series file for".
2022 " $checkdistro ($what): $series, cannot continue";
2024 die "$series $!" if SERIES->error;
2028 sub check_for_vendor_patches () {
2029 # This dpkg-source feature doesn't seem to be documented anywhere!
2030 # But it can be found in the changelog (reformatted):
2032 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
2033 # Author: Raphael Hertzog <hertzog@debian.org>
2034 # Date: Sun Oct 3 09:36:48 2010 +0200
2036 # dpkg-source: correctly create .pc/.quilt_series with alternate
2039 # If you have debian/patches/ubuntu.series and you were
2040 # unpacking the source package on ubuntu, quilt was still
2041 # directed to debian/patches/series instead of
2042 # debian/patches/ubuntu.series.
2044 # debian/changelog | 3 +++
2045 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
2046 # 2 files changed, 6 insertions(+), 1 deletion(-)
2049 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2050 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2051 "Dpkg::Vendor \`current vendor'");
2052 vendor_patches_distro(access_basedistro(),
2053 "(base) distro being accessed");
2054 vendor_patches_distro(access_nomdistro(),
2055 "(nominal) distro being accessed");
2058 sub generate_commits_from_dsc () {
2059 # See big comment in fetch_from_archive, below.
2060 # See also README.dsc-import.
2064 my @dfi = dsc_files_info();
2065 foreach my $fi (@dfi) {
2066 my $f = $fi->{Filename};
2067 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2069 printdebug "considering linking $f: ";
2071 link_ltarget "../../../../$f", $f
2072 or ((printdebug "($!) "), 0)
2076 printdebug "linked.\n";
2078 complete_file_from_dsc('.', $fi)
2081 if (is_orig_file_in_dsc($f, \@dfi)) {
2082 link $f, "../../../../$f"
2088 # We unpack and record the orig tarballs first, so that we only
2089 # need disk space for one private copy of the unpacked source.
2090 # But we can't make them into commits until we have the metadata
2091 # from the debian/changelog, so we record the tree objects now and
2092 # make them into commits later.
2094 my $upstreamv = upstreamversion $dsc->{version};
2095 my $orig_f_base = srcfn $upstreamv, '';
2097 foreach my $fi (@dfi) {
2098 # We actually import, and record as a commit, every tarball
2099 # (unless there is only one file, in which case there seems
2102 my $f = $fi->{Filename};
2103 printdebug "import considering $f ";
2104 (printdebug "only one dfi\n"), next if @dfi == 1;
2105 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2106 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2110 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2112 printdebug "Y ", (join ' ', map { $_//"(none)" }
2113 $compr_ext, $orig_f_part
2116 my $input = new IO::File $f, '<' or die "$f $!";
2120 if (defined $compr_ext) {
2122 Dpkg::Compression::compression_guess_from_filename $f;
2123 fail "Dpkg::Compression cannot handle file $f in source package"
2124 if defined $compr_ext && !defined $cname;
2126 new Dpkg::Compression::Process compression => $cname;
2127 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2128 my $compr_fh = new IO::Handle;
2129 my $compr_pid = open $compr_fh, "-|" // die $!;
2131 open STDIN, "<&", $input or die $!;
2133 die "dgit (child): exec $compr_cmd[0]: $!\n";
2138 rmtree "_unpack-tar";
2139 mkdir "_unpack-tar" or die $!;
2140 my @tarcmd = qw(tar -x -f -
2141 --no-same-owner --no-same-permissions
2142 --no-acls --no-xattrs --no-selinux);
2143 my $tar_pid = fork // die $!;
2145 chdir "_unpack-tar" or die $!;
2146 open STDIN, "<&", $input or die $!;
2148 die "dgit (child): exec $tarcmd[0]: $!";
2150 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2151 !$? or failedcmd @tarcmd;
2154 (@compr_cmd ? failedcmd @compr_cmd
2156 # finally, we have the results in "tarball", but maybe
2157 # with the wrong permissions
2159 runcmd qw(chmod -R +rwX _unpack-tar);
2160 changedir "_unpack-tar";
2161 remove_stray_gits($f);
2162 mktree_in_ud_here();
2164 my ($tree) = git_add_write_tree();
2165 my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2166 if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2168 printdebug "one subtree $1\n";
2170 printdebug "multiple subtrees\n";
2173 rmtree "_unpack-tar";
2175 my $ent = [ $f, $tree ];
2177 Orig => !!$orig_f_part,
2178 Sort => (!$orig_f_part ? 2 :
2179 $orig_f_part =~ m/-/g ? 1 :
2187 # put any without "_" first (spec is not clear whether files
2188 # are always in the usual order). Tarballs without "_" are
2189 # the main orig or the debian tarball.
2190 $a->{Sort} <=> $b->{Sort} or
2194 my $any_orig = grep { $_->{Orig} } @tartrees;
2196 my $dscfn = "$package.dsc";
2198 my $treeimporthow = 'package';
2200 open D, ">", $dscfn or die "$dscfn: $!";
2201 print D $dscdata or die "$dscfn: $!";
2202 close D or die "$dscfn: $!";
2203 my @cmd = qw(dpkg-source);
2204 push @cmd, '--no-check' if $dsc_checked;
2205 if (madformat $dsc->{format}) {
2206 push @cmd, '--skip-patches';
2207 $treeimporthow = 'unpatched';
2209 push @cmd, qw(-x --), $dscfn;
2212 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2213 if (madformat $dsc->{format}) {
2214 check_for_vendor_patches();
2218 if (madformat $dsc->{format}) {
2219 my @pcmd = qw(dpkg-source --before-build .);
2220 runcmd shell_cmd 'exec >/dev/null', @pcmd;
2222 $dappliedtree = git_add_write_tree();
2225 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2226 debugcmd "|",@clogcmd;
2227 open CLOGS, "-|", @clogcmd or die $!;
2232 printdebug "import clog search...\n";
2235 my $stanzatext = do { local $/=""; <CLOGS>; };
2236 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2237 last if !defined $stanzatext;
2239 my $desc = "package changelog, entry no.$.";
2240 open my $stanzafh, "<", \$stanzatext or die;
2241 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2242 $clogp //= $thisstanza;
2244 printdebug "import clog $thisstanza->{version} $desc...\n";
2246 last if !$any_orig; # we don't need $r1clogp
2248 # We look for the first (most recent) changelog entry whose
2249 # version number is lower than the upstream version of this
2250 # package. Then the last (least recent) previous changelog
2251 # entry is treated as the one which introduced this upstream
2252 # version and used for the synthetic commits for the upstream
2255 # One might think that a more sophisticated algorithm would be
2256 # necessary. But: we do not want to scan the whole changelog
2257 # file. Stopping when we see an earlier version, which
2258 # necessarily then is an earlier upstream version, is the only
2259 # realistic way to do that. Then, either the earliest
2260 # changelog entry we have seen so far is indeed the earliest
2261 # upload of this upstream version; or there are only changelog
2262 # entries relating to later upstream versions (which is not
2263 # possible unless the changelog and .dsc disagree about the
2264 # version). Then it remains to choose between the physically
2265 # last entry in the file, and the one with the lowest version
2266 # number. If these are not the same, we guess that the
2267 # versions were created in a non-monotic order rather than
2268 # that the changelog entries have been misordered.
2270 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2272 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2273 $r1clogp = $thisstanza;
2275 printdebug "import clog $r1clogp->{version} becomes r1\n";
2277 die $! if CLOGS->error;
2278 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2280 $clogp or fail "package changelog has no entries!";
2282 my $authline = clogp_authline $clogp;
2283 my $changes = getfield $clogp, 'Changes';
2284 my $cversion = getfield $clogp, 'Version';
2287 $r1clogp //= $clogp; # maybe there's only one entry;
2288 my $r1authline = clogp_authline $r1clogp;
2289 # Strictly, r1authline might now be wrong if it's going to be
2290 # unused because !$any_orig. Whatever.
2292 printdebug "import tartrees authline $authline\n";
2293 printdebug "import tartrees r1authline $r1authline\n";
2295 foreach my $tt (@tartrees) {
2296 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2298 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2301 committer $r1authline
2305 [dgit import orig $tt->{F}]
2313 [dgit import tarball $package $cversion $tt->{F}]
2318 printdebug "import main commit\n";
2320 open C, ">../commit.tmp" or die $!;
2321 print C <<END or die $!;
2324 print C <<END or die $! foreach @tartrees;
2327 print C <<END or die $!;
2333 [dgit import $treeimporthow $package $cversion]
2337 my $rawimport_hash = make_commit qw(../commit.tmp);
2339 if (madformat $dsc->{format}) {
2340 printdebug "import apply patches...\n";
2342 # regularise the state of the working tree so that
2343 # the checkout of $rawimport_hash works nicely.
2344 my $dappliedcommit = make_commit_text(<<END);
2351 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2353 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2355 # We need the answers to be reproducible
2356 my @authline = clogp_authline($clogp);
2357 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
2358 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2359 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
2360 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
2361 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2362 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
2364 my $path = $ENV{PATH} or die;
2366 foreach my $use_absurd (qw(0 1)) {
2367 runcmd @git, qw(checkout -q unpa);
2368 runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2369 local $ENV{PATH} = $path;
2372 progress "warning: $@";
2373 $path = "$absurdity:$path";
2374 progress "$us: trying slow absurd-git-apply...";
2375 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2380 die "forbid absurd git-apply\n" if $use_absurd
2381 && forceing [qw(import-gitapply-no-absurd)];
2382 die "only absurd git-apply!\n" if !$use_absurd
2383 && forceing [qw(import-gitapply-absurd)];
2385 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2386 local $ENV{PATH} = $path if $use_absurd;
2388 my @showcmd = (gbp_pq, qw(import));
2389 my @realcmd = shell_cmd
2390 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2391 debugcmd "+",@realcmd;
2392 if (system @realcmd) {
2393 die +(shellquote @showcmd).
2395 failedcmd_waitstatus()."\n";
2398 my $gapplied = git_rev_parse('HEAD');
2399 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2400 $gappliedtree eq $dappliedtree or
2402 gbp-pq import and dpkg-source disagree!
2403 gbp-pq import gave commit $gapplied
2404 gbp-pq import gave tree $gappliedtree
2405 dpkg-source --before-build gave tree $dappliedtree
2407 $rawimport_hash = $gapplied;
2412 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2417 progress "synthesised git commit from .dsc $cversion";
2419 my $rawimport_mergeinput = {
2420 Commit => $rawimport_hash,
2421 Info => "Import of source package",
2423 my @output = ($rawimport_mergeinput);
2425 if ($lastpush_mergeinput) {
2426 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2427 my $oversion = getfield $oldclogp, 'Version';
2429 version_compare($oversion, $cversion);
2431 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2432 { Message => <<END, ReverseParents => 1 });
2433 Record $package ($cversion) in archive suite $csuite
2435 } elsif ($vcmp > 0) {
2436 print STDERR <<END or die $!;
2438 Version actually in archive: $cversion (older)
2439 Last version pushed with dgit: $oversion (newer or same)
2442 @output = $lastpush_mergeinput;
2444 # Same version. Use what's in the server git branch,
2445 # discarding our own import. (This could happen if the
2446 # server automatically imports all packages into git.)
2447 @output = $lastpush_mergeinput;
2450 changedir '../../../..';
2455 sub complete_file_from_dsc ($$) {
2456 our ($dstdir, $fi) = @_;
2457 # Ensures that we have, in $dir, the file $fi, with the correct
2458 # contents. (Downloading it from alongside $dscurl if necessary.)
2460 my $f = $fi->{Filename};
2461 my $tf = "$dstdir/$f";
2464 if (stat_exists $tf) {
2465 progress "using existing $f";
2467 printdebug "$tf does not exist, need to fetch\n";
2469 $furl =~ s{/[^/]+$}{};
2471 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2472 die "$f ?" if $f =~ m#/#;
2473 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2474 return 0 if !act_local();
2478 open F, "<", "$tf" or die "$tf: $!";
2479 $fi->{Digester}->reset();
2480 $fi->{Digester}->addfile(*F);
2481 F->error and die $!;
2482 my $got = $fi->{Digester}->hexdigest();
2483 $got eq $fi->{Hash} or
2484 fail "file $f has hash $got but .dsc".
2485 " demands hash $fi->{Hash} ".
2486 ($downloaded ? "(got wrong file from archive!)"
2487 : "(perhaps you should delete this file?)");
2492 sub ensure_we_have_orig () {
2493 my @dfi = dsc_files_info();
2494 foreach my $fi (@dfi) {
2495 my $f = $fi->{Filename};
2496 next unless is_orig_file_in_dsc($f, \@dfi);
2497 complete_file_from_dsc('..', $fi)
2502 #---------- git fetch ----------
2504 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2505 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2507 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
2508 # locally fetched refs because they have unhelpful names and clutter
2509 # up gitk etc. So we track whether we have "used up" head ref (ie,
2510 # whether we have made another local ref which refers to this object).
2512 # (If we deleted them unconditionally, then we might end up
2513 # re-fetching the same git objects each time dgit fetch was run.)
2515 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
2516 # in git_fetch_us to fetch the refs in question, and possibly a call
2517 # to lrfetchref_used.
2519 our (%lrfetchrefs_f, %lrfetchrefs_d);
2520 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2522 sub lrfetchref_used ($) {
2523 my ($fullrefname) = @_;
2524 my $objid = $lrfetchrefs_f{$fullrefname};
2525 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2528 sub git_lrfetch_sane {
2529 my ($supplementary, @specs) = @_;
2530 # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2531 # at least as regards @specs. Also leave the results in
2532 # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2533 # able to clean these up.
2535 # With $supplementary==1, @specs must not contain wildcards
2536 # and we add to our previous fetches (non-atomically).
2538 # This is rather miserable:
2539 # When git fetch --prune is passed a fetchspec ending with a *,
2540 # it does a plausible thing. If there is no * then:
2541 # - it matches subpaths too, even if the supplied refspec
2542 # starts refs, and behaves completely madly if the source
2543 # has refs/refs/something. (See, for example, Debian #NNNN.)
2544 # - if there is no matching remote ref, it bombs out the whole
2546 # We want to fetch a fixed ref, and we don't know in advance
2547 # if it exists, so this is not suitable.
2549 # Our workaround is to use git ls-remote. git ls-remote has its
2550 # own qairks. Notably, it has the absurd multi-tail-matching
2551 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2552 # refs/refs/foo etc.
2554 # Also, we want an idempotent snapshot, but we have to make two
2555 # calls to the remote: one to git ls-remote and to git fetch. The
2556 # solution is use git ls-remote to obtain a target state, and
2557 # git fetch to try to generate it. If we don't manage to generate
2558 # the target state, we try again.
2560 my $url = access_giturl();
2562 printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2564 my $specre = join '|', map {
2567 my $wildcard = $x =~ s/\\\*$/.*/;
2568 die if $wildcard && $supplementary;
2571 printdebug "git_lrfetch_sane specre=$specre\n";
2572 my $wanted_rref = sub {
2574 return m/^(?:$specre)$/;
2577 my $fetch_iteration = 0;
2580 printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2581 if (++$fetch_iteration > 10) {
2582 fail "too many iterations trying to get sane fetch!";
2585 my @look = map { "refs/$_" } @specs;
2586 my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2590 open GITLS, "-|", @lcmd or die $!;
2592 printdebug "=> ", $_;
2593 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2594 my ($objid,$rrefname) = ($1,$2);
2595 if (!$wanted_rref->($rrefname)) {
2597 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2601 $wantr{$rrefname} = $objid;
2604 close GITLS or failedcmd @lcmd;
2606 # OK, now %want is exactly what we want for refs in @specs
2608 !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2609 "+refs/$_:".lrfetchrefs."/$_";
2612 printdebug "git_lrfetch_sane fspecs @fspecs\n";
2614 my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2615 runcmd_ordryrun_local @fcmd if @fspecs;
2617 if (!$supplementary) {
2618 %lrfetchrefs_f = ();
2622 git_for_each_ref(lrfetchrefs, sub {
2623 my ($objid,$objtype,$lrefname,$reftail) = @_;
2624 $lrfetchrefs_f{$lrefname} = $objid;
2625 $objgot{$objid} = 1;
2628 if ($supplementary) {
2632 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2633 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2634 if (!exists $wantr{$rrefname}) {
2635 if ($wanted_rref->($rrefname)) {
2637 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2641 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2644 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2645 delete $lrfetchrefs_f{$lrefname};
2649 foreach my $rrefname (sort keys %wantr) {
2650 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2651 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2652 my $want = $wantr{$rrefname};
2653 next if $got eq $want;
2654 if (!defined $objgot{$want}) {
2656 warning: git ls-remote suggests we want $lrefname
2657 warning: and it should refer to $want
2658 warning: but git fetch didn't fetch that object to any relevant ref.
2659 warning: This may be due to a race with someone updating the server.
2660 warning: Will try again...
2662 next FETCH_ITERATION;
2665 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2667 runcmd_ordryrun_local @git, qw(update-ref -m),
2668 "dgit fetch git fetch fixup", $lrefname, $want;
2669 $lrfetchrefs_f{$lrefname} = $want;
2673 printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2674 Dumper(\%lrfetchrefs_f);
2677 sub git_fetch_us () {
2678 # Want to fetch only what we are going to use, unless
2679 # deliberately-not-ff, in which case we must fetch everything.
2681 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2683 (quiltmode_splitbrain
2684 ? (map { $_->('*',access_nomdistro) }
2685 \&debiantag_new, \&debiantag_maintview)
2686 : debiantags('*',access_nomdistro));
2687 push @specs, server_branch($csuite);
2688 push @specs, $rewritemap;
2689 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2691 git_lrfetch_sane 0, @specs;
2694 my @tagpats = debiantags('*',access_nomdistro);
2696 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2697 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2698 printdebug "currently $fullrefname=$objid\n";
2699 $here{$fullrefname} = $objid;
2701 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2702 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2703 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2704 printdebug "offered $lref=$objid\n";
2705 if (!defined $here{$lref}) {
2706 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2707 runcmd_ordryrun_local @upd;
2708 lrfetchref_used $fullrefname;
2709 } elsif ($here{$lref} eq $objid) {
2710 lrfetchref_used $fullrefname;
2713 "Not updateting $lref from $here{$lref} to $objid.\n";
2718 #---------- dsc and archive handling ----------
2720 sub mergeinfo_getclogp ($) {
2721 # Ensures thit $mi->{Clogp} exists and returns it
2723 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2726 sub mergeinfo_version ($) {
2727 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2730 sub fetch_from_archive_record_1 ($) {
2732 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2733 'DGIT_ARCHIVE', $hash;
2734 cmdoutput @git, qw(log -n2), $hash;
2735 # ... gives git a chance to complain if our commit is malformed
2738 sub fetch_from_archive_record_2 ($) {
2740 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2744 dryrun_report @upd_cmd;
2748 sub parse_dsc_field ($$) {
2749 my ($dsc, $what) = @_;
2751 foreach my $field (@ourdscfield) {
2752 $f = $dsc->{$field};
2756 progress "$what: NO git hash";
2757 } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2758 = $f =~ m/^(\w+) ($distro_re) ($versiontag_re) (\S+)(?:\s|$)/) {
2759 progress "$what: specified git info ($dsc_distro)";
2760 $dsc_hint_tag = [ $dsc_hint_tag ];
2761 } elsif ($f =~ m/^\w+\s*$/) {
2763 $dsc_distro //= 'debian';
2764 $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2766 progress "$what: specified git hash";
2768 fail "$what: invalid Dgit info";
2772 sub resolve_dsc_field_commit ($$) {
2773 my ($already_distro, $already_mapref) = @_;
2775 return unless defined $dsc_hash;
2778 defined $already_mapref &&
2779 ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2780 ? $already_mapref : undef;
2784 my ($what, @fetch) = @_;
2786 local $idistro = $dsc_distro;
2787 my $lrf = lrfetchrefs;
2789 if (!$chase_dsc_distro) {
2791 "not chasing .dsc distro $dsc_distro: not fetching $what";
2796 ".dsc names distro $dsc_distro: fetching $what";
2798 my $url = access_giturl();
2799 if (!defined $url) {
2800 defined $dsc_hint_url or fail <<END;
2801 .dsc Dgit metadata is in context of distro $dsc_distro
2802 for which we have no configured url and .dsc provides no hint
2805 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2806 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2807 parse_cfg_bool "dsc-url-proto-ok", 'false',
2808 cfg("dgit.dsc-url-proto-ok.$proto",
2809 "dgit.default.dsc-url-proto-ok")
2811 .dsc Dgit metadata is in context of distro $dsc_distro
2812 for which we have no configured url;
2813 .dsc provices hinted url with protocol $proto which is unsafe.
2814 (can be overridden by config - consult documentation)
2816 $url = $dsc_hint_url;
2819 git_lrfetch_sane 1, @fetch;
2824 if (parse_cfg_bool 'rewrite-map-enable', 'true',
2825 access_cfg('rewrite-map-enable', 'RETURN-UNDEF')) {
2826 my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2827 $mapref = $lrf.'/'.$rewritemap;
2828 my $rewritemapdata = git_cat_file $mapref.':map';
2829 if (defined $rewritemapdata
2830 && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2832 "server's git history rewrite map contains a relevant entry!";
2835 if (defined $dsc_hash) {
2836 progress "using rewritten git hash in place of .dsc value";
2838 progress "server data says .dsc hash is to be disregarded";
2843 if (!defined git_cat_file $dsc_hash) {
2844 my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2845 my $lrf = $do_fetch->("additional commits", @tags) &&
2846 defined git_cat_file $dsc_hash
2848 .dsc Dgit metadata requires commit $dsc_hash
2849 but we could not obtain that object anywhere.
2851 foreach my $t (@tags) {
2852 my $fullrefname = $lrf.'/'.$t;
2853 print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2854 next unless $lrfetchrefs_f{$fullrefname};
2855 next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2856 lrfetchref_used $fullrefname;
2861 sub fetch_from_archive () {
2862 ensure_setup_existing_tree();
2864 # Ensures that lrref() is what is actually in the archive, one way
2865 # or another, according to us - ie this client's
2866 # appropritaely-updated archive view. Also returns the commit id.
2867 # If there is nothing in the archive, leaves lrref alone and
2868 # returns undef. git_fetch_us must have already been called.
2872 parse_dsc_field($dsc, 'last upload to archive');
2873 resolve_dsc_field_commit access_basedistro,
2874 lrfetchrefs."/".$rewritemap
2876 progress "no version available from the archive";
2879 # If the archive's .dsc has a Dgit field, there are three
2880 # relevant git commitids we need to choose between and/or merge
2882 # 1. $dsc_hash: the Dgit field from the archive
2883 # 2. $lastpush_hash: the suite branch on the dgit git server
2884 # 3. $lastfetch_hash: our local tracking brach for the suite
2886 # These may all be distinct and need not be in any fast forward
2889 # If the dsc was pushed to this suite, then the server suite
2890 # branch will have been updated; but it might have been pushed to
2891 # a different suite and copied by the archive. Conversely a more
2892 # recent version may have been pushed with dgit but not appeared
2893 # in the archive (yet).
2895 # $lastfetch_hash may be awkward because archive imports
2896 # (particularly, imports of Dgit-less .dscs) are performed only as
2897 # needed on individual clients, so different clients may perform a
2898 # different subset of them - and these imports are only made
2899 # public during push. So $lastfetch_hash may represent a set of
2900 # imports different to a subsequent upload by a different dgit
2903 # Our approach is as follows:
2905 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2906 # descendant of $dsc_hash, then it was pushed by a dgit user who
2907 # had based their work on $dsc_hash, so we should prefer it.
2908 # Otherwise, $dsc_hash was installed into this suite in the
2909 # archive other than by a dgit push, and (necessarily) after the
2910 # last dgit push into that suite (since a dgit push would have
2911 # been descended from the dgit server git branch); thus, in that
2912 # case, we prefer the archive's version (and produce a
2913 # pseudo-merge to overwrite the dgit server git branch).
2915 # (If there is no Dgit field in the archive's .dsc then
2916 # generate_commit_from_dsc uses the version numbers to decide
2917 # whether the suite branch or the archive is newer. If the suite
2918 # branch is newer it ignores the archive's .dsc; otherwise it
2919 # generates an import of the .dsc, and produces a pseudo-merge to
2920 # overwrite the suite branch with the archive contents.)
2922 # The outcome of that part of the algorithm is the `public view',
2923 # and is same for all dgit clients: it does not depend on any
2924 # unpublished history in the local tracking branch.
2926 # As between the public view and the local tracking branch: The
2927 # local tracking branch is only updated by dgit fetch, and
2928 # whenever dgit fetch runs it includes the public view in the
2929 # local tracking branch. Therefore if the public view is not
2930 # descended from the local tracking branch, the local tracking
2931 # branch must contain history which was imported from the archive
2932 # but never pushed; and, its tip is now out of date. So, we make
2933 # a pseudo-merge to overwrite the old imports and stitch the old
2936 # Finally: we do not necessarily reify the public view (as
2937 # described above). This is so that we do not end up stacking two
2938 # pseudo-merges. So what we actually do is figure out the inputs
2939 # to any public view pseudo-merge and put them in @mergeinputs.
2942 # $mergeinputs[]{Commit}
2943 # $mergeinputs[]{Info}
2944 # $mergeinputs[0] is the one whose tree we use
2945 # @mergeinputs is in the order we use in the actual commit)
2948 # $mergeinputs[]{Message} is a commit message to use
2949 # $mergeinputs[]{ReverseParents} if def specifies that parent
2950 # list should be in opposite order
2951 # Such an entry has no Commit or Info. It applies only when found
2952 # in the last entry. (This ugliness is to support making
2953 # identical imports to previous dgit versions.)
2955 my $lastpush_hash = git_get_ref(lrfetchref());
2956 printdebug "previous reference hash=$lastpush_hash\n";
2957 $lastpush_mergeinput = $lastpush_hash && {
2958 Commit => $lastpush_hash,
2959 Info => "dgit suite branch on dgit git server",
2962 my $lastfetch_hash = git_get_ref(lrref());
2963 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2964 my $lastfetch_mergeinput = $lastfetch_hash && {
2965 Commit => $lastfetch_hash,
2966 Info => "dgit client's archive history view",
2969 my $dsc_mergeinput = $dsc_hash && {
2970 Commit => $dsc_hash,
2971 Info => "Dgit field in .dsc from archive",
2975 my $del_lrfetchrefs = sub {
2978 printdebug "del_lrfetchrefs...\n";
2979 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2980 my $objid = $lrfetchrefs_d{$fullrefname};
2981 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2983 $gur ||= new IO::Handle;
2984 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2986 printf $gur "delete %s %s\n", $fullrefname, $objid;
2989 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2993 if (defined $dsc_hash) {
2994 ensure_we_have_orig();
2995 if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2996 @mergeinputs = $dsc_mergeinput
2997 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2998 print STDERR <<END or die $!;
3000 Git commit in archive is behind the last version allegedly pushed/uploaded.
3001 Commit referred to by archive: $dsc_hash
3002 Last version pushed with dgit: $lastpush_hash
3005 @mergeinputs = ($lastpush_mergeinput);
3007 # Archive has .dsc which is not a descendant of the last dgit
3008 # push. This can happen if the archive moves .dscs about.
3009 # Just follow its lead.
3010 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3011 progress "archive .dsc names newer git commit";
3012 @mergeinputs = ($dsc_mergeinput);
3014 progress "archive .dsc names other git commit, fixing up";
3015 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3019 @mergeinputs = generate_commits_from_dsc();
3020 # We have just done an import. Now, our import algorithm might
3021 # have been improved. But even so we do not want to generate
3022 # a new different import of the same package. So if the
3023 # version numbers are the same, just use our existing version.
3024 # If the version numbers are different, the archive has changed
3025 # (perhaps, rewound).
3026 if ($lastfetch_mergeinput &&
3027 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3028 (mergeinfo_version $mergeinputs[0]) )) {
3029 @mergeinputs = ($lastfetch_mergeinput);
3031 } elsif ($lastpush_hash) {
3032 # only in git, not in the archive yet
3033 @mergeinputs = ($lastpush_mergeinput);
3034 print STDERR <<END or die $!;
3036 Package not found in the archive, but has allegedly been pushed using dgit.
3040 printdebug "nothing found!\n";
3041 if (defined $skew_warning_vsn) {
3042 print STDERR <<END or die $!;
3044 Warning: relevant archive skew detected.
3045 Archive allegedly contains $skew_warning_vsn
3046 But we were not able to obtain any version from the archive or git.
3050 unshift @end, $del_lrfetchrefs;
3054 if ($lastfetch_hash &&
3056 my $h = $_->{Commit};
3057 $h and is_fast_fwd($lastfetch_hash, $h);
3058 # If true, one of the existing parents of this commit
3059 # is a descendant of the $lastfetch_hash, so we'll
3060 # be ff from that automatically.
3064 push @mergeinputs, $lastfetch_mergeinput;
3067 printdebug "fetch mergeinfos:\n";
3068 foreach my $mi (@mergeinputs) {
3070 printdebug " commit $mi->{Commit} $mi->{Info}\n";
3072 printdebug sprintf " ReverseParents=%d Message=%s",
3073 $mi->{ReverseParents}, $mi->{Message};
3077 my $compat_info= pop @mergeinputs
3078 if $mergeinputs[$#mergeinputs]{Message};
3080 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3083 if (@mergeinputs > 1) {
3085 my $tree_commit = $mergeinputs[0]{Commit};
3087 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3088 $tree =~ m/\n\n/; $tree = $`;
3089 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3092 # We use the changelog author of the package in question the
3093 # author of this pseudo-merge. This is (roughly) correct if
3094 # this commit is simply representing aa non-dgit upload.
3095 # (Roughly because it does not record sponsorship - but we
3096 # don't have sponsorship info because that's in the .changes,
3097 # which isn't in the archivw.)
3099 # But, it might be that we are representing archive history
3100 # updates (including in-archive copies). These are not really
3101 # the responsibility of the person who created the .dsc, but
3102 # there is no-one whose name we should better use. (The
3103 # author of the .dsc-named commit is clearly worse.)
3105 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3106 my $author = clogp_authline $useclogp;
3107 my $cversion = getfield $useclogp, 'Version';
3109 my $mcf = ".git/dgit/mergecommit";
3110 open MC, ">", $mcf or die "$mcf $!";
3111 print MC <<END or die $!;
3115 my @parents = grep { $_->{Commit} } @mergeinputs;
3116 @parents = reverse @parents if $compat_info->{ReverseParents};
3117 print MC <<END or die $! foreach @parents;
3121 print MC <<END or die $!;
3127 if (defined $compat_info->{Message}) {
3128 print MC $compat_info->{Message} or die $!;
3130 print MC <<END or die $!;
3131 Record $package ($cversion) in archive suite $csuite
3135 my $message_add_info = sub {
3137 my $mversion = mergeinfo_version $mi;
3138 printf MC " %-20s %s\n", $mversion, $mi->{Info}
3142 $message_add_info->($mergeinputs[0]);
3143 print MC <<END or die $!;
3144 should be treated as descended from
3146 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3150 $hash = make_commit $mcf;
3152 $hash = $mergeinputs[0]{Commit};
3154 printdebug "fetch hash=$hash\n";
3157 my ($lasth, $what) = @_;
3158 return unless $lasth;
3159 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3162 $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3164 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3166 fetch_from_archive_record_1($hash);
3168 if (defined $skew_warning_vsn) {
3170 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3171 my $gotclogp = commit_getclogp($hash);
3172 my $got_vsn = getfield $gotclogp, 'Version';
3173 printdebug "SKEW CHECK GOT $got_vsn\n";
3174 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3175 print STDERR <<END or die $!;
3177 Warning: archive skew detected. Using the available version:
3178 Archive allegedly contains $skew_warning_vsn
3179 We were able to obtain only $got_vsn
3185 if ($lastfetch_hash ne $hash) {
3186 fetch_from_archive_record_2($hash);
3189 lrfetchref_used lrfetchref();
3191 unshift @end, $del_lrfetchrefs;
3195 sub set_local_git_config ($$) {
3197 runcmd @git, qw(config), $k, $v;
3200 sub setup_mergechangelogs (;$) {
3202 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3204 my $driver = 'dpkg-mergechangelogs';
3205 my $cb = "merge.$driver";
3206 my $attrs = '.git/info/attributes';
3207 ensuredir '.git/info';
3209 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3210 if (!open ATTRS, "<", $attrs) {
3211 $!==ENOENT or die "$attrs: $!";
3215 next if m{^debian/changelog\s};
3216 print NATTRS $_, "\n" or die $!;
3218 ATTRS->error and die $!;
3221 print NATTRS "debian/changelog merge=$driver\n" or die $!;
3224 set_local_git_config "$cb.name", 'debian/changelog merge driver';
3225 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3227 rename "$attrs.new", "$attrs" or die "$attrs: $!";
3230 sub setup_useremail (;$) {
3232 return unless $always || access_cfg_bool(1, 'setup-useremail');
3235 my ($k, $envvar) = @_;
3236 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3237 return unless defined $v;
3238 set_local_git_config "user.$k", $v;
3241 $setup->('email', 'DEBEMAIL');
3242 $setup->('name', 'DEBFULLNAME');
3245 sub ensure_setup_existing_tree () {
3246 my $k = "remote.$remotename.skipdefaultupdate";
3247 my $c = git_get_config $k;
3248 return if defined $c;
3249 set_local_git_config $k, 'true';
3252 sub setup_new_tree () {
3253 setup_mergechangelogs();
3257 sub multisuite_suite_child ($$$) {
3258 my ($tsuite, $merginputs, $fn) = @_;
3259 # in child, sets things up, calls $fn->(), and returns undef
3260 # in parent, returns canonical suite name for $tsuite
3261 my $canonsuitefh = IO::File::new_tmpfile;
3262 my $pid = fork // die $!;
3265 $us .= " [$isuite]";
3266 $debugprefix .= " ";
3267 progress "fetching $tsuite...";
3268 canonicalise_suite();
3269 print $canonsuitefh $csuite, "\n" or die $!;
3270 close $canonsuitefh or die $!;
3274 waitpid $pid,0 == $pid or die $!;
3275 fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3276 seek $canonsuitefh,0,0 or die $!;
3277 local $csuite = <$canonsuitefh>;
3278 die $! unless defined $csuite && chomp $csuite;
3280 printdebug "multisuite $tsuite missing\n";
3283 printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3284 push @$merginputs, {
3291 sub fork_for_multisuite ($) {
3292 my ($before_fetch_merge) = @_;
3293 # if nothing unusual, just returns ''
3296 # returns 0 to caller in child, to do first of the specified suites
3297 # in child, $csuite is not yet set
3299 # returns 1 to caller in parent, to finish up anything needed after
3300 # in parent, $csuite is set to canonicalised portmanteau
3302 my $org_isuite = $isuite;
3303 my @suites = split /\,/, $isuite;
3304 return '' unless @suites > 1;
3305 printdebug "fork_for_multisuite: @suites\n";
3309 my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3311 return 0 unless defined $cbasesuite;
3313 fail "package $package missing in (base suite) $cbasesuite"
3314 unless @mergeinputs;
3316 my @csuites = ($cbasesuite);
3318 $before_fetch_merge->();
3320 foreach my $tsuite (@suites[1..$#suites]) {
3321 my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3327 # xxx collecte the ref here
3329 $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3330 push @csuites, $csubsuite;
3333 foreach my $mi (@mergeinputs) {
3334 my $ref = git_get_ref $mi->{Ref};
3335 die "$mi->{Ref} ?" unless length $ref;
3336 $mi->{Commit} = $ref;
3339 $csuite = join ",", @csuites;
3341 my $previous = git_get_ref lrref;
3343 unshift @mergeinputs, {
3344 Commit => $previous,
3345 Info => "local combined tracking branch",
3347 "archive seems to have rewound: local tracking branch is ahead!",
3351 foreach my $ix (0..$#mergeinputs) {
3352 $mergeinputs[$ix]{Index} = $ix;
3355 @mergeinputs = sort {
3356 -version_compare(mergeinfo_version $a,
3357 mergeinfo_version $b) # highest version first
3359 $a->{Index} <=> $b->{Index}; # earliest in spec first
3365 foreach my $mi (@mergeinputs) {
3366 printdebug "multisuite merge check $mi->{Info}\n";
3367 foreach my $previous (@needed) {
3368 next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3369 printdebug "multisuite merge un-needed $previous->{Info}\n";
3373 printdebug "multisuite merge this-needed\n";
3374 $mi->{Character} = '+';
3377 $needed[0]{Character} = '*';
3379 my $output = $needed[0]{Commit};
3382 printdebug "multisuite merge nontrivial\n";
3383 my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3385 my $commit = "tree $tree\n";
3386 my $msg = "Combine archive branches $csuite [dgit]\n\n".
3387 "Input branches:\n";
3389 foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3390 printdebug "multisuite merge include $mi->{Info}\n";
3391 $mi->{Character} //= ' ';
3392 $commit .= "parent $mi->{Commit}\n";
3393 $msg .= sprintf " %s %-25s %s\n",
3395 (mergeinfo_version $mi),
3398 my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3400 " * marks the highest version branch, which choose to use\n".
3401 " + marks each branch which was not already an ancestor\n\n".
3402 "[dgit multi-suite $csuite]\n";
3404 "author $authline\n".
3405 "committer $authline\n\n";
3406 $output = make_commit_text $commit.$msg;
3407 printdebug "multisuite merge generated $output\n";
3410 fetch_from_archive_record_1($output);
3411 fetch_from_archive_record_2($output);
3413 progress "calculated combined tracking suite $csuite";
3418 sub clone_set_head () {
3419 open H, "> .git/HEAD" or die $!;
3420 print H "ref: ".lref()."\n" or die $!;
3423 sub clone_finish ($) {
3425 runcmd @git, qw(reset --hard), lrref();
3426 runcmd qw(bash -ec), <<'END';
3428 git ls-tree -r --name-only -z HEAD | \
3429 xargs -0r touch -h -r . --
3431 printdone "ready for work in $dstdir";
3436 badusage "dry run makes no sense with clone" unless act_local();
3438 my $multi_fetched = fork_for_multisuite(sub {
3439 printdebug "multi clone before fetch merge\n";
3442 if ($multi_fetched) {
3443 printdebug "multi clone after fetch merge\n";
3445 clone_finish($dstdir);
3448 printdebug "clone main body\n";
3450 canonicalise_suite();
3451 my $hasgit = check_for_git();
3452 mkdir $dstdir or fail "create \`$dstdir': $!";
3454 runcmd @git, qw(init -q);
3456 my $giturl = access_giturl(1);
3457 if (defined $giturl) {
3458 runcmd @git, qw(remote add), 'origin', $giturl;
3461 progress "fetching existing git history";
3463 runcmd_ordryrun_local @git, qw(fetch origin);
3465 progress "starting new git history";
3467 fetch_from_archive() or no_such_package;
3468 my $vcsgiturl = $dsc->{'Vcs-Git'};
3469 if (length $vcsgiturl) {
3470 $vcsgiturl =~ s/\s+-b\s+\S+//g;
3471 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3474 clone_finish($dstdir);
3478 canonicalise_suite();
3479 if (check_for_git()) {
3482 fetch_from_archive() or no_such_package();
3483 printdone "fetched into ".lrref();
3487 my $multi_fetched = fork_for_multisuite(sub { });
3488 fetch() unless $multi_fetched; # parent
3489 return if $multi_fetched eq '0'; # child
3490 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3492 printdone "fetched to ".lrref()." and merged into HEAD";
3495 sub check_not_dirty () {
3496 foreach my $f (qw(local-options local-patch-header)) {
3497 if (stat_exists "debian/source/$f") {
3498 fail "git tree contains debian/source/$f";
3502 return if $ignoredirty;
3504 my @cmd = (@git, qw(diff --quiet HEAD));
3506 $!=0; $?=-1; system @cmd;
3509 fail "working tree is dirty (does not match HEAD)";
3515 sub commit_admin ($) {
3518 runcmd_ordryrun_local @git, qw(commit -m), $m;
3521 sub commit_quilty_patch () {
3522 my $output = cmdoutput @git, qw(status --porcelain);
3524 foreach my $l (split /\n/, $output) {
3525 next unless $l =~ m/\S/;
3526 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3530 delete $adds{'.pc'}; # if there wasn't one before, don't add it
3532 progress "nothing quilty to commit, ok.";
3535 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3536 runcmd_ordryrun_local @git, qw(add -f), @adds;
3538 Commit Debian 3.0 (quilt) metadata
3540 [dgit ($our_version) quilt-fixup]
3544 sub get_source_format () {
3546 if (open F, "debian/source/options") {
3550 s/\s+$//; # ignore missing final newline
3552 my ($k, $v) = ($`, $'); #');
3553 $v =~ s/^"(.*)"$/$1/;
3559 F->error and die $!;
3562 die $! unless $!==&ENOENT;
3565 if (!open F, "debian/source/format") {
3566 die $! unless $!==&ENOENT;
3570 F->error and die $!;
3572 return ($_, \%options);
3575 sub madformat_wantfixup ($) {
3577 return 0 unless $format eq '3.0 (quilt)';
3578 our $quilt_mode_warned;
3579 if ($quilt_mode eq 'nocheck') {
3580 progress "Not doing any fixup of \`$format' due to".
3581 " ----no-quilt-fixup or --quilt=nocheck"
3582 unless $quilt_mode_warned++;
3585 progress "Format \`$format', need to check/update patch stack"
3586 unless $quilt_mode_warned++;
3590 sub maybe_split_brain_save ($$$) {
3591 my ($headref, $dgitview, $msg) = @_;
3592 # => message fragment "$saved" describing disposition of $dgitview
3593 return "commit id $dgitview" unless defined $split_brain_save;
3594 my @cmd = (shell_cmd "cd ../../../..",
3595 @git, qw(update-ref -m),
3596 "dgit --dgit-view-save $msg HEAD=$headref",
3597 $split_brain_save, $dgitview);
3599 return "and left in $split_brain_save";
3602 # An "infopair" is a tuple [ $thing, $what ]
3603 # (often $thing is a commit hash; $what is a description)
3605 sub infopair_cond_equal ($$) {
3607 $x->[0] eq $y->[0] or fail <<END;
3608 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3612 sub infopair_lrf_tag_lookup ($$) {
3613 my ($tagnames, $what) = @_;
3614 # $tagname may be an array ref
3615 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3616 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3617 foreach my $tagname (@tagnames) {
3618 my $lrefname = lrfetchrefs."/tags/$tagname";
3619 my $tagobj = $lrfetchrefs_f{$lrefname};
3620 next unless defined $tagobj;
3621 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3622 return [ git_rev_parse($tagobj), $what ];
3624 fail @tagnames==1 ? <<END : <<END;
3625 Wanted tag $what (@tagnames) on dgit server, but not found
3627 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3631 sub infopair_cond_ff ($$) {
3632 my ($anc,$desc) = @_;
3633 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3634 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3638 sub pseudomerge_version_check ($$) {
3639 my ($clogp, $archive_hash) = @_;
3641 my $arch_clogp = commit_getclogp $archive_hash;
3642 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3643 'version currently in archive' ];
3644 if (defined $overwrite_version) {
3645 if (length $overwrite_version) {
3646 infopair_cond_equal([ $overwrite_version,
3647 '--overwrite= version' ],
3650 my $v = $i_arch_v->[0];
3651 progress "Checking package changelog for archive version $v ...";
3653 my @xa = ("-f$v", "-t$v");
3654 my $vclogp = parsechangelog @xa;
3655 my $cv = [ (getfield $vclogp, 'Version'),
3656 "Version field from dpkg-parsechangelog @xa" ];
3657 infopair_cond_equal($i_arch_v, $cv);
3660 $@ =~ s/^dgit: //gm;
3662 "Perhaps debian/changelog does not mention $v ?";
3667 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3671 sub pseudomerge_make_commit ($$$$ $$) {
3672 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3673 $msg_cmd, $msg_msg) = @_;
3674 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3676 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3677 my $authline = clogp_authline $clogp;
3681 !defined $overwrite_version ? ""
3682 : !length $overwrite_version ? " --overwrite"
3683 : " --overwrite=".$overwrite_version;
3686 my $pmf = ".git/dgit/pseudomerge";
3687 open MC, ">", $pmf or die "$pmf $!";
3688 print MC <<END or die $!;
3691 parent $archive_hash
3701 return make_commit($pmf);
3704 sub splitbrain_pseudomerge ($$$$) {
3705 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3706 # => $merged_dgitview
3707 printdebug "splitbrain_pseudomerge...\n";
3709 # We: debian/PREVIOUS HEAD($maintview)
3710 # expect: o ----------------- o
3713 # a/d/PREVIOUS $dgitview
3716 # we do: `------------------ o
3720 return $dgitview unless defined $archive_hash;
3722 printdebug "splitbrain_pseudomerge...\n";
3724 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3726 if (!defined $overwrite_version) {
3727 progress "Checking that HEAD inciudes all changes in archive...";
3730 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3732 if (defined $overwrite_version) {
3734 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3735 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3736 my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3737 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3738 my $i_archive = [ $archive_hash, "current archive contents" ];
3740 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3742 infopair_cond_equal($i_dgit, $i_archive);
3743 infopair_cond_ff($i_dep14, $i_dgit);
3744 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3748 $us: check failed (maybe --overwrite is needed, consult documentation)
3753 my $r = pseudomerge_make_commit
3754 $clogp, $dgitview, $archive_hash, $i_arch_v,
3755 "dgit --quilt=$quilt_mode",
3756 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3757 Declare fast forward from $i_arch_v->[0]
3759 Make fast forward from $i_arch_v->[0]
3762 maybe_split_brain_save $maintview, $r, "pseudomerge";
3764 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3768 sub plain_overwrite_pseudomerge ($$$) {
3769 my ($clogp, $head, $archive_hash) = @_;
3771 printdebug "plain_overwrite_pseudomerge...";
3773 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3775 return $head if is_fast_fwd $archive_hash, $head;
3777 my $m = "Declare fast forward from $i_arch_v->[0]";
3779 my $r = pseudomerge_make_commit
3780 $clogp, $head, $archive_hash, $i_arch_v,
3783 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3785 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3789 sub push_parse_changelog ($) {
3792 my $clogp = Dpkg::Control::Hash->new();
3793 $clogp->load($clogpfn) or die;
3795 my $clogpackage = getfield $clogp, 'Source';
3796 $package //= $clogpackage;
3797 fail "-p specified $package but changelog specified $clogpackage"
3798 unless $package eq $clogpackage;
3799 my $cversion = getfield $clogp, 'Version';
3800 my $tag = debiantag($cversion, access_nomdistro);
3801 runcmd @git, qw(check-ref-format), $tag;
3803 my $dscfn = dscfn($cversion);
3805 return ($clogp, $cversion, $dscfn);
3808 sub push_parse_dsc ($$$) {
3809 my ($dscfn,$dscfnwhat, $cversion) = @_;
3810 $dsc = parsecontrol($dscfn,$dscfnwhat);
3811 my $dversion = getfield $dsc, 'Version';
3812 my $dscpackage = getfield $dsc, 'Source';
3813 ($dscpackage eq $package && $dversion eq $cversion) or
3814 fail "$dscfn is for $dscpackage $dversion".
3815 " but debian/changelog is for $package $cversion";
3818 sub push_tagwants ($$$$) {
3819 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3822 TagFn => \&debiantag,
3827 if (defined $maintviewhead) {
3829 TagFn => \&debiantag_maintview,
3830 Objid => $maintviewhead,
3831 TfSuffix => '-maintview',
3834 } elsif ($dodep14tag eq 'no' ? 0
3835 : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
3836 : $dodep14tag eq 'always'
3837 ? (access_cfg_tagformats_can_splitbrain or fail <<END)
3838 --dep14tag-always (or equivalent in config) means server must support
3839 both "new" and "maint" tag formats, but config says it doesn't.
3841 : die "$dodep14tag ?") {
3843 TagFn => \&debiantag_maintview,
3845 TfSuffix => '-dgit',
3849 foreach my $tw (@tagwants) {
3850 $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3851 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3853 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3857 sub push_mktags ($$ $$ $) {
3859 $changesfile,$changesfilewhat,
3862 die unless $tagwants->[0]{View} eq 'dgit';
3864 my $declaredistro = access_nomdistro();
3865 my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
3866 $dsc->{$ourdscfield[0]} = join " ",
3867 $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
3869 $dsc->save("$dscfn.tmp") or die $!;
3871 my $changes = parsecontrol($changesfile,$changesfilewhat);
3872 foreach my $field (qw(Source Distribution Version)) {
3873 $changes->{$field} eq $clogp->{$field} or
3874 fail "changes field $field \`$changes->{$field}'".
3875 " does not match changelog \`$clogp->{$field}'";
3878 my $cversion = getfield $clogp, 'Version';
3879 my $clogsuite = getfield $clogp, 'Distribution';
3881 # We make the git tag by hand because (a) that makes it easier
3882 # to control the "tagger" (b) we can do remote signing
3883 my $authline = clogp_authline $clogp;
3884 my $delibs = join(" ", "",@deliberatelies);
3888 my $tfn = $tw->{Tfn};
3889 my $head = $tw->{Objid};
3890 my $tag = $tw->{Tag};
3892 open TO, '>', $tfn->('.tmp') or die $!;
3893 print TO <<END or die $!;
3900 if ($tw->{View} eq 'dgit') {
3901 print TO <<END or die $!;
3902 $package release $cversion for $clogsuite ($csuite) [dgit]
3903 [dgit distro=$declaredistro$delibs]
3905 foreach my $ref (sort keys %previously) {
3906 print TO <<END or die $!;
3907 [dgit previously:$ref=$previously{$ref}]
3910 } elsif ($tw->{View} eq 'maint') {
3911 print TO <<END or die $!;
3912 $package release $cversion for $clogsuite ($csuite)
3913 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3916 die Dumper($tw)."?";
3921 my $tagobjfn = $tfn->('.tmp');
3923 if (!defined $keyid) {
3924 $keyid = access_cfg('keyid','RETURN-UNDEF');
3926 if (!defined $keyid) {
3927 $keyid = getfield $clogp, 'Maintainer';
3929 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3930 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3931 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3932 push @sign_cmd, $tfn->('.tmp');
3933 runcmd_ordryrun @sign_cmd;
3935 $tagobjfn = $tfn->('.signed.tmp');
3936 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3937 $tfn->('.tmp'), $tfn->('.tmp.asc');
3943 my @r = map { $mktag->($_); } @$tagwants;
3947 sub sign_changes ($) {
3948 my ($changesfile) = @_;
3950 my @debsign_cmd = @debsign;
3951 push @debsign_cmd, "-k$keyid" if defined $keyid;
3952 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3953 push @debsign_cmd, $changesfile;
3954 runcmd_ordryrun @debsign_cmd;
3959 printdebug "actually entering push\n";
3961 supplementary_message(<<'END');
3962 Push failed, while checking state of the archive.
3963 You can retry the push, after fixing the problem, if you like.
3965 if (check_for_git()) {
3968 my $archive_hash = fetch_from_archive();
3969 if (!$archive_hash) {
3971 fail "package appears to be new in this suite;".
3972 " if this is intentional, use --new";
3975 supplementary_message(<<'END');
3976 Push failed, while preparing your push.
3977 You can retry the push, after fixing the problem, if you like.
3980 need_tagformat 'new', "quilt mode $quilt_mode"
3981 if quiltmode_splitbrain;
3985 access_giturl(); # check that success is vaguely likely
3988 my $clogpfn = ".git/dgit/changelog.822.tmp";
3989 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3991 responder_send_file('parsed-changelog', $clogpfn);
3993 my ($clogp, $cversion, $dscfn) =
3994 push_parse_changelog("$clogpfn");
3996 my $dscpath = "$buildproductsdir/$dscfn";
3997 stat_exists $dscpath or
3998 fail "looked for .dsc $dscpath, but $!;".
3999 " maybe you forgot to build";
4001 responder_send_file('dsc', $dscpath);
4003 push_parse_dsc($dscpath, $dscfn, $cversion);
4005 my $format = getfield $dsc, 'Format';
4006 printdebug "format $format\n";
4008 my $actualhead = git_rev_parse('HEAD');
4009 my $dgithead = $actualhead;
4010 my $maintviewhead = undef;
4012 my $upstreamversion = upstreamversion $clogp->{Version};
4014 if (madformat_wantfixup($format)) {
4015 # user might have not used dgit build, so maybe do this now:
4016 if (quiltmode_splitbrain()) {
4018 quilt_make_fake_dsc($upstreamversion);
4020 ($dgithead, $cachekey) =
4021 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
4023 "--quilt=$quilt_mode but no cached dgit view:
4024 perhaps tree changed since dgit build[-source] ?";
4026 $dgithead = splitbrain_pseudomerge($clogp,
4027 $actualhead, $dgithead,
4029 $maintviewhead = $actualhead;
4030 changedir '../../../..';
4031 prep_ud(); # so _only_subdir() works, below
4033 commit_quilty_patch();
4037 if (defined $overwrite_version && !defined $maintviewhead) {
4038 $dgithead = plain_overwrite_pseudomerge($clogp,
4046 if ($archive_hash) {
4047 if (is_fast_fwd($archive_hash, $dgithead)) {
4049 } elsif (deliberately_not_fast_forward) {
4052 fail "dgit push: HEAD is not a descendant".
4053 " of the archive's version.\n".
4054 "To overwrite the archive's contents,".
4055 " pass --overwrite[=VERSION].\n".
4056 "To rewind history, if permitted by the archive,".
4057 " use --deliberately-not-fast-forward.";
4062 progress "checking that $dscfn corresponds to HEAD";
4063 runcmd qw(dpkg-source -x --),
4064 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
4065 my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
4066 check_for_vendor_patches() if madformat($dsc->{format});
4067 changedir '../../../..';
4068 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
4069 debugcmd "+",@diffcmd;
4071 my $r = system @diffcmd;
4074 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
4076 HEAD specifies a different tree to $dscfn:
4078 Perhaps you forgot to build. Or perhaps there is a problem with your
4079 source tree (see dgit(7) for some hints). To see a full diff, run
4086 if (!$changesfile) {
4087 my $pat = changespat $cversion;
4088 my @cs = glob "$buildproductsdir/$pat";
4089 fail "failed to find unique changes file".
4090 " (looked for $pat in $buildproductsdir);".
4091 " perhaps you need to use dgit -C"
4093 ($changesfile) = @cs;
4095 $changesfile = "$buildproductsdir/$changesfile";
4098 # Check that changes and .dsc agree enough
4099 $changesfile =~ m{[^/]*$};
4100 my $changes = parsecontrol($changesfile,$&);
4101 files_compare_inputs($dsc, $changes)
4102 unless forceing [qw(dsc-changes-mismatch)];
4104 # Perhaps adjust .dsc to contain right set of origs
4105 changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
4107 unless forceing [qw(changes-origs-exactly)];
4109 # Checks complete, we're going to try and go ahead:
4111 responder_send_file('changes',$changesfile);
4112 responder_send_command("param head $dgithead");
4113 responder_send_command("param csuite $csuite");
4114 responder_send_command("param tagformat $tagformat");
4115 if (defined $maintviewhead) {
4116 die unless ($protovsn//4) >= 4;
4117 responder_send_command("param maint-view $maintviewhead");
4120 if (deliberately_not_fast_forward) {
4121 git_for_each_ref(lrfetchrefs, sub {
4122 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
4123 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
4124 responder_send_command("previously $rrefname=$objid");
4125 $previously{$rrefname} = $objid;
4129 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
4133 supplementary_message(<<'END');
4134 Push failed, while signing the tag.
4135 You can retry the push, after fixing the problem, if you like.
4137 # If we manage to sign but fail to record it anywhere, it's fine.
4138 if ($we_are_responder) {
4139 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
4140 responder_receive_files('signed-tag', @tagobjfns);
4142 @tagobjfns = push_mktags($clogp,$dscpath,
4143 $changesfile,$changesfile,
4146 supplementary_message(<<'END');
4147 Push failed, *after* signing the tag.
4148 If you want to try again, you should use a new version number.
4151 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
4153 foreach my $tw (@tagwants) {
4154 my $tag = $tw->{Tag};
4155 my $tagobjfn = $tw->{TagObjFn};
4157 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
4158 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
4159 runcmd_ordryrun_local
4160 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
4163 supplementary_message(<<'END');
4164 Push failed, while updating the remote git repository - see messages above.
4165 If you want to try again, you should use a new version number.
4167 if (!check_for_git()) {
4168 create_remote_git_repo();
4171 my @pushrefs = $forceflag.$dgithead.":".rrref();
4172 foreach my $tw (@tagwants) {
4173 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
4176 runcmd_ordryrun @git,
4177 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
4178 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
4180 supplementary_message(<<'END');
4181 Push failed, while obtaining signatures on the .changes and .dsc.
4182 If it was just that the signature failed, you may try again by using
4183 debsign by hand to sign the changes
4185 and then dput to complete the upload.
4186 If you need to change the package, you must use a new version number.
4188 if ($we_are_responder) {
4189 my $dryrunsuffix = act_local() ? "" : ".tmp";
4190 responder_receive_files('signed-dsc-changes',
4191 "$dscpath$dryrunsuffix",
4192 "$changesfile$dryrunsuffix");
4195 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
4197 progress "[new .dsc left in $dscpath.tmp]";
4199 sign_changes $changesfile;
4202 supplementary_message(<<END);
4203 Push failed, while uploading package(s) to the archive server.
4204 You can retry the upload of exactly these same files with dput of:
4206 If that .changes file is broken, you will need to use a new version
4207 number for your next attempt at the upload.
4209 my $host = access_cfg('upload-host','RETURN-UNDEF');
4210 my @hostarg = defined($host) ? ($host,) : ();
4211 runcmd_ordryrun @dput, @hostarg, $changesfile;
4212 printdone "pushed and uploaded $cversion";
4214 supplementary_message('');
4215 responder_send_command("complete");
4221 badusage "-p is not allowed with clone; specify as argument instead"
4222 if defined $package;
4225 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4226 ($package,$isuite) = @ARGV;
4227 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4228 ($package,$dstdir) = @ARGV;
4229 } elsif (@ARGV==3) {
4230 ($package,$isuite,$dstdir) = @ARGV;
4232 badusage "incorrect arguments to dgit clone";
4236 $dstdir ||= "$package";
4237 if (stat_exists $dstdir) {
4238 fail "$dstdir already exists";
4242 if ($rmonerror && !$dryrun_level) {
4243 $cwd_remove= getcwd();
4245 return unless defined $cwd_remove;
4246 if (!chdir "$cwd_remove") {
4247 return if $!==&ENOENT;
4248 die "chdir $cwd_remove: $!";
4250 printdebug "clone rmonerror removing $dstdir\n";
4252 rmtree($dstdir) or die "remove $dstdir: $!\n";
4253 } elsif (grep { $! == $_ }
4254 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4256 print STDERR "check whether to remove $dstdir: $!\n";
4262 $cwd_remove = undef;
4265 sub branchsuite () {
4266 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4267 if ($branch =~ m#$lbranch_re#o) {
4274 sub fetchpullargs () {
4275 if (!defined $package) {
4276 my $sourcep = parsecontrol('debian/control','debian/control');
4277 $package = getfield $sourcep, 'Source';
4280 $isuite = branchsuite();
4282 my $clogp = parsechangelog();
4283 $isuite = getfield $clogp, 'Distribution';
4285 } elsif (@ARGV==1) {
4288 badusage "incorrect arguments to dgit fetch or dgit pull";
4296 my $multi_fetched = fork_for_multisuite(sub { });
4297 exit 0 if $multi_fetched;
4304 if (quiltmode_splitbrain()) {
4305 my ($format, $fopts) = get_source_format();
4306 madformat($format) and fail <<END
4307 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4316 badusage "-p is not allowed with dgit push" if defined $package;
4318 my $clogp = parsechangelog();
4319 $package = getfield $clogp, 'Source';
4322 } elsif (@ARGV==1) {
4323 ($specsuite) = (@ARGV);
4325 badusage "incorrect arguments to dgit push";
4327 $isuite = getfield $clogp, 'Distribution';
4329 local ($package) = $existing_package; # this is a hack
4330 canonicalise_suite();
4332 canonicalise_suite();
4334 if (defined $specsuite &&
4335 $specsuite ne $isuite &&
4336 $specsuite ne $csuite) {
4337 fail "dgit push: changelog specifies $isuite ($csuite)".
4338 " but command line specifies $specsuite";
4343 #---------- remote commands' implementation ----------
4345 sub cmd_remote_push_build_host {
4346 my ($nrargs) = shift @ARGV;
4347 my (@rargs) = @ARGV[0..$nrargs-1];
4348 @ARGV = @ARGV[$nrargs..$#ARGV];
4350 my ($dir,$vsnwant) = @rargs;
4351 # vsnwant is a comma-separated list; we report which we have
4352 # chosen in our ready response (so other end can tell if they
4355 $we_are_responder = 1;
4356 $us .= " (build host)";
4360 open PI, "<&STDIN" or die $!;
4361 open STDIN, "/dev/null" or die $!;
4362 open PO, ">&STDOUT" or die $!;
4364 open STDOUT, ">&STDERR" or die $!;
4368 ($protovsn) = grep {
4369 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4370 } @rpushprotovsn_support;
4372 fail "build host has dgit rpush protocol versions ".
4373 (join ",", @rpushprotovsn_support).
4374 " but invocation host has $vsnwant"
4375 unless defined $protovsn;
4377 responder_send_command("dgit-remote-push-ready $protovsn");
4378 rpush_handle_protovsn_bothends();
4383 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4384 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4385 # a good error message)
4387 sub rpush_handle_protovsn_bothends () {
4388 if ($protovsn < 4) {
4389 need_tagformat 'old', "rpush negotiated protocol $protovsn";
4398 my $report = i_child_report();
4399 if (defined $report) {
4400 printdebug "($report)\n";
4401 } elsif ($i_child_pid) {
4402 printdebug "(killing build host child $i_child_pid)\n";
4403 kill 15, $i_child_pid;
4405 if (defined $i_tmp && !defined $initiator_tempdir) {
4407 eval { rmtree $i_tmp; };
4411 END { i_cleanup(); }
4414 my ($base,$selector,@args) = @_;
4415 $selector =~ s/\-/_/g;
4416 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4423 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4431 push @rargs, join ",", @rpushprotovsn_support;
4434 push @rdgit, @ropts;
4435 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4437 my @cmd = (@ssh, $host, shellquote @rdgit);
4440 if (defined $initiator_tempdir) {
4441 rmtree $initiator_tempdir;
4442 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4443 $i_tmp = $initiator_tempdir;
4447 $i_child_pid = open2(\*RO, \*RI, @cmd);
4449 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4450 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4451 $supplementary_message = '' unless $protovsn >= 3;
4453 fail "rpush negotiated protocol version $protovsn".
4454 " which does not support quilt mode $quilt_mode"
4455 if quiltmode_splitbrain;
4457 rpush_handle_protovsn_bothends();
4459 my ($icmd,$iargs) = initiator_expect {
4460 m/^(\S+)(?: (.*))?$/;
4463 i_method "i_resp", $icmd, $iargs;
4467 sub i_resp_progress ($) {
4469 my $msg = protocol_read_bytes \*RO, $rhs;
4473 sub i_resp_supplementary_message ($) {
4475 $supplementary_message = protocol_read_bytes \*RO, $rhs;
4478 sub i_resp_complete {
4479 my $pid = $i_child_pid;
4480 $i_child_pid = undef; # prevents killing some other process with same pid
4481 printdebug "waiting for build host child $pid...\n";
4482 my $got = waitpid $pid, 0;
4483 die $! unless $got == $pid;
4484 die "build host child failed $?" if $?;
4487 printdebug "all done\n";
4491 sub i_resp_file ($) {
4493 my $localname = i_method "i_localname", $keyword;
4494 my $localpath = "$i_tmp/$localname";
4495 stat_exists $localpath and
4496 badproto \*RO, "file $keyword ($localpath) twice";
4497 protocol_receive_file \*RO, $localpath;
4498 i_method "i_file", $keyword;
4503 sub i_resp_param ($) {
4504 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4508 sub i_resp_previously ($) {
4509 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4510 or badproto \*RO, "bad previously spec";
4511 my $r = system qw(git check-ref-format), $1;
4512 die "bad previously ref spec ($r)" if $r;
4513 $previously{$1} = $2;
4518 sub i_resp_want ($) {
4520 die "$keyword ?" if $i_wanted{$keyword}++;
4521 my @localpaths = i_method "i_want", $keyword;
4522 printdebug "[[ $keyword @localpaths\n";
4523 foreach my $localpath (@localpaths) {
4524 protocol_send_file \*RI, $localpath;
4526 print RI "files-end\n" or die $!;
4529 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4531 sub i_localname_parsed_changelog {
4532 return "remote-changelog.822";
4534 sub i_file_parsed_changelog {
4535 ($i_clogp, $i_version, $i_dscfn) =
4536 push_parse_changelog "$i_tmp/remote-changelog.822";
4537 die if $i_dscfn =~ m#/|^\W#;
4540 sub i_localname_dsc {
4541 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4546 sub i_localname_changes {
4547 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4548 $i_changesfn = $i_dscfn;
4549 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4550 return $i_changesfn;
4552 sub i_file_changes { }
4554 sub i_want_signed_tag {
4555 printdebug Dumper(\%i_param, $i_dscfn);
4556 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4557 && defined $i_param{'csuite'}
4558 or badproto \*RO, "premature desire for signed-tag";
4559 my $head = $i_param{'head'};
4560 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4562 my $maintview = $i_param{'maint-view'};
4563 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4566 if ($protovsn >= 4) {
4567 my $p = $i_param{'tagformat'} // '<undef>';
4569 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4572 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4574 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4576 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4579 push_mktags $i_clogp, $i_dscfn,
4580 $i_changesfn, 'remote changes',
4584 sub i_want_signed_dsc_changes {
4585 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4586 sign_changes $i_changesfn;
4587 return ($i_dscfn, $i_changesfn);
4590 #---------- building etc. ----------
4596 #----- `3.0 (quilt)' handling -----
4598 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4600 sub quiltify_dpkg_commit ($$$;$) {
4601 my ($patchname,$author,$msg, $xinfo) = @_;
4605 my $descfn = ".git/dgit/quilt-description.tmp";
4606 open O, '>', $descfn or die "$descfn: $!";
4607 $msg =~ s/\n+/\n\n/;
4608 print O <<END or die $!;
4610 ${xinfo}Subject: $msg
4617 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4618 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4619 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4620 runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
4624 sub quiltify_trees_differ ($$;$$$) {
4625 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4626 # returns true iff the two tree objects differ other than in debian/
4627 # with $finegrained,
4628 # returns bitmask 01 - differ in upstream files except .gitignore
4629 # 02 - differ in .gitignore
4630 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4631 # is set for each modified .gitignore filename $fn
4632 # if $unrepres is defined, array ref to which is appeneded
4633 # a list of unrepresentable changes (removals of upstream files
4636 my @cmd = (@git, qw(diff-tree -z));
4637 push @cmd, qw(--name-only) unless $unrepres;
4638 push @cmd, qw(-r) if $finegrained || $unrepres;
4640 my $diffs= cmdoutput @cmd;
4643 foreach my $f (split /\0/, $diffs) {
4644 if ($unrepres && !@lmodes) {
4645 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
4648 my ($oldmode,$newmode) = @lmodes;
4651 next if $f =~ m#^debian(?:/.*)?$#s;
4655 die "not a plain file\n"
4656 unless $newmode =~ m/^10\d{4}$/ ||
4657 $oldmode =~ m/^10\d{4}$/;
4658 if ($oldmode =~ m/[^0]/ &&
4659 $newmode =~ m/[^0]/) {
4660 die "mode changed\n" if $oldmode ne $newmode;
4662 die "non-default mode\n"
4663 unless $newmode =~ m/^100644$/ ||
4664 $oldmode =~ m/^100644$/;
4668 local $/="\n"; chomp $@;
4669 push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
4673 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4674 $r |= $isignore ? 02 : 01;
4675 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4677 printdebug "quiltify_trees_differ $x $y => $r\n";
4681 sub quiltify_tree_sentinelfiles ($) {
4682 # lists the `sentinel' files present in the tree
4684 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4685 qw(-- debian/rules debian/control);
4690 sub quiltify_splitbrain_needed () {
4691 if (!$split_brain) {
4692 progress "dgit view: changes are required...";
4693 runcmd @git, qw(checkout -q -b dgit-view);
4698 sub quiltify_splitbrain ($$$$$$) {
4699 my ($clogp, $unapplied, $headref, $diffbits,
4700 $editedignores, $cachekey) = @_;
4701 if ($quilt_mode !~ m/gbp|dpm/) {
4702 # treat .gitignore just like any other upstream file
4703 $diffbits = { %$diffbits };
4704 $_ = !!$_ foreach values %$diffbits;
4706 # We would like any commits we generate to be reproducible
4707 my @authline = clogp_authline($clogp);
4708 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
4709 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4710 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
4711 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
4712 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4713 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
4715 if ($quilt_mode =~ m/gbp|unapplied/ &&
4716 ($diffbits->{O2H} & 01)) {
4718 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4719 " but git tree differs from orig in upstream files.";
4720 if (!stat_exists "debian/patches") {
4722 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4726 if ($quilt_mode =~ m/dpm/ &&
4727 ($diffbits->{H2A} & 01)) {
4729 --quilt=$quilt_mode specified, implying patches-applied git tree
4730 but git tree differs from result of applying debian/patches to upstream
4733 if ($quilt_mode =~ m/gbp|unapplied/ &&
4734 ($diffbits->{O2A} & 01)) { # some patches
4735 quiltify_splitbrain_needed();
4736 progress "dgit view: creating patches-applied version using gbp pq";
4737 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4738 # gbp pq import creates a fresh branch; push back to dgit-view
4739 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4740 runcmd @git, qw(checkout -q dgit-view);
4742 if ($quilt_mode =~ m/gbp|dpm/ &&
4743 ($diffbits->{O2A} & 02)) {
4745 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4746 tool which does not create patches for changes to upstream
4747 .gitignores: but, such patches exist in debian/patches.
4750 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4751 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4752 quiltify_splitbrain_needed();
4753 progress "dgit view: creating patch to represent .gitignore changes";
4754 ensuredir "debian/patches";
4755 my $gipatch = "debian/patches/auto-gitignore";
4756 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4757 stat GIPATCH or die "$gipatch: $!";
4758 fail "$gipatch already exists; but want to create it".
4759 " to record .gitignore changes" if (stat _)[7];
4760 print GIPATCH <<END or die "$gipatch: $!";
4761 Subject: Update .gitignore from Debian packaging branch
4763 The Debian packaging git branch contains these updates to the upstream
4764 .gitignore file(s). This patch is autogenerated, to provide these
4765 updates to users of the official Debian archive view of the package.
4767 [dgit ($our_version) update-gitignore]
4770 close GIPATCH or die "$gipatch: $!";
4771 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4772 $unapplied, $headref, "--", sort keys %$editedignores;
4773 open SERIES, "+>>", "debian/patches/series" or die $!;
4774 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4776 defined read SERIES, $newline, 1 or die $!;
4777 print SERIES "\n" or die $! unless $newline eq "\n";
4778 print SERIES "auto-gitignore\n" or die $!;
4779 close SERIES or die $!;
4780 runcmd @git, qw(add -- debian/patches/series), $gipatch;
4782 Commit patch to update .gitignore
4784 [dgit ($our_version) update-gitignore-quilt-fixup]
4788 my $dgitview = git_rev_parse 'HEAD';
4790 changedir '../../../..';
4791 # When we no longer need to support squeeze, use --create-reflog
4793 ensuredir ".git/logs/refs/dgit-intern";
4794 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4797 my $oldcache = git_get_ref "refs/$splitbraincache";
4798 if ($oldcache eq $dgitview) {
4799 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4800 # git update-ref doesn't always update, in this case. *sigh*
4801 my $dummy = make_commit_text <<END;
4804 author Dgit <dgit\@example.com> 1000000000 +0000
4805 committer Dgit <dgit\@example.com> 1000000000 +0000
4807 Dummy commit - do not use
4809 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4810 "refs/$splitbraincache", $dummy;
4812 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4815 changedir '.git/dgit/unpack/work';
4817 my $saved = maybe_split_brain_save $headref, $dgitview, "converted";
4818 progress "dgit view: created ($saved)";
4821 sub quiltify ($$$$) {
4822 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4824 # Quilt patchification algorithm
4826 # We search backwards through the history of the main tree's HEAD
4827 # (T) looking for a start commit S whose tree object is identical
4828 # to to the patch tip tree (ie the tree corresponding to the
4829 # current dpkg-committed patch series). For these purposes
4830 # `identical' disregards anything in debian/ - this wrinkle is
4831 # necessary because dpkg-source treates debian/ specially.
4833 # We can only traverse edges where at most one of the ancestors'
4834 # trees differs (in changes outside in debian/). And we cannot
4835 # handle edges which change .pc/ or debian/patches. To avoid
4836 # going down a rathole we avoid traversing edges which introduce
4837 # debian/rules or debian/control. And we set a limit on the
4838 # number of edges we are willing to look at.
4840 # If we succeed, we walk forwards again. For each traversed edge
4841 # PC (with P parent, C child) (starting with P=S and ending with
4842 # C=T) to we do this:
4844 # - dpkg-source --commit with a patch name and message derived from C
4845 # After traversing PT, we git commit the changes which
4846 # should be contained within debian/patches.
4848 # The search for the path S..T is breadth-first. We maintain a
4849 # todo list containing search nodes. A search node identifies a
4850 # commit, and looks something like this:
4852 # Commit => $git_commit_id,
4853 # Child => $c, # or undef if P=T
4854 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4855 # Nontrivial => true iff $p..$c has relevant changes
4862 my %considered; # saves being exponential on some weird graphs
4864 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4867 my ($search,$whynot) = @_;
4868 printdebug " search NOT $search->{Commit} $whynot\n";
4869 $search->{Whynot} = $whynot;
4870 push @nots, $search;
4871 no warnings qw(exiting);
4880 my $c = shift @todo;
4881 next if $considered{$c->{Commit}}++;
4883 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4885 printdebug "quiltify investigate $c->{Commit}\n";
4888 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4889 printdebug " search finished hooray!\n";
4894 if ($quilt_mode eq 'nofix') {
4895 fail "quilt fixup required but quilt mode is \`nofix'\n".
4896 "HEAD commit $c->{Commit} differs from tree implied by ".
4897 " debian/patches (tree object $oldtiptree)";
4899 if ($quilt_mode eq 'smash') {
4900 printdebug " search quitting smash\n";
4904 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4905 $not->($c, "has $c_sentinels not $t_sentinels")
4906 if $c_sentinels ne $t_sentinels;
4908 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4909 $commitdata =~ m/\n\n/;
4911 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4912 @parents = map { { Commit => $_, Child => $c } } @parents;
4914 $not->($c, "root commit") if !@parents;
4916 foreach my $p (@parents) {
4917 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4919 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4920 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4922 foreach my $p (@parents) {
4923 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4925 my @cmd= (@git, qw(diff-tree -r --name-only),
4926 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4927 my $patchstackchange = cmdoutput @cmd;
4928 if (length $patchstackchange) {
4929 $patchstackchange =~ s/\n/,/g;
4930 $not->($p, "changed $patchstackchange");
4933 printdebug " search queue P=$p->{Commit} ",
4934 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4940 printdebug "quiltify want to smash\n";
4943 my $x = $_[0]{Commit};
4944 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4947 my $reportnot = sub {
4949 my $s = $abbrev->($notp);
4950 my $c = $notp->{Child};
4951 $s .= "..".$abbrev->($c) if $c;
4952 $s .= ": ".$notp->{Whynot};
4955 if ($quilt_mode eq 'linear') {
4956 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4957 foreach my $notp (@nots) {
4958 print STDERR "$us: ", $reportnot->($notp), "\n";
4960 print STDERR "$us: $_\n" foreach @$failsuggestion;
4961 fail "quilt fixup naive history linearisation failed.\n".
4962 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4963 } elsif ($quilt_mode eq 'smash') {
4964 } elsif ($quilt_mode eq 'auto') {
4965 progress "quilt fixup cannot be linear, smashing...";
4967 die "$quilt_mode ?";
4970 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4971 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4973 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4975 quiltify_dpkg_commit "auto-$version-$target-$time",
4976 (getfield $clogp, 'Maintainer'),
4977 "Automatically generated patch ($clogp->{Version})\n".
4978 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4982 progress "quiltify linearisation planning successful, executing...";
4984 for (my $p = $sref_S;
4985 my $c = $p->{Child};
4987 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4988 next unless $p->{Nontrivial};
4990 my $cc = $c->{Commit};
4992 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4993 $commitdata =~ m/\n\n/ or die "$c ?";
4996 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4999 my $commitdate = cmdoutput
5000 @git, qw(log -n1 --pretty=format:%aD), $cc;
5002 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
5004 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
5011 my $gbp_check_suitable = sub {
5016 die "contains unexpected slashes\n" if m{//} || m{/$};
5017 die "contains leading punctuation\n" if m{^\W} || m{/\W};
5018 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
5019 die "too long" if length > 200;
5021 return $_ unless $@;
5022 print STDERR "quiltifying commit $cc:".
5023 " ignoring/dropping Gbp-Pq $what: $@";
5027 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
5029 (\S+) \s* \n //ixm) {
5030 $patchname = $gbp_check_suitable->($1, 'Name');
5032 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
5034 (\S+) \s* \n //ixm) {
5035 $patchdir = $gbp_check_suitable->($1, 'Topic');
5040 if (!defined $patchname) {
5041 $patchname = $title;
5042 $patchname =~ s/[.:]$//;
5045 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
5046 my $translitname = $converter->convert($patchname);
5047 die unless defined $translitname;
5048 $patchname = $translitname;
5051 "dgit: patch title transliteration error: $@"
5053 $patchname =~ y/ A-Z/-a-z/;
5054 $patchname =~ y/-a-z0-9_.+=~//cd;
5055 $patchname =~ s/^\W/x-$&/;
5056 $patchname = substr($patchname,0,40);
5058 if (!defined $patchdir) {
5061 if (length $patchdir) {
5062 $patchname = "$patchdir/$patchname";
5064 if ($patchname =~ m{^(.*)/}) {
5065 mkpath "debian/patches/$1";
5070 stat "debian/patches/$patchname$index";
5072 $!==ENOENT or die "$patchname$index $!";
5074 runcmd @git, qw(checkout -q), $cc;
5076 # We use the tip's changelog so that dpkg-source doesn't
5077 # produce complaining messages from dpkg-parsechangelog. None
5078 # of the information dpkg-source gets from the changelog is
5079 # actually relevant - it gets put into the original message
5080 # which dpkg-source provides our stunt editor, and then
5082 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
5084 quiltify_dpkg_commit "$patchname$index", $author, $msg,
5085 "Date: $commitdate\n".
5086 "X-Dgit-Generated: $clogp->{Version} $cc\n";
5088 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
5091 runcmd @git, qw(checkout -q master);
5094 sub build_maybe_quilt_fixup () {
5095 my ($format,$fopts) = get_source_format;
5096 return unless madformat_wantfixup $format;
5099 check_for_vendor_patches();
5101 if (quiltmode_splitbrain) {
5102 fail <<END unless access_cfg_tagformats_can_splitbrain;
5103 quilt mode $quilt_mode requires split view so server needs to support
5104 both "new" and "maint" tag formats, but config says it doesn't.
5108 my $clogp = parsechangelog();
5109 my $headref = git_rev_parse('HEAD');
5114 my $upstreamversion = upstreamversion $version;
5116 if ($fopts->{'single-debian-patch'}) {
5117 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
5119 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
5122 die 'bug' if $split_brain && !$need_split_build_invocation;
5124 changedir '../../../..';
5125 runcmd_ordryrun_local
5126 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
5129 sub quilt_fixup_mkwork ($) {
5132 mkdir "work" or die $!;
5134 mktree_in_ud_here();
5135 runcmd @git, qw(reset -q --hard), $headref;
5138 sub quilt_fixup_linkorigs ($$) {
5139 my ($upstreamversion, $fn) = @_;
5140 # calls $fn->($leafname);
5142 foreach my $f (<../../../../*>) { #/){
5143 my $b=$f; $b =~ s{.*/}{};
5145 local ($debuglevel) = $debuglevel-1;
5146 printdebug "QF linkorigs $b, $f ?\n";
5148 next unless is_orig_file_of_vsn $b, $upstreamversion;
5149 printdebug "QF linkorigs $b, $f Y\n";
5150 link_ltarget $f, $b or die "$b $!";
5155 sub quilt_fixup_delete_pc () {
5156 runcmd @git, qw(rm -rqf .pc);
5158 Commit removal of .pc (quilt series tracking data)
5160 [dgit ($our_version) upgrade quilt-remove-pc]
5164 sub quilt_fixup_singlepatch ($$$) {
5165 my ($clogp, $headref, $upstreamversion) = @_;
5167 progress "starting quiltify (single-debian-patch)";
5169 # dpkg-source --commit generates new patches even if
5170 # single-debian-patch is in debian/source/options. In order to
5171 # get it to generate debian/patches/debian-changes, it is
5172 # necessary to build the source package.
5174 quilt_fixup_linkorigs($upstreamversion, sub { });
5175 quilt_fixup_mkwork($headref);
5177 rmtree("debian/patches");
5179 runcmd @dpkgsource, qw(-b .);
5181 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
5182 rename srcfn("$upstreamversion", "/debian/patches"),
5183 "work/debian/patches";
5186 commit_quilty_patch();
5189 sub quilt_make_fake_dsc ($) {
5190 my ($upstreamversion) = @_;
5192 my $fakeversion="$upstreamversion-~~DGITFAKE";
5194 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
5195 print $fakedsc <<END or die $!;
5198 Version: $fakeversion
5202 my $dscaddfile=sub {
5205 my $md = new Digest::MD5;
5207 my $fh = new IO::File $b, '<' or die "$b $!";
5212 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
5215 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
5217 my @files=qw(debian/source/format debian/rules
5218 debian/control debian/changelog);
5219 foreach my $maybe (qw(debian/patches debian/source/options
5220 debian/tests/control)) {
5221 next unless stat_exists "../../../$maybe";
5222 push @files, $maybe;
5225 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
5226 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
5228 $dscaddfile->($debtar);
5229 close $fakedsc or die $!;
5232 sub quilt_check_splitbrain_cache ($$) {
5233 my ($headref, $upstreamversion) = @_;
5234 # Called only if we are in (potentially) split brain mode.
5236 # Computes the cache key and looks in the cache.
5237 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
5239 my $splitbrain_cachekey;
5242 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
5243 # we look in the reflog of dgit-intern/quilt-cache
5244 # we look for an entry whose message is the key for the cache lookup
5245 my @cachekey = (qw(dgit), $our_version);
5246 push @cachekey, $upstreamversion;
5247 push @cachekey, $quilt_mode;
5248 push @cachekey, $headref;
5250 push @cachekey, hashfile('fake.dsc');
5252 my $srcshash = Digest::SHA->new(256);
5253 my %sfs = ( %INC, '$0(dgit)' => $0 );
5254 foreach my $sfk (sort keys %sfs) {
5255 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
5256 $srcshash->add($sfk," ");
5257 $srcshash->add(hashfile($sfs{$sfk}));
5258 $srcshash->add("\n");
5260 push @cachekey, $srcshash->hexdigest();
5261 $splitbrain_cachekey = "@cachekey";
5263 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
5265 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
5266 debugcmd "|(probably)",@cmd;
5267 my $child = open GC, "-|"; defined $child or die $!;
5269 chdir '../../..' or die $!;
5270 if (!stat ".git/logs/refs/$splitbraincache") {
5271 $! == ENOENT or die $!;
5272 printdebug ">(no reflog)\n";
5279 printdebug ">| ", $_, "\n" if $debuglevel > 1;
5280 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
5283 quilt_fixup_mkwork($headref);
5284 my $saved = maybe_split_brain_save $headref, $cachehit, "cache-hit";
5285 if ($cachehit ne $headref) {
5286 progress "dgit view: found cached ($saved)";
5287 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
5289 return ($cachehit, $splitbrain_cachekey);
5291 progress "dgit view: found cached, no changes required";
5292 return ($headref, $splitbrain_cachekey);
5294 die $! if GC->error;
5295 failedcmd unless close GC;
5297 printdebug "splitbrain cache miss\n";
5298 return (undef, $splitbrain_cachekey);
5301 sub quilt_fixup_multipatch ($$$) {
5302 my ($clogp, $headref, $upstreamversion) = @_;
5304 progress "examining quilt state (multiple patches, $quilt_mode mode)";
5307 # - honour any existing .pc in case it has any strangeness
5308 # - determine the git commit corresponding to the tip of
5309 # the patch stack (if there is one)
5310 # - if there is such a git commit, convert each subsequent
5311 # git commit into a quilt patch with dpkg-source --commit
5312 # - otherwise convert all the differences in the tree into
5313 # a single git commit
5317 # Our git tree doesn't necessarily contain .pc. (Some versions of
5318 # dgit would include the .pc in the git tree.) If there isn't
5319 # one, we need to generate one by unpacking the patches that we
5322 # We first look for a .pc in the git tree. If there is one, we
5323 # will use it. (This is not the normal case.)
5325 # Otherwise need to regenerate .pc so that dpkg-source --commit
5326 # can work. We do this as follows:
5327 # 1. Collect all relevant .orig from parent directory
5328 # 2. Generate a debian.tar.gz out of
5329 # debian/{patches,rules,source/format,source/options}
5330 # 3. Generate a fake .dsc containing just these fields:
5331 # Format Source Version Files
5332 # 4. Extract the fake .dsc
5333 # Now the fake .dsc has a .pc directory.
5334 # (In fact we do this in every case, because in future we will
5335 # want to search for a good base commit for generating patches.)
5337 # Then we can actually do the dpkg-source --commit
5338 # 1. Make a new working tree with the same object
5339 # store as our main tree and check out the main
5341 # 2. Copy .pc from the fake's extraction, if necessary
5342 # 3. Run dpkg-source --commit
5343 # 4. If the result has changes to debian/, then
5344 # - git add them them
5345 # - git add .pc if we had a .pc in-tree
5347 # 5. If we had a .pc in-tree, delete it, and git commit
5348 # 6. Back in the main tree, fast forward to the new HEAD
5350 # Another situation we may have to cope with is gbp-style
5351 # patches-unapplied trees.
5353 # We would want to detect these, so we know to escape into
5354 # quilt_fixup_gbp. However, this is in general not possible.
5355 # Consider a package with a one patch which the dgit user reverts
5356 # (with git revert or the moral equivalent).
5358 # That is indistinguishable in contents from a patches-unapplied
5359 # tree. And looking at the history to distinguish them is not
5360 # useful because the user might have made a confusing-looking git
5361 # history structure (which ought to produce an error if dgit can't
5362 # cope, not a silent reintroduction of an unwanted patch).
5364 # So gbp users will have to pass an option. But we can usually
5365 # detect their failure to do so: if the tree is not a clean
5366 # patches-applied tree, quilt linearisation fails, but the tree
5367 # _is_ a clean patches-unapplied tree, we can suggest that maybe
5368 # they want --quilt=unapplied.
5370 # To help detect this, when we are extracting the fake dsc, we
5371 # first extract it with --skip-patches, and then apply the patches
5372 # afterwards with dpkg-source --before-build. That lets us save a
5373 # tree object corresponding to .origs.
5375 my $splitbrain_cachekey;
5377 quilt_make_fake_dsc($upstreamversion);
5379 if (quiltmode_splitbrain()) {
5381 ($cachehit, $splitbrain_cachekey) =
5382 quilt_check_splitbrain_cache($headref, $upstreamversion);
5383 return if $cachehit;
5387 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
5389 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
5390 rename $fakexdir, "fake" or die "$fakexdir $!";
5394 remove_stray_gits("source package");
5395 mktree_in_ud_here();
5399 my $unapplied=git_add_write_tree();
5400 printdebug "fake orig tree object $unapplied\n";
5404 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
5406 if (system @bbcmd) {
5407 failedcmd @bbcmd if $? < 0;
5409 failed to apply your git tree's patch stack (from debian/patches/) to
5410 the corresponding upstream tarball(s). Your source tree and .orig
5411 are probably too inconsistent. dgit can only fix up certain kinds of
5412 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
5418 quilt_fixup_mkwork($headref);
5421 if (stat_exists ".pc") {
5423 progress "Tree already contains .pc - will use it then delete it.";
5426 rename '../fake/.pc','.pc' or die $!;
5429 changedir '../fake';
5431 my $oldtiptree=git_add_write_tree();
5432 printdebug "fake o+d/p tree object $unapplied\n";
5433 changedir '../work';
5436 # We calculate some guesswork now about what kind of tree this might
5437 # be. This is mostly for error reporting.
5443 # O = orig, without patches applied
5444 # A = "applied", ie orig with H's debian/patches applied
5445 O2H => quiltify_trees_differ($unapplied,$headref, 1,
5446 \%editedignores, \@unrepres),
5447 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
5448 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
5452 foreach my $b (qw(01 02)) {
5453 foreach my $v (qw(O2H O2A H2A)) {
5454 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
5457 printdebug "differences \@dl @dl.\n";
5460 "$us: base trees orig=%.20s o+d/p=%.20s",
5461 $unapplied, $oldtiptree;
5463 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
5464 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
5465 $dl[0], $dl[1], $dl[3], $dl[4],
5469 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
5471 forceable_fail [qw(unrepresentable)], <<END;
5472 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
5477 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
5478 push @failsuggestion, "This might be a patches-unapplied branch.";
5479 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
5480 push @failsuggestion, "This might be a patches-applied branch.";
5482 push @failsuggestion, "Maybe you need to specify one of".
5483 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
5485 if (quiltmode_splitbrain()) {
5486 quiltify_splitbrain($clogp, $unapplied, $headref,
5487 $diffbits, \%editedignores,
5488 $splitbrain_cachekey);
5492 progress "starting quiltify (multiple patches, $quilt_mode mode)";
5493 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
5495 if (!open P, '>>', ".pc/applied-patches") {
5496 $!==&ENOENT or die $!;
5501 commit_quilty_patch();
5503 if ($mustdeletepc) {
5504 quilt_fixup_delete_pc();
5508 sub quilt_fixup_editor () {
5509 my $descfn = $ENV{$fakeeditorenv};
5510 my $editing = $ARGV[$#ARGV];
5511 open I1, '<', $descfn or die "$descfn: $!";
5512 open I2, '<', $editing or die "$editing: $!";
5513 unlink $editing or die "$editing: $!";
5514 open O, '>', $editing or die "$editing: $!";
5515 while (<I1>) { print O or die $!; } I1->error and die $!;
5518 $copying ||= m/^\-\-\- /;
5519 next unless $copying;
5522 I2->error and die $!;
5527 sub maybe_apply_patches_dirtily () {
5528 return unless $quilt_mode =~ m/gbp|unapplied/;
5529 print STDERR <<END or die $!;
5531 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
5532 dgit: Have to apply the patches - making the tree dirty.
5533 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
5536 $patches_applied_dirtily = 01;
5537 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
5538 runcmd qw(dpkg-source --before-build .);
5541 sub maybe_unapply_patches_again () {
5542 progress "dgit: Unapplying patches again to tidy up the tree."
5543 if $patches_applied_dirtily;
5544 runcmd qw(dpkg-source --after-build .)
5545 if $patches_applied_dirtily & 01;
5547 if $patches_applied_dirtily & 02;
5548 $patches_applied_dirtily = 0;
5551 #----- other building -----
5553 our $clean_using_builder;
5554 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
5555 # clean the tree before building (perhaps invoked indirectly by
5556 # whatever we are using to run the build), rather than separately
5557 # and explicitly by us.
5560 return if $clean_using_builder;
5561 if ($cleanmode eq 'dpkg-source') {
5562 maybe_apply_patches_dirtily();
5563 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
5564 } elsif ($cleanmode eq 'dpkg-source-d') {
5565 maybe_apply_patches_dirtily();
5566 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
5567 } elsif ($cleanmode eq 'git') {
5568 runcmd_ordryrun_local @git, qw(clean -xdf);
5569 } elsif ($cleanmode eq 'git-ff') {
5570 runcmd_ordryrun_local @git, qw(clean -xdff);
5571 } elsif ($cleanmode eq 'check') {
5572 my $leftovers = cmdoutput @git, qw(clean -xdn);
5573 if (length $leftovers) {
5574 print STDERR $leftovers, "\n" or die $!;
5575 fail "tree contains uncommitted files and --clean=check specified";
5577 } elsif ($cleanmode eq 'none') {
5584 badusage "clean takes no additional arguments" if @ARGV;
5587 maybe_unapply_patches_again();
5590 sub build_prep_early () {
5591 our $build_prep_early_done //= 0;
5592 return if $build_prep_early_done++;
5594 badusage "-p is not allowed when building" if defined $package;
5595 my $clogp = parsechangelog();
5596 $isuite = getfield $clogp, 'Distribution';
5597 $package = getfield $clogp, 'Source';
5598 $version = getfield $clogp, 'Version';
5605 build_maybe_quilt_fixup();
5607 my $pat = changespat $version;
5608 foreach my $f (glob "$buildproductsdir/$pat") {
5610 unlink $f or fail "remove old changes file $f: $!";
5612 progress "would remove $f";
5618 sub changesopts_initial () {
5619 my @opts =@changesopts[1..$#changesopts];
5622 sub changesopts_version () {
5623 if (!defined $changes_since_version) {
5624 my @vsns = archive_query('archive_query');
5625 my @quirk = access_quirk();
5626 if ($quirk[0] eq 'backports') {
5627 local $isuite = $quirk[2];
5629 canonicalise_suite();
5630 push @vsns, archive_query('archive_query');
5633 @vsns = map { $_->[0] } @vsns;
5634 @vsns = sort { -version_compare($a, $b) } @vsns;
5635 $changes_since_version = $vsns[0];
5636 progress "changelog will contain changes since $vsns[0]";
5638 $changes_since_version = '_';
5639 progress "package seems new, not specifying -v<version>";
5642 if ($changes_since_version ne '_') {
5643 return ("-v$changes_since_version");
5649 sub changesopts () {
5650 return (changesopts_initial(), changesopts_version());
5653 sub massage_dbp_args ($;$) {
5654 my ($cmd,$xargs) = @_;
5657 # - if we're going to split the source build out so we can
5658 # do strange things to it, massage the arguments to dpkg-buildpackage
5659 # so that the main build doessn't build source (or add an argument
5660 # to stop it building source by default).
5662 # - add -nc to stop dpkg-source cleaning the source tree,
5663 # unless we're not doing a split build and want dpkg-source
5664 # as cleanmode, in which case we can do nothing
5667 # 0 - source will NOT need to be built separately by caller
5668 # +1 - source will need to be built separately by caller
5669 # +2 - source will need to be built separately by caller AND
5670 # dpkg-buildpackage should not in fact be run at all!
5671 debugcmd '#massaging#', @$cmd if $debuglevel>1;
5672 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
5673 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
5674 $clean_using_builder = 1;
5677 # -nc has the side effect of specifying -b if nothing else specified
5678 # and some combinations of -S, -b, et al, are errors, rather than
5679 # later simply overriding earlie. So we need to:
5680 # - search the command line for these options
5681 # - pick the last one
5682 # - perhaps add our own as a default
5683 # - perhaps adjust it to the corresponding non-source-building version
5685 foreach my $l ($cmd, $xargs) {
5687 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
5690 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
5692 if ($need_split_build_invocation) {
5693 printdebug "massage split $dmode.\n";
5694 $r = $dmode =~ m/[S]/ ? +2 :
5695 $dmode =~ y/gGF/ABb/ ? +1 :
5696 $dmode =~ m/[ABb]/ ? 0 :
5699 printdebug "massage done $r $dmode.\n";
5701 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
5707 my $wasdir = must_getcwd();
5713 sub postbuild_mergechanges ($) { # must run with CWD=.. (eg in in_parent)
5714 my ($msg_if_onlyone) = @_;
5715 # If there is only one .changes file, fail with $msg_if_onlyone,
5716 # or if that is undef, be a no-op.
5717 # Returns the changes file to report to the user.
5718 my $pat = changespat $version;
5719 my @changesfiles = glob $pat;
5720 @changesfiles = sort {
5721 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5725 if (@changesfiles==1) {
5726 fail <<END.$msg_if_onlyone if defined $msg_if_onlyone;
5727 only one changes file from build (@changesfiles)
5729 $result = $changesfiles[0];
5730 } elsif (@changesfiles==2) {
5731 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5732 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5733 fail "$l found in binaries changes file $binchanges"
5736 runcmd_ordryrun_local @mergechanges, @changesfiles;
5737 my $multichanges = changespat $version,'multi';
5739 stat_exists $multichanges or fail "$multichanges: $!";
5740 foreach my $cf (glob $pat) {
5741 next if $cf eq $multichanges;
5742 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5745 $result = $multichanges;
5747 fail "wrong number of different changes files (@changesfiles)";
5749 printdone "build successful, results in $result\n" or die $!;
5752 sub midbuild_checkchanges () {
5753 my $pat = changespat $version;
5754 return if $rmchanges;
5755 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5756 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5758 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5759 Suggest you delete @unwanted.
5764 sub midbuild_checkchanges_vanilla ($) {
5766 midbuild_checkchanges() if $wantsrc == 1;
5769 sub postbuild_mergechanges_vanilla ($) {
5771 if ($wantsrc == 1) {
5773 postbuild_mergechanges(undef);
5776 printdone "build successful\n";
5782 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
5783 my $wantsrc = massage_dbp_args \@dbp;
5786 midbuild_checkchanges_vanilla $wantsrc;
5791 push @dbp, changesopts_version();
5792 maybe_apply_patches_dirtily();
5793 runcmd_ordryrun_local @dbp;
5795 maybe_unapply_patches_again();
5796 postbuild_mergechanges_vanilla $wantsrc;
5800 $quilt_mode //= 'gbp';
5806 # gbp can make .origs out of thin air. In my tests it does this
5807 # even for a 1.0 format package, with no origs present. So I
5808 # guess it keys off just the version number. We don't know
5809 # exactly what .origs ought to exist, but let's assume that we
5810 # should run gbp if: the version has an upstream part and the main
5812 my $upstreamversion = upstreamversion $version;
5813 my $origfnpat = srcfn $upstreamversion, '.orig.tar.*';
5814 my $gbp_make_orig = $version =~ m/-/ && !(() = glob "../$origfnpat");
5816 if ($gbp_make_orig) {
5818 $cleanmode = 'none'; # don't do it again
5819 $need_split_build_invocation = 1;
5822 my @dbp = @dpkgbuildpackage;
5824 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
5826 if (!length $gbp_build[0]) {
5827 if (length executable_on_path('git-buildpackage')) {
5828 $gbp_build[0] = qw(git-buildpackage);
5830 $gbp_build[0] = 'gbp buildpackage';
5833 my @cmd = opts_opt_multi_cmd @gbp_build;
5835 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
5837 if ($gbp_make_orig) {
5838 ensuredir '.git/dgit';
5839 my $ok = '.git/dgit/origs-gen-ok';
5840 unlink $ok or $!==&ENOENT or die $!;
5841 my @origs_cmd = @cmd;
5842 push @origs_cmd, qw(--git-cleaner=true);
5843 push @origs_cmd, "--git-prebuild=touch $ok .git/dgit/no-such-dir/ok";
5844 push @origs_cmd, @ARGV;
5846 debugcmd @origs_cmd;
5848 do { local $!; stat_exists $ok; }
5849 or failedcmd @origs_cmd;
5851 dryrun_report @origs_cmd;
5857 midbuild_checkchanges_vanilla $wantsrc;
5859 if (!$clean_using_builder) {
5860 push @cmd, '--git-cleaner=true';
5864 maybe_unapply_patches_again();
5866 push @cmd, changesopts();
5867 runcmd_ordryrun_local @cmd, @ARGV;
5869 postbuild_mergechanges_vanilla $wantsrc;
5871 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
5875 my $our_cleanmode = $cleanmode;
5876 if ($need_split_build_invocation) {
5877 # Pretend that clean is being done some other way. This
5878 # forces us not to try to use dpkg-buildpackage to clean and
5879 # build source all in one go; and instead we run dpkg-source
5880 # (and build_prep() will do the clean since $clean_using_builder
5882 $our_cleanmode = 'ELSEWHERE';
5884 if ($our_cleanmode =~ m/^dpkg-source/) {
5885 # dpkg-source invocation (below) will clean, so build_prep shouldn't
5886 $clean_using_builder = 1;
5889 $sourcechanges = changespat $version,'source';
5891 unlink "../$sourcechanges" or $!==ENOENT
5892 or fail "remove $sourcechanges: $!";
5894 $dscfn = dscfn($version);
5895 if ($our_cleanmode eq 'dpkg-source') {
5896 maybe_apply_patches_dirtily();
5897 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
5899 } elsif ($our_cleanmode eq 'dpkg-source-d') {
5900 maybe_apply_patches_dirtily();
5901 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
5904 my @cmd = (@dpkgsource, qw(-b --));
5907 runcmd_ordryrun_local @cmd, "work";
5908 my @udfiles = <${package}_*>;
5909 changedir "../../..";
5910 foreach my $f (@udfiles) {
5911 printdebug "source copy, found $f\n";
5914 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
5915 $f eq srcfn($version, $&));
5916 printdebug "source copy, found $f - renaming\n";
5917 rename "$ud/$f", "../$f" or $!==ENOENT
5918 or fail "put in place new source file ($f): $!";
5921 my $pwd = must_getcwd();
5922 my $leafdir = basename $pwd;
5924 runcmd_ordryrun_local @cmd, $leafdir;
5927 runcmd_ordryrun_local qw(sh -ec),
5928 'exec >$1; shift; exec "$@"','x',
5929 "../$sourcechanges",
5930 @dpkggenchanges, qw(-S), changesopts();
5934 sub cmd_build_source {
5936 badusage "build-source takes no additional arguments" if @ARGV;
5938 maybe_unapply_patches_again();
5939 printdone "source built, results in $dscfn and $sourcechanges";
5944 midbuild_checkchanges();
5947 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5948 stat_exists $sourcechanges
5949 or fail "$sourcechanges (in parent directory): $!";
5951 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5953 maybe_unapply_patches_again();
5955 postbuild_mergechanges(<<END);
5956 perhaps you need to pass -A ? (sbuild's default is to build only
5957 arch-specific binaries; dgit 1.4 used to override that.)
5962 sub cmd_quilt_fixup {
5963 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5966 build_maybe_quilt_fixup();
5969 sub cmd_import_dsc {
5973 last unless $ARGV[0] =~ m/^-/;
5976 if (m/^--require-valid-signature$/) {
5979 badusage "unknown dgit import-dsc sub-option \`$_'";
5983 badusage "usage: dgit import-dsc .../PATH/TO/.DSC BRANCH" unless @ARGV==2;
5984 my ($dscfn, $dstbranch) = @ARGV;
5986 badusage "dry run makes no sense with import-dsc" unless act_local();
5988 my $force = $dstbranch =~ s/^\+// ? +1 :
5989 $dstbranch =~ s/^\.\.// ? -1 :
5991 my $info = $force ? " $&" : '';
5992 $info = "$dscfn$info";
5994 my $specbranch = $dstbranch;
5995 $dstbranch = "refs/heads/$dstbranch" unless $dstbranch =~ m#^refs/#;
5996 $dstbranch = cmdoutput @git, qw(check-ref-format --normalize), $dstbranch;
5998 my @symcmd = (@git, qw(symbolic-ref -q HEAD));
5999 my $chead = cmdoutput_errok @symcmd;
6000 defined $chead or $?==256 or failedcmd @symcmd;
6002 fail "$dstbranch is checked out - will not update it"
6003 if defined $chead and $chead eq $dstbranch;
6005 my $oldhash = git_get_ref $dstbranch;
6007 open D, "<", $dscfn or fail "open import .dsc ($dscfn): $!";
6008 $dscdata = do { local $/ = undef; <D>; };
6009 D->error and fail "read $dscfn: $!";
6012 # we don't normally need this so import it here
6013 use Dpkg::Source::Package;
6014 my $dp = new Dpkg::Source::Package filename => $dscfn,
6015 require_valid_signature => $needsig;
6017 local $SIG{__WARN__} = sub {
6019 return unless $needsig;
6020 fail "import-dsc signature check failed";
6022 if (!$dp->is_signed()) {
6023 warn "$us: warning: importing unsigned .dsc\n";
6025 my $r = $dp->check_signature();
6026 die "->check_signature => $r" if $needsig && $r;
6032 $package = getfield $dsc, 'Source';
6034 parse_dsc_field($dsc, "Dgit metadata in .dsc")
6035 unless forceing [qw(import-dsc-with-dgit-field)];
6037 if (defined $dsc_hash) {
6038 progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
6039 resolve_dsc_field_commit undef, undef;
6041 if (defined $dsc_hash) {
6042 my @cmd = (qw(sh -ec),
6043 "echo $dsc_hash | git cat-file --batch-check");
6044 my $objgot = cmdoutput @cmd;
6045 if ($objgot =~ m#^\w+ missing\b#) {
6047 .dsc contains Dgit field referring to object $dsc_hash
6048 Your git tree does not have that object. Try `git fetch' from a
6049 plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
6052 if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
6054 progress "Not fast forward, forced update.";
6056 fail "Not fast forward to $dsc_hash";
6059 @cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
6060 $dstbranch, $dsc_hash);
6062 progress "dgit: import-dsc updated git ref $dstbranch";
6067 Branch $dstbranch already exists
6068 Specify ..$specbranch for a pseudo-merge, binding in existing history
6069 Specify +$specbranch to overwrite, discarding existing history
6071 if $oldhash && !$force;
6073 my @dfi = dsc_files_info();
6074 foreach my $fi (@dfi) {
6075 my $f = $fi->{Filename};
6077 next if lstat $here;
6078 fail "stat $here: $!" unless $! == ENOENT;
6080 if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
6082 } elsif ($dscfn =~ m#^/#) {
6085 fail "cannot import $dscfn which seems to be inside working tree!";
6087 $there =~ s#/+[^/]+$## or
6088 fail "cannot import $dscfn which seems to not have a basename";
6090 symlink $there, $here or fail "symlink $there to $here: $!";
6091 progress "made symlink $here -> $there";
6092 # print STDERR Dumper($fi);
6094 my @mergeinputs = generate_commits_from_dsc();
6095 die unless @mergeinputs == 1;
6097 my $newhash = $mergeinputs[0]{Commit};
6101 progress "Import, forced update - synthetic orphan git history.";
6102 } elsif ($force < 0) {
6103 progress "Import, merging.";
6104 my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
6105 my $version = getfield $dsc, 'Version';
6106 my $clogp = commit_getclogp $newhash;
6107 my $authline = clogp_authline $clogp;
6108 $newhash = make_commit_text <<END;
6115 Merge $package ($version) import into $dstbranch
6118 die; # caught earlier
6122 my @cmd = (@git, qw(update-ref -m), "dgit import-dsc: $info",
6123 $dstbranch, $newhash);
6125 progress "dgit: import-dsc results are in in git ref $dstbranch";
6128 sub cmd_archive_api_query {
6129 badusage "need only 1 subpath argument" unless @ARGV==1;
6130 my ($subpath) = @ARGV;
6131 my @cmd = archive_api_query_cmd($subpath);
6134 exec @cmd or fail "exec curl: $!\n";
6137 sub cmd_clone_dgit_repos_server {
6138 badusage "need destination argument" unless @ARGV==1;
6139 my ($destdir) = @ARGV;
6140 $package = '_dgit-repos-server';
6141 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
6143 exec @cmd or fail "exec git clone: $!\n";
6146 sub cmd_setup_mergechangelogs {
6147 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6148 setup_mergechangelogs(1);
6151 sub cmd_setup_useremail {
6152 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
6156 sub cmd_setup_new_tree {
6157 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
6161 #---------- argument parsing and main program ----------
6164 print "dgit version $our_version\n" or die $!;
6168 our (%valopts_long, %valopts_short);
6171 sub defvalopt ($$$$) {
6172 my ($long,$short,$val_re,$how) = @_;
6173 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
6174 $valopts_long{$long} = $oi;
6175 $valopts_short{$short} = $oi;
6176 # $how subref should:
6177 # do whatever assignemnt or thing it likes with $_[0]
6178 # if the option should not be passed on to remote, @rvalopts=()
6179 # or $how can be a scalar ref, meaning simply assign the value
6182 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
6183 defvalopt '--distro', '-d', '.+', \$idistro;
6184 defvalopt '', '-k', '.+', \$keyid;
6185 defvalopt '--existing-package','', '.*', \$existing_package;
6186 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
6187 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
6188 defvalopt '--package', '-p', $package_re, \$package;
6189 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
6191 defvalopt '', '-C', '.+', sub {
6192 ($changesfile) = (@_);
6193 if ($changesfile =~ s#^(.*)/##) {
6194 $buildproductsdir = $1;
6198 defvalopt '--initiator-tempdir','','.*', sub {
6199 ($initiator_tempdir) = (@_);
6200 $initiator_tempdir =~ m#^/# or
6201 badusage "--initiator-tempdir must be used specify an".
6202 " absolute, not relative, directory."
6208 if (defined $ENV{'DGIT_SSH'}) {
6209 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
6210 } elsif (defined $ENV{'GIT_SSH'}) {
6211 @ssh = ($ENV{'GIT_SSH'});
6219 if (!defined $val) {
6220 badusage "$what needs a value" unless @ARGV;
6222 push @rvalopts, $val;
6224 badusage "bad value \`$val' for $what" unless
6225 $val =~ m/^$oi->{Re}$(?!\n)/s;
6226 my $how = $oi->{How};
6227 if (ref($how) eq 'SCALAR') {
6232 push @ropts, @rvalopts;
6236 last unless $ARGV[0] =~ m/^-/;
6240 if (m/^--dry-run$/) {
6243 } elsif (m/^--damp-run$/) {
6246 } elsif (m/^--no-sign$/) {
6249 } elsif (m/^--help$/) {
6251 } elsif (m/^--version$/) {
6253 } elsif (m/^--new$/) {
6256 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
6257 ($om = $opts_opt_map{$1}) &&
6261 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
6262 !$opts_opt_cmdonly{$1} &&
6263 ($om = $opts_opt_map{$1})) {
6266 } elsif (m/^--(gbp|dpm)$/s) {
6267 push @ropts, "--quilt=$1";
6269 } elsif (m/^--ignore-dirty$/s) {
6272 } elsif (m/^--no-quilt-fixup$/s) {
6274 $quilt_mode = 'nocheck';
6275 } elsif (m/^--no-rm-on-error$/s) {
6278 } elsif (m/^--overwrite$/s) {
6280 $overwrite_version = '';
6281 } elsif (m/^--overwrite=(.+)$/s) {
6283 $overwrite_version = $1;
6284 } elsif (m/^--dep14tag$/s) {
6286 $dodep14tag= 'want';
6287 } elsif (m/^--no-dep14tag$/s) {
6290 } elsif (m/^--always-dep14tag$/s) {
6292 $dodep14tag= 'always';
6293 } elsif (m/^--delayed=(\d+)$/s) {
6296 } elsif (m/^--dgit-view-save=(.+)$/s) {
6298 $split_brain_save = $1;
6299 $split_brain_save =~ s#^(?!refs/)#refs/heads/#;
6300 } elsif (m/^--(no-)?rm-old-changes$/s) {
6303 } elsif (m/^--deliberately-($deliberately_re)$/s) {
6305 push @deliberatelies, $&;
6306 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
6310 } elsif (m/^--force-/) {
6312 "$us: warning: ignoring unknown force option $_\n";
6314 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
6315 # undocumented, for testing
6317 $tagformat_want = [ $1, 'command line', 1 ];
6318 # 1 menas overrides distro configuration
6319 } elsif (m/^--always-split-source-build$/s) {
6320 # undocumented, for testing
6322 $need_split_build_invocation = 1;
6323 } elsif (m/^--config-lookup-explode=(.+)$/s) {
6324 # undocumented, for testing
6326 $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
6327 # ^ it's supposed to be an array ref
6328 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
6329 $val = $2 ? $' : undef; #';
6330 $valopt->($oi->{Long});
6332 badusage "unknown long option \`$_'";
6339 } elsif (s/^-L/-/) {
6342 } elsif (s/^-h/-/) {
6344 } elsif (s/^-D/-/) {
6348 } elsif (s/^-N/-/) {
6353 push @changesopts, $_;
6355 } elsif (s/^-wn$//s) {
6357 $cleanmode = 'none';
6358 } elsif (s/^-wg$//s) {
6361 } elsif (s/^-wgf$//s) {
6363 $cleanmode = 'git-ff';
6364 } elsif (s/^-wd$//s) {
6366 $cleanmode = 'dpkg-source';
6367 } elsif (s/^-wdd$//s) {
6369 $cleanmode = 'dpkg-source-d';
6370 } elsif (s/^-wc$//s) {
6372 $cleanmode = 'check';
6373 } elsif (s/^-c([^=]*)\=(.*)$//s) {
6374 push @git, '-c', $&;
6375 $gitcfgs{cmdline}{$1} = [ $2 ];
6376 } elsif (s/^-c([^=]+)$//s) {
6377 push @git, '-c', $&;
6378 $gitcfgs{cmdline}{$1} = [ 'true' ];
6379 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
6381 $val = undef unless length $val;
6382 $valopt->($oi->{Short});
6385 badusage "unknown short option \`$_'";
6392 sub check_env_sanity () {
6393 my $blocked = new POSIX::SigSet;
6394 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
6397 foreach my $name (qw(PIPE CHLD)) {
6398 my $signame = "SIG$name";
6399 my $signum = eval "POSIX::$signame" // die;
6400 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
6401 die "$signame is set to something other than SIG_DFL\n";
6402 $blocked->ismember($signum) and
6403 die "$signame is blocked\n";
6409 On entry to dgit, $@
6410 This is a bug produced by something in in your execution environment.
6416 sub parseopts_late_defaults () {
6417 foreach my $k (keys %opts_opt_map) {
6418 my $om = $opts_opt_map{$k};
6420 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
6422 badcfg "cannot set command for $k"
6423 unless length $om->[0];
6427 foreach my $c (access_cfg_cfgs("opts-$k")) {
6429 map { $_ ? @$_ : () }
6430 map { $gitcfgs{$_}{$c} }
6431 reverse @gitcfgsources;
6432 printdebug "CL $c ", (join " ", map { shellquote } @vl),
6433 "\n" if $debuglevel >= 4;
6435 badcfg "cannot configure options for $k"
6436 if $opts_opt_cmdonly{$k};
6437 my $insertpos = $opts_cfg_insertpos{$k};
6438 @$om = ( @$om[0..$insertpos-1],
6440 @$om[$insertpos..$#$om] );
6444 if (!defined $rmchanges) {
6445 local $access_forpush;
6446 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
6449 if (!defined $quilt_mode) {
6450 local $access_forpush;
6451 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
6452 // access_cfg('quilt-mode', 'RETURN-UNDEF')
6454 $quilt_mode =~ m/^($quilt_modes_re)$/
6455 or badcfg "unknown quilt-mode \`$quilt_mode'";
6459 if (!defined $dodep14tag) {
6460 local $access_forpush;
6461 $dodep14tag = access_cfg('dep14tag', 'RETURN-UNDEF') // 'want';
6462 $dodep14tag =~ m/^($dodep14tag_re)$/
6463 or badcfg "unknown dep14tag setting \`$dodep14tag'";
6467 $need_split_build_invocation ||= quiltmode_splitbrain();
6469 if (!defined $cleanmode) {
6470 local $access_forpush;
6471 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
6472 $cleanmode //= 'dpkg-source';
6474 badcfg "unknown clean-mode \`$cleanmode'" unless
6475 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
6479 if ($ENV{$fakeeditorenv}) {
6481 quilt_fixup_editor();
6488 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
6489 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
6490 if $dryrun_level == 1;
6492 print STDERR $helpmsg or die $!;
6495 my $cmd = shift @ARGV;
6498 my $pre_fn = ${*::}{"pre_$cmd"};
6499 $pre_fn->() if $pre_fn;
6501 my $fn = ${*::}{"cmd_$cmd"};
6502 $fn or badusage "unknown operation $cmd";