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';
80 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
81 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?";
83 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
84 our $splitbraincache = 'dgit-intern/quilt-cache';
87 our (@dget) = qw(dget);
88 our (@curl) = qw(curl -f);
89 our (@dput) = qw(dput);
90 our (@debsign) = qw(debsign);
92 our (@sbuild) = qw(sbuild);
94 our (@dgit) = qw(dgit);
95 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
96 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
97 our (@dpkggenchanges) = qw(dpkg-genchanges);
98 our (@mergechanges) = qw(mergechanges -f);
100 our (@changesopts) = ('');
102 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
105 'debsign' => \@debsign,
107 'sbuild' => \@sbuild,
111 'dpkg-source' => \@dpkgsource,
112 'dpkg-buildpackage' => \@dpkgbuildpackage,
113 'dpkg-genchanges' => \@dpkggenchanges,
115 'ch' => \@changesopts,
116 'mergechanges' => \@mergechanges);
118 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
119 our %opts_cfg_insertpos = map {
121 scalar @{ $opts_opt_map{$_} }
122 } keys %opts_opt_map;
124 sub finalise_opts_opts();
130 our $supplementary_message = '';
131 our $need_split_build_invocation = 0;
132 our $split_brain = 0;
136 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
139 our $remotename = 'dgit';
140 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
145 my ($v,$distro) = @_;
146 return $tagformatfn->($v, $distro);
149 sub debiantag_maintview ($$) {
150 my ($v,$distro) = @_;
155 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
157 sub lbranch () { return "$branchprefix/$csuite"; }
158 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
159 sub lref () { return "refs/heads/".lbranch(); }
160 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
161 sub rrref () { return server_ref($csuite); }
163 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
164 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
166 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
167 # locally fetched refs because they have unhelpful names and clutter
168 # up gitk etc. So we track whether we have "used up" head ref (ie,
169 # whether we have made another local ref which refers to this object).
171 # (If we deleted them unconditionally, then we might end up
172 # re-fetching the same git objects each time dgit fetch was run.)
174 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
175 # in git_fetch_us to fetch the refs in question, and possibly a call
176 # to lrfetchref_used.
178 our (%lrfetchrefs_f, %lrfetchrefs_d);
179 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
181 sub lrfetchref_used ($) {
182 my ($fullrefname) = @_;
183 my $objid = $lrfetchrefs_f{$fullrefname};
184 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
195 return "${package}_".(stripepoch $vsn).$sfx
200 return srcfn($vsn,".dsc");
203 sub changespat ($;$) {
204 my ($vsn, $arch) = @_;
205 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
214 foreach my $f (@end) {
216 print STDERR "$us: cleanup: $@" if length $@;
220 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
222 sub no_such_package () {
223 print STDERR "$us: package $package does not exist in suite $isuite\n";
229 printdebug "CD $newdir\n";
230 chdir $newdir or confess "chdir: $newdir: $!";
233 sub deliberately ($) {
235 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
238 sub deliberately_not_fast_forward () {
239 foreach (qw(not-fast-forward fresh-repo)) {
240 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
244 sub quiltmode_splitbrain () {
245 $quilt_mode =~ m/gbp|dpm|unapplied/;
248 #---------- remote protocol support, common ----------
250 # remote push initiator/responder protocol:
251 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
252 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
253 # < dgit-remote-push-ready <actual-proto-vsn>
260 # > supplementary-message NBYTES # $protovsn >= 3
265 # > file parsed-changelog
266 # [indicates that output of dpkg-parsechangelog follows]
267 # > data-block NBYTES
268 # > [NBYTES bytes of data (no newline)]
269 # [maybe some more blocks]
278 # > param head DGIT-VIEW-HEAD
279 # > param csuite SUITE
280 # > param tagformat old|new
281 # > param maint-view MAINT-VIEW-HEAD
283 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
284 # # goes into tag, for replay prevention
287 # [indicates that signed tag is wanted]
288 # < data-block NBYTES
289 # < [NBYTES bytes of data (no newline)]
290 # [maybe some more blocks]
294 # > want signed-dsc-changes
295 # < data-block NBYTES [transfer of signed dsc]
297 # < data-block NBYTES [transfer of signed changes]
305 sub i_child_report () {
306 # Sees if our child has died, and reap it if so. Returns a string
307 # describing how it died if it failed, or undef otherwise.
308 return undef unless $i_child_pid;
309 my $got = waitpid $i_child_pid, WNOHANG;
310 return undef if $got <= 0;
311 die unless $got == $i_child_pid;
312 $i_child_pid = undef;
313 return undef unless $?;
314 return "build host child ".waitstatusmsg();
319 fail "connection lost: $!" if $fh->error;
320 fail "protocol violation; $m not expected";
323 sub badproto_badread ($$) {
325 fail "connection lost: $!" if $!;
326 my $report = i_child_report();
327 fail $report if defined $report;
328 badproto $fh, "eof (reading $wh)";
331 sub protocol_expect (&$) {
332 my ($match, $fh) = @_;
335 defined && chomp or badproto_badread $fh, "protocol message";
343 badproto $fh, "\`$_'";
346 sub protocol_send_file ($$) {
347 my ($fh, $ourfn) = @_;
348 open PF, "<", $ourfn or die "$ourfn: $!";
351 my $got = read PF, $d, 65536;
352 die "$ourfn: $!" unless defined $got;
354 print $fh "data-block ".length($d)."\n" or die $!;
355 print $fh $d or die $!;
357 PF->error and die "$ourfn $!";
358 print $fh "data-end\n" or die $!;
362 sub protocol_read_bytes ($$) {
363 my ($fh, $nbytes) = @_;
364 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
366 my $got = read $fh, $d, $nbytes;
367 $got==$nbytes or badproto_badread $fh, "data block";
371 sub protocol_receive_file ($$) {
372 my ($fh, $ourfn) = @_;
373 printdebug "() $ourfn\n";
374 open PF, ">", $ourfn or die "$ourfn: $!";
376 my ($y,$l) = protocol_expect {
377 m/^data-block (.*)$/ ? (1,$1) :
378 m/^data-end$/ ? (0,) :
382 my $d = protocol_read_bytes $fh, $l;
383 print PF $d or die $!;
388 #---------- remote protocol support, responder ----------
390 sub responder_send_command ($) {
392 return unless $we_are_responder;
393 # called even without $we_are_responder
394 printdebug ">> $command\n";
395 print PO $command, "\n" or die $!;
398 sub responder_send_file ($$) {
399 my ($keyword, $ourfn) = @_;
400 return unless $we_are_responder;
401 printdebug "]] $keyword $ourfn\n";
402 responder_send_command "file $keyword";
403 protocol_send_file \*PO, $ourfn;
406 sub responder_receive_files ($@) {
407 my ($keyword, @ourfns) = @_;
408 die unless $we_are_responder;
409 printdebug "[[ $keyword @ourfns\n";
410 responder_send_command "want $keyword";
411 foreach my $fn (@ourfns) {
412 protocol_receive_file \*PI, $fn;
415 protocol_expect { m/^files-end$/ } \*PI;
418 #---------- remote protocol support, initiator ----------
420 sub initiator_expect (&) {
422 protocol_expect { &$match } \*RO;
425 #---------- end remote code ----------
428 if ($we_are_responder) {
430 responder_send_command "progress ".length($m) or die $!;
431 print PO $m or die $!;
441 $ua = LWP::UserAgent->new();
445 progress "downloading $what...";
446 my $r = $ua->get(@_) or die $!;
447 return undef if $r->code == 404;
448 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
449 return $r->decoded_content(charset => 'none');
452 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
457 failedcmd @_ if system @_;
460 sub act_local () { return $dryrun_level <= 1; }
461 sub act_scary () { return !$dryrun_level; }
464 if (!$dryrun_level) {
465 progress "dgit ok: @_";
467 progress "would be ok: @_ (but dry run only)";
472 printcmd(\*STDERR,$debugprefix."#",@_);
475 sub runcmd_ordryrun {
483 sub runcmd_ordryrun_local {
492 my ($first_shell, @cmd) = @_;
493 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
496 our $helpmsg = <<END;
498 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
499 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
500 dgit [dgit-opts] build [dpkg-buildpackage-opts]
501 dgit [dgit-opts] sbuild [sbuild-opts]
502 dgit [dgit-opts] push [dgit-opts] [suite]
503 dgit [dgit-opts] rpush build-host:build-dir ...
504 important dgit options:
505 -k<keyid> sign tag and package with <keyid> instead of default
506 --dry-run -n do not change anything, but go through the motions
507 --damp-run -L like --dry-run but make local changes, without signing
508 --new -N allow introducing a new package
509 --debug -D increase debug level
510 -c<name>=<value> set git config option (used directly by dgit too)
513 our $later_warning_msg = <<END;
514 Perhaps the upload is stuck in incoming. Using the version from git.
518 print STDERR "$us: @_\n", $helpmsg or die $!;
523 @ARGV or badusage "too few arguments";
524 return scalar shift @ARGV;
528 print $helpmsg or die $!;
532 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
534 our %defcfg = ('dgit.default.distro' => 'debian',
535 'dgit.default.username' => '',
536 'dgit.default.archive-query-default-component' => 'main',
537 'dgit.default.ssh' => 'ssh',
538 'dgit.default.archive-query' => 'madison:',
539 'dgit.default.sshpsql-dbname' => 'service=projectb',
540 'dgit.default.dgit-tag-format' => 'old,new,maint',
541 # old means "repo server accepts pushes with old dgit tags"
542 # new means "repo server accepts pushes with new dgit tags"
543 # maint means "repo server accepts split brain pushes"
544 # hist means "repo server may have old pushes without new tag"
545 # ("hist" is implied by "old")
546 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
547 'dgit-distro.debian.git-check' => 'url',
548 'dgit-distro.debian.git-check-suffix' => '/info/refs',
549 'dgit-distro.debian.new-private-pushers' => 't',
550 'dgit-distro.debian.dgit-tag-format' => 'new',
551 'dgit-distro.debian/push.git-url' => '',
552 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
553 'dgit-distro.debian/push.git-user-force' => 'dgit',
554 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
555 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
556 'dgit-distro.debian/push.git-create' => 'true',
557 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
558 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
559 # 'dgit-distro.debian.archive-query-tls-key',
560 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
561 # ^ this does not work because curl is broken nowadays
562 # Fixing #790093 properly will involve providing providing the key
563 # in some pacagke and maybe updating these paths.
565 # 'dgit-distro.debian.archive-query-tls-curl-args',
566 # '--ca-path=/etc/ssl/ca-debian',
567 # ^ this is a workaround but works (only) on DSA-administered machines
568 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
569 'dgit-distro.debian.git-url-suffix' => '',
570 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
571 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
572 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
573 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
574 'dgit-distro.ubuntu.git-check' => 'false',
575 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
576 'dgit-distro.test-dummy.ssh' => "$td/ssh",
577 'dgit-distro.test-dummy.username' => "alice",
578 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
579 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
580 'dgit-distro.test-dummy.git-url' => "$td/git",
581 'dgit-distro.test-dummy.git-host' => "git",
582 'dgit-distro.test-dummy.git-path' => "$td/git",
583 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
584 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
585 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
586 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
591 sub git_slurp_config () {
592 local ($debuglevel) = $debuglevel-2;
595 my @cmd = (@git, qw(config -z --get-regexp .*));
598 open GITS, "-|", @cmd or die $!;
601 printdebug "=> ", (messagequote $_), "\n";
603 push @{ $gitcfg{$`} }, $'; #';
607 or ($!==0 && $?==256)
611 sub git_get_config ($) {
614 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
617 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
623 return undef if $c =~ /RETURN-UNDEF/;
624 my $v = git_get_config($c);
625 return $v if defined $v;
626 my $dv = $defcfg{$c};
627 return $dv if defined $dv;
629 badcfg "need value for one of: @_\n".
630 "$us: distro or suite appears not to be (properly) supported";
633 sub access_basedistro () {
634 if (defined $idistro) {
637 return cfg("dgit-suite.$isuite.distro",
638 "dgit.default.distro");
642 sub access_quirk () {
643 # returns (quirk name, distro to use instead or undef, quirk-specific info)
644 my $basedistro = access_basedistro();
645 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
647 if (defined $backports_quirk) {
648 my $re = $backports_quirk;
649 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
651 $re =~ s/\%/([-0-9a-z_]+)/
652 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
653 if ($isuite =~ m/^$re$/) {
654 return ('backports',"$basedistro-backports",$1);
657 return ('none',undef);
662 sub parse_cfg_bool ($$$) {
663 my ($what,$def,$v) = @_;
666 $v =~ m/^[ty1]/ ? 1 :
667 $v =~ m/^[fn0]/ ? 0 :
668 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
671 sub access_forpush_config () {
672 my $d = access_basedistro();
676 parse_cfg_bool('new-private-pushers', 0,
677 cfg("dgit-distro.$d.new-private-pushers",
680 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
683 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
684 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
685 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
686 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
689 sub access_forpush () {
690 $access_forpush //= access_forpush_config();
691 return $access_forpush;
695 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
696 badcfg "pushing but distro is configured readonly"
697 if access_forpush_config() eq '0';
699 $supplementary_message = <<'END' unless $we_are_responder;
700 Push failed, before we got started.
701 You can retry the push, after fixing the problem, if you like.
703 finalise_opts_opts();
707 finalise_opts_opts();
710 sub supplementary_message ($) {
712 if (!$we_are_responder) {
713 $supplementary_message = $msg;
715 } elsif ($protovsn >= 3) {
716 responder_send_command "supplementary-message ".length($msg)
718 print PO $msg or die $!;
722 sub access_distros () {
723 # Returns list of distros to try, in order
726 # 0. `instead of' distro name(s) we have been pointed to
727 # 1. the access_quirk distro, if any
728 # 2a. the user's specified distro, or failing that } basedistro
729 # 2b. the distro calculated from the suite }
730 my @l = access_basedistro();
732 my (undef,$quirkdistro) = access_quirk();
733 unshift @l, $quirkdistro;
734 unshift @l, $instead_distro;
735 @l = grep { defined } @l;
737 if (access_forpush()) {
738 @l = map { ("$_/push", $_) } @l;
743 sub access_cfg_cfgs (@) {
746 # The nesting of these loops determines the search order. We put
747 # the key loop on the outside so that we search all the distros
748 # for each key, before going on to the next key. That means that
749 # if access_cfg is called with a more specific, and then a less
750 # specific, key, an earlier distro can override the less specific
751 # without necessarily overriding any more specific keys. (If the
752 # distro wants to override the more specific keys it can simply do
753 # so; whereas if we did the loop the other way around, it would be
754 # impossible to for an earlier distro to override a less specific
755 # key but not the more specific ones without restating the unknown
756 # values of the more specific keys.
759 # We have to deal with RETURN-UNDEF specially, so that we don't
760 # terminate the search prematurely.
762 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
765 foreach my $d (access_distros()) {
766 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
768 push @cfgs, map { "dgit.default.$_" } @realkeys;
775 my (@cfgs) = access_cfg_cfgs(@keys);
776 my $value = cfg(@cfgs);
780 sub access_cfg_bool ($$) {
781 my ($def, @keys) = @_;
782 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
785 sub string_to_ssh ($) {
787 if ($spec =~ m/\s/) {
788 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
794 sub access_cfg_ssh () {
795 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
796 if (!defined $gitssh) {
799 return string_to_ssh $gitssh;
803 sub access_runeinfo ($) {
805 return ": dgit ".access_basedistro()." $info ;";
808 sub access_someuserhost ($) {
810 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
811 defined($user) && length($user) or
812 $user = access_cfg("$some-user",'username');
813 my $host = access_cfg("$some-host");
814 return length($user) ? "$user\@$host" : $host;
817 sub access_gituserhost () {
818 return access_someuserhost('git');
821 sub access_giturl (;$) {
823 my $url = access_cfg('git-url','RETURN-UNDEF');
826 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
827 return undef unless defined $proto;
830 access_gituserhost().
831 access_cfg('git-path');
833 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
836 return "$url/$package$suffix";
839 sub parsecontrolfh ($$;$) {
840 my ($fh, $desc, $allowsigned) = @_;
841 our $dpkgcontrolhash_noissigned;
844 my %opts = ('name' => $desc);
845 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
846 $c = Dpkg::Control::Hash->new(%opts);
847 $c->parse($fh,$desc) or die "parsing of $desc failed";
848 last if $allowsigned;
849 last if $dpkgcontrolhash_noissigned;
850 my $issigned= $c->get_option('is_pgp_signed');
851 if (!defined $issigned) {
852 $dpkgcontrolhash_noissigned= 1;
853 seek $fh, 0,0 or die "seek $desc: $!";
854 } elsif ($issigned) {
855 fail "control file $desc is (already) PGP-signed. ".
856 " Note that dgit push needs to modify the .dsc and then".
857 " do the signature itself";
866 my ($file, $desc) = @_;
867 my $fh = new IO::Handle;
868 open $fh, '<', $file or die "$file: $!";
869 my $c = parsecontrolfh($fh,$desc);
870 $fh->error and die $!;
876 my ($dctrl,$field) = @_;
877 my $v = $dctrl->{$field};
878 return $v if defined $v;
879 fail "missing field $field in ".$dctrl->get_option('name');
883 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
884 my $p = new IO::Handle;
885 my @cmd = (qw(dpkg-parsechangelog), @_);
886 open $p, '-|', @cmd or die $!;
888 $?=0; $!=0; close $p or failedcmd @cmd;
892 sub commit_getclogp ($) {
893 # Returns the parsed changelog hashref for a particular commit
895 our %commit_getclogp_memo;
896 my $memo = $commit_getclogp_memo{$objid};
897 return $memo if $memo;
899 my $mclog = ".git/dgit/clog-$objid";
900 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
901 "$objid:debian/changelog";
902 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
907 defined $d or fail "getcwd failed: $!";
913 sub archive_query ($) {
915 my $query = access_cfg('archive-query','RETURN-UNDEF');
916 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
919 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
922 sub pool_dsc_subpath ($$) {
923 my ($vsn,$component) = @_; # $package is implict arg
924 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
925 return "/pool/$component/$prefix/$package/".dscfn($vsn);
928 #---------- `ftpmasterapi' archive query method (nascent) ----------
930 sub archive_api_query_cmd ($) {
932 my @cmd = qw(curl -sS);
933 my $url = access_cfg('archive-query-url');
934 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
936 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
937 foreach my $key (split /\:/, $keys) {
938 $key =~ s/\%HOST\%/$host/g;
940 fail "for $url: stat $key: $!" unless $!==ENOENT;
943 fail "config requested specific TLS key but do not know".
944 " how to get curl to use exactly that EE key ($key)";
945 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
946 # # Sadly the above line does not work because of changes
947 # # to gnutls. The real fix for #790093 may involve
948 # # new curl options.
951 # Fixing #790093 properly will involve providing a value
952 # for this on clients.
953 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
954 push @cmd, split / /, $kargs if defined $kargs;
956 push @cmd, $url.$subpath;
962 my ($data, $subpath) = @_;
963 badcfg "ftpmasterapi archive query method takes no data part"
965 my @cmd = archive_api_query_cmd($subpath);
966 my $json = cmdoutput @cmd;
967 return decode_json($json);
970 sub canonicalise_suite_ftpmasterapi () {
971 my ($proto,$data) = @_;
972 my $suites = api_query($data, 'suites');
974 foreach my $entry (@$suites) {
976 my $v = $entry->{$_};
977 defined $v && $v eq $isuite;
979 push @matched, $entry;
981 fail "unknown suite $isuite" unless @matched;
984 @matched==1 or die "multiple matches for suite $isuite\n";
985 $cn = "$matched[0]{codename}";
986 defined $cn or die "suite $isuite info has no codename\n";
987 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
989 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
994 sub archive_query_ftpmasterapi () {
995 my ($proto,$data) = @_;
996 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
998 my $digester = Digest::SHA->new(256);
999 foreach my $entry (@$info) {
1001 my $vsn = "$entry->{version}";
1002 my ($ok,$msg) = version_check $vsn;
1003 die "bad version: $msg\n" unless $ok;
1004 my $component = "$entry->{component}";
1005 $component =~ m/^$component_re$/ or die "bad component";
1006 my $filename = "$entry->{filename}";
1007 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1008 or die "bad filename";
1009 my $sha256sum = "$entry->{sha256sum}";
1010 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1011 push @rows, [ $vsn, "/pool/$component/$filename",
1012 $digester, $sha256sum ];
1014 die "bad ftpmaster api response: $@\n".Dumper($entry)
1017 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1021 #---------- `madison' archive query method ----------
1023 sub archive_query_madison {
1024 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1027 sub madison_get_parse {
1028 my ($proto,$data) = @_;
1029 die unless $proto eq 'madison';
1030 if (!length $data) {
1031 $data= access_cfg('madison-distro','RETURN-UNDEF');
1032 $data //= access_basedistro();
1034 $rmad{$proto,$data,$package} ||= cmdoutput
1035 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1036 my $rmad = $rmad{$proto,$data,$package};
1039 foreach my $l (split /\n/, $rmad) {
1040 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1041 \s*( [^ \t|]+ )\s* \|
1042 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1043 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1044 $1 eq $package or die "$rmad $package ?";
1051 $component = access_cfg('archive-query-default-component');
1053 $5 eq 'source' or die "$rmad ?";
1054 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1056 return sort { -version_compare($a->[0],$b->[0]); } @out;
1059 sub canonicalise_suite_madison {
1060 # madison canonicalises for us
1061 my @r = madison_get_parse(@_);
1063 "unable to canonicalise suite using package $package".
1064 " which does not appear to exist in suite $isuite;".
1065 " --existing-package may help";
1069 #---------- `sshpsql' archive query method ----------
1072 my ($data,$runeinfo,$sql) = @_;
1073 if (!length $data) {
1074 $data= access_someuserhost('sshpsql').':'.
1075 access_cfg('sshpsql-dbname');
1077 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1078 my ($userhost,$dbname) = ($`,$'); #';
1080 my @cmd = (access_cfg_ssh, $userhost,
1081 access_runeinfo("ssh-psql $runeinfo").
1082 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1083 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1085 open P, "-|", @cmd or die $!;
1088 printdebug(">|$_|\n");
1091 $!=0; $?=0; close P or failedcmd @cmd;
1093 my $nrows = pop @rows;
1094 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1095 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1096 @rows = map { [ split /\|/, $_ ] } @rows;
1097 my $ncols = scalar @{ shift @rows };
1098 die if grep { scalar @$_ != $ncols } @rows;
1102 sub sql_injection_check {
1103 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1106 sub archive_query_sshpsql ($$) {
1107 my ($proto,$data) = @_;
1108 sql_injection_check $isuite, $package;
1109 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1110 SELECT source.version, component.name, files.filename, files.sha256sum
1112 JOIN src_associations ON source.id = src_associations.source
1113 JOIN suite ON suite.id = src_associations.suite
1114 JOIN dsc_files ON dsc_files.source = source.id
1115 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1116 JOIN component ON component.id = files_archive_map.component_id
1117 JOIN files ON files.id = dsc_files.file
1118 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1119 AND source.source='$package'
1120 AND files.filename LIKE '%.dsc';
1122 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1123 my $digester = Digest::SHA->new(256);
1125 my ($vsn,$component,$filename,$sha256sum) = @$_;
1126 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1131 sub canonicalise_suite_sshpsql ($$) {
1132 my ($proto,$data) = @_;
1133 sql_injection_check $isuite;
1134 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1135 SELECT suite.codename
1136 FROM suite where suite_name='$isuite' or codename='$isuite';
1138 @rows = map { $_->[0] } @rows;
1139 fail "unknown suite $isuite" unless @rows;
1140 die "ambiguous $isuite: @rows ?" if @rows>1;
1144 #---------- `dummycat' archive query method ----------
1146 sub canonicalise_suite_dummycat ($$) {
1147 my ($proto,$data) = @_;
1148 my $dpath = "$data/suite.$isuite";
1149 if (!open C, "<", $dpath) {
1150 $!==ENOENT or die "$dpath: $!";
1151 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1155 chomp or die "$dpath: $!";
1157 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1161 sub archive_query_dummycat ($$) {
1162 my ($proto,$data) = @_;
1163 canonicalise_suite();
1164 my $dpath = "$data/package.$csuite.$package";
1165 if (!open C, "<", $dpath) {
1166 $!==ENOENT or die "$dpath: $!";
1167 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1175 printdebug "dummycat query $csuite $package $dpath | $_\n";
1176 my @row = split /\s+/, $_;
1177 @row==2 or die "$dpath: $_ ?";
1180 C->error and die "$dpath: $!";
1182 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1185 #---------- tag format handling ----------
1187 sub access_cfg_tagformats () {
1188 split /\,/, access_cfg('dgit-tag-format');
1191 sub need_tagformat ($$) {
1192 my ($fmt, $why) = @_;
1193 fail "need to use tag format $fmt ($why) but also need".
1194 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1195 " - no way to proceed"
1196 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1197 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1200 sub select_tagformat () {
1202 return if $tagformatfn && !$tagformat_want;
1203 die 'bug' if $tagformatfn && $tagformat_want;
1204 # ... $tagformat_want assigned after previous select_tagformat
1206 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1207 printdebug "select_tagformat supported @supported\n";
1209 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1210 printdebug "select_tagformat specified @$tagformat_want\n";
1212 my ($fmt,$why,$override) = @$tagformat_want;
1214 fail "target distro supports tag formats @supported".
1215 " but have to use $fmt ($why)"
1217 or grep { $_ eq $fmt } @supported;
1219 $tagformat_want = undef;
1221 $tagformatfn = ${*::}{"debiantag_$fmt"};
1223 fail "trying to use unknown tag format \`$fmt' ($why) !"
1224 unless $tagformatfn;
1227 #---------- archive query entrypoints and rest of program ----------
1229 sub canonicalise_suite () {
1230 return if defined $csuite;
1231 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1232 $csuite = archive_query('canonicalise_suite');
1233 if ($isuite ne $csuite) {
1234 progress "canonical suite name for $isuite is $csuite";
1238 sub get_archive_dsc () {
1239 canonicalise_suite();
1240 my @vsns = archive_query('archive_query');
1241 foreach my $vinfo (@vsns) {
1242 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1243 $dscurl = access_cfg('mirror').$subpath;
1244 $dscdata = url_get($dscurl);
1246 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1251 $digester->add($dscdata);
1252 my $got = $digester->hexdigest();
1254 fail "$dscurl has hash $got but".
1255 " archive told us to expect $digest";
1257 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1258 printdebug Dumper($dscdata) if $debuglevel>1;
1259 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1260 printdebug Dumper($dsc) if $debuglevel>1;
1261 my $fmt = getfield $dsc, 'Format';
1262 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1263 $dsc_checked = !!$digester;
1264 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1268 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1271 sub check_for_git ();
1272 sub check_for_git () {
1274 my $how = access_cfg('git-check');
1275 if ($how eq 'ssh-cmd') {
1277 (access_cfg_ssh, access_gituserhost(),
1278 access_runeinfo("git-check $package").
1279 " set -e; cd ".access_cfg('git-path').";".
1280 " if test -d $package.git; then echo 1; else echo 0; fi");
1281 my $r= cmdoutput @cmd;
1282 if (defined $r and $r =~ m/^divert (\w+)$/) {
1284 my ($usedistro,) = access_distros();
1285 # NB that if we are pushing, $usedistro will be $distro/push
1286 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1287 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1288 progress "diverting to $divert (using config for $instead_distro)";
1289 return check_for_git();
1291 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1293 } elsif ($how eq 'url') {
1294 my $prefix = access_cfg('git-check-url','git-url');
1295 my $suffix = access_cfg('git-check-suffix','git-suffix',
1296 'RETURN-UNDEF') // '.git';
1297 my $url = "$prefix/$package$suffix";
1298 my @cmd = (qw(curl -sS -I), $url);
1299 my $result = cmdoutput @cmd;
1300 $result =~ s/^\S+ 200 .*\n\r?\n//;
1301 # curl -sS -I with https_proxy prints
1302 # HTTP/1.0 200 Connection established
1303 $result =~ m/^\S+ (404|200) /s or
1304 fail "unexpected results from git check query - ".
1305 Dumper($prefix, $result);
1307 if ($code eq '404') {
1309 } elsif ($code eq '200') {
1314 } elsif ($how eq 'true') {
1316 } elsif ($how eq 'false') {
1319 badcfg "unknown git-check \`$how'";
1323 sub create_remote_git_repo () {
1324 my $how = access_cfg('git-create');
1325 if ($how eq 'ssh-cmd') {
1327 (access_cfg_ssh, access_gituserhost(),
1328 access_runeinfo("git-create $package").
1329 "set -e; cd ".access_cfg('git-path').";".
1330 " cp -a _template $package.git");
1331 } elsif ($how eq 'true') {
1334 badcfg "unknown git-create \`$how'";
1338 our ($dsc_hash,$lastpush_mergeinput);
1340 our $ud = '.git/dgit/unpack';
1350 sub mktree_in_ud_here () {
1351 runcmd qw(git init -q);
1352 runcmd qw(git config gc.auto 0);
1353 rmtree('.git/objects');
1354 symlink '../../../../objects','.git/objects' or die $!;
1357 sub git_write_tree () {
1358 my $tree = cmdoutput @git, qw(write-tree);
1359 $tree =~ m/^\w+$/ or die "$tree ?";
1363 sub remove_stray_gits () {
1364 my @gitscmd = qw(find -name .git -prune -print0);
1365 debugcmd "|",@gitscmd;
1366 open GITS, "-|", @gitscmd or die $!;
1371 print STDERR "$us: warning: removing from source package: ",
1372 (messagequote $_), "\n";
1376 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1379 sub mktree_in_ud_from_only_subdir (;$) {
1382 # changes into the subdir
1384 die "expected one subdir but found @dirs ?" unless @dirs==1;
1385 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1389 remove_stray_gits();
1390 mktree_in_ud_here();
1392 my ($format, $fopts) = get_source_format();
1393 if (madformat($format)) {
1398 runcmd @git, qw(add -Af);
1399 my $tree=git_write_tree();
1400 return ($tree,$dir);
1403 sub dsc_files_info () {
1404 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1405 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1406 ['Files', 'Digest::MD5', 'new()']) {
1407 my ($fname, $module, $method) = @$csumi;
1408 my $field = $dsc->{$fname};
1409 next unless defined $field;
1410 eval "use $module; 1;" or die $@;
1412 foreach (split /\n/, $field) {
1414 m/^(\w+) (\d+) (\S+)$/ or
1415 fail "could not parse .dsc $fname line \`$_'";
1416 my $digester = eval "$module"."->$method;" or die $@;
1421 Digester => $digester,
1426 fail "missing any supported Checksums-* or Files field in ".
1427 $dsc->get_option('name');
1431 map { $_->{Filename} } dsc_files_info();
1434 sub is_orig_file_in_dsc ($$) {
1435 my ($f, $dsc_files_info) = @_;
1436 return 0 if @$dsc_files_info <= 1;
1437 # One file means no origs, and the filename doesn't have a "what
1438 # part of dsc" component. (Consider versions ending `.orig'.)
1439 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1443 sub is_orig_file_of_vsn ($$) {
1444 my ($f, $upstreamvsn) = @_;
1445 my $base = srcfn $upstreamvsn, '';
1446 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1450 sub make_commit ($) {
1452 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1455 sub make_commit_text ($) {
1458 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1460 print Dumper($text) if $debuglevel > 1;
1461 my $child = open2($out, $in, @cmd) or die $!;
1464 print $in $text or die $!;
1465 close $in or die $!;
1467 $h =~ m/^\w+$/ or die;
1469 printdebug "=> $h\n";
1472 waitpid $child, 0 == $child or die "$child $!";
1473 $? and failedcmd @cmd;
1477 sub clogp_authline ($) {
1479 my $author = getfield $clogp, 'Maintainer';
1480 $author =~ s#,.*##ms;
1481 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1482 my $authline = "$author $date";
1483 $authline =~ m/$git_authline_re/o or
1484 fail "unexpected commit author line format \`$authline'".
1485 " (was generated from changelog Maintainer field)";
1486 return ($1,$2,$3) if wantarray;
1490 sub vendor_patches_distro ($$) {
1491 my ($checkdistro, $what) = @_;
1492 return unless defined $checkdistro;
1494 my $series = "debian/patches/\L$checkdistro\E.series";
1495 printdebug "checking for vendor-specific $series ($what)\n";
1497 if (!open SERIES, "<", $series) {
1498 die "$series $!" unless $!==ENOENT;
1507 Unfortunately, this source package uses a feature of dpkg-source where
1508 the same source package unpacks to different source code on different
1509 distros. dgit cannot safely operate on such packages on affected
1510 distros, because the meaning of source packages is not stable.
1512 Please ask the distro/maintainer to remove the distro-specific series
1513 files and use a different technique (if necessary, uploading actually
1514 different packages, if different distros are supposed to have
1518 fail "Found active distro-specific series file for".
1519 " $checkdistro ($what): $series, cannot continue";
1521 die "$series $!" if SERIES->error;
1525 sub check_for_vendor_patches () {
1526 # This dpkg-source feature doesn't seem to be documented anywhere!
1527 # But it can be found in the changelog (reformatted):
1529 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1530 # Author: Raphael Hertzog <hertzog@debian.org>
1531 # Date: Sun Oct 3 09:36:48 2010 +0200
1533 # dpkg-source: correctly create .pc/.quilt_series with alternate
1536 # If you have debian/patches/ubuntu.series and you were
1537 # unpacking the source package on ubuntu, quilt was still
1538 # directed to debian/patches/series instead of
1539 # debian/patches/ubuntu.series.
1541 # debian/changelog | 3 +++
1542 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1543 # 2 files changed, 6 insertions(+), 1 deletion(-)
1546 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1547 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1548 "Dpkg::Vendor \`current vendor'");
1549 vendor_patches_distro(access_basedistro(),
1550 "distro being accessed");
1553 sub generate_commits_from_dsc () {
1554 # See big comment in fetch_from_archive, below.
1558 my @dfi = dsc_files_info();
1559 foreach my $fi (@dfi) {
1560 my $f = $fi->{Filename};
1561 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1563 link_ltarget "../../../$f", $f
1567 complete_file_from_dsc('.', $fi)
1570 if (is_orig_file_in_dsc($f, \@dfi)) {
1571 link $f, "../../../../$f"
1577 # We unpack and record the orig tarballs first, so that we only
1578 # need disk space for one private copy of the unpacked source.
1579 # But we can't make them into commits until we have the metadata
1580 # from the debian/changelog, so we record the tree objects now and
1581 # make them into commits later.
1583 my $upstreamv = $dsc->{version};
1584 $upstreamv =~ s/-[^-]+$//;
1585 my $orig_f_base = srcfn $upstreamv, '';
1587 foreach my $fi (@dfi) {
1588 # We actually import, and record as a commit, every tarball
1589 # (unless there is only one file, in which case there seems
1592 my $f = $fi->{Filename};
1593 printdebug "import considering $f ";
1594 (printdebug "only one dfi\n"), next if @dfi == 1;
1595 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1599 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1601 printdebug "Y ", (join ' ', map { $_//"(none)" }
1602 $compr_ext, $orig_f_part
1605 my $input = new IO::File $f, '<' or die "$f $!";
1609 if (defined $compr_ext) {
1611 Dpkg::Compression::compression_guess_from_filename $f;
1612 fail "Dpkg::Compression cannot handle file $f in source package"
1613 if defined $compr_ext && !defined $cname;
1615 new Dpkg::Compression::Process compression => $cname;
1616 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1617 my $compr_fh = new IO::Handle;
1618 my $compr_pid = open $compr_fh, "-|" // die $!;
1620 open STDIN, "<&", $input or die $!;
1622 die "dgit (child): exec $compr_cmd[0]: $!\n";
1627 rmtree "../unpack-tar";
1628 mkdir "../unpack-tar" or die $!;
1629 my @tarcmd = qw(tar -x -f -
1630 --no-same-owner --no-same-permissions
1631 --no-acls --no-xattrs --no-selinux);
1632 my $tar_pid = fork // die $!;
1634 chdir "../unpack-tar" or die $!;
1635 open STDIN, "<&", $input or die $!;
1637 die "dgit (child): exec $tarcmd[0]: $!";
1639 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1640 !$? or failedcmd @tarcmd;
1643 (@compr_cmd ? failedcmd @compr_cmd
1645 # finally, we have the results in "tarball", but maybe
1646 # with the wrong permissions
1648 runcmd qw(chmod -R +rwX ../unpack-tar);
1649 changedir "../unpack-tar";
1650 my ($tree) = mktree_in_ud_from_only_subdir(1);
1651 changedir "../../unpack";
1652 rmtree "../unpack-tar";
1654 my $ent = [ $f, $tree ];
1656 Orig => !!$orig_f_part,
1657 Sort => (!$orig_f_part ? 2 :
1658 $orig_f_part =~ m/-/g ? 1 :
1666 # put any without "_" first (spec is not clear whether files
1667 # are always in the usual order). Tarballs without "_" are
1668 # the main orig or the debian tarball.
1669 $a->{Sort} <=> $b->{Sort} or
1673 my $any_orig = grep { $_->{Orig} } @tartrees;
1675 my $dscfn = "$package.dsc";
1677 my $treeimporthow = 'package';
1679 open D, ">", $dscfn or die "$dscfn: $!";
1680 print D $dscdata or die "$dscfn: $!";
1681 close D or die "$dscfn: $!";
1682 my @cmd = qw(dpkg-source);
1683 push @cmd, '--no-check' if $dsc_checked;
1684 if (madformat $dsc->{format}) {
1685 push @cmd, '--skip-patches';
1686 $treeimporthow = 'unpatched';
1688 push @cmd, qw(-x --), $dscfn;
1691 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1692 if (madformat $dsc->{format}) {
1693 check_for_vendor_patches();
1697 if (madformat $dsc->{format}) {
1698 my @pcmd = qw(dpkg-source --before-build .);
1699 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1701 runcmd @git, qw(add -Af);
1702 $dappliedtree = git_write_tree();
1705 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1706 debugcmd "|",@clogcmd;
1707 open CLOGS, "-|", @clogcmd or die $!;
1713 my $stanzatext = do { local $/=""; <CLOGS>; };
1714 last if !defined $stanzatext;
1716 my $desc = "package changelog, entry no.$.";
1717 open my $stanzafh, "<", \$stanzatext or die;
1718 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1719 $clogp //= $thisstanza;
1721 last if !$any_orig; # we don't need $r1clogp
1723 # We look for the first (most recent) changelog entry whose
1724 # version number is lower than the upstream version of this
1725 # package. Then the last (least recent) previous changelog
1726 # entry is treated as the one which introduced this upstream
1727 # version and used for the synthetic commits for the upstream
1730 # One might think that a more sophisticated algorithm would be
1731 # necessary. But: we do not want to scan the whole changelog
1732 # file. Stopping when we see an earlier version, which
1733 # necessarily then is an earlier upstream version, is the only
1734 # realistic way to do that. Then, either the earliest
1735 # changelog entry we have seen so far is indeed the earliest
1736 # upload of this upstream version; or there are only changelog
1737 # entries relating to later upstream versions (which is not
1738 # possible unless the changelog and .dsc disagree about the
1739 # version). Then it remains to choose between the physically
1740 # last entry in the file, and the one with the lowest version
1741 # number. If these are not the same, we guess that the
1742 # versions were created in a non-monotic order rather than
1743 # that the changelog entries have been misordered.
1745 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1746 $r1clogp = $thisstanza;
1748 die $! if CLOGS->error;
1749 close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
1751 $clogp or fail "package changelog has no entries!";
1753 my $authline = clogp_authline $clogp;
1754 my $changes = getfield $clogp, 'Changes';
1755 my $cversion = getfield $clogp, 'Version';
1758 $r1clogp //= $clogp; # maybe there's only one entry;
1759 my $r1authline = clogp_authline $r1clogp;
1760 # Strictly, r1authline might now be wrong if it's going to be
1761 # unused because !$any_orig. Whatever.
1763 foreach my $tt (@tartrees) {
1764 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1767 committer $r1authline
1771 [dgit import orig $tt->{F}]
1779 [dgit import tarball $package $cversion $tt->{F}]
1784 open C, ">../commit.tmp" or die $!;
1785 print C <<END or die $!;
1788 print C <<END or die $! foreach @tartrees;
1791 print C <<END or die $!;
1797 [dgit import $treeimporthow $package $cversion]
1801 my $rawimport_hash = make_commit qw(../commit.tmp);
1803 if (madformat $dsc->{format}) {
1804 # regularise the state of the working tree so that
1805 # the checkout of $rawimport_hash works nicely.
1806 my $dappliedcommit = make_commit_text(<<END);
1813 runcmd @git, qw(checkout -b dapplied), $dappliedcommit;
1815 runcmd @git, qw(checkout -b unpa), $rawimport_hash;
1816 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
1817 my $gapplied = git_rev_parse('HEAD');
1818 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1819 $gappliedtree eq $dappliedtree or
1821 gbp-pq import and dpkg-source disagree!
1822 gbp-pq import gave commit $gapplied
1823 gbp-pq import gave tree $gappliedtree
1824 dpkg-source --before-build gave tree $dappliedtree
1826 $rawimport_hash = $gapplied;
1829 progress "synthesised git commit from .dsc $cversion";
1831 my $rawimport_mergeinput = {
1832 Commit => $rawimport_hash,
1833 Info => "Import of source package",
1835 my @output = ($rawimport_mergeinput);
1837 if ($lastpush_mergeinput) {
1838 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1839 my $oversion = getfield $oldclogp, 'Version';
1841 version_compare($oversion, $cversion);
1843 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1844 { Message => <<END, ReverseParents => 1 });
1845 Record $package ($cversion) in archive suite $csuite
1847 } elsif ($vcmp > 0) {
1848 print STDERR <<END or die $!;
1850 Version actually in archive: $cversion (older)
1851 Last version pushed with dgit: $oversion (newer or same)
1854 @output = $lastpush_mergeinput;
1856 # Same version. Use what's in the server git branch,
1857 # discarding our own import. (This could happen if the
1858 # server automatically imports all packages into git.)
1859 @output = $lastpush_mergeinput;
1862 changedir '../../../..';
1867 sub complete_file_from_dsc ($$) {
1868 our ($dstdir, $fi) = @_;
1869 # Ensures that we have, in $dir, the file $fi, with the correct
1870 # contents. (Downloading it from alongside $dscurl if necessary.)
1872 my $f = $fi->{Filename};
1873 my $tf = "$dstdir/$f";
1876 if (stat_exists $tf) {
1877 progress "using existing $f";
1880 $furl =~ s{/[^/]+$}{};
1882 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1883 die "$f ?" if $f =~ m#/#;
1884 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1885 return 0 if !act_local();
1889 open F, "<", "$tf" or die "$tf: $!";
1890 $fi->{Digester}->reset();
1891 $fi->{Digester}->addfile(*F);
1892 F->error and die $!;
1893 my $got = $fi->{Digester}->hexdigest();
1894 $got eq $fi->{Hash} or
1895 fail "file $f has hash $got but .dsc".
1896 " demands hash $fi->{Hash} ".
1897 ($downloaded ? "(got wrong file from archive!)"
1898 : "(perhaps you should delete this file?)");
1903 sub ensure_we_have_orig () {
1904 my @dfi = dsc_files_info();
1905 foreach my $fi (@dfi) {
1906 my $f = $fi->{Filename};
1907 next unless is_orig_file_in_dsc($f, \@dfi);
1908 complete_file_from_dsc('..', $fi)
1913 sub git_fetch_us () {
1914 # Want to fetch only what we are going to use, unless
1915 # deliberately-not-ff, in which case we must fetch everything.
1917 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1919 (quiltmode_splitbrain
1920 ? (map { $_->('*',access_basedistro) }
1921 \&debiantag_new, \&debiantag_maintview)
1922 : debiantags('*',access_basedistro));
1923 push @specs, server_branch($csuite);
1924 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1926 # This is rather miserable:
1927 # When git-fetch --prune is passed a fetchspec ending with a *,
1928 # it does a plausible thing. If there is no * then:
1929 # - it matches subpaths too, even if the supplied refspec
1930 # starts refs, and behaves completely madly if the source
1931 # has refs/refs/something. (See, for example, Debian #NNNN.)
1932 # - if there is no matching remote ref, it bombs out the whole
1934 # We want to fetch a fixed ref, and we don't know in advance
1935 # if it exists, so this is not suitable.
1937 # Our workaround is to use git-ls-remote. git-ls-remote has its
1938 # own qairks. Notably, it has the absurd multi-tail-matching
1939 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1940 # refs/refs/foo etc.
1942 # Also, we want an idempotent snapshot, but we have to make two
1943 # calls to the remote: one to git-ls-remote and to git-fetch. The
1944 # solution is use git-ls-remote to obtain a target state, and
1945 # git-fetch to try to generate it. If we don't manage to generate
1946 # the target state, we try again.
1948 my $specre = join '|', map {
1954 printdebug "git_fetch_us specre=$specre\n";
1955 my $wanted_rref = sub {
1957 return m/^(?:$specre)$/o;
1960 my $fetch_iteration = 0;
1963 if (++$fetch_iteration > 10) {
1964 fail "too many iterations trying to get sane fetch!";
1967 my @look = map { "refs/$_" } @specs;
1968 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1972 open GITLS, "-|", @lcmd or die $!;
1974 printdebug "=> ", $_;
1975 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1976 my ($objid,$rrefname) = ($1,$2);
1977 if (!$wanted_rref->($rrefname)) {
1979 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1983 $wantr{$rrefname} = $objid;
1986 close GITLS or failedcmd @lcmd;
1988 # OK, now %want is exactly what we want for refs in @specs
1990 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1991 "+refs/$_:".lrfetchrefs."/$_";
1994 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1995 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1998 %lrfetchrefs_f = ();
2001 git_for_each_ref(lrfetchrefs, sub {
2002 my ($objid,$objtype,$lrefname,$reftail) = @_;
2003 $lrfetchrefs_f{$lrefname} = $objid;
2004 $objgot{$objid} = 1;
2007 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2008 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2009 if (!exists $wantr{$rrefname}) {
2010 if ($wanted_rref->($rrefname)) {
2012 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
2016 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
2019 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2020 delete $lrfetchrefs_f{$lrefname};
2024 foreach my $rrefname (sort keys %wantr) {
2025 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2026 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2027 my $want = $wantr{$rrefname};
2028 next if $got eq $want;
2029 if (!defined $objgot{$want}) {
2031 warning: git-ls-remote suggests we want $lrefname
2032 warning: and it should refer to $want
2033 warning: but git-fetch didn't fetch that object to any relevant ref.
2034 warning: This may be due to a race with someone updating the server.
2035 warning: Will try again...
2037 next FETCH_ITERATION;
2040 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
2042 runcmd_ordryrun_local @git, qw(update-ref -m),
2043 "dgit fetch git-fetch fixup", $lrefname, $want;
2044 $lrfetchrefs_f{$lrefname} = $want;
2048 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
2049 Dumper(\%lrfetchrefs_f);
2052 my @tagpats = debiantags('*',access_basedistro);
2054 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2055 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2056 printdebug "currently $fullrefname=$objid\n";
2057 $here{$fullrefname} = $objid;
2059 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2060 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2061 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2062 printdebug "offered $lref=$objid\n";
2063 if (!defined $here{$lref}) {
2064 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2065 runcmd_ordryrun_local @upd;
2066 lrfetchref_used $fullrefname;
2067 } elsif ($here{$lref} eq $objid) {
2068 lrfetchref_used $fullrefname;
2071 "Not updateting $lref from $here{$lref} to $objid.\n";
2076 sub mergeinfo_getclogp ($) {
2077 # Ensures thit $mi->{Clogp} exists and returns it
2079 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2082 sub mergeinfo_version ($) {
2083 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2086 sub fetch_from_archive () {
2087 # Ensures that lrref() is what is actually in the archive, one way
2088 # or another, according to us - ie this client's
2089 # appropritaely-updated archive view. Also returns the commit id.
2090 # If there is nothing in the archive, leaves lrref alone and
2091 # returns undef. git_fetch_us must have already been called.
2095 foreach my $field (@ourdscfield) {
2096 $dsc_hash = $dsc->{$field};
2097 last if defined $dsc_hash;
2099 if (defined $dsc_hash) {
2100 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2102 progress "last upload to archive specified git hash";
2104 progress "last upload to archive has NO git hash";
2107 progress "no version available from the archive";
2110 # If the archive's .dsc has a Dgit field, there are three
2111 # relevant git commitids we need to choose between and/or merge
2113 # 1. $dsc_hash: the Dgit field from the archive
2114 # 2. $lastpush_hash: the suite branch on the dgit git server
2115 # 3. $lastfetch_hash: our local tracking brach for the suite
2117 # These may all be distinct and need not be in any fast forward
2120 # If the dsc was pushed to this suite, then the server suite
2121 # branch will have been updated; but it might have been pushed to
2122 # a different suite and copied by the archive. Conversely a more
2123 # recent version may have been pushed with dgit but not appeared
2124 # in the archive (yet).
2126 # $lastfetch_hash may be awkward because archive imports
2127 # (particularly, imports of Dgit-less .dscs) are performed only as
2128 # needed on individual clients, so different clients may perform a
2129 # different subset of them - and these imports are only made
2130 # public during push. So $lastfetch_hash may represent a set of
2131 # imports different to a subsequent upload by a different dgit
2134 # Our approach is as follows:
2136 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2137 # descendant of $dsc_hash, then it was pushed by a dgit user who
2138 # had based their work on $dsc_hash, so we should prefer it.
2139 # Otherwise, $dsc_hash was installed into this suite in the
2140 # archive other than by a dgit push, and (necessarily) after the
2141 # last dgit push into that suite (since a dgit push would have
2142 # been descended from the dgit server git branch); thus, in that
2143 # case, we prefer the archive's version (and produce a
2144 # pseudo-merge to overwrite the dgit server git branch).
2146 # (If there is no Dgit field in the archive's .dsc then
2147 # generate_commit_from_dsc uses the version numbers to decide
2148 # whether the suite branch or the archive is newer. If the suite
2149 # branch is newer it ignores the archive's .dsc; otherwise it
2150 # generates an import of the .dsc, and produces a pseudo-merge to
2151 # overwrite the suite branch with the archive contents.)
2153 # The outcome of that part of the algorithm is the `public view',
2154 # and is same for all dgit clients: it does not depend on any
2155 # unpublished history in the local tracking branch.
2157 # As between the public view and the local tracking branch: The
2158 # local tracking branch is only updated by dgit fetch, and
2159 # whenever dgit fetch runs it includes the public view in the
2160 # local tracking branch. Therefore if the public view is not
2161 # descended from the local tracking branch, the local tracking
2162 # branch must contain history which was imported from the archive
2163 # but never pushed; and, its tip is now out of date. So, we make
2164 # a pseudo-merge to overwrite the old imports and stitch the old
2167 # Finally: we do not necessarily reify the public view (as
2168 # described above). This is so that we do not end up stacking two
2169 # pseudo-merges. So what we actually do is figure out the inputs
2170 # to any public view pseudo-merge and put them in @mergeinputs.
2173 # $mergeinputs[]{Commit}
2174 # $mergeinputs[]{Info}
2175 # $mergeinputs[0] is the one whose tree we use
2176 # @mergeinputs is in the order we use in the actual commit)
2179 # $mergeinputs[]{Message} is a commit message to use
2180 # $mergeinputs[]{ReverseParents} if def specifies that parent
2181 # list should be in opposite order
2182 # Such an entry has no Commit or Info. It applies only when found
2183 # in the last entry. (This ugliness is to support making
2184 # identical imports to previous dgit versions.)
2186 my $lastpush_hash = git_get_ref(lrfetchref());
2187 printdebug "previous reference hash=$lastpush_hash\n";
2188 $lastpush_mergeinput = $lastpush_hash && {
2189 Commit => $lastpush_hash,
2190 Info => "dgit suite branch on dgit git server",
2193 my $lastfetch_hash = git_get_ref(lrref());
2194 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2195 my $lastfetch_mergeinput = $lastfetch_hash && {
2196 Commit => $lastfetch_hash,
2197 Info => "dgit client's archive history view",
2200 my $dsc_mergeinput = $dsc_hash && {
2201 Commit => $dsc_hash,
2202 Info => "Dgit field in .dsc from archive",
2206 my $del_lrfetchrefs = sub {
2209 printdebug "del_lrfetchrefs...\n";
2210 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2211 my $objid = $lrfetchrefs_d{$fullrefname};
2212 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2214 $gur ||= new IO::Handle;
2215 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2217 printf $gur "delete %s %s\n", $fullrefname, $objid;
2220 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2224 if (defined $dsc_hash) {
2225 fail "missing remote git history even though dsc has hash -".
2226 " could not find ref ".rref()." at ".access_giturl()
2227 unless $lastpush_hash;
2228 ensure_we_have_orig();
2229 if ($dsc_hash eq $lastpush_hash) {
2230 @mergeinputs = $dsc_mergeinput
2231 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2232 print STDERR <<END or die $!;
2234 Git commit in archive is behind the last version allegedly pushed/uploaded.
2235 Commit referred to by archive: $dsc_hash
2236 Last version pushed with dgit: $lastpush_hash
2239 @mergeinputs = ($lastpush_mergeinput);
2241 # Archive has .dsc which is not a descendant of the last dgit
2242 # push. This can happen if the archive moves .dscs about.
2243 # Just follow its lead.
2244 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2245 progress "archive .dsc names newer git commit";
2246 @mergeinputs = ($dsc_mergeinput);
2248 progress "archive .dsc names other git commit, fixing up";
2249 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2253 @mergeinputs = generate_commits_from_dsc();
2254 # We have just done an import. Now, our import algorithm might
2255 # have been improved. But even so we do not want to generate
2256 # a new different import of the same package. So if the
2257 # version numbers are the same, just use our existing version.
2258 # If the version numbers are different, the archive has changed
2259 # (perhaps, rewound).
2260 if ($lastfetch_mergeinput &&
2261 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2262 (mergeinfo_version $mergeinputs[0]) )) {
2263 @mergeinputs = ($lastfetch_mergeinput);
2265 } elsif ($lastpush_hash) {
2266 # only in git, not in the archive yet
2267 @mergeinputs = ($lastpush_mergeinput);
2268 print STDERR <<END or die $!;
2270 Package not found in the archive, but has allegedly been pushed using dgit.
2274 printdebug "nothing found!\n";
2275 if (defined $skew_warning_vsn) {
2276 print STDERR <<END or die $!;
2278 Warning: relevant archive skew detected.
2279 Archive allegedly contains $skew_warning_vsn
2280 But we were not able to obtain any version from the archive or git.
2284 unshift @end, $del_lrfetchrefs;
2288 if ($lastfetch_hash &&
2290 my $h = $_->{Commit};
2291 $h and is_fast_fwd($lastfetch_hash, $h);
2292 # If true, one of the existing parents of this commit
2293 # is a descendant of the $lastfetch_hash, so we'll
2294 # be ff from that automatically.
2298 push @mergeinputs, $lastfetch_mergeinput;
2301 printdebug "fetch mergeinfos:\n";
2302 foreach my $mi (@mergeinputs) {
2304 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2306 printdebug sprintf " ReverseParents=%d Message=%s",
2307 $mi->{ReverseParents}, $mi->{Message};
2311 my $compat_info= pop @mergeinputs
2312 if $mergeinputs[$#mergeinputs]{Message};
2314 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2317 if (@mergeinputs > 1) {
2319 my $tree_commit = $mergeinputs[0]{Commit};
2321 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2322 $tree =~ m/\n\n/; $tree = $`;
2323 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2326 # We use the changelog author of the package in question the
2327 # author of this pseudo-merge. This is (roughly) correct if
2328 # this commit is simply representing aa non-dgit upload.
2329 # (Roughly because it does not record sponsorship - but we
2330 # don't have sponsorship info because that's in the .changes,
2331 # which isn't in the archivw.)
2333 # But, it might be that we are representing archive history
2334 # updates (including in-archive copies). These are not really
2335 # the responsibility of the person who created the .dsc, but
2336 # there is no-one whose name we should better use. (The
2337 # author of the .dsc-named commit is clearly worse.)
2339 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2340 my $author = clogp_authline $useclogp;
2341 my $cversion = getfield $useclogp, 'Version';
2343 my $mcf = ".git/dgit/mergecommit";
2344 open MC, ">", $mcf or die "$mcf $!";
2345 print MC <<END or die $!;
2349 my @parents = grep { $_->{Commit} } @mergeinputs;
2350 @parents = reverse @parents if $compat_info->{ReverseParents};
2351 print MC <<END or die $! foreach @parents;
2355 print MC <<END or die $!;
2361 if (defined $compat_info->{Message}) {
2362 print MC $compat_info->{Message} or die $!;
2364 print MC <<END or die $!;
2365 Record $package ($cversion) in archive suite $csuite
2369 my $message_add_info = sub {
2371 my $mversion = mergeinfo_version $mi;
2372 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2376 $message_add_info->($mergeinputs[0]);
2377 print MC <<END or die $!;
2378 should be treated as descended from
2380 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2384 $hash = make_commit $mcf;
2386 $hash = $mergeinputs[0]{Commit};
2388 progress "fetch hash=$hash\n";
2391 my ($lasth, $what) = @_;
2392 return unless $lasth;
2393 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2396 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2397 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2399 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2400 'DGIT_ARCHIVE', $hash;
2401 cmdoutput @git, qw(log -n2), $hash;
2402 # ... gives git a chance to complain if our commit is malformed
2404 if (defined $skew_warning_vsn) {
2406 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2407 my $gotclogp = commit_getclogp($hash);
2408 my $got_vsn = getfield $gotclogp, 'Version';
2409 printdebug "SKEW CHECK GOT $got_vsn\n";
2410 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2411 print STDERR <<END or die $!;
2413 Warning: archive skew detected. Using the available version:
2414 Archive allegedly contains $skew_warning_vsn
2415 We were able to obtain only $got_vsn
2421 if ($lastfetch_hash ne $hash) {
2422 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2426 dryrun_report @upd_cmd;
2430 lrfetchref_used lrfetchref();
2432 unshift @end, $del_lrfetchrefs;
2436 sub set_local_git_config ($$) {
2438 runcmd @git, qw(config), $k, $v;
2441 sub setup_mergechangelogs (;$) {
2443 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2445 my $driver = 'dpkg-mergechangelogs';
2446 my $cb = "merge.$driver";
2447 my $attrs = '.git/info/attributes';
2448 ensuredir '.git/info';
2450 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2451 if (!open ATTRS, "<", $attrs) {
2452 $!==ENOENT or die "$attrs: $!";
2456 next if m{^debian/changelog\s};
2457 print NATTRS $_, "\n" or die $!;
2459 ATTRS->error and die $!;
2462 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2465 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2466 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2468 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2471 sub setup_useremail (;$) {
2473 return unless $always || access_cfg_bool(1, 'setup-useremail');
2476 my ($k, $envvar) = @_;
2477 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2478 return unless defined $v;
2479 set_local_git_config "user.$k", $v;
2482 $setup->('email', 'DEBEMAIL');
2483 $setup->('name', 'DEBFULLNAME');
2486 sub setup_new_tree () {
2487 setup_mergechangelogs();
2493 canonicalise_suite();
2494 badusage "dry run makes no sense with clone" unless act_local();
2495 my $hasgit = check_for_git();
2496 mkdir $dstdir or fail "create \`$dstdir': $!";
2498 runcmd @git, qw(init -q);
2499 my $giturl = access_giturl(1);
2500 if (defined $giturl) {
2501 open H, "> .git/HEAD" or die $!;
2502 print H "ref: ".lref()."\n" or die $!;
2504 runcmd @git, qw(remote add), 'origin', $giturl;
2507 progress "fetching existing git history";
2509 runcmd_ordryrun_local @git, qw(fetch origin);
2511 progress "starting new git history";
2513 fetch_from_archive() or no_such_package;
2514 my $vcsgiturl = $dsc->{'Vcs-Git'};
2515 if (length $vcsgiturl) {
2516 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2517 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2520 runcmd @git, qw(reset --hard), lrref();
2521 printdone "ready for work in $dstdir";
2525 if (check_for_git()) {
2528 fetch_from_archive() or no_such_package();
2529 printdone "fetched into ".lrref();
2534 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2536 printdone "fetched to ".lrref()." and merged into HEAD";
2539 sub check_not_dirty () {
2540 foreach my $f (qw(local-options local-patch-header)) {
2541 if (stat_exists "debian/source/$f") {
2542 fail "git tree contains debian/source/$f";
2546 return if $ignoredirty;
2548 my @cmd = (@git, qw(diff --quiet HEAD));
2550 $!=0; $?=-1; system @cmd;
2553 fail "working tree is dirty (does not match HEAD)";
2559 sub commit_admin ($) {
2562 runcmd_ordryrun_local @git, qw(commit -m), $m;
2565 sub commit_quilty_patch () {
2566 my $output = cmdoutput @git, qw(status --porcelain);
2568 foreach my $l (split /\n/, $output) {
2569 next unless $l =~ m/\S/;
2570 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2574 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2576 progress "nothing quilty to commit, ok.";
2579 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2580 runcmd_ordryrun_local @git, qw(add -f), @adds;
2581 commit_admin "Commit Debian 3.0 (quilt) metadata";
2584 sub get_source_format () {
2586 if (open F, "debian/source/options") {
2590 s/\s+$//; # ignore missing final newline
2592 my ($k, $v) = ($`, $'); #');
2593 $v =~ s/^"(.*)"$/$1/;
2599 F->error and die $!;
2602 die $! unless $!==&ENOENT;
2605 if (!open F, "debian/source/format") {
2606 die $! unless $!==&ENOENT;
2610 F->error and die $!;
2612 return ($_, \%options);
2615 sub madformat_wantfixup ($) {
2617 return 0 unless $format eq '3.0 (quilt)';
2618 our $quilt_mode_warned;
2619 if ($quilt_mode eq 'nocheck') {
2620 progress "Not doing any fixup of \`$format' due to".
2621 " ----no-quilt-fixup or --quilt=nocheck"
2622 unless $quilt_mode_warned++;
2625 progress "Format \`$format', need to check/update patch stack"
2626 unless $quilt_mode_warned++;
2630 # An "infopair" is a tuple [ $thing, $what ]
2631 # (often $thing is a commit hash; $what is a description)
2633 sub infopair_cond_equal ($$) {
2635 $x->[0] eq $y->[0] or fail <<END;
2636 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2640 sub infopair_lrf_tag_lookup ($$) {
2641 my ($tagnames, $what) = @_;
2642 # $tagname may be an array ref
2643 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2644 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2645 foreach my $tagname (@tagnames) {
2646 my $lrefname = lrfetchrefs."/tags/$tagname";
2647 my $tagobj = $lrfetchrefs_f{$lrefname};
2648 next unless defined $tagobj;
2649 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2650 return [ git_rev_parse($tagobj), $what ];
2652 fail @tagnames==1 ? <<END : <<END;
2653 Wanted tag $what (@tagnames) on dgit server, but not found
2655 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2659 sub infopair_cond_ff ($$) {
2660 my ($anc,$desc) = @_;
2661 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2662 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2666 sub pseudomerge_version_check ($$) {
2667 my ($clogp, $archive_hash) = @_;
2669 my $arch_clogp = commit_getclogp $archive_hash;
2670 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2671 'version currently in archive' ];
2672 if (defined $overwrite_version) {
2673 if (length $overwrite_version) {
2674 infopair_cond_equal([ $overwrite_version,
2675 '--overwrite= version' ],
2678 my $v = $i_arch_v->[0];
2679 progress "Checking package changelog for archive version $v ...";
2681 my @xa = ("-f$v", "-t$v");
2682 my $vclogp = parsechangelog @xa;
2683 my $cv = [ (getfield $vclogp, 'Version'),
2684 "Version field from dpkg-parsechangelog @xa" ];
2685 infopair_cond_equal($i_arch_v, $cv);
2688 $@ =~ s/^dgit: //gm;
2690 "Perhaps debian/changelog does not mention $v ?";
2695 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2699 sub pseudomerge_make_commit ($$$$ $$) {
2700 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2701 $msg_cmd, $msg_msg) = @_;
2702 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2704 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2705 my $authline = clogp_authline $clogp;
2709 !defined $overwrite_version ? ""
2710 : !length $overwrite_version ? " --overwrite"
2711 : " --overwrite=".$overwrite_version;
2714 my $pmf = ".git/dgit/pseudomerge";
2715 open MC, ">", $pmf or die "$pmf $!";
2716 print MC <<END or die $!;
2719 parent $archive_hash
2729 return make_commit($pmf);
2732 sub splitbrain_pseudomerge ($$$$) {
2733 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2734 # => $merged_dgitview
2735 printdebug "splitbrain_pseudomerge...\n";
2737 # We: debian/PREVIOUS HEAD($maintview)
2738 # expect: o ----------------- o
2741 # a/d/PREVIOUS $dgitview
2744 # we do: `------------------ o
2748 printdebug "splitbrain_pseudomerge...\n";
2750 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2752 return $dgitview unless defined $archive_hash;
2754 if (!defined $overwrite_version) {
2755 progress "Checking that HEAD inciudes all changes in archive...";
2758 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2760 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2761 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2762 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2763 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2764 my $i_archive = [ $archive_hash, "current archive contents" ];
2766 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2768 infopair_cond_equal($i_dgit, $i_archive);
2769 infopair_cond_ff($i_dep14, $i_dgit);
2770 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2772 my $r = pseudomerge_make_commit
2773 $clogp, $dgitview, $archive_hash, $i_arch_v,
2774 "dgit --quilt=$quilt_mode",
2775 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2776 Declare fast forward from $overwrite_version
2778 Make fast forward from $i_arch_v->[0]
2781 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2785 sub plain_overwrite_pseudomerge ($$$) {
2786 my ($clogp, $head, $archive_hash) = @_;
2788 printdebug "plain_overwrite_pseudomerge...";
2790 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2792 my @tagformats = access_cfg_tagformats();
2794 map { $_->($i_arch_v->[0], access_basedistro) }
2795 (grep { m/^(?:old|hist)$/ } @tagformats)
2796 ? \&debiantags : \&debiantag_new;
2797 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2798 my $i_archive = [ $archive_hash, "current archive contents" ];
2800 infopair_cond_equal($i_overwr, $i_archive);
2802 return $head if is_fast_fwd $archive_hash, $head;
2804 my $m = "Declare fast forward from $i_arch_v->[0]";
2806 my $r = pseudomerge_make_commit
2807 $clogp, $head, $archive_hash, $i_arch_v,
2810 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2812 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2816 sub push_parse_changelog ($) {
2819 my $clogp = Dpkg::Control::Hash->new();
2820 $clogp->load($clogpfn) or die;
2822 $package = getfield $clogp, 'Source';
2823 my $cversion = getfield $clogp, 'Version';
2824 my $tag = debiantag($cversion, access_basedistro);
2825 runcmd @git, qw(check-ref-format), $tag;
2827 my $dscfn = dscfn($cversion);
2829 return ($clogp, $cversion, $dscfn);
2832 sub push_parse_dsc ($$$) {
2833 my ($dscfn,$dscfnwhat, $cversion) = @_;
2834 $dsc = parsecontrol($dscfn,$dscfnwhat);
2835 my $dversion = getfield $dsc, 'Version';
2836 my $dscpackage = getfield $dsc, 'Source';
2837 ($dscpackage eq $package && $dversion eq $cversion) or
2838 fail "$dscfn is for $dscpackage $dversion".
2839 " but debian/changelog is for $package $cversion";
2842 sub push_tagwants ($$$$) {
2843 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2846 TagFn => \&debiantag,
2851 if (defined $maintviewhead) {
2853 TagFn => \&debiantag_maintview,
2854 Objid => $maintviewhead,
2855 TfSuffix => '-maintview',
2859 foreach my $tw (@tagwants) {
2860 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2861 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2863 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2867 sub push_mktags ($$ $$ $) {
2869 $changesfile,$changesfilewhat,
2872 die unless $tagwants->[0]{View} eq 'dgit';
2874 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2875 $dsc->save("$dscfn.tmp") or die $!;
2877 my $changes = parsecontrol($changesfile,$changesfilewhat);
2878 foreach my $field (qw(Source Distribution Version)) {
2879 $changes->{$field} eq $clogp->{$field} or
2880 fail "changes field $field \`$changes->{$field}'".
2881 " does not match changelog \`$clogp->{$field}'";
2884 my $cversion = getfield $clogp, 'Version';
2885 my $clogsuite = getfield $clogp, 'Distribution';
2887 # We make the git tag by hand because (a) that makes it easier
2888 # to control the "tagger" (b) we can do remote signing
2889 my $authline = clogp_authline $clogp;
2890 my $delibs = join(" ", "",@deliberatelies);
2891 my $declaredistro = access_basedistro();
2895 my $tfn = $tw->{Tfn};
2896 my $head = $tw->{Objid};
2897 my $tag = $tw->{Tag};
2899 open TO, '>', $tfn->('.tmp') or die $!;
2900 print TO <<END or die $!;
2907 if ($tw->{View} eq 'dgit') {
2908 print TO <<END or die $!;
2909 $package release $cversion for $clogsuite ($csuite) [dgit]
2910 [dgit distro=$declaredistro$delibs]
2912 foreach my $ref (sort keys %previously) {
2913 print TO <<END or die $!;
2914 [dgit previously:$ref=$previously{$ref}]
2917 } elsif ($tw->{View} eq 'maint') {
2918 print TO <<END or die $!;
2919 $package release $cversion for $clogsuite ($csuite)
2920 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2923 die Dumper($tw)."?";
2928 my $tagobjfn = $tfn->('.tmp');
2930 if (!defined $keyid) {
2931 $keyid = access_cfg('keyid','RETURN-UNDEF');
2933 if (!defined $keyid) {
2934 $keyid = getfield $clogp, 'Maintainer';
2936 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2937 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2938 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2939 push @sign_cmd, $tfn->('.tmp');
2940 runcmd_ordryrun @sign_cmd;
2942 $tagobjfn = $tfn->('.signed.tmp');
2943 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2944 $tfn->('.tmp'), $tfn->('.tmp.asc');
2950 my @r = map { $mktag->($_); } @$tagwants;
2954 sub sign_changes ($) {
2955 my ($changesfile) = @_;
2957 my @debsign_cmd = @debsign;
2958 push @debsign_cmd, "-k$keyid" if defined $keyid;
2959 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2960 push @debsign_cmd, $changesfile;
2961 runcmd_ordryrun @debsign_cmd;
2966 printdebug "actually entering push\n";
2968 supplementary_message(<<'END');
2969 Push failed, while checking state of the archive.
2970 You can retry the push, after fixing the problem, if you like.
2972 if (check_for_git()) {
2975 my $archive_hash = fetch_from_archive();
2976 if (!$archive_hash) {
2978 fail "package appears to be new in this suite;".
2979 " if this is intentional, use --new";
2982 supplementary_message(<<'END');
2983 Push failed, while preparing your push.
2984 You can retry the push, after fixing the problem, if you like.
2987 need_tagformat 'new', "quilt mode $quilt_mode"
2988 if quiltmode_splitbrain;
2992 access_giturl(); # check that success is vaguely likely
2995 my $clogpfn = ".git/dgit/changelog.822.tmp";
2996 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2998 responder_send_file('parsed-changelog', $clogpfn);
3000 my ($clogp, $cversion, $dscfn) =
3001 push_parse_changelog("$clogpfn");
3003 my $dscpath = "$buildproductsdir/$dscfn";
3004 stat_exists $dscpath or
3005 fail "looked for .dsc $dscfn, but $!;".
3006 " maybe you forgot to build";
3008 responder_send_file('dsc', $dscpath);
3010 push_parse_dsc($dscpath, $dscfn, $cversion);
3012 my $format = getfield $dsc, 'Format';
3013 printdebug "format $format\n";
3015 my $actualhead = git_rev_parse('HEAD');
3016 my $dgithead = $actualhead;
3017 my $maintviewhead = undef;
3019 if (madformat_wantfixup($format)) {
3020 # user might have not used dgit build, so maybe do this now:
3021 if (quiltmode_splitbrain()) {
3022 my $upstreamversion = $clogp->{Version};
3023 $upstreamversion =~ s/-[^-]*$//;
3025 quilt_make_fake_dsc($upstreamversion);
3026 my ($dgitview, $cachekey) =
3027 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3029 "--quilt=$quilt_mode but no cached dgit view:
3030 perhaps tree changed since dgit build[-source] ?";
3032 $dgithead = splitbrain_pseudomerge($clogp,
3033 $actualhead, $dgitview,
3035 $maintviewhead = $actualhead;
3036 changedir '../../../..';
3037 prep_ud(); # so _only_subdir() works, below
3039 commit_quilty_patch();
3043 if (defined $overwrite_version && !defined $maintviewhead) {
3044 $dgithead = plain_overwrite_pseudomerge($clogp,
3052 if ($archive_hash) {
3053 if (is_fast_fwd($archive_hash, $dgithead)) {
3055 } elsif (deliberately_not_fast_forward) {
3058 fail "dgit push: HEAD is not a descendant".
3059 " of the archive's version.\n".
3060 "To overwrite the archive's contents,".
3061 " pass --overwrite[=VERSION].\n".
3062 "To rewind history, if permitted by the archive,".
3063 " use --deliberately-not-fast-forward.";
3068 progress "checking that $dscfn corresponds to HEAD";
3069 runcmd qw(dpkg-source -x --),
3070 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3071 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3072 check_for_vendor_patches() if madformat($dsc->{format});
3073 changedir '../../../..';
3074 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
3075 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
3076 debugcmd "+",@diffcmd;
3078 my $r = system @diffcmd;
3081 fail "$dscfn specifies a different tree to your HEAD commit;".
3082 " perhaps you forgot to build".
3083 ($diffopt eq '--exit-code' ? "" :
3084 " (run with -D to see full diff output)");
3089 if (!$changesfile) {
3090 my $pat = changespat $cversion;
3091 my @cs = glob "$buildproductsdir/$pat";
3092 fail "failed to find unique changes file".
3093 " (looked for $pat in $buildproductsdir);".
3094 " perhaps you need to use dgit -C"
3096 ($changesfile) = @cs;
3098 $changesfile = "$buildproductsdir/$changesfile";
3101 # Checks complete, we're going to try and go ahead:
3103 responder_send_file('changes',$changesfile);
3104 responder_send_command("param head $dgithead");
3105 responder_send_command("param csuite $csuite");
3106 responder_send_command("param tagformat $tagformat");
3107 if (defined $maintviewhead) {
3108 die unless ($protovsn//4) >= 4;
3109 responder_send_command("param maint-view $maintviewhead");
3112 if (deliberately_not_fast_forward) {
3113 git_for_each_ref(lrfetchrefs, sub {
3114 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3115 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3116 responder_send_command("previously $rrefname=$objid");
3117 $previously{$rrefname} = $objid;
3121 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3125 supplementary_message(<<'END');
3126 Push failed, while signing the tag.
3127 You can retry the push, after fixing the problem, if you like.
3129 # If we manage to sign but fail to record it anywhere, it's fine.
3130 if ($we_are_responder) {
3131 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3132 responder_receive_files('signed-tag', @tagobjfns);
3134 @tagobjfns = push_mktags($clogp,$dscpath,
3135 $changesfile,$changesfile,
3138 supplementary_message(<<'END');
3139 Push failed, *after* signing the tag.
3140 If you want to try again, you should use a new version number.
3143 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3145 foreach my $tw (@tagwants) {
3146 my $tag = $tw->{Tag};
3147 my $tagobjfn = $tw->{TagObjFn};
3149 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3150 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3151 runcmd_ordryrun_local
3152 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3155 supplementary_message(<<'END');
3156 Push failed, while updating the remote git repository - see messages above.
3157 If you want to try again, you should use a new version number.
3159 if (!check_for_git()) {
3160 create_remote_git_repo();
3163 my @pushrefs = $forceflag.$dgithead.":".rrref();
3164 foreach my $tw (@tagwants) {
3165 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3168 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
3169 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3171 supplementary_message(<<'END');
3172 Push failed, after updating the remote git repository.
3173 If you want to try again, you must use a new version number.
3175 if ($we_are_responder) {
3176 my $dryrunsuffix = act_local() ? "" : ".tmp";
3177 responder_receive_files('signed-dsc-changes',
3178 "$dscpath$dryrunsuffix",
3179 "$changesfile$dryrunsuffix");
3182 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3184 progress "[new .dsc left in $dscpath.tmp]";
3186 sign_changes $changesfile;
3189 supplementary_message(<<END);
3190 Push failed, while uploading package(s) to the archive server.
3191 You can retry the upload of exactly these same files with dput of:
3193 If that .changes file is broken, you will need to use a new version
3194 number for your next attempt at the upload.
3196 my $host = access_cfg('upload-host','RETURN-UNDEF');
3197 my @hostarg = defined($host) ? ($host,) : ();
3198 runcmd_ordryrun @dput, @hostarg, $changesfile;
3199 printdone "pushed and uploaded $cversion";
3201 supplementary_message('');
3202 responder_send_command("complete");
3209 badusage "-p is not allowed with clone; specify as argument instead"
3210 if defined $package;
3213 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3214 ($package,$isuite) = @ARGV;
3215 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3216 ($package,$dstdir) = @ARGV;
3217 } elsif (@ARGV==3) {
3218 ($package,$isuite,$dstdir) = @ARGV;
3220 badusage "incorrect arguments to dgit clone";
3222 $dstdir ||= "$package";
3224 if (stat_exists $dstdir) {
3225 fail "$dstdir already exists";
3229 if ($rmonerror && !$dryrun_level) {
3230 $cwd_remove= getcwd();
3232 return unless defined $cwd_remove;
3233 if (!chdir "$cwd_remove") {
3234 return if $!==&ENOENT;
3235 die "chdir $cwd_remove: $!";
3238 rmtree($dstdir) or die "remove $dstdir: $!\n";
3239 } elsif (!grep { $! == $_ }
3240 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3242 print STDERR "check whether to remove $dstdir: $!\n";
3248 $cwd_remove = undef;
3251 sub branchsuite () {
3252 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3253 if ($branch =~ m#$lbranch_re#o) {
3260 sub fetchpullargs () {
3262 if (!defined $package) {
3263 my $sourcep = parsecontrol('debian/control','debian/control');
3264 $package = getfield $sourcep, 'Source';
3267 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3269 my $clogp = parsechangelog();
3270 $isuite = getfield $clogp, 'Distribution';
3272 canonicalise_suite();
3273 progress "fetching from suite $csuite";
3274 } elsif (@ARGV==1) {
3276 canonicalise_suite();
3278 badusage "incorrect arguments to dgit fetch or dgit pull";
3297 badusage "-p is not allowed with dgit push" if defined $package;
3299 my $clogp = parsechangelog();
3300 $package = getfield $clogp, 'Source';
3303 } elsif (@ARGV==1) {
3304 ($specsuite) = (@ARGV);
3306 badusage "incorrect arguments to dgit push";
3308 $isuite = getfield $clogp, 'Distribution';
3310 local ($package) = $existing_package; # this is a hack
3311 canonicalise_suite();
3313 canonicalise_suite();
3315 if (defined $specsuite &&
3316 $specsuite ne $isuite &&
3317 $specsuite ne $csuite) {
3318 fail "dgit push: changelog specifies $isuite ($csuite)".
3319 " but command line specifies $specsuite";
3324 #---------- remote commands' implementation ----------
3326 sub cmd_remote_push_build_host {
3327 my ($nrargs) = shift @ARGV;
3328 my (@rargs) = @ARGV[0..$nrargs-1];
3329 @ARGV = @ARGV[$nrargs..$#ARGV];
3331 my ($dir,$vsnwant) = @rargs;
3332 # vsnwant is a comma-separated list; we report which we have
3333 # chosen in our ready response (so other end can tell if they
3336 $we_are_responder = 1;
3337 $us .= " (build host)";
3341 open PI, "<&STDIN" or die $!;
3342 open STDIN, "/dev/null" or die $!;
3343 open PO, ">&STDOUT" or die $!;
3345 open STDOUT, ">&STDERR" or die $!;
3349 ($protovsn) = grep {
3350 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3351 } @rpushprotovsn_support;
3353 fail "build host has dgit rpush protocol versions ".
3354 (join ",", @rpushprotovsn_support).
3355 " but invocation host has $vsnwant"
3356 unless defined $protovsn;
3358 responder_send_command("dgit-remote-push-ready $protovsn");
3359 rpush_handle_protovsn_bothends();
3364 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3365 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3366 # a good error message)
3368 sub rpush_handle_protovsn_bothends () {
3369 if ($protovsn < 4) {
3370 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3379 my $report = i_child_report();
3380 if (defined $report) {
3381 printdebug "($report)\n";
3382 } elsif ($i_child_pid) {
3383 printdebug "(killing build host child $i_child_pid)\n";
3384 kill 15, $i_child_pid;
3386 if (defined $i_tmp && !defined $initiator_tempdir) {
3388 eval { rmtree $i_tmp; };
3392 END { i_cleanup(); }
3395 my ($base,$selector,@args) = @_;
3396 $selector =~ s/\-/_/g;
3397 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3404 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3412 push @rargs, join ",", @rpushprotovsn_support;
3415 push @rdgit, @ropts;
3416 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3418 my @cmd = (@ssh, $host, shellquote @rdgit);
3421 if (defined $initiator_tempdir) {
3422 rmtree $initiator_tempdir;
3423 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3424 $i_tmp = $initiator_tempdir;
3428 $i_child_pid = open2(\*RO, \*RI, @cmd);
3430 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3431 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3432 $supplementary_message = '' unless $protovsn >= 3;
3434 fail "rpush negotiated protocol version $protovsn".
3435 " which does not support quilt mode $quilt_mode"
3436 if quiltmode_splitbrain;
3438 rpush_handle_protovsn_bothends();
3440 my ($icmd,$iargs) = initiator_expect {
3441 m/^(\S+)(?: (.*))?$/;
3444 i_method "i_resp", $icmd, $iargs;
3448 sub i_resp_progress ($) {
3450 my $msg = protocol_read_bytes \*RO, $rhs;
3454 sub i_resp_supplementary_message ($) {
3456 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3459 sub i_resp_complete {
3460 my $pid = $i_child_pid;
3461 $i_child_pid = undef; # prevents killing some other process with same pid
3462 printdebug "waiting for build host child $pid...\n";
3463 my $got = waitpid $pid, 0;
3464 die $! unless $got == $pid;
3465 die "build host child failed $?" if $?;
3468 printdebug "all done\n";
3472 sub i_resp_file ($) {
3474 my $localname = i_method "i_localname", $keyword;
3475 my $localpath = "$i_tmp/$localname";
3476 stat_exists $localpath and
3477 badproto \*RO, "file $keyword ($localpath) twice";
3478 protocol_receive_file \*RO, $localpath;
3479 i_method "i_file", $keyword;
3484 sub i_resp_param ($) {
3485 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3489 sub i_resp_previously ($) {
3490 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3491 or badproto \*RO, "bad previously spec";
3492 my $r = system qw(git check-ref-format), $1;
3493 die "bad previously ref spec ($r)" if $r;
3494 $previously{$1} = $2;
3499 sub i_resp_want ($) {
3501 die "$keyword ?" if $i_wanted{$keyword}++;
3502 my @localpaths = i_method "i_want", $keyword;
3503 printdebug "[[ $keyword @localpaths\n";
3504 foreach my $localpath (@localpaths) {
3505 protocol_send_file \*RI, $localpath;
3507 print RI "files-end\n" or die $!;
3510 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3512 sub i_localname_parsed_changelog {
3513 return "remote-changelog.822";
3515 sub i_file_parsed_changelog {
3516 ($i_clogp, $i_version, $i_dscfn) =
3517 push_parse_changelog "$i_tmp/remote-changelog.822";
3518 die if $i_dscfn =~ m#/|^\W#;
3521 sub i_localname_dsc {
3522 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3527 sub i_localname_changes {
3528 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3529 $i_changesfn = $i_dscfn;
3530 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3531 return $i_changesfn;
3533 sub i_file_changes { }
3535 sub i_want_signed_tag {
3536 printdebug Dumper(\%i_param, $i_dscfn);
3537 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3538 && defined $i_param{'csuite'}
3539 or badproto \*RO, "premature desire for signed-tag";
3540 my $head = $i_param{'head'};
3541 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3543 my $maintview = $i_param{'maint-view'};
3544 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3547 if ($protovsn >= 4) {
3548 my $p = $i_param{'tagformat'} // '<undef>';
3550 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3553 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3555 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3557 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3560 push_mktags $i_clogp, $i_dscfn,
3561 $i_changesfn, 'remote changes',
3565 sub i_want_signed_dsc_changes {
3566 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3567 sign_changes $i_changesfn;
3568 return ($i_dscfn, $i_changesfn);
3571 #---------- building etc. ----------
3577 #----- `3.0 (quilt)' handling -----
3579 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3581 sub quiltify_dpkg_commit ($$$;$) {
3582 my ($patchname,$author,$msg, $xinfo) = @_;
3586 my $descfn = ".git/dgit/quilt-description.tmp";
3587 open O, '>', $descfn or die "$descfn: $!";
3590 $msg =~ s/^\s+$/ ./mg;
3591 print O <<END or die $!;
3601 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3602 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3603 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3604 runcmd @dpkgsource, qw(--commit .), $patchname;
3608 sub quiltify_trees_differ ($$;$$) {
3609 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3610 # returns true iff the two tree objects differ other than in debian/
3611 # with $finegrained,
3612 # returns bitmask 01 - differ in upstream files except .gitignore
3613 # 02 - differ in .gitignore
3614 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3615 # is set for each modified .gitignore filename $fn
3617 my @cmd = (@git, qw(diff-tree --name-only -z));
3618 push @cmd, qw(-r) if $finegrained;
3620 my $diffs= cmdoutput @cmd;
3622 foreach my $f (split /\0/, $diffs) {
3623 next if $f =~ m#^debian(?:/.*)?$#s;
3624 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3625 $r |= $isignore ? 02 : 01;
3626 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3628 printdebug "quiltify_trees_differ $x $y => $r\n";
3632 sub quiltify_tree_sentinelfiles ($) {
3633 # lists the `sentinel' files present in the tree
3635 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3636 qw(-- debian/rules debian/control);
3641 sub quiltify_splitbrain_needed () {
3642 if (!$split_brain) {
3643 progress "dgit view: changes are required...";
3644 runcmd @git, qw(checkout -q -b dgit-view);
3649 sub quiltify_splitbrain ($$$$$$) {
3650 my ($clogp, $unapplied, $headref, $diffbits,
3651 $editedignores, $cachekey) = @_;
3652 if ($quilt_mode !~ m/gbp|dpm/) {
3653 # treat .gitignore just like any other upstream file
3654 $diffbits = { %$diffbits };
3655 $_ = !!$_ foreach values %$diffbits;
3657 # We would like any commits we generate to be reproducible
3658 my @authline = clogp_authline($clogp);
3659 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3660 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3661 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3663 if ($quilt_mode =~ m/gbp|unapplied/ &&
3664 ($diffbits->{H2O} & 01)) {
3666 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3667 " but git tree differs from orig in upstream files.";
3668 if (!stat_exists "debian/patches") {
3670 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3674 if ($quilt_mode =~ m/dpm/ &&
3675 ($diffbits->{H2A} & 01)) {
3677 --quilt=$quilt_mode specified, implying patches-applied git tree
3678 but git tree differs from result of applying debian/patches to upstream
3681 if ($quilt_mode =~ m/gbp|unapplied/ &&
3682 ($diffbits->{O2A} & 01)) { # some patches
3683 quiltify_splitbrain_needed();
3684 progress "dgit view: creating patches-applied version using gbp pq";
3685 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3686 # gbp pq import creates a fresh branch; push back to dgit-view
3687 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3688 runcmd @git, qw(checkout -q dgit-view);
3690 if ($quilt_mode =~ m/gbp|dpm/ &&
3691 ($diffbits->{O2A} & 02)) {
3693 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3694 tool which does not create patches for changes to upstream
3695 .gitignores: but, such patches exist in debian/patches.
3698 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3699 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3700 quiltify_splitbrain_needed();
3701 progress "dgit view: creating patch to represent .gitignore changes";
3702 ensuredir "debian/patches";
3703 my $gipatch = "debian/patches/auto-gitignore";
3704 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3705 stat GIPATCH or die "$gipatch: $!";
3706 fail "$gipatch already exists; but want to create it".
3707 " to record .gitignore changes" if (stat _)[7];
3708 print GIPATCH <<END or die "$gipatch: $!";
3709 Subject: Update .gitignore from Debian packaging branch
3711 The Debian packaging git branch contains these updates to the upstream
3712 .gitignore file(s). This patch is autogenerated, to provide these
3713 updates to users of the official Debian archive view of the package.
3715 [dgit version $our_version]
3718 close GIPATCH or die "$gipatch: $!";
3719 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3720 $unapplied, $headref, "--", sort keys %$editedignores;
3721 open SERIES, "+>>", "debian/patches/series" or die $!;
3722 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3724 defined read SERIES, $newline, 1 or die $!;
3725 print SERIES "\n" or die $! unless $newline eq "\n";
3726 print SERIES "auto-gitignore\n" or die $!;
3727 close SERIES or die $!;
3728 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3729 commit_admin "Commit patch to update .gitignore";
3732 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3734 changedir '../../../..';
3735 ensuredir ".git/logs/refs/dgit-intern";
3736 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3738 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3741 progress "dgit view: created (commit id $dgitview)";
3743 changedir '.git/dgit/unpack/work';
3746 sub quiltify ($$$$) {
3747 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3749 # Quilt patchification algorithm
3751 # We search backwards through the history of the main tree's HEAD
3752 # (T) looking for a start commit S whose tree object is identical
3753 # to to the patch tip tree (ie the tree corresponding to the
3754 # current dpkg-committed patch series). For these purposes
3755 # `identical' disregards anything in debian/ - this wrinkle is
3756 # necessary because dpkg-source treates debian/ specially.
3758 # We can only traverse edges where at most one of the ancestors'
3759 # trees differs (in changes outside in debian/). And we cannot
3760 # handle edges which change .pc/ or debian/patches. To avoid
3761 # going down a rathole we avoid traversing edges which introduce
3762 # debian/rules or debian/control. And we set a limit on the
3763 # number of edges we are willing to look at.
3765 # If we succeed, we walk forwards again. For each traversed edge
3766 # PC (with P parent, C child) (starting with P=S and ending with
3767 # C=T) to we do this:
3769 # - dpkg-source --commit with a patch name and message derived from C
3770 # After traversing PT, we git commit the changes which
3771 # should be contained within debian/patches.
3773 # The search for the path S..T is breadth-first. We maintain a
3774 # todo list containing search nodes. A search node identifies a
3775 # commit, and looks something like this:
3777 # Commit => $git_commit_id,
3778 # Child => $c, # or undef if P=T
3779 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3780 # Nontrivial => true iff $p..$c has relevant changes
3787 my %considered; # saves being exponential on some weird graphs
3789 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3792 my ($search,$whynot) = @_;
3793 printdebug " search NOT $search->{Commit} $whynot\n";
3794 $search->{Whynot} = $whynot;
3795 push @nots, $search;
3796 no warnings qw(exiting);
3805 my $c = shift @todo;
3806 next if $considered{$c->{Commit}}++;
3808 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3810 printdebug "quiltify investigate $c->{Commit}\n";
3813 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3814 printdebug " search finished hooray!\n";
3819 if ($quilt_mode eq 'nofix') {
3820 fail "quilt fixup required but quilt mode is \`nofix'\n".
3821 "HEAD commit $c->{Commit} differs from tree implied by ".
3822 " debian/patches (tree object $oldtiptree)";
3824 if ($quilt_mode eq 'smash') {
3825 printdebug " search quitting smash\n";
3829 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3830 $not->($c, "has $c_sentinels not $t_sentinels")
3831 if $c_sentinels ne $t_sentinels;
3833 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3834 $commitdata =~ m/\n\n/;
3836 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3837 @parents = map { { Commit => $_, Child => $c } } @parents;
3839 $not->($c, "root commit") if !@parents;
3841 foreach my $p (@parents) {
3842 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3844 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3845 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3847 foreach my $p (@parents) {
3848 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3850 my @cmd= (@git, qw(diff-tree -r --name-only),
3851 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3852 my $patchstackchange = cmdoutput @cmd;
3853 if (length $patchstackchange) {
3854 $patchstackchange =~ s/\n/,/g;
3855 $not->($p, "changed $patchstackchange");
3858 printdebug " search queue P=$p->{Commit} ",
3859 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3865 printdebug "quiltify want to smash\n";
3868 my $x = $_[0]{Commit};
3869 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3872 my $reportnot = sub {
3874 my $s = $abbrev->($notp);
3875 my $c = $notp->{Child};
3876 $s .= "..".$abbrev->($c) if $c;
3877 $s .= ": ".$notp->{Whynot};
3880 if ($quilt_mode eq 'linear') {
3881 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3882 foreach my $notp (@nots) {
3883 print STDERR "$us: ", $reportnot->($notp), "\n";
3885 print STDERR "$us: $_\n" foreach @$failsuggestion;
3886 fail "quilt fixup naive history linearisation failed.\n".
3887 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3888 } elsif ($quilt_mode eq 'smash') {
3889 } elsif ($quilt_mode eq 'auto') {
3890 progress "quilt fixup cannot be linear, smashing...";
3892 die "$quilt_mode ?";
3895 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3896 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3898 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3900 quiltify_dpkg_commit "auto-$version-$target-$time",
3901 (getfield $clogp, 'Maintainer'),
3902 "Automatically generated patch ($clogp->{Version})\n".
3903 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3907 progress "quiltify linearisation planning successful, executing...";
3909 for (my $p = $sref_S;
3910 my $c = $p->{Child};
3912 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3913 next unless $p->{Nontrivial};
3915 my $cc = $c->{Commit};
3917 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3918 $commitdata =~ m/\n\n/ or die "$c ?";
3921 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3924 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3927 my $patchname = $title;
3928 $patchname =~ s/[.:]$//;
3929 $patchname =~ y/ A-Z/-a-z/;
3930 $patchname =~ y/-a-z0-9_.+=~//cd;
3931 $patchname =~ s/^\W/x-$&/;
3932 $patchname = substr($patchname,0,40);
3935 stat "debian/patches/$patchname$index";
3937 $!==ENOENT or die "$patchname$index $!";
3939 runcmd @git, qw(checkout -q), $cc;
3941 # We use the tip's changelog so that dpkg-source doesn't
3942 # produce complaining messages from dpkg-parsechangelog. None
3943 # of the information dpkg-source gets from the changelog is
3944 # actually relevant - it gets put into the original message
3945 # which dpkg-source provides our stunt editor, and then
3947 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3949 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3950 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3952 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3955 runcmd @git, qw(checkout -q master);
3958 sub build_maybe_quilt_fixup () {
3959 my ($format,$fopts) = get_source_format;
3960 return unless madformat_wantfixup $format;
3963 check_for_vendor_patches();
3965 if (quiltmode_splitbrain) {
3966 foreach my $needtf (qw(new maint)) {
3967 next if grep { $_ eq $needtf } access_cfg_tagformats;
3969 quilt mode $quilt_mode requires split view so server needs to support
3970 both "new" and "maint" tag formats, but config says it doesn't.
3975 my $clogp = parsechangelog();
3976 my $headref = git_rev_parse('HEAD');
3981 my $upstreamversion=$version;
3982 $upstreamversion =~ s/-[^-]*$//;
3984 if ($fopts->{'single-debian-patch'}) {
3985 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3987 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3990 die 'bug' if $split_brain && !$need_split_build_invocation;
3992 changedir '../../../..';
3993 runcmd_ordryrun_local
3994 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3997 sub quilt_fixup_mkwork ($) {
4000 mkdir "work" or die $!;
4002 mktree_in_ud_here();
4003 runcmd @git, qw(reset -q --hard), $headref;
4006 sub quilt_fixup_linkorigs ($$) {
4007 my ($upstreamversion, $fn) = @_;
4008 # calls $fn->($leafname);
4010 foreach my $f (<../../../../*>) { #/){
4011 my $b=$f; $b =~ s{.*/}{};
4013 local ($debuglevel) = $debuglevel-1;
4014 printdebug "QF linkorigs $b, $f ?\n";
4016 next unless is_orig_file_of_vsn $b, $upstreamversion;
4017 printdebug "QF linkorigs $b, $f Y\n";
4018 link_ltarget $f, $b or die "$b $!";
4023 sub quilt_fixup_delete_pc () {
4024 runcmd @git, qw(rm -rqf .pc);
4025 commit_admin "Commit removal of .pc (quilt series tracking data)";
4028 sub quilt_fixup_singlepatch ($$$) {
4029 my ($clogp, $headref, $upstreamversion) = @_;
4031 progress "starting quiltify (single-debian-patch)";
4033 # dpkg-source --commit generates new patches even if
4034 # single-debian-patch is in debian/source/options. In order to
4035 # get it to generate debian/patches/debian-changes, it is
4036 # necessary to build the source package.
4038 quilt_fixup_linkorigs($upstreamversion, sub { });
4039 quilt_fixup_mkwork($headref);
4041 rmtree("debian/patches");
4043 runcmd @dpkgsource, qw(-b .);
4045 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4046 rename srcfn("$upstreamversion", "/debian/patches"),
4047 "work/debian/patches";
4050 commit_quilty_patch();
4053 sub quilt_make_fake_dsc ($) {
4054 my ($upstreamversion) = @_;
4056 my $fakeversion="$upstreamversion-~~DGITFAKE";
4058 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4059 print $fakedsc <<END or die $!;
4062 Version: $fakeversion
4066 my $dscaddfile=sub {
4069 my $md = new Digest::MD5;
4071 my $fh = new IO::File $b, '<' or die "$b $!";
4076 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4079 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4081 my @files=qw(debian/source/format debian/rules
4082 debian/control debian/changelog);
4083 foreach my $maybe (qw(debian/patches debian/source/options
4084 debian/tests/control)) {
4085 next unless stat_exists "../../../$maybe";
4086 push @files, $maybe;
4089 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4090 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4092 $dscaddfile->($debtar);
4093 close $fakedsc or die $!;
4096 sub quilt_check_splitbrain_cache ($$) {
4097 my ($headref, $upstreamversion) = @_;
4098 # Called only if we are in (potentially) split brain mode.
4100 # Computes the cache key and looks in the cache.
4101 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4103 my $splitbrain_cachekey;
4106 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4107 # we look in the reflog of dgit-intern/quilt-cache
4108 # we look for an entry whose message is the key for the cache lookup
4109 my @cachekey = (qw(dgit), $our_version);
4110 push @cachekey, $upstreamversion;
4111 push @cachekey, $quilt_mode;
4112 push @cachekey, $headref;
4114 push @cachekey, hashfile('fake.dsc');
4116 my $srcshash = Digest::SHA->new(256);
4117 my %sfs = ( %INC, '$0(dgit)' => $0 );
4118 foreach my $sfk (sort keys %sfs) {
4119 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
4120 $srcshash->add($sfk," ");
4121 $srcshash->add(hashfile($sfs{$sfk}));
4122 $srcshash->add("\n");
4124 push @cachekey, $srcshash->hexdigest();
4125 $splitbrain_cachekey = "@cachekey";
4127 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
4129 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4130 debugcmd "|(probably)",@cmd;
4131 my $child = open GC, "-|"; defined $child or die $!;
4133 chdir '../../..' or die $!;
4134 if (!stat ".git/logs/refs/$splitbraincache") {
4135 $! == ENOENT or die $!;
4136 printdebug ">(no reflog)\n";
4143 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4144 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4147 quilt_fixup_mkwork($headref);
4148 if ($cachehit ne $headref) {
4149 progress "dgit view: found cached (commit id $cachehit)";
4150 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4152 return ($cachehit, $splitbrain_cachekey);
4154 progress "dgit view: found cached, no changes required";
4155 return ($headref, $splitbrain_cachekey);
4157 die $! if GC->error;
4158 failedcmd unless close GC;
4160 printdebug "splitbrain cache miss\n";
4161 return (undef, $splitbrain_cachekey);
4164 sub quilt_fixup_multipatch ($$$) {
4165 my ($clogp, $headref, $upstreamversion) = @_;
4167 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4170 # - honour any existing .pc in case it has any strangeness
4171 # - determine the git commit corresponding to the tip of
4172 # the patch stack (if there is one)
4173 # - if there is such a git commit, convert each subsequent
4174 # git commit into a quilt patch with dpkg-source --commit
4175 # - otherwise convert all the differences in the tree into
4176 # a single git commit
4180 # Our git tree doesn't necessarily contain .pc. (Some versions of
4181 # dgit would include the .pc in the git tree.) If there isn't
4182 # one, we need to generate one by unpacking the patches that we
4185 # We first look for a .pc in the git tree. If there is one, we
4186 # will use it. (This is not the normal case.)
4188 # Otherwise need to regenerate .pc so that dpkg-source --commit
4189 # can work. We do this as follows:
4190 # 1. Collect all relevant .orig from parent directory
4191 # 2. Generate a debian.tar.gz out of
4192 # debian/{patches,rules,source/format,source/options}
4193 # 3. Generate a fake .dsc containing just these fields:
4194 # Format Source Version Files
4195 # 4. Extract the fake .dsc
4196 # Now the fake .dsc has a .pc directory.
4197 # (In fact we do this in every case, because in future we will
4198 # want to search for a good base commit for generating patches.)
4200 # Then we can actually do the dpkg-source --commit
4201 # 1. Make a new working tree with the same object
4202 # store as our main tree and check out the main
4204 # 2. Copy .pc from the fake's extraction, if necessary
4205 # 3. Run dpkg-source --commit
4206 # 4. If the result has changes to debian/, then
4207 # - git-add them them
4208 # - git-add .pc if we had a .pc in-tree
4210 # 5. If we had a .pc in-tree, delete it, and git-commit
4211 # 6. Back in the main tree, fast forward to the new HEAD
4213 # Another situation we may have to cope with is gbp-style
4214 # patches-unapplied trees.
4216 # We would want to detect these, so we know to escape into
4217 # quilt_fixup_gbp. However, this is in general not possible.
4218 # Consider a package with a one patch which the dgit user reverts
4219 # (with git-revert or the moral equivalent).
4221 # That is indistinguishable in contents from a patches-unapplied
4222 # tree. And looking at the history to distinguish them is not
4223 # useful because the user might have made a confusing-looking git
4224 # history structure (which ought to produce an error if dgit can't
4225 # cope, not a silent reintroduction of an unwanted patch).
4227 # So gbp users will have to pass an option. But we can usually
4228 # detect their failure to do so: if the tree is not a clean
4229 # patches-applied tree, quilt linearisation fails, but the tree
4230 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4231 # they want --quilt=unapplied.
4233 # To help detect this, when we are extracting the fake dsc, we
4234 # first extract it with --skip-patches, and then apply the patches
4235 # afterwards with dpkg-source --before-build. That lets us save a
4236 # tree object corresponding to .origs.
4238 my $splitbrain_cachekey;
4240 quilt_make_fake_dsc($upstreamversion);
4242 if (quiltmode_splitbrain()) {
4244 ($cachehit, $splitbrain_cachekey) =
4245 quilt_check_splitbrain_cache($headref, $upstreamversion);
4246 return if $cachehit;
4250 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4252 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4253 rename $fakexdir, "fake" or die "$fakexdir $!";
4257 remove_stray_gits();
4258 mktree_in_ud_here();
4262 runcmd @git, qw(add -Af .);
4263 my $unapplied=git_write_tree();
4264 printdebug "fake orig tree object $unapplied\n";
4269 'exec dpkg-source --before-build . >/dev/null';
4273 quilt_fixup_mkwork($headref);
4276 if (stat_exists ".pc") {
4278 progress "Tree already contains .pc - will use it then delete it.";
4281 rename '../fake/.pc','.pc' or die $!;
4284 changedir '../fake';
4286 runcmd @git, qw(add -Af .);
4287 my $oldtiptree=git_write_tree();
4288 printdebug "fake o+d/p tree object $unapplied\n";
4289 changedir '../work';
4292 # We calculate some guesswork now about what kind of tree this might
4293 # be. This is mostly for error reporting.
4298 # O = orig, without patches applied
4299 # A = "applied", ie orig with H's debian/patches applied
4300 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4301 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4302 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4306 foreach my $b (qw(01 02)) {
4307 foreach my $v (qw(H2O O2A H2A)) {
4308 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4311 printdebug "differences \@dl @dl.\n";
4314 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4315 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4316 $dl[0], $dl[1], $dl[3], $dl[4],
4320 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4321 push @failsuggestion, "This might be a patches-unapplied branch.";
4322 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4323 push @failsuggestion, "This might be a patches-applied branch.";
4325 push @failsuggestion, "Maybe you need to specify one of".
4326 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4328 if (quiltmode_splitbrain()) {
4329 quiltify_splitbrain($clogp, $unapplied, $headref,
4330 $diffbits, \%editedignores,
4331 $splitbrain_cachekey);
4335 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4336 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4338 if (!open P, '>>', ".pc/applied-patches") {
4339 $!==&ENOENT or die $!;
4344 commit_quilty_patch();
4346 if ($mustdeletepc) {
4347 quilt_fixup_delete_pc();
4351 sub quilt_fixup_editor () {
4352 my $descfn = $ENV{$fakeeditorenv};
4353 my $editing = $ARGV[$#ARGV];
4354 open I1, '<', $descfn or die "$descfn: $!";
4355 open I2, '<', $editing or die "$editing: $!";
4356 unlink $editing or die "$editing: $!";
4357 open O, '>', $editing or die "$editing: $!";
4358 while (<I1>) { print O or die $!; } I1->error and die $!;
4361 $copying ||= m/^\-\-\- /;
4362 next unless $copying;
4365 I2->error and die $!;
4370 sub maybe_apply_patches_dirtily () {
4371 return unless $quilt_mode =~ m/gbp|unapplied/;
4372 print STDERR <<END or die $!;
4374 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4375 dgit: Have to apply the patches - making the tree dirty.
4376 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4379 $patches_applied_dirtily = 01;
4380 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4381 runcmd qw(dpkg-source --before-build .);
4384 sub maybe_unapply_patches_again () {
4385 progress "dgit: Unapplying patches again to tidy up the tree."
4386 if $patches_applied_dirtily;
4387 runcmd qw(dpkg-source --after-build .)
4388 if $patches_applied_dirtily & 01;
4390 if $patches_applied_dirtily & 02;
4391 $patches_applied_dirtily = 0;
4394 #----- other building -----
4396 our $clean_using_builder;
4397 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4398 # clean the tree before building (perhaps invoked indirectly by
4399 # whatever we are using to run the build), rather than separately
4400 # and explicitly by us.
4403 return if $clean_using_builder;
4404 if ($cleanmode eq 'dpkg-source') {
4405 maybe_apply_patches_dirtily();
4406 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4407 } elsif ($cleanmode eq 'dpkg-source-d') {
4408 maybe_apply_patches_dirtily();
4409 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4410 } elsif ($cleanmode eq 'git') {
4411 runcmd_ordryrun_local @git, qw(clean -xdf);
4412 } elsif ($cleanmode eq 'git-ff') {
4413 runcmd_ordryrun_local @git, qw(clean -xdff);
4414 } elsif ($cleanmode eq 'check') {
4415 my $leftovers = cmdoutput @git, qw(clean -xdn);
4416 if (length $leftovers) {
4417 print STDERR $leftovers, "\n" or die $!;
4418 fail "tree contains uncommitted files and --clean=check specified";
4420 } elsif ($cleanmode eq 'none') {
4427 badusage "clean takes no additional arguments" if @ARGV;
4430 maybe_unapply_patches_again();
4435 badusage "-p is not allowed when building" if defined $package;
4438 my $clogp = parsechangelog();
4439 $isuite = getfield $clogp, 'Distribution';
4440 $package = getfield $clogp, 'Source';
4441 $version = getfield $clogp, 'Version';
4442 build_maybe_quilt_fixup();
4444 my $pat = changespat $version;
4445 foreach my $f (glob "$buildproductsdir/$pat") {
4447 unlink $f or fail "remove old changes file $f: $!";
4449 progress "would remove $f";
4455 sub changesopts_initial () {
4456 my @opts =@changesopts[1..$#changesopts];
4459 sub changesopts_version () {
4460 if (!defined $changes_since_version) {
4461 my @vsns = archive_query('archive_query');
4462 my @quirk = access_quirk();
4463 if ($quirk[0] eq 'backports') {
4464 local $isuite = $quirk[2];
4466 canonicalise_suite();
4467 push @vsns, archive_query('archive_query');
4470 @vsns = map { $_->[0] } @vsns;
4471 @vsns = sort { -version_compare($a, $b) } @vsns;
4472 $changes_since_version = $vsns[0];
4473 progress "changelog will contain changes since $vsns[0]";
4475 $changes_since_version = '_';
4476 progress "package seems new, not specifying -v<version>";
4479 if ($changes_since_version ne '_') {
4480 return ("-v$changes_since_version");
4486 sub changesopts () {
4487 return (changesopts_initial(), changesopts_version());
4490 sub massage_dbp_args ($;$) {
4491 my ($cmd,$xargs) = @_;
4494 # - if we're going to split the source build out so we can
4495 # do strange things to it, massage the arguments to dpkg-buildpackage
4496 # so that the main build doessn't build source (or add an argument
4497 # to stop it building source by default).
4499 # - add -nc to stop dpkg-source cleaning the source tree,
4500 # unless we're not doing a split build and want dpkg-source
4501 # as cleanmode, in which case we can do nothing
4504 # 0 - source will NOT need to be built separately by caller
4505 # +1 - source will need to be built separately by caller
4506 # +2 - source will need to be built separately by caller AND
4507 # dpkg-buildpackage should not in fact be run at all!
4508 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4509 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4510 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4511 $clean_using_builder = 1;
4514 # -nc has the side effect of specifying -b if nothing else specified
4515 # and some combinations of -S, -b, et al, are errors, rather than
4516 # later simply overriding earlie. So we need to:
4517 # - search the command line for these options
4518 # - pick the last one
4519 # - perhaps add our own as a default
4520 # - perhaps adjust it to the corresponding non-source-building version
4522 foreach my $l ($cmd, $xargs) {
4524 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4527 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4529 if ($need_split_build_invocation) {
4530 printdebug "massage split $dmode.\n";
4531 $r = $dmode =~ m/[S]/ ? +2 :
4532 $dmode =~ y/gGF/ABb/ ? +1 :
4533 $dmode =~ m/[ABb]/ ? 0 :
4536 printdebug "massage done $r $dmode.\n";
4538 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4543 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4544 my $wantsrc = massage_dbp_args \@dbp;
4551 push @dbp, changesopts_version();
4552 maybe_apply_patches_dirtily();
4553 runcmd_ordryrun_local @dbp;
4555 maybe_unapply_patches_again();
4556 printdone "build successful\n";
4560 my @dbp = @dpkgbuildpackage;
4562 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4565 if (length executable_on_path('git-buildpackage')) {
4566 @cmd = qw(git-buildpackage);
4568 @cmd = qw(gbp buildpackage);
4570 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4575 if (!$clean_using_builder) {
4576 push @cmd, '--git-cleaner=true';
4580 maybe_unapply_patches_again();
4582 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4583 canonicalise_suite();
4584 push @cmd, "--git-debian-branch=".lbranch();
4586 push @cmd, changesopts();
4587 runcmd_ordryrun_local @cmd, @ARGV;
4589 printdone "build successful\n";
4591 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4594 my $our_cleanmode = $cleanmode;
4595 if ($need_split_build_invocation) {
4596 # Pretend that clean is being done some other way. This
4597 # forces us not to try to use dpkg-buildpackage to clean and
4598 # build source all in one go; and instead we run dpkg-source
4599 # (and build_prep() will do the clean since $clean_using_builder
4601 $our_cleanmode = 'ELSEWHERE';
4603 if ($our_cleanmode =~ m/^dpkg-source/) {
4604 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4605 $clean_using_builder = 1;
4608 $sourcechanges = changespat $version,'source';
4610 unlink "../$sourcechanges" or $!==ENOENT
4611 or fail "remove $sourcechanges: $!";
4613 $dscfn = dscfn($version);
4614 if ($our_cleanmode eq 'dpkg-source') {
4615 maybe_apply_patches_dirtily();
4616 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4618 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4619 maybe_apply_patches_dirtily();
4620 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4623 my @cmd = (@dpkgsource, qw(-b --));
4626 runcmd_ordryrun_local @cmd, "work";
4627 my @udfiles = <${package}_*>;
4628 changedir "../../..";
4629 foreach my $f (@udfiles) {
4630 printdebug "source copy, found $f\n";
4633 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4634 $f eq srcfn($version, $&));
4635 printdebug "source copy, found $f - renaming\n";
4636 rename "$ud/$f", "../$f" or $!==ENOENT
4637 or fail "put in place new source file ($f): $!";
4640 my $pwd = must_getcwd();
4641 my $leafdir = basename $pwd;
4643 runcmd_ordryrun_local @cmd, $leafdir;
4646 runcmd_ordryrun_local qw(sh -ec),
4647 'exec >$1; shift; exec "$@"','x',
4648 "../$sourcechanges",
4649 @dpkggenchanges, qw(-S), changesopts();
4653 sub cmd_build_source {
4654 badusage "build-source takes no additional arguments" if @ARGV;
4656 maybe_unapply_patches_again();
4657 printdone "source built, results in $dscfn and $sourcechanges";
4662 my $pat = changespat $version;
4664 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4665 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4666 fail "changes files other than source matching $pat".
4667 " already present (@unwanted);".
4668 " building would result in ambiguity about the intended results"
4671 my $wasdir = must_getcwd();
4674 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4675 stat_exists $sourcechanges
4676 or fail "$sourcechanges (in parent directory): $!";
4678 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4679 my @changesfiles = glob $pat;
4680 @changesfiles = sort {
4681 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4684 fail "wrong number of different changes files (@changesfiles)"
4685 unless @changesfiles==2;
4686 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4687 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4688 fail "$l found in binaries changes file $binchanges"
4691 runcmd_ordryrun_local @mergechanges, @changesfiles;
4692 my $multichanges = changespat $version,'multi';
4694 stat_exists $multichanges or fail "$multichanges: $!";
4695 foreach my $cf (glob $pat) {
4696 next if $cf eq $multichanges;
4697 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4701 maybe_unapply_patches_again();
4702 printdone "build successful, results in $multichanges\n" or die $!;
4705 sub cmd_quilt_fixup {
4706 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4707 my $clogp = parsechangelog();
4708 $version = getfield $clogp, 'Version';
4709 $package = getfield $clogp, 'Source';
4712 build_maybe_quilt_fixup();
4715 sub cmd_archive_api_query {
4716 badusage "need only 1 subpath argument" unless @ARGV==1;
4717 my ($subpath) = @ARGV;
4718 my @cmd = archive_api_query_cmd($subpath);
4720 exec @cmd or fail "exec curl: $!\n";
4723 sub cmd_clone_dgit_repos_server {
4724 badusage "need destination argument" unless @ARGV==1;
4725 my ($destdir) = @ARGV;
4726 $package = '_dgit-repos-server';
4727 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4729 exec @cmd or fail "exec git clone: $!\n";
4732 sub cmd_setup_mergechangelogs {
4733 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4734 setup_mergechangelogs(1);
4737 sub cmd_setup_useremail {
4738 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4742 sub cmd_setup_new_tree {
4743 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4747 #---------- argument parsing and main program ----------
4750 print "dgit version $our_version\n" or die $!;
4754 our (%valopts_long, %valopts_short);
4757 sub defvalopt ($$$$) {
4758 my ($long,$short,$val_re,$how) = @_;
4759 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4760 $valopts_long{$long} = $oi;
4761 $valopts_short{$short} = $oi;
4762 # $how subref should:
4763 # do whatever assignemnt or thing it likes with $_[0]
4764 # if the option should not be passed on to remote, @rvalopts=()
4765 # or $how can be a scalar ref, meaning simply assign the value
4768 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4769 defvalopt '--distro', '-d', '.+', \$idistro;
4770 defvalopt '', '-k', '.+', \$keyid;
4771 defvalopt '--existing-package','', '.*', \$existing_package;
4772 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4773 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4774 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4776 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4778 defvalopt '', '-C', '.+', sub {
4779 ($changesfile) = (@_);
4780 if ($changesfile =~ s#^(.*)/##) {
4781 $buildproductsdir = $1;
4785 defvalopt '--initiator-tempdir','','.*', sub {
4786 ($initiator_tempdir) = (@_);
4787 $initiator_tempdir =~ m#^/# or
4788 badusage "--initiator-tempdir must be used specify an".
4789 " absolute, not relative, directory."
4795 if (defined $ENV{'DGIT_SSH'}) {
4796 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4797 } elsif (defined $ENV{'GIT_SSH'}) {
4798 @ssh = ($ENV{'GIT_SSH'});
4806 if (!defined $val) {
4807 badusage "$what needs a value" unless @ARGV;
4809 push @rvalopts, $val;
4811 badusage "bad value \`$val' for $what" unless
4812 $val =~ m/^$oi->{Re}$(?!\n)/s;
4813 my $how = $oi->{How};
4814 if (ref($how) eq 'SCALAR') {
4819 push @ropts, @rvalopts;
4823 last unless $ARGV[0] =~ m/^-/;
4827 if (m/^--dry-run$/) {
4830 } elsif (m/^--damp-run$/) {
4833 } elsif (m/^--no-sign$/) {
4836 } elsif (m/^--help$/) {
4838 } elsif (m/^--version$/) {
4840 } elsif (m/^--new$/) {
4843 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4844 ($om = $opts_opt_map{$1}) &&
4848 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4849 !$opts_opt_cmdonly{$1} &&
4850 ($om = $opts_opt_map{$1})) {
4853 } elsif (m/^--ignore-dirty$/s) {
4856 } elsif (m/^--no-quilt-fixup$/s) {
4858 $quilt_mode = 'nocheck';
4859 } elsif (m/^--no-rm-on-error$/s) {
4862 } elsif (m/^--overwrite$/s) {
4864 $overwrite_version = '';
4865 } elsif (m/^--overwrite=(.+)$/s) {
4867 $overwrite_version = $1;
4868 } elsif (m/^--(no-)?rm-old-changes$/s) {
4871 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4873 push @deliberatelies, $&;
4874 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4875 # undocumented, for testing
4877 $tagformat_want = [ $1, 'command line', 1 ];
4878 # 1 menas overrides distro configuration
4879 } elsif (m/^--always-split-source-build$/s) {
4880 # undocumented, for testing
4882 $need_split_build_invocation = 1;
4883 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4884 $val = $2 ? $' : undef; #';
4885 $valopt->($oi->{Long});
4887 badusage "unknown long option \`$_'";
4894 } elsif (s/^-L/-/) {
4897 } elsif (s/^-h/-/) {
4899 } elsif (s/^-D/-/) {
4903 } elsif (s/^-N/-/) {
4908 push @changesopts, $_;
4910 } elsif (s/^-wn$//s) {
4912 $cleanmode = 'none';
4913 } elsif (s/^-wg$//s) {
4916 } elsif (s/^-wgf$//s) {
4918 $cleanmode = 'git-ff';
4919 } elsif (s/^-wd$//s) {
4921 $cleanmode = 'dpkg-source';
4922 } elsif (s/^-wdd$//s) {
4924 $cleanmode = 'dpkg-source-d';
4925 } elsif (s/^-wc$//s) {
4927 $cleanmode = 'check';
4928 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4930 $val = undef unless length $val;
4931 $valopt->($oi->{Short});
4934 badusage "unknown short option \`$_'";
4941 sub finalise_opts_opts () {
4942 foreach my $k (keys %opts_opt_map) {
4943 my $om = $opts_opt_map{$k};
4945 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4947 badcfg "cannot set command for $k"
4948 unless length $om->[0];
4952 foreach my $c (access_cfg_cfgs("opts-$k")) {
4953 my $vl = $gitcfg{$c};
4954 printdebug "CL $c ",
4955 ($vl ? join " ", map { shellquote } @$vl : ""),
4956 "\n" if $debuglevel >= 4;
4958 badcfg "cannot configure options for $k"
4959 if $opts_opt_cmdonly{$k};
4960 my $insertpos = $opts_cfg_insertpos{$k};
4961 @$om = ( @$om[0..$insertpos-1],
4963 @$om[$insertpos..$#$om] );
4968 if ($ENV{$fakeeditorenv}) {
4970 quilt_fixup_editor();
4976 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4977 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4978 if $dryrun_level == 1;
4980 print STDERR $helpmsg or die $!;
4983 my $cmd = shift @ARGV;
4986 if (!defined $rmchanges) {
4987 local $access_forpush;
4988 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4991 if (!defined $quilt_mode) {
4992 local $access_forpush;
4993 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4994 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4996 $quilt_mode =~ m/^($quilt_modes_re)$/
4997 or badcfg "unknown quilt-mode \`$quilt_mode'";
5001 $need_split_build_invocation ||= quiltmode_splitbrain();
5003 if (!defined $cleanmode) {
5004 local $access_forpush;
5005 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5006 $cleanmode //= 'dpkg-source';
5008 badcfg "unknown clean-mode \`$cleanmode'" unless
5009 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5012 my $fn = ${*::}{"cmd_$cmd"};
5013 $fn or badusage "unknown operation $cmd";