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|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
81 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
82 our $splitbraincache = 'dgit-intern/quilt-cache';
85 our (@dget) = qw(dget);
86 our (@curl) = qw(curl -f);
87 our (@dput) = qw(dput);
88 our (@debsign) = qw(debsign);
90 our (@sbuild) = qw(sbuild);
92 our (@dgit) = qw(dgit);
93 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
94 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
95 our (@dpkggenchanges) = qw(dpkg-genchanges);
96 our (@mergechanges) = qw(mergechanges -f);
98 our (@changesopts) = ('');
100 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
103 'debsign' => \@debsign,
105 'sbuild' => \@sbuild,
109 'dpkg-source' => \@dpkgsource,
110 'dpkg-buildpackage' => \@dpkgbuildpackage,
111 'dpkg-genchanges' => \@dpkggenchanges,
113 'ch' => \@changesopts,
114 'mergechanges' => \@mergechanges);
116 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
117 our %opts_cfg_insertpos = map {
119 scalar @{ $opts_opt_map{$_} }
120 } keys %opts_opt_map;
122 sub finalise_opts_opts();
128 our $supplementary_message = '';
129 our $need_split_build_invocation = 0;
130 our $split_brain = 0;
134 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
137 our $remotename = 'dgit';
138 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
143 my ($v,$distro) = @_;
144 return $tagformatfn->($v, $distro);
147 sub debiantag_maintview ($$) {
148 my ($v,$distro) = @_;
153 sub 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 # old means "repo server accepts pushes with old dgit tags"
538 # new means "repo server accepts pushes with new dgit tags"
539 # maint means "repo server accepts split brain pushes"
540 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
541 'dgit-distro.debian.git-check' => 'url',
542 'dgit-distro.debian.git-check-suffix' => '/info/refs',
543 'dgit-distro.debian.new-private-pushers' => 't',
544 'dgit-distro.debian.dgit-tag-format' => 'old',
545 'dgit-distro.debian/push.git-url' => '',
546 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
547 'dgit-distro.debian/push.git-user-force' => 'dgit',
548 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
549 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
550 'dgit-distro.debian/push.git-create' => 'true',
551 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
552 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
553 # 'dgit-distro.debian.archive-query-tls-key',
554 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
555 # ^ this does not work because curl is broken nowadays
556 # Fixing #790093 properly will involve providing providing the key
557 # in some pacagke and maybe updating these paths.
559 # 'dgit-distro.debian.archive-query-tls-curl-args',
560 # '--ca-path=/etc/ssl/ca-debian',
561 # ^ this is a workaround but works (only) on DSA-administered machines
562 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
563 'dgit-distro.debian.git-url-suffix' => '',
564 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
565 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
566 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
567 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
568 'dgit-distro.ubuntu.git-check' => 'false',
569 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
570 'dgit-distro.test-dummy.ssh' => "$td/ssh",
571 'dgit-distro.test-dummy.username' => "alice",
572 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
573 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
574 'dgit-distro.test-dummy.git-url' => "$td/git",
575 'dgit-distro.test-dummy.git-host' => "git",
576 'dgit-distro.test-dummy.git-path' => "$td/git",
577 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
578 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
579 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
580 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
585 sub git_slurp_config () {
586 local ($debuglevel) = $debuglevel-2;
589 my @cmd = (@git, qw(config -z --get-regexp .*));
592 open GITS, "-|", @cmd or die $!;
595 printdebug "=> ", (messagequote $_), "\n";
597 push @{ $gitcfg{$`} }, $'; #';
601 or ($!==0 && $?==256)
605 sub git_get_config ($) {
608 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
611 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
617 return undef if $c =~ /RETURN-UNDEF/;
618 my $v = git_get_config($c);
619 return $v if defined $v;
620 my $dv = $defcfg{$c};
621 return $dv if defined $dv;
623 badcfg "need value for one of: @_\n".
624 "$us: distro or suite appears not to be (properly) supported";
627 sub access_basedistro () {
628 if (defined $idistro) {
631 return cfg("dgit-suite.$isuite.distro",
632 "dgit.default.distro");
636 sub access_quirk () {
637 # returns (quirk name, distro to use instead or undef, quirk-specific info)
638 my $basedistro = access_basedistro();
639 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
641 if (defined $backports_quirk) {
642 my $re = $backports_quirk;
643 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
645 $re =~ s/\%/([-0-9a-z_]+)/
646 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
647 if ($isuite =~ m/^$re$/) {
648 return ('backports',"$basedistro-backports",$1);
651 return ('none',undef);
656 sub parse_cfg_bool ($$$) {
657 my ($what,$def,$v) = @_;
660 $v =~ m/^[ty1]/ ? 1 :
661 $v =~ m/^[fn0]/ ? 0 :
662 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
665 sub access_forpush_config () {
666 my $d = access_basedistro();
670 parse_cfg_bool('new-private-pushers', 0,
671 cfg("dgit-distro.$d.new-private-pushers",
674 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
677 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
678 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
679 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
680 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
683 sub access_forpush () {
684 $access_forpush //= access_forpush_config();
685 return $access_forpush;
689 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
690 badcfg "pushing but distro is configured readonly"
691 if access_forpush_config() eq '0';
693 $supplementary_message = <<'END' unless $we_are_responder;
694 Push failed, before we got started.
695 You can retry the push, after fixing the problem, if you like.
697 finalise_opts_opts();
701 finalise_opts_opts();
704 sub supplementary_message ($) {
706 if (!$we_are_responder) {
707 $supplementary_message = $msg;
709 } elsif ($protovsn >= 3) {
710 responder_send_command "supplementary-message ".length($msg)
712 print PO $msg or die $!;
716 sub access_distros () {
717 # Returns list of distros to try, in order
720 # 0. `instead of' distro name(s) we have been pointed to
721 # 1. the access_quirk distro, if any
722 # 2a. the user's specified distro, or failing that } basedistro
723 # 2b. the distro calculated from the suite }
724 my @l = access_basedistro();
726 my (undef,$quirkdistro) = access_quirk();
727 unshift @l, $quirkdistro;
728 unshift @l, $instead_distro;
729 @l = grep { defined } @l;
731 if (access_forpush()) {
732 @l = map { ("$_/push", $_) } @l;
737 sub access_cfg_cfgs (@) {
740 # The nesting of these loops determines the search order. We put
741 # the key loop on the outside so that we search all the distros
742 # for each key, before going on to the next key. That means that
743 # if access_cfg is called with a more specific, and then a less
744 # specific, key, an earlier distro can override the less specific
745 # without necessarily overriding any more specific keys. (If the
746 # distro wants to override the more specific keys it can simply do
747 # so; whereas if we did the loop the other way around, it would be
748 # impossible to for an earlier distro to override a less specific
749 # key but not the more specific ones without restating the unknown
750 # values of the more specific keys.
753 # We have to deal with RETURN-UNDEF specially, so that we don't
754 # terminate the search prematurely.
756 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
759 foreach my $d (access_distros()) {
760 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
762 push @cfgs, map { "dgit.default.$_" } @realkeys;
769 my (@cfgs) = access_cfg_cfgs(@keys);
770 my $value = cfg(@cfgs);
774 sub access_cfg_bool ($$) {
775 my ($def, @keys) = @_;
776 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
779 sub string_to_ssh ($) {
781 if ($spec =~ m/\s/) {
782 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
788 sub access_cfg_ssh () {
789 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
790 if (!defined $gitssh) {
793 return string_to_ssh $gitssh;
797 sub access_runeinfo ($) {
799 return ": dgit ".access_basedistro()." $info ;";
802 sub access_someuserhost ($) {
804 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
805 defined($user) && length($user) or
806 $user = access_cfg("$some-user",'username');
807 my $host = access_cfg("$some-host");
808 return length($user) ? "$user\@$host" : $host;
811 sub access_gituserhost () {
812 return access_someuserhost('git');
815 sub access_giturl (;$) {
817 my $url = access_cfg('git-url','RETURN-UNDEF');
820 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
821 return undef unless defined $proto;
824 access_gituserhost().
825 access_cfg('git-path');
827 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
830 return "$url/$package$suffix";
833 sub parsecontrolfh ($$;$) {
834 my ($fh, $desc, $allowsigned) = @_;
835 our $dpkgcontrolhash_noissigned;
838 my %opts = ('name' => $desc);
839 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
840 $c = Dpkg::Control::Hash->new(%opts);
841 $c->parse($fh,$desc) or die "parsing of $desc failed";
842 last if $allowsigned;
843 last if $dpkgcontrolhash_noissigned;
844 my $issigned= $c->get_option('is_pgp_signed');
845 if (!defined $issigned) {
846 $dpkgcontrolhash_noissigned= 1;
847 seek $fh, 0,0 or die "seek $desc: $!";
848 } elsif ($issigned) {
849 fail "control file $desc is (already) PGP-signed. ".
850 " Note that dgit push needs to modify the .dsc and then".
851 " do the signature itself";
860 my ($file, $desc) = @_;
861 my $fh = new IO::Handle;
862 open $fh, '<', $file or die "$file: $!";
863 my $c = parsecontrolfh($fh,$desc);
864 $fh->error and die $!;
870 my ($dctrl,$field) = @_;
871 my $v = $dctrl->{$field};
872 return $v if defined $v;
873 fail "missing field $field in ".$v->get_option('name');
877 my $c = Dpkg::Control::Hash->new();
878 my $p = new IO::Handle;
879 my @cmd = (qw(dpkg-parsechangelog), @_);
880 open $p, '-|', @cmd or die $!;
882 $?=0; $!=0; close $p or failedcmd @cmd;
886 sub commit_getclogp ($) {
887 # Returns the parsed changelog hashref for a particular commit
889 our %commit_getclogp_memo;
890 my $memo = $commit_getclogp_memo{$objid};
891 return $memo if $memo;
893 my $mclog = ".git/dgit/clog-$objid";
894 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
895 "$objid:debian/changelog";
896 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
901 defined $d or fail "getcwd failed: $!";
907 sub archive_query ($) {
909 my $query = access_cfg('archive-query','RETURN-UNDEF');
910 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
913 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
916 sub pool_dsc_subpath ($$) {
917 my ($vsn,$component) = @_; # $package is implict arg
918 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
919 return "/pool/$component/$prefix/$package/".dscfn($vsn);
922 #---------- `ftpmasterapi' archive query method (nascent) ----------
924 sub archive_api_query_cmd ($) {
926 my @cmd = qw(curl -sS);
927 my $url = access_cfg('archive-query-url');
928 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
930 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
931 foreach my $key (split /\:/, $keys) {
932 $key =~ s/\%HOST\%/$host/g;
934 fail "for $url: stat $key: $!" unless $!==ENOENT;
937 fail "config requested specific TLS key but do not know".
938 " how to get curl to use exactly that EE key ($key)";
939 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
940 # # Sadly the above line does not work because of changes
941 # # to gnutls. The real fix for #790093 may involve
942 # # new curl options.
945 # Fixing #790093 properly will involve providing a value
946 # for this on clients.
947 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
948 push @cmd, split / /, $kargs if defined $kargs;
950 push @cmd, $url.$subpath;
956 my ($data, $subpath) = @_;
957 badcfg "ftpmasterapi archive query method takes no data part"
959 my @cmd = archive_api_query_cmd($subpath);
960 my $json = cmdoutput @cmd;
961 return decode_json($json);
964 sub canonicalise_suite_ftpmasterapi () {
965 my ($proto,$data) = @_;
966 my $suites = api_query($data, 'suites');
968 foreach my $entry (@$suites) {
970 my $v = $entry->{$_};
971 defined $v && $v eq $isuite;
973 push @matched, $entry;
975 fail "unknown suite $isuite" unless @matched;
978 @matched==1 or die "multiple matches for suite $isuite\n";
979 $cn = "$matched[0]{codename}";
980 defined $cn or die "suite $isuite info has no codename\n";
981 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
983 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
988 sub archive_query_ftpmasterapi () {
989 my ($proto,$data) = @_;
990 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
992 my $digester = Digest::SHA->new(256);
993 foreach my $entry (@$info) {
995 my $vsn = "$entry->{version}";
996 my ($ok,$msg) = version_check $vsn;
997 die "bad version: $msg\n" unless $ok;
998 my $component = "$entry->{component}";
999 $component =~ m/^$component_re$/ or die "bad component";
1000 my $filename = "$entry->{filename}";
1001 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1002 or die "bad filename";
1003 my $sha256sum = "$entry->{sha256sum}";
1004 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1005 push @rows, [ $vsn, "/pool/$component/$filename",
1006 $digester, $sha256sum ];
1008 die "bad ftpmaster api response: $@\n".Dumper($entry)
1011 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1015 #---------- `madison' archive query method ----------
1017 sub archive_query_madison {
1018 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1021 sub madison_get_parse {
1022 my ($proto,$data) = @_;
1023 die unless $proto eq 'madison';
1024 if (!length $data) {
1025 $data= access_cfg('madison-distro','RETURN-UNDEF');
1026 $data //= access_basedistro();
1028 $rmad{$proto,$data,$package} ||= cmdoutput
1029 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1030 my $rmad = $rmad{$proto,$data,$package};
1033 foreach my $l (split /\n/, $rmad) {
1034 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1035 \s*( [^ \t|]+ )\s* \|
1036 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1037 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1038 $1 eq $package or die "$rmad $package ?";
1045 $component = access_cfg('archive-query-default-component');
1047 $5 eq 'source' or die "$rmad ?";
1048 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1050 return sort { -version_compare($a->[0],$b->[0]); } @out;
1053 sub canonicalise_suite_madison {
1054 # madison canonicalises for us
1055 my @r = madison_get_parse(@_);
1057 "unable to canonicalise suite using package $package".
1058 " which does not appear to exist in suite $isuite;".
1059 " --existing-package may help";
1063 #---------- `sshpsql' archive query method ----------
1066 my ($data,$runeinfo,$sql) = @_;
1067 if (!length $data) {
1068 $data= access_someuserhost('sshpsql').':'.
1069 access_cfg('sshpsql-dbname');
1071 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1072 my ($userhost,$dbname) = ($`,$'); #';
1074 my @cmd = (access_cfg_ssh, $userhost,
1075 access_runeinfo("ssh-psql $runeinfo").
1076 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1077 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1079 open P, "-|", @cmd or die $!;
1082 printdebug(">|$_|\n");
1085 $!=0; $?=0; close P or failedcmd @cmd;
1087 my $nrows = pop @rows;
1088 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1089 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1090 @rows = map { [ split /\|/, $_ ] } @rows;
1091 my $ncols = scalar @{ shift @rows };
1092 die if grep { scalar @$_ != $ncols } @rows;
1096 sub sql_injection_check {
1097 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1100 sub archive_query_sshpsql ($$) {
1101 my ($proto,$data) = @_;
1102 sql_injection_check $isuite, $package;
1103 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1104 SELECT source.version, component.name, files.filename, files.sha256sum
1106 JOIN src_associations ON source.id = src_associations.source
1107 JOIN suite ON suite.id = src_associations.suite
1108 JOIN dsc_files ON dsc_files.source = source.id
1109 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1110 JOIN component ON component.id = files_archive_map.component_id
1111 JOIN files ON files.id = dsc_files.file
1112 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1113 AND source.source='$package'
1114 AND files.filename LIKE '%.dsc';
1116 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1117 my $digester = Digest::SHA->new(256);
1119 my ($vsn,$component,$filename,$sha256sum) = @$_;
1120 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1125 sub canonicalise_suite_sshpsql ($$) {
1126 my ($proto,$data) = @_;
1127 sql_injection_check $isuite;
1128 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1129 SELECT suite.codename
1130 FROM suite where suite_name='$isuite' or codename='$isuite';
1132 @rows = map { $_->[0] } @rows;
1133 fail "unknown suite $isuite" unless @rows;
1134 die "ambiguous $isuite: @rows ?" if @rows>1;
1138 #---------- `dummycat' archive query method ----------
1140 sub canonicalise_suite_dummycat ($$) {
1141 my ($proto,$data) = @_;
1142 my $dpath = "$data/suite.$isuite";
1143 if (!open C, "<", $dpath) {
1144 $!==ENOENT or die "$dpath: $!";
1145 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1149 chomp or die "$dpath: $!";
1151 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1155 sub archive_query_dummycat ($$) {
1156 my ($proto,$data) = @_;
1157 canonicalise_suite();
1158 my $dpath = "$data/package.$csuite.$package";
1159 if (!open C, "<", $dpath) {
1160 $!==ENOENT or die "$dpath: $!";
1161 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1169 printdebug "dummycat query $csuite $package $dpath | $_\n";
1170 my @row = split /\s+/, $_;
1171 @row==2 or die "$dpath: $_ ?";
1174 C->error and die "$dpath: $!";
1176 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1179 #---------- tag format handling ----------
1181 sub access_cfg_tagformats () {
1182 split /\,/, access_cfg('dgit-tag-format');
1185 sub need_tagformat ($$) {
1186 my ($fmt, $why) = @_;
1187 fail "need to use tag format $fmt ($why) but also need".
1188 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1189 " - no way to proceed"
1190 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1191 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1194 sub select_tagformat () {
1196 return if $tagformatfn && !$tagformat_want;
1197 die 'bug' if $tagformatfn && $tagformat_want;
1198 # ... $tagformat_want assigned after previous select_tagformat
1200 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1201 printdebug "select_tagformat supported @supported\n";
1203 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1204 printdebug "select_tagformat specified @$tagformat_want\n";
1206 my ($fmt,$why,$override) = @$tagformat_want;
1208 fail "target distro supports tag formats @supported".
1209 " but have to use $fmt ($why)"
1211 or grep { $_ eq $fmt } @supported;
1213 $tagformat_want = undef;
1215 $tagformatfn = ${*::}{"debiantag_$fmt"};
1217 fail "trying to use unknown tag format \`$fmt' ($why) !"
1218 unless $tagformatfn;
1221 #---------- archive query entrypoints and rest of program ----------
1223 sub canonicalise_suite () {
1224 return if defined $csuite;
1225 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1226 $csuite = archive_query('canonicalise_suite');
1227 if ($isuite ne $csuite) {
1228 progress "canonical suite name for $isuite is $csuite";
1232 sub get_archive_dsc () {
1233 canonicalise_suite();
1234 my @vsns = archive_query('archive_query');
1235 foreach my $vinfo (@vsns) {
1236 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1237 $dscurl = access_cfg('mirror').$subpath;
1238 $dscdata = url_get($dscurl);
1240 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1245 $digester->add($dscdata);
1246 my $got = $digester->hexdigest();
1248 fail "$dscurl has hash $got but".
1249 " archive told us to expect $digest";
1251 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1252 printdebug Dumper($dscdata) if $debuglevel>1;
1253 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1254 printdebug Dumper($dsc) if $debuglevel>1;
1255 my $fmt = getfield $dsc, 'Format';
1256 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1257 $dsc_checked = !!$digester;
1258 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1262 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1265 sub check_for_git ();
1266 sub check_for_git () {
1268 my $how = access_cfg('git-check');
1269 if ($how eq 'ssh-cmd') {
1271 (access_cfg_ssh, access_gituserhost(),
1272 access_runeinfo("git-check $package").
1273 " set -e; cd ".access_cfg('git-path').";".
1274 " if test -d $package.git; then echo 1; else echo 0; fi");
1275 my $r= cmdoutput @cmd;
1276 if (defined $r and $r =~ m/^divert (\w+)$/) {
1278 my ($usedistro,) = access_distros();
1279 # NB that if we are pushing, $usedistro will be $distro/push
1280 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1281 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1282 progress "diverting to $divert (using config for $instead_distro)";
1283 return check_for_git();
1285 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1287 } elsif ($how eq 'url') {
1288 my $prefix = access_cfg('git-check-url','git-url');
1289 my $suffix = access_cfg('git-check-suffix','git-suffix',
1290 'RETURN-UNDEF') // '.git';
1291 my $url = "$prefix/$package$suffix";
1292 my @cmd = (qw(curl -sS -I), $url);
1293 my $result = cmdoutput @cmd;
1294 $result =~ s/^\S+ 200 .*\n\r?\n//;
1295 # curl -sS -I with https_proxy prints
1296 # HTTP/1.0 200 Connection established
1297 $result =~ m/^\S+ (404|200) /s or
1298 fail "unexpected results from git check query - ".
1299 Dumper($prefix, $result);
1301 if ($code eq '404') {
1303 } elsif ($code eq '200') {
1308 } elsif ($how eq 'true') {
1310 } elsif ($how eq 'false') {
1313 badcfg "unknown git-check \`$how'";
1317 sub create_remote_git_repo () {
1318 my $how = access_cfg('git-create');
1319 if ($how eq 'ssh-cmd') {
1321 (access_cfg_ssh, access_gituserhost(),
1322 access_runeinfo("git-create $package").
1323 "set -e; cd ".access_cfg('git-path').";".
1324 " cp -a _template $package.git");
1325 } elsif ($how eq 'true') {
1328 badcfg "unknown git-create \`$how'";
1332 our ($dsc_hash,$lastpush_mergeinput);
1334 our $ud = '.git/dgit/unpack';
1344 sub mktree_in_ud_here () {
1345 runcmd qw(git init -q);
1346 runcmd qw(git config gc.auto 0);
1347 rmtree('.git/objects');
1348 symlink '../../../../objects','.git/objects' or die $!;
1351 sub git_write_tree () {
1352 my $tree = cmdoutput @git, qw(write-tree);
1353 $tree =~ m/^\w+$/ or die "$tree ?";
1357 sub remove_stray_gits () {
1358 my @gitscmd = qw(find -name .git -prune -print0);
1359 debugcmd "|",@gitscmd;
1360 open GITS, "-|", @gitscmd or die $!;
1365 print STDERR "$us: warning: removing from source package: ",
1366 (messagequote $_), "\n";
1370 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1373 sub mktree_in_ud_from_only_subdir () {
1374 # changes into the subdir
1376 die "@dirs ?" unless @dirs==1;
1377 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1381 remove_stray_gits();
1382 mktree_in_ud_here();
1383 my ($format, $fopts) = get_source_format();
1384 if (madformat($format)) {
1387 runcmd @git, qw(add -Af);
1388 my $tree=git_write_tree();
1389 return ($tree,$dir);
1392 sub dsc_files_info () {
1393 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1394 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1395 ['Files', 'Digest::MD5', 'new()']) {
1396 my ($fname, $module, $method) = @$csumi;
1397 my $field = $dsc->{$fname};
1398 next unless defined $field;
1399 eval "use $module; 1;" or die $@;
1401 foreach (split /\n/, $field) {
1403 m/^(\w+) (\d+) (\S+)$/ or
1404 fail "could not parse .dsc $fname line \`$_'";
1405 my $digester = eval "$module"."->$method;" or die $@;
1410 Digester => $digester,
1415 fail "missing any supported Checksums-* or Files field in ".
1416 $dsc->get_option('name');
1420 map { $_->{Filename} } dsc_files_info();
1423 sub is_orig_file ($;$) {
1426 m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1427 defined $base or return 1;
1431 sub make_commit ($) {
1433 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1436 sub clogp_authline ($) {
1438 my $author = getfield $clogp, 'Maintainer';
1439 $author =~ s#,.*##ms;
1440 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1441 my $authline = "$author $date";
1442 $authline =~ m/$git_authline_re/o or
1443 fail "unexpected commit author line format \`$authline'".
1444 " (was generated from changelog Maintainer field)";
1445 return ($1,$2,$3) if wantarray;
1449 sub vendor_patches_distro ($$) {
1450 my ($checkdistro, $what) = @_;
1451 return unless defined $checkdistro;
1453 my $series = "debian/patches/\L$checkdistro\E.series";
1454 printdebug "checking for vendor-specific $series ($what)\n";
1456 if (!open SERIES, "<", $series) {
1457 die "$series $!" unless $!==ENOENT;
1466 Unfortunately, this source package uses a feature of dpkg-source where
1467 the same source package unpacks to different source code on different
1468 distros. dgit cannot safely operate on such packages on affected
1469 distros, because the meaning of source packages is not stable.
1471 Please ask the distro/maintainer to remove the distro-specific series
1472 files and use a different technique (if necessary, uploading actually
1473 different packages, if different distros are supposed to have
1477 fail "Found active distro-specific series file for".
1478 " $checkdistro ($what): $series, cannot continue";
1480 die "$series $!" if SERIES->error;
1484 sub check_for_vendor_patches () {
1485 # This dpkg-source feature doesn't seem to be documented anywhere!
1486 # But it can be found in the changelog (reformatted):
1488 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1489 # Author: Raphael Hertzog <hertzog@debian.org>
1490 # Date: Sun Oct 3 09:36:48 2010 +0200
1492 # dpkg-source: correctly create .pc/.quilt_series with alternate
1495 # If you have debian/patches/ubuntu.series and you were
1496 # unpacking the source package on ubuntu, quilt was still
1497 # directed to debian/patches/series instead of
1498 # debian/patches/ubuntu.series.
1500 # debian/changelog | 3 +++
1501 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1502 # 2 files changed, 6 insertions(+), 1 deletion(-)
1505 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1506 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1507 "Dpkg::Vendor \`current vendor'");
1508 vendor_patches_distro(access_basedistro(),
1509 "distro being accessed");
1512 sub generate_commits_from_dsc () {
1513 # See big comment in fetch_from_archive, below.
1517 foreach my $fi (dsc_files_info()) {
1518 my $f = $fi->{Filename};
1519 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1521 link_ltarget "../../../$f", $f
1525 complete_file_from_dsc('.', $fi)
1528 if (is_orig_file($f)) {
1529 link $f, "../../../../$f"
1535 my $dscfn = "$package.dsc";
1537 open D, ">", $dscfn or die "$dscfn: $!";
1538 print D $dscdata or die "$dscfn: $!";
1539 close D or die "$dscfn: $!";
1540 my @cmd = qw(dpkg-source);
1541 push @cmd, '--no-check' if $dsc_checked;
1542 push @cmd, qw(-x --), $dscfn;
1545 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1546 check_for_vendor_patches() if madformat($dsc->{format});
1547 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1548 my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1549 my $authline = clogp_authline $clogp;
1550 my $changes = getfield $clogp, 'Changes';
1551 open C, ">../commit.tmp" or die $!;
1552 print C <<END or die $!;
1559 # imported from the archive
1562 my $rawimport_hash = make_commit qw(../commit.tmp);
1563 my $cversion = getfield $clogp, 'Version';
1564 my $rawimport_mergeinput = {
1565 Commit => $rawimport_hash,
1566 Info => "Import of source package",
1568 my @output = ($rawimport_mergeinput);
1569 progress "synthesised git commit from .dsc $cversion";
1570 if ($lastpush_mergeinput) {
1571 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1572 my $oversion = getfield $oldclogp, 'Version';
1574 version_compare($oversion, $cversion);
1576 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1577 { Message => <<END, ReverseParents => 1 });
1578 Record $package ($cversion) in archive suite $csuite
1580 } elsif ($vcmp > 0) {
1581 print STDERR <<END or die $!;
1583 Version actually in archive: $cversion (older)
1584 Last version pushed with dgit: $oversion (newer or same)
1587 @output = $lastpush_mergeinput;
1589 # Same version. Use what's in the server git branch,
1590 # discarding our own import. (This could happen if the
1591 # server automatically imports all packages into git.)
1592 @output = $lastpush_mergeinput;
1595 changedir '../../../..';
1600 sub complete_file_from_dsc ($$) {
1601 our ($dstdir, $fi) = @_;
1602 # Ensures that we have, in $dir, the file $fi, with the correct
1603 # contents. (Downloading it from alongside $dscurl if necessary.)
1605 my $f = $fi->{Filename};
1606 my $tf = "$dstdir/$f";
1609 if (stat_exists $tf) {
1610 progress "using existing $f";
1613 $furl =~ s{/[^/]+$}{};
1615 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1616 die "$f ?" if $f =~ m#/#;
1617 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1618 return 0 if !act_local();
1622 open F, "<", "$tf" or die "$tf: $!";
1623 $fi->{Digester}->reset();
1624 $fi->{Digester}->addfile(*F);
1625 F->error and die $!;
1626 my $got = $fi->{Digester}->hexdigest();
1627 $got eq $fi->{Hash} or
1628 fail "file $f has hash $got but .dsc".
1629 " demands hash $fi->{Hash} ".
1630 ($downloaded ? "(got wrong file from archive!)"
1631 : "(perhaps you should delete this file?)");
1636 sub ensure_we_have_orig () {
1637 foreach my $fi (dsc_files_info()) {
1638 my $f = $fi->{Filename};
1639 next unless is_orig_file($f);
1640 complete_file_from_dsc('..', $fi)
1645 sub git_fetch_us () {
1646 # Want to fetch only what we are going to use, unless
1647 # deliberately-not-ff, in which case we must fetch everything.
1649 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1651 (quiltmode_splitbrain
1652 ? (map { $_->('*',access_basedistro) }
1653 \&debiantag_new, \&debiantag_maintview)
1654 : debiantags('*',access_basedistro));
1655 push @specs, server_branch($csuite);
1656 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1658 # This is rather miserable:
1659 # When git-fetch --prune is passed a fetchspec ending with a *,
1660 # it does a plausible thing. If there is no * then:
1661 # - it matches subpaths too, even if the supplied refspec
1662 # starts refs, and behaves completely madly if the source
1663 # has refs/refs/something. (See, for example, Debian #NNNN.)
1664 # - if there is no matching remote ref, it bombs out the whole
1666 # We want to fetch a fixed ref, and we don't know in advance
1667 # if it exists, so this is not suitable.
1669 # Our workaround is to use git-ls-remote. git-ls-remote has its
1670 # own qairks. Notably, it has the absurd multi-tail-matching
1671 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1672 # refs/refs/foo etc.
1674 # Also, we want an idempotent snapshot, but we have to make two
1675 # calls to the remote: one to git-ls-remote and to git-fetch. The
1676 # solution is use git-ls-remote to obtain a target state, and
1677 # git-fetch to try to generate it. If we don't manage to generate
1678 # the target state, we try again.
1680 my $specre = join '|', map {
1686 printdebug "git_fetch_us specre=$specre\n";
1687 my $wanted_rref = sub {
1689 return m/^(?:$specre)$/o;
1692 my $fetch_iteration = 0;
1695 if (++$fetch_iteration > 10) {
1696 fail "too many iterations trying to get sane fetch!";
1699 my @look = map { "refs/$_" } @specs;
1700 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1704 open GITLS, "-|", @lcmd or die $!;
1706 printdebug "=> ", $_;
1707 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1708 my ($objid,$rrefname) = ($1,$2);
1709 if (!$wanted_rref->($rrefname)) {
1711 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1715 $wantr{$rrefname} = $objid;
1718 close GITLS or failedcmd @lcmd;
1720 # OK, now %want is exactly what we want for refs in @specs
1722 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1723 "+refs/$_:".lrfetchrefs."/$_";
1726 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1727 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1730 %lrfetchrefs_f = ();
1733 git_for_each_ref(lrfetchrefs, sub {
1734 my ($objid,$objtype,$lrefname,$reftail) = @_;
1735 $lrfetchrefs_f{$lrefname} = $objid;
1736 $objgot{$objid} = 1;
1739 foreach my $lrefname (sort keys %lrfetchrefs_f) {
1740 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
1741 if (!exists $wantr{$rrefname}) {
1742 if ($wanted_rref->($rrefname)) {
1744 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
1748 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
1751 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
1752 delete $lrfetchrefs_f{$lrefname};
1756 foreach my $rrefname (sort keys %wantr) {
1757 my $lrefname = lrfetchrefs.substr($rrefname, 4);
1758 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
1759 my $want = $wantr{$rrefname};
1760 next if $got eq $want;
1761 if (!defined $objgot{$want}) {
1763 warning: git-ls-remote suggests we want $lrefname
1764 warning: and it should refer to $want
1765 warning: but git-fetch didn't fetch that object to any relevant ref.
1766 warning: This may be due to a race with someone updating the server.
1767 warning: Will try again...
1769 next FETCH_ITERATION;
1772 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
1774 runcmd_ordryrun_local @git, qw(update-ref -m),
1775 "dgit fetch git-fetch fixup", $lrefname, $want;
1776 $lrfetchrefs_f{$lrefname} = $want;
1780 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
1781 Dumper(\%lrfetchrefs_f);
1784 my @tagpats = debiantags('*',access_basedistro);
1786 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
1787 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1788 printdebug "currently $fullrefname=$objid\n";
1789 $here{$fullrefname} = $objid;
1791 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
1792 my ($objid,$objtype,$fullrefname,$reftail) = @_;
1793 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
1794 printdebug "offered $lref=$objid\n";
1795 if (!defined $here{$lref}) {
1796 my @upd = (@git, qw(update-ref), $lref, $objid, '');
1797 runcmd_ordryrun_local @upd;
1798 lrfetchref_used $fullrefname;
1799 } elsif ($here{$lref} eq $objid) {
1800 lrfetchref_used $fullrefname;
1803 "Not updateting $lref from $here{$lref} to $objid.\n";
1808 sub mergeinfo_getclogp ($) {
1809 # Ensures thit $mi->{Clogp} exists and returns it
1811 $mi->{Clogp} = commit_getclogp($mi->{Commit});
1814 sub mergeinfo_version ($) {
1815 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
1818 sub fetch_from_archive () {
1819 # Ensures that lrref() is what is actually in the archive, one way
1820 # or another, according to us - ie this client's
1821 # appropritaely-updated archive view. Also returns the commit id.
1822 # If there is nothing in the archive, leaves lrref alone and
1823 # returns undef. git_fetch_us must have already been called.
1827 foreach my $field (@ourdscfield) {
1828 $dsc_hash = $dsc->{$field};
1829 last if defined $dsc_hash;
1831 if (defined $dsc_hash) {
1832 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1834 progress "last upload to archive specified git hash";
1836 progress "last upload to archive has NO git hash";
1839 progress "no version available from the archive";
1842 # If the archive's .dsc has a Dgit field, there are three
1843 # relevant git commitids we need to choose between and/or merge
1845 # 1. $dsc_hash: the Dgit field from the archive
1846 # 2. $lastpush_hash: the suite branch on the dgit git server
1847 # 3. $lastfetch_hash: our local tracking brach for the suite
1849 # These may all be distinct and need not be in any fast forward
1852 # If the dsc was pushed to this suite, then the server suite
1853 # branch will have been updated; but it might have been pushed to
1854 # a different suite and copied by the archive. Conversely a more
1855 # recent version may have been pushed with dgit but not appeared
1856 # in the archive (yet).
1858 # $lastfetch_hash may be awkward because archive imports
1859 # (particularly, imports of Dgit-less .dscs) are performed only as
1860 # needed on individual clients, so different clients may perform a
1861 # different subset of them - and these imports are only made
1862 # public during push. So $lastfetch_hash may represent a set of
1863 # imports different to a subsequent upload by a different dgit
1866 # Our approach is as follows:
1868 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1869 # descendant of $dsc_hash, then it was pushed by a dgit user who
1870 # had based their work on $dsc_hash, so we should prefer it.
1871 # Otherwise, $dsc_hash was installed into this suite in the
1872 # archive other than by a dgit push, and (necessarily) after the
1873 # last dgit push into that suite (since a dgit push would have
1874 # been descended from the dgit server git branch); thus, in that
1875 # case, we prefer the archive's version (and produce a
1876 # pseudo-merge to overwrite the dgit server git branch).
1878 # (If there is no Dgit field in the archive's .dsc then
1879 # generate_commit_from_dsc uses the version numbers to decide
1880 # whether the suite branch or the archive is newer. If the suite
1881 # branch is newer it ignores the archive's .dsc; otherwise it
1882 # generates an import of the .dsc, and produces a pseudo-merge to
1883 # overwrite the suite branch with the archive contents.)
1885 # The outcome of that part of the algorithm is the `public view',
1886 # and is same for all dgit clients: it does not depend on any
1887 # unpublished history in the local tracking branch.
1889 # As between the public view and the local tracking branch: The
1890 # local tracking branch is only updated by dgit fetch, and
1891 # whenever dgit fetch runs it includes the public view in the
1892 # local tracking branch. Therefore if the public view is not
1893 # descended from the local tracking branch, the local tracking
1894 # branch must contain history which was imported from the archive
1895 # but never pushed; and, its tip is now out of date. So, we make
1896 # a pseudo-merge to overwrite the old imports and stitch the old
1899 # Finally: we do not necessarily reify the public view (as
1900 # described above). This is so that we do not end up stacking two
1901 # pseudo-merges. So what we actually do is figure out the inputs
1902 # to any public view pseudo-merge and put them in @mergeinputs.
1905 # $mergeinputs[]{Commit}
1906 # $mergeinputs[]{Info}
1907 # $mergeinputs[0] is the one whose tree we use
1908 # @mergeinputs is in the order we use in the actual commit)
1911 # $mergeinputs[]{Message} is a commit message to use
1912 # $mergeinputs[]{ReverseParents} if def specifies that parent
1913 # list should be in opposite order
1914 # Such an entry has no Commit or Info. It applies only when found
1915 # in the last entry. (This ugliness is to support making
1916 # identical imports to previous dgit versions.)
1918 my $lastpush_hash = git_get_ref(lrfetchref());
1919 printdebug "previous reference hash=$lastpush_hash\n";
1920 $lastpush_mergeinput = $lastpush_hash && {
1921 Commit => $lastpush_hash,
1922 Info => "dgit suite branch on dgit git server",
1925 my $lastfetch_hash = git_get_ref(lrref());
1926 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1927 my $lastfetch_mergeinput = $lastfetch_hash && {
1928 Commit => $lastfetch_hash,
1929 Info => "dgit client's archive history view",
1932 my $dsc_mergeinput = $dsc_hash && {
1933 Commit => $dsc_hash,
1934 Info => "Dgit field in .dsc from archive",
1938 my $del_lrfetchrefs = sub {
1941 printdebug "del_lrfetchrefs...\n";
1942 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1943 my $objid = $lrfetchrefs_d{$fullrefname};
1944 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
1946 $gur ||= new IO::Handle;
1947 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1949 printf $gur "delete %s %s\n", $fullrefname, $objid;
1952 close $gur or failedcmd "git update-ref delete lrfetchrefs";
1956 if (defined $dsc_hash) {
1957 fail "missing remote git history even though dsc has hash -".
1958 " could not find ref ".rref()." at ".access_giturl()
1959 unless $lastpush_hash;
1960 ensure_we_have_orig();
1961 if ($dsc_hash eq $lastpush_hash) {
1962 @mergeinputs = $dsc_mergeinput
1963 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1964 print STDERR <<END or die $!;
1966 Git commit in archive is behind the last version allegedly pushed/uploaded.
1967 Commit referred to by archive: $dsc_hash
1968 Last version pushed with dgit: $lastpush_hash
1971 @mergeinputs = ($lastpush_mergeinput);
1973 # Archive has .dsc which is not a descendant of the last dgit
1974 # push. This can happen if the archive moves .dscs about.
1975 # Just follow its lead.
1976 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1977 progress "archive .dsc names newer git commit";
1978 @mergeinputs = ($dsc_mergeinput);
1980 progress "archive .dsc names other git commit, fixing up";
1981 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1985 @mergeinputs = generate_commits_from_dsc();
1986 # We have just done an import. Now, our import algorithm might
1987 # have been improved. But even so we do not want to generate
1988 # a new different import of the same package. So if the
1989 # version numbers are the same, just use our existing version.
1990 # If the version numbers are different, the archive has changed
1991 # (perhaps, rewound).
1992 if ($lastfetch_mergeinput &&
1993 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1994 (mergeinfo_version $mergeinputs[0]) )) {
1995 @mergeinputs = ($lastfetch_mergeinput);
1997 } elsif ($lastpush_hash) {
1998 # only in git, not in the archive yet
1999 @mergeinputs = ($lastpush_mergeinput);
2000 print STDERR <<END or die $!;
2002 Package not found in the archive, but has allegedly been pushed using dgit.
2006 printdebug "nothing found!\n";
2007 if (defined $skew_warning_vsn) {
2008 print STDERR <<END or die $!;
2010 Warning: relevant archive skew detected.
2011 Archive allegedly contains $skew_warning_vsn
2012 But we were not able to obtain any version from the archive or git.
2016 unshift @end, $del_lrfetchrefs;
2020 if ($lastfetch_hash &&
2022 my $h = $_->{Commit};
2023 $h and is_fast_fwd($lastfetch_hash, $h);
2024 # If true, one of the existing parents of this commit
2025 # is a descendant of the $lastfetch_hash, so we'll
2026 # be ff from that automatically.
2030 push @mergeinputs, $lastfetch_mergeinput;
2033 printdebug "fetch mergeinfos:\n";
2034 foreach my $mi (@mergeinputs) {
2036 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2038 printdebug sprintf " ReverseParents=%d Message=%s",
2039 $mi->{ReverseParents}, $mi->{Message};
2043 my $compat_info= pop @mergeinputs
2044 if $mergeinputs[$#mergeinputs]{Message};
2046 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2049 if (@mergeinputs > 1) {
2051 my $tree_commit = $mergeinputs[0]{Commit};
2053 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2054 $tree =~ m/\n\n/; $tree = $`;
2055 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2058 # We use the changelog author of the package in question the
2059 # author of this pseudo-merge. This is (roughly) correct if
2060 # this commit is simply representing aa non-dgit upload.
2061 # (Roughly because it does not record sponsorship - but we
2062 # don't have sponsorship info because that's in the .changes,
2063 # which isn't in the archivw.)
2065 # But, it might be that we are representing archive history
2066 # updates (including in-archive copies). These are not really
2067 # the responsibility of the person who created the .dsc, but
2068 # there is no-one whose name we should better use. (The
2069 # author of the .dsc-named commit is clearly worse.)
2071 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2072 my $author = clogp_authline $useclogp;
2073 my $cversion = getfield $useclogp, 'Version';
2075 my $mcf = ".git/dgit/mergecommit";
2076 open MC, ">", $mcf or die "$mcf $!";
2077 print MC <<END or die $!;
2081 my @parents = grep { $_->{Commit} } @mergeinputs;
2082 @parents = reverse @parents if $compat_info->{ReverseParents};
2083 print MC <<END or die $! foreach @parents;
2087 print MC <<END or die $!;
2093 if (defined $compat_info->{Message}) {
2094 print MC $compat_info->{Message} or die $!;
2096 print MC <<END or die $!;
2097 Record $package ($cversion) in archive suite $csuite
2101 my $message_add_info = sub {
2103 my $mversion = mergeinfo_version $mi;
2104 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2108 $message_add_info->($mergeinputs[0]);
2109 print MC <<END or die $!;
2110 should be treated as descended from
2112 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2116 $hash = make_commit $mcf;
2118 $hash = $mergeinputs[0]{Commit};
2120 progress "fetch hash=$hash\n";
2123 my ($lasth, $what) = @_;
2124 return unless $lasth;
2125 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2128 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2129 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2131 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2132 'DGIT_ARCHIVE', $hash;
2133 cmdoutput @git, qw(log -n2), $hash;
2134 # ... gives git a chance to complain if our commit is malformed
2136 if (defined $skew_warning_vsn) {
2138 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2139 my $gotclogp = commit_getclogp($hash);
2140 my $got_vsn = getfield $gotclogp, 'Version';
2141 printdebug "SKEW CHECK GOT $got_vsn\n";
2142 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2143 print STDERR <<END or die $!;
2145 Warning: archive skew detected. Using the available version:
2146 Archive allegedly contains $skew_warning_vsn
2147 We were able to obtain only $got_vsn
2153 if ($lastfetch_hash ne $hash) {
2154 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2158 dryrun_report @upd_cmd;
2162 lrfetchref_used lrfetchref();
2164 unshift @end, $del_lrfetchrefs;
2168 sub set_local_git_config ($$) {
2170 runcmd @git, qw(config), $k, $v;
2173 sub setup_mergechangelogs (;$) {
2175 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2177 my $driver = 'dpkg-mergechangelogs';
2178 my $cb = "merge.$driver";
2179 my $attrs = '.git/info/attributes';
2180 ensuredir '.git/info';
2182 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2183 if (!open ATTRS, "<", $attrs) {
2184 $!==ENOENT or die "$attrs: $!";
2188 next if m{^debian/changelog\s};
2189 print NATTRS $_, "\n" or die $!;
2191 ATTRS->error and die $!;
2194 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2197 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2198 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2200 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2203 sub setup_useremail (;$) {
2205 return unless $always || access_cfg_bool(1, 'setup-useremail');
2208 my ($k, $envvar) = @_;
2209 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2210 return unless defined $v;
2211 set_local_git_config "user.$k", $v;
2214 $setup->('email', 'DEBEMAIL');
2215 $setup->('name', 'DEBFULLNAME');
2218 sub setup_new_tree () {
2219 setup_mergechangelogs();
2225 canonicalise_suite();
2226 badusage "dry run makes no sense with clone" unless act_local();
2227 my $hasgit = check_for_git();
2228 mkdir $dstdir or fail "create \`$dstdir': $!";
2230 runcmd @git, qw(init -q);
2231 my $giturl = access_giturl(1);
2232 if (defined $giturl) {
2233 open H, "> .git/HEAD" or die $!;
2234 print H "ref: ".lref()."\n" or die $!;
2236 runcmd @git, qw(remote add), 'origin', $giturl;
2239 progress "fetching existing git history";
2241 runcmd_ordryrun_local @git, qw(fetch origin);
2243 progress "starting new git history";
2245 fetch_from_archive() or no_such_package;
2246 my $vcsgiturl = $dsc->{'Vcs-Git'};
2247 if (length $vcsgiturl) {
2248 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2249 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2252 runcmd @git, qw(reset --hard), lrref();
2253 printdone "ready for work in $dstdir";
2257 if (check_for_git()) {
2260 fetch_from_archive() or no_such_package();
2261 printdone "fetched into ".lrref();
2266 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2268 printdone "fetched to ".lrref()." and merged into HEAD";
2271 sub check_not_dirty () {
2272 foreach my $f (qw(local-options local-patch-header)) {
2273 if (stat_exists "debian/source/$f") {
2274 fail "git tree contains debian/source/$f";
2278 return if $ignoredirty;
2280 my @cmd = (@git, qw(diff --quiet HEAD));
2282 $!=0; $?=-1; system @cmd;
2285 fail "working tree is dirty (does not match HEAD)";
2291 sub commit_admin ($) {
2294 runcmd_ordryrun_local @git, qw(commit -m), $m;
2297 sub commit_quilty_patch () {
2298 my $output = cmdoutput @git, qw(status --porcelain);
2300 foreach my $l (split /\n/, $output) {
2301 next unless $l =~ m/\S/;
2302 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2306 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2308 progress "nothing quilty to commit, ok.";
2311 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2312 runcmd_ordryrun_local @git, qw(add -f), @adds;
2313 commit_admin "Commit Debian 3.0 (quilt) metadata";
2316 sub get_source_format () {
2318 if (open F, "debian/source/options") {
2322 s/\s+$//; # ignore missing final newline
2324 my ($k, $v) = ($`, $'); #');
2325 $v =~ s/^"(.*)"$/$1/;
2331 F->error and die $!;
2334 die $! unless $!==&ENOENT;
2337 if (!open F, "debian/source/format") {
2338 die $! unless $!==&ENOENT;
2342 F->error and die $!;
2344 return ($_, \%options);
2349 return 0 unless $format eq '3.0 (quilt)';
2350 our $quilt_mode_warned;
2351 if ($quilt_mode eq 'nocheck') {
2352 progress "Not doing any fixup of \`$format' due to".
2353 " ----no-quilt-fixup or --quilt=nocheck"
2354 unless $quilt_mode_warned++;
2357 progress "Format \`$format', need to check/update patch stack"
2358 unless $quilt_mode_warned++;
2362 # An "infopair" is a tuple [ $thing, $what ]
2363 # (often $thing is a commit hash; $what is a description)
2365 sub infopair_cond_equal ($$) {
2367 $x->[0] eq $y->[0] or fail <<END;
2368 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2372 sub infopair_lrf_tag_lookup ($$) {
2373 my ($tagnames, $what) = @_;
2374 # $tagname may be an array ref
2375 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2376 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2377 foreach my $tagname (@tagnames) {
2378 my $lrefname = lrfetchrefs."/tags/$tagname";
2379 my $tagobj = $lrfetchrefs_f{$lrefname};
2380 next unless defined $tagobj;
2381 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2382 return [ git_rev_parse($tagobj), $what ];
2384 fail @tagnames==1 ? <<END : <<END;
2385 Wanted tag $what (@tagnames) on dgit server, but not found
2387 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2391 sub infopair_cond_ff ($$) {
2392 my ($anc,$desc) = @_;
2393 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2394 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2398 sub splitbrain_pseudomerge ($$$$) {
2399 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2400 # => $merged_dgitview
2401 printdebug "splitbrain_pseudomerge...\n";
2403 # We: debian/PREVIOUS HEAD($maintview)
2404 # expect: o ----------------- o
2407 # a/d/PREVIOUS $dgitview
2410 # we do: `------------------ o
2414 my $arch_clogp = commit_getclogp $archive_hash;
2415 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2416 'version currently in archive' ];
2418 printdebug "splitbrain_pseudomerge i_arch_v @$i_arch_v\n";
2420 return $dgitview unless defined $archive_hash;
2422 if (defined $overwrite_version) {
2423 progress "Declaring that HEAD inciudes all changes in archive...";
2424 progress "Checking that $overwrite_version does so...";
2425 infopair_cond_equal([ $overwrite_version, '--overwrite= version' ],
2428 progress "Checking that HEAD inciudes all changes in archive...";
2431 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2433 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2434 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2435 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2436 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2437 my $i_archive = [ $archive_hash, "current archive contents" ];
2439 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2441 infopair_cond_equal($i_dgit, $i_archive);
2442 infopair_cond_ff($i_dep14, $i_dgit);
2443 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2445 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2446 my $authline = clogp_authline $clogp;
2449 my $pmf = ".git/dgit/pseudomerge";
2450 open MC, ">", $pmf or die "$pmf $!";
2451 print MC <<END or die $!;
2454 parent $archive_hash
2459 if (defined $overwrite_version) {
2461 Declare fast forward from $overwrite_version
2463 [dgit --quilt=$quilt_mode --overwrite-version=$overwrite_version]
2467 Make fast forward from $i_arch_v->[0]
2469 [dgit --quilt=$quilt_mode]
2474 progress "Making pseudo-merge of $i_arch_v->[0] into dgit view.";
2475 return make_commit($pmf);
2478 sub push_parse_changelog ($) {
2481 my $clogp = Dpkg::Control::Hash->new();
2482 $clogp->load($clogpfn) or die;
2484 $package = getfield $clogp, 'Source';
2485 my $cversion = getfield $clogp, 'Version';
2486 my $tag = debiantag($cversion, access_basedistro);
2487 runcmd @git, qw(check-ref-format), $tag;
2489 my $dscfn = dscfn($cversion);
2491 return ($clogp, $cversion, $dscfn);
2494 sub push_parse_dsc ($$$) {
2495 my ($dscfn,$dscfnwhat, $cversion) = @_;
2496 $dsc = parsecontrol($dscfn,$dscfnwhat);
2497 my $dversion = getfield $dsc, 'Version';
2498 my $dscpackage = getfield $dsc, 'Source';
2499 ($dscpackage eq $package && $dversion eq $cversion) or
2500 fail "$dscfn is for $dscpackage $dversion".
2501 " but debian/changelog is for $package $cversion";
2504 sub push_tagwants ($$$$) {
2505 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2508 TagFn => \&debiantag,
2513 if (defined $maintviewhead) {
2515 TagFn => \&debiantag_maintview,
2516 Objid => $maintviewhead,
2517 TfSuffix => '-maintview',
2521 foreach my $tw (@tagwants) {
2522 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2523 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2525 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2529 sub push_mktags ($$ $$ $) {
2531 $changesfile,$changesfilewhat,
2534 die unless $tagwants->[0]{View} eq 'dgit';
2536 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2537 $dsc->save("$dscfn.tmp") or die $!;
2539 my $changes = parsecontrol($changesfile,$changesfilewhat);
2540 foreach my $field (qw(Source Distribution Version)) {
2541 $changes->{$field} eq $clogp->{$field} or
2542 fail "changes field $field \`$changes->{$field}'".
2543 " does not match changelog \`$clogp->{$field}'";
2546 my $cversion = getfield $clogp, 'Version';
2547 my $clogsuite = getfield $clogp, 'Distribution';
2549 # We make the git tag by hand because (a) that makes it easier
2550 # to control the "tagger" (b) we can do remote signing
2551 my $authline = clogp_authline $clogp;
2552 my $delibs = join(" ", "",@deliberatelies);
2553 my $declaredistro = access_basedistro();
2557 my $tfn = $tw->{Tfn};
2558 my $head = $tw->{Objid};
2559 my $tag = $tw->{Tag};
2561 open TO, '>', $tfn->('.tmp') or die $!;
2562 print TO <<END or die $!;
2569 if ($tw->{View} eq 'dgit') {
2570 print TO <<END or die $!;
2571 $package release $cversion for $clogsuite ($csuite) [dgit]
2572 [dgit distro=$declaredistro$delibs]
2574 foreach my $ref (sort keys %previously) {
2575 print TO <<END or die $!;
2576 [dgit previously:$ref=$previously{$ref}]
2579 } elsif ($tw->{View} eq 'maint') {
2580 print TO <<END or die $!;
2581 $package release $cversion for $clogsuite ($csuite)
2582 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2585 die Dumper($tw)."?";
2590 my $tagobjfn = $tfn->('.tmp');
2592 if (!defined $keyid) {
2593 $keyid = access_cfg('keyid','RETURN-UNDEF');
2595 if (!defined $keyid) {
2596 $keyid = getfield $clogp, 'Maintainer';
2598 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2599 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2600 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2601 push @sign_cmd, $tfn->('.tmp');
2602 runcmd_ordryrun @sign_cmd;
2604 $tagobjfn = $tfn->('.signed.tmp');
2605 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2606 $tfn->('.tmp'), $tfn->('.tmp.asc');
2612 my @r = map { $mktag->($_); } @$tagwants;
2616 sub sign_changes ($) {
2617 my ($changesfile) = @_;
2619 my @debsign_cmd = @debsign;
2620 push @debsign_cmd, "-k$keyid" if defined $keyid;
2621 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2622 push @debsign_cmd, $changesfile;
2623 runcmd_ordryrun @debsign_cmd;
2628 printdebug "actually entering push\n";
2630 supplementary_message(<<'END');
2631 Push failed, while checking state of the archive.
2632 You can retry the push, after fixing the problem, if you like.
2634 if (check_for_git()) {
2637 my $archive_hash = fetch_from_archive();
2638 if (!$archive_hash) {
2640 fail "package appears to be new in this suite;".
2641 " if this is intentional, use --new";
2644 supplementary_message(<<'END');
2645 Push failed, while preparing your push.
2646 You can retry the push, after fixing the problem, if you like.
2649 need_tagformat 'new', "quilt mode $quilt_mode"
2650 if quiltmode_splitbrain;
2654 access_giturl(); # check that success is vaguely likely
2657 my $clogpfn = ".git/dgit/changelog.822.tmp";
2658 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2660 responder_send_file('parsed-changelog', $clogpfn);
2662 my ($clogp, $cversion, $dscfn) =
2663 push_parse_changelog("$clogpfn");
2665 my $dscpath = "$buildproductsdir/$dscfn";
2666 stat_exists $dscpath or
2667 fail "looked for .dsc $dscfn, but $!;".
2668 " maybe you forgot to build";
2670 responder_send_file('dsc', $dscpath);
2672 push_parse_dsc($dscpath, $dscfn, $cversion);
2674 my $format = getfield $dsc, 'Format';
2675 printdebug "format $format\n";
2677 my $actualhead = git_rev_parse('HEAD');
2678 my $dgithead = $actualhead;
2679 my $maintviewhead = undef;
2681 if (madformat($format)) {
2682 # user might have not used dgit build, so maybe do this now:
2683 if (quiltmode_splitbrain()) {
2684 my $upstreamversion = $clogp->{Version};
2685 $upstreamversion =~ s/-[^-]*$//;
2687 quilt_make_fake_dsc($upstreamversion);
2688 my ($dgitview, $cachekey) =
2689 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2691 "--quilt=$quilt_mode but no cached dgit view:
2692 perhaps tree changed since dgit build[-source] ?";
2694 $dgithead = splitbrain_pseudomerge($clogp,
2695 $actualhead, $dgitview,
2697 $maintviewhead = $actualhead;
2698 changedir '../../../..';
2699 prep_ud(); # so _only_subdir() works, below
2701 commit_quilty_patch();
2708 if ($archive_hash) {
2709 if (is_fast_fwd($archive_hash, $dgithead)) {
2711 } elsif (deliberately_not_fast_forward) {
2714 fail "dgit push: HEAD is not a descendant".
2715 " of the archive's version.\n".
2716 "dgit: To overwrite its contents,".
2717 " use git merge -s ours ".lrref().".\n".
2718 "dgit: To rewind history, if permitted by the archive,".
2719 " use --deliberately-not-fast-forward";
2724 progress "checking that $dscfn corresponds to HEAD";
2725 runcmd qw(dpkg-source -x --),
2726 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2727 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2728 check_for_vendor_patches() if madformat($dsc->{format});
2729 changedir '../../../..';
2730 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2731 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2732 debugcmd "+",@diffcmd;
2734 my $r = system @diffcmd;
2737 fail "$dscfn specifies a different tree to your HEAD commit;".
2738 " perhaps you forgot to build".
2739 ($diffopt eq '--exit-code' ? "" :
2740 " (run with -D to see full diff output)");
2745 if (!$changesfile) {
2746 my $pat = changespat $cversion;
2747 my @cs = glob "$buildproductsdir/$pat";
2748 fail "failed to find unique changes file".
2749 " (looked for $pat in $buildproductsdir);".
2750 " perhaps you need to use dgit -C"
2752 ($changesfile) = @cs;
2754 $changesfile = "$buildproductsdir/$changesfile";
2757 # Checks complete, we're going to try and go ahead:
2759 responder_send_file('changes',$changesfile);
2760 responder_send_command("param head $dgithead");
2761 responder_send_command("param csuite $csuite");
2762 responder_send_command("param tagformat $tagformat");
2763 if (defined $maintviewhead) {
2764 die unless ($protovsn//4) >= 4;
2765 responder_send_command("param maint-view $maintviewhead");
2768 if (deliberately_not_fast_forward) {
2769 git_for_each_ref(lrfetchrefs, sub {
2770 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2771 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2772 responder_send_command("previously $rrefname=$objid");
2773 $previously{$rrefname} = $objid;
2777 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2781 supplementary_message(<<'END');
2782 Push failed, while signing the tag.
2783 You can retry the push, after fixing the problem, if you like.
2785 # If we manage to sign but fail to record it anywhere, it's fine.
2786 if ($we_are_responder) {
2787 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2788 responder_receive_files('signed-tag', @tagobjfns);
2790 @tagobjfns = push_mktags($clogp,$dscpath,
2791 $changesfile,$changesfile,
2794 supplementary_message(<<'END');
2795 Push failed, *after* signing the tag.
2796 If you want to try again, you should use a new version number.
2799 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2801 foreach my $tw (@tagwants) {
2802 my $tag = $tw->{Tag};
2803 my $tagobjfn = $tw->{TagObjFn};
2805 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2806 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2807 runcmd_ordryrun_local
2808 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2811 supplementary_message(<<'END');
2812 Push failed, while updating the remote git repository - see messages above.
2813 If you want to try again, you should use a new version number.
2815 if (!check_for_git()) {
2816 create_remote_git_repo();
2819 my @pushrefs = $forceflag.$dgithead.":".rrref();
2820 foreach my $tw (@tagwants) {
2821 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2824 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2825 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2827 supplementary_message(<<'END');
2828 Push failed, after updating the remote git repository.
2829 If you want to try again, you must use a new version number.
2831 if ($we_are_responder) {
2832 my $dryrunsuffix = act_local() ? "" : ".tmp";
2833 responder_receive_files('signed-dsc-changes',
2834 "$dscpath$dryrunsuffix",
2835 "$changesfile$dryrunsuffix");
2838 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2840 progress "[new .dsc left in $dscpath.tmp]";
2842 sign_changes $changesfile;
2845 supplementary_message(<<END);
2846 Push failed, while uploading package(s) to the archive server.
2847 You can retry the upload of exactly these same files with dput of:
2849 If that .changes file is broken, you will need to use a new version
2850 number for your next attempt at the upload.
2852 my $host = access_cfg('upload-host','RETURN-UNDEF');
2853 my @hostarg = defined($host) ? ($host,) : ();
2854 runcmd_ordryrun @dput, @hostarg, $changesfile;
2855 printdone "pushed and uploaded $cversion";
2857 supplementary_message('');
2858 responder_send_command("complete");
2865 badusage "-p is not allowed with clone; specify as argument instead"
2866 if defined $package;
2869 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2870 ($package,$isuite) = @ARGV;
2871 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2872 ($package,$dstdir) = @ARGV;
2873 } elsif (@ARGV==3) {
2874 ($package,$isuite,$dstdir) = @ARGV;
2876 badusage "incorrect arguments to dgit clone";
2878 $dstdir ||= "$package";
2880 if (stat_exists $dstdir) {
2881 fail "$dstdir already exists";
2885 if ($rmonerror && !$dryrun_level) {
2886 $cwd_remove= getcwd();
2888 return unless defined $cwd_remove;
2889 if (!chdir "$cwd_remove") {
2890 return if $!==&ENOENT;
2891 die "chdir $cwd_remove: $!";
2894 rmtree($dstdir) or die "remove $dstdir: $!\n";
2895 } elsif (!grep { $! == $_ }
2896 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2898 print STDERR "check whether to remove $dstdir: $!\n";
2904 $cwd_remove = undef;
2907 sub branchsuite () {
2908 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2909 if ($branch =~ m#$lbranch_re#o) {
2916 sub fetchpullargs () {
2918 if (!defined $package) {
2919 my $sourcep = parsecontrol('debian/control','debian/control');
2920 $package = getfield $sourcep, 'Source';
2923 # $isuite = branchsuite(); # this doesn't work because dak hates canons
2925 my $clogp = parsechangelog();
2926 $isuite = getfield $clogp, 'Distribution';
2928 canonicalise_suite();
2929 progress "fetching from suite $csuite";
2930 } elsif (@ARGV==1) {
2932 canonicalise_suite();
2934 badusage "incorrect arguments to dgit fetch or dgit pull";
2953 badusage "-p is not allowed with dgit push" if defined $package;
2955 my $clogp = parsechangelog();
2956 $package = getfield $clogp, 'Source';
2959 } elsif (@ARGV==1) {
2960 ($specsuite) = (@ARGV);
2962 badusage "incorrect arguments to dgit push";
2964 $isuite = getfield $clogp, 'Distribution';
2966 local ($package) = $existing_package; # this is a hack
2967 canonicalise_suite();
2969 canonicalise_suite();
2971 if (defined $specsuite &&
2972 $specsuite ne $isuite &&
2973 $specsuite ne $csuite) {
2974 fail "dgit push: changelog specifies $isuite ($csuite)".
2975 " but command line specifies $specsuite";
2980 #---------- remote commands' implementation ----------
2982 sub cmd_remote_push_build_host {
2983 my ($nrargs) = shift @ARGV;
2984 my (@rargs) = @ARGV[0..$nrargs-1];
2985 @ARGV = @ARGV[$nrargs..$#ARGV];
2987 my ($dir,$vsnwant) = @rargs;
2988 # vsnwant is a comma-separated list; we report which we have
2989 # chosen in our ready response (so other end can tell if they
2992 $we_are_responder = 1;
2993 $us .= " (build host)";
2997 open PI, "<&STDIN" or die $!;
2998 open STDIN, "/dev/null" or die $!;
2999 open PO, ">&STDOUT" or die $!;
3001 open STDOUT, ">&STDERR" or die $!;
3005 ($protovsn) = grep {
3006 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3007 } @rpushprotovsn_support;
3009 fail "build host has dgit rpush protocol versions ".
3010 (join ",", @rpushprotovsn_support).
3011 " but invocation host has $vsnwant"
3012 unless defined $protovsn;
3014 responder_send_command("dgit-remote-push-ready $protovsn");
3015 rpush_handle_protovsn_bothends();
3020 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3021 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3022 # a good error message)
3024 sub rpush_handle_protovsn_bothends () {
3025 if ($protovsn < 4) {
3026 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3035 my $report = i_child_report();
3036 if (defined $report) {
3037 printdebug "($report)\n";
3038 } elsif ($i_child_pid) {
3039 printdebug "(killing build host child $i_child_pid)\n";
3040 kill 15, $i_child_pid;
3042 if (defined $i_tmp && !defined $initiator_tempdir) {
3044 eval { rmtree $i_tmp; };
3048 END { i_cleanup(); }
3051 my ($base,$selector,@args) = @_;
3052 $selector =~ s/\-/_/g;
3053 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3060 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3068 push @rargs, join ",", @rpushprotovsn_support;
3071 push @rdgit, @ropts;
3072 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3074 my @cmd = (@ssh, $host, shellquote @rdgit);
3077 if (defined $initiator_tempdir) {
3078 rmtree $initiator_tempdir;
3079 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3080 $i_tmp = $initiator_tempdir;
3084 $i_child_pid = open2(\*RO, \*RI, @cmd);
3086 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3087 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3088 $supplementary_message = '' unless $protovsn >= 3;
3090 fail "rpush negotiated protocol version $protovsn".
3091 " which does not support quilt mode $quilt_mode"
3092 if quiltmode_splitbrain;
3094 rpush_handle_protovsn_bothends();
3096 my ($icmd,$iargs) = initiator_expect {
3097 m/^(\S+)(?: (.*))?$/;
3100 i_method "i_resp", $icmd, $iargs;
3104 sub i_resp_progress ($) {
3106 my $msg = protocol_read_bytes \*RO, $rhs;
3110 sub i_resp_supplementary_message ($) {
3112 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3115 sub i_resp_complete {
3116 my $pid = $i_child_pid;
3117 $i_child_pid = undef; # prevents killing some other process with same pid
3118 printdebug "waiting for build host child $pid...\n";
3119 my $got = waitpid $pid, 0;
3120 die $! unless $got == $pid;
3121 die "build host child failed $?" if $?;
3124 printdebug "all done\n";
3128 sub i_resp_file ($) {
3130 my $localname = i_method "i_localname", $keyword;
3131 my $localpath = "$i_tmp/$localname";
3132 stat_exists $localpath and
3133 badproto \*RO, "file $keyword ($localpath) twice";
3134 protocol_receive_file \*RO, $localpath;
3135 i_method "i_file", $keyword;
3140 sub i_resp_param ($) {
3141 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3145 sub i_resp_previously ($) {
3146 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3147 or badproto \*RO, "bad previously spec";
3148 my $r = system qw(git check-ref-format), $1;
3149 die "bad previously ref spec ($r)" if $r;
3150 $previously{$1} = $2;
3155 sub i_resp_want ($) {
3157 die "$keyword ?" if $i_wanted{$keyword}++;
3158 my @localpaths = i_method "i_want", $keyword;
3159 printdebug "[[ $keyword @localpaths\n";
3160 foreach my $localpath (@localpaths) {
3161 protocol_send_file \*RI, $localpath;
3163 print RI "files-end\n" or die $!;
3166 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3168 sub i_localname_parsed_changelog {
3169 return "remote-changelog.822";
3171 sub i_file_parsed_changelog {
3172 ($i_clogp, $i_version, $i_dscfn) =
3173 push_parse_changelog "$i_tmp/remote-changelog.822";
3174 die if $i_dscfn =~ m#/|^\W#;
3177 sub i_localname_dsc {
3178 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3183 sub i_localname_changes {
3184 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3185 $i_changesfn = $i_dscfn;
3186 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3187 return $i_changesfn;
3189 sub i_file_changes { }
3191 sub i_want_signed_tag {
3192 printdebug Dumper(\%i_param, $i_dscfn);
3193 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3194 && defined $i_param{'csuite'}
3195 or badproto \*RO, "premature desire for signed-tag";
3196 my $head = $i_param{'head'};
3197 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3199 my $maintview = $i_param{'maint-view'};
3200 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3203 if ($protovsn >= 4) {
3204 my $p = $i_param{'tagformat'} // '<undef>';
3206 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3209 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3211 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3213 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3216 push_mktags $i_clogp, $i_dscfn,
3217 $i_changesfn, 'remote changes',
3221 sub i_want_signed_dsc_changes {
3222 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3223 sign_changes $i_changesfn;
3224 return ($i_dscfn, $i_changesfn);
3227 #---------- building etc. ----------
3233 #----- `3.0 (quilt)' handling -----
3235 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3237 sub quiltify_dpkg_commit ($$$;$) {
3238 my ($patchname,$author,$msg, $xinfo) = @_;
3242 my $descfn = ".git/dgit/quilt-description.tmp";
3243 open O, '>', $descfn or die "$descfn: $!";
3246 $msg =~ s/^\s+$/ ./mg;
3247 print O <<END or die $!;
3257 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3258 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3259 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3260 runcmd @dpkgsource, qw(--commit .), $patchname;
3264 sub quiltify_trees_differ ($$;$$) {
3265 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3266 # returns true iff the two tree objects differ other than in debian/
3267 # with $finegrained,
3268 # returns bitmask 01 - differ in upstream files except .gitignore
3269 # 02 - differ in .gitignore
3270 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3271 # is set for each modified .gitignore filename $fn
3273 my @cmd = (@git, qw(diff-tree --name-only -z));
3274 push @cmd, qw(-r) if $finegrained;
3276 my $diffs= cmdoutput @cmd;
3278 foreach my $f (split /\0/, $diffs) {
3279 next if $f =~ m#^debian(?:/.*)?$#s;
3280 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3281 $r |= $isignore ? 02 : 01;
3282 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3284 printdebug "quiltify_trees_differ $x $y => $r\n";
3288 sub quiltify_tree_sentinelfiles ($) {
3289 # lists the `sentinel' files present in the tree
3291 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3292 qw(-- debian/rules debian/control);
3297 sub quiltify_splitbrain_needed () {
3298 if (!$split_brain) {
3299 progress "dgit view: changes are required...";
3300 runcmd @git, qw(checkout -q -b dgit-view);
3305 sub quiltify_splitbrain ($$$$$$) {
3306 my ($clogp, $unapplied, $headref, $diffbits,
3307 $editedignores, $cachekey) = @_;
3308 if ($quilt_mode !~ m/gbp|dpm/) {
3309 # treat .gitignore just like any other upstream file
3310 $diffbits = { %$diffbits };
3311 $_ = !!$_ foreach values %$diffbits;
3313 # We would like any commits we generate to be reproducible
3314 my @authline = clogp_authline($clogp);
3315 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3316 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3317 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3319 if ($quilt_mode =~ m/gbp|unapplied/ &&
3320 ($diffbits->{H2O} & 01)) {
3322 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3323 " but git tree differs from orig in upstream files.";
3324 if (!stat_exists "debian/patches") {
3326 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3330 if ($quilt_mode =~ m/dpm/ &&
3331 ($diffbits->{H2A} & 01)) {
3333 --quilt=$quilt_mode specified, implying patches-applied git tree
3334 but git tree differs from result of applying debian/patches to upstream
3337 if ($quilt_mode =~ m/gbp|unapplied/ &&
3338 ($diffbits->{O2A} & 01)) { # some patches
3339 quiltify_splitbrain_needed();
3340 progress "dgit view: creating patches-applied version using gbp pq";
3341 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3342 # gbp pq import creates a fresh branch; push back to dgit-view
3343 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3344 runcmd @git, qw(checkout -q dgit-view);
3346 if ($quilt_mode =~ m/gbp|dpm/ &&
3347 ($diffbits->{O2A} & 02)) {
3349 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3350 tool which does not create patches for changes to upstream
3351 .gitignores: but, such patches exist in debian/patches.
3354 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3355 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3356 quiltify_splitbrain_needed();
3357 progress "dgit view: creating patch to represent .gitignore changes";
3358 ensuredir "debian/patches";
3359 my $gipatch = "debian/patches/auto-gitignore";
3360 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3361 stat GIPATCH or die "$gipatch: $!";
3362 fail "$gipatch already exists; but want to create it".
3363 " to record .gitignore changes" if (stat _)[7];
3364 print GIPATCH <<END or die "$gipatch: $!";
3365 Subject: Update .gitignore from Debian packaging branch
3367 The Debian packaging git branch contains these updates to the upstream
3368 .gitignore file(s). This patch is autogenerated, to provide these
3369 updates to users of the official Debian archive view of the package.
3371 [dgit version $our_version]
3374 close GIPATCH or die "$gipatch: $!";
3375 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3376 $unapplied, $headref, "--", sort keys %$editedignores;
3377 open SERIES, "+>>", "debian/patches/series" or die $!;
3378 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3380 defined read SERIES, $newline, 1 or die $!;
3381 print SERIES "\n" or die $! unless $newline eq "\n";
3382 print SERIES "auto-gitignore\n" or die $!;
3383 close SERIES or die $!;
3384 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3385 commit_admin "Commit patch to update .gitignore";
3388 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3390 changedir '../../../..';
3391 ensuredir ".git/logs/refs/dgit-intern";
3392 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3394 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3397 progress "dgit view: created (commit id $dgitview)";
3399 changedir '.git/dgit/unpack/work';
3402 sub quiltify ($$$$) {
3403 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3405 # Quilt patchification algorithm
3407 # We search backwards through the history of the main tree's HEAD
3408 # (T) looking for a start commit S whose tree object is identical
3409 # to to the patch tip tree (ie the tree corresponding to the
3410 # current dpkg-committed patch series). For these purposes
3411 # `identical' disregards anything in debian/ - this wrinkle is
3412 # necessary because dpkg-source treates debian/ specially.
3414 # We can only traverse edges where at most one of the ancestors'
3415 # trees differs (in changes outside in debian/). And we cannot
3416 # handle edges which change .pc/ or debian/patches. To avoid
3417 # going down a rathole we avoid traversing edges which introduce
3418 # debian/rules or debian/control. And we set a limit on the
3419 # number of edges we are willing to look at.
3421 # If we succeed, we walk forwards again. For each traversed edge
3422 # PC (with P parent, C child) (starting with P=S and ending with
3423 # C=T) to we do this:
3425 # - dpkg-source --commit with a patch name and message derived from C
3426 # After traversing PT, we git commit the changes which
3427 # should be contained within debian/patches.
3429 # The search for the path S..T is breadth-first. We maintain a
3430 # todo list containing search nodes. A search node identifies a
3431 # commit, and looks something like this:
3433 # Commit => $git_commit_id,
3434 # Child => $c, # or undef if P=T
3435 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3436 # Nontrivial => true iff $p..$c has relevant changes
3443 my %considered; # saves being exponential on some weird graphs
3445 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3448 my ($search,$whynot) = @_;
3449 printdebug " search NOT $search->{Commit} $whynot\n";
3450 $search->{Whynot} = $whynot;
3451 push @nots, $search;
3452 no warnings qw(exiting);
3461 my $c = shift @todo;
3462 next if $considered{$c->{Commit}}++;
3464 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3466 printdebug "quiltify investigate $c->{Commit}\n";
3469 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3470 printdebug " search finished hooray!\n";
3475 if ($quilt_mode eq 'nofix') {
3476 fail "quilt fixup required but quilt mode is \`nofix'\n".
3477 "HEAD commit $c->{Commit} differs from tree implied by ".
3478 " debian/patches (tree object $oldtiptree)";
3480 if ($quilt_mode eq 'smash') {
3481 printdebug " search quitting smash\n";
3485 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3486 $not->($c, "has $c_sentinels not $t_sentinels")
3487 if $c_sentinels ne $t_sentinels;
3489 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3490 $commitdata =~ m/\n\n/;
3492 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3493 @parents = map { { Commit => $_, Child => $c } } @parents;
3495 $not->($c, "root commit") if !@parents;
3497 foreach my $p (@parents) {
3498 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3500 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3501 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3503 foreach my $p (@parents) {
3504 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3506 my @cmd= (@git, qw(diff-tree -r --name-only),
3507 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3508 my $patchstackchange = cmdoutput @cmd;
3509 if (length $patchstackchange) {
3510 $patchstackchange =~ s/\n/,/g;
3511 $not->($p, "changed $patchstackchange");
3514 printdebug " search queue P=$p->{Commit} ",
3515 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3521 printdebug "quiltify want to smash\n";
3524 my $x = $_[0]{Commit};
3525 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3528 my $reportnot = sub {
3530 my $s = $abbrev->($notp);
3531 my $c = $notp->{Child};
3532 $s .= "..".$abbrev->($c) if $c;
3533 $s .= ": ".$notp->{Whynot};
3536 if ($quilt_mode eq 'linear') {
3537 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3538 foreach my $notp (@nots) {
3539 print STDERR "$us: ", $reportnot->($notp), "\n";
3541 print STDERR "$us: $_\n" foreach @$failsuggestion;
3542 fail "quilt fixup naive history linearisation failed.\n".
3543 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3544 } elsif ($quilt_mode eq 'smash') {
3545 } elsif ($quilt_mode eq 'auto') {
3546 progress "quilt fixup cannot be linear, smashing...";
3548 die "$quilt_mode ?";
3551 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3552 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3554 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3556 quiltify_dpkg_commit "auto-$version-$target-$time",
3557 (getfield $clogp, 'Maintainer'),
3558 "Automatically generated patch ($clogp->{Version})\n".
3559 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3563 progress "quiltify linearisation planning successful, executing...";
3565 for (my $p = $sref_S;
3566 my $c = $p->{Child};
3568 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3569 next unless $p->{Nontrivial};
3571 my $cc = $c->{Commit};
3573 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3574 $commitdata =~ m/\n\n/ or die "$c ?";
3577 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3580 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3583 my $patchname = $title;
3584 $patchname =~ s/[.:]$//;
3585 $patchname =~ y/ A-Z/-a-z/;
3586 $patchname =~ y/-a-z0-9_.+=~//cd;
3587 $patchname =~ s/^\W/x-$&/;
3588 $patchname = substr($patchname,0,40);
3591 stat "debian/patches/$patchname$index";
3593 $!==ENOENT or die "$patchname$index $!";
3595 runcmd @git, qw(checkout -q), $cc;
3597 # We use the tip's changelog so that dpkg-source doesn't
3598 # produce complaining messages from dpkg-parsechangelog. None
3599 # of the information dpkg-source gets from the changelog is
3600 # actually relevant - it gets put into the original message
3601 # which dpkg-source provides our stunt editor, and then
3603 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3605 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3606 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3608 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3611 runcmd @git, qw(checkout -q master);
3614 sub build_maybe_quilt_fixup () {
3615 my ($format,$fopts) = get_source_format;
3616 return unless madformat $format;
3619 check_for_vendor_patches();
3621 my $clogp = parsechangelog();
3622 my $headref = git_rev_parse('HEAD');
3627 my $upstreamversion=$version;
3628 $upstreamversion =~ s/-[^-]*$//;
3630 if ($fopts->{'single-debian-patch'}) {
3631 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3633 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3636 die 'bug' if $split_brain && !$need_split_build_invocation;
3638 changedir '../../../..';
3639 runcmd_ordryrun_local
3640 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3643 sub quilt_fixup_mkwork ($) {
3646 mkdir "work" or die $!;
3648 mktree_in_ud_here();
3649 runcmd @git, qw(reset -q --hard), $headref;
3652 sub quilt_fixup_linkorigs ($$) {
3653 my ($upstreamversion, $fn) = @_;
3654 # calls $fn->($leafname);
3656 foreach my $f (<../../../../*>) { #/){
3657 my $b=$f; $b =~ s{.*/}{};
3659 local ($debuglevel) = $debuglevel-1;
3660 printdebug "QF linkorigs $b, $f ?\n";
3662 next unless is_orig_file $b, srcfn $upstreamversion,'';
3663 printdebug "QF linkorigs $b, $f Y\n";
3664 link_ltarget $f, $b or die "$b $!";
3669 sub quilt_fixup_delete_pc () {
3670 runcmd @git, qw(rm -rqf .pc);
3671 commit_admin "Commit removal of .pc (quilt series tracking data)";
3674 sub quilt_fixup_singlepatch ($$$) {
3675 my ($clogp, $headref, $upstreamversion) = @_;
3677 progress "starting quiltify (single-debian-patch)";
3679 # dpkg-source --commit generates new patches even if
3680 # single-debian-patch is in debian/source/options. In order to
3681 # get it to generate debian/patches/debian-changes, it is
3682 # necessary to build the source package.
3684 quilt_fixup_linkorigs($upstreamversion, sub { });
3685 quilt_fixup_mkwork($headref);
3687 rmtree("debian/patches");
3689 runcmd @dpkgsource, qw(-b .);
3691 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3692 rename srcfn("$upstreamversion", "/debian/patches"),
3693 "work/debian/patches";
3696 commit_quilty_patch();
3699 sub quilt_make_fake_dsc ($) {
3700 my ($upstreamversion) = @_;
3702 my $fakeversion="$upstreamversion-~~DGITFAKE";
3704 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3705 print $fakedsc <<END or die $!;
3708 Version: $fakeversion
3712 my $dscaddfile=sub {
3715 my $md = new Digest::MD5;
3717 my $fh = new IO::File $b, '<' or die "$b $!";
3722 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3725 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3727 my @files=qw(debian/source/format debian/rules
3728 debian/control debian/changelog);
3729 foreach my $maybe (qw(debian/patches debian/source/options
3730 debian/tests/control)) {
3731 next unless stat_exists "../../../$maybe";
3732 push @files, $maybe;
3735 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3736 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3738 $dscaddfile->($debtar);
3739 close $fakedsc or die $!;
3742 sub quilt_check_splitbrain_cache ($$) {
3743 my ($headref, $upstreamversion) = @_;
3744 # Called only if we are in (potentially) split brain mode.
3746 # Computes the cache key and looks in the cache.
3747 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3749 my $splitbrain_cachekey;
3752 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3753 # we look in the reflog of dgit-intern/quilt-cache
3754 # we look for an entry whose message is the key for the cache lookup
3755 my @cachekey = (qw(dgit), $our_version);
3756 push @cachekey, $upstreamversion;
3757 push @cachekey, $quilt_mode;
3758 push @cachekey, $headref;
3760 push @cachekey, hashfile('fake.dsc');
3762 my $srcshash = Digest::SHA->new(256);
3763 my %sfs = ( %INC, '$0(dgit)' => $0 );
3764 foreach my $sfk (sort keys %sfs) {
3765 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3766 $srcshash->add($sfk," ");
3767 $srcshash->add(hashfile($sfs{$sfk}));
3768 $srcshash->add("\n");
3770 push @cachekey, $srcshash->hexdigest();
3771 $splitbrain_cachekey = "@cachekey";
3773 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3775 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3776 debugcmd "|(probably)",@cmd;
3777 my $child = open GC, "-|"; defined $child or die $!;
3779 chdir '../../..' or die $!;
3780 if (!stat ".git/logs/refs/$splitbraincache") {
3781 $! == ENOENT or die $!;
3782 printdebug ">(no reflog)\n";
3789 printdebug ">| ", $_, "\n" if $debuglevel > 1;
3790 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3793 quilt_fixup_mkwork($headref);
3794 if ($cachehit ne $headref) {
3795 progress "dgit view: found cached (commit id $cachehit)";
3796 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3798 return ($cachehit, $splitbrain_cachekey);
3800 progress "dgit view: found cached, no changes required";
3801 return ($headref, $splitbrain_cachekey);
3803 die $! if GC->error;
3804 failedcmd unless close GC;
3806 printdebug "splitbrain cache miss\n";
3807 return (undef, $splitbrain_cachekey);
3810 sub quilt_fixup_multipatch ($$$) {
3811 my ($clogp, $headref, $upstreamversion) = @_;
3813 progress "examining quilt state (multiple patches, $quilt_mode mode)";
3816 # - honour any existing .pc in case it has any strangeness
3817 # - determine the git commit corresponding to the tip of
3818 # the patch stack (if there is one)
3819 # - if there is such a git commit, convert each subsequent
3820 # git commit into a quilt patch with dpkg-source --commit
3821 # - otherwise convert all the differences in the tree into
3822 # a single git commit
3826 # Our git tree doesn't necessarily contain .pc. (Some versions of
3827 # dgit would include the .pc in the git tree.) If there isn't
3828 # one, we need to generate one by unpacking the patches that we
3831 # We first look for a .pc in the git tree. If there is one, we
3832 # will use it. (This is not the normal case.)
3834 # Otherwise need to regenerate .pc so that dpkg-source --commit
3835 # can work. We do this as follows:
3836 # 1. Collect all relevant .orig from parent directory
3837 # 2. Generate a debian.tar.gz out of
3838 # debian/{patches,rules,source/format,source/options}
3839 # 3. Generate a fake .dsc containing just these fields:
3840 # Format Source Version Files
3841 # 4. Extract the fake .dsc
3842 # Now the fake .dsc has a .pc directory.
3843 # (In fact we do this in every case, because in future we will
3844 # want to search for a good base commit for generating patches.)
3846 # Then we can actually do the dpkg-source --commit
3847 # 1. Make a new working tree with the same object
3848 # store as our main tree and check out the main
3850 # 2. Copy .pc from the fake's extraction, if necessary
3851 # 3. Run dpkg-source --commit
3852 # 4. If the result has changes to debian/, then
3853 # - git-add them them
3854 # - git-add .pc if we had a .pc in-tree
3856 # 5. If we had a .pc in-tree, delete it, and git-commit
3857 # 6. Back in the main tree, fast forward to the new HEAD
3859 # Another situation we may have to cope with is gbp-style
3860 # patches-unapplied trees.
3862 # We would want to detect these, so we know to escape into
3863 # quilt_fixup_gbp. However, this is in general not possible.
3864 # Consider a package with a one patch which the dgit user reverts
3865 # (with git-revert or the moral equivalent).
3867 # That is indistinguishable in contents from a patches-unapplied
3868 # tree. And looking at the history to distinguish them is not
3869 # useful because the user might have made a confusing-looking git
3870 # history structure (which ought to produce an error if dgit can't
3871 # cope, not a silent reintroduction of an unwanted patch).
3873 # So gbp users will have to pass an option. But we can usually
3874 # detect their failure to do so: if the tree is not a clean
3875 # patches-applied tree, quilt linearisation fails, but the tree
3876 # _is_ a clean patches-unapplied tree, we can suggest that maybe
3877 # they want --quilt=unapplied.
3879 # To help detect this, when we are extracting the fake dsc, we
3880 # first extract it with --skip-patches, and then apply the patches
3881 # afterwards with dpkg-source --before-build. That lets us save a
3882 # tree object corresponding to .origs.
3884 my $splitbrain_cachekey;
3886 quilt_make_fake_dsc($upstreamversion);
3888 if (quiltmode_splitbrain()) {
3890 ($cachehit, $splitbrain_cachekey) =
3891 quilt_check_splitbrain_cache($headref, $upstreamversion);
3892 return if $cachehit;
3896 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3898 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3899 rename $fakexdir, "fake" or die "$fakexdir $!";
3903 remove_stray_gits();
3904 mktree_in_ud_here();
3908 runcmd @git, qw(add -Af .);
3909 my $unapplied=git_write_tree();
3910 printdebug "fake orig tree object $unapplied\n";
3915 'exec dpkg-source --before-build . >/dev/null';
3919 quilt_fixup_mkwork($headref);
3922 if (stat_exists ".pc") {
3924 progress "Tree already contains .pc - will use it then delete it.";
3927 rename '../fake/.pc','.pc' or die $!;
3930 changedir '../fake';
3932 runcmd @git, qw(add -Af .);
3933 my $oldtiptree=git_write_tree();
3934 printdebug "fake o+d/p tree object $unapplied\n";
3935 changedir '../work';
3938 # We calculate some guesswork now about what kind of tree this might
3939 # be. This is mostly for error reporting.
3944 # O = orig, without patches applied
3945 # A = "applied", ie orig with H's debian/patches applied
3946 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
3947 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
3948 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3952 foreach my $b (qw(01 02)) {
3953 foreach my $v (qw(H2O O2A H2A)) {
3954 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3957 printdebug "differences \@dl @dl.\n";
3960 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
3961 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
3962 $dl[0], $dl[1], $dl[3], $dl[4],
3966 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3967 push @failsuggestion, "This might be a patches-unapplied branch.";
3968 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3969 push @failsuggestion, "This might be a patches-applied branch.";
3971 push @failsuggestion, "Maybe you need to specify one of".
3972 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3974 if (quiltmode_splitbrain()) {
3975 quiltify_splitbrain($clogp, $unapplied, $headref,
3976 $diffbits, \%editedignores,
3977 $splitbrain_cachekey);
3981 progress "starting quiltify (multiple patches, $quilt_mode mode)";
3982 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3984 if (!open P, '>>', ".pc/applied-patches") {
3985 $!==&ENOENT or die $!;
3990 commit_quilty_patch();
3992 if ($mustdeletepc) {
3993 quilt_fixup_delete_pc();
3997 sub quilt_fixup_editor () {
3998 my $descfn = $ENV{$fakeeditorenv};
3999 my $editing = $ARGV[$#ARGV];
4000 open I1, '<', $descfn or die "$descfn: $!";
4001 open I2, '<', $editing or die "$editing: $!";
4002 unlink $editing or die "$editing: $!";
4003 open O, '>', $editing or die "$editing: $!";
4004 while (<I1>) { print O or die $!; } I1->error and die $!;
4007 $copying ||= m/^\-\-\- /;
4008 next unless $copying;
4011 I2->error and die $!;
4016 sub maybe_apply_patches_dirtily () {
4017 return unless $quilt_mode =~ m/gbp|unapplied/;
4018 print STDERR <<END or die $!;
4020 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4021 dgit: Have to apply the patches - making the tree dirty.
4022 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4025 $patches_applied_dirtily = 01;
4026 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4027 runcmd qw(dpkg-source --before-build .);
4030 sub maybe_unapply_patches_again () {
4031 progress "dgit: Unapplying patches again to tidy up the tree."
4032 if $patches_applied_dirtily;
4033 runcmd qw(dpkg-source --after-build .)
4034 if $patches_applied_dirtily & 01;
4036 if $patches_applied_dirtily & 02;
4037 $patches_applied_dirtily = 0;
4040 #----- other building -----
4042 our $clean_using_builder;
4043 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4044 # clean the tree before building (perhaps invoked indirectly by
4045 # whatever we are using to run the build), rather than separately
4046 # and explicitly by us.
4049 return if $clean_using_builder;
4050 if ($cleanmode eq 'dpkg-source') {
4051 maybe_apply_patches_dirtily();
4052 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4053 } elsif ($cleanmode eq 'dpkg-source-d') {
4054 maybe_apply_patches_dirtily();
4055 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4056 } elsif ($cleanmode eq 'git') {
4057 runcmd_ordryrun_local @git, qw(clean -xdf);
4058 } elsif ($cleanmode eq 'git-ff') {
4059 runcmd_ordryrun_local @git, qw(clean -xdff);
4060 } elsif ($cleanmode eq 'check') {
4061 my $leftovers = cmdoutput @git, qw(clean -xdn);
4062 if (length $leftovers) {
4063 print STDERR $leftovers, "\n" or die $!;
4064 fail "tree contains uncommitted files and --clean=check specified";
4066 } elsif ($cleanmode eq 'none') {
4073 badusage "clean takes no additional arguments" if @ARGV;
4076 maybe_unapply_patches_again();
4081 badusage "-p is not allowed when building" if defined $package;
4084 my $clogp = parsechangelog();
4085 $isuite = getfield $clogp, 'Distribution';
4086 $package = getfield $clogp, 'Source';
4087 $version = getfield $clogp, 'Version';
4088 build_maybe_quilt_fixup();
4090 my $pat = changespat $version;
4091 foreach my $f (glob "$buildproductsdir/$pat") {
4093 unlink $f or fail "remove old changes file $f: $!";
4095 progress "would remove $f";
4101 sub changesopts_initial () {
4102 my @opts =@changesopts[1..$#changesopts];
4105 sub changesopts_version () {
4106 if (!defined $changes_since_version) {
4107 my @vsns = archive_query('archive_query');
4108 my @quirk = access_quirk();
4109 if ($quirk[0] eq 'backports') {
4110 local $isuite = $quirk[2];
4112 canonicalise_suite();
4113 push @vsns, archive_query('archive_query');
4116 @vsns = map { $_->[0] } @vsns;
4117 @vsns = sort { -version_compare($a, $b) } @vsns;
4118 $changes_since_version = $vsns[0];
4119 progress "changelog will contain changes since $vsns[0]";
4121 $changes_since_version = '_';
4122 progress "package seems new, not specifying -v<version>";
4125 if ($changes_since_version ne '_') {
4126 return ("-v$changes_since_version");
4132 sub changesopts () {
4133 return (changesopts_initial(), changesopts_version());
4136 sub massage_dbp_args ($;$) {
4137 my ($cmd,$xargs) = @_;
4140 # - if we're going to split the source build out so we can
4141 # do strange things to it, massage the arguments to dpkg-buildpackage
4142 # so that the main build doessn't build source (or add an argument
4143 # to stop it building source by default).
4145 # - add -nc to stop dpkg-source cleaning the source tree,
4146 # unless we're not doing a split build and want dpkg-source
4147 # as cleanmode, in which case we can do nothing
4150 # 0 - source will NOT need to be built separately by caller
4151 # +1 - source will need to be built separately by caller
4152 # +2 - source will need to be built separately by caller AND
4153 # dpkg-buildpackage should not in fact be run at all!
4154 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4155 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4156 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4157 $clean_using_builder = 1;
4160 # -nc has the side effect of specifying -b if nothing else specified
4161 # and some combinations of -S, -b, et al, are errors, rather than
4162 # later simply overriding earlie. So we need to:
4163 # - search the command line for these options
4164 # - pick the last one
4165 # - perhaps add our own as a default
4166 # - perhaps adjust it to the corresponding non-source-building version
4168 foreach my $l ($cmd, $xargs) {
4170 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4173 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4175 if ($need_split_build_invocation) {
4176 printdebug "massage split $dmode.\n";
4177 $r = $dmode =~ m/[S]/ ? +2 :
4178 $dmode =~ y/gGF/ABb/ ? +1 :
4179 $dmode =~ m/[ABb]/ ? 0 :
4182 printdebug "massage done $r $dmode.\n";
4184 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4189 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4190 my $wantsrc = massage_dbp_args \@dbp;
4197 push @dbp, changesopts_version();
4198 maybe_apply_patches_dirtily();
4199 runcmd_ordryrun_local @dbp;
4201 maybe_unapply_patches_again();
4202 printdone "build successful\n";
4206 my @dbp = @dpkgbuildpackage;
4208 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4211 if (length executable_on_path('git-buildpackage')) {
4212 @cmd = qw(git-buildpackage);
4214 @cmd = qw(gbp buildpackage);
4216 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4221 if (!$clean_using_builder) {
4222 push @cmd, '--git-cleaner=true';
4226 maybe_unapply_patches_again();
4228 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4229 canonicalise_suite();
4230 push @cmd, "--git-debian-branch=".lbranch();
4232 push @cmd, changesopts();
4233 runcmd_ordryrun_local @cmd, @ARGV;
4235 printdone "build successful\n";
4237 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4240 my $our_cleanmode = $cleanmode;
4241 if ($need_split_build_invocation) {
4242 # Pretend that clean is being done some other way. This
4243 # forces us not to try to use dpkg-buildpackage to clean and
4244 # build source all in one go; and instead we run dpkg-source
4245 # (and build_prep() will do the clean since $clean_using_builder
4247 $our_cleanmode = 'ELSEWHERE';
4249 if ($our_cleanmode =~ m/^dpkg-source/) {
4250 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4251 $clean_using_builder = 1;
4254 $sourcechanges = changespat $version,'source';
4256 unlink "../$sourcechanges" or $!==ENOENT
4257 or fail "remove $sourcechanges: $!";
4259 $dscfn = dscfn($version);
4260 if ($our_cleanmode eq 'dpkg-source') {
4261 maybe_apply_patches_dirtily();
4262 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4264 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4265 maybe_apply_patches_dirtily();
4266 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4269 my @cmd = (@dpkgsource, qw(-b --));
4272 runcmd_ordryrun_local @cmd, "work";
4273 my @udfiles = <${package}_*>;
4274 changedir "../../..";
4275 foreach my $f (@udfiles) {
4276 printdebug "source copy, found $f\n";
4279 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4280 $f eq srcfn($version, $&));
4281 printdebug "source copy, found $f - renaming\n";
4282 rename "$ud/$f", "../$f" or $!==ENOENT
4283 or fail "put in place new source file ($f): $!";
4286 my $pwd = must_getcwd();
4287 my $leafdir = basename $pwd;
4289 runcmd_ordryrun_local @cmd, $leafdir;
4292 runcmd_ordryrun_local qw(sh -ec),
4293 'exec >$1; shift; exec "$@"','x',
4294 "../$sourcechanges",
4295 @dpkggenchanges, qw(-S), changesopts();
4299 sub cmd_build_source {
4300 badusage "build-source takes no additional arguments" if @ARGV;
4302 maybe_unapply_patches_again();
4303 printdone "source built, results in $dscfn and $sourcechanges";
4308 my $pat = changespat $version;
4310 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4311 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4312 fail "changes files other than source matching $pat".
4313 " already present (@unwanted);".
4314 " building would result in ambiguity about the intended results"
4317 my $wasdir = must_getcwd();
4320 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4321 stat_exists $sourcechanges
4322 or fail "$sourcechanges (in parent directory): $!";
4324 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4325 my @changesfiles = glob $pat;
4326 @changesfiles = sort {
4327 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4330 fail "wrong number of different changes files (@changesfiles)"
4331 unless @changesfiles==2;
4332 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4333 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4334 fail "$l found in binaries changes file $binchanges"
4337 runcmd_ordryrun_local @mergechanges, @changesfiles;
4338 my $multichanges = changespat $version,'multi';
4340 stat_exists $multichanges or fail "$multichanges: $!";
4341 foreach my $cf (glob $pat) {
4342 next if $cf eq $multichanges;
4343 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4347 maybe_unapply_patches_again();
4348 printdone "build successful, results in $multichanges\n" or die $!;
4351 sub cmd_quilt_fixup {
4352 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4353 my $clogp = parsechangelog();
4354 $version = getfield $clogp, 'Version';
4355 $package = getfield $clogp, 'Source';
4358 build_maybe_quilt_fixup();
4361 sub cmd_archive_api_query {
4362 badusage "need only 1 subpath argument" unless @ARGV==1;
4363 my ($subpath) = @ARGV;
4364 my @cmd = archive_api_query_cmd($subpath);
4366 exec @cmd or fail "exec curl: $!\n";
4369 sub cmd_clone_dgit_repos_server {
4370 badusage "need destination argument" unless @ARGV==1;
4371 my ($destdir) = @ARGV;
4372 $package = '_dgit-repos-server';
4373 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4375 exec @cmd or fail "exec git clone: $!\n";
4378 sub cmd_setup_mergechangelogs {
4379 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4380 setup_mergechangelogs(1);
4383 sub cmd_setup_useremail {
4384 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4388 sub cmd_setup_new_tree {
4389 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4393 #---------- argument parsing and main program ----------
4396 print "dgit version $our_version\n" or die $!;
4400 our (%valopts_long, %valopts_short);
4403 sub defvalopt ($$$$) {
4404 my ($long,$short,$val_re,$how) = @_;
4405 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4406 $valopts_long{$long} = $oi;
4407 $valopts_short{$short} = $oi;
4408 # $how subref should:
4409 # do whatever assignemnt or thing it likes with $_[0]
4410 # if the option should not be passed on to remote, @rvalopts=()
4411 # or $how can be a scalar ref, meaning simply assign the value
4414 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4415 defvalopt '--distro', '-d', '.+', \$idistro;
4416 defvalopt '', '-k', '.+', \$keyid;
4417 defvalopt '--existing-package','', '.*', \$existing_package;
4418 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4419 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4420 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4422 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4424 defvalopt '', '-C', '.+', sub {
4425 ($changesfile) = (@_);
4426 if ($changesfile =~ s#^(.*)/##) {
4427 $buildproductsdir = $1;
4431 defvalopt '--initiator-tempdir','','.*', sub {
4432 ($initiator_tempdir) = (@_);
4433 $initiator_tempdir =~ m#^/# or
4434 badusage "--initiator-tempdir must be used specify an".
4435 " absolute, not relative, directory."
4441 if (defined $ENV{'DGIT_SSH'}) {
4442 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4443 } elsif (defined $ENV{'GIT_SSH'}) {
4444 @ssh = ($ENV{'GIT_SSH'});
4452 if (!defined $val) {
4453 badusage "$what needs a value" unless @ARGV;
4455 push @rvalopts, $val;
4457 badusage "bad value \`$val' for $what" unless
4458 $val =~ m/^$oi->{Re}$(?!\n)/s;
4459 my $how = $oi->{How};
4460 if (ref($how) eq 'SCALAR') {
4465 push @ropts, @rvalopts;
4469 last unless $ARGV[0] =~ m/^-/;
4473 if (m/^--dry-run$/) {
4476 } elsif (m/^--damp-run$/) {
4479 } elsif (m/^--no-sign$/) {
4482 } elsif (m/^--help$/) {
4484 } elsif (m/^--version$/) {
4486 } elsif (m/^--new$/) {
4489 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4490 ($om = $opts_opt_map{$1}) &&
4494 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4495 !$opts_opt_cmdonly{$1} &&
4496 ($om = $opts_opt_map{$1})) {
4499 } elsif (m/^--ignore-dirty$/s) {
4502 } elsif (m/^--no-quilt-fixup$/s) {
4504 $quilt_mode = 'nocheck';
4505 } elsif (m/^--no-rm-on-error$/s) {
4508 } elsif (m/^--(no-)?rm-old-changes$/s) {
4511 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4513 push @deliberatelies, $&;
4514 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4515 # undocumented, for testing
4517 $tagformat_want = [ $1, 'command line', 1 ];
4518 # 1 menas overrides distro configuration
4519 } elsif (m/^--always-split-source-build$/s) {
4520 # undocumented, for testing
4522 $need_split_build_invocation = 1;
4523 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4524 $val = $2 ? $' : undef; #';
4525 $valopt->($oi->{Long});
4527 badusage "unknown long option \`$_'";
4534 } elsif (s/^-L/-/) {
4537 } elsif (s/^-h/-/) {
4539 } elsif (s/^-D/-/) {
4543 } elsif (s/^-N/-/) {
4548 push @changesopts, $_;
4550 } elsif (s/^-wn$//s) {
4552 $cleanmode = 'none';
4553 } elsif (s/^-wg$//s) {
4556 } elsif (s/^-wgf$//s) {
4558 $cleanmode = 'git-ff';
4559 } elsif (s/^-wd$//s) {
4561 $cleanmode = 'dpkg-source';
4562 } elsif (s/^-wdd$//s) {
4564 $cleanmode = 'dpkg-source-d';
4565 } elsif (s/^-wc$//s) {
4567 $cleanmode = 'check';
4568 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4570 $val = undef unless length $val;
4571 $valopt->($oi->{Short});
4574 badusage "unknown short option \`$_'";
4581 sub finalise_opts_opts () {
4582 foreach my $k (keys %opts_opt_map) {
4583 my $om = $opts_opt_map{$k};
4585 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4587 badcfg "cannot set command for $k"
4588 unless length $om->[0];
4592 foreach my $c (access_cfg_cfgs("opts-$k")) {
4593 my $vl = $gitcfg{$c};
4594 printdebug "CL $c ",
4595 ($vl ? join " ", map { shellquote } @$vl : ""),
4596 "\n" if $debuglevel >= 4;
4598 badcfg "cannot configure options for $k"
4599 if $opts_opt_cmdonly{$k};
4600 my $insertpos = $opts_cfg_insertpos{$k};
4601 @$om = ( @$om[0..$insertpos-1],
4603 @$om[$insertpos..$#$om] );
4608 if ($ENV{$fakeeditorenv}) {
4610 quilt_fixup_editor();
4616 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4617 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4618 if $dryrun_level == 1;
4620 print STDERR $helpmsg or die $!;
4623 my $cmd = shift @ARGV;
4626 if (!defined $rmchanges) {
4627 local $access_forpush;
4628 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4631 if (!defined $quilt_mode) {
4632 local $access_forpush;
4633 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4634 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4636 $quilt_mode =~ m/^($quilt_modes_re)$/
4637 or badcfg "unknown quilt-mode \`$quilt_mode'";
4641 $need_split_build_invocation ||= quiltmode_splitbrain();
4643 if (!defined $cleanmode) {
4644 local $access_forpush;
4645 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
4646 $cleanmode //= 'dpkg-source';
4648 badcfg "unknown clean-mode \`$cleanmode'" unless
4649 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
4652 my $fn = ${*::}{"cmd_$cmd"};
4653 $fn or badusage "unknown operation $cmd";