3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
48 our $isuite = 'unstable';
54 our $dryrun_level = 0;
56 our $buildproductsdir = '..';
62 our $existing_package = 'dpkg';
64 our $changes_since_version;
66 our $overwrite_version; # undef: not specified; '': check changelog
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
80 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
81 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
82 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
84 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
85 our $splitbraincache = 'dgit-intern/quilt-cache';
88 our (@dget) = qw(dget);
89 our (@curl) = qw(curl -f);
90 our (@dput) = qw(dput);
91 our (@debsign) = qw(debsign);
93 our (@sbuild) = qw(sbuild);
95 our (@dgit) = qw(dgit);
96 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
97 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
98 our (@dpkggenchanges) = qw(dpkg-genchanges);
99 our (@mergechanges) = qw(mergechanges -f);
100 our (@gbp) = qw(gbp);
101 our (@changesopts) = ('');
103 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
106 'debsign' => \@debsign,
108 'sbuild' => \@sbuild,
112 'dpkg-source' => \@dpkgsource,
113 'dpkg-buildpackage' => \@dpkgbuildpackage,
114 'dpkg-genchanges' => \@dpkggenchanges,
116 'ch' => \@changesopts,
117 'mergechanges' => \@mergechanges);
119 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
120 our %opts_cfg_insertpos = map {
122 scalar @{ $opts_opt_map{$_} }
123 } keys %opts_opt_map;
125 sub finalise_opts_opts();
131 our $supplementary_message = '';
132 our $need_split_build_invocation = 0;
133 our $split_brain = 0;
137 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
140 our $remotename = 'dgit';
141 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
146 my ($v,$distro) = @_;
147 return $tagformatfn->($v, $distro);
150 sub debiantag_maintview ($$) {
151 my ($v,$distro) = @_;
156 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
158 sub lbranch () { return "$branchprefix/$csuite"; }
159 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
160 sub lref () { return "refs/heads/".lbranch(); }
161 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
162 sub rrref () { return server_ref($csuite); }
164 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
165 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
167 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
168 # locally fetched refs because they have unhelpful names and clutter
169 # up gitk etc. So we track whether we have "used up" head ref (ie,
170 # whether we have made another local ref which refers to this object).
172 # (If we deleted them unconditionally, then we might end up
173 # re-fetching the same git objects each time dgit fetch was run.)
175 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
176 # in git_fetch_us to fetch the refs in question, and possibly a call
177 # to lrfetchref_used.
179 our (%lrfetchrefs_f, %lrfetchrefs_d);
180 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
182 sub lrfetchref_used ($) {
183 my ($fullrefname) = @_;
184 my $objid = $lrfetchrefs_f{$fullrefname};
185 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
196 return "${package}_".(stripepoch $vsn).$sfx
201 return srcfn($vsn,".dsc");
204 sub changespat ($;$) {
205 my ($vsn, $arch) = @_;
206 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
215 foreach my $f (@end) {
217 print STDERR "$us: cleanup: $@" if length $@;
221 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
223 sub no_such_package () {
224 print STDERR "$us: package $package does not exist in suite $isuite\n";
230 printdebug "CD $newdir\n";
231 chdir $newdir or confess "chdir: $newdir: $!";
234 sub deliberately ($) {
236 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
239 sub deliberately_not_fast_forward () {
240 foreach (qw(not-fast-forward fresh-repo)) {
241 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
245 sub quiltmode_splitbrain () {
246 $quilt_mode =~ m/gbp|dpm|unapplied/;
249 #---------- remote protocol support, common ----------
251 # remote push initiator/responder protocol:
252 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
253 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
254 # < dgit-remote-push-ready <actual-proto-vsn>
261 # > supplementary-message NBYTES # $protovsn >= 3
266 # > file parsed-changelog
267 # [indicates that output of dpkg-parsechangelog follows]
268 # > data-block NBYTES
269 # > [NBYTES bytes of data (no newline)]
270 # [maybe some more blocks]
279 # > param head DGIT-VIEW-HEAD
280 # > param csuite SUITE
281 # > param tagformat old|new
282 # > param maint-view MAINT-VIEW-HEAD
284 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
285 # # goes into tag, for replay prevention
288 # [indicates that signed tag is wanted]
289 # < data-block NBYTES
290 # < [NBYTES bytes of data (no newline)]
291 # [maybe some more blocks]
295 # > want signed-dsc-changes
296 # < data-block NBYTES [transfer of signed dsc]
298 # < data-block NBYTES [transfer of signed changes]
306 sub i_child_report () {
307 # Sees if our child has died, and reap it if so. Returns a string
308 # describing how it died if it failed, or undef otherwise.
309 return undef unless $i_child_pid;
310 my $got = waitpid $i_child_pid, WNOHANG;
311 return undef if $got <= 0;
312 die unless $got == $i_child_pid;
313 $i_child_pid = undef;
314 return undef unless $?;
315 return "build host child ".waitstatusmsg();
320 fail "connection lost: $!" if $fh->error;
321 fail "protocol violation; $m not expected";
324 sub badproto_badread ($$) {
326 fail "connection lost: $!" if $!;
327 my $report = i_child_report();
328 fail $report if defined $report;
329 badproto $fh, "eof (reading $wh)";
332 sub protocol_expect (&$) {
333 my ($match, $fh) = @_;
336 defined && chomp or badproto_badread $fh, "protocol message";
344 badproto $fh, "\`$_'";
347 sub protocol_send_file ($$) {
348 my ($fh, $ourfn) = @_;
349 open PF, "<", $ourfn or die "$ourfn: $!";
352 my $got = read PF, $d, 65536;
353 die "$ourfn: $!" unless defined $got;
355 print $fh "data-block ".length($d)."\n" or die $!;
356 print $fh $d or die $!;
358 PF->error and die "$ourfn $!";
359 print $fh "data-end\n" or die $!;
363 sub protocol_read_bytes ($$) {
364 my ($fh, $nbytes) = @_;
365 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
367 my $got = read $fh, $d, $nbytes;
368 $got==$nbytes or badproto_badread $fh, "data block";
372 sub protocol_receive_file ($$) {
373 my ($fh, $ourfn) = @_;
374 printdebug "() $ourfn\n";
375 open PF, ">", $ourfn or die "$ourfn: $!";
377 my ($y,$l) = protocol_expect {
378 m/^data-block (.*)$/ ? (1,$1) :
379 m/^data-end$/ ? (0,) :
383 my $d = protocol_read_bytes $fh, $l;
384 print PF $d or die $!;
389 #---------- remote protocol support, responder ----------
391 sub responder_send_command ($) {
393 return unless $we_are_responder;
394 # called even without $we_are_responder
395 printdebug ">> $command\n";
396 print PO $command, "\n" or die $!;
399 sub responder_send_file ($$) {
400 my ($keyword, $ourfn) = @_;
401 return unless $we_are_responder;
402 printdebug "]] $keyword $ourfn\n";
403 responder_send_command "file $keyword";
404 protocol_send_file \*PO, $ourfn;
407 sub responder_receive_files ($@) {
408 my ($keyword, @ourfns) = @_;
409 die unless $we_are_responder;
410 printdebug "[[ $keyword @ourfns\n";
411 responder_send_command "want $keyword";
412 foreach my $fn (@ourfns) {
413 protocol_receive_file \*PI, $fn;
416 protocol_expect { m/^files-end$/ } \*PI;
419 #---------- remote protocol support, initiator ----------
421 sub initiator_expect (&) {
423 protocol_expect { &$match } \*RO;
426 #---------- end remote code ----------
429 if ($we_are_responder) {
431 responder_send_command "progress ".length($m) or die $!;
432 print PO $m or die $!;
442 $ua = LWP::UserAgent->new();
446 progress "downloading $what...";
447 my $r = $ua->get(@_) or die $!;
448 return undef if $r->code == 404;
449 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
450 return $r->decoded_content(charset => 'none');
453 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
458 failedcmd @_ if system @_;
461 sub act_local () { return $dryrun_level <= 1; }
462 sub act_scary () { return !$dryrun_level; }
465 if (!$dryrun_level) {
466 progress "dgit ok: @_";
468 progress "would be ok: @_ (but dry run only)";
473 printcmd(\*STDERR,$debugprefix."#",@_);
476 sub runcmd_ordryrun {
484 sub runcmd_ordryrun_local {
493 my ($first_shell, @cmd) = @_;
494 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
497 our $helpmsg = <<END;
499 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
500 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
501 dgit [dgit-opts] build [dpkg-buildpackage-opts]
502 dgit [dgit-opts] sbuild [sbuild-opts]
503 dgit [dgit-opts] push [dgit-opts] [suite]
504 dgit [dgit-opts] rpush build-host:build-dir ...
505 important dgit options:
506 -k<keyid> sign tag and package with <keyid> instead of default
507 --dry-run -n do not change anything, but go through the motions
508 --damp-run -L like --dry-run but make local changes, without signing
509 --new -N allow introducing a new package
510 --debug -D increase debug level
511 -c<name>=<value> set git config option (used directly by dgit too)
514 our $later_warning_msg = <<END;
515 Perhaps the upload is stuck in incoming. Using the version from git.
519 print STDERR "$us: @_\n", $helpmsg or die $!;
524 @ARGV or badusage "too few arguments";
525 return scalar shift @ARGV;
529 print $helpmsg or die $!;
533 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
535 our %defcfg = ('dgit.default.distro' => 'debian',
536 'dgit.default.username' => '',
537 'dgit.default.archive-query-default-component' => 'main',
538 'dgit.default.ssh' => 'ssh',
539 'dgit.default.archive-query' => 'madison:',
540 'dgit.default.sshpsql-dbname' => 'service=projectb',
541 'dgit.default.dgit-tag-format' => 'old,new,maint',
542 # old means "repo server accepts pushes with old dgit tags"
543 # new means "repo server accepts pushes with new dgit tags"
544 # maint means "repo server accepts split brain pushes"
545 # hist means "repo server may have old pushes without new tag"
546 # ("hist" is implied by "old")
547 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
548 'dgit-distro.debian.git-check' => 'url',
549 'dgit-distro.debian.git-check-suffix' => '/info/refs',
550 'dgit-distro.debian.new-private-pushers' => 't',
551 'dgit-distro.debian.dgit-tag-format' => 'new',
552 'dgit-distro.debian/push.git-url' => '',
553 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
554 'dgit-distro.debian/push.git-user-force' => 'dgit',
555 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
556 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
557 'dgit-distro.debian/push.git-create' => 'true',
558 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
559 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
560 # 'dgit-distro.debian.archive-query-tls-key',
561 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
562 # ^ this does not work because curl is broken nowadays
563 # Fixing #790093 properly will involve providing providing the key
564 # in some pacagke and maybe updating these paths.
566 # 'dgit-distro.debian.archive-query-tls-curl-args',
567 # '--ca-path=/etc/ssl/ca-debian',
568 # ^ this is a workaround but works (only) on DSA-administered machines
569 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
570 'dgit-distro.debian.git-url-suffix' => '',
571 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
572 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
573 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
574 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
575 'dgit-distro.ubuntu.git-check' => 'false',
576 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
577 'dgit-distro.test-dummy.ssh' => "$td/ssh",
578 'dgit-distro.test-dummy.username' => "alice",
579 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
580 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
581 'dgit-distro.test-dummy.git-url' => "$td/git",
582 'dgit-distro.test-dummy.git-host' => "git",
583 'dgit-distro.test-dummy.git-path' => "$td/git",
584 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
585 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
586 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
587 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
592 sub git_slurp_config () {
593 local ($debuglevel) = $debuglevel-2;
596 my @cmd = (@git, qw(config -z --get-regexp .*));
599 open GITS, "-|", @cmd or die $!;
602 printdebug "=> ", (messagequote $_), "\n";
604 push @{ $gitcfg{$`} }, $'; #';
608 or ($!==0 && $?==256)
612 sub git_get_config ($) {
615 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
618 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
624 return undef if $c =~ /RETURN-UNDEF/;
625 my $v = git_get_config($c);
626 return $v if defined $v;
627 my $dv = $defcfg{$c};
628 return $dv if defined $dv;
630 badcfg "need value for one of: @_\n".
631 "$us: distro or suite appears not to be (properly) supported";
634 sub access_basedistro () {
635 if (defined $idistro) {
638 return cfg("dgit-suite.$isuite.distro",
639 "dgit.default.distro");
643 sub access_quirk () {
644 # returns (quirk name, distro to use instead or undef, quirk-specific info)
645 my $basedistro = access_basedistro();
646 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
648 if (defined $backports_quirk) {
649 my $re = $backports_quirk;
650 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
652 $re =~ s/\%/([-0-9a-z_]+)/
653 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
654 if ($isuite =~ m/^$re$/) {
655 return ('backports',"$basedistro-backports",$1);
658 return ('none',undef);
663 sub parse_cfg_bool ($$$) {
664 my ($what,$def,$v) = @_;
667 $v =~ m/^[ty1]/ ? 1 :
668 $v =~ m/^[fn0]/ ? 0 :
669 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
672 sub access_forpush_config () {
673 my $d = access_basedistro();
677 parse_cfg_bool('new-private-pushers', 0,
678 cfg("dgit-distro.$d.new-private-pushers",
681 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
684 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
685 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
686 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
687 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
690 sub access_forpush () {
691 $access_forpush //= access_forpush_config();
692 return $access_forpush;
696 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
697 badcfg "pushing but distro is configured readonly"
698 if access_forpush_config() eq '0';
700 $supplementary_message = <<'END' unless $we_are_responder;
701 Push failed, before we got started.
702 You can retry the push, after fixing the problem, if you like.
704 finalise_opts_opts();
708 finalise_opts_opts();
711 sub supplementary_message ($) {
713 if (!$we_are_responder) {
714 $supplementary_message = $msg;
716 } elsif ($protovsn >= 3) {
717 responder_send_command "supplementary-message ".length($msg)
719 print PO $msg or die $!;
723 sub access_distros () {
724 # Returns list of distros to try, in order
727 # 0. `instead of' distro name(s) we have been pointed to
728 # 1. the access_quirk distro, if any
729 # 2a. the user's specified distro, or failing that } basedistro
730 # 2b. the distro calculated from the suite }
731 my @l = access_basedistro();
733 my (undef,$quirkdistro) = access_quirk();
734 unshift @l, $quirkdistro;
735 unshift @l, $instead_distro;
736 @l = grep { defined } @l;
738 if (access_forpush()) {
739 @l = map { ("$_/push", $_) } @l;
744 sub access_cfg_cfgs (@) {
747 # The nesting of these loops determines the search order. We put
748 # the key loop on the outside so that we search all the distros
749 # for each key, before going on to the next key. That means that
750 # if access_cfg is called with a more specific, and then a less
751 # specific, key, an earlier distro can override the less specific
752 # without necessarily overriding any more specific keys. (If the
753 # distro wants to override the more specific keys it can simply do
754 # so; whereas if we did the loop the other way around, it would be
755 # impossible to for an earlier distro to override a less specific
756 # key but not the more specific ones without restating the unknown
757 # values of the more specific keys.
760 # We have to deal with RETURN-UNDEF specially, so that we don't
761 # terminate the search prematurely.
763 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
766 foreach my $d (access_distros()) {
767 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
769 push @cfgs, map { "dgit.default.$_" } @realkeys;
776 my (@cfgs) = access_cfg_cfgs(@keys);
777 my $value = cfg(@cfgs);
781 sub access_cfg_bool ($$) {
782 my ($def, @keys) = @_;
783 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
786 sub string_to_ssh ($) {
788 if ($spec =~ m/\s/) {
789 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
795 sub access_cfg_ssh () {
796 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
797 if (!defined $gitssh) {
800 return string_to_ssh $gitssh;
804 sub access_runeinfo ($) {
806 return ": dgit ".access_basedistro()." $info ;";
809 sub access_someuserhost ($) {
811 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
812 defined($user) && length($user) or
813 $user = access_cfg("$some-user",'username');
814 my $host = access_cfg("$some-host");
815 return length($user) ? "$user\@$host" : $host;
818 sub access_gituserhost () {
819 return access_someuserhost('git');
822 sub access_giturl (;$) {
824 my $url = access_cfg('git-url','RETURN-UNDEF');
827 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
828 return undef unless defined $proto;
831 access_gituserhost().
832 access_cfg('git-path');
834 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
837 return "$url/$package$suffix";
840 sub parsecontrolfh ($$;$) {
841 my ($fh, $desc, $allowsigned) = @_;
842 our $dpkgcontrolhash_noissigned;
845 my %opts = ('name' => $desc);
846 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
847 $c = Dpkg::Control::Hash->new(%opts);
848 $c->parse($fh,$desc) or die "parsing of $desc failed";
849 last if $allowsigned;
850 last if $dpkgcontrolhash_noissigned;
851 my $issigned= $c->get_option('is_pgp_signed');
852 if (!defined $issigned) {
853 $dpkgcontrolhash_noissigned= 1;
854 seek $fh, 0,0 or die "seek $desc: $!";
855 } elsif ($issigned) {
856 fail "control file $desc is (already) PGP-signed. ".
857 " Note that dgit push needs to modify the .dsc and then".
858 " do the signature itself";
867 my ($file, $desc) = @_;
868 my $fh = new IO::Handle;
869 open $fh, '<', $file or die "$file: $!";
870 my $c = parsecontrolfh($fh,$desc);
871 $fh->error and die $!;
877 my ($dctrl,$field) = @_;
878 my $v = $dctrl->{$field};
879 return $v if defined $v;
880 fail "missing field $field in ".$dctrl->get_option('name');
884 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
885 my $p = new IO::Handle;
886 my @cmd = (qw(dpkg-parsechangelog), @_);
887 open $p, '-|', @cmd or die $!;
889 $?=0; $!=0; close $p or failedcmd @cmd;
893 sub commit_getclogp ($) {
894 # Returns the parsed changelog hashref for a particular commit
896 our %commit_getclogp_memo;
897 my $memo = $commit_getclogp_memo{$objid};
898 return $memo if $memo;
900 my $mclog = ".git/dgit/clog-$objid";
901 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
902 "$objid:debian/changelog";
903 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
908 defined $d or fail "getcwd failed: $!";
914 sub archive_query ($) {
916 my $query = access_cfg('archive-query','RETURN-UNDEF');
917 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
920 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
923 sub pool_dsc_subpath ($$) {
924 my ($vsn,$component) = @_; # $package is implict arg
925 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
926 return "/pool/$component/$prefix/$package/".dscfn($vsn);
929 #---------- `ftpmasterapi' archive query method (nascent) ----------
931 sub archive_api_query_cmd ($) {
933 my @cmd = qw(curl -sS);
934 my $url = access_cfg('archive-query-url');
935 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
937 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
938 foreach my $key (split /\:/, $keys) {
939 $key =~ s/\%HOST\%/$host/g;
941 fail "for $url: stat $key: $!" unless $!==ENOENT;
944 fail "config requested specific TLS key but do not know".
945 " how to get curl to use exactly that EE key ($key)";
946 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
947 # # Sadly the above line does not work because of changes
948 # # to gnutls. The real fix for #790093 may involve
949 # # new curl options.
952 # Fixing #790093 properly will involve providing a value
953 # for this on clients.
954 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
955 push @cmd, split / /, $kargs if defined $kargs;
957 push @cmd, $url.$subpath;
963 my ($data, $subpath) = @_;
964 badcfg "ftpmasterapi archive query method takes no data part"
966 my @cmd = archive_api_query_cmd($subpath);
967 my $json = cmdoutput @cmd;
968 return decode_json($json);
971 sub canonicalise_suite_ftpmasterapi () {
972 my ($proto,$data) = @_;
973 my $suites = api_query($data, 'suites');
975 foreach my $entry (@$suites) {
977 my $v = $entry->{$_};
978 defined $v && $v eq $isuite;
980 push @matched, $entry;
982 fail "unknown suite $isuite" unless @matched;
985 @matched==1 or die "multiple matches for suite $isuite\n";
986 $cn = "$matched[0]{codename}";
987 defined $cn or die "suite $isuite info has no codename\n";
988 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
990 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
995 sub archive_query_ftpmasterapi () {
996 my ($proto,$data) = @_;
997 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
999 my $digester = Digest::SHA->new(256);
1000 foreach my $entry (@$info) {
1002 my $vsn = "$entry->{version}";
1003 my ($ok,$msg) = version_check $vsn;
1004 die "bad version: $msg\n" unless $ok;
1005 my $component = "$entry->{component}";
1006 $component =~ m/^$component_re$/ or die "bad component";
1007 my $filename = "$entry->{filename}";
1008 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1009 or die "bad filename";
1010 my $sha256sum = "$entry->{sha256sum}";
1011 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1012 push @rows, [ $vsn, "/pool/$component/$filename",
1013 $digester, $sha256sum ];
1015 die "bad ftpmaster api response: $@\n".Dumper($entry)
1018 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1022 #---------- `madison' archive query method ----------
1024 sub archive_query_madison {
1025 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1028 sub madison_get_parse {
1029 my ($proto,$data) = @_;
1030 die unless $proto eq 'madison';
1031 if (!length $data) {
1032 $data= access_cfg('madison-distro','RETURN-UNDEF');
1033 $data //= access_basedistro();
1035 $rmad{$proto,$data,$package} ||= cmdoutput
1036 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1037 my $rmad = $rmad{$proto,$data,$package};
1040 foreach my $l (split /\n/, $rmad) {
1041 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1042 \s*( [^ \t|]+ )\s* \|
1043 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1044 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1045 $1 eq $package or die "$rmad $package ?";
1052 $component = access_cfg('archive-query-default-component');
1054 $5 eq 'source' or die "$rmad ?";
1055 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1057 return sort { -version_compare($a->[0],$b->[0]); } @out;
1060 sub canonicalise_suite_madison {
1061 # madison canonicalises for us
1062 my @r = madison_get_parse(@_);
1064 "unable to canonicalise suite using package $package".
1065 " which does not appear to exist in suite $isuite;".
1066 " --existing-package may help";
1070 #---------- `sshpsql' archive query method ----------
1073 my ($data,$runeinfo,$sql) = @_;
1074 if (!length $data) {
1075 $data= access_someuserhost('sshpsql').':'.
1076 access_cfg('sshpsql-dbname');
1078 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1079 my ($userhost,$dbname) = ($`,$'); #';
1081 my @cmd = (access_cfg_ssh, $userhost,
1082 access_runeinfo("ssh-psql $runeinfo").
1083 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1084 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1086 open P, "-|", @cmd or die $!;
1089 printdebug(">|$_|\n");
1092 $!=0; $?=0; close P or failedcmd @cmd;
1094 my $nrows = pop @rows;
1095 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1096 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1097 @rows = map { [ split /\|/, $_ ] } @rows;
1098 my $ncols = scalar @{ shift @rows };
1099 die if grep { scalar @$_ != $ncols } @rows;
1103 sub sql_injection_check {
1104 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1107 sub archive_query_sshpsql ($$) {
1108 my ($proto,$data) = @_;
1109 sql_injection_check $isuite, $package;
1110 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1111 SELECT source.version, component.name, files.filename, files.sha256sum
1113 JOIN src_associations ON source.id = src_associations.source
1114 JOIN suite ON suite.id = src_associations.suite
1115 JOIN dsc_files ON dsc_files.source = source.id
1116 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1117 JOIN component ON component.id = files_archive_map.component_id
1118 JOIN files ON files.id = dsc_files.file
1119 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1120 AND source.source='$package'
1121 AND files.filename LIKE '%.dsc';
1123 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1124 my $digester = Digest::SHA->new(256);
1126 my ($vsn,$component,$filename,$sha256sum) = @$_;
1127 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1132 sub canonicalise_suite_sshpsql ($$) {
1133 my ($proto,$data) = @_;
1134 sql_injection_check $isuite;
1135 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1136 SELECT suite.codename
1137 FROM suite where suite_name='$isuite' or codename='$isuite';
1139 @rows = map { $_->[0] } @rows;
1140 fail "unknown suite $isuite" unless @rows;
1141 die "ambiguous $isuite: @rows ?" if @rows>1;
1145 #---------- `dummycat' archive query method ----------
1147 sub canonicalise_suite_dummycat ($$) {
1148 my ($proto,$data) = @_;
1149 my $dpath = "$data/suite.$isuite";
1150 if (!open C, "<", $dpath) {
1151 $!==ENOENT or die "$dpath: $!";
1152 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1156 chomp or die "$dpath: $!";
1158 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1162 sub archive_query_dummycat ($$) {
1163 my ($proto,$data) = @_;
1164 canonicalise_suite();
1165 my $dpath = "$data/package.$csuite.$package";
1166 if (!open C, "<", $dpath) {
1167 $!==ENOENT or die "$dpath: $!";
1168 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1176 printdebug "dummycat query $csuite $package $dpath | $_\n";
1177 my @row = split /\s+/, $_;
1178 @row==2 or die "$dpath: $_ ?";
1181 C->error and die "$dpath: $!";
1183 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1186 #---------- tag format handling ----------
1188 sub access_cfg_tagformats () {
1189 split /\,/, access_cfg('dgit-tag-format');
1192 sub need_tagformat ($$) {
1193 my ($fmt, $why) = @_;
1194 fail "need to use tag format $fmt ($why) but also need".
1195 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1196 " - no way to proceed"
1197 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1198 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1201 sub select_tagformat () {
1203 return if $tagformatfn && !$tagformat_want;
1204 die 'bug' if $tagformatfn && $tagformat_want;
1205 # ... $tagformat_want assigned after previous select_tagformat
1207 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1208 printdebug "select_tagformat supported @supported\n";
1210 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1211 printdebug "select_tagformat specified @$tagformat_want\n";
1213 my ($fmt,$why,$override) = @$tagformat_want;
1215 fail "target distro supports tag formats @supported".
1216 " but have to use $fmt ($why)"
1218 or grep { $_ eq $fmt } @supported;
1220 $tagformat_want = undef;
1222 $tagformatfn = ${*::}{"debiantag_$fmt"};
1224 fail "trying to use unknown tag format \`$fmt' ($why) !"
1225 unless $tagformatfn;
1228 #---------- archive query entrypoints and rest of program ----------
1230 sub canonicalise_suite () {
1231 return if defined $csuite;
1232 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1233 $csuite = archive_query('canonicalise_suite');
1234 if ($isuite ne $csuite) {
1235 progress "canonical suite name for $isuite is $csuite";
1239 sub get_archive_dsc () {
1240 canonicalise_suite();
1241 my @vsns = archive_query('archive_query');
1242 foreach my $vinfo (@vsns) {
1243 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1244 $dscurl = access_cfg('mirror').$subpath;
1245 $dscdata = url_get($dscurl);
1247 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1252 $digester->add($dscdata);
1253 my $got = $digester->hexdigest();
1255 fail "$dscurl has hash $got but".
1256 " archive told us to expect $digest";
1258 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1259 printdebug Dumper($dscdata) if $debuglevel>1;
1260 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1261 printdebug Dumper($dsc) if $debuglevel>1;
1262 my $fmt = getfield $dsc, 'Format';
1263 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1264 $dsc_checked = !!$digester;
1265 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1269 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1272 sub check_for_git ();
1273 sub check_for_git () {
1275 my $how = access_cfg('git-check');
1276 if ($how eq 'ssh-cmd') {
1278 (access_cfg_ssh, access_gituserhost(),
1279 access_runeinfo("git-check $package").
1280 " set -e; cd ".access_cfg('git-path').";".
1281 " if test -d $package.git; then echo 1; else echo 0; fi");
1282 my $r= cmdoutput @cmd;
1283 if (defined $r and $r =~ m/^divert (\w+)$/) {
1285 my ($usedistro,) = access_distros();
1286 # NB that if we are pushing, $usedistro will be $distro/push
1287 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1288 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1289 progress "diverting to $divert (using config for $instead_distro)";
1290 return check_for_git();
1292 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1294 } elsif ($how eq 'url') {
1295 my $prefix = access_cfg('git-check-url','git-url');
1296 my $suffix = access_cfg('git-check-suffix','git-suffix',
1297 'RETURN-UNDEF') // '.git';
1298 my $url = "$prefix/$package$suffix";
1299 my @cmd = (qw(curl -sS -I), $url);
1300 my $result = cmdoutput @cmd;
1301 $result =~ s/^\S+ 200 .*\n\r?\n//;
1302 # curl -sS -I with https_proxy prints
1303 # HTTP/1.0 200 Connection established
1304 $result =~ m/^\S+ (404|200) /s or
1305 fail "unexpected results from git check query - ".
1306 Dumper($prefix, $result);
1308 if ($code eq '404') {
1310 } elsif ($code eq '200') {
1315 } elsif ($how eq 'true') {
1317 } elsif ($how eq 'false') {
1320 badcfg "unknown git-check \`$how'";
1324 sub create_remote_git_repo () {
1325 my $how = access_cfg('git-create');
1326 if ($how eq 'ssh-cmd') {
1328 (access_cfg_ssh, access_gituserhost(),
1329 access_runeinfo("git-create $package").
1330 "set -e; cd ".access_cfg('git-path').";".
1331 " cp -a _template $package.git");
1332 } elsif ($how eq 'true') {
1335 badcfg "unknown git-create \`$how'";
1339 our ($dsc_hash,$lastpush_mergeinput);
1341 our $ud = '.git/dgit/unpack';
1351 sub mktree_in_ud_here () {
1352 runcmd qw(git init -q);
1353 runcmd qw(git config gc.auto 0);
1354 rmtree('.git/objects');
1355 symlink '../../../../objects','.git/objects' or die $!;
1358 sub git_write_tree () {
1359 my $tree = cmdoutput @git, qw(write-tree);
1360 $tree =~ m/^\w+$/ or die "$tree ?";
1364 sub remove_stray_gits () {
1365 my @gitscmd = qw(find -name .git -prune -print0);
1366 debugcmd "|",@gitscmd;
1367 open GITS, "-|", @gitscmd or die $!;
1372 print STDERR "$us: warning: removing from source package: ",
1373 (messagequote $_), "\n";
1377 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1380 sub mktree_in_ud_from_only_subdir (;$) {
1383 # changes into the subdir
1385 die "expected one subdir but found @dirs ?" unless @dirs==1;
1386 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1390 remove_stray_gits();
1391 mktree_in_ud_here();
1393 my ($format, $fopts) = get_source_format();
1394 if (madformat($format)) {
1399 runcmd @git, qw(add -Af);
1400 my $tree=git_write_tree();
1401 return ($tree,$dir);
1404 sub dsc_files_info () {
1405 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1406 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1407 ['Files', 'Digest::MD5', 'new()']) {
1408 my ($fname, $module, $method) = @$csumi;
1409 my $field = $dsc->{$fname};
1410 next unless defined $field;
1411 eval "use $module; 1;" or die $@;
1413 foreach (split /\n/, $field) {
1415 m/^(\w+) (\d+) (\S+)$/ or
1416 fail "could not parse .dsc $fname line \`$_'";
1417 my $digester = eval "$module"."->$method;" or die $@;
1422 Digester => $digester,
1427 fail "missing any supported Checksums-* or Files field in ".
1428 $dsc->get_option('name');
1432 map { $_->{Filename} } dsc_files_info();
1435 sub is_orig_file_in_dsc ($$) {
1436 my ($f, $dsc_files_info) = @_;
1437 return 0 if @$dsc_files_info <= 1;
1438 # One file means no origs, and the filename doesn't have a "what
1439 # part of dsc" component. (Consider versions ending `.orig'.)
1440 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1444 sub is_orig_file_of_vsn ($$) {
1445 my ($f, $upstreamvsn) = @_;
1446 my $base = srcfn $upstreamvsn, '';
1447 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1451 sub make_commit ($) {
1453 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1456 sub make_commit_text ($) {
1459 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1461 print Dumper($text) if $debuglevel > 1;
1462 my $child = open2($out, $in, @cmd) or die $!;
1465 print $in $text or die $!;
1466 close $in or die $!;
1468 $h =~ m/^\w+$/ or die;
1470 printdebug "=> $h\n";
1473 waitpid $child, 0 == $child or die "$child $!";
1474 $? and failedcmd @cmd;
1478 sub clogp_authline ($) {
1480 my $author = getfield $clogp, 'Maintainer';
1481 $author =~ s#,.*##ms;
1482 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1483 my $authline = "$author $date";
1484 $authline =~ m/$git_authline_re/o or
1485 fail "unexpected commit author line format \`$authline'".
1486 " (was generated from changelog Maintainer field)";
1487 return ($1,$2,$3) if wantarray;
1491 sub vendor_patches_distro ($$) {
1492 my ($checkdistro, $what) = @_;
1493 return unless defined $checkdistro;
1495 my $series = "debian/patches/\L$checkdistro\E.series";
1496 printdebug "checking for vendor-specific $series ($what)\n";
1498 if (!open SERIES, "<", $series) {
1499 die "$series $!" unless $!==ENOENT;
1508 Unfortunately, this source package uses a feature of dpkg-source where
1509 the same source package unpacks to different source code on different
1510 distros. dgit cannot safely operate on such packages on affected
1511 distros, because the meaning of source packages is not stable.
1513 Please ask the distro/maintainer to remove the distro-specific series
1514 files and use a different technique (if necessary, uploading actually
1515 different packages, if different distros are supposed to have
1519 fail "Found active distro-specific series file for".
1520 " $checkdistro ($what): $series, cannot continue";
1522 die "$series $!" if SERIES->error;
1526 sub check_for_vendor_patches () {
1527 # This dpkg-source feature doesn't seem to be documented anywhere!
1528 # But it can be found in the changelog (reformatted):
1530 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1531 # Author: Raphael Hertzog <hertzog@debian.org>
1532 # Date: Sun Oct 3 09:36:48 2010 +0200
1534 # dpkg-source: correctly create .pc/.quilt_series with alternate
1537 # If you have debian/patches/ubuntu.series and you were
1538 # unpacking the source package on ubuntu, quilt was still
1539 # directed to debian/patches/series instead of
1540 # debian/patches/ubuntu.series.
1542 # debian/changelog | 3 +++
1543 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1544 # 2 files changed, 6 insertions(+), 1 deletion(-)
1547 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1548 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1549 "Dpkg::Vendor \`current vendor'");
1550 vendor_patches_distro(access_basedistro(),
1551 "distro being accessed");
1554 sub generate_commits_from_dsc () {
1555 # See big comment in fetch_from_archive, below.
1559 my @dfi = dsc_files_info();
1560 foreach my $fi (@dfi) {
1561 my $f = $fi->{Filename};
1562 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1564 link_ltarget "../../../$f", $f
1568 complete_file_from_dsc('.', $fi)
1571 if (is_orig_file_in_dsc($f, \@dfi)) {
1572 link $f, "../../../../$f"
1578 # We unpack and record the orig tarballs first, so that we only
1579 # need disk space for one private copy of the unpacked source.
1580 # But we can't make them into commits until we have the metadata
1581 # from the debian/changelog, so we record the tree objects now and
1582 # make them into commits later.
1584 my $upstreamv = $dsc->{version};
1585 $upstreamv =~ s/-[^-]+$//;
1586 my $orig_f_base = srcfn $upstreamv, '';
1588 foreach my $fi (@dfi) {
1589 # We actually import, and record as a commit, every tarball
1590 # (unless there is only one file, in which case there seems
1593 my $f = $fi->{Filename};
1594 printdebug "import considering $f ";
1595 (printdebug "only one dfi\n"), next if @dfi == 1;
1596 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1597 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1601 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1603 printdebug "Y ", (join ' ', map { $_//"(none)" }
1604 $compr_ext, $orig_f_part
1607 my $input = new IO::File $f, '<' or die "$f $!";
1611 if (defined $compr_ext) {
1613 Dpkg::Compression::compression_guess_from_filename $f;
1614 fail "Dpkg::Compression cannot handle file $f in source package"
1615 if defined $compr_ext && !defined $cname;
1617 new Dpkg::Compression::Process compression => $cname;
1618 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1619 my $compr_fh = new IO::Handle;
1620 my $compr_pid = open $compr_fh, "-|" // die $!;
1622 open STDIN, "<&", $input or die $!;
1624 die "dgit (child): exec $compr_cmd[0]: $!\n";
1629 rmtree "../unpack-tar";
1630 mkdir "../unpack-tar" or die $!;
1631 my @tarcmd = qw(tar -x -f -
1632 --no-same-owner --no-same-permissions
1633 --no-acls --no-xattrs --no-selinux);
1634 my $tar_pid = fork // die $!;
1636 chdir "../unpack-tar" or die $!;
1637 open STDIN, "<&", $input or die $!;
1639 die "dgit (child): exec $tarcmd[0]: $!";
1641 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1642 !$? or failedcmd @tarcmd;
1645 (@compr_cmd ? failedcmd @compr_cmd
1647 # finally, we have the results in "tarball", but maybe
1648 # with the wrong permissions
1650 runcmd qw(chmod -R +rwX ../unpack-tar);
1651 changedir "../unpack-tar";
1652 my ($tree) = mktree_in_ud_from_only_subdir(1);
1653 changedir "../../unpack";
1654 rmtree "../unpack-tar";
1656 my $ent = [ $f, $tree ];
1658 Orig => !!$orig_f_part,
1659 Sort => (!$orig_f_part ? 2 :
1660 $orig_f_part =~ m/-/g ? 1 :
1668 # put any without "_" first (spec is not clear whether files
1669 # are always in the usual order). Tarballs without "_" are
1670 # the main orig or the debian tarball.
1671 $a->{Sort} <=> $b->{Sort} or
1675 my $any_orig = grep { $_->{Orig} } @tartrees;
1677 my $dscfn = "$package.dsc";
1679 my $treeimporthow = 'package';
1681 open D, ">", $dscfn or die "$dscfn: $!";
1682 print D $dscdata or die "$dscfn: $!";
1683 close D or die "$dscfn: $!";
1684 my @cmd = qw(dpkg-source);
1685 push @cmd, '--no-check' if $dsc_checked;
1686 if (madformat $dsc->{format}) {
1687 push @cmd, '--skip-patches';
1688 $treeimporthow = 'unpatched';
1690 push @cmd, qw(-x --), $dscfn;
1693 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1694 if (madformat $dsc->{format}) {
1695 check_for_vendor_patches();
1699 if (madformat $dsc->{format}) {
1700 my @pcmd = qw(dpkg-source --before-build .);
1701 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1703 runcmd @git, qw(add -Af);
1704 $dappliedtree = git_write_tree();
1707 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1708 debugcmd "|",@clogcmd;
1709 open CLOGS, "-|", @clogcmd or die $!;
1714 printdebug "import clog search...\n";
1717 my $stanzatext = do { local $/=""; <CLOGS>; };
1718 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1719 last if !defined $stanzatext;
1721 my $desc = "package changelog, entry no.$.";
1722 open my $stanzafh, "<", \$stanzatext or die;
1723 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1724 $clogp //= $thisstanza;
1726 printdebug "import clog $thisstanza->{version} $desc...\n";
1728 last if !$any_orig; # we don't need $r1clogp
1730 # We look for the first (most recent) changelog entry whose
1731 # version number is lower than the upstream version of this
1732 # package. Then the last (least recent) previous changelog
1733 # entry is treated as the one which introduced this upstream
1734 # version and used for the synthetic commits for the upstream
1737 # One might think that a more sophisticated algorithm would be
1738 # necessary. But: we do not want to scan the whole changelog
1739 # file. Stopping when we see an earlier version, which
1740 # necessarily then is an earlier upstream version, is the only
1741 # realistic way to do that. Then, either the earliest
1742 # changelog entry we have seen so far is indeed the earliest
1743 # upload of this upstream version; or there are only changelog
1744 # entries relating to later upstream versions (which is not
1745 # possible unless the changelog and .dsc disagree about the
1746 # version). Then it remains to choose between the physically
1747 # last entry in the file, and the one with the lowest version
1748 # number. If these are not the same, we guess that the
1749 # versions were created in a non-monotic order rather than
1750 # that the changelog entries have been misordered.
1752 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1754 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1755 $r1clogp = $thisstanza;
1757 printdebug "import clog $r1clogp->{version} becomes r1\n";
1759 die $! if CLOGS->error;
1760 close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
1762 $clogp or fail "package changelog has no entries!";
1764 my $authline = clogp_authline $clogp;
1765 my $changes = getfield $clogp, 'Changes';
1766 my $cversion = getfield $clogp, 'Version';
1769 $r1clogp //= $clogp; # maybe there's only one entry;
1770 my $r1authline = clogp_authline $r1clogp;
1771 # Strictly, r1authline might now be wrong if it's going to be
1772 # unused because !$any_orig. Whatever.
1774 printdebug "import tartrees authline $authline\n";
1775 printdebug "import tartrees r1authline $r1authline\n";
1777 foreach my $tt (@tartrees) {
1778 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1780 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1783 committer $r1authline
1787 [dgit import orig $tt->{F}]
1795 [dgit import tarball $package $cversion $tt->{F}]
1800 printdebug "import main commit\n";
1802 open C, ">../commit.tmp" or die $!;
1803 print C <<END or die $!;
1806 print C <<END or die $! foreach @tartrees;
1809 print C <<END or die $!;
1815 [dgit import $treeimporthow $package $cversion]
1819 my $rawimport_hash = make_commit qw(../commit.tmp);
1821 if (madformat $dsc->{format}) {
1822 printdebug "import apply patches...\n";
1824 # regularise the state of the working tree so that
1825 # the checkout of $rawimport_hash works nicely.
1826 my $dappliedcommit = make_commit_text(<<END);
1833 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1835 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1837 # We need the answers to be reproducible
1838 my @authline = clogp_authline($clogp);
1839 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1840 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1841 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1842 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1843 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1844 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1846 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
1848 my $gapplied = git_rev_parse('HEAD');
1849 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1850 $gappliedtree eq $dappliedtree or
1852 gbp-pq import and dpkg-source disagree!
1853 gbp-pq import gave commit $gapplied
1854 gbp-pq import gave tree $gappliedtree
1855 dpkg-source --before-build gave tree $dappliedtree
1857 $rawimport_hash = $gapplied;
1860 progress "synthesised git commit from .dsc $cversion";
1862 my $rawimport_mergeinput = {
1863 Commit => $rawimport_hash,
1864 Info => "Import of source package",
1866 my @output = ($rawimport_mergeinput);
1868 if ($lastpush_mergeinput) {
1869 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1870 my $oversion = getfield $oldclogp, 'Version';
1872 version_compare($oversion, $cversion);
1874 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1875 { Message => <<END, ReverseParents => 1 });
1876 Record $package ($cversion) in archive suite $csuite
1878 } elsif ($vcmp > 0) {
1879 print STDERR <<END or die $!;
1881 Version actually in archive: $cversion (older)
1882 Last version pushed with dgit: $oversion (newer or same)
1885 @output = $lastpush_mergeinput;
1887 # Same version. Use what's in the server git branch,
1888 # discarding our own import. (This could happen if the
1889 # server automatically imports all packages into git.)
1890 @output = $lastpush_mergeinput;
1893 changedir '../../../..';
1898 sub complete_file_from_dsc ($$) {
1899 our ($dstdir, $fi) = @_;
1900 # Ensures that we have, in $dir, the file $fi, with the correct
1901 # contents. (Downloading it from alongside $dscurl if necessary.)
1903 my $f = $fi->{Filename};
1904 my $tf = "$dstdir/$f";
1907 if (stat_exists $tf) {
1908 progress "using existing $f";
1911 $furl =~ s{/[^/]+$}{};
1913 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1914 die "$f ?" if $f =~ m#/#;
1915 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1916 return 0 if !act_local();
1920 open F, "<", "$tf" or die "$tf: $!";
1921 $fi->{Digester}->reset();
1922 $fi->{Digester}->addfile(*F);
1923 F->error and die $!;
1924 my $got = $fi->{Digester}->hexdigest();
1925 $got eq $fi->{Hash} or
1926 fail "file $f has hash $got but .dsc".
1927 " demands hash $fi->{Hash} ".
1928 ($downloaded ? "(got wrong file from archive!)"
1929 : "(perhaps you should delete this file?)");
1934 sub ensure_we_have_orig () {
1935 my @dfi = dsc_files_info();
1936 foreach my $fi (@dfi) {
1937 my $f = $fi->{Filename};
1938 next unless is_orig_file_in_dsc($f, \@dfi);
1939 complete_file_from_dsc('..', $fi)
1944 sub git_fetch_us () {
1945 # Want to fetch only what we are going to use, unless
1946 # deliberately-not-ff, in which case we must fetch everything.
1948 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1950 (quiltmode_splitbrain
1951 ? (map { $_->('*',access_basedistro) }
1952 \&debiantag_new, \&debiantag_maintview)
1953 : debiantags('*',access_basedistro));
1954 push @specs, server_branch($csuite);
1955 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1957 # This is rather miserable:
1958 # When git-fetch --prune is passed a fetchspec ending with a *,
1959 # it does a plausible thing. If there is no * then:
1960 # - it matches subpaths too, even if the supplied refspec
1961 # starts refs, and behaves completely madly if the source
1962 # has refs/refs/something. (See, for example, Debian #NNNN.)
1963 # - if there is no matching remote ref, it bombs out the whole
1965 # We want to fetch a fixed ref, and we don't know in advance
1966 # if it exists, so this is not suitable.
1968 # Our workaround is to use git-ls-remote. git-ls-remote has its
1969 # own qairks. Notably, it has the absurd multi-tail-matching
1970 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1971 # refs/refs/foo etc.
1973 # Also, we want an idempotent snapshot, but we have to make two
1974 # calls to the remote: one to git-ls-remote and to git-fetch. The
1975 # solution is use git-ls-remote to obtain a target state, and
1976 # git-fetch to try to generate it. If we don't manage to generate
1977 # the target state, we try again.
1979 my $specre = join '|', map {
1985 printdebug "git_fetch_us specre=$specre\n";
1986 my $wanted_rref = sub {
1988 return m/^(?:$specre)$/o;
1991 my $fetch_iteration = 0;
1994 if (++$fetch_iteration > 10) {
1995 fail "too many iterations trying to get sane fetch!";
1998 my @look = map { "refs/$_" } @specs;
1999 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2003 open GITLS, "-|", @lcmd or die $!;
2005 printdebug "=> ", $_;
2006 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2007 my ($objid,$rrefname) = ($1,$2);
2008 if (!$wanted_rref->($rrefname)) {
2010 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
2014 $wantr{$rrefname} = $objid;
2017 close GITLS or failedcmd @lcmd;
2019 # OK, now %want is exactly what we want for refs in @specs
2021 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2022 "+refs/$_:".lrfetchrefs."/$_";
2025 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2026 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2029 %lrfetchrefs_f = ();
2032 git_for_each_ref(lrfetchrefs, sub {
2033 my ($objid,$objtype,$lrefname,$reftail) = @_;
2034 $lrfetchrefs_f{$lrefname} = $objid;
2035 $objgot{$objid} = 1;
2038 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2039 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2040 if (!exists $wantr{$rrefname}) {
2041 if ($wanted_rref->($rrefname)) {
2043 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
2047 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
2050 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2051 delete $lrfetchrefs_f{$lrefname};
2055 foreach my $rrefname (sort keys %wantr) {
2056 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2057 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2058 my $want = $wantr{$rrefname};
2059 next if $got eq $want;
2060 if (!defined $objgot{$want}) {
2062 warning: git-ls-remote suggests we want $lrefname
2063 warning: and it should refer to $want
2064 warning: but git-fetch didn't fetch that object to any relevant ref.
2065 warning: This may be due to a race with someone updating the server.
2066 warning: Will try again...
2068 next FETCH_ITERATION;
2071 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
2073 runcmd_ordryrun_local @git, qw(update-ref -m),
2074 "dgit fetch git-fetch fixup", $lrefname, $want;
2075 $lrfetchrefs_f{$lrefname} = $want;
2079 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
2080 Dumper(\%lrfetchrefs_f);
2083 my @tagpats = debiantags('*',access_basedistro);
2085 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2086 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2087 printdebug "currently $fullrefname=$objid\n";
2088 $here{$fullrefname} = $objid;
2090 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2091 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2092 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2093 printdebug "offered $lref=$objid\n";
2094 if (!defined $here{$lref}) {
2095 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2096 runcmd_ordryrun_local @upd;
2097 lrfetchref_used $fullrefname;
2098 } elsif ($here{$lref} eq $objid) {
2099 lrfetchref_used $fullrefname;
2102 "Not updateting $lref from $here{$lref} to $objid.\n";
2107 sub mergeinfo_getclogp ($) {
2108 # Ensures thit $mi->{Clogp} exists and returns it
2110 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2113 sub mergeinfo_version ($) {
2114 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2117 sub fetch_from_archive () {
2118 # Ensures that lrref() is what is actually in the archive, one way
2119 # or another, according to us - ie this client's
2120 # appropritaely-updated archive view. Also returns the commit id.
2121 # If there is nothing in the archive, leaves lrref alone and
2122 # returns undef. git_fetch_us must have already been called.
2126 foreach my $field (@ourdscfield) {
2127 $dsc_hash = $dsc->{$field};
2128 last if defined $dsc_hash;
2130 if (defined $dsc_hash) {
2131 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2133 progress "last upload to archive specified git hash";
2135 progress "last upload to archive has NO git hash";
2138 progress "no version available from the archive";
2141 # If the archive's .dsc has a Dgit field, there are three
2142 # relevant git commitids we need to choose between and/or merge
2144 # 1. $dsc_hash: the Dgit field from the archive
2145 # 2. $lastpush_hash: the suite branch on the dgit git server
2146 # 3. $lastfetch_hash: our local tracking brach for the suite
2148 # These may all be distinct and need not be in any fast forward
2151 # If the dsc was pushed to this suite, then the server suite
2152 # branch will have been updated; but it might have been pushed to
2153 # a different suite and copied by the archive. Conversely a more
2154 # recent version may have been pushed with dgit but not appeared
2155 # in the archive (yet).
2157 # $lastfetch_hash may be awkward because archive imports
2158 # (particularly, imports of Dgit-less .dscs) are performed only as
2159 # needed on individual clients, so different clients may perform a
2160 # different subset of them - and these imports are only made
2161 # public during push. So $lastfetch_hash may represent a set of
2162 # imports different to a subsequent upload by a different dgit
2165 # Our approach is as follows:
2167 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2168 # descendant of $dsc_hash, then it was pushed by a dgit user who
2169 # had based their work on $dsc_hash, so we should prefer it.
2170 # Otherwise, $dsc_hash was installed into this suite in the
2171 # archive other than by a dgit push, and (necessarily) after the
2172 # last dgit push into that suite (since a dgit push would have
2173 # been descended from the dgit server git branch); thus, in that
2174 # case, we prefer the archive's version (and produce a
2175 # pseudo-merge to overwrite the dgit server git branch).
2177 # (If there is no Dgit field in the archive's .dsc then
2178 # generate_commit_from_dsc uses the version numbers to decide
2179 # whether the suite branch or the archive is newer. If the suite
2180 # branch is newer it ignores the archive's .dsc; otherwise it
2181 # generates an import of the .dsc, and produces a pseudo-merge to
2182 # overwrite the suite branch with the archive contents.)
2184 # The outcome of that part of the algorithm is the `public view',
2185 # and is same for all dgit clients: it does not depend on any
2186 # unpublished history in the local tracking branch.
2188 # As between the public view and the local tracking branch: The
2189 # local tracking branch is only updated by dgit fetch, and
2190 # whenever dgit fetch runs it includes the public view in the
2191 # local tracking branch. Therefore if the public view is not
2192 # descended from the local tracking branch, the local tracking
2193 # branch must contain history which was imported from the archive
2194 # but never pushed; and, its tip is now out of date. So, we make
2195 # a pseudo-merge to overwrite the old imports and stitch the old
2198 # Finally: we do not necessarily reify the public view (as
2199 # described above). This is so that we do not end up stacking two
2200 # pseudo-merges. So what we actually do is figure out the inputs
2201 # to any public view pseudo-merge and put them in @mergeinputs.
2204 # $mergeinputs[]{Commit}
2205 # $mergeinputs[]{Info}
2206 # $mergeinputs[0] is the one whose tree we use
2207 # @mergeinputs is in the order we use in the actual commit)
2210 # $mergeinputs[]{Message} is a commit message to use
2211 # $mergeinputs[]{ReverseParents} if def specifies that parent
2212 # list should be in opposite order
2213 # Such an entry has no Commit or Info. It applies only when found
2214 # in the last entry. (This ugliness is to support making
2215 # identical imports to previous dgit versions.)
2217 my $lastpush_hash = git_get_ref(lrfetchref());
2218 printdebug "previous reference hash=$lastpush_hash\n";
2219 $lastpush_mergeinput = $lastpush_hash && {
2220 Commit => $lastpush_hash,
2221 Info => "dgit suite branch on dgit git server",
2224 my $lastfetch_hash = git_get_ref(lrref());
2225 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2226 my $lastfetch_mergeinput = $lastfetch_hash && {
2227 Commit => $lastfetch_hash,
2228 Info => "dgit client's archive history view",
2231 my $dsc_mergeinput = $dsc_hash && {
2232 Commit => $dsc_hash,
2233 Info => "Dgit field in .dsc from archive",
2237 my $del_lrfetchrefs = sub {
2240 printdebug "del_lrfetchrefs...\n";
2241 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2242 my $objid = $lrfetchrefs_d{$fullrefname};
2243 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2245 $gur ||= new IO::Handle;
2246 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2248 printf $gur "delete %s %s\n", $fullrefname, $objid;
2251 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2255 if (defined $dsc_hash) {
2256 fail "missing remote git history even though dsc has hash -".
2257 " could not find ref ".rref()." at ".access_giturl()
2258 unless $lastpush_hash;
2259 ensure_we_have_orig();
2260 if ($dsc_hash eq $lastpush_hash) {
2261 @mergeinputs = $dsc_mergeinput
2262 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2263 print STDERR <<END or die $!;
2265 Git commit in archive is behind the last version allegedly pushed/uploaded.
2266 Commit referred to by archive: $dsc_hash
2267 Last version pushed with dgit: $lastpush_hash
2270 @mergeinputs = ($lastpush_mergeinput);
2272 # Archive has .dsc which is not a descendant of the last dgit
2273 # push. This can happen if the archive moves .dscs about.
2274 # Just follow its lead.
2275 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2276 progress "archive .dsc names newer git commit";
2277 @mergeinputs = ($dsc_mergeinput);
2279 progress "archive .dsc names other git commit, fixing up";
2280 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2284 @mergeinputs = generate_commits_from_dsc();
2285 # We have just done an import. Now, our import algorithm might
2286 # have been improved. But even so we do not want to generate
2287 # a new different import of the same package. So if the
2288 # version numbers are the same, just use our existing version.
2289 # If the version numbers are different, the archive has changed
2290 # (perhaps, rewound).
2291 if ($lastfetch_mergeinput &&
2292 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2293 (mergeinfo_version $mergeinputs[0]) )) {
2294 @mergeinputs = ($lastfetch_mergeinput);
2296 } elsif ($lastpush_hash) {
2297 # only in git, not in the archive yet
2298 @mergeinputs = ($lastpush_mergeinput);
2299 print STDERR <<END or die $!;
2301 Package not found in the archive, but has allegedly been pushed using dgit.
2305 printdebug "nothing found!\n";
2306 if (defined $skew_warning_vsn) {
2307 print STDERR <<END or die $!;
2309 Warning: relevant archive skew detected.
2310 Archive allegedly contains $skew_warning_vsn
2311 But we were not able to obtain any version from the archive or git.
2315 unshift @end, $del_lrfetchrefs;
2319 if ($lastfetch_hash &&
2321 my $h = $_->{Commit};
2322 $h and is_fast_fwd($lastfetch_hash, $h);
2323 # If true, one of the existing parents of this commit
2324 # is a descendant of the $lastfetch_hash, so we'll
2325 # be ff from that automatically.
2329 push @mergeinputs, $lastfetch_mergeinput;
2332 printdebug "fetch mergeinfos:\n";
2333 foreach my $mi (@mergeinputs) {
2335 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2337 printdebug sprintf " ReverseParents=%d Message=%s",
2338 $mi->{ReverseParents}, $mi->{Message};
2342 my $compat_info= pop @mergeinputs
2343 if $mergeinputs[$#mergeinputs]{Message};
2345 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2348 if (@mergeinputs > 1) {
2350 my $tree_commit = $mergeinputs[0]{Commit};
2352 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2353 $tree =~ m/\n\n/; $tree = $`;
2354 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2357 # We use the changelog author of the package in question the
2358 # author of this pseudo-merge. This is (roughly) correct if
2359 # this commit is simply representing aa non-dgit upload.
2360 # (Roughly because it does not record sponsorship - but we
2361 # don't have sponsorship info because that's in the .changes,
2362 # which isn't in the archivw.)
2364 # But, it might be that we are representing archive history
2365 # updates (including in-archive copies). These are not really
2366 # the responsibility of the person who created the .dsc, but
2367 # there is no-one whose name we should better use. (The
2368 # author of the .dsc-named commit is clearly worse.)
2370 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2371 my $author = clogp_authline $useclogp;
2372 my $cversion = getfield $useclogp, 'Version';
2374 my $mcf = ".git/dgit/mergecommit";
2375 open MC, ">", $mcf or die "$mcf $!";
2376 print MC <<END or die $!;
2380 my @parents = grep { $_->{Commit} } @mergeinputs;
2381 @parents = reverse @parents if $compat_info->{ReverseParents};
2382 print MC <<END or die $! foreach @parents;
2386 print MC <<END or die $!;
2392 if (defined $compat_info->{Message}) {
2393 print MC $compat_info->{Message} or die $!;
2395 print MC <<END or die $!;
2396 Record $package ($cversion) in archive suite $csuite
2400 my $message_add_info = sub {
2402 my $mversion = mergeinfo_version $mi;
2403 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2407 $message_add_info->($mergeinputs[0]);
2408 print MC <<END or die $!;
2409 should be treated as descended from
2411 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2415 $hash = make_commit $mcf;
2417 $hash = $mergeinputs[0]{Commit};
2419 printdebug "fetch hash=$hash\n";
2422 my ($lasth, $what) = @_;
2423 return unless $lasth;
2424 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2427 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2428 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2430 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2431 'DGIT_ARCHIVE', $hash;
2432 cmdoutput @git, qw(log -n2), $hash;
2433 # ... gives git a chance to complain if our commit is malformed
2435 if (defined $skew_warning_vsn) {
2437 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2438 my $gotclogp = commit_getclogp($hash);
2439 my $got_vsn = getfield $gotclogp, 'Version';
2440 printdebug "SKEW CHECK GOT $got_vsn\n";
2441 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2442 print STDERR <<END or die $!;
2444 Warning: archive skew detected. Using the available version:
2445 Archive allegedly contains $skew_warning_vsn
2446 We were able to obtain only $got_vsn
2452 if ($lastfetch_hash ne $hash) {
2453 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2457 dryrun_report @upd_cmd;
2461 lrfetchref_used lrfetchref();
2463 unshift @end, $del_lrfetchrefs;
2467 sub set_local_git_config ($$) {
2469 runcmd @git, qw(config), $k, $v;
2472 sub setup_mergechangelogs (;$) {
2474 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2476 my $driver = 'dpkg-mergechangelogs';
2477 my $cb = "merge.$driver";
2478 my $attrs = '.git/info/attributes';
2479 ensuredir '.git/info';
2481 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2482 if (!open ATTRS, "<", $attrs) {
2483 $!==ENOENT or die "$attrs: $!";
2487 next if m{^debian/changelog\s};
2488 print NATTRS $_, "\n" or die $!;
2490 ATTRS->error and die $!;
2493 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2496 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2497 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2499 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2502 sub setup_useremail (;$) {
2504 return unless $always || access_cfg_bool(1, 'setup-useremail');
2507 my ($k, $envvar) = @_;
2508 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2509 return unless defined $v;
2510 set_local_git_config "user.$k", $v;
2513 $setup->('email', 'DEBEMAIL');
2514 $setup->('name', 'DEBFULLNAME');
2517 sub setup_new_tree () {
2518 setup_mergechangelogs();
2524 canonicalise_suite();
2525 badusage "dry run makes no sense with clone" unless act_local();
2526 my $hasgit = check_for_git();
2527 mkdir $dstdir or fail "create \`$dstdir': $!";
2529 runcmd @git, qw(init -q);
2530 my $giturl = access_giturl(1);
2531 if (defined $giturl) {
2532 open H, "> .git/HEAD" or die $!;
2533 print H "ref: ".lref()."\n" or die $!;
2535 runcmd @git, qw(remote add), 'origin', $giturl;
2538 progress "fetching existing git history";
2540 runcmd_ordryrun_local @git, qw(fetch origin);
2542 progress "starting new git history";
2544 fetch_from_archive() or no_such_package;
2545 my $vcsgiturl = $dsc->{'Vcs-Git'};
2546 if (length $vcsgiturl) {
2547 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2548 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2551 runcmd @git, qw(reset --hard), lrref();
2552 printdone "ready for work in $dstdir";
2556 if (check_for_git()) {
2559 fetch_from_archive() or no_such_package();
2560 printdone "fetched into ".lrref();
2565 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2567 printdone "fetched to ".lrref()." and merged into HEAD";
2570 sub check_not_dirty () {
2571 foreach my $f (qw(local-options local-patch-header)) {
2572 if (stat_exists "debian/source/$f") {
2573 fail "git tree contains debian/source/$f";
2577 return if $ignoredirty;
2579 my @cmd = (@git, qw(diff --quiet HEAD));
2581 $!=0; $?=-1; system @cmd;
2584 fail "working tree is dirty (does not match HEAD)";
2590 sub commit_admin ($) {
2593 runcmd_ordryrun_local @git, qw(commit -m), $m;
2596 sub commit_quilty_patch () {
2597 my $output = cmdoutput @git, qw(status --porcelain);
2599 foreach my $l (split /\n/, $output) {
2600 next unless $l =~ m/\S/;
2601 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2605 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2607 progress "nothing quilty to commit, ok.";
2610 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2611 runcmd_ordryrun_local @git, qw(add -f), @adds;
2612 commit_admin "Commit Debian 3.0 (quilt) metadata";
2615 sub get_source_format () {
2617 if (open F, "debian/source/options") {
2621 s/\s+$//; # ignore missing final newline
2623 my ($k, $v) = ($`, $'); #');
2624 $v =~ s/^"(.*)"$/$1/;
2630 F->error and die $!;
2633 die $! unless $!==&ENOENT;
2636 if (!open F, "debian/source/format") {
2637 die $! unless $!==&ENOENT;
2641 F->error and die $!;
2643 return ($_, \%options);
2646 sub madformat_wantfixup ($) {
2648 return 0 unless $format eq '3.0 (quilt)';
2649 our $quilt_mode_warned;
2650 if ($quilt_mode eq 'nocheck') {
2651 progress "Not doing any fixup of \`$format' due to".
2652 " ----no-quilt-fixup or --quilt=nocheck"
2653 unless $quilt_mode_warned++;
2656 progress "Format \`$format', need to check/update patch stack"
2657 unless $quilt_mode_warned++;
2661 # An "infopair" is a tuple [ $thing, $what ]
2662 # (often $thing is a commit hash; $what is a description)
2664 sub infopair_cond_equal ($$) {
2666 $x->[0] eq $y->[0] or fail <<END;
2667 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2671 sub infopair_lrf_tag_lookup ($$) {
2672 my ($tagnames, $what) = @_;
2673 # $tagname may be an array ref
2674 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2675 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2676 foreach my $tagname (@tagnames) {
2677 my $lrefname = lrfetchrefs."/tags/$tagname";
2678 my $tagobj = $lrfetchrefs_f{$lrefname};
2679 next unless defined $tagobj;
2680 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2681 return [ git_rev_parse($tagobj), $what ];
2683 fail @tagnames==1 ? <<END : <<END;
2684 Wanted tag $what (@tagnames) on dgit server, but not found
2686 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2690 sub infopair_cond_ff ($$) {
2691 my ($anc,$desc) = @_;
2692 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2693 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2697 sub pseudomerge_version_check ($$) {
2698 my ($clogp, $archive_hash) = @_;
2700 my $arch_clogp = commit_getclogp $archive_hash;
2701 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2702 'version currently in archive' ];
2703 if (defined $overwrite_version) {
2704 if (length $overwrite_version) {
2705 infopair_cond_equal([ $overwrite_version,
2706 '--overwrite= version' ],
2709 my $v = $i_arch_v->[0];
2710 progress "Checking package changelog for archive version $v ...";
2712 my @xa = ("-f$v", "-t$v");
2713 my $vclogp = parsechangelog @xa;
2714 my $cv = [ (getfield $vclogp, 'Version'),
2715 "Version field from dpkg-parsechangelog @xa" ];
2716 infopair_cond_equal($i_arch_v, $cv);
2719 $@ =~ s/^dgit: //gm;
2721 "Perhaps debian/changelog does not mention $v ?";
2726 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2730 sub pseudomerge_make_commit ($$$$ $$) {
2731 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2732 $msg_cmd, $msg_msg) = @_;
2733 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2735 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2736 my $authline = clogp_authline $clogp;
2740 !defined $overwrite_version ? ""
2741 : !length $overwrite_version ? " --overwrite"
2742 : " --overwrite=".$overwrite_version;
2745 my $pmf = ".git/dgit/pseudomerge";
2746 open MC, ">", $pmf or die "$pmf $!";
2747 print MC <<END or die $!;
2750 parent $archive_hash
2760 return make_commit($pmf);
2763 sub splitbrain_pseudomerge ($$$$) {
2764 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2765 # => $merged_dgitview
2766 printdebug "splitbrain_pseudomerge...\n";
2768 # We: debian/PREVIOUS HEAD($maintview)
2769 # expect: o ----------------- o
2772 # a/d/PREVIOUS $dgitview
2775 # we do: `------------------ o
2779 printdebug "splitbrain_pseudomerge...\n";
2781 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2783 return $dgitview unless defined $archive_hash;
2785 if (!defined $overwrite_version) {
2786 progress "Checking that HEAD inciudes all changes in archive...";
2789 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2791 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2792 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2793 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2794 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2795 my $i_archive = [ $archive_hash, "current archive contents" ];
2797 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2799 infopair_cond_equal($i_dgit, $i_archive);
2800 infopair_cond_ff($i_dep14, $i_dgit);
2801 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2803 my $r = pseudomerge_make_commit
2804 $clogp, $dgitview, $archive_hash, $i_arch_v,
2805 "dgit --quilt=$quilt_mode",
2806 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2807 Declare fast forward from $overwrite_version
2809 Make fast forward from $i_arch_v->[0]
2812 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2816 sub plain_overwrite_pseudomerge ($$$) {
2817 my ($clogp, $head, $archive_hash) = @_;
2819 printdebug "plain_overwrite_pseudomerge...";
2821 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2823 my @tagformats = access_cfg_tagformats();
2825 map { $_->($i_arch_v->[0], access_basedistro) }
2826 (grep { m/^(?:old|hist)$/ } @tagformats)
2827 ? \&debiantags : \&debiantag_new;
2828 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2829 my $i_archive = [ $archive_hash, "current archive contents" ];
2831 infopair_cond_equal($i_overwr, $i_archive);
2833 return $head if is_fast_fwd $archive_hash, $head;
2835 my $m = "Declare fast forward from $i_arch_v->[0]";
2837 my $r = pseudomerge_make_commit
2838 $clogp, $head, $archive_hash, $i_arch_v,
2841 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2843 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2847 sub push_parse_changelog ($) {
2850 my $clogp = Dpkg::Control::Hash->new();
2851 $clogp->load($clogpfn) or die;
2853 $package = getfield $clogp, 'Source';
2854 my $cversion = getfield $clogp, 'Version';
2855 my $tag = debiantag($cversion, access_basedistro);
2856 runcmd @git, qw(check-ref-format), $tag;
2858 my $dscfn = dscfn($cversion);
2860 return ($clogp, $cversion, $dscfn);
2863 sub push_parse_dsc ($$$) {
2864 my ($dscfn,$dscfnwhat, $cversion) = @_;
2865 $dsc = parsecontrol($dscfn,$dscfnwhat);
2866 my $dversion = getfield $dsc, 'Version';
2867 my $dscpackage = getfield $dsc, 'Source';
2868 ($dscpackage eq $package && $dversion eq $cversion) or
2869 fail "$dscfn is for $dscpackage $dversion".
2870 " but debian/changelog is for $package $cversion";
2873 sub push_tagwants ($$$$) {
2874 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2877 TagFn => \&debiantag,
2882 if (defined $maintviewhead) {
2884 TagFn => \&debiantag_maintview,
2885 Objid => $maintviewhead,
2886 TfSuffix => '-maintview',
2890 foreach my $tw (@tagwants) {
2891 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2892 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2894 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2898 sub push_mktags ($$ $$ $) {
2900 $changesfile,$changesfilewhat,
2903 die unless $tagwants->[0]{View} eq 'dgit';
2905 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2906 $dsc->save("$dscfn.tmp") or die $!;
2908 my $changes = parsecontrol($changesfile,$changesfilewhat);
2909 foreach my $field (qw(Source Distribution Version)) {
2910 $changes->{$field} eq $clogp->{$field} or
2911 fail "changes field $field \`$changes->{$field}'".
2912 " does not match changelog \`$clogp->{$field}'";
2915 my $cversion = getfield $clogp, 'Version';
2916 my $clogsuite = getfield $clogp, 'Distribution';
2918 # We make the git tag by hand because (a) that makes it easier
2919 # to control the "tagger" (b) we can do remote signing
2920 my $authline = clogp_authline $clogp;
2921 my $delibs = join(" ", "",@deliberatelies);
2922 my $declaredistro = access_basedistro();
2926 my $tfn = $tw->{Tfn};
2927 my $head = $tw->{Objid};
2928 my $tag = $tw->{Tag};
2930 open TO, '>', $tfn->('.tmp') or die $!;
2931 print TO <<END or die $!;
2938 if ($tw->{View} eq 'dgit') {
2939 print TO <<END or die $!;
2940 $package release $cversion for $clogsuite ($csuite) [dgit]
2941 [dgit distro=$declaredistro$delibs]
2943 foreach my $ref (sort keys %previously) {
2944 print TO <<END or die $!;
2945 [dgit previously:$ref=$previously{$ref}]
2948 } elsif ($tw->{View} eq 'maint') {
2949 print TO <<END or die $!;
2950 $package release $cversion for $clogsuite ($csuite)
2951 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2954 die Dumper($tw)."?";
2959 my $tagobjfn = $tfn->('.tmp');
2961 if (!defined $keyid) {
2962 $keyid = access_cfg('keyid','RETURN-UNDEF');
2964 if (!defined $keyid) {
2965 $keyid = getfield $clogp, 'Maintainer';
2967 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2968 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2969 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2970 push @sign_cmd, $tfn->('.tmp');
2971 runcmd_ordryrun @sign_cmd;
2973 $tagobjfn = $tfn->('.signed.tmp');
2974 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2975 $tfn->('.tmp'), $tfn->('.tmp.asc');
2981 my @r = map { $mktag->($_); } @$tagwants;
2985 sub sign_changes ($) {
2986 my ($changesfile) = @_;
2988 my @debsign_cmd = @debsign;
2989 push @debsign_cmd, "-k$keyid" if defined $keyid;
2990 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2991 push @debsign_cmd, $changesfile;
2992 runcmd_ordryrun @debsign_cmd;
2997 printdebug "actually entering push\n";
2999 supplementary_message(<<'END');
3000 Push failed, while checking state of the archive.
3001 You can retry the push, after fixing the problem, if you like.
3003 if (check_for_git()) {
3006 my $archive_hash = fetch_from_archive();
3007 if (!$archive_hash) {
3009 fail "package appears to be new in this suite;".
3010 " if this is intentional, use --new";
3013 supplementary_message(<<'END');
3014 Push failed, while preparing your push.
3015 You can retry the push, after fixing the problem, if you like.
3018 need_tagformat 'new', "quilt mode $quilt_mode"
3019 if quiltmode_splitbrain;
3023 access_giturl(); # check that success is vaguely likely
3026 my $clogpfn = ".git/dgit/changelog.822.tmp";
3027 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3029 responder_send_file('parsed-changelog', $clogpfn);
3031 my ($clogp, $cversion, $dscfn) =
3032 push_parse_changelog("$clogpfn");
3034 my $dscpath = "$buildproductsdir/$dscfn";
3035 stat_exists $dscpath or
3036 fail "looked for .dsc $dscfn, but $!;".
3037 " maybe you forgot to build";
3039 responder_send_file('dsc', $dscpath);
3041 push_parse_dsc($dscpath, $dscfn, $cversion);
3043 my $format = getfield $dsc, 'Format';
3044 printdebug "format $format\n";
3046 my $actualhead = git_rev_parse('HEAD');
3047 my $dgithead = $actualhead;
3048 my $maintviewhead = undef;
3050 if (madformat_wantfixup($format)) {
3051 # user might have not used dgit build, so maybe do this now:
3052 if (quiltmode_splitbrain()) {
3053 my $upstreamversion = $clogp->{Version};
3054 $upstreamversion =~ s/-[^-]*$//;
3056 quilt_make_fake_dsc($upstreamversion);
3057 my ($dgitview, $cachekey) =
3058 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3060 "--quilt=$quilt_mode but no cached dgit view:
3061 perhaps tree changed since dgit build[-source] ?";
3063 $dgithead = splitbrain_pseudomerge($clogp,
3064 $actualhead, $dgitview,
3066 $maintviewhead = $actualhead;
3067 changedir '../../../..';
3068 prep_ud(); # so _only_subdir() works, below
3070 commit_quilty_patch();
3074 if (defined $overwrite_version && !defined $maintviewhead) {
3075 $dgithead = plain_overwrite_pseudomerge($clogp,
3083 if ($archive_hash) {
3084 if (is_fast_fwd($archive_hash, $dgithead)) {
3086 } elsif (deliberately_not_fast_forward) {
3089 fail "dgit push: HEAD is not a descendant".
3090 " of the archive's version.\n".
3091 "To overwrite the archive's contents,".
3092 " pass --overwrite[=VERSION].\n".
3093 "To rewind history, if permitted by the archive,".
3094 " use --deliberately-not-fast-forward.";
3099 progress "checking that $dscfn corresponds to HEAD";
3100 runcmd qw(dpkg-source -x --),
3101 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3102 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3103 check_for_vendor_patches() if madformat($dsc->{format});
3104 changedir '../../../..';
3105 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
3106 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
3107 debugcmd "+",@diffcmd;
3109 my $r = system @diffcmd;
3112 fail "$dscfn specifies a different tree to your HEAD commit;".
3113 " perhaps you forgot to build".
3114 ($diffopt eq '--exit-code' ? "" :
3115 " (run with -D to see full diff output)");
3120 if (!$changesfile) {
3121 my $pat = changespat $cversion;
3122 my @cs = glob "$buildproductsdir/$pat";
3123 fail "failed to find unique changes file".
3124 " (looked for $pat in $buildproductsdir);".
3125 " perhaps you need to use dgit -C"
3127 ($changesfile) = @cs;
3129 $changesfile = "$buildproductsdir/$changesfile";
3132 # Checks complete, we're going to try and go ahead:
3134 responder_send_file('changes',$changesfile);
3135 responder_send_command("param head $dgithead");
3136 responder_send_command("param csuite $csuite");
3137 responder_send_command("param tagformat $tagformat");
3138 if (defined $maintviewhead) {
3139 die unless ($protovsn//4) >= 4;
3140 responder_send_command("param maint-view $maintviewhead");
3143 if (deliberately_not_fast_forward) {
3144 git_for_each_ref(lrfetchrefs, sub {
3145 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3146 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3147 responder_send_command("previously $rrefname=$objid");
3148 $previously{$rrefname} = $objid;
3152 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3156 supplementary_message(<<'END');
3157 Push failed, while signing the tag.
3158 You can retry the push, after fixing the problem, if you like.
3160 # If we manage to sign but fail to record it anywhere, it's fine.
3161 if ($we_are_responder) {
3162 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3163 responder_receive_files('signed-tag', @tagobjfns);
3165 @tagobjfns = push_mktags($clogp,$dscpath,
3166 $changesfile,$changesfile,
3169 supplementary_message(<<'END');
3170 Push failed, *after* signing the tag.
3171 If you want to try again, you should use a new version number.
3174 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3176 foreach my $tw (@tagwants) {
3177 my $tag = $tw->{Tag};
3178 my $tagobjfn = $tw->{TagObjFn};
3180 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3181 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3182 runcmd_ordryrun_local
3183 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3186 supplementary_message(<<'END');
3187 Push failed, while updating the remote git repository - see messages above.
3188 If you want to try again, you should use a new version number.
3190 if (!check_for_git()) {
3191 create_remote_git_repo();
3194 my @pushrefs = $forceflag.$dgithead.":".rrref();
3195 foreach my $tw (@tagwants) {
3196 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3199 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
3200 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3202 supplementary_message(<<'END');
3203 Push failed, after updating the remote git repository.
3204 If you want to try again, you must use a new version number.
3206 if ($we_are_responder) {
3207 my $dryrunsuffix = act_local() ? "" : ".tmp";
3208 responder_receive_files('signed-dsc-changes',
3209 "$dscpath$dryrunsuffix",
3210 "$changesfile$dryrunsuffix");
3213 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3215 progress "[new .dsc left in $dscpath.tmp]";
3217 sign_changes $changesfile;
3220 supplementary_message(<<END);
3221 Push failed, while uploading package(s) to the archive server.
3222 You can retry the upload of exactly these same files with dput of:
3224 If that .changes file is broken, you will need to use a new version
3225 number for your next attempt at the upload.
3227 my $host = access_cfg('upload-host','RETURN-UNDEF');
3228 my @hostarg = defined($host) ? ($host,) : ();
3229 runcmd_ordryrun @dput, @hostarg, $changesfile;
3230 printdone "pushed and uploaded $cversion";
3232 supplementary_message('');
3233 responder_send_command("complete");
3240 badusage "-p is not allowed with clone; specify as argument instead"
3241 if defined $package;
3244 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3245 ($package,$isuite) = @ARGV;
3246 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3247 ($package,$dstdir) = @ARGV;
3248 } elsif (@ARGV==3) {
3249 ($package,$isuite,$dstdir) = @ARGV;
3251 badusage "incorrect arguments to dgit clone";
3253 $dstdir ||= "$package";
3255 if (stat_exists $dstdir) {
3256 fail "$dstdir already exists";
3260 if ($rmonerror && !$dryrun_level) {
3261 $cwd_remove= getcwd();
3263 return unless defined $cwd_remove;
3264 if (!chdir "$cwd_remove") {
3265 return if $!==&ENOENT;
3266 die "chdir $cwd_remove: $!";
3269 rmtree($dstdir) or die "remove $dstdir: $!\n";
3270 } elsif (!grep { $! == $_ }
3271 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3273 print STDERR "check whether to remove $dstdir: $!\n";
3279 $cwd_remove = undef;
3282 sub branchsuite () {
3283 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3284 if ($branch =~ m#$lbranch_re#o) {
3291 sub fetchpullargs () {
3293 if (!defined $package) {
3294 my $sourcep = parsecontrol('debian/control','debian/control');
3295 $package = getfield $sourcep, 'Source';
3298 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3300 my $clogp = parsechangelog();
3301 $isuite = getfield $clogp, 'Distribution';
3303 canonicalise_suite();
3304 progress "fetching from suite $csuite";
3305 } elsif (@ARGV==1) {
3307 canonicalise_suite();
3309 badusage "incorrect arguments to dgit fetch or dgit pull";
3328 badusage "-p is not allowed with dgit push" if defined $package;
3330 my $clogp = parsechangelog();
3331 $package = getfield $clogp, 'Source';
3334 } elsif (@ARGV==1) {
3335 ($specsuite) = (@ARGV);
3337 badusage "incorrect arguments to dgit push";
3339 $isuite = getfield $clogp, 'Distribution';
3341 local ($package) = $existing_package; # this is a hack
3342 canonicalise_suite();
3344 canonicalise_suite();
3346 if (defined $specsuite &&
3347 $specsuite ne $isuite &&
3348 $specsuite ne $csuite) {
3349 fail "dgit push: changelog specifies $isuite ($csuite)".
3350 " but command line specifies $specsuite";
3355 #---------- remote commands' implementation ----------
3357 sub cmd_remote_push_build_host {
3358 my ($nrargs) = shift @ARGV;
3359 my (@rargs) = @ARGV[0..$nrargs-1];
3360 @ARGV = @ARGV[$nrargs..$#ARGV];
3362 my ($dir,$vsnwant) = @rargs;
3363 # vsnwant is a comma-separated list; we report which we have
3364 # chosen in our ready response (so other end can tell if they
3367 $we_are_responder = 1;
3368 $us .= " (build host)";
3372 open PI, "<&STDIN" or die $!;
3373 open STDIN, "/dev/null" or die $!;
3374 open PO, ">&STDOUT" or die $!;
3376 open STDOUT, ">&STDERR" or die $!;
3380 ($protovsn) = grep {
3381 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3382 } @rpushprotovsn_support;
3384 fail "build host has dgit rpush protocol versions ".
3385 (join ",", @rpushprotovsn_support).
3386 " but invocation host has $vsnwant"
3387 unless defined $protovsn;
3389 responder_send_command("dgit-remote-push-ready $protovsn");
3390 rpush_handle_protovsn_bothends();
3395 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3396 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3397 # a good error message)
3399 sub rpush_handle_protovsn_bothends () {
3400 if ($protovsn < 4) {
3401 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3410 my $report = i_child_report();
3411 if (defined $report) {
3412 printdebug "($report)\n";
3413 } elsif ($i_child_pid) {
3414 printdebug "(killing build host child $i_child_pid)\n";
3415 kill 15, $i_child_pid;
3417 if (defined $i_tmp && !defined $initiator_tempdir) {
3419 eval { rmtree $i_tmp; };
3423 END { i_cleanup(); }
3426 my ($base,$selector,@args) = @_;
3427 $selector =~ s/\-/_/g;
3428 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3435 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3443 push @rargs, join ",", @rpushprotovsn_support;
3446 push @rdgit, @ropts;
3447 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3449 my @cmd = (@ssh, $host, shellquote @rdgit);
3452 if (defined $initiator_tempdir) {
3453 rmtree $initiator_tempdir;
3454 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3455 $i_tmp = $initiator_tempdir;
3459 $i_child_pid = open2(\*RO, \*RI, @cmd);
3461 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3462 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3463 $supplementary_message = '' unless $protovsn >= 3;
3465 fail "rpush negotiated protocol version $protovsn".
3466 " which does not support quilt mode $quilt_mode"
3467 if quiltmode_splitbrain;
3469 rpush_handle_protovsn_bothends();
3471 my ($icmd,$iargs) = initiator_expect {
3472 m/^(\S+)(?: (.*))?$/;
3475 i_method "i_resp", $icmd, $iargs;
3479 sub i_resp_progress ($) {
3481 my $msg = protocol_read_bytes \*RO, $rhs;
3485 sub i_resp_supplementary_message ($) {
3487 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3490 sub i_resp_complete {
3491 my $pid = $i_child_pid;
3492 $i_child_pid = undef; # prevents killing some other process with same pid
3493 printdebug "waiting for build host child $pid...\n";
3494 my $got = waitpid $pid, 0;
3495 die $! unless $got == $pid;
3496 die "build host child failed $?" if $?;
3499 printdebug "all done\n";
3503 sub i_resp_file ($) {
3505 my $localname = i_method "i_localname", $keyword;
3506 my $localpath = "$i_tmp/$localname";
3507 stat_exists $localpath and
3508 badproto \*RO, "file $keyword ($localpath) twice";
3509 protocol_receive_file \*RO, $localpath;
3510 i_method "i_file", $keyword;
3515 sub i_resp_param ($) {
3516 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3520 sub i_resp_previously ($) {
3521 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3522 or badproto \*RO, "bad previously spec";
3523 my $r = system qw(git check-ref-format), $1;
3524 die "bad previously ref spec ($r)" if $r;
3525 $previously{$1} = $2;
3530 sub i_resp_want ($) {
3532 die "$keyword ?" if $i_wanted{$keyword}++;
3533 my @localpaths = i_method "i_want", $keyword;
3534 printdebug "[[ $keyword @localpaths\n";
3535 foreach my $localpath (@localpaths) {
3536 protocol_send_file \*RI, $localpath;
3538 print RI "files-end\n" or die $!;
3541 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3543 sub i_localname_parsed_changelog {
3544 return "remote-changelog.822";
3546 sub i_file_parsed_changelog {
3547 ($i_clogp, $i_version, $i_dscfn) =
3548 push_parse_changelog "$i_tmp/remote-changelog.822";
3549 die if $i_dscfn =~ m#/|^\W#;
3552 sub i_localname_dsc {
3553 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3558 sub i_localname_changes {
3559 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3560 $i_changesfn = $i_dscfn;
3561 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3562 return $i_changesfn;
3564 sub i_file_changes { }
3566 sub i_want_signed_tag {
3567 printdebug Dumper(\%i_param, $i_dscfn);
3568 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3569 && defined $i_param{'csuite'}
3570 or badproto \*RO, "premature desire for signed-tag";
3571 my $head = $i_param{'head'};
3572 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3574 my $maintview = $i_param{'maint-view'};
3575 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3578 if ($protovsn >= 4) {
3579 my $p = $i_param{'tagformat'} // '<undef>';
3581 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3584 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3586 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3588 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3591 push_mktags $i_clogp, $i_dscfn,
3592 $i_changesfn, 'remote changes',
3596 sub i_want_signed_dsc_changes {
3597 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3598 sign_changes $i_changesfn;
3599 return ($i_dscfn, $i_changesfn);
3602 #---------- building etc. ----------
3608 #----- `3.0 (quilt)' handling -----
3610 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3612 sub quiltify_dpkg_commit ($$$;$) {
3613 my ($patchname,$author,$msg, $xinfo) = @_;
3617 my $descfn = ".git/dgit/quilt-description.tmp";
3618 open O, '>', $descfn or die "$descfn: $!";
3621 $msg =~ s/^\s+$/ ./mg;
3622 print O <<END or die $!;
3632 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3633 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3634 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3635 runcmd @dpkgsource, qw(--commit .), $patchname;
3639 sub quiltify_trees_differ ($$;$$) {
3640 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3641 # returns true iff the two tree objects differ other than in debian/
3642 # with $finegrained,
3643 # returns bitmask 01 - differ in upstream files except .gitignore
3644 # 02 - differ in .gitignore
3645 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3646 # is set for each modified .gitignore filename $fn
3648 my @cmd = (@git, qw(diff-tree --name-only -z));
3649 push @cmd, qw(-r) if $finegrained;
3651 my $diffs= cmdoutput @cmd;
3653 foreach my $f (split /\0/, $diffs) {
3654 next if $f =~ m#^debian(?:/.*)?$#s;
3655 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3656 $r |= $isignore ? 02 : 01;
3657 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3659 printdebug "quiltify_trees_differ $x $y => $r\n";
3663 sub quiltify_tree_sentinelfiles ($) {
3664 # lists the `sentinel' files present in the tree
3666 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3667 qw(-- debian/rules debian/control);
3672 sub quiltify_splitbrain_needed () {
3673 if (!$split_brain) {
3674 progress "dgit view: changes are required...";
3675 runcmd @git, qw(checkout -q -b dgit-view);
3680 sub quiltify_splitbrain ($$$$$$) {
3681 my ($clogp, $unapplied, $headref, $diffbits,
3682 $editedignores, $cachekey) = @_;
3683 if ($quilt_mode !~ m/gbp|dpm/) {
3684 # treat .gitignore just like any other upstream file
3685 $diffbits = { %$diffbits };
3686 $_ = !!$_ foreach values %$diffbits;
3688 # We would like any commits we generate to be reproducible
3689 my @authline = clogp_authline($clogp);
3690 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3691 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3692 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3693 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3694 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3695 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3697 if ($quilt_mode =~ m/gbp|unapplied/ &&
3698 ($diffbits->{H2O} & 01)) {
3700 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3701 " but git tree differs from orig in upstream files.";
3702 if (!stat_exists "debian/patches") {
3704 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3708 if ($quilt_mode =~ m/dpm/ &&
3709 ($diffbits->{H2A} & 01)) {
3711 --quilt=$quilt_mode specified, implying patches-applied git tree
3712 but git tree differs from result of applying debian/patches to upstream
3715 if ($quilt_mode =~ m/gbp|unapplied/ &&
3716 ($diffbits->{O2A} & 01)) { # some patches
3717 quiltify_splitbrain_needed();
3718 progress "dgit view: creating patches-applied version using gbp pq";
3719 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3720 # gbp pq import creates a fresh branch; push back to dgit-view
3721 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3722 runcmd @git, qw(checkout -q dgit-view);
3724 if ($quilt_mode =~ m/gbp|dpm/ &&
3725 ($diffbits->{O2A} & 02)) {
3727 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3728 tool which does not create patches for changes to upstream
3729 .gitignores: but, such patches exist in debian/patches.
3732 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3733 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3734 quiltify_splitbrain_needed();
3735 progress "dgit view: creating patch to represent .gitignore changes";
3736 ensuredir "debian/patches";
3737 my $gipatch = "debian/patches/auto-gitignore";
3738 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3739 stat GIPATCH or die "$gipatch: $!";
3740 fail "$gipatch already exists; but want to create it".
3741 " to record .gitignore changes" if (stat _)[7];
3742 print GIPATCH <<END or die "$gipatch: $!";
3743 Subject: Update .gitignore from Debian packaging branch
3745 The Debian packaging git branch contains these updates to the upstream
3746 .gitignore file(s). This patch is autogenerated, to provide these
3747 updates to users of the official Debian archive view of the package.
3749 [dgit ($our_version) update-gitignore]
3752 close GIPATCH or die "$gipatch: $!";
3753 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3754 $unapplied, $headref, "--", sort keys %$editedignores;
3755 open SERIES, "+>>", "debian/patches/series" or die $!;
3756 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3758 defined read SERIES, $newline, 1 or die $!;
3759 print SERIES "\n" or die $! unless $newline eq "\n";
3760 print SERIES "auto-gitignore\n" or die $!;
3761 close SERIES or die $!;
3762 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3763 commit_admin "Commit patch to update .gitignore";
3766 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3768 changedir '../../../..';
3769 ensuredir ".git/logs/refs/dgit-intern";
3770 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3772 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3775 progress "dgit view: created (commit id $dgitview)";
3777 changedir '.git/dgit/unpack/work';
3780 sub quiltify ($$$$) {
3781 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3783 # Quilt patchification algorithm
3785 # We search backwards through the history of the main tree's HEAD
3786 # (T) looking for a start commit S whose tree object is identical
3787 # to to the patch tip tree (ie the tree corresponding to the
3788 # current dpkg-committed patch series). For these purposes
3789 # `identical' disregards anything in debian/ - this wrinkle is
3790 # necessary because dpkg-source treates debian/ specially.
3792 # We can only traverse edges where at most one of the ancestors'
3793 # trees differs (in changes outside in debian/). And we cannot
3794 # handle edges which change .pc/ or debian/patches. To avoid
3795 # going down a rathole we avoid traversing edges which introduce
3796 # debian/rules or debian/control. And we set a limit on the
3797 # number of edges we are willing to look at.
3799 # If we succeed, we walk forwards again. For each traversed edge
3800 # PC (with P parent, C child) (starting with P=S and ending with
3801 # C=T) to we do this:
3803 # - dpkg-source --commit with a patch name and message derived from C
3804 # After traversing PT, we git commit the changes which
3805 # should be contained within debian/patches.
3807 # The search for the path S..T is breadth-first. We maintain a
3808 # todo list containing search nodes. A search node identifies a
3809 # commit, and looks something like this:
3811 # Commit => $git_commit_id,
3812 # Child => $c, # or undef if P=T
3813 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3814 # Nontrivial => true iff $p..$c has relevant changes
3821 my %considered; # saves being exponential on some weird graphs
3823 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3826 my ($search,$whynot) = @_;
3827 printdebug " search NOT $search->{Commit} $whynot\n";
3828 $search->{Whynot} = $whynot;
3829 push @nots, $search;
3830 no warnings qw(exiting);
3839 my $c = shift @todo;
3840 next if $considered{$c->{Commit}}++;
3842 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3844 printdebug "quiltify investigate $c->{Commit}\n";
3847 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3848 printdebug " search finished hooray!\n";
3853 if ($quilt_mode eq 'nofix') {
3854 fail "quilt fixup required but quilt mode is \`nofix'\n".
3855 "HEAD commit $c->{Commit} differs from tree implied by ".
3856 " debian/patches (tree object $oldtiptree)";
3858 if ($quilt_mode eq 'smash') {
3859 printdebug " search quitting smash\n";
3863 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3864 $not->($c, "has $c_sentinels not $t_sentinels")
3865 if $c_sentinels ne $t_sentinels;
3867 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3868 $commitdata =~ m/\n\n/;
3870 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3871 @parents = map { { Commit => $_, Child => $c } } @parents;
3873 $not->($c, "root commit") if !@parents;
3875 foreach my $p (@parents) {
3876 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3878 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3879 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3881 foreach my $p (@parents) {
3882 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3884 my @cmd= (@git, qw(diff-tree -r --name-only),
3885 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3886 my $patchstackchange = cmdoutput @cmd;
3887 if (length $patchstackchange) {
3888 $patchstackchange =~ s/\n/,/g;
3889 $not->($p, "changed $patchstackchange");
3892 printdebug " search queue P=$p->{Commit} ",
3893 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3899 printdebug "quiltify want to smash\n";
3902 my $x = $_[0]{Commit};
3903 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3906 my $reportnot = sub {
3908 my $s = $abbrev->($notp);
3909 my $c = $notp->{Child};
3910 $s .= "..".$abbrev->($c) if $c;
3911 $s .= ": ".$notp->{Whynot};
3914 if ($quilt_mode eq 'linear') {
3915 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3916 foreach my $notp (@nots) {
3917 print STDERR "$us: ", $reportnot->($notp), "\n";
3919 print STDERR "$us: $_\n" foreach @$failsuggestion;
3920 fail "quilt fixup naive history linearisation failed.\n".
3921 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3922 } elsif ($quilt_mode eq 'smash') {
3923 } elsif ($quilt_mode eq 'auto') {
3924 progress "quilt fixup cannot be linear, smashing...";
3926 die "$quilt_mode ?";
3929 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3930 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3932 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3934 quiltify_dpkg_commit "auto-$version-$target-$time",
3935 (getfield $clogp, 'Maintainer'),
3936 "Automatically generated patch ($clogp->{Version})\n".
3937 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3941 progress "quiltify linearisation planning successful, executing...";
3943 for (my $p = $sref_S;
3944 my $c = $p->{Child};
3946 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3947 next unless $p->{Nontrivial};
3949 my $cc = $c->{Commit};
3951 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3952 $commitdata =~ m/\n\n/ or die "$c ?";
3955 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3958 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3961 my $patchname = $title;
3962 $patchname =~ s/[.:]$//;
3963 $patchname =~ y/ A-Z/-a-z/;
3964 $patchname =~ y/-a-z0-9_.+=~//cd;
3965 $patchname =~ s/^\W/x-$&/;
3966 $patchname = substr($patchname,0,40);
3969 stat "debian/patches/$patchname$index";
3971 $!==ENOENT or die "$patchname$index $!";
3973 runcmd @git, qw(checkout -q), $cc;
3975 # We use the tip's changelog so that dpkg-source doesn't
3976 # produce complaining messages from dpkg-parsechangelog. None
3977 # of the information dpkg-source gets from the changelog is
3978 # actually relevant - it gets put into the original message
3979 # which dpkg-source provides our stunt editor, and then
3981 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3983 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3984 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3986 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3989 runcmd @git, qw(checkout -q master);
3992 sub build_maybe_quilt_fixup () {
3993 my ($format,$fopts) = get_source_format;
3994 return unless madformat_wantfixup $format;
3997 check_for_vendor_patches();
3999 if (quiltmode_splitbrain) {
4000 foreach my $needtf (qw(new maint)) {
4001 next if grep { $_ eq $needtf } access_cfg_tagformats;
4003 quilt mode $quilt_mode requires split view so server needs to support
4004 both "new" and "maint" tag formats, but config says it doesn't.
4009 my $clogp = parsechangelog();
4010 my $headref = git_rev_parse('HEAD');
4015 my $upstreamversion=$version;
4016 $upstreamversion =~ s/-[^-]*$//;
4018 if ($fopts->{'single-debian-patch'}) {
4019 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4021 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4024 die 'bug' if $split_brain && !$need_split_build_invocation;
4026 changedir '../../../..';
4027 runcmd_ordryrun_local
4028 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4031 sub quilt_fixup_mkwork ($) {
4034 mkdir "work" or die $!;
4036 mktree_in_ud_here();
4037 runcmd @git, qw(reset -q --hard), $headref;
4040 sub quilt_fixup_linkorigs ($$) {
4041 my ($upstreamversion, $fn) = @_;
4042 # calls $fn->($leafname);
4044 foreach my $f (<../../../../*>) { #/){
4045 my $b=$f; $b =~ s{.*/}{};
4047 local ($debuglevel) = $debuglevel-1;
4048 printdebug "QF linkorigs $b, $f ?\n";
4050 next unless is_orig_file_of_vsn $b, $upstreamversion;
4051 printdebug "QF linkorigs $b, $f Y\n";
4052 link_ltarget $f, $b or die "$b $!";
4057 sub quilt_fixup_delete_pc () {
4058 runcmd @git, qw(rm -rqf .pc);
4059 commit_admin "Commit removal of .pc (quilt series tracking data)";
4062 sub quilt_fixup_singlepatch ($$$) {
4063 my ($clogp, $headref, $upstreamversion) = @_;
4065 progress "starting quiltify (single-debian-patch)";
4067 # dpkg-source --commit generates new patches even if
4068 # single-debian-patch is in debian/source/options. In order to
4069 # get it to generate debian/patches/debian-changes, it is
4070 # necessary to build the source package.
4072 quilt_fixup_linkorigs($upstreamversion, sub { });
4073 quilt_fixup_mkwork($headref);
4075 rmtree("debian/patches");
4077 runcmd @dpkgsource, qw(-b .);
4079 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4080 rename srcfn("$upstreamversion", "/debian/patches"),
4081 "work/debian/patches";
4084 commit_quilty_patch();
4087 sub quilt_make_fake_dsc ($) {
4088 my ($upstreamversion) = @_;
4090 my $fakeversion="$upstreamversion-~~DGITFAKE";
4092 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4093 print $fakedsc <<END or die $!;
4096 Version: $fakeversion
4100 my $dscaddfile=sub {
4103 my $md = new Digest::MD5;
4105 my $fh = new IO::File $b, '<' or die "$b $!";
4110 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4113 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4115 my @files=qw(debian/source/format debian/rules
4116 debian/control debian/changelog);
4117 foreach my $maybe (qw(debian/patches debian/source/options
4118 debian/tests/control)) {
4119 next unless stat_exists "../../../$maybe";
4120 push @files, $maybe;
4123 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4124 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4126 $dscaddfile->($debtar);
4127 close $fakedsc or die $!;
4130 sub quilt_check_splitbrain_cache ($$) {
4131 my ($headref, $upstreamversion) = @_;
4132 # Called only if we are in (potentially) split brain mode.
4134 # Computes the cache key and looks in the cache.
4135 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4137 my $splitbrain_cachekey;
4140 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4141 # we look in the reflog of dgit-intern/quilt-cache
4142 # we look for an entry whose message is the key for the cache lookup
4143 my @cachekey = (qw(dgit), $our_version);
4144 push @cachekey, $upstreamversion;
4145 push @cachekey, $quilt_mode;
4146 push @cachekey, $headref;
4148 push @cachekey, hashfile('fake.dsc');
4150 my $srcshash = Digest::SHA->new(256);
4151 my %sfs = ( %INC, '$0(dgit)' => $0 );
4152 foreach my $sfk (sort keys %sfs) {
4153 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
4154 $srcshash->add($sfk," ");
4155 $srcshash->add(hashfile($sfs{$sfk}));
4156 $srcshash->add("\n");
4158 push @cachekey, $srcshash->hexdigest();
4159 $splitbrain_cachekey = "@cachekey";
4161 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
4163 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4164 debugcmd "|(probably)",@cmd;
4165 my $child = open GC, "-|"; defined $child or die $!;
4167 chdir '../../..' or die $!;
4168 if (!stat ".git/logs/refs/$splitbraincache") {
4169 $! == ENOENT or die $!;
4170 printdebug ">(no reflog)\n";
4177 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4178 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4181 quilt_fixup_mkwork($headref);
4182 if ($cachehit ne $headref) {
4183 progress "dgit view: found cached (commit id $cachehit)";
4184 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4186 return ($cachehit, $splitbrain_cachekey);
4188 progress "dgit view: found cached, no changes required";
4189 return ($headref, $splitbrain_cachekey);
4191 die $! if GC->error;
4192 failedcmd unless close GC;
4194 printdebug "splitbrain cache miss\n";
4195 return (undef, $splitbrain_cachekey);
4198 sub quilt_fixup_multipatch ($$$) {
4199 my ($clogp, $headref, $upstreamversion) = @_;
4201 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4204 # - honour any existing .pc in case it has any strangeness
4205 # - determine the git commit corresponding to the tip of
4206 # the patch stack (if there is one)
4207 # - if there is such a git commit, convert each subsequent
4208 # git commit into a quilt patch with dpkg-source --commit
4209 # - otherwise convert all the differences in the tree into
4210 # a single git commit
4214 # Our git tree doesn't necessarily contain .pc. (Some versions of
4215 # dgit would include the .pc in the git tree.) If there isn't
4216 # one, we need to generate one by unpacking the patches that we
4219 # We first look for a .pc in the git tree. If there is one, we
4220 # will use it. (This is not the normal case.)
4222 # Otherwise need to regenerate .pc so that dpkg-source --commit
4223 # can work. We do this as follows:
4224 # 1. Collect all relevant .orig from parent directory
4225 # 2. Generate a debian.tar.gz out of
4226 # debian/{patches,rules,source/format,source/options}
4227 # 3. Generate a fake .dsc containing just these fields:
4228 # Format Source Version Files
4229 # 4. Extract the fake .dsc
4230 # Now the fake .dsc has a .pc directory.
4231 # (In fact we do this in every case, because in future we will
4232 # want to search for a good base commit for generating patches.)
4234 # Then we can actually do the dpkg-source --commit
4235 # 1. Make a new working tree with the same object
4236 # store as our main tree and check out the main
4238 # 2. Copy .pc from the fake's extraction, if necessary
4239 # 3. Run dpkg-source --commit
4240 # 4. If the result has changes to debian/, then
4241 # - git-add them them
4242 # - git-add .pc if we had a .pc in-tree
4244 # 5. If we had a .pc in-tree, delete it, and git-commit
4245 # 6. Back in the main tree, fast forward to the new HEAD
4247 # Another situation we may have to cope with is gbp-style
4248 # patches-unapplied trees.
4250 # We would want to detect these, so we know to escape into
4251 # quilt_fixup_gbp. However, this is in general not possible.
4252 # Consider a package with a one patch which the dgit user reverts
4253 # (with git-revert or the moral equivalent).
4255 # That is indistinguishable in contents from a patches-unapplied
4256 # tree. And looking at the history to distinguish them is not
4257 # useful because the user might have made a confusing-looking git
4258 # history structure (which ought to produce an error if dgit can't
4259 # cope, not a silent reintroduction of an unwanted patch).
4261 # So gbp users will have to pass an option. But we can usually
4262 # detect their failure to do so: if the tree is not a clean
4263 # patches-applied tree, quilt linearisation fails, but the tree
4264 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4265 # they want --quilt=unapplied.
4267 # To help detect this, when we are extracting the fake dsc, we
4268 # first extract it with --skip-patches, and then apply the patches
4269 # afterwards with dpkg-source --before-build. That lets us save a
4270 # tree object corresponding to .origs.
4272 my $splitbrain_cachekey;
4274 quilt_make_fake_dsc($upstreamversion);
4276 if (quiltmode_splitbrain()) {
4278 ($cachehit, $splitbrain_cachekey) =
4279 quilt_check_splitbrain_cache($headref, $upstreamversion);
4280 return if $cachehit;
4284 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4286 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4287 rename $fakexdir, "fake" or die "$fakexdir $!";
4291 remove_stray_gits();
4292 mktree_in_ud_here();
4296 runcmd @git, qw(add -Af .);
4297 my $unapplied=git_write_tree();
4298 printdebug "fake orig tree object $unapplied\n";
4303 'exec dpkg-source --before-build . >/dev/null';
4307 quilt_fixup_mkwork($headref);
4310 if (stat_exists ".pc") {
4312 progress "Tree already contains .pc - will use it then delete it.";
4315 rename '../fake/.pc','.pc' or die $!;
4318 changedir '../fake';
4320 runcmd @git, qw(add -Af .);
4321 my $oldtiptree=git_write_tree();
4322 printdebug "fake o+d/p tree object $unapplied\n";
4323 changedir '../work';
4326 # We calculate some guesswork now about what kind of tree this might
4327 # be. This is mostly for error reporting.
4332 # O = orig, without patches applied
4333 # A = "applied", ie orig with H's debian/patches applied
4334 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4335 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4336 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4340 foreach my $b (qw(01 02)) {
4341 foreach my $v (qw(H2O O2A H2A)) {
4342 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4345 printdebug "differences \@dl @dl.\n";
4348 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4349 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4350 $dl[0], $dl[1], $dl[3], $dl[4],
4354 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4355 push @failsuggestion, "This might be a patches-unapplied branch.";
4356 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4357 push @failsuggestion, "This might be a patches-applied branch.";
4359 push @failsuggestion, "Maybe you need to specify one of".
4360 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4362 if (quiltmode_splitbrain()) {
4363 quiltify_splitbrain($clogp, $unapplied, $headref,
4364 $diffbits, \%editedignores,
4365 $splitbrain_cachekey);
4369 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4370 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4372 if (!open P, '>>', ".pc/applied-patches") {
4373 $!==&ENOENT or die $!;
4378 commit_quilty_patch();
4380 if ($mustdeletepc) {
4381 quilt_fixup_delete_pc();
4385 sub quilt_fixup_editor () {
4386 my $descfn = $ENV{$fakeeditorenv};
4387 my $editing = $ARGV[$#ARGV];
4388 open I1, '<', $descfn or die "$descfn: $!";
4389 open I2, '<', $editing or die "$editing: $!";
4390 unlink $editing or die "$editing: $!";
4391 open O, '>', $editing or die "$editing: $!";
4392 while (<I1>) { print O or die $!; } I1->error and die $!;
4395 $copying ||= m/^\-\-\- /;
4396 next unless $copying;
4399 I2->error and die $!;
4404 sub maybe_apply_patches_dirtily () {
4405 return unless $quilt_mode =~ m/gbp|unapplied/;
4406 print STDERR <<END or die $!;
4408 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4409 dgit: Have to apply the patches - making the tree dirty.
4410 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4413 $patches_applied_dirtily = 01;
4414 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4415 runcmd qw(dpkg-source --before-build .);
4418 sub maybe_unapply_patches_again () {
4419 progress "dgit: Unapplying patches again to tidy up the tree."
4420 if $patches_applied_dirtily;
4421 runcmd qw(dpkg-source --after-build .)
4422 if $patches_applied_dirtily & 01;
4424 if $patches_applied_dirtily & 02;
4425 $patches_applied_dirtily = 0;
4428 #----- other building -----
4430 our $clean_using_builder;
4431 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4432 # clean the tree before building (perhaps invoked indirectly by
4433 # whatever we are using to run the build), rather than separately
4434 # and explicitly by us.
4437 return if $clean_using_builder;
4438 if ($cleanmode eq 'dpkg-source') {
4439 maybe_apply_patches_dirtily();
4440 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4441 } elsif ($cleanmode eq 'dpkg-source-d') {
4442 maybe_apply_patches_dirtily();
4443 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4444 } elsif ($cleanmode eq 'git') {
4445 runcmd_ordryrun_local @git, qw(clean -xdf);
4446 } elsif ($cleanmode eq 'git-ff') {
4447 runcmd_ordryrun_local @git, qw(clean -xdff);
4448 } elsif ($cleanmode eq 'check') {
4449 my $leftovers = cmdoutput @git, qw(clean -xdn);
4450 if (length $leftovers) {
4451 print STDERR $leftovers, "\n" or die $!;
4452 fail "tree contains uncommitted files and --clean=check specified";
4454 } elsif ($cleanmode eq 'none') {
4461 badusage "clean takes no additional arguments" if @ARGV;
4464 maybe_unapply_patches_again();
4469 badusage "-p is not allowed when building" if defined $package;
4472 my $clogp = parsechangelog();
4473 $isuite = getfield $clogp, 'Distribution';
4474 $package = getfield $clogp, 'Source';
4475 $version = getfield $clogp, 'Version';
4476 build_maybe_quilt_fixup();
4478 my $pat = changespat $version;
4479 foreach my $f (glob "$buildproductsdir/$pat") {
4481 unlink $f or fail "remove old changes file $f: $!";
4483 progress "would remove $f";
4489 sub changesopts_initial () {
4490 my @opts =@changesopts[1..$#changesopts];
4493 sub changesopts_version () {
4494 if (!defined $changes_since_version) {
4495 my @vsns = archive_query('archive_query');
4496 my @quirk = access_quirk();
4497 if ($quirk[0] eq 'backports') {
4498 local $isuite = $quirk[2];
4500 canonicalise_suite();
4501 push @vsns, archive_query('archive_query');
4504 @vsns = map { $_->[0] } @vsns;
4505 @vsns = sort { -version_compare($a, $b) } @vsns;
4506 $changes_since_version = $vsns[0];
4507 progress "changelog will contain changes since $vsns[0]";
4509 $changes_since_version = '_';
4510 progress "package seems new, not specifying -v<version>";
4513 if ($changes_since_version ne '_') {
4514 return ("-v$changes_since_version");
4520 sub changesopts () {
4521 return (changesopts_initial(), changesopts_version());
4524 sub massage_dbp_args ($;$) {
4525 my ($cmd,$xargs) = @_;
4528 # - if we're going to split the source build out so we can
4529 # do strange things to it, massage the arguments to dpkg-buildpackage
4530 # so that the main build doessn't build source (or add an argument
4531 # to stop it building source by default).
4533 # - add -nc to stop dpkg-source cleaning the source tree,
4534 # unless we're not doing a split build and want dpkg-source
4535 # as cleanmode, in which case we can do nothing
4538 # 0 - source will NOT need to be built separately by caller
4539 # +1 - source will need to be built separately by caller
4540 # +2 - source will need to be built separately by caller AND
4541 # dpkg-buildpackage should not in fact be run at all!
4542 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4543 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4544 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4545 $clean_using_builder = 1;
4548 # -nc has the side effect of specifying -b if nothing else specified
4549 # and some combinations of -S, -b, et al, are errors, rather than
4550 # later simply overriding earlie. So we need to:
4551 # - search the command line for these options
4552 # - pick the last one
4553 # - perhaps add our own as a default
4554 # - perhaps adjust it to the corresponding non-source-building version
4556 foreach my $l ($cmd, $xargs) {
4558 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4561 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4563 if ($need_split_build_invocation) {
4564 printdebug "massage split $dmode.\n";
4565 $r = $dmode =~ m/[S]/ ? +2 :
4566 $dmode =~ y/gGF/ABb/ ? +1 :
4567 $dmode =~ m/[ABb]/ ? 0 :
4570 printdebug "massage done $r $dmode.\n";
4572 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4577 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4578 my $wantsrc = massage_dbp_args \@dbp;
4585 push @dbp, changesopts_version();
4586 maybe_apply_patches_dirtily();
4587 runcmd_ordryrun_local @dbp;
4589 maybe_unapply_patches_again();
4590 printdone "build successful\n";
4594 my @dbp = @dpkgbuildpackage;
4596 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4599 if (length executable_on_path('git-buildpackage')) {
4600 @cmd = qw(git-buildpackage);
4602 @cmd = qw(gbp buildpackage);
4604 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4609 if (!$clean_using_builder) {
4610 push @cmd, '--git-cleaner=true';
4614 maybe_unapply_patches_again();
4616 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4617 canonicalise_suite();
4618 push @cmd, "--git-debian-branch=".lbranch();
4620 push @cmd, changesopts();
4621 runcmd_ordryrun_local @cmd, @ARGV;
4623 printdone "build successful\n";
4625 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4628 my $our_cleanmode = $cleanmode;
4629 if ($need_split_build_invocation) {
4630 # Pretend that clean is being done some other way. This
4631 # forces us not to try to use dpkg-buildpackage to clean and
4632 # build source all in one go; and instead we run dpkg-source
4633 # (and build_prep() will do the clean since $clean_using_builder
4635 $our_cleanmode = 'ELSEWHERE';
4637 if ($our_cleanmode =~ m/^dpkg-source/) {
4638 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4639 $clean_using_builder = 1;
4642 $sourcechanges = changespat $version,'source';
4644 unlink "../$sourcechanges" or $!==ENOENT
4645 or fail "remove $sourcechanges: $!";
4647 $dscfn = dscfn($version);
4648 if ($our_cleanmode eq 'dpkg-source') {
4649 maybe_apply_patches_dirtily();
4650 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4652 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4653 maybe_apply_patches_dirtily();
4654 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4657 my @cmd = (@dpkgsource, qw(-b --));
4660 runcmd_ordryrun_local @cmd, "work";
4661 my @udfiles = <${package}_*>;
4662 changedir "../../..";
4663 foreach my $f (@udfiles) {
4664 printdebug "source copy, found $f\n";
4667 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4668 $f eq srcfn($version, $&));
4669 printdebug "source copy, found $f - renaming\n";
4670 rename "$ud/$f", "../$f" or $!==ENOENT
4671 or fail "put in place new source file ($f): $!";
4674 my $pwd = must_getcwd();
4675 my $leafdir = basename $pwd;
4677 runcmd_ordryrun_local @cmd, $leafdir;
4680 runcmd_ordryrun_local qw(sh -ec),
4681 'exec >$1; shift; exec "$@"','x',
4682 "../$sourcechanges",
4683 @dpkggenchanges, qw(-S), changesopts();
4687 sub cmd_build_source {
4688 badusage "build-source takes no additional arguments" if @ARGV;
4690 maybe_unapply_patches_again();
4691 printdone "source built, results in $dscfn and $sourcechanges";
4696 my $pat = changespat $version;
4698 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4699 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4700 fail "changes files other than source matching $pat".
4701 " already present (@unwanted);".
4702 " building would result in ambiguity about the intended results"
4705 my $wasdir = must_getcwd();
4708 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4709 stat_exists $sourcechanges
4710 or fail "$sourcechanges (in parent directory): $!";
4712 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4713 my @changesfiles = glob $pat;
4714 @changesfiles = sort {
4715 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4718 fail "wrong number of different changes files (@changesfiles)"
4719 unless @changesfiles==2;
4720 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4721 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4722 fail "$l found in binaries changes file $binchanges"
4725 runcmd_ordryrun_local @mergechanges, @changesfiles;
4726 my $multichanges = changespat $version,'multi';
4728 stat_exists $multichanges or fail "$multichanges: $!";
4729 foreach my $cf (glob $pat) {
4730 next if $cf eq $multichanges;
4731 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4735 maybe_unapply_patches_again();
4736 printdone "build successful, results in $multichanges\n" or die $!;
4739 sub cmd_quilt_fixup {
4740 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4741 my $clogp = parsechangelog();
4742 $version = getfield $clogp, 'Version';
4743 $package = getfield $clogp, 'Source';
4746 build_maybe_quilt_fixup();
4749 sub cmd_archive_api_query {
4750 badusage "need only 1 subpath argument" unless @ARGV==1;
4751 my ($subpath) = @ARGV;
4752 my @cmd = archive_api_query_cmd($subpath);
4754 exec @cmd or fail "exec curl: $!\n";
4757 sub cmd_clone_dgit_repos_server {
4758 badusage "need destination argument" unless @ARGV==1;
4759 my ($destdir) = @ARGV;
4760 $package = '_dgit-repos-server';
4761 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4763 exec @cmd or fail "exec git clone: $!\n";
4766 sub cmd_setup_mergechangelogs {
4767 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4768 setup_mergechangelogs(1);
4771 sub cmd_setup_useremail {
4772 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4776 sub cmd_setup_new_tree {
4777 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4781 #---------- argument parsing and main program ----------
4784 print "dgit version $our_version\n" or die $!;
4788 our (%valopts_long, %valopts_short);
4791 sub defvalopt ($$$$) {
4792 my ($long,$short,$val_re,$how) = @_;
4793 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4794 $valopts_long{$long} = $oi;
4795 $valopts_short{$short} = $oi;
4796 # $how subref should:
4797 # do whatever assignemnt or thing it likes with $_[0]
4798 # if the option should not be passed on to remote, @rvalopts=()
4799 # or $how can be a scalar ref, meaning simply assign the value
4802 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4803 defvalopt '--distro', '-d', '.+', \$idistro;
4804 defvalopt '', '-k', '.+', \$keyid;
4805 defvalopt '--existing-package','', '.*', \$existing_package;
4806 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4807 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4808 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4810 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4812 defvalopt '', '-C', '.+', sub {
4813 ($changesfile) = (@_);
4814 if ($changesfile =~ s#^(.*)/##) {
4815 $buildproductsdir = $1;
4819 defvalopt '--initiator-tempdir','','.*', sub {
4820 ($initiator_tempdir) = (@_);
4821 $initiator_tempdir =~ m#^/# or
4822 badusage "--initiator-tempdir must be used specify an".
4823 " absolute, not relative, directory."
4829 if (defined $ENV{'DGIT_SSH'}) {
4830 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4831 } elsif (defined $ENV{'GIT_SSH'}) {
4832 @ssh = ($ENV{'GIT_SSH'});
4840 if (!defined $val) {
4841 badusage "$what needs a value" unless @ARGV;
4843 push @rvalopts, $val;
4845 badusage "bad value \`$val' for $what" unless
4846 $val =~ m/^$oi->{Re}$(?!\n)/s;
4847 my $how = $oi->{How};
4848 if (ref($how) eq 'SCALAR') {
4853 push @ropts, @rvalopts;
4857 last unless $ARGV[0] =~ m/^-/;
4861 if (m/^--dry-run$/) {
4864 } elsif (m/^--damp-run$/) {
4867 } elsif (m/^--no-sign$/) {
4870 } elsif (m/^--help$/) {
4872 } elsif (m/^--version$/) {
4874 } elsif (m/^--new$/) {
4877 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4878 ($om = $opts_opt_map{$1}) &&
4882 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4883 !$opts_opt_cmdonly{$1} &&
4884 ($om = $opts_opt_map{$1})) {
4887 } elsif (m/^--ignore-dirty$/s) {
4890 } elsif (m/^--no-quilt-fixup$/s) {
4892 $quilt_mode = 'nocheck';
4893 } elsif (m/^--no-rm-on-error$/s) {
4896 } elsif (m/^--overwrite$/s) {
4898 $overwrite_version = '';
4899 } elsif (m/^--overwrite=(.+)$/s) {
4901 $overwrite_version = $1;
4902 } elsif (m/^--(no-)?rm-old-changes$/s) {
4905 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4907 push @deliberatelies, $&;
4908 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4909 # undocumented, for testing
4911 $tagformat_want = [ $1, 'command line', 1 ];
4912 # 1 menas overrides distro configuration
4913 } elsif (m/^--always-split-source-build$/s) {
4914 # undocumented, for testing
4916 $need_split_build_invocation = 1;
4917 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4918 $val = $2 ? $' : undef; #';
4919 $valopt->($oi->{Long});
4921 badusage "unknown long option \`$_'";
4928 } elsif (s/^-L/-/) {
4931 } elsif (s/^-h/-/) {
4933 } elsif (s/^-D/-/) {
4937 } elsif (s/^-N/-/) {
4942 push @changesopts, $_;
4944 } elsif (s/^-wn$//s) {
4946 $cleanmode = 'none';
4947 } elsif (s/^-wg$//s) {
4950 } elsif (s/^-wgf$//s) {
4952 $cleanmode = 'git-ff';
4953 } elsif (s/^-wd$//s) {
4955 $cleanmode = 'dpkg-source';
4956 } elsif (s/^-wdd$//s) {
4958 $cleanmode = 'dpkg-source-d';
4959 } elsif (s/^-wc$//s) {
4961 $cleanmode = 'check';
4962 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4964 $val = undef unless length $val;
4965 $valopt->($oi->{Short});
4968 badusage "unknown short option \`$_'";
4975 sub finalise_opts_opts () {
4976 foreach my $k (keys %opts_opt_map) {
4977 my $om = $opts_opt_map{$k};
4979 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4981 badcfg "cannot set command for $k"
4982 unless length $om->[0];
4986 foreach my $c (access_cfg_cfgs("opts-$k")) {
4987 my $vl = $gitcfg{$c};
4988 printdebug "CL $c ",
4989 ($vl ? join " ", map { shellquote } @$vl : ""),
4990 "\n" if $debuglevel >= 4;
4992 badcfg "cannot configure options for $k"
4993 if $opts_opt_cmdonly{$k};
4994 my $insertpos = $opts_cfg_insertpos{$k};
4995 @$om = ( @$om[0..$insertpos-1],
4997 @$om[$insertpos..$#$om] );
5002 if ($ENV{$fakeeditorenv}) {
5004 quilt_fixup_editor();
5010 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5011 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5012 if $dryrun_level == 1;
5014 print STDERR $helpmsg or die $!;
5017 my $cmd = shift @ARGV;
5020 if (!defined $rmchanges) {
5021 local $access_forpush;
5022 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5025 if (!defined $quilt_mode) {
5026 local $access_forpush;
5027 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5028 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5030 $quilt_mode =~ m/^($quilt_modes_re)$/
5031 or badcfg "unknown quilt-mode \`$quilt_mode'";
5035 $need_split_build_invocation ||= quiltmode_splitbrain();
5037 if (!defined $cleanmode) {
5038 local $access_forpush;
5039 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5040 $cleanmode //= 'dpkg-source';
5042 badcfg "unknown clean-mode \`$cleanmode'" unless
5043 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5046 my $fn = ${*::}{"cmd_$cmd"};
5047 $fn or badusage "unknown operation $cmd";