3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 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);
43 our $our_version = 'UNRELEASED'; ###substituted###
45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
48 our $isuite = 'unstable';
54 our $dryrun_level = 0;
56 our $buildproductsdir = '..';
62 our $existing_package = 'dpkg';
64 our $changes_since_version;
66 our $overwrite_version; # undef: not specified; '': check changelog
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
81 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
82 our $splitbraincache = 'dgit-intern/quilt-cache';
85 our (@dget) = qw(dget);
86 our (@curl) = qw(curl -f);
87 our (@dput) = qw(dput);
88 our (@debsign) = qw(debsign);
90 our (@sbuild) = qw(sbuild);
92 our (@dgit) = qw(dgit);
93 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
94 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
95 our (@dpkggenchanges) = qw(dpkg-genchanges);
96 our (@mergechanges) = qw(mergechanges -f);
98 our (@changesopts) = ('');
100 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
103 'debsign' => \@debsign,
105 'sbuild' => \@sbuild,
109 'dpkg-source' => \@dpkgsource,
110 'dpkg-buildpackage' => \@dpkgbuildpackage,
111 'dpkg-genchanges' => \@dpkggenchanges,
113 'ch' => \@changesopts,
114 'mergechanges' => \@mergechanges);
116 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
117 our %opts_cfg_insertpos = map {
119 scalar @{ $opts_opt_map{$_} }
120 } keys %opts_opt_map;
122 sub finalise_opts_opts();
128 our $supplementary_message = '';
129 our $need_split_build_invocation = 0;
130 our $split_brain = 0;
134 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
137 our $remotename = 'dgit';
138 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
143 my ($v,$distro) = @_;
144 return $tagformatfn->($v, $distro);
147 sub debiantag_maintview ($$) {
148 my ($v,$distro) = @_;
153 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
155 sub lbranch () { return "$branchprefix/$csuite"; }
156 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
157 sub lref () { return "refs/heads/".lbranch(); }
158 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
159 sub rrref () { return server_ref($csuite); }
161 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
162 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
164 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
165 # locally fetched refs because they have unhelpful names and clutter
166 # up gitk etc. So we track whether we have "used up" head ref (ie,
167 # whether we have made another local ref which refers to this object).
169 # (If we deleted them unconditionally, then we might end up
170 # re-fetching the same git objects each time dgit fetch was run.)
172 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
173 # in git_fetch_us to fetch the refs in question, and possibly a call
174 # to lrfetchref_used.
176 our (%lrfetchrefs_f, %lrfetchrefs_d);
177 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
179 sub lrfetchref_used ($) {
180 my ($fullrefname) = @_;
181 my $objid = $lrfetchrefs_f{$fullrefname};
182 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
193 return "${package}_".(stripepoch $vsn).$sfx
198 return srcfn($vsn,".dsc");
201 sub changespat ($;$) {
202 my ($vsn, $arch) = @_;
203 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
212 foreach my $f (@end) {
214 print STDERR "$us: cleanup: $@" if length $@;
218 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
220 sub no_such_package () {
221 print STDERR "$us: package $package does not exist in suite $isuite\n";
227 printdebug "CD $newdir\n";
228 chdir $newdir or confess "chdir: $newdir: $!";
231 sub deliberately ($) {
233 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
236 sub deliberately_not_fast_forward () {
237 foreach (qw(not-fast-forward fresh-repo)) {
238 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
242 sub quiltmode_splitbrain () {
243 $quilt_mode =~ m/gbp|dpm|unapplied/;
246 #---------- remote protocol support, common ----------
248 # remote push initiator/responder protocol:
249 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
250 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
251 # < dgit-remote-push-ready <actual-proto-vsn>
258 # > supplementary-message NBYTES # $protovsn >= 3
263 # > file parsed-changelog
264 # [indicates that output of dpkg-parsechangelog follows]
265 # > data-block NBYTES
266 # > [NBYTES bytes of data (no newline)]
267 # [maybe some more blocks]
276 # > param head DGIT-VIEW-HEAD
277 # > param csuite SUITE
278 # > param tagformat old|new
279 # > param maint-view MAINT-VIEW-HEAD
281 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
282 # # goes into tag, for replay prevention
285 # [indicates that signed tag is wanted]
286 # < data-block NBYTES
287 # < [NBYTES bytes of data (no newline)]
288 # [maybe some more blocks]
292 # > want signed-dsc-changes
293 # < data-block NBYTES [transfer of signed dsc]
295 # < data-block NBYTES [transfer of signed changes]
303 sub i_child_report () {
304 # Sees if our child has died, and reap it if so. Returns a string
305 # describing how it died if it failed, or undef otherwise.
306 return undef unless $i_child_pid;
307 my $got = waitpid $i_child_pid, WNOHANG;
308 return undef if $got <= 0;
309 die unless $got == $i_child_pid;
310 $i_child_pid = undef;
311 return undef unless $?;
312 return "build host child ".waitstatusmsg();
317 fail "connection lost: $!" if $fh->error;
318 fail "protocol violation; $m not expected";
321 sub badproto_badread ($$) {
323 fail "connection lost: $!" if $!;
324 my $report = i_child_report();
325 fail $report if defined $report;
326 badproto $fh, "eof (reading $wh)";
329 sub protocol_expect (&$) {
330 my ($match, $fh) = @_;
333 defined && chomp or badproto_badread $fh, "protocol message";
341 badproto $fh, "\`$_'";
344 sub protocol_send_file ($$) {
345 my ($fh, $ourfn) = @_;
346 open PF, "<", $ourfn or die "$ourfn: $!";
349 my $got = read PF, $d, 65536;
350 die "$ourfn: $!" unless defined $got;
352 print $fh "data-block ".length($d)."\n" or die $!;
353 print $fh $d or die $!;
355 PF->error and die "$ourfn $!";
356 print $fh "data-end\n" or die $!;
360 sub protocol_read_bytes ($$) {
361 my ($fh, $nbytes) = @_;
362 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
364 my $got = read $fh, $d, $nbytes;
365 $got==$nbytes or badproto_badread $fh, "data block";
369 sub protocol_receive_file ($$) {
370 my ($fh, $ourfn) = @_;
371 printdebug "() $ourfn\n";
372 open PF, ">", $ourfn or die "$ourfn: $!";
374 my ($y,$l) = protocol_expect {
375 m/^data-block (.*)$/ ? (1,$1) :
376 m/^data-end$/ ? (0,) :
380 my $d = protocol_read_bytes $fh, $l;
381 print PF $d or die $!;
386 #---------- remote protocol support, responder ----------
388 sub responder_send_command ($) {
390 return unless $we_are_responder;
391 # called even without $we_are_responder
392 printdebug ">> $command\n";
393 print PO $command, "\n" or die $!;
396 sub responder_send_file ($$) {
397 my ($keyword, $ourfn) = @_;
398 return unless $we_are_responder;
399 printdebug "]] $keyword $ourfn\n";
400 responder_send_command "file $keyword";
401 protocol_send_file \*PO, $ourfn;
404 sub responder_receive_files ($@) {
405 my ($keyword, @ourfns) = @_;
406 die unless $we_are_responder;
407 printdebug "[[ $keyword @ourfns\n";
408 responder_send_command "want $keyword";
409 foreach my $fn (@ourfns) {
410 protocol_receive_file \*PI, $fn;
413 protocol_expect { m/^files-end$/ } \*PI;
416 #---------- remote protocol support, initiator ----------
418 sub initiator_expect (&) {
420 protocol_expect { &$match } \*RO;
423 #---------- end remote code ----------
426 if ($we_are_responder) {
428 responder_send_command "progress ".length($m) or die $!;
429 print PO $m or die $!;
439 $ua = LWP::UserAgent->new();
443 progress "downloading $what...";
444 my $r = $ua->get(@_) or die $!;
445 return undef if $r->code == 404;
446 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
447 return $r->decoded_content(charset => 'none');
450 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
455 failedcmd @_ if system @_;
458 sub act_local () { return $dryrun_level <= 1; }
459 sub act_scary () { return !$dryrun_level; }
462 if (!$dryrun_level) {
463 progress "dgit ok: @_";
465 progress "would be ok: @_ (but dry run only)";
470 printcmd(\*STDERR,$debugprefix."#",@_);
473 sub runcmd_ordryrun {
481 sub runcmd_ordryrun_local {
490 my ($first_shell, @cmd) = @_;
491 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
494 our $helpmsg = <<END;
496 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
497 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
498 dgit [dgit-opts] build [dpkg-buildpackage-opts]
499 dgit [dgit-opts] sbuild [sbuild-opts]
500 dgit [dgit-opts] push [dgit-opts] [suite]
501 dgit [dgit-opts] rpush build-host:build-dir ...
502 important dgit options:
503 -k<keyid> sign tag and package with <keyid> instead of default
504 --dry-run -n do not change anything, but go through the motions
505 --damp-run -L like --dry-run but make local changes, without signing
506 --new -N allow introducing a new package
507 --debug -D increase debug level
508 -c<name>=<value> set git config option (used directly by dgit too)
511 our $later_warning_msg = <<END;
512 Perhaps the upload is stuck in incoming. Using the version from git.
516 print STDERR "$us: @_\n", $helpmsg or die $!;
521 @ARGV or badusage "too few arguments";
522 return scalar shift @ARGV;
526 print $helpmsg or die $!;
530 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
532 our %defcfg = ('dgit.default.distro' => 'debian',
533 'dgit.default.username' => '',
534 'dgit.default.archive-query-default-component' => 'main',
535 'dgit.default.ssh' => 'ssh',
536 'dgit.default.archive-query' => 'madison:',
537 'dgit.default.sshpsql-dbname' => 'service=projectb',
538 'dgit.default.dgit-tag-format' => 'old,new,maint',
539 # old means "repo server accepts pushes with old dgit tags"
540 # new means "repo server accepts pushes with new dgit tags"
541 # maint means "repo server accepts split brain pushes"
542 # hist means "repo server may have old pushes without new tag"
543 # ("hist" is implied by "old")
544 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
545 'dgit-distro.debian.git-check' => 'url',
546 'dgit-distro.debian.git-check-suffix' => '/info/refs',
547 'dgit-distro.debian.new-private-pushers' => 't',
548 'dgit-distro.debian.dgit-tag-format' => 'new',
549 'dgit-distro.debian/push.git-url' => '',
550 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
551 'dgit-distro.debian/push.git-user-force' => 'dgit',
552 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
553 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
554 'dgit-distro.debian/push.git-create' => 'true',
555 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
556 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
557 # 'dgit-distro.debian.archive-query-tls-key',
558 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
559 # ^ this does not work because curl is broken nowadays
560 # Fixing #790093 properly will involve providing providing the key
561 # in some pacagke and maybe updating these paths.
563 # 'dgit-distro.debian.archive-query-tls-curl-args',
564 # '--ca-path=/etc/ssl/ca-debian',
565 # ^ this is a workaround but works (only) on DSA-administered machines
566 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
567 'dgit-distro.debian.git-url-suffix' => '',
568 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
569 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
570 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
571 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
572 'dgit-distro.ubuntu.git-check' => 'false',
573 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
574 'dgit-distro.test-dummy.ssh' => "$td/ssh",
575 'dgit-distro.test-dummy.username' => "alice",
576 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
577 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
578 'dgit-distro.test-dummy.git-url' => "$td/git",
579 'dgit-distro.test-dummy.git-host' => "git",
580 'dgit-distro.test-dummy.git-path' => "$td/git",
581 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
582 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
583 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
584 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
589 sub git_slurp_config () {
590 local ($debuglevel) = $debuglevel-2;
593 my @cmd = (@git, qw(config -z --get-regexp .*));
596 open GITS, "-|", @cmd or die $!;
599 printdebug "=> ", (messagequote $_), "\n";
601 push @{ $gitcfg{$`} }, $'; #';
605 or ($!==0 && $?==256)
609 sub git_get_config ($) {
612 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
615 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
621 return undef if $c =~ /RETURN-UNDEF/;
622 my $v = git_get_config($c);
623 return $v if defined $v;
624 my $dv = $defcfg{$c};
625 return $dv if defined $dv;
627 badcfg "need value for one of: @_\n".
628 "$us: distro or suite appears not to be (properly) supported";
631 sub access_basedistro () {
632 if (defined $idistro) {
635 return cfg("dgit-suite.$isuite.distro",
636 "dgit.default.distro");
640 sub access_quirk () {
641 # returns (quirk name, distro to use instead or undef, quirk-specific info)
642 my $basedistro = access_basedistro();
643 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
645 if (defined $backports_quirk) {
646 my $re = $backports_quirk;
647 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
649 $re =~ s/\%/([-0-9a-z_]+)/
650 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
651 if ($isuite =~ m/^$re$/) {
652 return ('backports',"$basedistro-backports",$1);
655 return ('none',undef);
660 sub parse_cfg_bool ($$$) {
661 my ($what,$def,$v) = @_;
664 $v =~ m/^[ty1]/ ? 1 :
665 $v =~ m/^[fn0]/ ? 0 :
666 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
669 sub access_forpush_config () {
670 my $d = access_basedistro();
674 parse_cfg_bool('new-private-pushers', 0,
675 cfg("dgit-distro.$d.new-private-pushers",
678 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
681 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
682 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
683 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
684 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
687 sub access_forpush () {
688 $access_forpush //= access_forpush_config();
689 return $access_forpush;
693 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
694 badcfg "pushing but distro is configured readonly"
695 if access_forpush_config() eq '0';
697 $supplementary_message = <<'END' unless $we_are_responder;
698 Push failed, before we got started.
699 You can retry the push, after fixing the problem, if you like.
701 finalise_opts_opts();
705 finalise_opts_opts();
708 sub supplementary_message ($) {
710 if (!$we_are_responder) {
711 $supplementary_message = $msg;
713 } elsif ($protovsn >= 3) {
714 responder_send_command "supplementary-message ".length($msg)
716 print PO $msg or die $!;
720 sub access_distros () {
721 # Returns list of distros to try, in order
724 # 0. `instead of' distro name(s) we have been pointed to
725 # 1. the access_quirk distro, if any
726 # 2a. the user's specified distro, or failing that } basedistro
727 # 2b. the distro calculated from the suite }
728 my @l = access_basedistro();
730 my (undef,$quirkdistro) = access_quirk();
731 unshift @l, $quirkdistro;
732 unshift @l, $instead_distro;
733 @l = grep { defined } @l;
735 if (access_forpush()) {
736 @l = map { ("$_/push", $_) } @l;
741 sub access_cfg_cfgs (@) {
744 # The nesting of these loops determines the search order. We put
745 # the key loop on the outside so that we search all the distros
746 # for each key, before going on to the next key. That means that
747 # if access_cfg is called with a more specific, and then a less
748 # specific, key, an earlier distro can override the less specific
749 # without necessarily overriding any more specific keys. (If the
750 # distro wants to override the more specific keys it can simply do
751 # so; whereas if we did the loop the other way around, it would be
752 # impossible to for an earlier distro to override a less specific
753 # key but not the more specific ones without restating the unknown
754 # values of the more specific keys.
757 # We have to deal with RETURN-UNDEF specially, so that we don't
758 # terminate the search prematurely.
760 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
763 foreach my $d (access_distros()) {
764 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
766 push @cfgs, map { "dgit.default.$_" } @realkeys;
773 my (@cfgs) = access_cfg_cfgs(@keys);
774 my $value = cfg(@cfgs);
778 sub access_cfg_bool ($$) {
779 my ($def, @keys) = @_;
780 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
783 sub string_to_ssh ($) {
785 if ($spec =~ m/\s/) {
786 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
792 sub access_cfg_ssh () {
793 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
794 if (!defined $gitssh) {
797 return string_to_ssh $gitssh;
801 sub access_runeinfo ($) {
803 return ": dgit ".access_basedistro()." $info ;";
806 sub access_someuserhost ($) {
808 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
809 defined($user) && length($user) or
810 $user = access_cfg("$some-user",'username');
811 my $host = access_cfg("$some-host");
812 return length($user) ? "$user\@$host" : $host;
815 sub access_gituserhost () {
816 return access_someuserhost('git');
819 sub access_giturl (;$) {
821 my $url = access_cfg('git-url','RETURN-UNDEF');
824 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
825 return undef unless defined $proto;
828 access_gituserhost().
829 access_cfg('git-path');
831 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
834 return "$url/$package$suffix";
837 sub parsecontrolfh ($$;$) {
838 my ($fh, $desc, $allowsigned) = @_;
839 our $dpkgcontrolhash_noissigned;
842 my %opts = ('name' => $desc);
843 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
844 $c = Dpkg::Control::Hash->new(%opts);
845 $c->parse($fh,$desc) or die "parsing of $desc failed";
846 last if $allowsigned;
847 last if $dpkgcontrolhash_noissigned;
848 my $issigned= $c->get_option('is_pgp_signed');
849 if (!defined $issigned) {
850 $dpkgcontrolhash_noissigned= 1;
851 seek $fh, 0,0 or die "seek $desc: $!";
852 } elsif ($issigned) {
853 fail "control file $desc is (already) PGP-signed. ".
854 " Note that dgit push needs to modify the .dsc and then".
855 " do the signature itself";
864 my ($file, $desc) = @_;
865 my $fh = new IO::Handle;
866 open $fh, '<', $file or die "$file: $!";
867 my $c = parsecontrolfh($fh,$desc);
868 $fh->error and die $!;
874 my ($dctrl,$field) = @_;
875 my $v = $dctrl->{$field};
876 return $v if defined $v;
877 fail "missing field $field in ".$dctrl->get_option('name');
881 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
882 my $p = new IO::Handle;
883 my @cmd = (qw(dpkg-parsechangelog), @_);
884 open $p, '-|', @cmd or die $!;
886 $?=0; $!=0; close $p or failedcmd @cmd;
890 sub commit_getclogp ($) {
891 # Returns the parsed changelog hashref for a particular commit
893 our %commit_getclogp_memo;
894 my $memo = $commit_getclogp_memo{$objid};
895 return $memo if $memo;
897 my $mclog = ".git/dgit/clog-$objid";
898 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
899 "$objid:debian/changelog";
900 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
905 defined $d or fail "getcwd failed: $!";
911 sub archive_query ($) {
913 my $query = access_cfg('archive-query','RETURN-UNDEF');
914 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
917 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
920 sub pool_dsc_subpath ($$) {
921 my ($vsn,$component) = @_; # $package is implict arg
922 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
923 return "/pool/$component/$prefix/$package/".dscfn($vsn);
926 #---------- `ftpmasterapi' archive query method (nascent) ----------
928 sub archive_api_query_cmd ($) {
930 my @cmd = qw(curl -sS);
931 my $url = access_cfg('archive-query-url');
932 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
934 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
935 foreach my $key (split /\:/, $keys) {
936 $key =~ s/\%HOST\%/$host/g;
938 fail "for $url: stat $key: $!" unless $!==ENOENT;
941 fail "config requested specific TLS key but do not know".
942 " how to get curl to use exactly that EE key ($key)";
943 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
944 # # Sadly the above line does not work because of changes
945 # # to gnutls. The real fix for #790093 may involve
946 # # new curl options.
949 # Fixing #790093 properly will involve providing a value
950 # for this on clients.
951 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
952 push @cmd, split / /, $kargs if defined $kargs;
954 push @cmd, $url.$subpath;
960 my ($data, $subpath) = @_;
961 badcfg "ftpmasterapi archive query method takes no data part"
963 my @cmd = archive_api_query_cmd($subpath);
964 my $json = cmdoutput @cmd;
965 return decode_json($json);
968 sub canonicalise_suite_ftpmasterapi () {
969 my ($proto,$data) = @_;
970 my $suites = api_query($data, 'suites');
972 foreach my $entry (@$suites) {
974 my $v = $entry->{$_};
975 defined $v && $v eq $isuite;
977 push @matched, $entry;
979 fail "unknown suite $isuite" unless @matched;
982 @matched==1 or die "multiple matches for suite $isuite\n";
983 $cn = "$matched[0]{codename}";
984 defined $cn or die "suite $isuite info has no codename\n";
985 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
987 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
992 sub archive_query_ftpmasterapi () {
993 my ($proto,$data) = @_;
994 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
996 my $digester = Digest::SHA->new(256);
997 foreach my $entry (@$info) {
999 my $vsn = "$entry->{version}";
1000 my ($ok,$msg) = version_check $vsn;
1001 die "bad version: $msg\n" unless $ok;
1002 my $component = "$entry->{component}";
1003 $component =~ m/^$component_re$/ or die "bad component";
1004 my $filename = "$entry->{filename}";
1005 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1006 or die "bad filename";
1007 my $sha256sum = "$entry->{sha256sum}";
1008 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1009 push @rows, [ $vsn, "/pool/$component/$filename",
1010 $digester, $sha256sum ];
1012 die "bad ftpmaster api response: $@\n".Dumper($entry)
1015 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1019 #---------- `madison' archive query method ----------
1021 sub archive_query_madison {
1022 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1025 sub madison_get_parse {
1026 my ($proto,$data) = @_;
1027 die unless $proto eq 'madison';
1028 if (!length $data) {
1029 $data= access_cfg('madison-distro','RETURN-UNDEF');
1030 $data //= access_basedistro();
1032 $rmad{$proto,$data,$package} ||= cmdoutput
1033 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1034 my $rmad = $rmad{$proto,$data,$package};
1037 foreach my $l (split /\n/, $rmad) {
1038 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1039 \s*( [^ \t|]+ )\s* \|
1040 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1041 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1042 $1 eq $package or die "$rmad $package ?";
1049 $component = access_cfg('archive-query-default-component');
1051 $5 eq 'source' or die "$rmad ?";
1052 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1054 return sort { -version_compare($a->[0],$b->[0]); } @out;
1057 sub canonicalise_suite_madison {
1058 # madison canonicalises for us
1059 my @r = madison_get_parse(@_);
1061 "unable to canonicalise suite using package $package".
1062 " which does not appear to exist in suite $isuite;".
1063 " --existing-package may help";
1067 #---------- `sshpsql' archive query method ----------
1070 my ($data,$runeinfo,$sql) = @_;
1071 if (!length $data) {
1072 $data= access_someuserhost('sshpsql').':'.
1073 access_cfg('sshpsql-dbname');
1075 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1076 my ($userhost,$dbname) = ($`,$'); #';
1078 my @cmd = (access_cfg_ssh, $userhost,
1079 access_runeinfo("ssh-psql $runeinfo").
1080 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1081 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1083 open P, "-|", @cmd or die $!;
1086 printdebug(">|$_|\n");
1089 $!=0; $?=0; close P or failedcmd @cmd;
1091 my $nrows = pop @rows;
1092 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1093 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1094 @rows = map { [ split /\|/, $_ ] } @rows;
1095 my $ncols = scalar @{ shift @rows };
1096 die if grep { scalar @$_ != $ncols } @rows;
1100 sub sql_injection_check {
1101 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1104 sub archive_query_sshpsql ($$) {
1105 my ($proto,$data) = @_;
1106 sql_injection_check $isuite, $package;
1107 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1108 SELECT source.version, component.name, files.filename, files.sha256sum
1110 JOIN src_associations ON source.id = src_associations.source
1111 JOIN suite ON suite.id = src_associations.suite
1112 JOIN dsc_files ON dsc_files.source = source.id
1113 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1114 JOIN component ON component.id = files_archive_map.component_id
1115 JOIN files ON files.id = dsc_files.file
1116 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1117 AND source.source='$package'
1118 AND files.filename LIKE '%.dsc';
1120 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1121 my $digester = Digest::SHA->new(256);
1123 my ($vsn,$component,$filename,$sha256sum) = @$_;
1124 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1129 sub canonicalise_suite_sshpsql ($$) {
1130 my ($proto,$data) = @_;
1131 sql_injection_check $isuite;
1132 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1133 SELECT suite.codename
1134 FROM suite where suite_name='$isuite' or codename='$isuite';
1136 @rows = map { $_->[0] } @rows;
1137 fail "unknown suite $isuite" unless @rows;
1138 die "ambiguous $isuite: @rows ?" if @rows>1;
1142 #---------- `dummycat' archive query method ----------
1144 sub canonicalise_suite_dummycat ($$) {
1145 my ($proto,$data) = @_;
1146 my $dpath = "$data/suite.$isuite";
1147 if (!open C, "<", $dpath) {
1148 $!==ENOENT or die "$dpath: $!";
1149 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1153 chomp or die "$dpath: $!";
1155 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1159 sub archive_query_dummycat ($$) {
1160 my ($proto,$data) = @_;
1161 canonicalise_suite();
1162 my $dpath = "$data/package.$csuite.$package";
1163 if (!open C, "<", $dpath) {
1164 $!==ENOENT or die "$dpath: $!";
1165 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1173 printdebug "dummycat query $csuite $package $dpath | $_\n";
1174 my @row = split /\s+/, $_;
1175 @row==2 or die "$dpath: $_ ?";
1178 C->error and die "$dpath: $!";
1180 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1183 #---------- tag format handling ----------
1185 sub access_cfg_tagformats () {
1186 split /\,/, access_cfg('dgit-tag-format');
1189 sub need_tagformat ($$) {
1190 my ($fmt, $why) = @_;
1191 fail "need to use tag format $fmt ($why) but also need".
1192 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1193 " - no way to proceed"
1194 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1195 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1198 sub select_tagformat () {
1200 return if $tagformatfn && !$tagformat_want;
1201 die 'bug' if $tagformatfn && $tagformat_want;
1202 # ... $tagformat_want assigned after previous select_tagformat
1204 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1205 printdebug "select_tagformat supported @supported\n";
1207 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1208 printdebug "select_tagformat specified @$tagformat_want\n";
1210 my ($fmt,$why,$override) = @$tagformat_want;
1212 fail "target distro supports tag formats @supported".
1213 " but have to use $fmt ($why)"
1215 or grep { $_ eq $fmt } @supported;
1217 $tagformat_want = undef;
1219 $tagformatfn = ${*::}{"debiantag_$fmt"};
1221 fail "trying to use unknown tag format \`$fmt' ($why) !"
1222 unless $tagformatfn;
1225 #---------- archive query entrypoints and rest of program ----------
1227 sub canonicalise_suite () {
1228 return if defined $csuite;
1229 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1230 $csuite = archive_query('canonicalise_suite');
1231 if ($isuite ne $csuite) {
1232 progress "canonical suite name for $isuite is $csuite";
1236 sub get_archive_dsc () {
1237 canonicalise_suite();
1238 my @vsns = archive_query('archive_query');
1239 foreach my $vinfo (@vsns) {
1240 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1241 $dscurl = access_cfg('mirror').$subpath;
1242 $dscdata = url_get($dscurl);
1244 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1249 $digester->add($dscdata);
1250 my $got = $digester->hexdigest();
1252 fail "$dscurl has hash $got but".
1253 " archive told us to expect $digest";
1255 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1256 printdebug Dumper($dscdata) if $debuglevel>1;
1257 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1258 printdebug Dumper($dsc) if $debuglevel>1;
1259 my $fmt = getfield $dsc, 'Format';
1260 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1261 $dsc_checked = !!$digester;
1262 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1266 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1269 sub check_for_git ();
1270 sub check_for_git () {
1272 my $how = access_cfg('git-check');
1273 if ($how eq 'ssh-cmd') {
1275 (access_cfg_ssh, access_gituserhost(),
1276 access_runeinfo("git-check $package").
1277 " set -e; cd ".access_cfg('git-path').";".
1278 " if test -d $package.git; then echo 1; else echo 0; fi");
1279 my $r= cmdoutput @cmd;
1280 if (defined $r and $r =~ m/^divert (\w+)$/) {
1282 my ($usedistro,) = access_distros();
1283 # NB that if we are pushing, $usedistro will be $distro/push
1284 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1285 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1286 progress "diverting to $divert (using config for $instead_distro)";
1287 return check_for_git();
1289 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1291 } elsif ($how eq 'url') {
1292 my $prefix = access_cfg('git-check-url','git-url');
1293 my $suffix = access_cfg('git-check-suffix','git-suffix',
1294 'RETURN-UNDEF') // '.git';
1295 my $url = "$prefix/$package$suffix";
1296 my @cmd = (qw(curl -sS -I), $url);
1297 my $result = cmdoutput @cmd;
1298 $result =~ s/^\S+ 200 .*\n\r?\n//;
1299 # curl -sS -I with https_proxy prints
1300 # HTTP/1.0 200 Connection established
1301 $result =~ m/^\S+ (404|200) /s or
1302 fail "unexpected results from git check query - ".
1303 Dumper($prefix, $result);
1305 if ($code eq '404') {
1307 } elsif ($code eq '200') {
1312 } elsif ($how eq 'true') {
1314 } elsif ($how eq 'false') {
1317 badcfg "unknown git-check \`$how'";
1321 sub create_remote_git_repo () {
1322 my $how = access_cfg('git-create');
1323 if ($how eq 'ssh-cmd') {
1325 (access_cfg_ssh, access_gituserhost(),
1326 access_runeinfo("git-create $package").
1327 "set -e; cd ".access_cfg('git-path').";".
1328 " cp -a _template $package.git");
1329 } elsif ($how eq 'true') {
1332 badcfg "unknown git-create \`$how'";
1336 our ($dsc_hash,$lastpush_mergeinput);
1338 our $ud = '.git/dgit/unpack';
1348 sub mktree_in_ud_here () {
1349 runcmd qw(git init -q);
1350 runcmd qw(git config gc.auto 0);
1351 rmtree('.git/objects');
1352 symlink '../../../../objects','.git/objects' or die $!;
1355 sub git_write_tree () {
1356 my $tree = cmdoutput @git, qw(write-tree);
1357 $tree =~ m/^\w+$/ or die "$tree ?";
1361 sub remove_stray_gits () {
1362 my @gitscmd = qw(find -name .git -prune -print0);
1363 debugcmd "|",@gitscmd;
1364 open GITS, "-|", @gitscmd or die $!;
1369 print STDERR "$us: warning: removing from source package: ",
1370 (messagequote $_), "\n";
1374 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1377 sub mktree_in_ud_from_only_subdir (;$) {
1380 # changes into the subdir
1382 die "expected one subdir but found @dirs ?" unless @dirs==1;
1383 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1387 remove_stray_gits();
1388 mktree_in_ud_here();
1390 my ($format, $fopts) = get_source_format();
1391 if (madformat($format)) {
1396 runcmd @git, qw(add -Af);
1397 my $tree=git_write_tree();
1398 return ($tree,$dir);
1401 sub dsc_files_info () {
1402 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1403 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1404 ['Files', 'Digest::MD5', 'new()']) {
1405 my ($fname, $module, $method) = @$csumi;
1406 my $field = $dsc->{$fname};
1407 next unless defined $field;
1408 eval "use $module; 1;" or die $@;
1410 foreach (split /\n/, $field) {
1412 m/^(\w+) (\d+) (\S+)$/ or
1413 fail "could not parse .dsc $fname line \`$_'";
1414 my $digester = eval "$module"."->$method;" or die $@;
1419 Digester => $digester,
1424 fail "missing any supported Checksums-* or Files field in ".
1425 $dsc->get_option('name');
1429 map { $_->{Filename} } dsc_files_info();
1432 sub is_orig_file_in_dsc ($$) {
1433 my ($f, $dsc_files_info) = @_;
1434 return 0 if @$dsc_files_info <= 1;
1435 # One file means no origs, and the filename doesn't have a "what
1436 # part of dsc" component. (Consider versions ending `.orig'.)
1437 return 0 unless $f =~ m/\.orig(?:-\w+)?\.tar(?:\.\w+)?$/;
1441 sub is_orig_file_of_vsn ($$) {
1442 my ($f, $upstreamvsn) = @_;
1443 my $base = srcfn $upstreamvsn, '';
1444 return 0 unless $f =~ m/^\Q$base\E\.orig(?:-\w+)?\.tar(?:\.\w+)?$/;
1448 sub make_commit ($) {
1450 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1453 sub clogp_authline ($) {
1455 my $author = getfield $clogp, 'Maintainer';
1456 $author =~ s#,.*##ms;
1457 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1458 my $authline = "$author $date";
1459 $authline =~ m/$git_authline_re/o or
1460 fail "unexpected commit author line format \`$authline'".
1461 " (was generated from changelog Maintainer field)";
1462 return ($1,$2,$3) if wantarray;
1466 sub vendor_patches_distro ($$) {
1467 my ($checkdistro, $what) = @_;
1468 return unless defined $checkdistro;
1470 my $series = "debian/patches/\L$checkdistro\E.series";
1471 printdebug "checking for vendor-specific $series ($what)\n";
1473 if (!open SERIES, "<", $series) {
1474 die "$series $!" unless $!==ENOENT;
1483 Unfortunately, this source package uses a feature of dpkg-source where
1484 the same source package unpacks to different source code on different
1485 distros. dgit cannot safely operate on such packages on affected
1486 distros, because the meaning of source packages is not stable.
1488 Please ask the distro/maintainer to remove the distro-specific series
1489 files and use a different technique (if necessary, uploading actually
1490 different packages, if different distros are supposed to have
1494 fail "Found active distro-specific series file for".
1495 " $checkdistro ($what): $series, cannot continue";
1497 die "$series $!" if SERIES->error;
1501 sub check_for_vendor_patches () {
1502 # This dpkg-source feature doesn't seem to be documented anywhere!
1503 # But it can be found in the changelog (reformatted):
1505 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1506 # Author: Raphael Hertzog <hertzog@debian.org>
1507 # Date: Sun Oct 3 09:36:48 2010 +0200
1509 # dpkg-source: correctly create .pc/.quilt_series with alternate
1512 # If you have debian/patches/ubuntu.series and you were
1513 # unpacking the source package on ubuntu, quilt was still
1514 # directed to debian/patches/series instead of
1515 # debian/patches/ubuntu.series.
1517 # debian/changelog | 3 +++
1518 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1519 # 2 files changed, 6 insertions(+), 1 deletion(-)
1522 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1523 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1524 "Dpkg::Vendor \`current vendor'");
1525 vendor_patches_distro(access_basedistro(),
1526 "distro being accessed");
1529 sub generate_commits_from_dsc () {
1530 # See big comment in fetch_from_archive, below.
1534 my @dfi = dsc_files_info();
1535 foreach my $fi (@dfi) {
1536 my $f = $fi->{Filename};
1537 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1539 link_ltarget "../../../$f", $f
1543 complete_file_from_dsc('.', $fi)
1546 if (is_orig_file_in_dsc($f, \@dfi)) {
1547 link $f, "../../../../$f"
1553 my $dscfn = "$package.dsc";
1555 open D, ">", $dscfn or die "$dscfn: $!";
1556 print D $dscdata or die "$dscfn: $!";
1557 close D or die "$dscfn: $!";
1558 my @cmd = qw(dpkg-source);
1559 push @cmd, '--no-check' if $dsc_checked;
1560 push @cmd, qw(-x --), $dscfn;
1563 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1564 check_for_vendor_patches() if madformat($dsc->{format});
1565 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1566 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1567 my $authline = clogp_authline $clogp;
1568 my $changes = getfield $clogp, 'Changes';
1569 open C, ">../commit.tmp" or die $!;
1570 print C <<END or die $!;
1577 # imported from the archive
1580 my $rawimport_hash = make_commit qw(../commit.tmp);
1581 my $cversion = getfield $clogp, 'Version';
1582 progress "synthesised git commit from .dsc $cversion";
1584 my $rawimport_mergeinput = {
1585 Commit => $rawimport_hash,
1586 Info => "Import of source package",
1588 my @output = ($rawimport_mergeinput);
1590 if ($lastpush_mergeinput) {
1591 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1592 my $oversion = getfield $oldclogp, 'Version';
1594 version_compare($oversion, $cversion);
1596 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1597 { Message => <<END, ReverseParents => 1 });
1598 Record $package ($cversion) in archive suite $csuite
1600 } elsif ($vcmp > 0) {
1601 print STDERR <<END or die $!;
1603 Version actually in archive: $cversion (older)
1604 Last version pushed with dgit: $oversion (newer or same)
1607 @output = $lastpush_mergeinput;
1609 # Same version. Use what's in the server git branch,
1610 # discarding our own import. (This could happen if the
1611 # server automatically imports all packages into git.)
1612 @output = $lastpush_mergeinput;
1615 changedir '../../../..';
1620 sub complete_file_from_dsc ($$) {
1621 our ($dstdir, $fi) = @_;
1622 # Ensures that we have, in $dir, the file $fi, with the correct
1623 # contents. (Downloading it from alongside $dscurl if necessary.)
1625 my $f = $fi->{Filename};
1626 my $tf = "$dstdir/$f";
1629 if (stat_exists $tf) {
1630 progress "using existing $f";
1633 $furl =~ s{/[^/]+$}{};
1635 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1636 die "$f ?" if $f =~ m#/#;
1637 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1638 return 0 if !act_local();
1642 open F, "<", "$tf" or die "$tf: $!";
1643 $fi->{Digester}->reset();
1644 $fi->{Digester}->addfile(*F);
1645 F->error and die $!;
1646 my $got = $fi->{Digester}->hexdigest();
1647 $got eq $fi->{Hash} or
1648 fail "file $f has hash $got but .dsc".
1649 " demands hash $fi->{Hash} ".
1650 ($downloaded ? "(got wrong file from archive!)"
1651 : "(perhaps you should delete this file?)");
1656 sub ensure_we_have_orig () {
1657 my @dfi = dsc_files_info();
1658 foreach my $fi (@dfi) {
1659 my $f = $fi->{Filename};
1660 next unless is_orig_file_in_dsc($f, \@dfi);
1661 complete_file_from_dsc('..', $fi)
1666 sub git_fetch_us () {
1667 # Want to fetch only what we are going to use, unless
1668 # deliberately-not-ff, in which case we must fetch everything.
1670 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1672 (quiltmode_splitbrain
1673 ? (map { $_->('*',access_basedistro) }
1674 \&debiantag_new, \&debiantag_maintview)
1675 : debiantags('*',access_basedistro));
1676 push @specs, server_branch($csuite);
1677 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1679 # This is rather miserable:
1680 # When git-fetch --prune is passed a fetchspec ending with a *,
1681 # it does a plausible thing. If there is no * then:
1682 # - it matches subpaths too, even if the supplied refspec
1683 # starts refs, and behaves completely madly if the source
1684 # has refs/refs/something. (See, for example, Debian #NNNN.)
1685 # - if there is no matching remote ref, it bombs out the whole
1687 # We want to fetch a fixed ref, and we don't know in advance
1688 # if it exists, so this is not suitable.
1690 # Our workaround is to use git-ls-remote. git-ls-remote has its
1691 # own qairks. Notably, it has the absurd multi-tail-matching
1692 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1693 # refs/refs/foo etc.
1695 # Also, we want an idempotent snapshot, but we have to make two
1696 # calls to the remote: one to git-ls-remote and to git-fetch. The
1697 # solution is use git-ls-remote to obtain a target state, and
1698 # git-fetch to try to generate it. If we don't manage to generate
1699 # the target state, we try again.
1701 my $specre = join '|', map {
1707 printdebug "git_fetch_us specre=$specre\n";
1708 my $wanted_rref = sub {
1710 return m/^(?:$specre)$/o;
1713 my $fetch_iteration = 0;
1716 if (++$fetch_iteration > 10) {
1717 fail "too many iterations trying to get sane fetch!";
1720 my @look = map { "refs/$_" } @specs;
1721 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1725 open GITLS, "-|", @lcmd or die $!;
1727 printdebug "=> ", $_;
1728 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1729 my ($objid,$rrefname) = ($1,$2);
1730 if (!$wanted_rref->($rrefname)) {
1732 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1736 $wantr{$rrefname} = $objid;
1739 close GITLS or failedcmd @lcmd;
1741 # OK, now %want is exactly what we want for refs in @specs
1743 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1744 "+refs/$_:".lrfetchrefs."/$_";
1747 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1748 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1751 %lrfetchrefs_f = ();
1754 git_for_each_ref(lrfetchrefs, sub {
1755 my ($objid,$objtype,$lrefname,$reftail) = @_;
1756 $lrfetchrefs_f{$lrefname} = $objid;
1757 $objgot{$objid} = 1;
1760 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1761 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1762 if (!exists $wantr{$rrefname}) {
1763 if ($wanted_rref->($rrefname)) {
1765 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1769 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1772 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1773 delete $lrfetchrefs_f{$lrefname};
1777 foreach my $rrefname (sort keys %wantr) {
1778 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1779 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1780 my $want = $wantr{$rrefname};
1781 next if $got eq $want;
1782 if (!defined $objgot{$want}) {
1784 warning: git-ls-remote suggests we want $lrefname
1785 warning: and it should refer to $want
1786 warning: but git-fetch didn't fetch that object to any relevant ref.
1787 warning: This may be due to a race with someone updating the server.
1788 warning: Will try again...
1790 next FETCH_ITERATION;
1793 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1795 runcmd_ordryrun_local @git, qw(update-ref -m),
1796 "dgit fetch git-fetch fixup", $lrefname, $want;
1797 $lrfetchrefs_f{$lrefname} = $want;
1801 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1802 Dumper(\%lrfetchrefs_f);
1805 my @tagpats = debiantags('*',access_basedistro);
1807 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1808 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1809 printdebug "currently $fullrefname=$objid\n";
1810 $here{$fullrefname} = $objid;
1812 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1813 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1814 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1815 printdebug "offered $lref=$objid\n";
1816 if (!defined $here{$lref}) {
1817 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1818 runcmd_ordryrun_local @upd;
1819 lrfetchref_used $fullrefname;
1820 } elsif ($here{$lref} eq $objid) {
1821 lrfetchref_used $fullrefname;
1824 "Not updateting $lref from $here{$lref} to $objid.\n";
1829 sub mergeinfo_getclogp ($) {
1830 # Ensures thit $mi->{Clogp} exists and returns it
1832 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1835 sub mergeinfo_version ($) {
1836 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1839 sub fetch_from_archive () {
1840 # Ensures that lrref() is what is actually in the archive, one way
1841 # or another, according to us - ie this client's
1842 # appropritaely-updated archive view. Also returns the commit id.
1843 # If there is nothing in the archive, leaves lrref alone and
1844 # returns undef. git_fetch_us must have already been called.
1848 foreach my $field (@ourdscfield) {
1849 $dsc_hash = $dsc->{$field};
1850 last if defined $dsc_hash;
1852 if (defined $dsc_hash) {
1853 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1855 progress "last upload to archive specified git hash";
1857 progress "last upload to archive has NO git hash";
1860 progress "no version available from the archive";
1863 # If the archive's .dsc has a Dgit field, there are three
1864 # relevant git commitids we need to choose between and/or merge
1866 # 1. $dsc_hash: the Dgit field from the archive
1867 # 2. $lastpush_hash: the suite branch on the dgit git server
1868 # 3. $lastfetch_hash: our local tracking brach for the suite
1870 # These may all be distinct and need not be in any fast forward
1873 # If the dsc was pushed to this suite, then the server suite
1874 # branch will have been updated; but it might have been pushed to
1875 # a different suite and copied by the archive. Conversely a more
1876 # recent version may have been pushed with dgit but not appeared
1877 # in the archive (yet).
1879 # $lastfetch_hash may be awkward because archive imports
1880 # (particularly, imports of Dgit-less .dscs) are performed only as
1881 # needed on individual clients, so different clients may perform a
1882 # different subset of them - and these imports are only made
1883 # public during push. So $lastfetch_hash may represent a set of
1884 # imports different to a subsequent upload by a different dgit
1887 # Our approach is as follows:
1889 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1890 # descendant of $dsc_hash, then it was pushed by a dgit user who
1891 # had based their work on $dsc_hash, so we should prefer it.
1892 # Otherwise, $dsc_hash was installed into this suite in the
1893 # archive other than by a dgit push, and (necessarily) after the
1894 # last dgit push into that suite (since a dgit push would have
1895 # been descended from the dgit server git branch); thus, in that
1896 # case, we prefer the archive's version (and produce a
1897 # pseudo-merge to overwrite the dgit server git branch).
1899 # (If there is no Dgit field in the archive's .dsc then
1900 # generate_commit_from_dsc uses the version numbers to decide
1901 # whether the suite branch or the archive is newer. If the suite
1902 # branch is newer it ignores the archive's .dsc; otherwise it
1903 # generates an import of the .dsc, and produces a pseudo-merge to
1904 # overwrite the suite branch with the archive contents.)
1906 # The outcome of that part of the algorithm is the `public view',
1907 # and is same for all dgit clients: it does not depend on any
1908 # unpublished history in the local tracking branch.
1910 # As between the public view and the local tracking branch: The
1911 # local tracking branch is only updated by dgit fetch, and
1912 # whenever dgit fetch runs it includes the public view in the
1913 # local tracking branch. Therefore if the public view is not
1914 # descended from the local tracking branch, the local tracking
1915 # branch must contain history which was imported from the archive
1916 # but never pushed; and, its tip is now out of date. So, we make
1917 # a pseudo-merge to overwrite the old imports and stitch the old
1920 # Finally: we do not necessarily reify the public view (as
1921 # described above). This is so that we do not end up stacking two
1922 # pseudo-merges. So what we actually do is figure out the inputs
1923 # to any public view pseudo-merge and put them in @mergeinputs.
1926 # $mergeinputs[]{Commit}
1927 # $mergeinputs[]{Info}
1928 # $mergeinputs[0] is the one whose tree we use
1929 # @mergeinputs is in the order we use in the actual commit)
1932 # $mergeinputs[]{Message} is a commit message to use
1933 # $mergeinputs[]{ReverseParents} if def specifies that parent
1934 # list should be in opposite order
1935 # Such an entry has no Commit or Info. It applies only when found
1936 # in the last entry. (This ugliness is to support making
1937 # identical imports to previous dgit versions.)
1939 my $lastpush_hash = git_get_ref(lrfetchref());
1940 printdebug "previous reference hash=$lastpush_hash\n";
1941 $lastpush_mergeinput = $lastpush_hash && {
1942 Commit => $lastpush_hash,
1943 Info => "dgit suite branch on dgit git server",
1946 my $lastfetch_hash = git_get_ref(lrref());
1947 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1948 my $lastfetch_mergeinput = $lastfetch_hash && {
1949 Commit => $lastfetch_hash,
1950 Info => "dgit client's archive history view",
1953 my $dsc_mergeinput = $dsc_hash && {
1954 Commit => $dsc_hash,
1955 Info => "Dgit field in .dsc from archive",
1959 my $del_lrfetchrefs = sub {
1962 printdebug "del_lrfetchrefs...\n";
1963 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1964 my $objid = $lrfetchrefs_d{$fullrefname};
1965 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1967 $gur ||= new IO::Handle;
1968 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1970 printf $gur "delete %s %s\n", $fullrefname, $objid;
1973 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1977 if (defined $dsc_hash) {
1978 fail "missing remote git history even though dsc has hash -".
1979 " could not find ref ".rref()." at ".access_giturl()
1980 unless $lastpush_hash;
1981 ensure_we_have_orig();
1982 if ($dsc_hash eq $lastpush_hash) {
1983 @mergeinputs = $dsc_mergeinput
1984 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1985 print STDERR <<END or die $!;
1987 Git commit in archive is behind the last version allegedly pushed/uploaded.
1988 Commit referred to by archive: $dsc_hash
1989 Last version pushed with dgit: $lastpush_hash
1992 @mergeinputs = ($lastpush_mergeinput);
1994 # Archive has .dsc which is not a descendant of the last dgit
1995 # push. This can happen if the archive moves .dscs about.
1996 # Just follow its lead.
1997 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1998 progress "archive .dsc names newer git commit";
1999 @mergeinputs = ($dsc_mergeinput);
2001 progress "archive .dsc names other git commit, fixing up";
2002 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2006 @mergeinputs = generate_commits_from_dsc();
2007 # We have just done an import. Now, our import algorithm might
2008 # have been improved. But even so we do not want to generate
2009 # a new different import of the same package. So if the
2010 # version numbers are the same, just use our existing version.
2011 # If the version numbers are different, the archive has changed
2012 # (perhaps, rewound).
2013 if ($lastfetch_mergeinput &&
2014 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2015 (mergeinfo_version $mergeinputs[0]) )) {
2016 @mergeinputs = ($lastfetch_mergeinput);
2018 } elsif ($lastpush_hash) {
2019 # only in git, not in the archive yet
2020 @mergeinputs = ($lastpush_mergeinput);
2021 print STDERR <<END or die $!;
2023 Package not found in the archive, but has allegedly been pushed using dgit.
2027 printdebug "nothing found!\n";
2028 if (defined $skew_warning_vsn) {
2029 print STDERR <<END or die $!;
2031 Warning: relevant archive skew detected.
2032 Archive allegedly contains $skew_warning_vsn
2033 But we were not able to obtain any version from the archive or git.
2037 unshift @end, $del_lrfetchrefs;
2041 if ($lastfetch_hash &&
2043 my $h = $_->{Commit};
2044 $h and is_fast_fwd($lastfetch_hash, $h);
2045 # If true, one of the existing parents of this commit
2046 # is a descendant of the $lastfetch_hash, so we'll
2047 # be ff from that automatically.
2051 push @mergeinputs, $lastfetch_mergeinput;
2054 printdebug "fetch mergeinfos:\n";
2055 foreach my $mi (@mergeinputs) {
2057 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2059 printdebug sprintf " ReverseParents=%d Message=%s",
2060 $mi->{ReverseParents}, $mi->{Message};
2064 my $compat_info= pop @mergeinputs
2065 if $mergeinputs[$#mergeinputs]{Message};
2067 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2070 if (@mergeinputs > 1) {
2072 my $tree_commit = $mergeinputs[0]{Commit};
2074 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2075 $tree =~ m/\n\n/; $tree = $`;
2076 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2079 # We use the changelog author of the package in question the
2080 # author of this pseudo-merge. This is (roughly) correct if
2081 # this commit is simply representing aa non-dgit upload.
2082 # (Roughly because it does not record sponsorship - but we
2083 # don't have sponsorship info because that's in the .changes,
2084 # which isn't in the archivw.)
2086 # But, it might be that we are representing archive history
2087 # updates (including in-archive copies). These are not really
2088 # the responsibility of the person who created the .dsc, but
2089 # there is no-one whose name we should better use. (The
2090 # author of the .dsc-named commit is clearly worse.)
2092 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2093 my $author = clogp_authline $useclogp;
2094 my $cversion = getfield $useclogp, 'Version';
2096 my $mcf = ".git/dgit/mergecommit";
2097 open MC, ">", $mcf or die "$mcf $!";
2098 print MC <<END or die $!;
2102 my @parents = grep { $_->{Commit} } @mergeinputs;
2103 @parents = reverse @parents if $compat_info->{ReverseParents};
2104 print MC <<END or die $! foreach @parents;
2108 print MC <<END or die $!;
2114 if (defined $compat_info->{Message}) {
2115 print MC $compat_info->{Message} or die $!;
2117 print MC <<END or die $!;
2118 Record $package ($cversion) in archive suite $csuite
2122 my $message_add_info = sub {
2124 my $mversion = mergeinfo_version $mi;
2125 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2129 $message_add_info->($mergeinputs[0]);
2130 print MC <<END or die $!;
2131 should be treated as descended from
2133 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2137 $hash = make_commit $mcf;
2139 $hash = $mergeinputs[0]{Commit};
2141 progress "fetch hash=$hash\n";
2144 my ($lasth, $what) = @_;
2145 return unless $lasth;
2146 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2149 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2150 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2152 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2153 'DGIT_ARCHIVE', $hash;
2154 cmdoutput @git, qw(log -n2), $hash;
2155 # ... gives git a chance to complain if our commit is malformed
2157 if (defined $skew_warning_vsn) {
2159 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2160 my $gotclogp = commit_getclogp($hash);
2161 my $got_vsn = getfield $gotclogp, 'Version';
2162 printdebug "SKEW CHECK GOT $got_vsn\n";
2163 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2164 print STDERR <<END or die $!;
2166 Warning: archive skew detected. Using the available version:
2167 Archive allegedly contains $skew_warning_vsn
2168 We were able to obtain only $got_vsn
2174 if ($lastfetch_hash ne $hash) {
2175 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2179 dryrun_report @upd_cmd;
2183 lrfetchref_used lrfetchref();
2185 unshift @end, $del_lrfetchrefs;
2189 sub set_local_git_config ($$) {
2191 runcmd @git, qw(config), $k, $v;
2194 sub setup_mergechangelogs (;$) {
2196 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2198 my $driver = 'dpkg-mergechangelogs';
2199 my $cb = "merge.$driver";
2200 my $attrs = '.git/info/attributes';
2201 ensuredir '.git/info';
2203 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2204 if (!open ATTRS, "<", $attrs) {
2205 $!==ENOENT or die "$attrs: $!";
2209 next if m{^debian/changelog\s};
2210 print NATTRS $_, "\n" or die $!;
2212 ATTRS->error and die $!;
2215 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2218 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2219 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2221 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2224 sub setup_useremail (;$) {
2226 return unless $always || access_cfg_bool(1, 'setup-useremail');
2229 my ($k, $envvar) = @_;
2230 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2231 return unless defined $v;
2232 set_local_git_config "user.$k", $v;
2235 $setup->('email', 'DEBEMAIL');
2236 $setup->('name', 'DEBFULLNAME');
2239 sub setup_new_tree () {
2240 setup_mergechangelogs();
2246 canonicalise_suite();
2247 badusage "dry run makes no sense with clone" unless act_local();
2248 my $hasgit = check_for_git();
2249 mkdir $dstdir or fail "create \`$dstdir': $!";
2251 runcmd @git, qw(init -q);
2252 my $giturl = access_giturl(1);
2253 if (defined $giturl) {
2254 open H, "> .git/HEAD" or die $!;
2255 print H "ref: ".lref()."\n" or die $!;
2257 runcmd @git, qw(remote add), 'origin', $giturl;
2260 progress "fetching existing git history";
2262 runcmd_ordryrun_local @git, qw(fetch origin);
2264 progress "starting new git history";
2266 fetch_from_archive() or no_such_package;
2267 my $vcsgiturl = $dsc->{'Vcs-Git'};
2268 if (length $vcsgiturl) {
2269 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2270 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2273 runcmd @git, qw(reset --hard), lrref();
2274 printdone "ready for work in $dstdir";
2278 if (check_for_git()) {
2281 fetch_from_archive() or no_such_package();
2282 printdone "fetched into ".lrref();
2287 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2289 printdone "fetched to ".lrref()." and merged into HEAD";
2292 sub check_not_dirty () {
2293 foreach my $f (qw(local-options local-patch-header)) {
2294 if (stat_exists "debian/source/$f") {
2295 fail "git tree contains debian/source/$f";
2299 return if $ignoredirty;
2301 my @cmd = (@git, qw(diff --quiet HEAD));
2303 $!=0; $?=-1; system @cmd;
2306 fail "working tree is dirty (does not match HEAD)";
2312 sub commit_admin ($) {
2315 runcmd_ordryrun_local @git, qw(commit -m), $m;
2318 sub commit_quilty_patch () {
2319 my $output = cmdoutput @git, qw(status --porcelain);
2321 foreach my $l (split /\n/, $output) {
2322 next unless $l =~ m/\S/;
2323 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2327 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2329 progress "nothing quilty to commit, ok.";
2332 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2333 runcmd_ordryrun_local @git, qw(add -f), @adds;
2334 commit_admin "Commit Debian 3.0 (quilt) metadata";
2337 sub get_source_format () {
2339 if (open F, "debian/source/options") {
2343 s/\s+$//; # ignore missing final newline
2345 my ($k, $v) = ($`, $'); #');
2346 $v =~ s/^"(.*)"$/$1/;
2352 F->error and die $!;
2355 die $! unless $!==&ENOENT;
2358 if (!open F, "debian/source/format") {
2359 die $! unless $!==&ENOENT;
2363 F->error and die $!;
2365 return ($_, \%options);
2368 sub madformat_wantfixup ($) {
2370 return 0 unless $format eq '3.0 (quilt)';
2371 our $quilt_mode_warned;
2372 if ($quilt_mode eq 'nocheck') {
2373 progress "Not doing any fixup of \`$format' due to".
2374 " ----no-quilt-fixup or --quilt=nocheck"
2375 unless $quilt_mode_warned++;
2378 progress "Format \`$format', need to check/update patch stack"
2379 unless $quilt_mode_warned++;
2383 # An "infopair" is a tuple [ $thing, $what ]
2384 # (often $thing is a commit hash; $what is a description)
2386 sub infopair_cond_equal ($$) {
2388 $x->[0] eq $y->[0] or fail <<END;
2389 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2393 sub infopair_lrf_tag_lookup ($$) {
2394 my ($tagnames, $what) = @_;
2395 # $tagname may be an array ref
2396 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2397 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2398 foreach my $tagname (@tagnames) {
2399 my $lrefname = lrfetchrefs."/tags/$tagname";
2400 my $tagobj = $lrfetchrefs_f{$lrefname};
2401 next unless defined $tagobj;
2402 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2403 return [ git_rev_parse($tagobj), $what ];
2405 fail @tagnames==1 ? <<END : <<END;
2406 Wanted tag $what (@tagnames) on dgit server, but not found
2408 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2412 sub infopair_cond_ff ($$) {
2413 my ($anc,$desc) = @_;
2414 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2415 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2419 sub pseudomerge_version_check ($$) {
2420 my ($clogp, $archive_hash) = @_;
2422 my $arch_clogp = commit_getclogp $archive_hash;
2423 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2424 'version currently in archive' ];
2425 if (defined $overwrite_version) {
2426 if (length $overwrite_version) {
2427 infopair_cond_equal([ $overwrite_version,
2428 '--overwrite= version' ],
2431 my $v = $i_arch_v->[0];
2432 progress "Checking package changelog for archive version $v ...";
2434 my @xa = ("-f$v", "-t$v");
2435 my $vclogp = parsechangelog @xa;
2436 my $cv = [ (getfield $vclogp, 'Version'),
2437 "Version field from dpkg-parsechangelog @xa" ];
2438 infopair_cond_equal($i_arch_v, $cv);
2441 $@ =~ s/^dgit: //gm;
2443 "Perhaps debian/changelog does not mention $v ?";
2448 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2452 sub pseudomerge_make_commit ($$$$ $$) {
2453 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2454 $msg_cmd, $msg_msg) = @_;
2455 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2457 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2458 my $authline = clogp_authline $clogp;
2462 !defined $overwrite_version ? ""
2463 : !length $overwrite_version ? " --overwrite"
2464 : " --overwrite=".$overwrite_version;
2467 my $pmf = ".git/dgit/pseudomerge";
2468 open MC, ">", $pmf or die "$pmf $!";
2469 print MC <<END or die $!;
2472 parent $archive_hash
2482 return make_commit($pmf);
2485 sub splitbrain_pseudomerge ($$$$) {
2486 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2487 # => $merged_dgitview
2488 printdebug "splitbrain_pseudomerge...\n";
2490 # We: debian/PREVIOUS HEAD($maintview)
2491 # expect: o ----------------- o
2494 # a/d/PREVIOUS $dgitview
2497 # we do: `------------------ o
2501 printdebug "splitbrain_pseudomerge...\n";
2503 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2505 return $dgitview unless defined $archive_hash;
2507 if (!defined $overwrite_version) {
2508 progress "Checking that HEAD inciudes all changes in archive...";
2511 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2513 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2514 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2515 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2516 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2517 my $i_archive = [ $archive_hash, "current archive contents" ];
2519 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2521 infopair_cond_equal($i_dgit, $i_archive);
2522 infopair_cond_ff($i_dep14, $i_dgit);
2523 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2525 my $r = pseudomerge_make_commit
2526 $clogp, $dgitview, $archive_hash, $i_arch_v,
2527 "dgit --quilt=$quilt_mode",
2528 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2529 Declare fast forward from $overwrite_version
2531 Make fast forward from $i_arch_v->[0]
2534 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2538 sub plain_overwrite_pseudomerge ($$$) {
2539 my ($clogp, $head, $archive_hash) = @_;
2541 printdebug "plain_overwrite_pseudomerge...";
2543 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2545 my @tagformats = access_cfg_tagformats();
2547 map { $_->($i_arch_v->[0], access_basedistro) }
2548 (grep { m/^(?:old|hist)$/ } @tagformats)
2549 ? \&debiantags : \&debiantag_new;
2550 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2551 my $i_archive = [ $archive_hash, "current archive contents" ];
2553 infopair_cond_equal($i_overwr, $i_archive);
2555 return $head if is_fast_fwd $archive_hash, $head;
2557 my $m = "Declare fast forward from $i_arch_v->[0]";
2559 my $r = pseudomerge_make_commit
2560 $clogp, $head, $archive_hash, $i_arch_v,
2563 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2565 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2569 sub push_parse_changelog ($) {
2572 my $clogp = Dpkg::Control::Hash->new();
2573 $clogp->load($clogpfn) or die;
2575 $package = getfield $clogp, 'Source';
2576 my $cversion = getfield $clogp, 'Version';
2577 my $tag = debiantag($cversion, access_basedistro);
2578 runcmd @git, qw(check-ref-format), $tag;
2580 my $dscfn = dscfn($cversion);
2582 return ($clogp, $cversion, $dscfn);
2585 sub push_parse_dsc ($$$) {
2586 my ($dscfn,$dscfnwhat, $cversion) = @_;
2587 $dsc = parsecontrol($dscfn,$dscfnwhat);
2588 my $dversion = getfield $dsc, 'Version';
2589 my $dscpackage = getfield $dsc, 'Source';
2590 ($dscpackage eq $package && $dversion eq $cversion) or
2591 fail "$dscfn is for $dscpackage $dversion".
2592 " but debian/changelog is for $package $cversion";
2595 sub push_tagwants ($$$$) {
2596 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2599 TagFn => \&debiantag,
2604 if (defined $maintviewhead) {
2606 TagFn => \&debiantag_maintview,
2607 Objid => $maintviewhead,
2608 TfSuffix => '-maintview',
2612 foreach my $tw (@tagwants) {
2613 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2614 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2616 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2620 sub push_mktags ($$ $$ $) {
2622 $changesfile,$changesfilewhat,
2625 die unless $tagwants->[0]{View} eq 'dgit';
2627 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2628 $dsc->save("$dscfn.tmp") or die $!;
2630 my $changes = parsecontrol($changesfile,$changesfilewhat);
2631 foreach my $field (qw(Source Distribution Version)) {
2632 $changes->{$field} eq $clogp->{$field} or
2633 fail "changes field $field \`$changes->{$field}'".
2634 " does not match changelog \`$clogp->{$field}'";
2637 my $cversion = getfield $clogp, 'Version';
2638 my $clogsuite = getfield $clogp, 'Distribution';
2640 # We make the git tag by hand because (a) that makes it easier
2641 # to control the "tagger" (b) we can do remote signing
2642 my $authline = clogp_authline $clogp;
2643 my $delibs = join(" ", "",@deliberatelies);
2644 my $declaredistro = access_basedistro();
2648 my $tfn = $tw->{Tfn};
2649 my $head = $tw->{Objid};
2650 my $tag = $tw->{Tag};
2652 open TO, '>', $tfn->('.tmp') or die $!;
2653 print TO <<END or die $!;
2660 if ($tw->{View} eq 'dgit') {
2661 print TO <<END or die $!;
2662 $package release $cversion for $clogsuite ($csuite) [dgit]
2663 [dgit distro=$declaredistro$delibs]
2665 foreach my $ref (sort keys %previously) {
2666 print TO <<END or die $!;
2667 [dgit previously:$ref=$previously{$ref}]
2670 } elsif ($tw->{View} eq 'maint') {
2671 print TO <<END or die $!;
2672 $package release $cversion for $clogsuite ($csuite)
2673 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2676 die Dumper($tw)."?";
2681 my $tagobjfn = $tfn->('.tmp');
2683 if (!defined $keyid) {
2684 $keyid = access_cfg('keyid','RETURN-UNDEF');
2686 if (!defined $keyid) {
2687 $keyid = getfield $clogp, 'Maintainer';
2689 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2690 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2691 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2692 push @sign_cmd, $tfn->('.tmp');
2693 runcmd_ordryrun @sign_cmd;
2695 $tagobjfn = $tfn->('.signed.tmp');
2696 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2697 $tfn->('.tmp'), $tfn->('.tmp.asc');
2703 my @r = map { $mktag->($_); } @$tagwants;
2707 sub sign_changes ($) {
2708 my ($changesfile) = @_;
2710 my @debsign_cmd = @debsign;
2711 push @debsign_cmd, "-k$keyid" if defined $keyid;
2712 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2713 push @debsign_cmd, $changesfile;
2714 runcmd_ordryrun @debsign_cmd;
2719 printdebug "actually entering push\n";
2721 supplementary_message(<<'END');
2722 Push failed, while checking state of the archive.
2723 You can retry the push, after fixing the problem, if you like.
2725 if (check_for_git()) {
2728 my $archive_hash = fetch_from_archive();
2729 if (!$archive_hash) {
2731 fail "package appears to be new in this suite;".
2732 " if this is intentional, use --new";
2735 supplementary_message(<<'END');
2736 Push failed, while preparing your push.
2737 You can retry the push, after fixing the problem, if you like.
2740 need_tagformat 'new', "quilt mode $quilt_mode"
2741 if quiltmode_splitbrain;
2745 access_giturl(); # check that success is vaguely likely
2748 my $clogpfn = ".git/dgit/changelog.822.tmp";
2749 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2751 responder_send_file('parsed-changelog', $clogpfn);
2753 my ($clogp, $cversion, $dscfn) =
2754 push_parse_changelog("$clogpfn");
2756 my $dscpath = "$buildproductsdir/$dscfn";
2757 stat_exists $dscpath or
2758 fail "looked for .dsc $dscfn, but $!;".
2759 " maybe you forgot to build";
2761 responder_send_file('dsc', $dscpath);
2763 push_parse_dsc($dscpath, $dscfn, $cversion);
2765 my $format = getfield $dsc, 'Format';
2766 printdebug "format $format\n";
2768 my $actualhead = git_rev_parse('HEAD');
2769 my $dgithead = $actualhead;
2770 my $maintviewhead = undef;
2772 if (madformat_wantfixup($format)) {
2773 # user might have not used dgit build, so maybe do this now:
2774 if (quiltmode_splitbrain()) {
2775 my $upstreamversion = $clogp->{Version};
2776 $upstreamversion =~ s/-[^-]*$//;
2778 quilt_make_fake_dsc($upstreamversion);
2779 my ($dgitview, $cachekey) =
2780 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2782 "--quilt=$quilt_mode but no cached dgit view:
2783 perhaps tree changed since dgit build[-source] ?";
2785 $dgithead = splitbrain_pseudomerge($clogp,
2786 $actualhead, $dgitview,
2788 $maintviewhead = $actualhead;
2789 changedir '../../../..';
2790 prep_ud(); # so _only_subdir() works, below
2792 commit_quilty_patch();
2796 if (defined $overwrite_version && !defined $maintviewhead) {
2797 $dgithead = plain_overwrite_pseudomerge($clogp,
2805 if ($archive_hash) {
2806 if (is_fast_fwd($archive_hash, $dgithead)) {
2808 } elsif (deliberately_not_fast_forward) {
2811 fail "dgit push: HEAD is not a descendant".
2812 " of the archive's version.\n".
2813 "To overwrite the archive's contents,".
2814 " pass --overwrite[=VERSION].\n".
2815 "To rewind history, if permitted by the archive,".
2816 " use --deliberately-not-fast-forward.";
2821 progress "checking that $dscfn corresponds to HEAD";
2822 runcmd qw(dpkg-source -x --),
2823 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2824 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2825 check_for_vendor_patches() if madformat($dsc->{format});
2826 changedir '../../../..';
2827 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2828 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2829 debugcmd "+",@diffcmd;
2831 my $r = system @diffcmd;
2834 fail "$dscfn specifies a different tree to your HEAD commit;".
2835 " perhaps you forgot to build".
2836 ($diffopt eq '--exit-code' ? "" :
2837 " (run with -D to see full diff output)");
2842 if (!$changesfile) {
2843 my $pat = changespat $cversion;
2844 my @cs = glob "$buildproductsdir/$pat";
2845 fail "failed to find unique changes file".
2846 " (looked for $pat in $buildproductsdir);".
2847 " perhaps you need to use dgit -C"
2849 ($changesfile) = @cs;
2851 $changesfile = "$buildproductsdir/$changesfile";
2854 # Checks complete, we're going to try and go ahead:
2856 responder_send_file('changes',$changesfile);
2857 responder_send_command("param head $dgithead");
2858 responder_send_command("param csuite $csuite");
2859 responder_send_command("param tagformat $tagformat");
2860 if (defined $maintviewhead) {
2861 die unless ($protovsn//4) >= 4;
2862 responder_send_command("param maint-view $maintviewhead");
2865 if (deliberately_not_fast_forward) {
2866 git_for_each_ref(lrfetchrefs, sub {
2867 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2868 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2869 responder_send_command("previously $rrefname=$objid");
2870 $previously{$rrefname} = $objid;
2874 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2878 supplementary_message(<<'END');
2879 Push failed, while signing the tag.
2880 You can retry the push, after fixing the problem, if you like.
2882 # If we manage to sign but fail to record it anywhere, it's fine.
2883 if ($we_are_responder) {
2884 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2885 responder_receive_files('signed-tag', @tagobjfns);
2887 @tagobjfns = push_mktags($clogp,$dscpath,
2888 $changesfile,$changesfile,
2891 supplementary_message(<<'END');
2892 Push failed, *after* signing the tag.
2893 If you want to try again, you should use a new version number.
2896 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2898 foreach my $tw (@tagwants) {
2899 my $tag = $tw->{Tag};
2900 my $tagobjfn = $tw->{TagObjFn};
2902 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2903 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2904 runcmd_ordryrun_local
2905 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2908 supplementary_message(<<'END');
2909 Push failed, while updating the remote git repository - see messages above.
2910 If you want to try again, you should use a new version number.
2912 if (!check_for_git()) {
2913 create_remote_git_repo();
2916 my @pushrefs = $forceflag.$dgithead.":".rrref();
2917 foreach my $tw (@tagwants) {
2918 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2921 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2922 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2924 supplementary_message(<<'END');
2925 Push failed, after updating the remote git repository.
2926 If you want to try again, you must use a new version number.
2928 if ($we_are_responder) {
2929 my $dryrunsuffix = act_local() ? "" : ".tmp";
2930 responder_receive_files('signed-dsc-changes',
2931 "$dscpath$dryrunsuffix",
2932 "$changesfile$dryrunsuffix");
2935 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2937 progress "[new .dsc left in $dscpath.tmp]";
2939 sign_changes $changesfile;
2942 supplementary_message(<<END);
2943 Push failed, while uploading package(s) to the archive server.
2944 You can retry the upload of exactly these same files with dput of:
2946 If that .changes file is broken, you will need to use a new version
2947 number for your next attempt at the upload.
2949 my $host = access_cfg('upload-host','RETURN-UNDEF');
2950 my @hostarg = defined($host) ? ($host,) : ();
2951 runcmd_ordryrun @dput, @hostarg, $changesfile;
2952 printdone "pushed and uploaded $cversion";
2954 supplementary_message('');
2955 responder_send_command("complete");
2962 badusage "-p is not allowed with clone; specify as argument instead"
2963 if defined $package;
2966 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2967 ($package,$isuite) = @ARGV;
2968 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2969 ($package,$dstdir) = @ARGV;
2970 } elsif (@ARGV==3) {
2971 ($package,$isuite,$dstdir) = @ARGV;
2973 badusage "incorrect arguments to dgit clone";
2975 $dstdir ||= "$package";
2977 if (stat_exists $dstdir) {
2978 fail "$dstdir already exists";
2982 if ($rmonerror && !$dryrun_level) {
2983 $cwd_remove= getcwd();
2985 return unless defined $cwd_remove;
2986 if (!chdir "$cwd_remove") {
2987 return if $!==&ENOENT;
2988 die "chdir $cwd_remove: $!";
2991 rmtree($dstdir) or die "remove $dstdir: $!\n";
2992 } elsif (!grep { $! == $_ }
2993 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2995 print STDERR "check whether to remove $dstdir: $!\n";
3001 $cwd_remove = undef;
3004 sub branchsuite () {
3005 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3006 if ($branch =~ m#$lbranch_re#o) {
3013 sub fetchpullargs () {
3015 if (!defined $package) {
3016 my $sourcep = parsecontrol('debian/control','debian/control');
3017 $package = getfield $sourcep, 'Source';
3020 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3022 my $clogp = parsechangelog();
3023 $isuite = getfield $clogp, 'Distribution';
3025 canonicalise_suite();
3026 progress "fetching from suite $csuite";
3027 } elsif (@ARGV==1) {
3029 canonicalise_suite();
3031 badusage "incorrect arguments to dgit fetch or dgit pull";
3050 badusage "-p is not allowed with dgit push" if defined $package;
3052 my $clogp = parsechangelog();
3053 $package = getfield $clogp, 'Source';
3056 } elsif (@ARGV==1) {
3057 ($specsuite) = (@ARGV);
3059 badusage "incorrect arguments to dgit push";
3061 $isuite = getfield $clogp, 'Distribution';
3063 local ($package) = $existing_package; # this is a hack
3064 canonicalise_suite();
3066 canonicalise_suite();
3068 if (defined $specsuite &&
3069 $specsuite ne $isuite &&
3070 $specsuite ne $csuite) {
3071 fail "dgit push: changelog specifies $isuite ($csuite)".
3072 " but command line specifies $specsuite";
3077 #---------- remote commands' implementation ----------
3079 sub cmd_remote_push_build_host {
3080 my ($nrargs) = shift @ARGV;
3081 my (@rargs) = @ARGV[0..$nrargs-1];
3082 @ARGV = @ARGV[$nrargs..$#ARGV];
3084 my ($dir,$vsnwant) = @rargs;
3085 # vsnwant is a comma-separated list; we report which we have
3086 # chosen in our ready response (so other end can tell if they
3089 $we_are_responder = 1;
3090 $us .= " (build host)";
3094 open PI, "<&STDIN" or die $!;
3095 open STDIN, "/dev/null" or die $!;
3096 open PO, ">&STDOUT" or die $!;
3098 open STDOUT, ">&STDERR" or die $!;
3102 ($protovsn) = grep {
3103 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3104 } @rpushprotovsn_support;
3106 fail "build host has dgit rpush protocol versions ".
3107 (join ",", @rpushprotovsn_support).
3108 " but invocation host has $vsnwant"
3109 unless defined $protovsn;
3111 responder_send_command("dgit-remote-push-ready $protovsn");
3112 rpush_handle_protovsn_bothends();
3117 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3118 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3119 # a good error message)
3121 sub rpush_handle_protovsn_bothends () {
3122 if ($protovsn < 4) {
3123 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3132 my $report = i_child_report();
3133 if (defined $report) {
3134 printdebug "($report)\n";
3135 } elsif ($i_child_pid) {
3136 printdebug "(killing build host child $i_child_pid)\n";
3137 kill 15, $i_child_pid;
3139 if (defined $i_tmp && !defined $initiator_tempdir) {
3141 eval { rmtree $i_tmp; };
3145 END { i_cleanup(); }
3148 my ($base,$selector,@args) = @_;
3149 $selector =~ s/\-/_/g;
3150 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3157 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3165 push @rargs, join ",", @rpushprotovsn_support;
3168 push @rdgit, @ropts;
3169 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3171 my @cmd = (@ssh, $host, shellquote @rdgit);
3174 if (defined $initiator_tempdir) {
3175 rmtree $initiator_tempdir;
3176 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3177 $i_tmp = $initiator_tempdir;
3181 $i_child_pid = open2(\*RO, \*RI, @cmd);
3183 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3184 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3185 $supplementary_message = '' unless $protovsn >= 3;
3187 fail "rpush negotiated protocol version $protovsn".
3188 " which does not support quilt mode $quilt_mode"
3189 if quiltmode_splitbrain;
3191 rpush_handle_protovsn_bothends();
3193 my ($icmd,$iargs) = initiator_expect {
3194 m/^(\S+)(?: (.*))?$/;
3197 i_method "i_resp", $icmd, $iargs;
3201 sub i_resp_progress ($) {
3203 my $msg = protocol_read_bytes \*RO, $rhs;
3207 sub i_resp_supplementary_message ($) {
3209 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3212 sub i_resp_complete {
3213 my $pid = $i_child_pid;
3214 $i_child_pid = undef; # prevents killing some other process with same pid
3215 printdebug "waiting for build host child $pid...\n";
3216 my $got = waitpid $pid, 0;
3217 die $! unless $got == $pid;
3218 die "build host child failed $?" if $?;
3221 printdebug "all done\n";
3225 sub i_resp_file ($) {
3227 my $localname = i_method "i_localname", $keyword;
3228 my $localpath = "$i_tmp/$localname";
3229 stat_exists $localpath and
3230 badproto \*RO, "file $keyword ($localpath) twice";
3231 protocol_receive_file \*RO, $localpath;
3232 i_method "i_file", $keyword;
3237 sub i_resp_param ($) {
3238 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3242 sub i_resp_previously ($) {
3243 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3244 or badproto \*RO, "bad previously spec";
3245 my $r = system qw(git check-ref-format), $1;
3246 die "bad previously ref spec ($r)" if $r;
3247 $previously{$1} = $2;
3252 sub i_resp_want ($) {
3254 die "$keyword ?" if $i_wanted{$keyword}++;
3255 my @localpaths = i_method "i_want", $keyword;
3256 printdebug "[[ $keyword @localpaths\n";
3257 foreach my $localpath (@localpaths) {
3258 protocol_send_file \*RI, $localpath;
3260 print RI "files-end\n" or die $!;
3263 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3265 sub i_localname_parsed_changelog {
3266 return "remote-changelog.822";
3268 sub i_file_parsed_changelog {
3269 ($i_clogp, $i_version, $i_dscfn) =
3270 push_parse_changelog "$i_tmp/remote-changelog.822";
3271 die if $i_dscfn =~ m#/|^\W#;
3274 sub i_localname_dsc {
3275 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3280 sub i_localname_changes {
3281 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3282 $i_changesfn = $i_dscfn;
3283 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3284 return $i_changesfn;
3286 sub i_file_changes { }
3288 sub i_want_signed_tag {
3289 printdebug Dumper(\%i_param, $i_dscfn);
3290 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3291 && defined $i_param{'csuite'}
3292 or badproto \*RO, "premature desire for signed-tag";
3293 my $head = $i_param{'head'};
3294 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3296 my $maintview = $i_param{'maint-view'};
3297 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3300 if ($protovsn >= 4) {
3301 my $p = $i_param{'tagformat'} // '<undef>';
3303 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3306 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3308 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3310 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3313 push_mktags $i_clogp, $i_dscfn,
3314 $i_changesfn, 'remote changes',
3318 sub i_want_signed_dsc_changes {
3319 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3320 sign_changes $i_changesfn;
3321 return ($i_dscfn, $i_changesfn);
3324 #---------- building etc. ----------
3330 #----- `3.0 (quilt)' handling -----
3332 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3334 sub quiltify_dpkg_commit ($$$;$) {
3335 my ($patchname,$author,$msg, $xinfo) = @_;
3339 my $descfn = ".git/dgit/quilt-description.tmp";
3340 open O, '>', $descfn or die "$descfn: $!";
3343 $msg =~ s/^\s+$/ ./mg;
3344 print O <<END or die $!;
3354 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3355 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3356 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3357 runcmd @dpkgsource, qw(--commit .), $patchname;
3361 sub quiltify_trees_differ ($$;$$) {
3362 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3363 # returns true iff the two tree objects differ other than in debian/
3364 # with $finegrained,
3365 # returns bitmask 01 - differ in upstream files except .gitignore
3366 # 02 - differ in .gitignore
3367 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3368 # is set for each modified .gitignore filename $fn
3370 my @cmd = (@git, qw(diff-tree --name-only -z));
3371 push @cmd, qw(-r) if $finegrained;
3373 my $diffs= cmdoutput @cmd;
3375 foreach my $f (split /\0/, $diffs) {
3376 next if $f =~ m#^debian(?:/.*)?$#s;
3377 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3378 $r |= $isignore ? 02 : 01;
3379 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3381 printdebug "quiltify_trees_differ $x $y => $r\n";
3385 sub quiltify_tree_sentinelfiles ($) {
3386 # lists the `sentinel' files present in the tree
3388 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3389 qw(-- debian/rules debian/control);
3394 sub quiltify_splitbrain_needed () {
3395 if (!$split_brain) {
3396 progress "dgit view: changes are required...";
3397 runcmd @git, qw(checkout -q -b dgit-view);
3402 sub quiltify_splitbrain ($$$$$$) {
3403 my ($clogp, $unapplied, $headref, $diffbits,
3404 $editedignores, $cachekey) = @_;
3405 if ($quilt_mode !~ m/gbp|dpm/) {
3406 # treat .gitignore just like any other upstream file
3407 $diffbits = { %$diffbits };
3408 $_ = !!$_ foreach values %$diffbits;
3410 # We would like any commits we generate to be reproducible
3411 my @authline = clogp_authline($clogp);
3412 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3413 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3414 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3416 if ($quilt_mode =~ m/gbp|unapplied/ &&
3417 ($diffbits->{H2O} & 01)) {
3419 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3420 " but git tree differs from orig in upstream files.";
3421 if (!stat_exists "debian/patches") {
3423 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3427 if ($quilt_mode =~ m/dpm/ &&
3428 ($diffbits->{H2A} & 01)) {
3430 --quilt=$quilt_mode specified, implying patches-applied git tree
3431 but git tree differs from result of applying debian/patches to upstream
3434 if ($quilt_mode =~ m/gbp|unapplied/ &&
3435 ($diffbits->{O2A} & 01)) { # some patches
3436 quiltify_splitbrain_needed();
3437 progress "dgit view: creating patches-applied version using gbp pq";
3438 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3439 # gbp pq import creates a fresh branch; push back to dgit-view
3440 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3441 runcmd @git, qw(checkout -q dgit-view);
3443 if ($quilt_mode =~ m/gbp|dpm/ &&
3444 ($diffbits->{O2A} & 02)) {
3446 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3447 tool which does not create patches for changes to upstream
3448 .gitignores: but, such patches exist in debian/patches.
3451 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3452 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3453 quiltify_splitbrain_needed();
3454 progress "dgit view: creating patch to represent .gitignore changes";
3455 ensuredir "debian/patches";
3456 my $gipatch = "debian/patches/auto-gitignore";
3457 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3458 stat GIPATCH or die "$gipatch: $!";
3459 fail "$gipatch already exists; but want to create it".
3460 " to record .gitignore changes" if (stat _)[7];
3461 print GIPATCH <<END or die "$gipatch: $!";
3462 Subject: Update .gitignore from Debian packaging branch
3464 The Debian packaging git branch contains these updates to the upstream
3465 .gitignore file(s). This patch is autogenerated, to provide these
3466 updates to users of the official Debian archive view of the package.
3468 [dgit version $our_version]
3471 close GIPATCH or die "$gipatch: $!";
3472 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3473 $unapplied, $headref, "--", sort keys %$editedignores;
3474 open SERIES, "+>>", "debian/patches/series" or die $!;
3475 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3477 defined read SERIES, $newline, 1 or die $!;
3478 print SERIES "\n" or die $! unless $newline eq "\n";
3479 print SERIES "auto-gitignore\n" or die $!;
3480 close SERIES or die $!;
3481 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3482 commit_admin "Commit patch to update .gitignore";
3485 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3487 changedir '../../../..';
3488 ensuredir ".git/logs/refs/dgit-intern";
3489 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3491 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3494 progress "dgit view: created (commit id $dgitview)";
3496 changedir '.git/dgit/unpack/work';
3499 sub quiltify ($$$$) {
3500 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3502 # Quilt patchification algorithm
3504 # We search backwards through the history of the main tree's HEAD
3505 # (T) looking for a start commit S whose tree object is identical
3506 # to to the patch tip tree (ie the tree corresponding to the
3507 # current dpkg-committed patch series). For these purposes
3508 # `identical' disregards anything in debian/ - this wrinkle is
3509 # necessary because dpkg-source treates debian/ specially.
3511 # We can only traverse edges where at most one of the ancestors'
3512 # trees differs (in changes outside in debian/). And we cannot
3513 # handle edges which change .pc/ or debian/patches. To avoid
3514 # going down a rathole we avoid traversing edges which introduce
3515 # debian/rules or debian/control. And we set a limit on the
3516 # number of edges we are willing to look at.
3518 # If we succeed, we walk forwards again. For each traversed edge
3519 # PC (with P parent, C child) (starting with P=S and ending with
3520 # C=T) to we do this:
3522 # - dpkg-source --commit with a patch name and message derived from C
3523 # After traversing PT, we git commit the changes which
3524 # should be contained within debian/patches.
3526 # The search for the path S..T is breadth-first. We maintain a
3527 # todo list containing search nodes. A search node identifies a
3528 # commit, and looks something like this:
3530 # Commit => $git_commit_id,
3531 # Child => $c, # or undef if P=T
3532 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3533 # Nontrivial => true iff $p..$c has relevant changes
3540 my %considered; # saves being exponential on some weird graphs
3542 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3545 my ($search,$whynot) = @_;
3546 printdebug " search NOT $search->{Commit} $whynot\n";
3547 $search->{Whynot} = $whynot;
3548 push @nots, $search;
3549 no warnings qw(exiting);
3558 my $c = shift @todo;
3559 next if $considered{$c->{Commit}}++;
3561 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3563 printdebug "quiltify investigate $c->{Commit}\n";
3566 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3567 printdebug " search finished hooray!\n";
3572 if ($quilt_mode eq 'nofix') {
3573 fail "quilt fixup required but quilt mode is \`nofix'\n".
3574 "HEAD commit $c->{Commit} differs from tree implied by ".
3575 " debian/patches (tree object $oldtiptree)";
3577 if ($quilt_mode eq 'smash') {
3578 printdebug " search quitting smash\n";
3582 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3583 $not->($c, "has $c_sentinels not $t_sentinels")
3584 if $c_sentinels ne $t_sentinels;
3586 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3587 $commitdata =~ m/\n\n/;
3589 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3590 @parents = map { { Commit => $_, Child => $c } } @parents;
3592 $not->($c, "root commit") if !@parents;
3594 foreach my $p (@parents) {
3595 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3597 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3598 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3600 foreach my $p (@parents) {
3601 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3603 my @cmd= (@git, qw(diff-tree -r --name-only),
3604 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3605 my $patchstackchange = cmdoutput @cmd;
3606 if (length $patchstackchange) {
3607 $patchstackchange =~ s/\n/,/g;
3608 $not->($p, "changed $patchstackchange");
3611 printdebug " search queue P=$p->{Commit} ",
3612 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3618 printdebug "quiltify want to smash\n";
3621 my $x = $_[0]{Commit};
3622 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3625 my $reportnot = sub {
3627 my $s = $abbrev->($notp);
3628 my $c = $notp->{Child};
3629 $s .= "..".$abbrev->($c) if $c;
3630 $s .= ": ".$notp->{Whynot};
3633 if ($quilt_mode eq 'linear') {
3634 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3635 foreach my $notp (@nots) {
3636 print STDERR "$us: ", $reportnot->($notp), "\n";
3638 print STDERR "$us: $_\n" foreach @$failsuggestion;
3639 fail "quilt fixup naive history linearisation failed.\n".
3640 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3641 } elsif ($quilt_mode eq 'smash') {
3642 } elsif ($quilt_mode eq 'auto') {
3643 progress "quilt fixup cannot be linear, smashing...";
3645 die "$quilt_mode ?";
3648 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3649 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3651 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3653 quiltify_dpkg_commit "auto-$version-$target-$time",
3654 (getfield $clogp, 'Maintainer'),
3655 "Automatically generated patch ($clogp->{Version})\n".
3656 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3660 progress "quiltify linearisation planning successful, executing...";
3662 for (my $p = $sref_S;
3663 my $c = $p->{Child};
3665 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3666 next unless $p->{Nontrivial};
3668 my $cc = $c->{Commit};
3670 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3671 $commitdata =~ m/\n\n/ or die "$c ?";
3674 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3677 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3680 my $patchname = $title;
3681 $patchname =~ s/[.:]$//;
3682 $patchname =~ y/ A-Z/-a-z/;
3683 $patchname =~ y/-a-z0-9_.+=~//cd;
3684 $patchname =~ s/^\W/x-$&/;
3685 $patchname = substr($patchname,0,40);
3688 stat "debian/patches/$patchname$index";
3690 $!==ENOENT or die "$patchname$index $!";
3692 runcmd @git, qw(checkout -q), $cc;
3694 # We use the tip's changelog so that dpkg-source doesn't
3695 # produce complaining messages from dpkg-parsechangelog. None
3696 # of the information dpkg-source gets from the changelog is
3697 # actually relevant - it gets put into the original message
3698 # which dpkg-source provides our stunt editor, and then
3700 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3702 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3703 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3705 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3708 runcmd @git, qw(checkout -q master);
3711 sub build_maybe_quilt_fixup () {
3712 my ($format,$fopts) = get_source_format;
3713 return unless madformat_wantfixup $format;
3716 check_for_vendor_patches();
3718 if (quiltmode_splitbrain) {
3719 foreach my $needtf (qw(new maint)) {
3720 next if grep { $_ eq $needtf } access_cfg_tagformats;
3722 quilt mode $quilt_mode requires split view so server needs to support
3723 both "new" and "maint" tag formats, but config says it doesn't.
3728 my $clogp = parsechangelog();
3729 my $headref = git_rev_parse('HEAD');
3734 my $upstreamversion=$version;
3735 $upstreamversion =~ s/-[^-]*$//;
3737 if ($fopts->{'single-debian-patch'}) {
3738 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3740 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3743 die 'bug' if $split_brain && !$need_split_build_invocation;
3745 changedir '../../../..';
3746 runcmd_ordryrun_local
3747 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3750 sub quilt_fixup_mkwork ($) {
3753 mkdir "work" or die $!;
3755 mktree_in_ud_here();
3756 runcmd @git, qw(reset -q --hard), $headref;
3759 sub quilt_fixup_linkorigs ($$) {
3760 my ($upstreamversion, $fn) = @_;
3761 # calls $fn->($leafname);
3763 foreach my $f (<../../../../*>) { #/){
3764 my $b=$f; $b =~ s{.*/}{};
3766 local ($debuglevel) = $debuglevel-1;
3767 printdebug "QF linkorigs $b, $f ?\n";
3769 next unless is_orig_file_of_vsn $b, $upstreamversion;
3770 printdebug "QF linkorigs $b, $f Y\n";
3771 link_ltarget $f, $b or die "$b $!";
3776 sub quilt_fixup_delete_pc () {
3777 runcmd @git, qw(rm -rqf .pc);
3778 commit_admin "Commit removal of .pc (quilt series tracking data)";
3781 sub quilt_fixup_singlepatch ($$$) {
3782 my ($clogp, $headref, $upstreamversion) = @_;
3784 progress "starting quiltify (single-debian-patch)";
3786 # dpkg-source --commit generates new patches even if
3787 # single-debian-patch is in debian/source/options. In order to
3788 # get it to generate debian/patches/debian-changes, it is
3789 # necessary to build the source package.
3791 quilt_fixup_linkorigs($upstreamversion, sub { });
3792 quilt_fixup_mkwork($headref);
3794 rmtree("debian/patches");
3796 runcmd @dpkgsource, qw(-b .);
3798 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3799 rename srcfn("$upstreamversion", "/debian/patches"),
3800 "work/debian/patches";
3803 commit_quilty_patch();
3806 sub quilt_make_fake_dsc ($) {
3807 my ($upstreamversion) = @_;
3809 my $fakeversion="$upstreamversion-~~DGITFAKE";
3811 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3812 print $fakedsc <<END or die $!;
3815 Version: $fakeversion
3819 my $dscaddfile=sub {
3822 my $md = new Digest::MD5;
3824 my $fh = new IO::File $b, '<' or die "$b $!";
3829 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3832 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3834 my @files=qw(debian/source/format debian/rules
3835 debian/control debian/changelog);
3836 foreach my $maybe (qw(debian/patches debian/source/options
3837 debian/tests/control)) {
3838 next unless stat_exists "../../../$maybe";
3839 push @files, $maybe;
3842 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3843 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3845 $dscaddfile->($debtar);
3846 close $fakedsc or die $!;
3849 sub quilt_check_splitbrain_cache ($$) {
3850 my ($headref, $upstreamversion) = @_;
3851 # Called only if we are in (potentially) split brain mode.
3853 # Computes the cache key and looks in the cache.
3854 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3856 my $splitbrain_cachekey;
3859 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3860 # we look in the reflog of dgit-intern/quilt-cache
3861 # we look for an entry whose message is the key for the cache lookup
3862 my @cachekey = (qw(dgit), $our_version);
3863 push @cachekey, $upstreamversion;
3864 push @cachekey, $quilt_mode;
3865 push @cachekey, $headref;
3867 push @cachekey, hashfile('fake.dsc');
3869 my $srcshash = Digest::SHA->new(256);
3870 my %sfs = ( %INC, '$0(dgit)' => $0 );
3871 foreach my $sfk (sort keys %sfs) {
3872 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3873 $srcshash->add($sfk," ");
3874 $srcshash->add(hashfile($sfs{$sfk}));
3875 $srcshash->add("\n");
3877 push @cachekey, $srcshash->hexdigest();
3878 $splitbrain_cachekey = "@cachekey";
3880 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3882 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3883 debugcmd "|(probably)",@cmd;
3884 my $child = open GC, "-|"; defined $child or die $!;
3886 chdir '../../..' or die $!;
3887 if (!stat ".git/logs/refs/$splitbraincache") {
3888 $! == ENOENT or die $!;
3889 printdebug ">(no reflog)\n";
3896 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3897 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3900 quilt_fixup_mkwork($headref);
3901 if ($cachehit ne $headref) {
3902 progress "dgit view: found cached (commit id $cachehit)";
3903 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3905 return ($cachehit, $splitbrain_cachekey);
3907 progress "dgit view: found cached, no changes required";
3908 return ($headref, $splitbrain_cachekey);
3910 die $! if GC->error;
3911 failedcmd unless close GC;
3913 printdebug "splitbrain cache miss\n";
3914 return (undef, $splitbrain_cachekey);
3917 sub quilt_fixup_multipatch ($$$) {
3918 my ($clogp, $headref, $upstreamversion) = @_;
3920 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3923 # - honour any existing .pc in case it has any strangeness
3924 # - determine the git commit corresponding to the tip of
3925 # the patch stack (if there is one)
3926 # - if there is such a git commit, convert each subsequent
3927 # git commit into a quilt patch with dpkg-source --commit
3928 # - otherwise convert all the differences in the tree into
3929 # a single git commit
3933 # Our git tree doesn't necessarily contain .pc. (Some versions of
3934 # dgit would include the .pc in the git tree.) If there isn't
3935 # one, we need to generate one by unpacking the patches that we
3938 # We first look for a .pc in the git tree. If there is one, we
3939 # will use it. (This is not the normal case.)
3941 # Otherwise need to regenerate .pc so that dpkg-source --commit
3942 # can work. We do this as follows:
3943 # 1. Collect all relevant .orig from parent directory
3944 # 2. Generate a debian.tar.gz out of
3945 # debian/{patches,rules,source/format,source/options}
3946 # 3. Generate a fake .dsc containing just these fields:
3947 # Format Source Version Files
3948 # 4. Extract the fake .dsc
3949 # Now the fake .dsc has a .pc directory.
3950 # (In fact we do this in every case, because in future we will
3951 # want to search for a good base commit for generating patches.)
3953 # Then we can actually do the dpkg-source --commit
3954 # 1. Make a new working tree with the same object
3955 # store as our main tree and check out the main
3957 # 2. Copy .pc from the fake's extraction, if necessary
3958 # 3. Run dpkg-source --commit
3959 # 4. If the result has changes to debian/, then
3960 # - git-add them them
3961 # - git-add .pc if we had a .pc in-tree
3963 # 5. If we had a .pc in-tree, delete it, and git-commit
3964 # 6. Back in the main tree, fast forward to the new HEAD
3966 # Another situation we may have to cope with is gbp-style
3967 # patches-unapplied trees.
3969 # We would want to detect these, so we know to escape into
3970 # quilt_fixup_gbp. However, this is in general not possible.
3971 # Consider a package with a one patch which the dgit user reverts
3972 # (with git-revert or the moral equivalent).
3974 # That is indistinguishable in contents from a patches-unapplied
3975 # tree. And looking at the history to distinguish them is not
3976 # useful because the user might have made a confusing-looking git
3977 # history structure (which ought to produce an error if dgit can't
3978 # cope, not a silent reintroduction of an unwanted patch).
3980 # So gbp users will have to pass an option. But we can usually
3981 # detect their failure to do so: if the tree is not a clean
3982 # patches-applied tree, quilt linearisation fails, but the tree
3983 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3984 # they want --quilt=unapplied.
3986 # To help detect this, when we are extracting the fake dsc, we
3987 # first extract it with --skip-patches, and then apply the patches
3988 # afterwards with dpkg-source --before-build. That lets us save a
3989 # tree object corresponding to .origs.
3991 my $splitbrain_cachekey;
3993 quilt_make_fake_dsc($upstreamversion);
3995 if (quiltmode_splitbrain()) {
3997 ($cachehit, $splitbrain_cachekey) =
3998 quilt_check_splitbrain_cache($headref, $upstreamversion);
3999 return if $cachehit;
4003 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4005 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4006 rename $fakexdir, "fake" or die "$fakexdir $!";
4010 remove_stray_gits();
4011 mktree_in_ud_here();
4015 runcmd @git, qw(add -Af .);
4016 my $unapplied=git_write_tree();
4017 printdebug "fake orig tree object $unapplied\n";
4022 'exec dpkg-source --before-build . >/dev/null';
4026 quilt_fixup_mkwork($headref);
4029 if (stat_exists ".pc") {
4031 progress "Tree already contains .pc - will use it then delete it.";
4034 rename '../fake/.pc','.pc' or die $!;
4037 changedir '../fake';
4039 runcmd @git, qw(add -Af .);
4040 my $oldtiptree=git_write_tree();
4041 printdebug "fake o+d/p tree object $unapplied\n";
4042 changedir '../work';
4045 # We calculate some guesswork now about what kind of tree this might
4046 # be. This is mostly for error reporting.
4051 # O = orig, without patches applied
4052 # A = "applied", ie orig with H's debian/patches applied
4053 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4054 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4055 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4059 foreach my $b (qw(01 02)) {
4060 foreach my $v (qw(H2O O2A H2A)) {
4061 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4064 printdebug "differences \@dl @dl.\n";
4067 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4068 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4069 $dl[0], $dl[1], $dl[3], $dl[4],
4073 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4074 push @failsuggestion, "This might be a patches-unapplied branch.";
4075 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4076 push @failsuggestion, "This might be a patches-applied branch.";
4078 push @failsuggestion, "Maybe you need to specify one of".
4079 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4081 if (quiltmode_splitbrain()) {
4082 quiltify_splitbrain($clogp, $unapplied, $headref,
4083 $diffbits, \%editedignores,
4084 $splitbrain_cachekey);
4088 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4089 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4091 if (!open P, '>>', ".pc/applied-patches") {
4092 $!==&ENOENT or die $!;
4097 commit_quilty_patch();
4099 if ($mustdeletepc) {
4100 quilt_fixup_delete_pc();
4104 sub quilt_fixup_editor () {
4105 my $descfn = $ENV{$fakeeditorenv};
4106 my $editing = $ARGV[$#ARGV];
4107 open I1, '<', $descfn or die "$descfn: $!";
4108 open I2, '<', $editing or die "$editing: $!";
4109 unlink $editing or die "$editing: $!";
4110 open O, '>', $editing or die "$editing: $!";
4111 while (<I1>) { print O or die $!; } I1->error and die $!;
4114 $copying ||= m/^\-\-\- /;
4115 next unless $copying;
4118 I2->error and die $!;
4123 sub maybe_apply_patches_dirtily () {
4124 return unless $quilt_mode =~ m/gbp|unapplied/;
4125 print STDERR <<END or die $!;
4127 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4128 dgit: Have to apply the patches - making the tree dirty.
4129 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4132 $patches_applied_dirtily = 01;
4133 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4134 runcmd qw(dpkg-source --before-build .);
4137 sub maybe_unapply_patches_again () {
4138 progress "dgit: Unapplying patches again to tidy up the tree."
4139 if $patches_applied_dirtily;
4140 runcmd qw(dpkg-source --after-build .)
4141 if $patches_applied_dirtily & 01;
4143 if $patches_applied_dirtily & 02;
4144 $patches_applied_dirtily = 0;
4147 #----- other building -----
4149 our $clean_using_builder;
4150 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4151 # clean the tree before building (perhaps invoked indirectly by
4152 # whatever we are using to run the build), rather than separately
4153 # and explicitly by us.
4156 return if $clean_using_builder;
4157 if ($cleanmode eq 'dpkg-source') {
4158 maybe_apply_patches_dirtily();
4159 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4160 } elsif ($cleanmode eq 'dpkg-source-d') {
4161 maybe_apply_patches_dirtily();
4162 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4163 } elsif ($cleanmode eq 'git') {
4164 runcmd_ordryrun_local @git, qw(clean -xdf);
4165 } elsif ($cleanmode eq 'git-ff') {
4166 runcmd_ordryrun_local @git, qw(clean -xdff);
4167 } elsif ($cleanmode eq 'check') {
4168 my $leftovers = cmdoutput @git, qw(clean -xdn);
4169 if (length $leftovers) {
4170 print STDERR $leftovers, "\n" or die $!;
4171 fail "tree contains uncommitted files and --clean=check specified";
4173 } elsif ($cleanmode eq 'none') {
4180 badusage "clean takes no additional arguments" if @ARGV;
4183 maybe_unapply_patches_again();
4188 badusage "-p is not allowed when building" if defined $package;
4191 my $clogp = parsechangelog();
4192 $isuite = getfield $clogp, 'Distribution';
4193 $package = getfield $clogp, 'Source';
4194 $version = getfield $clogp, 'Version';
4195 build_maybe_quilt_fixup();
4197 my $pat = changespat $version;
4198 foreach my $f (glob "$buildproductsdir/$pat") {
4200 unlink $f or fail "remove old changes file $f: $!";
4202 progress "would remove $f";
4208 sub changesopts_initial () {
4209 my @opts =@changesopts[1..$#changesopts];
4212 sub changesopts_version () {
4213 if (!defined $changes_since_version) {
4214 my @vsns = archive_query('archive_query');
4215 my @quirk = access_quirk();
4216 if ($quirk[0] eq 'backports') {
4217 local $isuite = $quirk[2];
4219 canonicalise_suite();
4220 push @vsns, archive_query('archive_query');
4223 @vsns = map { $_->[0] } @vsns;
4224 @vsns = sort { -version_compare($a, $b) } @vsns;
4225 $changes_since_version = $vsns[0];
4226 progress "changelog will contain changes since $vsns[0]";
4228 $changes_since_version = '_';
4229 progress "package seems new, not specifying -v<version>";
4232 if ($changes_since_version ne '_') {
4233 return ("-v$changes_since_version");
4239 sub changesopts () {
4240 return (changesopts_initial(), changesopts_version());
4243 sub massage_dbp_args ($;$) {
4244 my ($cmd,$xargs) = @_;
4247 # - if we're going to split the source build out so we can
4248 # do strange things to it, massage the arguments to dpkg-buildpackage
4249 # so that the main build doessn't build source (or add an argument
4250 # to stop it building source by default).
4252 # - add -nc to stop dpkg-source cleaning the source tree,
4253 # unless we're not doing a split build and want dpkg-source
4254 # as cleanmode, in which case we can do nothing
4257 # 0 - source will NOT need to be built separately by caller
4258 # +1 - source will need to be built separately by caller
4259 # +2 - source will need to be built separately by caller AND
4260 # dpkg-buildpackage should not in fact be run at all!
4261 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4262 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4263 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4264 $clean_using_builder = 1;
4267 # -nc has the side effect of specifying -b if nothing else specified
4268 # and some combinations of -S, -b, et al, are errors, rather than
4269 # later simply overriding earlie. So we need to:
4270 # - search the command line for these options
4271 # - pick the last one
4272 # - perhaps add our own as a default
4273 # - perhaps adjust it to the corresponding non-source-building version
4275 foreach my $l ($cmd, $xargs) {
4277 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4280 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4282 if ($need_split_build_invocation) {
4283 printdebug "massage split $dmode.\n";
4284 $r = $dmode =~ m/[S]/ ? +2 :
4285 $dmode =~ y/gGF/ABb/ ? +1 :
4286 $dmode =~ m/[ABb]/ ? 0 :
4289 printdebug "massage done $r $dmode.\n";
4291 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4296 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4297 my $wantsrc = massage_dbp_args \@dbp;
4304 push @dbp, changesopts_version();
4305 maybe_apply_patches_dirtily();
4306 runcmd_ordryrun_local @dbp;
4308 maybe_unapply_patches_again();
4309 printdone "build successful\n";
4313 my @dbp = @dpkgbuildpackage;
4315 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4318 if (length executable_on_path('git-buildpackage')) {
4319 @cmd = qw(git-buildpackage);
4321 @cmd = qw(gbp buildpackage);
4323 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4328 if (!$clean_using_builder) {
4329 push @cmd, '--git-cleaner=true';
4333 maybe_unapply_patches_again();
4335 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4336 canonicalise_suite();
4337 push @cmd, "--git-debian-branch=".lbranch();
4339 push @cmd, changesopts();
4340 runcmd_ordryrun_local @cmd, @ARGV;
4342 printdone "build successful\n";
4344 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4347 my $our_cleanmode = $cleanmode;
4348 if ($need_split_build_invocation) {
4349 # Pretend that clean is being done some other way. This
4350 # forces us not to try to use dpkg-buildpackage to clean and
4351 # build source all in one go; and instead we run dpkg-source
4352 # (and build_prep() will do the clean since $clean_using_builder
4354 $our_cleanmode = 'ELSEWHERE';
4356 if ($our_cleanmode =~ m/^dpkg-source/) {
4357 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4358 $clean_using_builder = 1;
4361 $sourcechanges = changespat $version,'source';
4363 unlink "../$sourcechanges" or $!==ENOENT
4364 or fail "remove $sourcechanges: $!";
4366 $dscfn = dscfn($version);
4367 if ($our_cleanmode eq 'dpkg-source') {
4368 maybe_apply_patches_dirtily();
4369 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4371 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4372 maybe_apply_patches_dirtily();
4373 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4376 my @cmd = (@dpkgsource, qw(-b --));
4379 runcmd_ordryrun_local @cmd, "work";
4380 my @udfiles = <${package}_*>;
4381 changedir "../../..";
4382 foreach my $f (@udfiles) {
4383 printdebug "source copy, found $f\n";
4386 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4387 $f eq srcfn($version, $&));
4388 printdebug "source copy, found $f - renaming\n";
4389 rename "$ud/$f", "../$f" or $!==ENOENT
4390 or fail "put in place new source file ($f): $!";
4393 my $pwd = must_getcwd();
4394 my $leafdir = basename $pwd;
4396 runcmd_ordryrun_local @cmd, $leafdir;
4399 runcmd_ordryrun_local qw(sh -ec),
4400 'exec >$1; shift; exec "$@"','x',
4401 "../$sourcechanges",
4402 @dpkggenchanges, qw(-S), changesopts();
4406 sub cmd_build_source {
4407 badusage "build-source takes no additional arguments" if @ARGV;
4409 maybe_unapply_patches_again();
4410 printdone "source built, results in $dscfn and $sourcechanges";
4415 my $pat = changespat $version;
4417 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4418 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4419 fail "changes files other than source matching $pat".
4420 " already present (@unwanted);".
4421 " building would result in ambiguity about the intended results"
4424 my $wasdir = must_getcwd();
4427 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4428 stat_exists $sourcechanges
4429 or fail "$sourcechanges (in parent directory): $!";
4431 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4432 my @changesfiles = glob $pat;
4433 @changesfiles = sort {
4434 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4437 fail "wrong number of different changes files (@changesfiles)"
4438 unless @changesfiles==2;
4439 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4440 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4441 fail "$l found in binaries changes file $binchanges"
4444 runcmd_ordryrun_local @mergechanges, @changesfiles;
4445 my $multichanges = changespat $version,'multi';
4447 stat_exists $multichanges or fail "$multichanges: $!";
4448 foreach my $cf (glob $pat) {
4449 next if $cf eq $multichanges;
4450 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4454 maybe_unapply_patches_again();
4455 printdone "build successful, results in $multichanges\n" or die $!;
4458 sub cmd_quilt_fixup {
4459 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4460 my $clogp = parsechangelog();
4461 $version = getfield $clogp, 'Version';
4462 $package = getfield $clogp, 'Source';
4465 build_maybe_quilt_fixup();
4468 sub cmd_archive_api_query {
4469 badusage "need only 1 subpath argument" unless @ARGV==1;
4470 my ($subpath) = @ARGV;
4471 my @cmd = archive_api_query_cmd($subpath);
4473 exec @cmd or fail "exec curl: $!\n";
4476 sub cmd_clone_dgit_repos_server {
4477 badusage "need destination argument" unless @ARGV==1;
4478 my ($destdir) = @ARGV;
4479 $package = '_dgit-repos-server';
4480 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4482 exec @cmd or fail "exec git clone: $!\n";
4485 sub cmd_setup_mergechangelogs {
4486 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4487 setup_mergechangelogs(1);
4490 sub cmd_setup_useremail {
4491 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4495 sub cmd_setup_new_tree {
4496 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4500 #---------- argument parsing and main program ----------
4503 print "dgit version $our_version\n" or die $!;
4507 our (%valopts_long, %valopts_short);
4510 sub defvalopt ($$$$) {
4511 my ($long,$short,$val_re,$how) = @_;
4512 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4513 $valopts_long{$long} = $oi;
4514 $valopts_short{$short} = $oi;
4515 # $how subref should:
4516 # do whatever assignemnt or thing it likes with $_[0]
4517 # if the option should not be passed on to remote, @rvalopts=()
4518 # or $how can be a scalar ref, meaning simply assign the value
4521 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4522 defvalopt '--distro', '-d', '.+', \$idistro;
4523 defvalopt '', '-k', '.+', \$keyid;
4524 defvalopt '--existing-package','', '.*', \$existing_package;
4525 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4526 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4527 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4529 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4531 defvalopt '', '-C', '.+', sub {
4532 ($changesfile) = (@_);
4533 if ($changesfile =~ s#^(.*)/##) {
4534 $buildproductsdir = $1;
4538 defvalopt '--initiator-tempdir','','.*', sub {
4539 ($initiator_tempdir) = (@_);
4540 $initiator_tempdir =~ m#^/# or
4541 badusage "--initiator-tempdir must be used specify an".
4542 " absolute, not relative, directory."
4548 if (defined $ENV{'DGIT_SSH'}) {
4549 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4550 } elsif (defined $ENV{'GIT_SSH'}) {
4551 @ssh = ($ENV{'GIT_SSH'});
4559 if (!defined $val) {
4560 badusage "$what needs a value" unless @ARGV;
4562 push @rvalopts, $val;
4564 badusage "bad value \`$val' for $what" unless
4565 $val =~ m/^$oi->{Re}$(?!\n)/s;
4566 my $how = $oi->{How};
4567 if (ref($how) eq 'SCALAR') {
4572 push @ropts, @rvalopts;
4576 last unless $ARGV[0] =~ m/^-/;
4580 if (m/^--dry-run$/) {
4583 } elsif (m/^--damp-run$/) {
4586 } elsif (m/^--no-sign$/) {
4589 } elsif (m/^--help$/) {
4591 } elsif (m/^--version$/) {
4593 } elsif (m/^--new$/) {
4596 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4597 ($om = $opts_opt_map{$1}) &&
4601 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4602 !$opts_opt_cmdonly{$1} &&
4603 ($om = $opts_opt_map{$1})) {
4606 } elsif (m/^--ignore-dirty$/s) {
4609 } elsif (m/^--no-quilt-fixup$/s) {
4611 $quilt_mode = 'nocheck';
4612 } elsif (m/^--no-rm-on-error$/s) {
4615 } elsif (m/^--overwrite$/s) {
4617 $overwrite_version = '';
4618 } elsif (m/^--overwrite=(.+)$/s) {
4620 $overwrite_version = $1;
4621 } elsif (m/^--(no-)?rm-old-changes$/s) {
4624 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4626 push @deliberatelies, $&;
4627 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4628 # undocumented, for testing
4630 $tagformat_want = [ $1, 'command line', 1 ];
4631 # 1 menas overrides distro configuration
4632 } elsif (m/^--always-split-source-build$/s) {
4633 # undocumented, for testing
4635 $need_split_build_invocation = 1;
4636 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4637 $val = $2 ? $' : undef; #';
4638 $valopt->($oi->{Long});
4640 badusage "unknown long option \`$_'";
4647 } elsif (s/^-L/-/) {
4650 } elsif (s/^-h/-/) {
4652 } elsif (s/^-D/-/) {
4656 } elsif (s/^-N/-/) {
4661 push @changesopts, $_;
4663 } elsif (s/^-wn$//s) {
4665 $cleanmode = 'none';
4666 } elsif (s/^-wg$//s) {
4669 } elsif (s/^-wgf$//s) {
4671 $cleanmode = 'git-ff';
4672 } elsif (s/^-wd$//s) {
4674 $cleanmode = 'dpkg-source';
4675 } elsif (s/^-wdd$//s) {
4677 $cleanmode = 'dpkg-source-d';
4678 } elsif (s/^-wc$//s) {
4680 $cleanmode = 'check';
4681 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4683 $val = undef unless length $val;
4684 $valopt->($oi->{Short});
4687 badusage "unknown short option \`$_'";
4694 sub finalise_opts_opts () {
4695 foreach my $k (keys %opts_opt_map) {
4696 my $om = $opts_opt_map{$k};
4698 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4700 badcfg "cannot set command for $k"
4701 unless length $om->[0];
4705 foreach my $c (access_cfg_cfgs("opts-$k")) {
4706 my $vl = $gitcfg{$c};
4707 printdebug "CL $c ",
4708 ($vl ? join " ", map { shellquote } @$vl : ""),
4709 "\n" if $debuglevel >= 4;
4711 badcfg "cannot configure options for $k"
4712 if $opts_opt_cmdonly{$k};
4713 my $insertpos = $opts_cfg_insertpos{$k};
4714 @$om = ( @$om[0..$insertpos-1],
4716 @$om[$insertpos..$#$om] );
4721 if ($ENV{$fakeeditorenv}) {
4723 quilt_fixup_editor();
4729 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4730 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4731 if $dryrun_level == 1;
4733 print STDERR $helpmsg or die $!;
4736 my $cmd = shift @ARGV;
4739 if (!defined $rmchanges) {
4740 local $access_forpush;
4741 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4744 if (!defined $quilt_mode) {
4745 local $access_forpush;
4746 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4747 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4749 $quilt_mode =~ m/^($quilt_modes_re)$/
4750 or badcfg "unknown quilt-mode \`$quilt_mode'";
4754 $need_split_build_invocation ||= quiltmode_splitbrain();
4756 if (!defined $cleanmode) {
4757 local $access_forpush;
4758 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4759 $cleanmode //= 'dpkg-source';
4761 badcfg "unknown clean-mode \`$cleanmode'" unless
4762 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4765 my $fn = ${*::}{"cmd_$cmd"};
4766 $fn or badusage "unknown operation $cmd";