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;
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
81 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
82 our $splitbraincache = 'dgit-intern/quilt-cache';
85 our (@dget) = qw(dget);
86 our (@curl) = qw(curl -f);
87 our (@dput) = qw(dput);
88 our (@debsign) = qw(debsign);
90 our (@sbuild) = qw(sbuild);
92 our (@dgit) = qw(dgit);
93 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
94 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
95 our (@dpkggenchanges) = qw(dpkg-genchanges);
96 our (@mergechanges) = qw(mergechanges -f);
98 our (@changesopts) = ('');
100 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
103 'debsign' => \@debsign,
105 'sbuild' => \@sbuild,
109 'dpkg-source' => \@dpkgsource,
110 'dpkg-buildpackage' => \@dpkgbuildpackage,
111 'dpkg-genchanges' => \@dpkggenchanges,
113 'ch' => \@changesopts,
114 'mergechanges' => \@mergechanges);
116 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
117 our %opts_cfg_insertpos = map {
119 scalar @{ $opts_opt_map{$_} }
120 } keys %opts_opt_map;
122 sub finalise_opts_opts();
128 our $supplementary_message = '';
129 our $need_split_build_invocation = 0;
130 our $split_brain = 0;
134 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
137 our $remotename = 'dgit';
138 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
143 my ($v,$distro) = @_;
144 return $tagformatfn->($v, $distro);
147 sub debiantag_maintview ($$) {
148 my ($v,$distro) = @_;
153 sub lbranch () { return "$branchprefix/$csuite"; }
154 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
155 sub lref () { return "refs/heads/".lbranch(); }
156 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
157 sub rrref () { return server_ref($csuite); }
159 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
160 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
162 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
163 # locally fetched refs because they have unhelpful names and clutter
164 # up gitk etc. So we track whether we have "used up" head ref (ie,
165 # whether we have made another local ref which refers to this object).
167 # (If we deleted them unconditionally, then we might end up
168 # re-fetching the same git objects each time dgit fetch was run.)
170 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
171 # in git_fetch_us to fetch the refs in question, and possibly a call
172 # to lrfetchref_used.
174 our (%lrfetchrefs_f, %lrfetchrefs_d);
175 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
177 sub lrfetchref_used ($) {
178 my ($fullrefname) = @_;
179 my $objid = $lrfetchrefs_f{$fullrefname};
180 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
191 return "${package}_".(stripepoch $vsn).$sfx
196 return srcfn($vsn,".dsc");
199 sub changespat ($;$) {
200 my ($vsn, $arch) = @_;
201 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
210 foreach my $f (@end) {
212 print STDERR "$us: cleanup: $@" if length $@;
216 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
218 sub no_such_package () {
219 print STDERR "$us: package $package does not exist in suite $isuite\n";
225 printdebug "CD $newdir\n";
226 chdir $newdir or confess "chdir: $newdir: $!";
229 sub deliberately ($) {
231 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
234 sub deliberately_not_fast_forward () {
235 foreach (qw(not-fast-forward fresh-repo)) {
236 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
240 sub quiltmode_splitbrain () {
241 $quilt_mode =~ m/gbp|dpm|unapplied/;
244 #---------- remote protocol support, common ----------
246 # remote push initiator/responder protocol:
247 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
248 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
249 # < dgit-remote-push-ready <actual-proto-vsn>
256 # > supplementary-message NBYTES # $protovsn >= 3
261 # > file parsed-changelog
262 # [indicates that output of dpkg-parsechangelog follows]
263 # > data-block NBYTES
264 # > [NBYTES bytes of data (no newline)]
265 # [maybe some more blocks]
274 # > param head DGIT-VIEW-HEAD
275 # > param csuite SUITE
276 # > param tagformat old|new
277 # > param maint-view MAINT-VIEW-HEAD
279 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
280 # # goes into tag, for replay prevention
283 # [indicates that signed tag is wanted]
284 # < data-block NBYTES
285 # < [NBYTES bytes of data (no newline)]
286 # [maybe some more blocks]
290 # > want signed-dsc-changes
291 # < data-block NBYTES [transfer of signed dsc]
293 # < data-block NBYTES [transfer of signed changes]
301 sub i_child_report () {
302 # Sees if our child has died, and reap it if so. Returns a string
303 # describing how it died if it failed, or undef otherwise.
304 return undef unless $i_child_pid;
305 my $got = waitpid $i_child_pid, WNOHANG;
306 return undef if $got <= 0;
307 die unless $got == $i_child_pid;
308 $i_child_pid = undef;
309 return undef unless $?;
310 return "build host child ".waitstatusmsg();
315 fail "connection lost: $!" if $fh->error;
316 fail "protocol violation; $m not expected";
319 sub badproto_badread ($$) {
321 fail "connection lost: $!" if $!;
322 my $report = i_child_report();
323 fail $report if defined $report;
324 badproto $fh, "eof (reading $wh)";
327 sub protocol_expect (&$) {
328 my ($match, $fh) = @_;
331 defined && chomp or badproto_badread $fh, "protocol message";
339 badproto $fh, "\`$_'";
342 sub protocol_send_file ($$) {
343 my ($fh, $ourfn) = @_;
344 open PF, "<", $ourfn or die "$ourfn: $!";
347 my $got = read PF, $d, 65536;
348 die "$ourfn: $!" unless defined $got;
350 print $fh "data-block ".length($d)."\n" or die $!;
351 print $fh $d or die $!;
353 PF->error and die "$ourfn $!";
354 print $fh "data-end\n" or die $!;
358 sub protocol_read_bytes ($$) {
359 my ($fh, $nbytes) = @_;
360 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
362 my $got = read $fh, $d, $nbytes;
363 $got==$nbytes or badproto_badread $fh, "data block";
367 sub protocol_receive_file ($$) {
368 my ($fh, $ourfn) = @_;
369 printdebug "() $ourfn\n";
370 open PF, ">", $ourfn or die "$ourfn: $!";
372 my ($y,$l) = protocol_expect {
373 m/^data-block (.*)$/ ? (1,$1) :
374 m/^data-end$/ ? (0,) :
378 my $d = protocol_read_bytes $fh, $l;
379 print PF $d or die $!;
384 #---------- remote protocol support, responder ----------
386 sub responder_send_command ($) {
388 return unless $we_are_responder;
389 # called even without $we_are_responder
390 printdebug ">> $command\n";
391 print PO $command, "\n" or die $!;
394 sub responder_send_file ($$) {
395 my ($keyword, $ourfn) = @_;
396 return unless $we_are_responder;
397 printdebug "]] $keyword $ourfn\n";
398 responder_send_command "file $keyword";
399 protocol_send_file \*PO, $ourfn;
402 sub responder_receive_files ($@) {
403 my ($keyword, @ourfns) = @_;
404 die unless $we_are_responder;
405 printdebug "[[ $keyword @ourfns\n";
406 responder_send_command "want $keyword";
407 foreach my $fn (@ourfns) {
408 protocol_receive_file \*PI, $fn;
411 protocol_expect { m/^files-end$/ } \*PI;
414 #---------- remote protocol support, initiator ----------
416 sub initiator_expect (&) {
418 protocol_expect { &$match } \*RO;
421 #---------- end remote code ----------
424 if ($we_are_responder) {
426 responder_send_command "progress ".length($m) or die $!;
427 print PO $m or die $!;
437 $ua = LWP::UserAgent->new();
441 progress "downloading $what...";
442 my $r = $ua->get(@_) or die $!;
443 return undef if $r->code == 404;
444 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
445 return $r->decoded_content(charset => 'none');
448 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
453 failedcmd @_ if system @_;
456 sub act_local () { return $dryrun_level <= 1; }
457 sub act_scary () { return !$dryrun_level; }
460 if (!$dryrun_level) {
461 progress "dgit ok: @_";
463 progress "would be ok: @_ (but dry run only)";
468 printcmd(\*STDERR,$debugprefix."#",@_);
471 sub runcmd_ordryrun {
479 sub runcmd_ordryrun_local {
488 my ($first_shell, @cmd) = @_;
489 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
492 our $helpmsg = <<END;
494 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
495 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
496 dgit [dgit-opts] build [dpkg-buildpackage-opts]
497 dgit [dgit-opts] sbuild [sbuild-opts]
498 dgit [dgit-opts] push [dgit-opts] [suite]
499 dgit [dgit-opts] rpush build-host:build-dir ...
500 important dgit options:
501 -k<keyid> sign tag and package with <keyid> instead of default
502 --dry-run -n do not change anything, but go through the motions
503 --damp-run -L like --dry-run but make local changes, without signing
504 --new -N allow introducing a new package
505 --debug -D increase debug level
506 -c<name>=<value> set git config option (used directly by dgit too)
509 our $later_warning_msg = <<END;
510 Perhaps the upload is stuck in incoming. Using the version from git.
514 print STDERR "$us: @_\n", $helpmsg or die $!;
519 @ARGV or badusage "too few arguments";
520 return scalar shift @ARGV;
524 print $helpmsg or die $!;
528 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
530 our %defcfg = ('dgit.default.distro' => 'debian',
531 'dgit.default.username' => '',
532 'dgit.default.archive-query-default-component' => 'main',
533 'dgit.default.ssh' => 'ssh',
534 'dgit.default.archive-query' => 'madison:',
535 'dgit.default.sshpsql-dbname' => 'service=projectb',
536 'dgit.default.dgit-tag-format' => 'old,new,maint',
537 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
538 'dgit-distro.debian.git-check' => 'url',
539 'dgit-distro.debian.git-check-suffix' => '/info/refs',
540 'dgit-distro.debian.new-private-pushers' => 't',
541 'dgit-distro.debian.dgit-tag-format' => 'old',
542 'dgit-distro.debian/push.git-url' => '',
543 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
544 'dgit-distro.debian/push.git-user-force' => 'dgit',
545 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
546 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
547 'dgit-distro.debian/push.git-create' => 'true',
548 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
549 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
550 # 'dgit-distro.debian.archive-query-tls-key',
551 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
552 # ^ this does not work because curl is broken nowadays
553 # Fixing #790093 properly will involve providing providing the key
554 # in some pacagke and maybe updating these paths.
556 # 'dgit-distro.debian.archive-query-tls-curl-args',
557 # '--ca-path=/etc/ssl/ca-debian',
558 # ^ this is a workaround but works (only) on DSA-administered machines
559 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
560 'dgit-distro.debian.git-url-suffix' => '',
561 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
562 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
563 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
564 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
565 'dgit-distro.ubuntu.git-check' => 'false',
566 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
567 'dgit-distro.test-dummy.ssh' => "$td/ssh",
568 'dgit-distro.test-dummy.username' => "alice",
569 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
570 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
571 'dgit-distro.test-dummy.git-url' => "$td/git",
572 'dgit-distro.test-dummy.git-host' => "git",
573 'dgit-distro.test-dummy.git-path' => "$td/git",
574 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
575 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
576 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
577 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
582 sub git_slurp_config () {
583 local ($debuglevel) = $debuglevel-2;
586 my @cmd = (@git, qw(config -z --get-regexp .*));
589 open GITS, "-|", @cmd or die $!;
592 printdebug "=> ", (messagequote $_), "\n";
594 push @{ $gitcfg{$`} }, $'; #';
598 or ($!==0 && $?==256)
602 sub git_get_config ($) {
605 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
608 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
614 return undef if $c =~ /RETURN-UNDEF/;
615 my $v = git_get_config($c);
616 return $v if defined $v;
617 my $dv = $defcfg{$c};
618 return $dv if defined $dv;
620 badcfg "need value for one of: @_\n".
621 "$us: distro or suite appears not to be (properly) supported";
624 sub access_basedistro () {
625 if (defined $idistro) {
628 return cfg("dgit-suite.$isuite.distro",
629 "dgit.default.distro");
633 sub access_quirk () {
634 # returns (quirk name, distro to use instead or undef, quirk-specific info)
635 my $basedistro = access_basedistro();
636 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
638 if (defined $backports_quirk) {
639 my $re = $backports_quirk;
640 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
642 $re =~ s/\%/([-0-9a-z_]+)/
643 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
644 if ($isuite =~ m/^$re$/) {
645 return ('backports',"$basedistro-backports",$1);
648 return ('none',undef);
653 sub parse_cfg_bool ($$$) {
654 my ($what,$def,$v) = @_;
657 $v =~ m/^[ty1]/ ? 1 :
658 $v =~ m/^[fn0]/ ? 0 :
659 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
662 sub access_forpush_config () {
663 my $d = access_basedistro();
667 parse_cfg_bool('new-private-pushers', 0,
668 cfg("dgit-distro.$d.new-private-pushers",
671 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
674 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
675 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
676 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
677 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
680 sub access_forpush () {
681 $access_forpush //= access_forpush_config();
682 return $access_forpush;
686 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
687 badcfg "pushing but distro is configured readonly"
688 if access_forpush_config() eq '0';
690 $supplementary_message = <<'END' unless $we_are_responder;
691 Push failed, before we got started.
692 You can retry the push, after fixing the problem, if you like.
694 finalise_opts_opts();
698 finalise_opts_opts();
701 sub supplementary_message ($) {
703 if (!$we_are_responder) {
704 $supplementary_message = $msg;
706 } elsif ($protovsn >= 3) {
707 responder_send_command "supplementary-message ".length($msg)
709 print PO $msg or die $!;
713 sub access_distros () {
714 # Returns list of distros to try, in order
717 # 0. `instead of' distro name(s) we have been pointed to
718 # 1. the access_quirk distro, if any
719 # 2a. the user's specified distro, or failing that } basedistro
720 # 2b. the distro calculated from the suite }
721 my @l = access_basedistro();
723 my (undef,$quirkdistro) = access_quirk();
724 unshift @l, $quirkdistro;
725 unshift @l, $instead_distro;
726 @l = grep { defined } @l;
728 if (access_forpush()) {
729 @l = map { ("$_/push", $_) } @l;
734 sub access_cfg_cfgs (@) {
737 # The nesting of these loops determines the search order. We put
738 # the key loop on the outside so that we search all the distros
739 # for each key, before going on to the next key. That means that
740 # if access_cfg is called with a more specific, and then a less
741 # specific, key, an earlier distro can override the less specific
742 # without necessarily overriding any more specific keys. (If the
743 # distro wants to override the more specific keys it can simply do
744 # so; whereas if we did the loop the other way around, it would be
745 # impossible to for an earlier distro to override a less specific
746 # key but not the more specific ones without restating the unknown
747 # values of the more specific keys.
750 # We have to deal with RETURN-UNDEF specially, so that we don't
751 # terminate the search prematurely.
753 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
756 foreach my $d (access_distros()) {
757 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
759 push @cfgs, map { "dgit.default.$_" } @realkeys;
766 my (@cfgs) = access_cfg_cfgs(@keys);
767 my $value = cfg(@cfgs);
771 sub access_cfg_bool ($$) {
772 my ($def, @keys) = @_;
773 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
776 sub string_to_ssh ($) {
778 if ($spec =~ m/\s/) {
779 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
785 sub access_cfg_ssh () {
786 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
787 if (!defined $gitssh) {
790 return string_to_ssh $gitssh;
794 sub access_runeinfo ($) {
796 return ": dgit ".access_basedistro()." $info ;";
799 sub access_someuserhost ($) {
801 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
802 defined($user) && length($user) or
803 $user = access_cfg("$some-user",'username');
804 my $host = access_cfg("$some-host");
805 return length($user) ? "$user\@$host" : $host;
808 sub access_gituserhost () {
809 return access_someuserhost('git');
812 sub access_giturl (;$) {
814 my $url = access_cfg('git-url','RETURN-UNDEF');
817 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
818 return undef unless defined $proto;
821 access_gituserhost().
822 access_cfg('git-path');
824 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
827 return "$url/$package$suffix";
830 sub parsecontrolfh ($$;$) {
831 my ($fh, $desc, $allowsigned) = @_;
832 our $dpkgcontrolhash_noissigned;
835 my %opts = ('name' => $desc);
836 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
837 $c = Dpkg::Control::Hash->new(%opts);
838 $c->parse($fh,$desc) or die "parsing of $desc failed";
839 last if $allowsigned;
840 last if $dpkgcontrolhash_noissigned;
841 my $issigned= $c->get_option('is_pgp_signed');
842 if (!defined $issigned) {
843 $dpkgcontrolhash_noissigned= 1;
844 seek $fh, 0,0 or die "seek $desc: $!";
845 } elsif ($issigned) {
846 fail "control file $desc is (already) PGP-signed. ".
847 " Note that dgit push needs to modify the .dsc and then".
848 " do the signature itself";
857 my ($file, $desc) = @_;
858 my $fh = new IO::Handle;
859 open $fh, '<', $file or die "$file: $!";
860 my $c = parsecontrolfh($fh,$desc);
861 $fh->error and die $!;
867 my ($dctrl,$field) = @_;
868 my $v = $dctrl->{$field};
869 return $v if defined $v;
870 fail "missing field $field in ".$v->get_option('name');
874 my $c = Dpkg::Control::Hash->new();
875 my $p = new IO::Handle;
876 my @cmd = (qw(dpkg-parsechangelog), @_);
877 open $p, '-|', @cmd or die $!;
879 $?=0; $!=0; close $p or failedcmd @cmd;
883 sub commit_getclogp ($) {
884 # Returns the parsed changelog hashref for a particular commit
886 our %commit_getclogp_memo;
887 my $memo = $commit_getclogp_memo{$objid};
888 return $memo if $memo;
890 my $mclog = ".git/dgit/clog-$objid";
891 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
892 "$objid:debian/changelog";
893 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
898 defined $d or fail "getcwd failed: $!";
904 sub archive_query ($) {
906 my $query = access_cfg('archive-query','RETURN-UNDEF');
907 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
910 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
913 sub pool_dsc_subpath ($$) {
914 my ($vsn,$component) = @_; # $package is implict arg
915 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
916 return "/pool/$component/$prefix/$package/".dscfn($vsn);
919 #---------- `ftpmasterapi' archive query method (nascent) ----------
921 sub archive_api_query_cmd ($) {
923 my @cmd = qw(curl -sS);
924 my $url = access_cfg('archive-query-url');
925 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
927 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
928 foreach my $key (split /\:/, $keys) {
929 $key =~ s/\%HOST\%/$host/g;
931 fail "for $url: stat $key: $!" unless $!==ENOENT;
934 fail "config requested specific TLS key but do not know".
935 " how to get curl to use exactly that EE key ($key)";
936 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
937 # # Sadly the above line does not work because of changes
938 # # to gnutls. The real fix for #790093 may involve
939 # # new curl options.
942 # Fixing #790093 properly will involve providing a value
943 # for this on clients.
944 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
945 push @cmd, split / /, $kargs if defined $kargs;
947 push @cmd, $url.$subpath;
953 my ($data, $subpath) = @_;
954 badcfg "ftpmasterapi archive query method takes no data part"
956 my @cmd = archive_api_query_cmd($subpath);
957 my $json = cmdoutput @cmd;
958 return decode_json($json);
961 sub canonicalise_suite_ftpmasterapi () {
962 my ($proto,$data) = @_;
963 my $suites = api_query($data, 'suites');
965 foreach my $entry (@$suites) {
967 my $v = $entry->{$_};
968 defined $v && $v eq $isuite;
970 push @matched, $entry;
972 fail "unknown suite $isuite" unless @matched;
975 @matched==1 or die "multiple matches for suite $isuite\n";
976 $cn = "$matched[0]{codename}";
977 defined $cn or die "suite $isuite info has no codename\n";
978 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
980 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
985 sub archive_query_ftpmasterapi () {
986 my ($proto,$data) = @_;
987 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
989 my $digester = Digest::SHA->new(256);
990 foreach my $entry (@$info) {
992 my $vsn = "$entry->{version}";
993 my ($ok,$msg) = version_check $vsn;
994 die "bad version: $msg\n" unless $ok;
995 my $component = "$entry->{component}";
996 $component =~ m/^$component_re$/ or die "bad component";
997 my $filename = "$entry->{filename}";
998 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
999 or die "bad filename";
1000 my $sha256sum = "$entry->{sha256sum}";
1001 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1002 push @rows, [ $vsn, "/pool/$component/$filename",
1003 $digester, $sha256sum ];
1005 die "bad ftpmaster api response: $@\n".Dumper($entry)
1008 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1012 #---------- `madison' archive query method ----------
1014 sub archive_query_madison {
1015 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1018 sub madison_get_parse {
1019 my ($proto,$data) = @_;
1020 die unless $proto eq 'madison';
1021 if (!length $data) {
1022 $data= access_cfg('madison-distro','RETURN-UNDEF');
1023 $data //= access_basedistro();
1025 $rmad{$proto,$data,$package} ||= cmdoutput
1026 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1027 my $rmad = $rmad{$proto,$data,$package};
1030 foreach my $l (split /\n/, $rmad) {
1031 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1032 \s*( [^ \t|]+ )\s* \|
1033 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1034 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1035 $1 eq $package or die "$rmad $package ?";
1042 $component = access_cfg('archive-query-default-component');
1044 $5 eq 'source' or die "$rmad ?";
1045 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1047 return sort { -version_compare($a->[0],$b->[0]); } @out;
1050 sub canonicalise_suite_madison {
1051 # madison canonicalises for us
1052 my @r = madison_get_parse(@_);
1054 "unable to canonicalise suite using package $package".
1055 " which does not appear to exist in suite $isuite;".
1056 " --existing-package may help";
1060 #---------- `sshpsql' archive query method ----------
1063 my ($data,$runeinfo,$sql) = @_;
1064 if (!length $data) {
1065 $data= access_someuserhost('sshpsql').':'.
1066 access_cfg('sshpsql-dbname');
1068 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1069 my ($userhost,$dbname) = ($`,$'); #';
1071 my @cmd = (access_cfg_ssh, $userhost,
1072 access_runeinfo("ssh-psql $runeinfo").
1073 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1074 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1076 open P, "-|", @cmd or die $!;
1079 printdebug(">|$_|\n");
1082 $!=0; $?=0; close P or failedcmd @cmd;
1084 my $nrows = pop @rows;
1085 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1086 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1087 @rows = map { [ split /\|/, $_ ] } @rows;
1088 my $ncols = scalar @{ shift @rows };
1089 die if grep { scalar @$_ != $ncols } @rows;
1093 sub sql_injection_check {
1094 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1097 sub archive_query_sshpsql ($$) {
1098 my ($proto,$data) = @_;
1099 sql_injection_check $isuite, $package;
1100 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1101 SELECT source.version, component.name, files.filename, files.sha256sum
1103 JOIN src_associations ON source.id = src_associations.source
1104 JOIN suite ON suite.id = src_associations.suite
1105 JOIN dsc_files ON dsc_files.source = source.id
1106 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1107 JOIN component ON component.id = files_archive_map.component_id
1108 JOIN files ON files.id = dsc_files.file
1109 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1110 AND source.source='$package'
1111 AND files.filename LIKE '%.dsc';
1113 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1114 my $digester = Digest::SHA->new(256);
1116 my ($vsn,$component,$filename,$sha256sum) = @$_;
1117 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1122 sub canonicalise_suite_sshpsql ($$) {
1123 my ($proto,$data) = @_;
1124 sql_injection_check $isuite;
1125 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1126 SELECT suite.codename
1127 FROM suite where suite_name='$isuite' or codename='$isuite';
1129 @rows = map { $_->[0] } @rows;
1130 fail "unknown suite $isuite" unless @rows;
1131 die "ambiguous $isuite: @rows ?" if @rows>1;
1135 #---------- `dummycat' archive query method ----------
1137 sub canonicalise_suite_dummycat ($$) {
1138 my ($proto,$data) = @_;
1139 my $dpath = "$data/suite.$isuite";
1140 if (!open C, "<", $dpath) {
1141 $!==ENOENT or die "$dpath: $!";
1142 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1146 chomp or die "$dpath: $!";
1148 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1152 sub archive_query_dummycat ($$) {
1153 my ($proto,$data) = @_;
1154 canonicalise_suite();
1155 my $dpath = "$data/package.$csuite.$package";
1156 if (!open C, "<", $dpath) {
1157 $!==ENOENT or die "$dpath: $!";
1158 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1166 printdebug "dummycat query $csuite $package $dpath | $_\n";
1167 my @row = split /\s+/, $_;
1168 @row==2 or die "$dpath: $_ ?";
1171 C->error and die "$dpath: $!";
1173 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1176 #---------- tag format handling ----------
1178 sub access_cfg_tagformats () {
1179 split /\,/, access_cfg('dgit-tag-format');
1182 sub need_tagformat ($$) {
1183 my ($fmt, $why) = @_;
1184 fail "need to use tag format $fmt ($why) but also need".
1185 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1186 " - no way to proceed"
1187 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1188 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1191 sub select_tagformat () {
1193 return if $tagformatfn && !$tagformat_want;
1194 die 'bug' if $tagformatfn && $tagformat_want;
1195 # ... $tagformat_want assigned after previous select_tagformat
1197 my (@supported) = grep { $_ ne 'maint' } access_cfg_tagformats();
1198 printdebug "select_tagformat supported @supported\n";
1200 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1201 printdebug "select_tagformat specified @$tagformat_want\n";
1203 my ($fmt,$why,$override) = @$tagformat_want;
1205 fail "target distro supports tag formats @supported".
1206 " but have to use $fmt ($why)"
1208 or grep { $_ eq $fmt } @supported;
1210 $tagformat_want = undef;
1212 $tagformatfn = ${*::}{"debiantag_$fmt"};
1214 fail "trying to use unknown tag format \`$fmt' ($why) !"
1215 unless $tagformatfn;
1218 #---------- archive query entrypoints and rest of program ----------
1220 sub canonicalise_suite () {
1221 return if defined $csuite;
1222 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1223 $csuite = archive_query('canonicalise_suite');
1224 if ($isuite ne $csuite) {
1225 progress "canonical suite name for $isuite is $csuite";
1229 sub get_archive_dsc () {
1230 canonicalise_suite();
1231 my @vsns = archive_query('archive_query');
1232 foreach my $vinfo (@vsns) {
1233 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1234 $dscurl = access_cfg('mirror').$subpath;
1235 $dscdata = url_get($dscurl);
1237 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1242 $digester->add($dscdata);
1243 my $got = $digester->hexdigest();
1245 fail "$dscurl has hash $got but".
1246 " archive told us to expect $digest";
1248 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1249 printdebug Dumper($dscdata) if $debuglevel>1;
1250 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1251 printdebug Dumper($dsc) if $debuglevel>1;
1252 my $fmt = getfield $dsc, 'Format';
1253 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1254 $dsc_checked = !!$digester;
1255 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1259 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1262 sub check_for_git ();
1263 sub check_for_git () {
1265 my $how = access_cfg('git-check');
1266 if ($how eq 'ssh-cmd') {
1268 (access_cfg_ssh, access_gituserhost(),
1269 access_runeinfo("git-check $package").
1270 " set -e; cd ".access_cfg('git-path').";".
1271 " if test -d $package.git; then echo 1; else echo 0; fi");
1272 my $r= cmdoutput @cmd;
1273 if (defined $r and $r =~ m/^divert (\w+)$/) {
1275 my ($usedistro,) = access_distros();
1276 # NB that if we are pushing, $usedistro will be $distro/push
1277 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1278 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1279 progress "diverting to $divert (using config for $instead_distro)";
1280 return check_for_git();
1282 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1284 } elsif ($how eq 'url') {
1285 my $prefix = access_cfg('git-check-url','git-url');
1286 my $suffix = access_cfg('git-check-suffix','git-suffix',
1287 'RETURN-UNDEF') // '.git';
1288 my $url = "$prefix/$package$suffix";
1289 my @cmd = (qw(curl -sS -I), $url);
1290 my $result = cmdoutput @cmd;
1291 $result =~ s/^\S+ 200 .*\n\r?\n//;
1292 # curl -sS -I with https_proxy prints
1293 # HTTP/1.0 200 Connection established
1294 $result =~ m/^\S+ (404|200) /s or
1295 fail "unexpected results from git check query - ".
1296 Dumper($prefix, $result);
1298 if ($code eq '404') {
1300 } elsif ($code eq '200') {
1305 } elsif ($how eq 'true') {
1307 } elsif ($how eq 'false') {
1310 badcfg "unknown git-check \`$how'";
1314 sub create_remote_git_repo () {
1315 my $how = access_cfg('git-create');
1316 if ($how eq 'ssh-cmd') {
1318 (access_cfg_ssh, access_gituserhost(),
1319 access_runeinfo("git-create $package").
1320 "set -e; cd ".access_cfg('git-path').";".
1321 " cp -a _template $package.git");
1322 } elsif ($how eq 'true') {
1325 badcfg "unknown git-create \`$how'";
1329 our ($dsc_hash,$lastpush_mergeinput);
1331 our $ud = '.git/dgit/unpack';
1341 sub mktree_in_ud_here () {
1342 runcmd qw(git init -q);
1343 rmtree('.git/objects');
1344 symlink '../../../../objects','.git/objects' or die $!;
1347 sub git_write_tree () {
1348 my $tree = cmdoutput @git, qw(write-tree);
1349 $tree =~ m/^\w+$/ or die "$tree ?";
1353 sub remove_stray_gits () {
1354 my @gitscmd = qw(find -name .git -prune -print0);
1355 debugcmd "|",@gitscmd;
1356 open GITS, "-|", @gitscmd or die $!;
1361 print STDERR "$us: warning: removing from source package: ",
1362 (messagequote $_), "\n";
1366 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1369 sub mktree_in_ud_from_only_subdir () {
1370 # changes into the subdir
1372 die "@dirs ?" unless @dirs==1;
1373 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1377 remove_stray_gits();
1378 mktree_in_ud_here();
1379 my ($format, $fopts) = get_source_format();
1380 if (madformat($format)) {
1383 runcmd @git, qw(add -Af);
1384 my $tree=git_write_tree();
1385 return ($tree,$dir);
1388 sub dsc_files_info () {
1389 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1390 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1391 ['Files', 'Digest::MD5', 'new()']) {
1392 my ($fname, $module, $method) = @$csumi;
1393 my $field = $dsc->{$fname};
1394 next unless defined $field;
1395 eval "use $module; 1;" or die $@;
1397 foreach (split /\n/, $field) {
1399 m/^(\w+) (\d+) (\S+)$/ or
1400 fail "could not parse .dsc $fname line \`$_'";
1401 my $digester = eval "$module"."->$method;" or die $@;
1406 Digester => $digester,
1411 fail "missing any supported Checksums-* or Files field in ".
1412 $dsc->get_option('name');
1416 map { $_->{Filename} } dsc_files_info();
1419 sub is_orig_file ($;$) {
1422 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1423 defined $base or return 1;
1427 sub make_commit ($) {
1429 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1432 sub clogp_authline ($) {
1434 my $author = getfield $clogp, 'Maintainer';
1435 $author =~ s#,.*##ms;
1436 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1437 my $authline = "$author $date";
1438 $authline =~ m/$git_authline_re/o or
1439 fail "unexpected commit author line format \`$authline'".
1440 " (was generated from changelog Maintainer field)";
1441 return ($1,$2,$3) if wantarray;
1445 sub vendor_patches_distro ($$) {
1446 my ($checkdistro, $what) = @_;
1447 return unless defined $checkdistro;
1449 my $series = "debian/patches/\L$checkdistro\E.series";
1450 printdebug "checking for vendor-specific $series ($what)\n";
1452 if (!open SERIES, "<", $series) {
1453 die "$series $!" unless $!==ENOENT;
1462 Unfortunately, this source package uses a feature of dpkg-source where
1463 the same source package unpacks to different source code on different
1464 distros. dgit cannot safely operate on such packages on affected
1465 distros, because the meaning of source packages is not stable.
1467 Please ask the distro/maintainer to remove the distro-specific series
1468 files and use a different technique (if necessary, uploading actually
1469 different packages, if different distros are supposed to have
1473 fail "Found active distro-specific series file for".
1474 " $checkdistro ($what): $series, cannot continue";
1476 die "$series $!" if SERIES->error;
1480 sub check_for_vendor_patches () {
1481 # This dpkg-source feature doesn't seem to be documented anywhere!
1482 # But it can be found in the changelog (reformatted):
1484 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1485 # Author: Raphael Hertzog <hertzog@debian.org>
1486 # Date: Sun Oct 3 09:36:48 2010 +0200
1488 # dpkg-source: correctly create .pc/.quilt_series with alternate
1491 # If you have debian/patches/ubuntu.series and you were
1492 # unpacking the source package on ubuntu, quilt was still
1493 # directed to debian/patches/series instead of
1494 # debian/patches/ubuntu.series.
1496 # debian/changelog | 3 +++
1497 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1498 # 2 files changed, 6 insertions(+), 1 deletion(-)
1501 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1502 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1503 "Dpkg::Vendor \`current vendor'");
1504 vendor_patches_distro(access_basedistro(),
1505 "distro being accessed");
1508 sub generate_commits_from_dsc () {
1509 # See big comment in fetch_from_archive, below.
1513 foreach my $fi (dsc_files_info()) {
1514 my $f = $fi->{Filename};
1515 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1517 link_ltarget "../../../$f", $f
1521 complete_file_from_dsc('.', $fi)
1524 if (is_orig_file($f)) {
1525 link $f, "../../../../$f"
1531 my $dscfn = "$package.dsc";
1533 open D, ">", $dscfn or die "$dscfn: $!";
1534 print D $dscdata or die "$dscfn: $!";
1535 close D or die "$dscfn: $!";
1536 my @cmd = qw(dpkg-source);
1537 push @cmd, '--no-check' if $dsc_checked;
1538 push @cmd, qw(-x --), $dscfn;
1541 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1542 check_for_vendor_patches() if madformat($dsc->{format});
1543 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1544 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1545 my $authline = clogp_authline $clogp;
1546 my $changes = getfield $clogp, 'Changes';
1547 open C, ">../commit.tmp" or die $!;
1548 print C <<END or die $!;
1555 # imported from the archive
1558 my $rawimport_hash = make_commit qw(../commit.tmp);
1559 my $cversion = getfield $clogp, 'Version';
1560 my $rawimport_mergeinput = {
1561 Commit => $rawimport_hash,
1562 Info => "Import of source package",
1564 my @output = ($rawimport_mergeinput);
1565 progress "synthesised git commit from .dsc $cversion";
1566 if ($lastpush_mergeinput) {
1567 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1568 my $oversion = getfield $oldclogp, 'Version';
1570 version_compare($oversion, $cversion);
1572 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1573 { Message => <<END, ReverseParents => 1 });
1574 Record $package ($cversion) in archive suite $csuite
1576 } elsif ($vcmp > 0) {
1577 print STDERR <<END or die $!;
1579 Version actually in archive: $cversion (older)
1580 Last version pushed with dgit: $oversion (newer or same)
1583 @output = $lastpush_mergeinput;
1585 # Same version. Use what's in the server git branch,
1586 # discarding our own import. (This could happen if the
1587 # server automatically imports all packages into git.)
1588 @output = $lastpush_mergeinput;
1591 changedir '../../../..';
1596 sub complete_file_from_dsc ($$) {
1597 our ($dstdir, $fi) = @_;
1598 # Ensures that we have, in $dir, the file $fi, with the correct
1599 # contents. (Downloading it from alongside $dscurl if necessary.)
1601 my $f = $fi->{Filename};
1602 my $tf = "$dstdir/$f";
1605 if (stat_exists $tf) {
1606 progress "using existing $f";
1609 $furl =~ s{/[^/]+$}{};
1611 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1612 die "$f ?" if $f =~ m#/#;
1613 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1614 return 0 if !act_local();
1618 open F, "<", "$tf" or die "$tf: $!";
1619 $fi->{Digester}->reset();
1620 $fi->{Digester}->addfile(*F);
1621 F->error and die $!;
1622 my $got = $fi->{Digester}->hexdigest();
1623 $got eq $fi->{Hash} or
1624 fail "file $f has hash $got but .dsc".
1625 " demands hash $fi->{Hash} ".
1626 ($downloaded ? "(got wrong file from archive!)"
1627 : "(perhaps you should delete this file?)");
1632 sub ensure_we_have_orig () {
1633 foreach my $fi (dsc_files_info()) {
1634 my $f = $fi->{Filename};
1635 next unless is_orig_file($f);
1636 complete_file_from_dsc('..', $fi)
1641 sub git_fetch_us () {
1642 # Want to fetch only what we are going to use, unless
1643 # deliberately-not-ff, in which case we must fetch everything.
1645 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1647 (quiltmode_splitbrain
1648 ? (map { $_->('*',access_basedistro) }
1649 \&debiantag_new, \&debiantag_maintview)
1650 : debiantags('*',access_basedistro));
1651 push @specs, server_branch($csuite);
1652 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1654 # This is rather miserable:
1655 # When git-fetch --prune is passed a fetchspec ending with a *,
1656 # it does a plausible thing. If there is no * then:
1657 # - it matches subpaths too, even if the supplied refspec
1658 # starts refs, and behaves completely madly if the source
1659 # has refs/refs/something. (See, for example, Debian #NNNN.)
1660 # - if there is no matching remote ref, it bombs out the whole
1662 # We want to fetch a fixed ref, and we don't know in advance
1663 # if it exists, so this is not suitable.
1665 # Our workaround is to use git-ls-remote. git-ls-remote has its
1666 # own qairks. Notably, it has the absurd multi-tail-matching
1667 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1668 # refs/refs/foo etc.
1670 # Also, we want an idempotent snapshot, but we have to make two
1671 # calls to the remote: one to git-ls-remote and to git-fetch. The
1672 # solution is use git-ls-remote to obtain a target state, and
1673 # git-fetch to try to generate it. If we don't manage to generate
1674 # the target state, we try again.
1676 my $specre = join '|', map {
1682 printdebug "git_fetch_us specre=$specre\n";
1683 my $wanted_rref = sub {
1685 return m/^(?:$specre)$/o;
1688 my $fetch_iteration = 0;
1691 if (++$fetch_iteration > 10) {
1692 fail "too many iterations trying to get sane fetch!";
1695 my @look = map { "refs/$_" } @specs;
1696 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1700 open GITLS, "-|", @lcmd or die $!;
1702 printdebug "=> ", $_;
1703 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1704 my ($objid,$rrefname) = ($1,$2);
1705 if (!$wanted_rref->($rrefname)) {
1707 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1711 $wantr{$rrefname} = $objid;
1714 close GITLS or failedcmd @lcmd;
1716 # OK, now %want is exactly what we want for refs in @specs
1718 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1719 "+refs/$_:".lrfetchrefs."/$_";
1722 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1723 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1726 %lrfetchrefs_f = ();
1729 git_for_each_ref(lrfetchrefs, sub {
1730 my ($objid,$objtype,$lrefname,$reftail) = @_;
1731 $lrfetchrefs_f{$lrefname} = $objid;
1732 $objgot{$objid} = 1;
1735 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1736 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1737 if (!exists $wantr{$rrefname}) {
1738 if ($wanted_rref->($rrefname)) {
1740 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1744 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1747 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1748 delete $lrfetchrefs_f{$lrefname};
1752 foreach my $rrefname (sort keys %wantr) {
1753 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1754 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1755 my $want = $wantr{$rrefname};
1756 next if $got eq $want;
1757 if (!defined $objgot{$want}) {
1759 warning: git-ls-remote suggests we want $lrefname
1760 warning: and it should refer to $want
1761 warning: but git-fetch didn't fetch that object to any relevant ref.
1762 warning: This may be due to a race with someone updating the server.
1763 warning: Will try again...
1765 next FETCH_ITERATION;
1768 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1770 runcmd_ordryrun_local @git, qw(update-ref -m),
1771 "dgit fetch git-fetch fixup", $lrefname, $want;
1772 $lrfetchrefs_f{$lrefname} = $want;
1776 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1777 Dumper(\%lrfetchrefs_f);
1780 my @tagpats = debiantags('*',access_basedistro);
1782 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1783 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1784 printdebug "currently $fullrefname=$objid\n";
1785 $here{$fullrefname} = $objid;
1787 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1788 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1789 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1790 printdebug "offered $lref=$objid\n";
1791 if (!defined $here{$lref}) {
1792 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1793 runcmd_ordryrun_local @upd;
1794 lrfetchref_used $fullrefname;
1795 } elsif ($here{$lref} eq $objid) {
1796 lrfetchref_used $fullrefname;
1799 "Not updateting $lref from $here{$lref} to $objid.\n";
1804 sub mergeinfo_getclogp ($) {
1805 # Ensures thit $mi->{Clogp} exists and returns it
1807 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1810 sub mergeinfo_version ($) {
1811 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1814 sub fetch_from_archive () {
1815 # Ensures that lrref() is what is actually in the archive, one way
1816 # or another, according to us - ie this client's
1817 # appropritaely-updated archive view. Also returns the commit id.
1818 # If there is nothing in the archive, leaves lrref alone and
1819 # returns undef. git_fetch_us must have already been called.
1823 foreach my $field (@ourdscfield) {
1824 $dsc_hash = $dsc->{$field};
1825 last if defined $dsc_hash;
1827 if (defined $dsc_hash) {
1828 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1830 progress "last upload to archive specified git hash";
1832 progress "last upload to archive has NO git hash";
1835 progress "no version available from the archive";
1838 # If the archive's .dsc has a Dgit field, there are three
1839 # relevant git commitids we need to choose between and/or merge
1841 # 1. $dsc_hash: the Dgit field from the archive
1842 # 2. $lastpush_hash: the suite branch on the dgit git server
1843 # 3. $lastfetch_hash: our local tracking brach for the suite
1845 # These may all be distinct and need not be in any fast forward
1848 # If the dsc was pushed to this suite, then the server suite
1849 # branch will have been updated; but it might have been pushed to
1850 # a different suite and copied by the archive. Conversely a more
1851 # recent version may have been pushed with dgit but not appeared
1852 # in the archive (yet).
1854 # $lastfetch_hash may be awkward because archive imports
1855 # (particularly, imports of Dgit-less .dscs) are performed only as
1856 # needed on individual clients, so different clients may perform a
1857 # different subset of them - and these imports are only made
1858 # public during push. So $lastfetch_hash may represent a set of
1859 # imports different to a subsequent upload by a different dgit
1862 # Our approach is as follows:
1864 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1865 # descendant of $dsc_hash, then it was pushed by a dgit user who
1866 # had based their work on $dsc_hash, so we should prefer it.
1867 # Otherwise, $dsc_hash was installed into this suite in the
1868 # archive other than by a dgit push, and (necessarily) after the
1869 # last dgit push into that suite (since a dgit push would have
1870 # been descended from the dgit server git branch); thus, in that
1871 # case, we prefer the archive's version (and produce a
1872 # pseudo-merge to overwrite the dgit server git branch).
1874 # (If there is no Dgit field in the archive's .dsc then
1875 # generate_commit_from_dsc uses the version numbers to decide
1876 # whether the suite branch or the archive is newer. If the suite
1877 # branch is newer it ignores the archive's .dsc; otherwise it
1878 # generates an import of the .dsc, and produces a pseudo-merge to
1879 # overwrite the suite branch with the archive contents.)
1881 # The outcome of that part of the algorithm is the `public view',
1882 # and is same for all dgit clients: it does not depend on any
1883 # unpublished history in the local tracking branch.
1885 # As between the public view and the local tracking branch: The
1886 # local tracking branch is only updated by dgit fetch, and
1887 # whenever dgit fetch runs it includes the public view in the
1888 # local tracking branch. Therefore if the public view is not
1889 # descended from the local tracking branch, the local tracking
1890 # branch must contain history which was imported from the archive
1891 # but never pushed; and, its tip is now out of date. So, we make
1892 # a pseudo-merge to overwrite the old imports and stitch the old
1895 # Finally: we do not necessarily reify the public view (as
1896 # described above). This is so that we do not end up stacking two
1897 # pseudo-merges. So what we actually do is figure out the inputs
1898 # to any public view psuedo-merge and put them in @mergeinputs.
1901 # $mergeinputs[]{Commit}
1902 # $mergeinputs[]{Info}
1903 # $mergeinputs[0] is the one whose tree we use
1904 # @mergeinputs is in the order we use in the actual commit)
1907 # $mergeinputs[]{Message} is a commit message to use
1908 # $mergeinputs[]{ReverseParents} if def specifies that parent
1909 # list should be in opposite order
1910 # Such an entry has no Commit or Info. It applies only when found
1911 # in the last entry. (This ugliness is to support making
1912 # identical imports to previous dgit versions.)
1914 my $lastpush_hash = git_get_ref(lrfetchref());
1915 printdebug "previous reference hash=$lastpush_hash\n";
1916 $lastpush_mergeinput = $lastpush_hash && {
1917 Commit => $lastpush_hash,
1918 Info => "dgit suite branch on dgit git server",
1921 my $lastfetch_hash = git_get_ref(lrref());
1922 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1923 my $lastfetch_mergeinput = $lastfetch_hash && {
1924 Commit => $lastfetch_hash,
1925 Info => "dgit client's archive history view",
1928 my $dsc_mergeinput = $dsc_hash && {
1929 Commit => $dsc_hash,
1930 Info => "Dgit field in .dsc from archive",
1934 my $del_lrfetchrefs = sub {
1937 printdebug "del_lrfetchrefs...\n";
1938 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1939 my $objid = $lrfetchrefs_d{$fullrefname};
1940 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1942 $gur ||= new IO::Handle;
1943 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1945 printf $gur "delete %s %s\n", $fullrefname, $objid;
1948 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1952 if (defined $dsc_hash) {
1953 fail "missing remote git history even though dsc has hash -".
1954 " could not find ref ".rref()." at ".access_giturl()
1955 unless $lastpush_hash;
1956 ensure_we_have_orig();
1957 if ($dsc_hash eq $lastpush_hash) {
1958 @mergeinputs = $dsc_mergeinput
1959 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1960 print STDERR <<END or die $!;
1962 Git commit in archive is behind the last version allegedly pushed/uploaded.
1963 Commit referred to by archive: $dsc_hash
1964 Last version pushed with dgit: $lastpush_hash
1967 @mergeinputs = ($lastpush_mergeinput);
1969 # Archive has .dsc which is not a descendant of the last dgit
1970 # push. This can happen if the archive moves .dscs about.
1971 # Just follow its lead.
1972 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1973 progress "archive .dsc names newer git commit";
1974 @mergeinputs = ($dsc_mergeinput);
1976 progress "archive .dsc names other git commit, fixing up";
1977 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1981 @mergeinputs = generate_commits_from_dsc();
1982 # We have just done an import. Now, our import algorithm might
1983 # have been improved. But even so we do not want to generate
1984 # a new different import of the same package. So if the
1985 # version numbers are the same, just use our existing version.
1986 # If the version numbers are different, the archive has changed
1987 # (perhaps, rewound).
1988 if ($lastfetch_mergeinput &&
1989 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1990 (mergeinfo_version $mergeinputs[0]) )) {
1991 @mergeinputs = ($lastfetch_mergeinput);
1993 } elsif ($lastpush_hash) {
1994 # only in git, not in the archive yet
1995 @mergeinputs = ($lastpush_mergeinput);
1996 print STDERR <<END or die $!;
1998 Package not found in the archive, but has allegedly been pushed using dgit.
2002 printdebug "nothing found!\n";
2003 if (defined $skew_warning_vsn) {
2004 print STDERR <<END or die $!;
2006 Warning: relevant archive skew detected.
2007 Archive allegedly contains $skew_warning_vsn
2008 But we were not able to obtain any version from the archive or git.
2012 unshift @end, $del_lrfetchrefs;
2016 if ($lastfetch_hash &&
2018 my $h = $_->{Commit};
2019 $h and is_fast_fwd($lastfetch_hash, $h);
2020 # If true, one of the existing parents of this commit
2021 # is a descendant of the $lastfetch_hash, so we'll
2022 # be ff from that automatically.
2026 push @mergeinputs, $lastfetch_mergeinput;
2029 printdebug "fetch mergeinfos:\n";
2030 foreach my $mi (@mergeinputs) {
2032 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2034 printdebug sprintf " ReverseParents=%d Message=%s",
2035 $mi->{ReverseParents}, $mi->{Message};
2039 my $compat_info= pop @mergeinputs
2040 if $mergeinputs[$#mergeinputs]{Message};
2042 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2045 if (@mergeinputs > 1) {
2047 my $tree_commit = $mergeinputs[0]{Commit};
2049 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2050 $tree =~ m/\n\n/; $tree = $`;
2051 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2054 # We use the changelog author of the package in question the
2055 # author of this pseudo-merge. This is (roughly) correct if
2056 # this commit is simply representing aa non-dgit upload.
2057 # (Roughly because it does not record sponsorship - but we
2058 # don't have sponsorship info because that's in the .changes,
2059 # which isn't in the archivw.)
2061 # But, it might be that we are representing archive history
2062 # updates (including in-archive copies). These are not really
2063 # the responsibility of the person who created the .dsc, but
2064 # there is no-one whose name we should better use. (The
2065 # author of the .dsc-named commit is clearly worse.)
2067 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2068 my $author = clogp_authline $useclogp;
2069 my $cversion = getfield $useclogp, 'Version';
2071 my $mcf = ".git/dgit/mergecommit";
2072 open MC, ">", $mcf or die "$mcf $!";
2073 print MC <<END or die $!;
2077 my @parents = grep { $_->{Commit} } @mergeinputs;
2078 @parents = reverse @parents if $compat_info->{ReverseParents};
2079 print MC <<END or die $! foreach @parents;
2083 print MC <<END or die $!;
2089 if (defined $compat_info->{Message}) {
2090 print MC $compat_info->{Message} or die $!;
2092 print MC <<END or die $!;
2093 Record $package ($cversion) in archive suite $csuite
2097 my $message_add_info = sub {
2099 my $mversion = mergeinfo_version $mi;
2100 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2104 $message_add_info->($mergeinputs[0]);
2105 print MC <<END or die $!;
2106 should be treated as descended from
2108 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2112 $hash = make_commit $mcf;
2114 $hash = $mergeinputs[0]{Commit};
2116 progress "fetch hash=$hash\n";
2119 my ($lasth, $what) = @_;
2120 return unless $lasth;
2121 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2124 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2125 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2127 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2128 'DGIT_ARCHIVE', $hash;
2129 cmdoutput @git, qw(log -n2), $hash;
2130 # ... gives git a chance to complain if our commit is malformed
2132 if (defined $skew_warning_vsn) {
2134 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2135 my $gotclogp = commit_getclogp($hash);
2136 my $got_vsn = getfield $gotclogp, 'Version';
2137 printdebug "SKEW CHECK GOT $got_vsn\n";
2138 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2139 print STDERR <<END or die $!;
2141 Warning: archive skew detected. Using the available version:
2142 Archive allegedly contains $skew_warning_vsn
2143 We were able to obtain only $got_vsn
2149 if ($lastfetch_hash ne $hash) {
2150 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2154 dryrun_report @upd_cmd;
2158 lrfetchref_used lrfetchref();
2160 unshift @end, $del_lrfetchrefs;
2164 sub set_local_git_config ($$) {
2166 runcmd @git, qw(config), $k, $v;
2169 sub setup_mergechangelogs (;$) {
2171 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2173 my $driver = 'dpkg-mergechangelogs';
2174 my $cb = "merge.$driver";
2175 my $attrs = '.git/info/attributes';
2176 ensuredir '.git/info';
2178 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2179 if (!open ATTRS, "<", $attrs) {
2180 $!==ENOENT or die "$attrs: $!";
2184 next if m{^debian/changelog\s};
2185 print NATTRS $_, "\n" or die $!;
2187 ATTRS->error and die $!;
2190 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2193 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2194 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2196 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2199 sub setup_useremail (;$) {
2201 return unless $always || access_cfg_bool(1, 'setup-useremail');
2204 my ($k, $envvar) = @_;
2205 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2206 return unless defined $v;
2207 set_local_git_config "user.$k", $v;
2210 $setup->('email', 'DEBEMAIL');
2211 $setup->('name', 'DEBFULLNAME');
2214 sub setup_new_tree () {
2215 setup_mergechangelogs();
2221 canonicalise_suite();
2222 badusage "dry run makes no sense with clone" unless act_local();
2223 my $hasgit = check_for_git();
2224 mkdir $dstdir or fail "create \`$dstdir': $!";
2226 runcmd @git, qw(init -q);
2227 my $giturl = access_giturl(1);
2228 if (defined $giturl) {
2229 open H, "> .git/HEAD" or die $!;
2230 print H "ref: ".lref()."\n" or die $!;
2232 runcmd @git, qw(remote add), 'origin', $giturl;
2235 progress "fetching existing git history";
2237 runcmd_ordryrun_local @git, qw(fetch origin);
2239 progress "starting new git history";
2241 fetch_from_archive() or no_such_package;
2242 my $vcsgiturl = $dsc->{'Vcs-Git'};
2243 if (length $vcsgiturl) {
2244 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2245 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2248 runcmd @git, qw(reset --hard), lrref();
2249 printdone "ready for work in $dstdir";
2253 if (check_for_git()) {
2256 fetch_from_archive() or no_such_package();
2257 printdone "fetched into ".lrref();
2262 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2264 printdone "fetched to ".lrref()." and merged into HEAD";
2267 sub check_not_dirty () {
2268 foreach my $f (qw(local-options local-patch-header)) {
2269 if (stat_exists "debian/source/$f") {
2270 fail "git tree contains debian/source/$f";
2274 return if $ignoredirty;
2276 my @cmd = (@git, qw(diff --quiet HEAD));
2278 $!=0; $?=-1; system @cmd;
2281 fail "working tree is dirty (does not match HEAD)";
2287 sub commit_admin ($) {
2290 runcmd_ordryrun_local @git, qw(commit -m), $m;
2293 sub commit_quilty_patch () {
2294 my $output = cmdoutput @git, qw(status --porcelain);
2296 foreach my $l (split /\n/, $output) {
2297 next unless $l =~ m/\S/;
2298 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2302 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2304 progress "nothing quilty to commit, ok.";
2307 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2308 runcmd_ordryrun_local @git, qw(add -f), @adds;
2309 commit_admin "Commit Debian 3.0 (quilt) metadata";
2312 sub get_source_format () {
2314 if (open F, "debian/source/options") {
2318 s/\s+$//; # ignore missing final newline
2320 my ($k, $v) = ($`, $'); #');
2321 $v =~ s/^"(.*)"$/$1/;
2327 F->error and die $!;
2330 die $! unless $!==&ENOENT;
2333 if (!open F, "debian/source/format") {
2334 die $! unless $!==&ENOENT;
2338 F->error and die $!;
2340 return ($_, \%options);
2345 return 0 unless $format eq '3.0 (quilt)';
2346 our $quilt_mode_warned;
2347 if ($quilt_mode eq 'nocheck') {
2348 progress "Not doing any fixup of \`$format' due to".
2349 " ----no-quilt-fixup or --quilt=nocheck"
2350 unless $quilt_mode_warned++;
2353 progress "Format \`$format', need to check/update patch stack"
2354 unless $quilt_mode_warned++;
2358 sub splitbrain_pseudomerge ($$$$) {
2359 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2360 # => $merged_dgitview
2361 printdebug "splitbrain_pseudomerge...\n";
2363 # We: debian/PREVIOUS HEAD($maintview)
2364 # expect: o ----------------- o
2367 # a/d/PREVIOUS $dgitview
2370 # we do: `------------------ o
2374 # We work with tuples [ $thing, $what ]
2375 # (often $thing is a commit hash; $what is a description)
2377 my $tag_lookup = sub {
2378 my ($tagname, $what) = @_;
2379 printdebug "splitbrain_pseudomerge tag_lookup $what\n";
2380 my $lrefname = lrfetchrefs."/tags/$tagname";
2381 my $tagobj = $lrfetchrefs_f{$lrefname};
2382 defined $tagobj or fail <<END;
2383 Wanted tag $tagname ($what) on dgit server, but not found
2385 printdebug "splitbrain_pseudomerge tag_lookup $tagobj $what\n";
2386 return [ git_rev_parse($tagobj), $what ];
2389 my $cond_equal = sub {
2391 $x->[0] eq $y->[0] or fail <<END;
2392 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2396 my ($anc,$desc) = @_;
2397 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2398 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2402 my $arch_clogp = commit_getclogp $archive_hash;
2403 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2404 'version currently in archive' ];
2406 printdebug "splitbrain_pseudomerge i_arch_v @$i_arch_v\n";
2408 return $dgitview unless defined $archive_hash;
2410 if ($overwrite_version) {
2411 progress "Declaring that HEAD inciudes all changes in archive...";
2412 progress "Checking that $overwrite_version does so...";
2413 $cond_equal->([ $overwrite_version, '--overwrite= version' ],
2416 progress "Checking that HEAD inciudes all changes in archive...";
2419 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2421 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2422 my $i_dep14 = $tag_lookup->($t_dep14, "maintainer view tag");
2423 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2424 my $i_dgit = $tag_lookup->($t_dgit, "dgit view tag");
2425 my $i_archive = [ $archive_hash, "current archive contents" ];
2427 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2429 $cond_equal->($i_dgit, $i_archive);
2430 $cond_ff->($i_dep14, $i_dgit);
2431 $overwrite_version or $cond_ff->($i_dep14, [ $maintview, 'HEAD' ]);
2433 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2434 my $authline = clogp_authline $clogp;
2437 my $pmf = ".git/dgit/pseudomerge";
2438 open MC, ">", $pmf or die "$pmf $!";
2439 print MC <<END or die $!;
2442 parent $archive_hash
2447 if ($overwrite_version) {
2449 Declare fast forward from $overwrite_version
2451 [dgit --quilt=$quilt_mode --overwrite-version=$overwrite_version]
2455 Make fast forward from $i_arch_v->[0]
2457 [dgit --quilt=$quilt_mode]
2462 progress "Making pseudo-merge of $i_arch_v->[0] into dgit view.";
2463 return make_commit($pmf);
2466 sub push_parse_changelog ($) {
2469 my $clogp = Dpkg::Control::Hash->new();
2470 $clogp->load($clogpfn) or die;
2472 $package = getfield $clogp, 'Source';
2473 my $cversion = getfield $clogp, 'Version';
2474 my $tag = debiantag($cversion, access_basedistro);
2475 runcmd @git, qw(check-ref-format), $tag;
2477 my $dscfn = dscfn($cversion);
2479 return ($clogp, $cversion, $dscfn);
2482 sub push_parse_dsc ($$$) {
2483 my ($dscfn,$dscfnwhat, $cversion) = @_;
2484 $dsc = parsecontrol($dscfn,$dscfnwhat);
2485 my $dversion = getfield $dsc, 'Version';
2486 my $dscpackage = getfield $dsc, 'Source';
2487 ($dscpackage eq $package && $dversion eq $cversion) or
2488 fail "$dscfn is for $dscpackage $dversion".
2489 " but debian/changelog is for $package $cversion";
2492 sub push_tagwants ($$$$) {
2493 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2496 TagFn => \&debiantag,
2501 if (defined $maintviewhead) {
2503 TagFn => \&debiantag_maintview,
2504 Objid => $maintviewhead,
2505 TfSuffix => '-maintview',
2509 foreach my $tw (@tagwants) {
2510 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2511 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2513 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2517 sub push_mktags ($$ $$ $) {
2519 $changesfile,$changesfilewhat,
2522 die unless $tagwants->[0]{View} eq 'dgit';
2524 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2525 $dsc->save("$dscfn.tmp") or die $!;
2527 my $changes = parsecontrol($changesfile,$changesfilewhat);
2528 foreach my $field (qw(Source Distribution Version)) {
2529 $changes->{$field} eq $clogp->{$field} or
2530 fail "changes field $field \`$changes->{$field}'".
2531 " does not match changelog \`$clogp->{$field}'";
2534 my $cversion = getfield $clogp, 'Version';
2535 my $clogsuite = getfield $clogp, 'Distribution';
2537 # We make the git tag by hand because (a) that makes it easier
2538 # to control the "tagger" (b) we can do remote signing
2539 my $authline = clogp_authline $clogp;
2540 my $delibs = join(" ", "",@deliberatelies);
2541 my $declaredistro = access_basedistro();
2545 my $tfn = $tw->{Tfn};
2546 my $head = $tw->{Objid};
2547 my $tag = $tw->{Tag};
2549 open TO, '>', $tfn->('.tmp') or die $!;
2550 print TO <<END or die $!;
2557 if ($tw->{View} eq 'dgit') {
2558 print TO <<END or die $!;
2559 $package release $cversion for $clogsuite ($csuite) [dgit]
2560 [dgit distro=$declaredistro$delibs]
2562 foreach my $ref (sort keys %previously) {
2563 print TO <<END or die $!;
2564 [dgit previously:$ref=$previously{$ref}]
2567 } elsif ($tw->{View} eq 'maint') {
2568 print TO <<END or die $!;
2569 $package release $cversion for $clogsuite ($csuite)
2570 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2573 die Dumper($tw)."?";
2578 my $tagobjfn = $tfn->('.tmp');
2580 if (!defined $keyid) {
2581 $keyid = access_cfg('keyid','RETURN-UNDEF');
2583 if (!defined $keyid) {
2584 $keyid = getfield $clogp, 'Maintainer';
2586 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2587 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2588 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2589 push @sign_cmd, $tfn->('.tmp');
2590 runcmd_ordryrun @sign_cmd;
2592 $tagobjfn = $tfn->('.signed.tmp');
2593 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2594 $tfn->('.tmp'), $tfn->('.tmp.asc');
2600 my @r = map { $mktag->($_); } @$tagwants;
2604 sub sign_changes ($) {
2605 my ($changesfile) = @_;
2607 my @debsign_cmd = @debsign;
2608 push @debsign_cmd, "-k$keyid" if defined $keyid;
2609 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2610 push @debsign_cmd, $changesfile;
2611 runcmd_ordryrun @debsign_cmd;
2616 printdebug "actually entering push\n";
2618 supplementary_message(<<'END');
2619 Push failed, while checking state of the archive.
2620 You can retry the push, after fixing the problem, if you like.
2622 if (check_for_git()) {
2625 my $archive_hash = fetch_from_archive();
2626 if (!$archive_hash) {
2628 fail "package appears to be new in this suite;".
2629 " if this is intentional, use --new";
2632 supplementary_message(<<'END');
2633 Push failed, while preparing your push.
2634 You can retry the push, after fixing the problem, if you like.
2637 need_tagformat 'new', "quilt mode $quilt_mode"
2638 if quiltmode_splitbrain;
2642 access_giturl(); # check that success is vaguely likely
2645 my $clogpfn = ".git/dgit/changelog.822.tmp";
2646 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2648 responder_send_file('parsed-changelog', $clogpfn);
2650 my ($clogp, $cversion, $dscfn) =
2651 push_parse_changelog("$clogpfn");
2653 my $dscpath = "$buildproductsdir/$dscfn";
2654 stat_exists $dscpath or
2655 fail "looked for .dsc $dscfn, but $!;".
2656 " maybe you forgot to build";
2658 responder_send_file('dsc', $dscpath);
2660 push_parse_dsc($dscpath, $dscfn, $cversion);
2662 my $format = getfield $dsc, 'Format';
2663 printdebug "format $format\n";
2665 my $actualhead = git_rev_parse('HEAD');
2666 my $dgithead = $actualhead;
2667 my $maintviewhead = undef;
2669 if (madformat($format)) {
2670 # user might have not used dgit build, so maybe do this now:
2671 if (quiltmode_splitbrain()) {
2672 my $upstreamversion = $clogp->{Version};
2673 $upstreamversion =~ s/-[^-]*$//;
2675 quilt_make_fake_dsc($upstreamversion);
2676 my ($dgitview, $cachekey) =
2677 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2679 "--quilt=$quilt_mode but no cached dgit view:
2680 perhaps tree changed since dgit build[-source] ?";
2682 $dgithead = splitbrain_pseudomerge($clogp,
2683 $actualhead, $dgitview,
2685 $maintviewhead = $actualhead;
2686 changedir '../../../..';
2687 prep_ud(); # so _only_subdir() works, below
2689 commit_quilty_patch();
2696 if ($archive_hash) {
2697 if (is_fast_fwd($archive_hash, $dgithead)) {
2699 } elsif (deliberately_not_fast_forward) {
2702 fail "dgit push: HEAD is not a descendant".
2703 " of the archive's version.\n".
2704 "dgit: To overwrite its contents,".
2705 " use git merge -s ours ".lrref().".\n".
2706 "dgit: To rewind history, if permitted by the archive,".
2707 " use --deliberately-not-fast-forward";
2712 progress "checking that $dscfn corresponds to HEAD";
2713 runcmd qw(dpkg-source -x --),
2714 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2715 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2716 check_for_vendor_patches() if madformat($dsc->{format});
2717 changedir '../../../..';
2718 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2719 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2720 debugcmd "+",@diffcmd;
2722 my $r = system @diffcmd;
2725 fail "$dscfn specifies a different tree to your HEAD commit;".
2726 " perhaps you forgot to build".
2727 ($diffopt eq '--exit-code' ? "" :
2728 " (run with -D to see full diff output)");
2733 if (!$changesfile) {
2734 my $pat = changespat $cversion;
2735 my @cs = glob "$buildproductsdir/$pat";
2736 fail "failed to find unique changes file".
2737 " (looked for $pat in $buildproductsdir);".
2738 " perhaps you need to use dgit -C"
2740 ($changesfile) = @cs;
2742 $changesfile = "$buildproductsdir/$changesfile";
2745 # Checks complete, we're going to try and go ahead:
2747 responder_send_file('changes',$changesfile);
2748 responder_send_command("param head $dgithead");
2749 responder_send_command("param csuite $csuite");
2750 responder_send_command("param tagformat $tagformat");
2751 if (quiltmode_splitbrain) {
2752 die unless ($protovsn//4) >= 4;
2753 responder_send_command("param maint-view $maintviewhead");
2756 if (deliberately_not_fast_forward) {
2757 git_for_each_ref(lrfetchrefs, sub {
2758 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2759 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2760 responder_send_command("previously $rrefname=$objid");
2761 $previously{$rrefname} = $objid;
2765 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2769 supplementary_message(<<'END');
2770 Push failed, while signing the tag.
2771 You can retry the push, after fixing the problem, if you like.
2773 # If we manage to sign but fail to record it anywhere, it's fine.
2774 if ($we_are_responder) {
2775 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2776 responder_receive_files('signed-tag', @tagobjfns);
2778 @tagobjfns = push_mktags($clogp,$dscpath,
2779 $changesfile,$changesfile,
2782 supplementary_message(<<'END');
2783 Push failed, *after* signing the tag.
2784 If you want to try again, you should use a new version number.
2787 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2789 foreach my $tw (@tagwants) {
2790 my $tag = $tw->{Tag};
2791 my $tagobjfn = $tw->{TagObjFn};
2793 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2794 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2795 runcmd_ordryrun_local
2796 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2799 supplementary_message(<<'END');
2800 Push failed, while updating the remote git repository - see messages above.
2801 If you want to try again, you should use a new version number.
2803 if (!check_for_git()) {
2804 create_remote_git_repo();
2807 my @pushrefs = $forceflag.$dgithead.":".rrref();
2808 foreach my $tw (@tagwants) {
2809 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2812 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2813 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2815 supplementary_message(<<'END');
2816 Push failed, after updating the remote git repository.
2817 If you want to try again, you must use a new version number.
2819 if ($we_are_responder) {
2820 my $dryrunsuffix = act_local() ? "" : ".tmp";
2821 responder_receive_files('signed-dsc-changes',
2822 "$dscpath$dryrunsuffix",
2823 "$changesfile$dryrunsuffix");
2826 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2828 progress "[new .dsc left in $dscpath.tmp]";
2830 sign_changes $changesfile;
2833 supplementary_message(<<END);
2834 Push failed, while uploading package(s) to the archive server.
2835 You can retry the upload of exactly these same files with dput of:
2837 If that .changes file is broken, you will need to use a new version
2838 number for your next attempt at the upload.
2840 my $host = access_cfg('upload-host','RETURN-UNDEF');
2841 my @hostarg = defined($host) ? ($host,) : ();
2842 runcmd_ordryrun @dput, @hostarg, $changesfile;
2843 printdone "pushed and uploaded $cversion";
2845 supplementary_message('');
2846 responder_send_command("complete");
2853 badusage "-p is not allowed with clone; specify as argument instead"
2854 if defined $package;
2857 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2858 ($package,$isuite) = @ARGV;
2859 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2860 ($package,$dstdir) = @ARGV;
2861 } elsif (@ARGV==3) {
2862 ($package,$isuite,$dstdir) = @ARGV;
2864 badusage "incorrect arguments to dgit clone";
2866 $dstdir ||= "$package";
2868 if (stat_exists $dstdir) {
2869 fail "$dstdir already exists";
2873 if ($rmonerror && !$dryrun_level) {
2874 $cwd_remove= getcwd();
2876 return unless defined $cwd_remove;
2877 if (!chdir "$cwd_remove") {
2878 return if $!==&ENOENT;
2879 die "chdir $cwd_remove: $!";
2882 rmtree($dstdir) or die "remove $dstdir: $!\n";
2883 } elsif (!grep { $! == $_ }
2884 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2886 print STDERR "check whether to remove $dstdir: $!\n";
2892 $cwd_remove = undef;
2895 sub branchsuite () {
2896 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2897 if ($branch =~ m#$lbranch_re#o) {
2904 sub fetchpullargs () {
2906 if (!defined $package) {
2907 my $sourcep = parsecontrol('debian/control','debian/control');
2908 $package = getfield $sourcep, 'Source';
2911 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2913 my $clogp = parsechangelog();
2914 $isuite = getfield $clogp, 'Distribution';
2916 canonicalise_suite();
2917 progress "fetching from suite $csuite";
2918 } elsif (@ARGV==1) {
2920 canonicalise_suite();
2922 badusage "incorrect arguments to dgit fetch or dgit pull";
2941 badusage "-p is not allowed with dgit push" if defined $package;
2943 my $clogp = parsechangelog();
2944 $package = getfield $clogp, 'Source';
2947 } elsif (@ARGV==1) {
2948 ($specsuite) = (@ARGV);
2950 badusage "incorrect arguments to dgit push";
2952 $isuite = getfield $clogp, 'Distribution';
2954 local ($package) = $existing_package; # this is a hack
2955 canonicalise_suite();
2957 canonicalise_suite();
2959 if (defined $specsuite &&
2960 $specsuite ne $isuite &&
2961 $specsuite ne $csuite) {
2962 fail "dgit push: changelog specifies $isuite ($csuite)".
2963 " but command line specifies $specsuite";
2968 #---------- remote commands' implementation ----------
2970 sub cmd_remote_push_build_host {
2971 my ($nrargs) = shift @ARGV;
2972 my (@rargs) = @ARGV[0..$nrargs-1];
2973 @ARGV = @ARGV[$nrargs..$#ARGV];
2975 my ($dir,$vsnwant) = @rargs;
2976 # vsnwant is a comma-separated list; we report which we have
2977 # chosen in our ready response (so other end can tell if they
2980 $we_are_responder = 1;
2981 $us .= " (build host)";
2985 open PI, "<&STDIN" or die $!;
2986 open STDIN, "/dev/null" or die $!;
2987 open PO, ">&STDOUT" or die $!;
2989 open STDOUT, ">&STDERR" or die $!;
2993 ($protovsn) = grep {
2994 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2995 } @rpushprotovsn_support;
2997 fail "build host has dgit rpush protocol versions ".
2998 (join ",", @rpushprotovsn_support).
2999 " but invocation host has $vsnwant"
3000 unless defined $protovsn;
3002 responder_send_command("dgit-remote-push-ready $protovsn");
3003 rpush_handle_protovsn_bothends();
3008 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3009 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3010 # a good error message)
3012 sub rpush_handle_protovsn_bothends () {
3013 if ($protovsn < 4) {
3014 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3023 my $report = i_child_report();
3024 if (defined $report) {
3025 printdebug "($report)\n";
3026 } elsif ($i_child_pid) {
3027 printdebug "(killing build host child $i_child_pid)\n";
3028 kill 15, $i_child_pid;
3030 if (defined $i_tmp && !defined $initiator_tempdir) {
3032 eval { rmtree $i_tmp; };
3036 END { i_cleanup(); }
3039 my ($base,$selector,@args) = @_;
3040 $selector =~ s/\-/_/g;
3041 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3048 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3056 push @rargs, join ",", @rpushprotovsn_support;
3059 push @rdgit, @ropts;
3060 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3062 my @cmd = (@ssh, $host, shellquote @rdgit);
3065 if (defined $initiator_tempdir) {
3066 rmtree $initiator_tempdir;
3067 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3068 $i_tmp = $initiator_tempdir;
3072 $i_child_pid = open2(\*RO, \*RI, @cmd);
3074 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3075 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3076 $supplementary_message = '' unless $protovsn >= 3;
3078 fail "rpush negotiated protocol version $protovsn".
3079 " which does not support quilt mode $quilt_mode"
3080 if quiltmode_splitbrain;
3082 rpush_handle_protovsn_bothends();
3084 my ($icmd,$iargs) = initiator_expect {
3085 m/^(\S+)(?: (.*))?$/;
3088 i_method "i_resp", $icmd, $iargs;
3092 sub i_resp_progress ($) {
3094 my $msg = protocol_read_bytes \*RO, $rhs;
3098 sub i_resp_supplementary_message ($) {
3100 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3103 sub i_resp_complete {
3104 my $pid = $i_child_pid;
3105 $i_child_pid = undef; # prevents killing some other process with same pid
3106 printdebug "waiting for build host child $pid...\n";
3107 my $got = waitpid $pid, 0;
3108 die $! unless $got == $pid;
3109 die "build host child failed $?" if $?;
3112 printdebug "all done\n";
3116 sub i_resp_file ($) {
3118 my $localname = i_method "i_localname", $keyword;
3119 my $localpath = "$i_tmp/$localname";
3120 stat_exists $localpath and
3121 badproto \*RO, "file $keyword ($localpath) twice";
3122 protocol_receive_file \*RO, $localpath;
3123 i_method "i_file", $keyword;
3128 sub i_resp_param ($) {
3129 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3133 sub i_resp_previously ($) {
3134 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3135 or badproto \*RO, "bad previously spec";
3136 my $r = system qw(git check-ref-format), $1;
3137 die "bad previously ref spec ($r)" if $r;
3138 $previously{$1} = $2;
3143 sub i_resp_want ($) {
3145 die "$keyword ?" if $i_wanted{$keyword}++;
3146 my @localpaths = i_method "i_want", $keyword;
3147 printdebug "[[ $keyword @localpaths\n";
3148 foreach my $localpath (@localpaths) {
3149 protocol_send_file \*RI, $localpath;
3151 print RI "files-end\n" or die $!;
3154 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3156 sub i_localname_parsed_changelog {
3157 return "remote-changelog.822";
3159 sub i_file_parsed_changelog {
3160 ($i_clogp, $i_version, $i_dscfn) =
3161 push_parse_changelog "$i_tmp/remote-changelog.822";
3162 die if $i_dscfn =~ m#/|^\W#;
3165 sub i_localname_dsc {
3166 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3171 sub i_localname_changes {
3172 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3173 $i_changesfn = $i_dscfn;
3174 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3175 return $i_changesfn;
3177 sub i_file_changes { }
3179 sub i_want_signed_tag {
3180 printdebug Dumper(\%i_param, $i_dscfn);
3181 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3182 && defined $i_param{'csuite'}
3183 or badproto \*RO, "premature desire for signed-tag";
3184 my $head = $i_param{'head'};
3185 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3187 my $maintview = $i_param{'maint-view'};
3188 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3191 if ($protovsn >= 4) {
3192 my $p = $i_param{'tagformat'} // '<undef>';
3194 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3197 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3199 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3201 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3204 push_mktags $i_clogp, $i_dscfn,
3205 $i_changesfn, 'remote changes',
3209 sub i_want_signed_dsc_changes {
3210 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3211 sign_changes $i_changesfn;
3212 return ($i_dscfn, $i_changesfn);
3215 #---------- building etc. ----------
3221 #----- `3.0 (quilt)' handling -----
3223 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3225 sub quiltify_dpkg_commit ($$$;$) {
3226 my ($patchname,$author,$msg, $xinfo) = @_;
3230 my $descfn = ".git/dgit/quilt-description.tmp";
3231 open O, '>', $descfn or die "$descfn: $!";
3234 $msg =~ s/^\s+$/ ./mg;
3235 print O <<END or die $!;
3245 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3246 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3247 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3248 runcmd @dpkgsource, qw(--commit .), $patchname;
3252 sub quiltify_trees_differ ($$;$$) {
3253 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3254 # returns true iff the two tree objects differ other than in debian/
3255 # with $finegrained,
3256 # returns bitmask 01 - differ in upstream files except .gitignore
3257 # 02 - differ in .gitignore
3258 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3259 # is set for each modified .gitignore filename $fn
3261 my @cmd = (@git, qw(diff-tree --name-only -z));
3262 push @cmd, qw(-r) if $finegrained;
3264 my $diffs= cmdoutput @cmd;
3266 foreach my $f (split /\0/, $diffs) {
3267 next if $f =~ m#^debian(?:/.*)?$#s;
3268 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3269 $r |= $isignore ? 02 : 01;
3270 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3272 printdebug "quiltify_trees_differ $x $y => $r\n";
3276 sub quiltify_tree_sentinelfiles ($) {
3277 # lists the `sentinel' files present in the tree
3279 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3280 qw(-- debian/rules debian/control);
3285 sub quiltify_splitbrain_needed () {
3286 if (!$split_brain) {
3287 progress "dgit view: changes are required...";
3288 runcmd @git, qw(checkout -q -b dgit-view);
3293 sub quiltify_splitbrain ($$$$$$) {
3294 my ($clogp, $unapplied, $headref, $diffbits,
3295 $editedignores, $cachekey) = @_;
3296 if ($quilt_mode !~ m/gbp|dpm/) {
3297 # treat .gitignore just like any other upstream file
3298 $diffbits = { %$diffbits };
3299 $_ = !!$_ foreach values %$diffbits;
3301 # We would like any commits we generate to be reproducible
3302 my @authline = clogp_authline($clogp);
3303 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3304 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3305 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3307 if ($quilt_mode =~ m/gbp|unapplied/ &&
3308 ($diffbits->{H2O} & 01)) {
3310 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3311 " but git tree differs from orig in upstream files.";
3312 if (!stat_exists "debian/patches") {
3314 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3318 if ($quilt_mode =~ m/gbp|unapplied/ &&
3319 ($diffbits->{O2A} & 01)) { # some patches
3320 quiltify_splitbrain_needed();
3321 progress "dgit view: creating patches-applied version using gbp pq";
3322 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3323 # gbp pq import creates a fresh branch; push back to dgit-view
3324 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3325 runcmd @git, qw(checkout -q dgit-view);
3327 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3328 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3329 quiltify_splitbrain_needed();
3330 progress "dgit view: creating patch to represent .gitignore changes";
3331 ensuredir "debian/patches";
3332 my $gipatch = "debian/patches/auto-gitignore";
3333 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3334 stat GIPATCH or die "$gipatch: $!";
3335 fail "$gipatch already exists; but want to create it".
3336 " to record .gitignore changes" if (stat _)[7];
3337 print GIPATCH <<END or die "$gipatch: $!";
3338 Subject: Update .gitignore from Debian packaging branch
3340 The Debian packaging git branch contains these updates to the upstream
3341 .gitignore file(s). This patch is autogenerated, to provide these
3342 updates to users of the official Debian archive view of the package.
3344 [dgit version $our_version]
3347 close GIPATCH or die "$gipatch: $!";
3348 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3349 $unapplied, $headref, "--", sort keys %$editedignores;
3350 open SERIES, "+>>", "debian/patches/series" or die $!;
3351 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3353 defined read SERIES, $newline, 1 or die $!;
3354 print SERIES "\n" or die $! unless $newline eq "\n";
3355 print SERIES "auto-gitignore\n" or die $!;
3356 close SERIES or die $!;
3357 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3358 commit_admin "Commit patch to update .gitignore";
3361 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3363 changedir '../../../..';
3364 ensuredir ".git/logs/refs/dgit-intern";
3365 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3367 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3370 progress "dgit view: created (commit id $dgitview)";
3372 changedir '.git/dgit/unpack/work';
3375 sub quiltify ($$$$) {
3376 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3378 # Quilt patchification algorithm
3380 # We search backwards through the history of the main tree's HEAD
3381 # (T) looking for a start commit S whose tree object is identical
3382 # to to the patch tip tree (ie the tree corresponding to the
3383 # current dpkg-committed patch series). For these purposes
3384 # `identical' disregards anything in debian/ - this wrinkle is
3385 # necessary because dpkg-source treates debian/ specially.
3387 # We can only traverse edges where at most one of the ancestors'
3388 # trees differs (in changes outside in debian/). And we cannot
3389 # handle edges which change .pc/ or debian/patches. To avoid
3390 # going down a rathole we avoid traversing edges which introduce
3391 # debian/rules or debian/control. And we set a limit on the
3392 # number of edges we are willing to look at.
3394 # If we succeed, we walk forwards again. For each traversed edge
3395 # PC (with P parent, C child) (starting with P=S and ending with
3396 # C=T) to we do this:
3398 # - dpkg-source --commit with a patch name and message derived from C
3399 # After traversing PT, we git commit the changes which
3400 # should be contained within debian/patches.
3402 # The search for the path S..T is breadth-first. We maintain a
3403 # todo list containing search nodes. A search node identifies a
3404 # commit, and looks something like this:
3406 # Commit => $git_commit_id,
3407 # Child => $c, # or undef if P=T
3408 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3409 # Nontrivial => true iff $p..$c has relevant changes
3416 my %considered; # saves being exponential on some weird graphs
3418 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3421 my ($search,$whynot) = @_;
3422 printdebug " search NOT $search->{Commit} $whynot\n";
3423 $search->{Whynot} = $whynot;
3424 push @nots, $search;
3425 no warnings qw(exiting);
3434 my $c = shift @todo;
3435 next if $considered{$c->{Commit}}++;
3437 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3439 printdebug "quiltify investigate $c->{Commit}\n";
3442 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3443 printdebug " search finished hooray!\n";
3448 if ($quilt_mode eq 'nofix') {
3449 fail "quilt fixup required but quilt mode is \`nofix'\n".
3450 "HEAD commit $c->{Commit} differs from tree implied by ".
3451 " debian/patches (tree object $oldtiptree)";
3453 if ($quilt_mode eq 'smash') {
3454 printdebug " search quitting smash\n";
3458 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3459 $not->($c, "has $c_sentinels not $t_sentinels")
3460 if $c_sentinels ne $t_sentinels;
3462 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3463 $commitdata =~ m/\n\n/;
3465 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3466 @parents = map { { Commit => $_, Child => $c } } @parents;
3468 $not->($c, "root commit") if !@parents;
3470 foreach my $p (@parents) {
3471 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3473 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3474 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3476 foreach my $p (@parents) {
3477 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3479 my @cmd= (@git, qw(diff-tree -r --name-only),
3480 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3481 my $patchstackchange = cmdoutput @cmd;
3482 if (length $patchstackchange) {
3483 $patchstackchange =~ s/\n/,/g;
3484 $not->($p, "changed $patchstackchange");
3487 printdebug " search queue P=$p->{Commit} ",
3488 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3494 printdebug "quiltify want to smash\n";
3497 my $x = $_[0]{Commit};
3498 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3501 my $reportnot = sub {
3503 my $s = $abbrev->($notp);
3504 my $c = $notp->{Child};
3505 $s .= "..".$abbrev->($c) if $c;
3506 $s .= ": ".$notp->{Whynot};
3509 if ($quilt_mode eq 'linear') {
3510 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3511 foreach my $notp (@nots) {
3512 print STDERR "$us: ", $reportnot->($notp), "\n";
3514 print STDERR "$us: $_\n" foreach @$failsuggestion;
3515 fail "quilt fixup naive history linearisation failed.\n".
3516 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3517 } elsif ($quilt_mode eq 'smash') {
3518 } elsif ($quilt_mode eq 'auto') {
3519 progress "quilt fixup cannot be linear, smashing...";
3521 die "$quilt_mode ?";
3524 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3525 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3527 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3529 quiltify_dpkg_commit "auto-$version-$target-$time",
3530 (getfield $clogp, 'Maintainer'),
3531 "Automatically generated patch ($clogp->{Version})\n".
3532 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3536 progress "quiltify linearisation planning successful, executing...";
3538 for (my $p = $sref_S;
3539 my $c = $p->{Child};
3541 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3542 next unless $p->{Nontrivial};
3544 my $cc = $c->{Commit};
3546 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3547 $commitdata =~ m/\n\n/ or die "$c ?";
3550 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3553 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3556 my $patchname = $title;
3557 $patchname =~ s/[.:]$//;
3558 $patchname =~ y/ A-Z/-a-z/;
3559 $patchname =~ y/-a-z0-9_.+=~//cd;
3560 $patchname =~ s/^\W/x-$&/;
3561 $patchname = substr($patchname,0,40);
3564 stat "debian/patches/$patchname$index";
3566 $!==ENOENT or die "$patchname$index $!";
3568 runcmd @git, qw(checkout -q), $cc;
3570 # We use the tip's changelog so that dpkg-source doesn't
3571 # produce complaining messages from dpkg-parsechangelog. None
3572 # of the information dpkg-source gets from the changelog is
3573 # actually relevant - it gets put into the original message
3574 # which dpkg-source provides our stunt editor, and then
3576 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3578 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3579 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3581 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3584 runcmd @git, qw(checkout -q master);
3587 sub build_maybe_quilt_fixup () {
3588 my ($format,$fopts) = get_source_format;
3589 return unless madformat $format;
3592 check_for_vendor_patches();
3594 my $clogp = parsechangelog();
3595 my $headref = git_rev_parse('HEAD');
3600 my $upstreamversion=$version;
3601 $upstreamversion =~ s/-[^-]*$//;
3603 if ($fopts->{'single-debian-patch'}) {
3604 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3606 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3609 die 'bug' if $split_brain && !$need_split_build_invocation;
3611 changedir '../../../..';
3612 runcmd_ordryrun_local
3613 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3616 sub quilt_fixup_mkwork ($) {
3619 mkdir "work" or die $!;
3621 mktree_in_ud_here();
3622 runcmd @git, qw(reset -q --hard), $headref;
3625 sub quilt_fixup_linkorigs ($$) {
3626 my ($upstreamversion, $fn) = @_;
3627 # calls $fn->($leafname);
3629 foreach my $f (<../../../../*>) { #/){
3630 my $b=$f; $b =~ s{.*/}{};
3632 local ($debuglevel) = $debuglevel-1;
3633 printdebug "QF linkorigs $b, $f ?\n";
3635 next unless is_orig_file $b, srcfn $upstreamversion,'';
3636 printdebug "QF linkorigs $b, $f Y\n";
3637 link_ltarget $f, $b or die "$b $!";
3642 sub quilt_fixup_delete_pc () {
3643 runcmd @git, qw(rm -rqf .pc);
3644 commit_admin "Commit removal of .pc (quilt series tracking data)";
3647 sub quilt_fixup_singlepatch ($$$) {
3648 my ($clogp, $headref, $upstreamversion) = @_;
3650 progress "starting quiltify (single-debian-patch)";
3652 # dpkg-source --commit generates new patches even if
3653 # single-debian-patch is in debian/source/options. In order to
3654 # get it to generate debian/patches/debian-changes, it is
3655 # necessary to build the source package.
3657 quilt_fixup_linkorigs($upstreamversion, sub { });
3658 quilt_fixup_mkwork($headref);
3660 rmtree("debian/patches");
3662 runcmd @dpkgsource, qw(-b .);
3664 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3665 rename srcfn("$upstreamversion", "/debian/patches"),
3666 "work/debian/patches";
3669 commit_quilty_patch();
3672 sub quilt_make_fake_dsc ($) {
3673 my ($upstreamversion) = @_;
3675 my $fakeversion="$upstreamversion-~~DGITFAKE";
3677 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3678 print $fakedsc <<END or die $!;
3681 Version: $fakeversion
3685 my $dscaddfile=sub {
3688 my $md = new Digest::MD5;
3690 my $fh = new IO::File $b, '<' or die "$b $!";
3695 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3698 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3700 my @files=qw(debian/source/format debian/rules
3701 debian/control debian/changelog);
3702 foreach my $maybe (qw(debian/patches debian/source/options
3703 debian/tests/control)) {
3704 next unless stat_exists "../../../$maybe";
3705 push @files, $maybe;
3708 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3709 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3711 $dscaddfile->($debtar);
3712 close $fakedsc or die $!;
3715 sub quilt_check_splitbrain_cache ($$) {
3716 my ($headref, $upstreamversion) = @_;
3717 # Called only if we are in (potentially) split brain mode.
3719 # Computes the cache key and looks in the cache.
3720 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3722 my $splitbrain_cachekey;
3725 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3726 # we look in the reflog of dgit-intern/quilt-cache
3727 # we look for an entry whose message is the key for the cache lookup
3728 my @cachekey = (qw(dgit), $our_version);
3729 push @cachekey, $upstreamversion;
3730 push @cachekey, $quilt_mode;
3731 push @cachekey, $headref;
3733 push @cachekey, hashfile('fake.dsc');
3735 my $srcshash = Digest::SHA->new(256);
3736 my %sfs = ( %INC, '$0(dgit)' => $0 );
3737 foreach my $sfk (sort keys %sfs) {
3738 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3739 $srcshash->add($sfk," ");
3740 $srcshash->add(hashfile($sfs{$sfk}));
3741 $srcshash->add("\n");
3743 push @cachekey, $srcshash->hexdigest();
3744 $splitbrain_cachekey = "@cachekey";
3746 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3748 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3749 debugcmd "|(probably)",@cmd;
3750 my $child = open GC, "-|"; defined $child or die $!;
3752 chdir '../../..' or die $!;
3753 if (!stat ".git/logs/refs/$splitbraincache") {
3754 $! == ENOENT or die $!;
3755 printdebug ">(no reflog)\n";
3762 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3763 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3766 quilt_fixup_mkwork($headref);
3767 if ($cachehit ne $headref) {
3768 progress "dgit view: found cached (commit id $cachehit)";
3769 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3771 return ($cachehit, $splitbrain_cachekey);
3773 progress "dgit view: found cached, no changes required";
3774 return ($headref, $splitbrain_cachekey);
3776 die $! if GC->error;
3777 failedcmd unless close GC;
3779 printdebug "splitbrain cache miss\n";
3780 return (undef, $splitbrain_cachekey);
3783 sub quilt_fixup_multipatch ($$$) {
3784 my ($clogp, $headref, $upstreamversion) = @_;
3786 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3789 # - honour any existing .pc in case it has any strangeness
3790 # - determine the git commit corresponding to the tip of
3791 # the patch stack (if there is one)
3792 # - if there is such a git commit, convert each subsequent
3793 # git commit into a quilt patch with dpkg-source --commit
3794 # - otherwise convert all the differences in the tree into
3795 # a single git commit
3799 # Our git tree doesn't necessarily contain .pc. (Some versions of
3800 # dgit would include the .pc in the git tree.) If there isn't
3801 # one, we need to generate one by unpacking the patches that we
3804 # We first look for a .pc in the git tree. If there is one, we
3805 # will use it. (This is not the normal case.)
3807 # Otherwise need to regenerate .pc so that dpkg-source --commit
3808 # can work. We do this as follows:
3809 # 1. Collect all relevant .orig from parent directory
3810 # 2. Generate a debian.tar.gz out of
3811 # debian/{patches,rules,source/format,source/options}
3812 # 3. Generate a fake .dsc containing just these fields:
3813 # Format Source Version Files
3814 # 4. Extract the fake .dsc
3815 # Now the fake .dsc has a .pc directory.
3816 # (In fact we do this in every case, because in future we will
3817 # want to search for a good base commit for generating patches.)
3819 # Then we can actually do the dpkg-source --commit
3820 # 1. Make a new working tree with the same object
3821 # store as our main tree and check out the main
3823 # 2. Copy .pc from the fake's extraction, if necessary
3824 # 3. Run dpkg-source --commit
3825 # 4. If the result has changes to debian/, then
3826 # - git-add them them
3827 # - git-add .pc if we had a .pc in-tree
3829 # 5. If we had a .pc in-tree, delete it, and git-commit
3830 # 6. Back in the main tree, fast forward to the new HEAD
3832 # Another situation we may have to cope with is gbp-style
3833 # patches-unapplied trees.
3835 # We would want to detect these, so we know to escape into
3836 # quilt_fixup_gbp. However, this is in general not possible.
3837 # Consider a package with a one patch which the dgit user reverts
3838 # (with git-revert or the moral equivalent).
3840 # That is indistinguishable in contents from a patches-unapplied
3841 # tree. And looking at the history to distinguish them is not
3842 # useful because the user might have made a confusing-looking git
3843 # history structure (which ought to produce an error if dgit can't
3844 # cope, not a silent reintroduction of an unwanted patch).
3846 # So gbp users will have to pass an option. But we can usually
3847 # detect their failure to do so: if the tree is not a clean
3848 # patches-applied tree, quilt linearisation fails, but the tree
3849 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3850 # they want --quilt=unapplied.
3852 # To help detect this, when we are extracting the fake dsc, we
3853 # first extract it with --skip-patches, and then apply the patches
3854 # afterwards with dpkg-source --before-build. That lets us save a
3855 # tree object corresponding to .origs.
3857 my $splitbrain_cachekey;
3859 quilt_make_fake_dsc($upstreamversion);
3861 if (quiltmode_splitbrain()) {
3863 ($cachehit, $splitbrain_cachekey) =
3864 quilt_check_splitbrain_cache($headref, $upstreamversion);
3865 return if $cachehit;
3869 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3871 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3872 rename $fakexdir, "fake" or die "$fakexdir $!";
3876 remove_stray_gits();
3877 mktree_in_ud_here();
3881 runcmd @git, qw(add -Af .);
3882 my $unapplied=git_write_tree();
3883 printdebug "fake orig tree object $unapplied\n";
3888 'exec dpkg-source --before-build . >/dev/null';
3892 quilt_fixup_mkwork($headref);
3895 if (stat_exists ".pc") {
3897 progress "Tree already contains .pc - will use it then delete it.";
3900 rename '../fake/.pc','.pc' or die $!;
3903 changedir '../fake';
3905 runcmd @git, qw(add -Af .);
3906 my $oldtiptree=git_write_tree();
3907 printdebug "fake o+d/p tree object $unapplied\n";
3908 changedir '../work';
3911 # We calculate some guesswork now about what kind of tree this might
3912 # be. This is mostly for error reporting.
3917 # O = orig, without patches applied
3918 # A = "applied", ie orig with H's debian/patches applied
3919 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3920 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3921 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3925 foreach my $b (qw(01 02)) {
3926 foreach my $v (qw(H2O O2A H2A)) {
3927 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3930 printdebug "differences \@dl @dl.\n";
3933 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3934 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3935 $dl[0], $dl[1], $dl[3], $dl[4],
3939 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3940 push @failsuggestion, "This might be a patches-unapplied branch.";
3941 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3942 push @failsuggestion, "This might be a patches-applied branch.";
3944 push @failsuggestion, "Maybe you need to specify one of".
3945 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3947 if (quiltmode_splitbrain()) {
3948 quiltify_splitbrain($clogp, $unapplied, $headref,
3949 $diffbits, \%editedignores,
3950 $splitbrain_cachekey);
3954 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3955 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3957 if (!open P, '>>', ".pc/applied-patches") {
3958 $!==&ENOENT or die $!;
3963 commit_quilty_patch();
3965 if ($mustdeletepc) {
3966 quilt_fixup_delete_pc();
3970 sub quilt_fixup_editor () {
3971 my $descfn = $ENV{$fakeeditorenv};
3972 my $editing = $ARGV[$#ARGV];
3973 open I1, '<', $descfn or die "$descfn: $!";
3974 open I2, '<', $editing or die "$editing: $!";
3975 unlink $editing or die "$editing: $!";
3976 open O, '>', $editing or die "$editing: $!";
3977 while (<I1>) { print O or die $!; } I1->error and die $!;
3980 $copying ||= m/^\-\-\- /;
3981 next unless $copying;
3984 I2->error and die $!;
3989 sub maybe_apply_patches_dirtily () {
3990 return unless $quilt_mode =~ m/gbp|unapplied/;
3991 print STDERR <<END or die $!;
3993 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3994 dgit: Have to apply the patches - making the tree dirty.
3995 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3998 $patches_applied_dirtily = 01;
3999 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4000 runcmd qw(dpkg-source --before-build .);
4003 sub maybe_unapply_patches_again () {
4004 progress "dgit: Unapplying patches again to tidy up the tree."
4005 if $patches_applied_dirtily;
4006 runcmd qw(dpkg-source --after-build .)
4007 if $patches_applied_dirtily & 01;
4009 if $patches_applied_dirtily & 02;
4010 $patches_applied_dirtily = 0;
4013 #----- other building -----
4015 our $clean_using_builder;
4016 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4017 # clean the tree before building (perhaps invoked indirectly by
4018 # whatever we are using to run the build), rather than separately
4019 # and explicitly by us.
4022 return if $clean_using_builder;
4023 if ($cleanmode eq 'dpkg-source') {
4024 maybe_apply_patches_dirtily();
4025 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4026 } elsif ($cleanmode eq 'dpkg-source-d') {
4027 maybe_apply_patches_dirtily();
4028 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4029 } elsif ($cleanmode eq 'git') {
4030 runcmd_ordryrun_local @git, qw(clean -xdf);
4031 } elsif ($cleanmode eq 'git-ff') {
4032 runcmd_ordryrun_local @git, qw(clean -xdff);
4033 } elsif ($cleanmode eq 'check') {
4034 my $leftovers = cmdoutput @git, qw(clean -xdn);
4035 if (length $leftovers) {
4036 print STDERR $leftovers, "\n" or die $!;
4037 fail "tree contains uncommitted files and --clean=check specified";
4039 } elsif ($cleanmode eq 'none') {
4046 badusage "clean takes no additional arguments" if @ARGV;
4049 maybe_unapply_patches_again();
4054 badusage "-p is not allowed when building" if defined $package;
4057 my $clogp = parsechangelog();
4058 $isuite = getfield $clogp, 'Distribution';
4059 $package = getfield $clogp, 'Source';
4060 $version = getfield $clogp, 'Version';
4061 build_maybe_quilt_fixup();
4063 my $pat = changespat $version;
4064 foreach my $f (glob "$buildproductsdir/$pat") {
4066 unlink $f or fail "remove old changes file $f: $!";
4068 progress "would remove $f";
4074 sub changesopts_initial () {
4075 my @opts =@changesopts[1..$#changesopts];
4078 sub changesopts_version () {
4079 if (!defined $changes_since_version) {
4080 my @vsns = archive_query('archive_query');
4081 my @quirk = access_quirk();
4082 if ($quirk[0] eq 'backports') {
4083 local $isuite = $quirk[2];
4085 canonicalise_suite();
4086 push @vsns, archive_query('archive_query');
4089 @vsns = map { $_->[0] } @vsns;
4090 @vsns = sort { -version_compare($a, $b) } @vsns;
4091 $changes_since_version = $vsns[0];
4092 progress "changelog will contain changes since $vsns[0]";
4094 $changes_since_version = '_';
4095 progress "package seems new, not specifying -v<version>";
4098 if ($changes_since_version ne '_') {
4099 return ("-v$changes_since_version");
4105 sub changesopts () {
4106 return (changesopts_initial(), changesopts_version());
4109 sub massage_dbp_args ($;$) {
4110 my ($cmd,$xargs) = @_;
4113 # - if we're going to split the source build out so we can
4114 # do strange things to it, massage the arguments to dpkg-buildpackage
4115 # so that the main build doessn't build source (or add an argument
4116 # to stop it building source by default).
4118 # - add -nc to stop dpkg-source cleaning the source tree,
4119 # unless we're not doing a split build and want dpkg-source
4120 # as cleanmode, in which case we can do nothing
4123 # 0 - source will NOT need to be built separately by caller
4124 # +1 - source will need to be built separately by caller
4125 # +2 - source will need to be built separately by caller AND
4126 # dpkg-buildpackage should not in fact be run at all!
4127 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4128 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4129 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4130 $clean_using_builder = 1;
4133 # -nc has the side effect of specifying -b if nothing else specified
4134 # and some combinations of -S, -b, et al, are errors, rather than
4135 # later simply overriding earlie. So we need to:
4136 # - search the command line for these options
4137 # - pick the last one
4138 # - perhaps add our own as a default
4139 # - perhaps adjust it to the corresponding non-source-building version
4141 foreach my $l ($cmd, $xargs) {
4143 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4146 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4148 if ($need_split_build_invocation) {
4149 printdebug "massage split $dmode.\n";
4150 $r = $dmode =~ m/[S]/ ? +2 :
4151 $dmode =~ y/gGF/ABb/ ? +1 :
4152 $dmode =~ m/[ABb]/ ? 0 :
4155 printdebug "massage done $r $dmode.\n";
4157 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4162 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4163 my $wantsrc = massage_dbp_args \@dbp;
4170 push @dbp, changesopts_version();
4171 maybe_apply_patches_dirtily();
4172 runcmd_ordryrun_local @dbp;
4174 maybe_unapply_patches_again();
4175 printdone "build successful\n";
4179 my @dbp = @dpkgbuildpackage;
4181 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4184 if (length executable_on_path('git-buildpackage')) {
4185 @cmd = qw(git-buildpackage);
4187 @cmd = qw(gbp buildpackage);
4189 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4194 if (!$clean_using_builder) {
4195 push @cmd, '--git-cleaner=true';
4199 maybe_unapply_patches_again();
4201 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4202 canonicalise_suite();
4203 push @cmd, "--git-debian-branch=".lbranch();
4205 push @cmd, changesopts();
4206 runcmd_ordryrun_local @cmd, @ARGV;
4208 printdone "build successful\n";
4210 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4213 my $our_cleanmode = $cleanmode;
4214 if ($need_split_build_invocation) {
4215 # Pretend that clean is being done some other way. This
4216 # forces us not to try to use dpkg-buildpackage to clean and
4217 # build source all in one go; and instead we run dpkg-source
4218 # (and build_prep() will do the clean since $clean_using_builder
4220 $our_cleanmode = 'ELSEWHERE';
4222 if ($our_cleanmode =~ m/^dpkg-source/) {
4223 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4224 $clean_using_builder = 1;
4227 $sourcechanges = changespat $version,'source';
4229 unlink "../$sourcechanges" or $!==ENOENT
4230 or fail "remove $sourcechanges: $!";
4232 $dscfn = dscfn($version);
4233 if ($our_cleanmode eq 'dpkg-source') {
4234 maybe_apply_patches_dirtily();
4235 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4237 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4238 maybe_apply_patches_dirtily();
4239 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4242 my @cmd = (@dpkgsource, qw(-b --));
4245 runcmd_ordryrun_local @cmd, "work";
4246 my @udfiles = <${package}_*>;
4247 changedir "../../..";
4248 foreach my $f (@udfiles) {
4249 printdebug "source copy, found $f\n";
4252 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4253 $f eq srcfn($version, $&));
4254 printdebug "source copy, found $f - renaming\n";
4255 rename "$ud/$f", "../$f" or $!==ENOENT
4256 or fail "put in place new source file ($f): $!";
4259 my $pwd = must_getcwd();
4260 my $leafdir = basename $pwd;
4262 runcmd_ordryrun_local @cmd, $leafdir;
4265 runcmd_ordryrun_local qw(sh -ec),
4266 'exec >$1; shift; exec "$@"','x',
4267 "../$sourcechanges",
4268 @dpkggenchanges, qw(-S), changesopts();
4272 sub cmd_build_source {
4273 badusage "build-source takes no additional arguments" if @ARGV;
4275 maybe_unapply_patches_again();
4276 printdone "source built, results in $dscfn and $sourcechanges";
4281 my $pat = changespat $version;
4283 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4284 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4285 fail "changes files other than source matching $pat".
4286 " already present (@unwanted);".
4287 " building would result in ambiguity about the intended results"
4290 my $wasdir = must_getcwd();
4293 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4294 stat_exists $sourcechanges
4295 or fail "$sourcechanges (in parent directory): $!";
4297 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4298 my @changesfiles = glob $pat;
4299 @changesfiles = sort {
4300 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4303 fail "wrong number of different changes files (@changesfiles)"
4304 unless @changesfiles==2;
4305 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4306 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4307 fail "$l found in binaries changes file $binchanges"
4310 runcmd_ordryrun_local @mergechanges, @changesfiles;
4311 my $multichanges = changespat $version,'multi';
4313 stat_exists $multichanges or fail "$multichanges: $!";
4314 foreach my $cf (glob $pat) {
4315 next if $cf eq $multichanges;
4316 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4320 maybe_unapply_patches_again();
4321 printdone "build successful, results in $multichanges\n" or die $!;
4324 sub cmd_quilt_fixup {
4325 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4326 my $clogp = parsechangelog();
4327 $version = getfield $clogp, 'Version';
4328 $package = getfield $clogp, 'Source';
4331 build_maybe_quilt_fixup();
4334 sub cmd_archive_api_query {
4335 badusage "need only 1 subpath argument" unless @ARGV==1;
4336 my ($subpath) = @ARGV;
4337 my @cmd = archive_api_query_cmd($subpath);
4339 exec @cmd or fail "exec curl: $!\n";
4342 sub cmd_clone_dgit_repos_server {
4343 badusage "need destination argument" unless @ARGV==1;
4344 my ($destdir) = @ARGV;
4345 $package = '_dgit-repos-server';
4346 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4348 exec @cmd or fail "exec git clone: $!\n";
4351 sub cmd_setup_mergechangelogs {
4352 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4353 setup_mergechangelogs(1);
4356 sub cmd_setup_useremail {
4357 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4361 sub cmd_setup_new_tree {
4362 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4366 #---------- argument parsing and main program ----------
4369 print "dgit version $our_version\n" or die $!;
4373 our (%valopts_long, %valopts_short);
4376 sub defvalopt ($$$$) {
4377 my ($long,$short,$val_re,$how) = @_;
4378 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4379 $valopts_long{$long} = $oi;
4380 $valopts_short{$short} = $oi;
4381 # $how subref should:
4382 # do whatever assignemnt or thing it likes with $_[0]
4383 # if the option should not be passed on to remote, @rvalopts=()
4384 # or $how can be a scalar ref, meaning simply assign the value
4387 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4388 defvalopt '--distro', '-d', '.+', \$idistro;
4389 defvalopt '', '-k', '.+', \$keyid;
4390 defvalopt '--existing-package','', '.*', \$existing_package;
4391 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4392 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4393 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4395 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4397 defvalopt '', '-C', '.+', sub {
4398 ($changesfile) = (@_);
4399 if ($changesfile =~ s#^(.*)/##) {
4400 $buildproductsdir = $1;
4404 defvalopt '--initiator-tempdir','','.*', sub {
4405 ($initiator_tempdir) = (@_);
4406 $initiator_tempdir =~ m#^/# or
4407 badusage "--initiator-tempdir must be used specify an".
4408 " absolute, not relative, directory."
4414 if (defined $ENV{'DGIT_SSH'}) {
4415 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4416 } elsif (defined $ENV{'GIT_SSH'}) {
4417 @ssh = ($ENV{'GIT_SSH'});
4425 if (!defined $val) {
4426 badusage "$what needs a value" unless @ARGV;
4428 push @rvalopts, $val;
4430 badusage "bad value \`$val' for $what" unless
4431 $val =~ m/^$oi->{Re}$(?!\n)/s;
4432 my $how = $oi->{How};
4433 if (ref($how) eq 'SCALAR') {
4438 push @ropts, @rvalopts;
4442 last unless $ARGV[0] =~ m/^-/;
4446 if (m/^--dry-run$/) {
4449 } elsif (m/^--damp-run$/) {
4452 } elsif (m/^--no-sign$/) {
4455 } elsif (m/^--help$/) {
4457 } elsif (m/^--version$/) {
4459 } elsif (m/^--new$/) {
4462 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4463 ($om = $opts_opt_map{$1}) &&
4467 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4468 !$opts_opt_cmdonly{$1} &&
4469 ($om = $opts_opt_map{$1})) {
4472 } elsif (m/^--ignore-dirty$/s) {
4475 } elsif (m/^--no-quilt-fixup$/s) {
4477 $quilt_mode = 'nocheck';
4478 } elsif (m/^--no-rm-on-error$/s) {
4481 } elsif (m/^--(no-)?rm-old-changes$/s) {
4484 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4486 push @deliberatelies, $&;
4487 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4488 # undocumented, for testing
4490 $tagformat_want = [ $1, 'command line', 1 ];
4491 # 1 menas overrides distro configuration
4492 } elsif (m/^--always-split-source-build$/s) {
4493 # undocumented, for testing
4495 $need_split_build_invocation = 1;
4496 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4497 $val = $2 ? $' : undef; #';
4498 $valopt->($oi->{Long});
4500 badusage "unknown long option \`$_'";
4507 } elsif (s/^-L/-/) {
4510 } elsif (s/^-h/-/) {
4512 } elsif (s/^-D/-/) {
4516 } elsif (s/^-N/-/) {
4521 push @changesopts, $_;
4523 } elsif (s/^-wn$//s) {
4525 $cleanmode = 'none';
4526 } elsif (s/^-wg$//s) {
4529 } elsif (s/^-wgf$//s) {
4531 $cleanmode = 'git-ff';
4532 } elsif (s/^-wd$//s) {
4534 $cleanmode = 'dpkg-source';
4535 } elsif (s/^-wdd$//s) {
4537 $cleanmode = 'dpkg-source-d';
4538 } elsif (s/^-wc$//s) {
4540 $cleanmode = 'check';
4541 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4543 $val = undef unless length $val;
4544 $valopt->($oi->{Short});
4547 badusage "unknown short option \`$_'";
4554 sub finalise_opts_opts () {
4555 foreach my $k (keys %opts_opt_map) {
4556 my $om = $opts_opt_map{$k};
4558 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4560 badcfg "cannot set command for $k"
4561 unless length $om->[0];
4565 foreach my $c (access_cfg_cfgs("opts-$k")) {
4566 my $vl = $gitcfg{$c};
4567 printdebug "CL $c ",
4568 ($vl ? join " ", map { shellquote } @$vl : ""),
4569 "\n" if $debuglevel >= 4;
4571 badcfg "cannot configure options for $k"
4572 if $opts_opt_cmdonly{$k};
4573 my $insertpos = $opts_cfg_insertpos{$k};
4574 @$om = ( @$om[0..$insertpos-1],
4576 @$om[$insertpos..$#$om] );
4581 if ($ENV{$fakeeditorenv}) {
4583 quilt_fixup_editor();
4589 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4590 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4591 if $dryrun_level == 1;
4593 print STDERR $helpmsg or die $!;
4596 my $cmd = shift @ARGV;
4599 if (!defined $rmchanges) {
4600 local $access_forpush;
4601 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4604 if (!defined $quilt_mode) {
4605 local $access_forpush;
4606 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4607 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4609 $quilt_mode =~ m/^($quilt_modes_re)$/
4610 or badcfg "unknown quilt-mode \`$quilt_mode'";
4614 $need_split_build_invocation ||= quiltmode_splitbrain();
4616 if (!defined $cleanmode) {
4617 local $access_forpush;
4618 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4619 $cleanmode //= 'dpkg-source';
4621 badcfg "unknown clean-mode \`$cleanmode'" unless
4622 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4625 my $fn = ${*::}{"cmd_$cmd"};
4626 $fn or badusage "unknown operation $cmd";