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_build) = ('');
101 our (@gbp_pq) = ('gbp pq');
102 our (@changesopts) = ('');
104 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
107 'debsign' => \@debsign,
109 'sbuild' => \@sbuild,
113 'dpkg-source' => \@dpkgsource,
114 'dpkg-buildpackage' => \@dpkgbuildpackage,
115 'dpkg-genchanges' => \@dpkggenchanges,
116 'gbp-build' => \@gbp_build,
117 'gbp-pq' => \@gbp_pq,
118 'ch' => \@changesopts,
119 'mergechanges' => \@mergechanges);
121 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
122 our %opts_cfg_insertpos = map {
124 scalar @{ $opts_opt_map{$_} }
125 } keys %opts_opt_map;
127 sub finalise_opts_opts();
133 our $supplementary_message = '';
134 our $need_split_build_invocation = 0;
135 our $split_brain = 0;
139 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
142 our $remotename = 'dgit';
143 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
148 my ($v,$distro) = @_;
149 return $tagformatfn->($v, $distro);
152 sub debiantag_maintview ($$) {
153 my ($v,$distro) = @_;
158 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
160 sub lbranch () { return "$branchprefix/$csuite"; }
161 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
162 sub lref () { return "refs/heads/".lbranch(); }
163 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
164 sub rrref () { return server_ref($csuite); }
166 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
167 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
169 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
170 # locally fetched refs because they have unhelpful names and clutter
171 # up gitk etc. So we track whether we have "used up" head ref (ie,
172 # whether we have made another local ref which refers to this object).
174 # (If we deleted them unconditionally, then we might end up
175 # re-fetching the same git objects each time dgit fetch was run.)
177 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
178 # in git_fetch_us to fetch the refs in question, and possibly a call
179 # to lrfetchref_used.
181 our (%lrfetchrefs_f, %lrfetchrefs_d);
182 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
184 sub lrfetchref_used ($) {
185 my ($fullrefname) = @_;
186 my $objid = $lrfetchrefs_f{$fullrefname};
187 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
198 return "${package}_".(stripepoch $vsn).$sfx
203 return srcfn($vsn,".dsc");
206 sub changespat ($;$) {
207 my ($vsn, $arch) = @_;
208 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
217 foreach my $f (@end) {
219 print STDERR "$us: cleanup: $@" if length $@;
223 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
225 sub no_such_package () {
226 print STDERR "$us: package $package does not exist in suite $isuite\n";
232 printdebug "CD $newdir\n";
233 chdir $newdir or confess "chdir: $newdir: $!";
236 sub deliberately ($) {
238 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
241 sub deliberately_not_fast_forward () {
242 foreach (qw(not-fast-forward fresh-repo)) {
243 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
247 sub quiltmode_splitbrain () {
248 $quilt_mode =~ m/gbp|dpm|unapplied/;
251 sub opts_opt_multi_cmd {
253 push @cmd, split /\s+/, shift @_;
259 return opts_opt_multi_cmd @gbp_pq;
262 #---------- remote protocol support, common ----------
264 # remote push initiator/responder protocol:
265 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
266 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
267 # < dgit-remote-push-ready <actual-proto-vsn>
274 # > supplementary-message NBYTES # $protovsn >= 3
279 # > file parsed-changelog
280 # [indicates that output of dpkg-parsechangelog follows]
281 # > data-block NBYTES
282 # > [NBYTES bytes of data (no newline)]
283 # [maybe some more blocks]
292 # > param head DGIT-VIEW-HEAD
293 # > param csuite SUITE
294 # > param tagformat old|new
295 # > param maint-view MAINT-VIEW-HEAD
297 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
298 # # goes into tag, for replay prevention
301 # [indicates that signed tag is wanted]
302 # < data-block NBYTES
303 # < [NBYTES bytes of data (no newline)]
304 # [maybe some more blocks]
308 # > want signed-dsc-changes
309 # < data-block NBYTES [transfer of signed dsc]
311 # < data-block NBYTES [transfer of signed changes]
319 sub i_child_report () {
320 # Sees if our child has died, and reap it if so. Returns a string
321 # describing how it died if it failed, or undef otherwise.
322 return undef unless $i_child_pid;
323 my $got = waitpid $i_child_pid, WNOHANG;
324 return undef if $got <= 0;
325 die unless $got == $i_child_pid;
326 $i_child_pid = undef;
327 return undef unless $?;
328 return "build host child ".waitstatusmsg();
333 fail "connection lost: $!" if $fh->error;
334 fail "protocol violation; $m not expected";
337 sub badproto_badread ($$) {
339 fail "connection lost: $!" if $!;
340 my $report = i_child_report();
341 fail $report if defined $report;
342 badproto $fh, "eof (reading $wh)";
345 sub protocol_expect (&$) {
346 my ($match, $fh) = @_;
349 defined && chomp or badproto_badread $fh, "protocol message";
357 badproto $fh, "\`$_'";
360 sub protocol_send_file ($$) {
361 my ($fh, $ourfn) = @_;
362 open PF, "<", $ourfn or die "$ourfn: $!";
365 my $got = read PF, $d, 65536;
366 die "$ourfn: $!" unless defined $got;
368 print $fh "data-block ".length($d)."\n" or die $!;
369 print $fh $d or die $!;
371 PF->error and die "$ourfn $!";
372 print $fh "data-end\n" or die $!;
376 sub protocol_read_bytes ($$) {
377 my ($fh, $nbytes) = @_;
378 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
380 my $got = read $fh, $d, $nbytes;
381 $got==$nbytes or badproto_badread $fh, "data block";
385 sub protocol_receive_file ($$) {
386 my ($fh, $ourfn) = @_;
387 printdebug "() $ourfn\n";
388 open PF, ">", $ourfn or die "$ourfn: $!";
390 my ($y,$l) = protocol_expect {
391 m/^data-block (.*)$/ ? (1,$1) :
392 m/^data-end$/ ? (0,) :
396 my $d = protocol_read_bytes $fh, $l;
397 print PF $d or die $!;
402 #---------- remote protocol support, responder ----------
404 sub responder_send_command ($) {
406 return unless $we_are_responder;
407 # called even without $we_are_responder
408 printdebug ">> $command\n";
409 print PO $command, "\n" or die $!;
412 sub responder_send_file ($$) {
413 my ($keyword, $ourfn) = @_;
414 return unless $we_are_responder;
415 printdebug "]] $keyword $ourfn\n";
416 responder_send_command "file $keyword";
417 protocol_send_file \*PO, $ourfn;
420 sub responder_receive_files ($@) {
421 my ($keyword, @ourfns) = @_;
422 die unless $we_are_responder;
423 printdebug "[[ $keyword @ourfns\n";
424 responder_send_command "want $keyword";
425 foreach my $fn (@ourfns) {
426 protocol_receive_file \*PI, $fn;
429 protocol_expect { m/^files-end$/ } \*PI;
432 #---------- remote protocol support, initiator ----------
434 sub initiator_expect (&) {
436 protocol_expect { &$match } \*RO;
439 #---------- end remote code ----------
442 if ($we_are_responder) {
444 responder_send_command "progress ".length($m) or die $!;
445 print PO $m or die $!;
455 $ua = LWP::UserAgent->new();
459 progress "downloading $what...";
460 my $r = $ua->get(@_) or die $!;
461 return undef if $r->code == 404;
462 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
463 return $r->decoded_content(charset => 'none');
466 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
471 failedcmd @_ if system @_;
474 sub act_local () { return $dryrun_level <= 1; }
475 sub act_scary () { return !$dryrun_level; }
478 if (!$dryrun_level) {
479 progress "dgit ok: @_";
481 progress "would be ok: @_ (but dry run only)";
486 printcmd(\*STDERR,$debugprefix."#",@_);
489 sub runcmd_ordryrun {
497 sub runcmd_ordryrun_local {
506 my ($first_shell, @cmd) = @_;
507 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
510 our $helpmsg = <<END;
512 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
513 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
514 dgit [dgit-opts] build [dpkg-buildpackage-opts]
515 dgit [dgit-opts] sbuild [sbuild-opts]
516 dgit [dgit-opts] push [dgit-opts] [suite]
517 dgit [dgit-opts] rpush build-host:build-dir ...
518 important dgit options:
519 -k<keyid> sign tag and package with <keyid> instead of default
520 --dry-run -n do not change anything, but go through the motions
521 --damp-run -L like --dry-run but make local changes, without signing
522 --new -N allow introducing a new package
523 --debug -D increase debug level
524 -c<name>=<value> set git config option (used directly by dgit too)
527 our $later_warning_msg = <<END;
528 Perhaps the upload is stuck in incoming. Using the version from git.
532 print STDERR "$us: @_\n", $helpmsg or die $!;
537 @ARGV or badusage "too few arguments";
538 return scalar shift @ARGV;
542 print $helpmsg or die $!;
546 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
548 our %defcfg = ('dgit.default.distro' => 'debian',
549 'dgit.default.username' => '',
550 'dgit.default.archive-query-default-component' => 'main',
551 'dgit.default.ssh' => 'ssh',
552 'dgit.default.archive-query' => 'madison:',
553 'dgit.default.sshpsql-dbname' => 'service=projectb',
554 'dgit.default.dgit-tag-format' => 'old,new,maint',
555 # old means "repo server accepts pushes with old dgit tags"
556 # new means "repo server accepts pushes with new dgit tags"
557 # maint means "repo server accepts split brain pushes"
558 # hist means "repo server may have old pushes without new tag"
559 # ("hist" is implied by "old")
560 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
561 'dgit-distro.debian.git-check' => 'url',
562 'dgit-distro.debian.git-check-suffix' => '/info/refs',
563 'dgit-distro.debian.new-private-pushers' => 't',
564 'dgit-distro.debian.dgit-tag-format' => 'new',
565 'dgit-distro.debian/push.git-url' => '',
566 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
567 'dgit-distro.debian/push.git-user-force' => 'dgit',
568 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
569 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
570 'dgit-distro.debian/push.git-create' => 'true',
571 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
572 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
573 # 'dgit-distro.debian.archive-query-tls-key',
574 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
575 # ^ this does not work because curl is broken nowadays
576 # Fixing #790093 properly will involve providing providing the key
577 # in some pacagke and maybe updating these paths.
579 # 'dgit-distro.debian.archive-query-tls-curl-args',
580 # '--ca-path=/etc/ssl/ca-debian',
581 # ^ this is a workaround but works (only) on DSA-administered machines
582 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
583 'dgit-distro.debian.git-url-suffix' => '',
584 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
585 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
586 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
587 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
588 'dgit-distro.ubuntu.git-check' => 'false',
589 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
590 'dgit-distro.test-dummy.ssh' => "$td/ssh",
591 'dgit-distro.test-dummy.username' => "alice",
592 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
593 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
594 'dgit-distro.test-dummy.git-url' => "$td/git",
595 'dgit-distro.test-dummy.git-host' => "git",
596 'dgit-distro.test-dummy.git-path' => "$td/git",
597 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
598 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
599 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
600 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
604 our @gitcfgsources = qw(cmdline local global system);
606 sub git_slurp_config () {
607 local ($debuglevel) = $debuglevel-2;
610 # This algoritm is a bit subtle, but this is needed so that for
611 # options which we want to be single-valued, we allow the
612 # different config sources to override properly. See #835858.
613 foreach my $src (@gitcfgsources) {
614 next if $src eq 'cmdline';
615 # we do this ourselves since git doesn't handle it
617 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
620 open GITS, "-|", @cmd or die $!;
623 printdebug "=> ", (messagequote $_), "\n";
625 push @{ $gitcfgs{$src}{$`} }, $'; #';
629 or ($!==0 && $?==256)
634 sub git_get_config ($) {
636 foreach my $src (@gitcfgsources) {
637 my $l = $gitcfgs{$src}{$c};
638 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
641 @$l==1 or badcfg "multiple values for $c".
642 " (in $src git config)" if @$l > 1;
650 return undef if $c =~ /RETURN-UNDEF/;
651 my $v = git_get_config($c);
652 return $v if defined $v;
653 my $dv = $defcfg{$c};
654 return $dv if defined $dv;
656 badcfg "need value for one of: @_\n".
657 "$us: distro or suite appears not to be (properly) supported";
660 sub access_basedistro () {
661 if (defined $idistro) {
664 return cfg("dgit-suite.$isuite.distro",
665 "dgit.default.distro");
669 sub access_quirk () {
670 # returns (quirk name, distro to use instead or undef, quirk-specific info)
671 my $basedistro = access_basedistro();
672 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
674 if (defined $backports_quirk) {
675 my $re = $backports_quirk;
676 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
678 $re =~ s/\%/([-0-9a-z_]+)/
679 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
680 if ($isuite =~ m/^$re$/) {
681 return ('backports',"$basedistro-backports",$1);
684 return ('none',undef);
689 sub parse_cfg_bool ($$$) {
690 my ($what,$def,$v) = @_;
693 $v =~ m/^[ty1]/ ? 1 :
694 $v =~ m/^[fn0]/ ? 0 :
695 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
698 sub access_forpush_config () {
699 my $d = access_basedistro();
703 parse_cfg_bool('new-private-pushers', 0,
704 cfg("dgit-distro.$d.new-private-pushers",
707 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
710 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
711 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
712 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
713 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
716 sub access_forpush () {
717 $access_forpush //= access_forpush_config();
718 return $access_forpush;
722 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
723 badcfg "pushing but distro is configured readonly"
724 if access_forpush_config() eq '0';
726 $supplementary_message = <<'END' unless $we_are_responder;
727 Push failed, before we got started.
728 You can retry the push, after fixing the problem, if you like.
730 finalise_opts_opts();
734 finalise_opts_opts();
737 sub supplementary_message ($) {
739 if (!$we_are_responder) {
740 $supplementary_message = $msg;
742 } elsif ($protovsn >= 3) {
743 responder_send_command "supplementary-message ".length($msg)
745 print PO $msg or die $!;
749 sub access_distros () {
750 # Returns list of distros to try, in order
753 # 0. `instead of' distro name(s) we have been pointed to
754 # 1. the access_quirk distro, if any
755 # 2a. the user's specified distro, or failing that } basedistro
756 # 2b. the distro calculated from the suite }
757 my @l = access_basedistro();
759 my (undef,$quirkdistro) = access_quirk();
760 unshift @l, $quirkdistro;
761 unshift @l, $instead_distro;
762 @l = grep { defined } @l;
764 if (access_forpush()) {
765 @l = map { ("$_/push", $_) } @l;
770 sub access_cfg_cfgs (@) {
773 # The nesting of these loops determines the search order. We put
774 # the key loop on the outside so that we search all the distros
775 # for each key, before going on to the next key. That means that
776 # if access_cfg is called with a more specific, and then a less
777 # specific, key, an earlier distro can override the less specific
778 # without necessarily overriding any more specific keys. (If the
779 # distro wants to override the more specific keys it can simply do
780 # so; whereas if we did the loop the other way around, it would be
781 # impossible to for an earlier distro to override a less specific
782 # key but not the more specific ones without restating the unknown
783 # values of the more specific keys.
786 # We have to deal with RETURN-UNDEF specially, so that we don't
787 # terminate the search prematurely.
789 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
792 foreach my $d (access_distros()) {
793 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
795 push @cfgs, map { "dgit.default.$_" } @realkeys;
802 my (@cfgs) = access_cfg_cfgs(@keys);
803 my $value = cfg(@cfgs);
807 sub access_cfg_bool ($$) {
808 my ($def, @keys) = @_;
809 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
812 sub string_to_ssh ($) {
814 if ($spec =~ m/\s/) {
815 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
821 sub access_cfg_ssh () {
822 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
823 if (!defined $gitssh) {
826 return string_to_ssh $gitssh;
830 sub access_runeinfo ($) {
832 return ": dgit ".access_basedistro()." $info ;";
835 sub access_someuserhost ($) {
837 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
838 defined($user) && length($user) or
839 $user = access_cfg("$some-user",'username');
840 my $host = access_cfg("$some-host");
841 return length($user) ? "$user\@$host" : $host;
844 sub access_gituserhost () {
845 return access_someuserhost('git');
848 sub access_giturl (;$) {
850 my $url = access_cfg('git-url','RETURN-UNDEF');
853 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
854 return undef unless defined $proto;
857 access_gituserhost().
858 access_cfg('git-path');
860 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
863 return "$url/$package$suffix";
866 sub parsecontrolfh ($$;$) {
867 my ($fh, $desc, $allowsigned) = @_;
868 our $dpkgcontrolhash_noissigned;
871 my %opts = ('name' => $desc);
872 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
873 $c = Dpkg::Control::Hash->new(%opts);
874 $c->parse($fh,$desc) or die "parsing of $desc failed";
875 last if $allowsigned;
876 last if $dpkgcontrolhash_noissigned;
877 my $issigned= $c->get_option('is_pgp_signed');
878 if (!defined $issigned) {
879 $dpkgcontrolhash_noissigned= 1;
880 seek $fh, 0,0 or die "seek $desc: $!";
881 } elsif ($issigned) {
882 fail "control file $desc is (already) PGP-signed. ".
883 " Note that dgit push needs to modify the .dsc and then".
884 " do the signature itself";
893 my ($file, $desc) = @_;
894 my $fh = new IO::Handle;
895 open $fh, '<', $file or die "$file: $!";
896 my $c = parsecontrolfh($fh,$desc);
897 $fh->error and die $!;
903 my ($dctrl,$field) = @_;
904 my $v = $dctrl->{$field};
905 return $v if defined $v;
906 fail "missing field $field in ".$dctrl->get_option('name');
910 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
911 my $p = new IO::Handle;
912 my @cmd = (qw(dpkg-parsechangelog), @_);
913 open $p, '-|', @cmd or die $!;
915 $?=0; $!=0; close $p or failedcmd @cmd;
919 sub commit_getclogp ($) {
920 # Returns the parsed changelog hashref for a particular commit
922 our %commit_getclogp_memo;
923 my $memo = $commit_getclogp_memo{$objid};
924 return $memo if $memo;
926 my $mclog = ".git/dgit/clog-$objid";
927 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
928 "$objid:debian/changelog";
929 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
934 defined $d or fail "getcwd failed: $!";
940 sub archive_query ($) {
942 my $query = access_cfg('archive-query','RETURN-UNDEF');
943 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
946 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
949 sub pool_dsc_subpath ($$) {
950 my ($vsn,$component) = @_; # $package is implict arg
951 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
952 return "/pool/$component/$prefix/$package/".dscfn($vsn);
955 #---------- `ftpmasterapi' archive query method (nascent) ----------
957 sub archive_api_query_cmd ($) {
959 my @cmd = qw(curl -sS);
960 my $url = access_cfg('archive-query-url');
961 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
963 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
964 foreach my $key (split /\:/, $keys) {
965 $key =~ s/\%HOST\%/$host/g;
967 fail "for $url: stat $key: $!" unless $!==ENOENT;
970 fail "config requested specific TLS key but do not know".
971 " how to get curl to use exactly that EE key ($key)";
972 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
973 # # Sadly the above line does not work because of changes
974 # # to gnutls. The real fix for #790093 may involve
975 # # new curl options.
978 # Fixing #790093 properly will involve providing a value
979 # for this on clients.
980 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
981 push @cmd, split / /, $kargs if defined $kargs;
983 push @cmd, $url.$subpath;
989 my ($data, $subpath) = @_;
990 badcfg "ftpmasterapi archive query method takes no data part"
992 my @cmd = archive_api_query_cmd($subpath);
993 my $json = cmdoutput @cmd;
994 return decode_json($json);
997 sub canonicalise_suite_ftpmasterapi () {
998 my ($proto,$data) = @_;
999 my $suites = api_query($data, 'suites');
1001 foreach my $entry (@$suites) {
1003 my $v = $entry->{$_};
1004 defined $v && $v eq $isuite;
1005 } qw(codename name);
1006 push @matched, $entry;
1008 fail "unknown suite $isuite" unless @matched;
1011 @matched==1 or die "multiple matches for suite $isuite\n";
1012 $cn = "$matched[0]{codename}";
1013 defined $cn or die "suite $isuite info has no codename\n";
1014 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1016 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1021 sub archive_query_ftpmasterapi () {
1022 my ($proto,$data) = @_;
1023 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1025 my $digester = Digest::SHA->new(256);
1026 foreach my $entry (@$info) {
1028 my $vsn = "$entry->{version}";
1029 my ($ok,$msg) = version_check $vsn;
1030 die "bad version: $msg\n" unless $ok;
1031 my $component = "$entry->{component}";
1032 $component =~ m/^$component_re$/ or die "bad component";
1033 my $filename = "$entry->{filename}";
1034 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1035 or die "bad filename";
1036 my $sha256sum = "$entry->{sha256sum}";
1037 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1038 push @rows, [ $vsn, "/pool/$component/$filename",
1039 $digester, $sha256sum ];
1041 die "bad ftpmaster api response: $@\n".Dumper($entry)
1044 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1048 #---------- `madison' archive query method ----------
1050 sub archive_query_madison {
1051 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1054 sub madison_get_parse {
1055 my ($proto,$data) = @_;
1056 die unless $proto eq 'madison';
1057 if (!length $data) {
1058 $data= access_cfg('madison-distro','RETURN-UNDEF');
1059 $data //= access_basedistro();
1061 $rmad{$proto,$data,$package} ||= cmdoutput
1062 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1063 my $rmad = $rmad{$proto,$data,$package};
1066 foreach my $l (split /\n/, $rmad) {
1067 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1068 \s*( [^ \t|]+ )\s* \|
1069 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1070 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1071 $1 eq $package or die "$rmad $package ?";
1078 $component = access_cfg('archive-query-default-component');
1080 $5 eq 'source' or die "$rmad ?";
1081 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1083 return sort { -version_compare($a->[0],$b->[0]); } @out;
1086 sub canonicalise_suite_madison {
1087 # madison canonicalises for us
1088 my @r = madison_get_parse(@_);
1090 "unable to canonicalise suite using package $package".
1091 " which does not appear to exist in suite $isuite;".
1092 " --existing-package may help";
1096 #---------- `sshpsql' archive query method ----------
1099 my ($data,$runeinfo,$sql) = @_;
1100 if (!length $data) {
1101 $data= access_someuserhost('sshpsql').':'.
1102 access_cfg('sshpsql-dbname');
1104 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1105 my ($userhost,$dbname) = ($`,$'); #';
1107 my @cmd = (access_cfg_ssh, $userhost,
1108 access_runeinfo("ssh-psql $runeinfo").
1109 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1110 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1112 open P, "-|", @cmd or die $!;
1115 printdebug(">|$_|\n");
1118 $!=0; $?=0; close P or failedcmd @cmd;
1120 my $nrows = pop @rows;
1121 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1122 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1123 @rows = map { [ split /\|/, $_ ] } @rows;
1124 my $ncols = scalar @{ shift @rows };
1125 die if grep { scalar @$_ != $ncols } @rows;
1129 sub sql_injection_check {
1130 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1133 sub archive_query_sshpsql ($$) {
1134 my ($proto,$data) = @_;
1135 sql_injection_check $isuite, $package;
1136 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1137 SELECT source.version, component.name, files.filename, files.sha256sum
1139 JOIN src_associations ON source.id = src_associations.source
1140 JOIN suite ON suite.id = src_associations.suite
1141 JOIN dsc_files ON dsc_files.source = source.id
1142 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1143 JOIN component ON component.id = files_archive_map.component_id
1144 JOIN files ON files.id = dsc_files.file
1145 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1146 AND source.source='$package'
1147 AND files.filename LIKE '%.dsc';
1149 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1150 my $digester = Digest::SHA->new(256);
1152 my ($vsn,$component,$filename,$sha256sum) = @$_;
1153 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1158 sub canonicalise_suite_sshpsql ($$) {
1159 my ($proto,$data) = @_;
1160 sql_injection_check $isuite;
1161 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1162 SELECT suite.codename
1163 FROM suite where suite_name='$isuite' or codename='$isuite';
1165 @rows = map { $_->[0] } @rows;
1166 fail "unknown suite $isuite" unless @rows;
1167 die "ambiguous $isuite: @rows ?" if @rows>1;
1171 #---------- `dummycat' archive query method ----------
1173 sub canonicalise_suite_dummycat ($$) {
1174 my ($proto,$data) = @_;
1175 my $dpath = "$data/suite.$isuite";
1176 if (!open C, "<", $dpath) {
1177 $!==ENOENT or die "$dpath: $!";
1178 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1182 chomp or die "$dpath: $!";
1184 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1188 sub archive_query_dummycat ($$) {
1189 my ($proto,$data) = @_;
1190 canonicalise_suite();
1191 my $dpath = "$data/package.$csuite.$package";
1192 if (!open C, "<", $dpath) {
1193 $!==ENOENT or die "$dpath: $!";
1194 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1202 printdebug "dummycat query $csuite $package $dpath | $_\n";
1203 my @row = split /\s+/, $_;
1204 @row==2 or die "$dpath: $_ ?";
1207 C->error and die "$dpath: $!";
1209 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1212 #---------- tag format handling ----------
1214 sub access_cfg_tagformats () {
1215 split /\,/, access_cfg('dgit-tag-format');
1218 sub need_tagformat ($$) {
1219 my ($fmt, $why) = @_;
1220 fail "need to use tag format $fmt ($why) but also need".
1221 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1222 " - no way to proceed"
1223 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1224 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1227 sub select_tagformat () {
1229 return if $tagformatfn && !$tagformat_want;
1230 die 'bug' if $tagformatfn && $tagformat_want;
1231 # ... $tagformat_want assigned after previous select_tagformat
1233 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1234 printdebug "select_tagformat supported @supported\n";
1236 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1237 printdebug "select_tagformat specified @$tagformat_want\n";
1239 my ($fmt,$why,$override) = @$tagformat_want;
1241 fail "target distro supports tag formats @supported".
1242 " but have to use $fmt ($why)"
1244 or grep { $_ eq $fmt } @supported;
1246 $tagformat_want = undef;
1248 $tagformatfn = ${*::}{"debiantag_$fmt"};
1250 fail "trying to use unknown tag format \`$fmt' ($why) !"
1251 unless $tagformatfn;
1254 #---------- archive query entrypoints and rest of program ----------
1256 sub canonicalise_suite () {
1257 return if defined $csuite;
1258 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1259 $csuite = archive_query('canonicalise_suite');
1260 if ($isuite ne $csuite) {
1261 progress "canonical suite name for $isuite is $csuite";
1265 sub get_archive_dsc () {
1266 canonicalise_suite();
1267 my @vsns = archive_query('archive_query');
1268 foreach my $vinfo (@vsns) {
1269 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1270 $dscurl = access_cfg('mirror').$subpath;
1271 $dscdata = url_get($dscurl);
1273 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1278 $digester->add($dscdata);
1279 my $got = $digester->hexdigest();
1281 fail "$dscurl has hash $got but".
1282 " archive told us to expect $digest";
1284 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1285 printdebug Dumper($dscdata) if $debuglevel>1;
1286 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1287 printdebug Dumper($dsc) if $debuglevel>1;
1288 my $fmt = getfield $dsc, 'Format';
1289 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1290 $dsc_checked = !!$digester;
1291 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1295 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1298 sub check_for_git ();
1299 sub check_for_git () {
1301 my $how = access_cfg('git-check');
1302 if ($how eq 'ssh-cmd') {
1304 (access_cfg_ssh, access_gituserhost(),
1305 access_runeinfo("git-check $package").
1306 " set -e; cd ".access_cfg('git-path').";".
1307 " if test -d $package.git; then echo 1; else echo 0; fi");
1308 my $r= cmdoutput @cmd;
1309 if (defined $r and $r =~ m/^divert (\w+)$/) {
1311 my ($usedistro,) = access_distros();
1312 # NB that if we are pushing, $usedistro will be $distro/push
1313 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1314 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1315 progress "diverting to $divert (using config for $instead_distro)";
1316 return check_for_git();
1318 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1320 } elsif ($how eq 'url') {
1321 my $prefix = access_cfg('git-check-url','git-url');
1322 my $suffix = access_cfg('git-check-suffix','git-suffix',
1323 'RETURN-UNDEF') // '.git';
1324 my $url = "$prefix/$package$suffix";
1325 my @cmd = (qw(curl -sS -I), $url);
1326 my $result = cmdoutput @cmd;
1327 $result =~ s/^\S+ 200 .*\n\r?\n//;
1328 # curl -sS -I with https_proxy prints
1329 # HTTP/1.0 200 Connection established
1330 $result =~ m/^\S+ (404|200) /s or
1331 fail "unexpected results from git check query - ".
1332 Dumper($prefix, $result);
1334 if ($code eq '404') {
1336 } elsif ($code eq '200') {
1341 } elsif ($how eq 'true') {
1343 } elsif ($how eq 'false') {
1346 badcfg "unknown git-check \`$how'";
1350 sub create_remote_git_repo () {
1351 my $how = access_cfg('git-create');
1352 if ($how eq 'ssh-cmd') {
1354 (access_cfg_ssh, access_gituserhost(),
1355 access_runeinfo("git-create $package").
1356 "set -e; cd ".access_cfg('git-path').";".
1357 " cp -a _template $package.git");
1358 } elsif ($how eq 'true') {
1361 badcfg "unknown git-create \`$how'";
1365 our ($dsc_hash,$lastpush_mergeinput);
1367 our $ud = '.git/dgit/unpack';
1377 sub mktree_in_ud_here () {
1378 runcmd qw(git init -q);
1379 runcmd qw(git config gc.auto 0);
1380 rmtree('.git/objects');
1381 symlink '../../../../objects','.git/objects' or die $!;
1384 sub git_write_tree () {
1385 my $tree = cmdoutput @git, qw(write-tree);
1386 $tree =~ m/^\w+$/ or die "$tree ?";
1390 sub remove_stray_gits () {
1391 my @gitscmd = qw(find -name .git -prune -print0);
1392 debugcmd "|",@gitscmd;
1393 open GITS, "-|", @gitscmd or die $!;
1398 print STDERR "$us: warning: removing from source package: ",
1399 (messagequote $_), "\n";
1403 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1406 sub mktree_in_ud_from_only_subdir (;$) {
1409 # changes into the subdir
1411 die "expected one subdir but found @dirs ?" unless @dirs==1;
1412 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1416 remove_stray_gits();
1417 mktree_in_ud_here();
1419 my ($format, $fopts) = get_source_format();
1420 if (madformat($format)) {
1425 runcmd @git, qw(add -Af);
1426 my $tree=git_write_tree();
1427 return ($tree,$dir);
1430 our @files_csum_info_fields =
1431 (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1432 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1433 ['Files', 'Digest::MD5', 'new()']);
1435 sub dsc_files_info () {
1436 foreach my $csumi (@files_csum_info_fields) {
1437 my ($fname, $module, $method) = @$csumi;
1438 my $field = $dsc->{$fname};
1439 next unless defined $field;
1440 eval "use $module; 1;" or die $@;
1442 foreach (split /\n/, $field) {
1444 m/^(\w+) (\d+) (\S+)$/ or
1445 fail "could not parse .dsc $fname line \`$_'";
1446 my $digester = eval "$module"."->$method;" or die $@;
1451 Digester => $digester,
1456 fail "missing any supported Checksums-* or Files field in ".
1457 $dsc->get_option('name');
1461 map { $_->{Filename} } dsc_files_info();
1464 sub files_compare_inputs (@) {
1469 my $showinputs = sub {
1470 return join "; ", map { $_->get_option('name') } @$inputs;
1473 foreach my $in (@$inputs) {
1475 my $in_name = $in->get_option('name');
1477 printdebug "files_compare_inputs $in_name\n";
1479 foreach my $csumi (@files_csum_info_fields) {
1480 my ($fname) = @$csumi;
1481 printdebug "files_compare_inputs $in_name $fname\n";
1483 my $field = $in->{$fname};
1484 next unless defined $field;
1487 foreach (split /\n/, $field) {
1490 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1491 fail "could not parse $in_name $fname line \`$_'";
1493 printdebug "files_compare_inputs $in_name $fname $f\n";
1497 my $re = \ $record{$f}{$fname};
1499 $fchecked{$f}{$in_name} = 1;
1501 fail "hash or size of $f varies in $fname fields".
1502 " (between: ".$showinputs->().")";
1507 @files = sort @files;
1508 $expected_files //= \@files;
1509 "@$expected_files" eq "@files" or
1510 fail "file list in $in_name varies between hash fields!";
1513 fail "$in_name has no files list field(s)";
1515 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1518 grep { keys %$_ == @$inputs-1 } values %fchecked
1519 or fail "no file appears in all file lists".
1520 " (looked in: ".$showinputs->().")";
1523 sub is_orig_file_in_dsc ($$) {
1524 my ($f, $dsc_files_info) = @_;
1525 return 0 if @$dsc_files_info <= 1;
1526 # One file means no origs, and the filename doesn't have a "what
1527 # part of dsc" component. (Consider versions ending `.orig'.)
1528 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1532 sub is_orig_file_of_vsn ($$) {
1533 my ($f, $upstreamvsn) = @_;
1534 my $base = srcfn $upstreamvsn, '';
1535 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1539 sub make_commit ($) {
1541 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1544 sub make_commit_text ($) {
1547 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1549 print Dumper($text) if $debuglevel > 1;
1550 my $child = open2($out, $in, @cmd) or die $!;
1553 print $in $text or die $!;
1554 close $in or die $!;
1556 $h =~ m/^\w+$/ or die;
1558 printdebug "=> $h\n";
1561 waitpid $child, 0 == $child or die "$child $!";
1562 $? and failedcmd @cmd;
1566 sub clogp_authline ($) {
1568 my $author = getfield $clogp, 'Maintainer';
1569 $author =~ s#,.*##ms;
1570 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1571 my $authline = "$author $date";
1572 $authline =~ m/$git_authline_re/o or
1573 fail "unexpected commit author line format \`$authline'".
1574 " (was generated from changelog Maintainer field)";
1575 return ($1,$2,$3) if wantarray;
1579 sub vendor_patches_distro ($$) {
1580 my ($checkdistro, $what) = @_;
1581 return unless defined $checkdistro;
1583 my $series = "debian/patches/\L$checkdistro\E.series";
1584 printdebug "checking for vendor-specific $series ($what)\n";
1586 if (!open SERIES, "<", $series) {
1587 die "$series $!" unless $!==ENOENT;
1596 Unfortunately, this source package uses a feature of dpkg-source where
1597 the same source package unpacks to different source code on different
1598 distros. dgit cannot safely operate on such packages on affected
1599 distros, because the meaning of source packages is not stable.
1601 Please ask the distro/maintainer to remove the distro-specific series
1602 files and use a different technique (if necessary, uploading actually
1603 different packages, if different distros are supposed to have
1607 fail "Found active distro-specific series file for".
1608 " $checkdistro ($what): $series, cannot continue";
1610 die "$series $!" if SERIES->error;
1614 sub check_for_vendor_patches () {
1615 # This dpkg-source feature doesn't seem to be documented anywhere!
1616 # But it can be found in the changelog (reformatted):
1618 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1619 # Author: Raphael Hertzog <hertzog@debian.org>
1620 # Date: Sun Oct 3 09:36:48 2010 +0200
1622 # dpkg-source: correctly create .pc/.quilt_series with alternate
1625 # If you have debian/patches/ubuntu.series and you were
1626 # unpacking the source package on ubuntu, quilt was still
1627 # directed to debian/patches/series instead of
1628 # debian/patches/ubuntu.series.
1630 # debian/changelog | 3 +++
1631 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1632 # 2 files changed, 6 insertions(+), 1 deletion(-)
1635 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1636 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1637 "Dpkg::Vendor \`current vendor'");
1638 vendor_patches_distro(access_basedistro(),
1639 "distro being accessed");
1642 sub generate_commits_from_dsc () {
1643 # See big comment in fetch_from_archive, below.
1644 # See also README.dsc-import.
1648 my @dfi = dsc_files_info();
1649 foreach my $fi (@dfi) {
1650 my $f = $fi->{Filename};
1651 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1653 link_ltarget "../../../$f", $f
1657 complete_file_from_dsc('.', $fi)
1660 if (is_orig_file_in_dsc($f, \@dfi)) {
1661 link $f, "../../../../$f"
1667 # We unpack and record the orig tarballs first, so that we only
1668 # need disk space for one private copy of the unpacked source.
1669 # But we can't make them into commits until we have the metadata
1670 # from the debian/changelog, so we record the tree objects now and
1671 # make them into commits later.
1673 my $upstreamv = $dsc->{version};
1674 $upstreamv =~ s/-[^-]+$//;
1675 my $orig_f_base = srcfn $upstreamv, '';
1677 foreach my $fi (@dfi) {
1678 # We actually import, and record as a commit, every tarball
1679 # (unless there is only one file, in which case there seems
1682 my $f = $fi->{Filename};
1683 printdebug "import considering $f ";
1684 (printdebug "only one dfi\n"), next if @dfi == 1;
1685 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1686 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1690 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1692 printdebug "Y ", (join ' ', map { $_//"(none)" }
1693 $compr_ext, $orig_f_part
1696 my $input = new IO::File $f, '<' or die "$f $!";
1700 if (defined $compr_ext) {
1702 Dpkg::Compression::compression_guess_from_filename $f;
1703 fail "Dpkg::Compression cannot handle file $f in source package"
1704 if defined $compr_ext && !defined $cname;
1706 new Dpkg::Compression::Process compression => $cname;
1707 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1708 my $compr_fh = new IO::Handle;
1709 my $compr_pid = open $compr_fh, "-|" // die $!;
1711 open STDIN, "<&", $input or die $!;
1713 die "dgit (child): exec $compr_cmd[0]: $!\n";
1718 rmtree "../unpack-tar";
1719 mkdir "../unpack-tar" or die $!;
1720 my @tarcmd = qw(tar -x -f -
1721 --no-same-owner --no-same-permissions
1722 --no-acls --no-xattrs --no-selinux);
1723 my $tar_pid = fork // die $!;
1725 chdir "../unpack-tar" or die $!;
1726 open STDIN, "<&", $input or die $!;
1728 die "dgit (child): exec $tarcmd[0]: $!";
1730 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1731 !$? or failedcmd @tarcmd;
1734 (@compr_cmd ? failedcmd @compr_cmd
1736 # finally, we have the results in "tarball", but maybe
1737 # with the wrong permissions
1739 runcmd qw(chmod -R +rwX ../unpack-tar);
1740 changedir "../unpack-tar";
1741 my ($tree) = mktree_in_ud_from_only_subdir(1);
1742 changedir "../../unpack";
1743 rmtree "../unpack-tar";
1745 my $ent = [ $f, $tree ];
1747 Orig => !!$orig_f_part,
1748 Sort => (!$orig_f_part ? 2 :
1749 $orig_f_part =~ m/-/g ? 1 :
1757 # put any without "_" first (spec is not clear whether files
1758 # are always in the usual order). Tarballs without "_" are
1759 # the main orig or the debian tarball.
1760 $a->{Sort} <=> $b->{Sort} or
1764 my $any_orig = grep { $_->{Orig} } @tartrees;
1766 my $dscfn = "$package.dsc";
1768 my $treeimporthow = 'package';
1770 open D, ">", $dscfn or die "$dscfn: $!";
1771 print D $dscdata or die "$dscfn: $!";
1772 close D or die "$dscfn: $!";
1773 my @cmd = qw(dpkg-source);
1774 push @cmd, '--no-check' if $dsc_checked;
1775 if (madformat $dsc->{format}) {
1776 push @cmd, '--skip-patches';
1777 $treeimporthow = 'unpatched';
1779 push @cmd, qw(-x --), $dscfn;
1782 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1783 if (madformat $dsc->{format}) {
1784 check_for_vendor_patches();
1788 if (madformat $dsc->{format}) {
1789 my @pcmd = qw(dpkg-source --before-build .);
1790 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1792 runcmd @git, qw(add -Af);
1793 $dappliedtree = git_write_tree();
1796 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1797 debugcmd "|",@clogcmd;
1798 open CLOGS, "-|", @clogcmd or die $!;
1803 printdebug "import clog search...\n";
1806 my $stanzatext = do { local $/=""; <CLOGS>; };
1807 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1808 last if !defined $stanzatext;
1810 my $desc = "package changelog, entry no.$.";
1811 open my $stanzafh, "<", \$stanzatext or die;
1812 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1813 $clogp //= $thisstanza;
1815 printdebug "import clog $thisstanza->{version} $desc...\n";
1817 last if !$any_orig; # we don't need $r1clogp
1819 # We look for the first (most recent) changelog entry whose
1820 # version number is lower than the upstream version of this
1821 # package. Then the last (least recent) previous changelog
1822 # entry is treated as the one which introduced this upstream
1823 # version and used for the synthetic commits for the upstream
1826 # One might think that a more sophisticated algorithm would be
1827 # necessary. But: we do not want to scan the whole changelog
1828 # file. Stopping when we see an earlier version, which
1829 # necessarily then is an earlier upstream version, is the only
1830 # realistic way to do that. Then, either the earliest
1831 # changelog entry we have seen so far is indeed the earliest
1832 # upload of this upstream version; or there are only changelog
1833 # entries relating to later upstream versions (which is not
1834 # possible unless the changelog and .dsc disagree about the
1835 # version). Then it remains to choose between the physically
1836 # last entry in the file, and the one with the lowest version
1837 # number. If these are not the same, we guess that the
1838 # versions were created in a non-monotic order rather than
1839 # that the changelog entries have been misordered.
1841 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1843 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1844 $r1clogp = $thisstanza;
1846 printdebug "import clog $r1clogp->{version} becomes r1\n";
1848 die $! if CLOGS->error;
1849 close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
1851 $clogp or fail "package changelog has no entries!";
1853 my $authline = clogp_authline $clogp;
1854 my $changes = getfield $clogp, 'Changes';
1855 my $cversion = getfield $clogp, 'Version';
1858 $r1clogp //= $clogp; # maybe there's only one entry;
1859 my $r1authline = clogp_authline $r1clogp;
1860 # Strictly, r1authline might now be wrong if it's going to be
1861 # unused because !$any_orig. Whatever.
1863 printdebug "import tartrees authline $authline\n";
1864 printdebug "import tartrees r1authline $r1authline\n";
1866 foreach my $tt (@tartrees) {
1867 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1869 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1872 committer $r1authline
1876 [dgit import orig $tt->{F}]
1884 [dgit import tarball $package $cversion $tt->{F}]
1889 printdebug "import main commit\n";
1891 open C, ">../commit.tmp" or die $!;
1892 print C <<END or die $!;
1895 print C <<END or die $! foreach @tartrees;
1898 print C <<END or die $!;
1904 [dgit import $treeimporthow $package $cversion]
1908 my $rawimport_hash = make_commit qw(../commit.tmp);
1910 if (madformat $dsc->{format}) {
1911 printdebug "import apply patches...\n";
1913 # regularise the state of the working tree so that
1914 # the checkout of $rawimport_hash works nicely.
1915 my $dappliedcommit = make_commit_text(<<END);
1922 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1924 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1926 # We need the answers to be reproducible
1927 my @authline = clogp_authline($clogp);
1928 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1929 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1930 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1931 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1932 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1933 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1936 runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
1940 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
1944 my $gapplied = git_rev_parse('HEAD');
1945 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1946 $gappliedtree eq $dappliedtree or
1948 gbp-pq import and dpkg-source disagree!
1949 gbp-pq import gave commit $gapplied
1950 gbp-pq import gave tree $gappliedtree
1951 dpkg-source --before-build gave tree $dappliedtree
1953 $rawimport_hash = $gapplied;
1956 progress "synthesised git commit from .dsc $cversion";
1958 my $rawimport_mergeinput = {
1959 Commit => $rawimport_hash,
1960 Info => "Import of source package",
1962 my @output = ($rawimport_mergeinput);
1964 if ($lastpush_mergeinput) {
1965 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1966 my $oversion = getfield $oldclogp, 'Version';
1968 version_compare($oversion, $cversion);
1970 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1971 { Message => <<END, ReverseParents => 1 });
1972 Record $package ($cversion) in archive suite $csuite
1974 } elsif ($vcmp > 0) {
1975 print STDERR <<END or die $!;
1977 Version actually in archive: $cversion (older)
1978 Last version pushed with dgit: $oversion (newer or same)
1981 @output = $lastpush_mergeinput;
1983 # Same version. Use what's in the server git branch,
1984 # discarding our own import. (This could happen if the
1985 # server automatically imports all packages into git.)
1986 @output = $lastpush_mergeinput;
1989 changedir '../../../..';
1994 sub complete_file_from_dsc ($$) {
1995 our ($dstdir, $fi) = @_;
1996 # Ensures that we have, in $dir, the file $fi, with the correct
1997 # contents. (Downloading it from alongside $dscurl if necessary.)
1999 my $f = $fi->{Filename};
2000 my $tf = "$dstdir/$f";
2003 if (stat_exists $tf) {
2004 progress "using existing $f";
2007 $furl =~ s{/[^/]+$}{};
2009 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2010 die "$f ?" if $f =~ m#/#;
2011 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
2012 return 0 if !act_local();
2016 open F, "<", "$tf" or die "$tf: $!";
2017 $fi->{Digester}->reset();
2018 $fi->{Digester}->addfile(*F);
2019 F->error and die $!;
2020 my $got = $fi->{Digester}->hexdigest();
2021 $got eq $fi->{Hash} or
2022 fail "file $f has hash $got but .dsc".
2023 " demands hash $fi->{Hash} ".
2024 ($downloaded ? "(got wrong file from archive!)"
2025 : "(perhaps you should delete this file?)");
2030 sub ensure_we_have_orig () {
2031 my @dfi = dsc_files_info();
2032 foreach my $fi (@dfi) {
2033 my $f = $fi->{Filename};
2034 next unless is_orig_file_in_dsc($f, \@dfi);
2035 complete_file_from_dsc('..', $fi)
2040 sub git_fetch_us () {
2041 # Want to fetch only what we are going to use, unless
2042 # deliberately-not-ff, in which case we must fetch everything.
2044 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2046 (quiltmode_splitbrain
2047 ? (map { $_->('*',access_basedistro) }
2048 \&debiantag_new, \&debiantag_maintview)
2049 : debiantags('*',access_basedistro));
2050 push @specs, server_branch($csuite);
2051 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2053 # This is rather miserable:
2054 # When git-fetch --prune is passed a fetchspec ending with a *,
2055 # it does a plausible thing. If there is no * then:
2056 # - it matches subpaths too, even if the supplied refspec
2057 # starts refs, and behaves completely madly if the source
2058 # has refs/refs/something. (See, for example, Debian #NNNN.)
2059 # - if there is no matching remote ref, it bombs out the whole
2061 # We want to fetch a fixed ref, and we don't know in advance
2062 # if it exists, so this is not suitable.
2064 # Our workaround is to use git-ls-remote. git-ls-remote has its
2065 # own qairks. Notably, it has the absurd multi-tail-matching
2066 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
2067 # refs/refs/foo etc.
2069 # Also, we want an idempotent snapshot, but we have to make two
2070 # calls to the remote: one to git-ls-remote and to git-fetch. The
2071 # solution is use git-ls-remote to obtain a target state, and
2072 # git-fetch to try to generate it. If we don't manage to generate
2073 # the target state, we try again.
2075 my $specre = join '|', map {
2081 printdebug "git_fetch_us specre=$specre\n";
2082 my $wanted_rref = sub {
2084 return m/^(?:$specre)$/o;
2087 my $fetch_iteration = 0;
2090 if (++$fetch_iteration > 10) {
2091 fail "too many iterations trying to get sane fetch!";
2094 my @look = map { "refs/$_" } @specs;
2095 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2099 open GITLS, "-|", @lcmd or die $!;
2101 printdebug "=> ", $_;
2102 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2103 my ($objid,$rrefname) = ($1,$2);
2104 if (!$wanted_rref->($rrefname)) {
2106 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
2110 $wantr{$rrefname} = $objid;
2113 close GITLS or failedcmd @lcmd;
2115 # OK, now %want is exactly what we want for refs in @specs
2117 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2118 "+refs/$_:".lrfetchrefs."/$_";
2121 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2122 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2125 %lrfetchrefs_f = ();
2128 git_for_each_ref(lrfetchrefs, sub {
2129 my ($objid,$objtype,$lrefname,$reftail) = @_;
2130 $lrfetchrefs_f{$lrefname} = $objid;
2131 $objgot{$objid} = 1;
2134 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2135 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2136 if (!exists $wantr{$rrefname}) {
2137 if ($wanted_rref->($rrefname)) {
2139 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
2143 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
2146 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2147 delete $lrfetchrefs_f{$lrefname};
2151 foreach my $rrefname (sort keys %wantr) {
2152 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2153 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2154 my $want = $wantr{$rrefname};
2155 next if $got eq $want;
2156 if (!defined $objgot{$want}) {
2158 warning: git-ls-remote suggests we want $lrefname
2159 warning: and it should refer to $want
2160 warning: but git-fetch didn't fetch that object to any relevant ref.
2161 warning: This may be due to a race with someone updating the server.
2162 warning: Will try again...
2164 next FETCH_ITERATION;
2167 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
2169 runcmd_ordryrun_local @git, qw(update-ref -m),
2170 "dgit fetch git-fetch fixup", $lrefname, $want;
2171 $lrfetchrefs_f{$lrefname} = $want;
2175 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
2176 Dumper(\%lrfetchrefs_f);
2179 my @tagpats = debiantags('*',access_basedistro);
2181 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2182 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2183 printdebug "currently $fullrefname=$objid\n";
2184 $here{$fullrefname} = $objid;
2186 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2187 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2188 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2189 printdebug "offered $lref=$objid\n";
2190 if (!defined $here{$lref}) {
2191 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2192 runcmd_ordryrun_local @upd;
2193 lrfetchref_used $fullrefname;
2194 } elsif ($here{$lref} eq $objid) {
2195 lrfetchref_used $fullrefname;
2198 "Not updateting $lref from $here{$lref} to $objid.\n";
2203 sub mergeinfo_getclogp ($) {
2204 # Ensures thit $mi->{Clogp} exists and returns it
2206 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2209 sub mergeinfo_version ($) {
2210 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2213 sub fetch_from_archive () {
2214 ensure_setup_existing_tree();
2216 # Ensures that lrref() is what is actually in the archive, one way
2217 # or another, according to us - ie this client's
2218 # appropritaely-updated archive view. Also returns the commit id.
2219 # If there is nothing in the archive, leaves lrref alone and
2220 # returns undef. git_fetch_us must have already been called.
2224 foreach my $field (@ourdscfield) {
2225 $dsc_hash = $dsc->{$field};
2226 last if defined $dsc_hash;
2228 if (defined $dsc_hash) {
2229 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2231 progress "last upload to archive specified git hash";
2233 progress "last upload to archive has NO git hash";
2236 progress "no version available from the archive";
2239 # If the archive's .dsc has a Dgit field, there are three
2240 # relevant git commitids we need to choose between and/or merge
2242 # 1. $dsc_hash: the Dgit field from the archive
2243 # 2. $lastpush_hash: the suite branch on the dgit git server
2244 # 3. $lastfetch_hash: our local tracking brach for the suite
2246 # These may all be distinct and need not be in any fast forward
2249 # If the dsc was pushed to this suite, then the server suite
2250 # branch will have been updated; but it might have been pushed to
2251 # a different suite and copied by the archive. Conversely a more
2252 # recent version may have been pushed with dgit but not appeared
2253 # in the archive (yet).
2255 # $lastfetch_hash may be awkward because archive imports
2256 # (particularly, imports of Dgit-less .dscs) are performed only as
2257 # needed on individual clients, so different clients may perform a
2258 # different subset of them - and these imports are only made
2259 # public during push. So $lastfetch_hash may represent a set of
2260 # imports different to a subsequent upload by a different dgit
2263 # Our approach is as follows:
2265 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2266 # descendant of $dsc_hash, then it was pushed by a dgit user who
2267 # had based their work on $dsc_hash, so we should prefer it.
2268 # Otherwise, $dsc_hash was installed into this suite in the
2269 # archive other than by a dgit push, and (necessarily) after the
2270 # last dgit push into that suite (since a dgit push would have
2271 # been descended from the dgit server git branch); thus, in that
2272 # case, we prefer the archive's version (and produce a
2273 # pseudo-merge to overwrite the dgit server git branch).
2275 # (If there is no Dgit field in the archive's .dsc then
2276 # generate_commit_from_dsc uses the version numbers to decide
2277 # whether the suite branch or the archive is newer. If the suite
2278 # branch is newer it ignores the archive's .dsc; otherwise it
2279 # generates an import of the .dsc, and produces a pseudo-merge to
2280 # overwrite the suite branch with the archive contents.)
2282 # The outcome of that part of the algorithm is the `public view',
2283 # and is same for all dgit clients: it does not depend on any
2284 # unpublished history in the local tracking branch.
2286 # As between the public view and the local tracking branch: The
2287 # local tracking branch is only updated by dgit fetch, and
2288 # whenever dgit fetch runs it includes the public view in the
2289 # local tracking branch. Therefore if the public view is not
2290 # descended from the local tracking branch, the local tracking
2291 # branch must contain history which was imported from the archive
2292 # but never pushed; and, its tip is now out of date. So, we make
2293 # a pseudo-merge to overwrite the old imports and stitch the old
2296 # Finally: we do not necessarily reify the public view (as
2297 # described above). This is so that we do not end up stacking two
2298 # pseudo-merges. So what we actually do is figure out the inputs
2299 # to any public view pseudo-merge and put them in @mergeinputs.
2302 # $mergeinputs[]{Commit}
2303 # $mergeinputs[]{Info}
2304 # $mergeinputs[0] is the one whose tree we use
2305 # @mergeinputs is in the order we use in the actual commit)
2308 # $mergeinputs[]{Message} is a commit message to use
2309 # $mergeinputs[]{ReverseParents} if def specifies that parent
2310 # list should be in opposite order
2311 # Such an entry has no Commit or Info. It applies only when found
2312 # in the last entry. (This ugliness is to support making
2313 # identical imports to previous dgit versions.)
2315 my $lastpush_hash = git_get_ref(lrfetchref());
2316 printdebug "previous reference hash=$lastpush_hash\n";
2317 $lastpush_mergeinput = $lastpush_hash && {
2318 Commit => $lastpush_hash,
2319 Info => "dgit suite branch on dgit git server",
2322 my $lastfetch_hash = git_get_ref(lrref());
2323 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2324 my $lastfetch_mergeinput = $lastfetch_hash && {
2325 Commit => $lastfetch_hash,
2326 Info => "dgit client's archive history view",
2329 my $dsc_mergeinput = $dsc_hash && {
2330 Commit => $dsc_hash,
2331 Info => "Dgit field in .dsc from archive",
2335 my $del_lrfetchrefs = sub {
2338 printdebug "del_lrfetchrefs...\n";
2339 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2340 my $objid = $lrfetchrefs_d{$fullrefname};
2341 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2343 $gur ||= new IO::Handle;
2344 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2346 printf $gur "delete %s %s\n", $fullrefname, $objid;
2349 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2353 if (defined $dsc_hash) {
2354 fail "missing remote git history even though dsc has hash -".
2355 " could not find ref ".rref()." at ".access_giturl()
2356 unless $lastpush_hash;
2357 ensure_we_have_orig();
2358 if ($dsc_hash eq $lastpush_hash) {
2359 @mergeinputs = $dsc_mergeinput
2360 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2361 print STDERR <<END or die $!;
2363 Git commit in archive is behind the last version allegedly pushed/uploaded.
2364 Commit referred to by archive: $dsc_hash
2365 Last version pushed with dgit: $lastpush_hash
2368 @mergeinputs = ($lastpush_mergeinput);
2370 # Archive has .dsc which is not a descendant of the last dgit
2371 # push. This can happen if the archive moves .dscs about.
2372 # Just follow its lead.
2373 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2374 progress "archive .dsc names newer git commit";
2375 @mergeinputs = ($dsc_mergeinput);
2377 progress "archive .dsc names other git commit, fixing up";
2378 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2382 @mergeinputs = generate_commits_from_dsc();
2383 # We have just done an import. Now, our import algorithm might
2384 # have been improved. But even so we do not want to generate
2385 # a new different import of the same package. So if the
2386 # version numbers are the same, just use our existing version.
2387 # If the version numbers are different, the archive has changed
2388 # (perhaps, rewound).
2389 if ($lastfetch_mergeinput &&
2390 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2391 (mergeinfo_version $mergeinputs[0]) )) {
2392 @mergeinputs = ($lastfetch_mergeinput);
2394 } elsif ($lastpush_hash) {
2395 # only in git, not in the archive yet
2396 @mergeinputs = ($lastpush_mergeinput);
2397 print STDERR <<END or die $!;
2399 Package not found in the archive, but has allegedly been pushed using dgit.
2403 printdebug "nothing found!\n";
2404 if (defined $skew_warning_vsn) {
2405 print STDERR <<END or die $!;
2407 Warning: relevant archive skew detected.
2408 Archive allegedly contains $skew_warning_vsn
2409 But we were not able to obtain any version from the archive or git.
2413 unshift @end, $del_lrfetchrefs;
2417 if ($lastfetch_hash &&
2419 my $h = $_->{Commit};
2420 $h and is_fast_fwd($lastfetch_hash, $h);
2421 # If true, one of the existing parents of this commit
2422 # is a descendant of the $lastfetch_hash, so we'll
2423 # be ff from that automatically.
2427 push @mergeinputs, $lastfetch_mergeinput;
2430 printdebug "fetch mergeinfos:\n";
2431 foreach my $mi (@mergeinputs) {
2433 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2435 printdebug sprintf " ReverseParents=%d Message=%s",
2436 $mi->{ReverseParents}, $mi->{Message};
2440 my $compat_info= pop @mergeinputs
2441 if $mergeinputs[$#mergeinputs]{Message};
2443 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2446 if (@mergeinputs > 1) {
2448 my $tree_commit = $mergeinputs[0]{Commit};
2450 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2451 $tree =~ m/\n\n/; $tree = $`;
2452 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2455 # We use the changelog author of the package in question the
2456 # author of this pseudo-merge. This is (roughly) correct if
2457 # this commit is simply representing aa non-dgit upload.
2458 # (Roughly because it does not record sponsorship - but we
2459 # don't have sponsorship info because that's in the .changes,
2460 # which isn't in the archivw.)
2462 # But, it might be that we are representing archive history
2463 # updates (including in-archive copies). These are not really
2464 # the responsibility of the person who created the .dsc, but
2465 # there is no-one whose name we should better use. (The
2466 # author of the .dsc-named commit is clearly worse.)
2468 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2469 my $author = clogp_authline $useclogp;
2470 my $cversion = getfield $useclogp, 'Version';
2472 my $mcf = ".git/dgit/mergecommit";
2473 open MC, ">", $mcf or die "$mcf $!";
2474 print MC <<END or die $!;
2478 my @parents = grep { $_->{Commit} } @mergeinputs;
2479 @parents = reverse @parents if $compat_info->{ReverseParents};
2480 print MC <<END or die $! foreach @parents;
2484 print MC <<END or die $!;
2490 if (defined $compat_info->{Message}) {
2491 print MC $compat_info->{Message} or die $!;
2493 print MC <<END or die $!;
2494 Record $package ($cversion) in archive suite $csuite
2498 my $message_add_info = sub {
2500 my $mversion = mergeinfo_version $mi;
2501 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2505 $message_add_info->($mergeinputs[0]);
2506 print MC <<END or die $!;
2507 should be treated as descended from
2509 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2513 $hash = make_commit $mcf;
2515 $hash = $mergeinputs[0]{Commit};
2517 printdebug "fetch hash=$hash\n";
2520 my ($lasth, $what) = @_;
2521 return unless $lasth;
2522 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2525 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2526 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2528 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2529 'DGIT_ARCHIVE', $hash;
2530 cmdoutput @git, qw(log -n2), $hash;
2531 # ... gives git a chance to complain if our commit is malformed
2533 if (defined $skew_warning_vsn) {
2535 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2536 my $gotclogp = commit_getclogp($hash);
2537 my $got_vsn = getfield $gotclogp, 'Version';
2538 printdebug "SKEW CHECK GOT $got_vsn\n";
2539 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2540 print STDERR <<END or die $!;
2542 Warning: archive skew detected. Using the available version:
2543 Archive allegedly contains $skew_warning_vsn
2544 We were able to obtain only $got_vsn
2550 if ($lastfetch_hash ne $hash) {
2551 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2555 dryrun_report @upd_cmd;
2559 lrfetchref_used lrfetchref();
2561 unshift @end, $del_lrfetchrefs;
2565 sub set_local_git_config ($$) {
2567 runcmd @git, qw(config), $k, $v;
2570 sub setup_mergechangelogs (;$) {
2572 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2574 my $driver = 'dpkg-mergechangelogs';
2575 my $cb = "merge.$driver";
2576 my $attrs = '.git/info/attributes';
2577 ensuredir '.git/info';
2579 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2580 if (!open ATTRS, "<", $attrs) {
2581 $!==ENOENT or die "$attrs: $!";
2585 next if m{^debian/changelog\s};
2586 print NATTRS $_, "\n" or die $!;
2588 ATTRS->error and die $!;
2591 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2594 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2595 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2597 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2600 sub setup_useremail (;$) {
2602 return unless $always || access_cfg_bool(1, 'setup-useremail');
2605 my ($k, $envvar) = @_;
2606 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2607 return unless defined $v;
2608 set_local_git_config "user.$k", $v;
2611 $setup->('email', 'DEBEMAIL');
2612 $setup->('name', 'DEBFULLNAME');
2615 sub ensure_setup_existing_tree () {
2616 my $k = "remote.$remotename.skipdefaultupdate";
2617 my $c = git_get_config $k;
2618 return if defined $c;
2619 set_local_git_config $k, 'true';
2622 sub setup_new_tree () {
2623 setup_mergechangelogs();
2629 canonicalise_suite();
2630 badusage "dry run makes no sense with clone" unless act_local();
2631 my $hasgit = check_for_git();
2632 mkdir $dstdir or fail "create \`$dstdir': $!";
2634 runcmd @git, qw(init -q);
2635 my $giturl = access_giturl(1);
2636 if (defined $giturl) {
2637 open H, "> .git/HEAD" or die $!;
2638 print H "ref: ".lref()."\n" or die $!;
2640 runcmd @git, qw(remote add), 'origin', $giturl;
2643 progress "fetching existing git history";
2645 runcmd_ordryrun_local @git, qw(fetch origin);
2647 progress "starting new git history";
2649 fetch_from_archive() or no_such_package;
2650 my $vcsgiturl = $dsc->{'Vcs-Git'};
2651 if (length $vcsgiturl) {
2652 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2653 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2656 runcmd @git, qw(reset --hard), lrref();
2657 printdone "ready for work in $dstdir";
2661 if (check_for_git()) {
2664 fetch_from_archive() or no_such_package();
2665 printdone "fetched into ".lrref();
2670 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2672 printdone "fetched to ".lrref()." and merged into HEAD";
2675 sub check_not_dirty () {
2676 foreach my $f (qw(local-options local-patch-header)) {
2677 if (stat_exists "debian/source/$f") {
2678 fail "git tree contains debian/source/$f";
2682 return if $ignoredirty;
2684 my @cmd = (@git, qw(diff --quiet HEAD));
2686 $!=0; $?=-1; system @cmd;
2689 fail "working tree is dirty (does not match HEAD)";
2695 sub commit_admin ($) {
2698 runcmd_ordryrun_local @git, qw(commit -m), $m;
2701 sub commit_quilty_patch () {
2702 my $output = cmdoutput @git, qw(status --porcelain);
2704 foreach my $l (split /\n/, $output) {
2705 next unless $l =~ m/\S/;
2706 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2710 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2712 progress "nothing quilty to commit, ok.";
2715 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2716 runcmd_ordryrun_local @git, qw(add -f), @adds;
2718 Commit Debian 3.0 (quilt) metadata
2720 [dgit ($our_version) quilt-fixup]
2724 sub get_source_format () {
2726 if (open F, "debian/source/options") {
2730 s/\s+$//; # ignore missing final newline
2732 my ($k, $v) = ($`, $'); #');
2733 $v =~ s/^"(.*)"$/$1/;
2739 F->error and die $!;
2742 die $! unless $!==&ENOENT;
2745 if (!open F, "debian/source/format") {
2746 die $! unless $!==&ENOENT;
2750 F->error and die $!;
2752 return ($_, \%options);
2755 sub madformat_wantfixup ($) {
2757 return 0 unless $format eq '3.0 (quilt)';
2758 our $quilt_mode_warned;
2759 if ($quilt_mode eq 'nocheck') {
2760 progress "Not doing any fixup of \`$format' due to".
2761 " ----no-quilt-fixup or --quilt=nocheck"
2762 unless $quilt_mode_warned++;
2765 progress "Format \`$format', need to check/update patch stack"
2766 unless $quilt_mode_warned++;
2770 # An "infopair" is a tuple [ $thing, $what ]
2771 # (often $thing is a commit hash; $what is a description)
2773 sub infopair_cond_equal ($$) {
2775 $x->[0] eq $y->[0] or fail <<END;
2776 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2780 sub infopair_lrf_tag_lookup ($$) {
2781 my ($tagnames, $what) = @_;
2782 # $tagname may be an array ref
2783 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2784 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2785 foreach my $tagname (@tagnames) {
2786 my $lrefname = lrfetchrefs."/tags/$tagname";
2787 my $tagobj = $lrfetchrefs_f{$lrefname};
2788 next unless defined $tagobj;
2789 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2790 return [ git_rev_parse($tagobj), $what ];
2792 fail @tagnames==1 ? <<END : <<END;
2793 Wanted tag $what (@tagnames) on dgit server, but not found
2795 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2799 sub infopair_cond_ff ($$) {
2800 my ($anc,$desc) = @_;
2801 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2802 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2806 sub pseudomerge_version_check ($$) {
2807 my ($clogp, $archive_hash) = @_;
2809 my $arch_clogp = commit_getclogp $archive_hash;
2810 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2811 'version currently in archive' ];
2812 if (defined $overwrite_version) {
2813 if (length $overwrite_version) {
2814 infopair_cond_equal([ $overwrite_version,
2815 '--overwrite= version' ],
2818 my $v = $i_arch_v->[0];
2819 progress "Checking package changelog for archive version $v ...";
2821 my @xa = ("-f$v", "-t$v");
2822 my $vclogp = parsechangelog @xa;
2823 my $cv = [ (getfield $vclogp, 'Version'),
2824 "Version field from dpkg-parsechangelog @xa" ];
2825 infopair_cond_equal($i_arch_v, $cv);
2828 $@ =~ s/^dgit: //gm;
2830 "Perhaps debian/changelog does not mention $v ?";
2835 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2839 sub pseudomerge_make_commit ($$$$ $$) {
2840 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2841 $msg_cmd, $msg_msg) = @_;
2842 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2844 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2845 my $authline = clogp_authline $clogp;
2849 !defined $overwrite_version ? ""
2850 : !length $overwrite_version ? " --overwrite"
2851 : " --overwrite=".$overwrite_version;
2854 my $pmf = ".git/dgit/pseudomerge";
2855 open MC, ">", $pmf or die "$pmf $!";
2856 print MC <<END or die $!;
2859 parent $archive_hash
2869 return make_commit($pmf);
2872 sub splitbrain_pseudomerge ($$$$) {
2873 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2874 # => $merged_dgitview
2875 printdebug "splitbrain_pseudomerge...\n";
2877 # We: debian/PREVIOUS HEAD($maintview)
2878 # expect: o ----------------- o
2881 # a/d/PREVIOUS $dgitview
2884 # we do: `------------------ o
2888 printdebug "splitbrain_pseudomerge...\n";
2890 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2892 return $dgitview unless defined $archive_hash;
2894 if (!defined $overwrite_version) {
2895 progress "Checking that HEAD inciudes all changes in archive...";
2898 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2900 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2901 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2902 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2903 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2904 my $i_archive = [ $archive_hash, "current archive contents" ];
2906 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2908 infopair_cond_equal($i_dgit, $i_archive);
2909 infopair_cond_ff($i_dep14, $i_dgit);
2910 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2912 my $r = pseudomerge_make_commit
2913 $clogp, $dgitview, $archive_hash, $i_arch_v,
2914 "dgit --quilt=$quilt_mode",
2915 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2916 Declare fast forward from $overwrite_version
2918 Make fast forward from $i_arch_v->[0]
2921 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2925 sub plain_overwrite_pseudomerge ($$$) {
2926 my ($clogp, $head, $archive_hash) = @_;
2928 printdebug "plain_overwrite_pseudomerge...";
2930 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2932 my @tagformats = access_cfg_tagformats();
2934 map { $_->($i_arch_v->[0], access_basedistro) }
2935 (grep { m/^(?:old|hist)$/ } @tagformats)
2936 ? \&debiantags : \&debiantag_new;
2937 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2938 my $i_archive = [ $archive_hash, "current archive contents" ];
2940 infopair_cond_equal($i_overwr, $i_archive);
2942 return $head if is_fast_fwd $archive_hash, $head;
2944 my $m = "Declare fast forward from $i_arch_v->[0]";
2946 my $r = pseudomerge_make_commit
2947 $clogp, $head, $archive_hash, $i_arch_v,
2950 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2952 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2956 sub push_parse_changelog ($) {
2959 my $clogp = Dpkg::Control::Hash->new();
2960 $clogp->load($clogpfn) or die;
2962 $package = getfield $clogp, 'Source';
2963 my $cversion = getfield $clogp, 'Version';
2964 my $tag = debiantag($cversion, access_basedistro);
2965 runcmd @git, qw(check-ref-format), $tag;
2967 my $dscfn = dscfn($cversion);
2969 return ($clogp, $cversion, $dscfn);
2972 sub push_parse_dsc ($$$) {
2973 my ($dscfn,$dscfnwhat, $cversion) = @_;
2974 $dsc = parsecontrol($dscfn,$dscfnwhat);
2975 my $dversion = getfield $dsc, 'Version';
2976 my $dscpackage = getfield $dsc, 'Source';
2977 ($dscpackage eq $package && $dversion eq $cversion) or
2978 fail "$dscfn is for $dscpackage $dversion".
2979 " but debian/changelog is for $package $cversion";
2982 sub push_tagwants ($$$$) {
2983 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2986 TagFn => \&debiantag,
2991 if (defined $maintviewhead) {
2993 TagFn => \&debiantag_maintview,
2994 Objid => $maintviewhead,
2995 TfSuffix => '-maintview',
2999 foreach my $tw (@tagwants) {
3000 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3001 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3003 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3007 sub push_mktags ($$ $$ $) {
3009 $changesfile,$changesfilewhat,
3012 die unless $tagwants->[0]{View} eq 'dgit';
3014 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3015 $dsc->save("$dscfn.tmp") or die $!;
3017 my $changes = parsecontrol($changesfile,$changesfilewhat);
3018 foreach my $field (qw(Source Distribution Version)) {
3019 $changes->{$field} eq $clogp->{$field} or
3020 fail "changes field $field \`$changes->{$field}'".
3021 " does not match changelog \`$clogp->{$field}'";
3024 my $cversion = getfield $clogp, 'Version';
3025 my $clogsuite = getfield $clogp, 'Distribution';
3027 # We make the git tag by hand because (a) that makes it easier
3028 # to control the "tagger" (b) we can do remote signing
3029 my $authline = clogp_authline $clogp;
3030 my $delibs = join(" ", "",@deliberatelies);
3031 my $declaredistro = access_basedistro();
3035 my $tfn = $tw->{Tfn};
3036 my $head = $tw->{Objid};
3037 my $tag = $tw->{Tag};
3039 open TO, '>', $tfn->('.tmp') or die $!;
3040 print TO <<END or die $!;
3047 if ($tw->{View} eq 'dgit') {
3048 print TO <<END or die $!;
3049 $package release $cversion for $clogsuite ($csuite) [dgit]
3050 [dgit distro=$declaredistro$delibs]
3052 foreach my $ref (sort keys %previously) {
3053 print TO <<END or die $!;
3054 [dgit previously:$ref=$previously{$ref}]
3057 } elsif ($tw->{View} eq 'maint') {
3058 print TO <<END or die $!;
3059 $package release $cversion for $clogsuite ($csuite)
3060 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3063 die Dumper($tw)."?";
3068 my $tagobjfn = $tfn->('.tmp');
3070 if (!defined $keyid) {
3071 $keyid = access_cfg('keyid','RETURN-UNDEF');
3073 if (!defined $keyid) {
3074 $keyid = getfield $clogp, 'Maintainer';
3076 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3077 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3078 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3079 push @sign_cmd, $tfn->('.tmp');
3080 runcmd_ordryrun @sign_cmd;
3082 $tagobjfn = $tfn->('.signed.tmp');
3083 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3084 $tfn->('.tmp'), $tfn->('.tmp.asc');
3090 my @r = map { $mktag->($_); } @$tagwants;
3094 sub sign_changes ($) {
3095 my ($changesfile) = @_;
3097 my @debsign_cmd = @debsign;
3098 push @debsign_cmd, "-k$keyid" if defined $keyid;
3099 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3100 push @debsign_cmd, $changesfile;
3101 runcmd_ordryrun @debsign_cmd;
3106 printdebug "actually entering push\n";
3108 supplementary_message(<<'END');
3109 Push failed, while checking state of the archive.
3110 You can retry the push, after fixing the problem, if you like.
3112 if (check_for_git()) {
3115 my $archive_hash = fetch_from_archive();
3116 if (!$archive_hash) {
3118 fail "package appears to be new in this suite;".
3119 " if this is intentional, use --new";
3122 supplementary_message(<<'END');
3123 Push failed, while preparing your push.
3124 You can retry the push, after fixing the problem, if you like.
3127 need_tagformat 'new', "quilt mode $quilt_mode"
3128 if quiltmode_splitbrain;
3132 access_giturl(); # check that success is vaguely likely
3135 my $clogpfn = ".git/dgit/changelog.822.tmp";
3136 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3138 responder_send_file('parsed-changelog', $clogpfn);
3140 my ($clogp, $cversion, $dscfn) =
3141 push_parse_changelog("$clogpfn");
3143 my $dscpath = "$buildproductsdir/$dscfn";
3144 stat_exists $dscpath or
3145 fail "looked for .dsc $dscfn, but $!;".
3146 " maybe you forgot to build";
3148 responder_send_file('dsc', $dscpath);
3150 push_parse_dsc($dscpath, $dscfn, $cversion);
3152 my $format = getfield $dsc, 'Format';
3153 printdebug "format $format\n";
3155 my $actualhead = git_rev_parse('HEAD');
3156 my $dgithead = $actualhead;
3157 my $maintviewhead = undef;
3159 if (madformat_wantfixup($format)) {
3160 # user might have not used dgit build, so maybe do this now:
3161 if (quiltmode_splitbrain()) {
3162 my $upstreamversion = $clogp->{Version};
3163 $upstreamversion =~ s/-[^-]*$//;
3165 quilt_make_fake_dsc($upstreamversion);
3166 my ($dgitview, $cachekey) =
3167 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3169 "--quilt=$quilt_mode but no cached dgit view:
3170 perhaps tree changed since dgit build[-source] ?";
3172 $dgithead = splitbrain_pseudomerge($clogp,
3173 $actualhead, $dgitview,
3175 $maintviewhead = $actualhead;
3176 changedir '../../../..';
3177 prep_ud(); # so _only_subdir() works, below
3179 commit_quilty_patch();
3183 if (defined $overwrite_version && !defined $maintviewhead) {
3184 $dgithead = plain_overwrite_pseudomerge($clogp,
3192 if ($archive_hash) {
3193 if (is_fast_fwd($archive_hash, $dgithead)) {
3195 } elsif (deliberately_not_fast_forward) {
3198 fail "dgit push: HEAD is not a descendant".
3199 " of the archive's version.\n".
3200 "To overwrite the archive's contents,".
3201 " pass --overwrite[=VERSION].\n".
3202 "To rewind history, if permitted by the archive,".
3203 " use --deliberately-not-fast-forward.";
3208 progress "checking that $dscfn corresponds to HEAD";
3209 runcmd qw(dpkg-source -x --),
3210 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3211 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3212 check_for_vendor_patches() if madformat($dsc->{format});
3213 changedir '../../../..';
3214 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
3215 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
3216 debugcmd "+",@diffcmd;
3218 my $r = system @diffcmd;
3221 fail "$dscfn specifies a different tree to your HEAD commit;".
3222 " perhaps you forgot to build".
3223 ($diffopt eq '--exit-code' ? "" :
3224 " (run with -D to see full diff output)");
3229 if (!$changesfile) {
3230 my $pat = changespat $cversion;
3231 my @cs = glob "$buildproductsdir/$pat";
3232 fail "failed to find unique changes file".
3233 " (looked for $pat in $buildproductsdir);".
3234 " perhaps you need to use dgit -C"
3236 ($changesfile) = @cs;
3238 $changesfile = "$buildproductsdir/$changesfile";
3241 # Check that changes and .dsc agree enough
3242 $changesfile =~ m{[^/]*$};
3243 files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3245 # Checks complete, we're going to try and go ahead:
3247 responder_send_file('changes',$changesfile);
3248 responder_send_command("param head $dgithead");
3249 responder_send_command("param csuite $csuite");
3250 responder_send_command("param tagformat $tagformat");
3251 if (defined $maintviewhead) {
3252 die unless ($protovsn//4) >= 4;
3253 responder_send_command("param maint-view $maintviewhead");
3256 if (deliberately_not_fast_forward) {
3257 git_for_each_ref(lrfetchrefs, sub {
3258 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3259 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3260 responder_send_command("previously $rrefname=$objid");
3261 $previously{$rrefname} = $objid;
3265 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3269 supplementary_message(<<'END');
3270 Push failed, while signing the tag.
3271 You can retry the push, after fixing the problem, if you like.
3273 # If we manage to sign but fail to record it anywhere, it's fine.
3274 if ($we_are_responder) {
3275 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3276 responder_receive_files('signed-tag', @tagobjfns);
3278 @tagobjfns = push_mktags($clogp,$dscpath,
3279 $changesfile,$changesfile,
3282 supplementary_message(<<'END');
3283 Push failed, *after* signing the tag.
3284 If you want to try again, you should use a new version number.
3287 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3289 foreach my $tw (@tagwants) {
3290 my $tag = $tw->{Tag};
3291 my $tagobjfn = $tw->{TagObjFn};
3293 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3294 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3295 runcmd_ordryrun_local
3296 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3299 supplementary_message(<<'END');
3300 Push failed, while updating the remote git repository - see messages above.
3301 If you want to try again, you should use a new version number.
3303 if (!check_for_git()) {
3304 create_remote_git_repo();
3307 my @pushrefs = $forceflag.$dgithead.":".rrref();
3308 foreach my $tw (@tagwants) {
3309 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3312 runcmd_ordryrun @git,
3313 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3314 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3316 supplementary_message(<<'END');
3317 Push failed, after updating the remote git repository.
3318 If you want to try again, you must use a new version number.
3320 if ($we_are_responder) {
3321 my $dryrunsuffix = act_local() ? "" : ".tmp";
3322 responder_receive_files('signed-dsc-changes',
3323 "$dscpath$dryrunsuffix",
3324 "$changesfile$dryrunsuffix");
3327 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3329 progress "[new .dsc left in $dscpath.tmp]";
3331 sign_changes $changesfile;
3334 supplementary_message(<<END);
3335 Push failed, while uploading package(s) to the archive server.
3336 You can retry the upload of exactly these same files with dput of:
3338 If that .changes file is broken, you will need to use a new version
3339 number for your next attempt at the upload.
3341 my $host = access_cfg('upload-host','RETURN-UNDEF');
3342 my @hostarg = defined($host) ? ($host,) : ();
3343 runcmd_ordryrun @dput, @hostarg, $changesfile;
3344 printdone "pushed and uploaded $cversion";
3346 supplementary_message('');
3347 responder_send_command("complete");
3354 badusage "-p is not allowed with clone; specify as argument instead"
3355 if defined $package;
3358 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3359 ($package,$isuite) = @ARGV;
3360 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3361 ($package,$dstdir) = @ARGV;
3362 } elsif (@ARGV==3) {
3363 ($package,$isuite,$dstdir) = @ARGV;
3365 badusage "incorrect arguments to dgit clone";
3367 $dstdir ||= "$package";
3369 if (stat_exists $dstdir) {
3370 fail "$dstdir already exists";
3374 if ($rmonerror && !$dryrun_level) {
3375 $cwd_remove= getcwd();
3377 return unless defined $cwd_remove;
3378 if (!chdir "$cwd_remove") {
3379 return if $!==&ENOENT;
3380 die "chdir $cwd_remove: $!";
3383 rmtree($dstdir) or die "remove $dstdir: $!\n";
3384 } elsif (grep { $! == $_ }
3385 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3387 print STDERR "check whether to remove $dstdir: $!\n";
3393 $cwd_remove = undef;
3396 sub branchsuite () {
3397 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3398 if ($branch =~ m#$lbranch_re#o) {
3405 sub fetchpullargs () {
3407 if (!defined $package) {
3408 my $sourcep = parsecontrol('debian/control','debian/control');
3409 $package = getfield $sourcep, 'Source';
3412 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3414 my $clogp = parsechangelog();
3415 $isuite = getfield $clogp, 'Distribution';
3417 canonicalise_suite();
3418 progress "fetching from suite $csuite";
3419 } elsif (@ARGV==1) {
3421 canonicalise_suite();
3423 badusage "incorrect arguments to dgit fetch or dgit pull";
3442 badusage "-p is not allowed with dgit push" if defined $package;
3444 my $clogp = parsechangelog();
3445 $package = getfield $clogp, 'Source';
3448 } elsif (@ARGV==1) {
3449 ($specsuite) = (@ARGV);
3451 badusage "incorrect arguments to dgit push";
3453 $isuite = getfield $clogp, 'Distribution';
3455 local ($package) = $existing_package; # this is a hack
3456 canonicalise_suite();
3458 canonicalise_suite();
3460 if (defined $specsuite &&
3461 $specsuite ne $isuite &&
3462 $specsuite ne $csuite) {
3463 fail "dgit push: changelog specifies $isuite ($csuite)".
3464 " but command line specifies $specsuite";
3469 #---------- remote commands' implementation ----------
3471 sub cmd_remote_push_build_host {
3472 my ($nrargs) = shift @ARGV;
3473 my (@rargs) = @ARGV[0..$nrargs-1];
3474 @ARGV = @ARGV[$nrargs..$#ARGV];
3476 my ($dir,$vsnwant) = @rargs;
3477 # vsnwant is a comma-separated list; we report which we have
3478 # chosen in our ready response (so other end can tell if they
3481 $we_are_responder = 1;
3482 $us .= " (build host)";
3486 open PI, "<&STDIN" or die $!;
3487 open STDIN, "/dev/null" or die $!;
3488 open PO, ">&STDOUT" or die $!;
3490 open STDOUT, ">&STDERR" or die $!;
3494 ($protovsn) = grep {
3495 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3496 } @rpushprotovsn_support;
3498 fail "build host has dgit rpush protocol versions ".
3499 (join ",", @rpushprotovsn_support).
3500 " but invocation host has $vsnwant"
3501 unless defined $protovsn;
3503 responder_send_command("dgit-remote-push-ready $protovsn");
3504 rpush_handle_protovsn_bothends();
3509 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3510 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3511 # a good error message)
3513 sub rpush_handle_protovsn_bothends () {
3514 if ($protovsn < 4) {
3515 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3524 my $report = i_child_report();
3525 if (defined $report) {
3526 printdebug "($report)\n";
3527 } elsif ($i_child_pid) {
3528 printdebug "(killing build host child $i_child_pid)\n";
3529 kill 15, $i_child_pid;
3531 if (defined $i_tmp && !defined $initiator_tempdir) {
3533 eval { rmtree $i_tmp; };
3537 END { i_cleanup(); }
3540 my ($base,$selector,@args) = @_;
3541 $selector =~ s/\-/_/g;
3542 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3549 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3557 push @rargs, join ",", @rpushprotovsn_support;
3560 push @rdgit, @ropts;
3561 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3563 my @cmd = (@ssh, $host, shellquote @rdgit);
3566 if (defined $initiator_tempdir) {
3567 rmtree $initiator_tempdir;
3568 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3569 $i_tmp = $initiator_tempdir;
3573 $i_child_pid = open2(\*RO, \*RI, @cmd);
3575 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3576 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3577 $supplementary_message = '' unless $protovsn >= 3;
3579 fail "rpush negotiated protocol version $protovsn".
3580 " which does not support quilt mode $quilt_mode"
3581 if quiltmode_splitbrain;
3583 rpush_handle_protovsn_bothends();
3585 my ($icmd,$iargs) = initiator_expect {
3586 m/^(\S+)(?: (.*))?$/;
3589 i_method "i_resp", $icmd, $iargs;
3593 sub i_resp_progress ($) {
3595 my $msg = protocol_read_bytes \*RO, $rhs;
3599 sub i_resp_supplementary_message ($) {
3601 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3604 sub i_resp_complete {
3605 my $pid = $i_child_pid;
3606 $i_child_pid = undef; # prevents killing some other process with same pid
3607 printdebug "waiting for build host child $pid...\n";
3608 my $got = waitpid $pid, 0;
3609 die $! unless $got == $pid;
3610 die "build host child failed $?" if $?;
3613 printdebug "all done\n";
3617 sub i_resp_file ($) {
3619 my $localname = i_method "i_localname", $keyword;
3620 my $localpath = "$i_tmp/$localname";
3621 stat_exists $localpath and
3622 badproto \*RO, "file $keyword ($localpath) twice";
3623 protocol_receive_file \*RO, $localpath;
3624 i_method "i_file", $keyword;
3629 sub i_resp_param ($) {
3630 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3634 sub i_resp_previously ($) {
3635 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3636 or badproto \*RO, "bad previously spec";
3637 my $r = system qw(git check-ref-format), $1;
3638 die "bad previously ref spec ($r)" if $r;
3639 $previously{$1} = $2;
3644 sub i_resp_want ($) {
3646 die "$keyword ?" if $i_wanted{$keyword}++;
3647 my @localpaths = i_method "i_want", $keyword;
3648 printdebug "[[ $keyword @localpaths\n";
3649 foreach my $localpath (@localpaths) {
3650 protocol_send_file \*RI, $localpath;
3652 print RI "files-end\n" or die $!;
3655 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3657 sub i_localname_parsed_changelog {
3658 return "remote-changelog.822";
3660 sub i_file_parsed_changelog {
3661 ($i_clogp, $i_version, $i_dscfn) =
3662 push_parse_changelog "$i_tmp/remote-changelog.822";
3663 die if $i_dscfn =~ m#/|^\W#;
3666 sub i_localname_dsc {
3667 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3672 sub i_localname_changes {
3673 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3674 $i_changesfn = $i_dscfn;
3675 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3676 return $i_changesfn;
3678 sub i_file_changes { }
3680 sub i_want_signed_tag {
3681 printdebug Dumper(\%i_param, $i_dscfn);
3682 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3683 && defined $i_param{'csuite'}
3684 or badproto \*RO, "premature desire for signed-tag";
3685 my $head = $i_param{'head'};
3686 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3688 my $maintview = $i_param{'maint-view'};
3689 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3692 if ($protovsn >= 4) {
3693 my $p = $i_param{'tagformat'} // '<undef>';
3695 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3698 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3700 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3702 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3705 push_mktags $i_clogp, $i_dscfn,
3706 $i_changesfn, 'remote changes',
3710 sub i_want_signed_dsc_changes {
3711 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3712 sign_changes $i_changesfn;
3713 return ($i_dscfn, $i_changesfn);
3716 #---------- building etc. ----------
3722 #----- `3.0 (quilt)' handling -----
3724 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3726 sub quiltify_dpkg_commit ($$$;$) {
3727 my ($patchname,$author,$msg, $xinfo) = @_;
3731 my $descfn = ".git/dgit/quilt-description.tmp";
3732 open O, '>', $descfn or die "$descfn: $!";
3733 $msg =~ s/\n+/\n\n/;
3734 print O <<END or die $!;
3736 ${xinfo}Subject: $msg
3743 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3744 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3745 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3746 runcmd @dpkgsource, qw(--commit .), $patchname;
3750 sub quiltify_trees_differ ($$;$$$) {
3751 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3752 # returns true iff the two tree objects differ other than in debian/
3753 # with $finegrained,
3754 # returns bitmask 01 - differ in upstream files except .gitignore
3755 # 02 - differ in .gitignore
3756 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3757 # is set for each modified .gitignore filename $fn
3758 # if $unrepres is defined, array ref to which is appeneded
3759 # a list of unrepresentable changes (removals of upstream files
3762 my @cmd = (@git, qw(diff-tree -z));
3763 push @cmd, qw(--name-only) unless $unrepres;
3764 push @cmd, qw(-r) if $finegrained || $unrepres;
3766 my $diffs= cmdoutput @cmd;
3769 foreach my $f (split /\0/, $diffs) {
3770 if ($unrepres && !@lmodes) {
3771 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3774 my ($oldmode,$newmode) = @lmodes;
3777 next if $f =~ m#^debian(?:/.*)?$#s;
3781 die "deleted\n" unless $newmode =~ m/[^0]/;
3782 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3783 if ($oldmode =~ m/[^0]/) {
3784 die "mode changed\n" if $oldmode ne $newmode;
3786 die "non-default mode\n" unless $newmode =~ m/^100644$/;
3790 local $/="\n"; chomp $@;
3791 push @$unrepres, [ $f, $@ ];
3795 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3796 $r |= $isignore ? 02 : 01;
3797 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3799 printdebug "quiltify_trees_differ $x $y => $r\n";
3803 sub quiltify_tree_sentinelfiles ($) {
3804 # lists the `sentinel' files present in the tree
3806 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3807 qw(-- debian/rules debian/control);
3812 sub quiltify_splitbrain_needed () {
3813 if (!$split_brain) {
3814 progress "dgit view: changes are required...";
3815 runcmd @git, qw(checkout -q -b dgit-view);
3820 sub quiltify_splitbrain ($$$$$$) {
3821 my ($clogp, $unapplied, $headref, $diffbits,
3822 $editedignores, $cachekey) = @_;
3823 if ($quilt_mode !~ m/gbp|dpm/) {
3824 # treat .gitignore just like any other upstream file
3825 $diffbits = { %$diffbits };
3826 $_ = !!$_ foreach values %$diffbits;
3828 # We would like any commits we generate to be reproducible
3829 my @authline = clogp_authline($clogp);
3830 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3831 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3832 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3833 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3834 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3835 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3837 if ($quilt_mode =~ m/gbp|unapplied/ &&
3838 ($diffbits->{O2H} & 01)) {
3840 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3841 " but git tree differs from orig in upstream files.";
3842 if (!stat_exists "debian/patches") {
3844 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3848 if ($quilt_mode =~ m/dpm/ &&
3849 ($diffbits->{H2A} & 01)) {
3851 --quilt=$quilt_mode specified, implying patches-applied git tree
3852 but git tree differs from result of applying debian/patches to upstream
3855 if ($quilt_mode =~ m/gbp|unapplied/ &&
3856 ($diffbits->{O2A} & 01)) { # some patches
3857 quiltify_splitbrain_needed();
3858 progress "dgit view: creating patches-applied version using gbp pq";
3859 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3860 # gbp pq import creates a fresh branch; push back to dgit-view
3861 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3862 runcmd @git, qw(checkout -q dgit-view);
3864 if ($quilt_mode =~ m/gbp|dpm/ &&
3865 ($diffbits->{O2A} & 02)) {
3867 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3868 tool which does not create patches for changes to upstream
3869 .gitignores: but, such patches exist in debian/patches.
3872 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3873 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3874 quiltify_splitbrain_needed();
3875 progress "dgit view: creating patch to represent .gitignore changes";
3876 ensuredir "debian/patches";
3877 my $gipatch = "debian/patches/auto-gitignore";
3878 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3879 stat GIPATCH or die "$gipatch: $!";
3880 fail "$gipatch already exists; but want to create it".
3881 " to record .gitignore changes" if (stat _)[7];
3882 print GIPATCH <<END or die "$gipatch: $!";
3883 Subject: Update .gitignore from Debian packaging branch
3885 The Debian packaging git branch contains these updates to the upstream
3886 .gitignore file(s). This patch is autogenerated, to provide these
3887 updates to users of the official Debian archive view of the package.
3889 [dgit ($our_version) update-gitignore]
3892 close GIPATCH or die "$gipatch: $!";
3893 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3894 $unapplied, $headref, "--", sort keys %$editedignores;
3895 open SERIES, "+>>", "debian/patches/series" or die $!;
3896 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3898 defined read SERIES, $newline, 1 or die $!;
3899 print SERIES "\n" or die $! unless $newline eq "\n";
3900 print SERIES "auto-gitignore\n" or die $!;
3901 close SERIES or die $!;
3902 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3904 Commit patch to update .gitignore
3906 [dgit ($our_version) update-gitignore-quilt-fixup]
3910 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3912 changedir '../../../..';
3913 ensuredir ".git/logs/refs/dgit-intern";
3914 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3916 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3919 progress "dgit view: created (commit id $dgitview)";
3921 changedir '.git/dgit/unpack/work';
3924 sub quiltify ($$$$) {
3925 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3927 # Quilt patchification algorithm
3929 # We search backwards through the history of the main tree's HEAD
3930 # (T) looking for a start commit S whose tree object is identical
3931 # to to the patch tip tree (ie the tree corresponding to the
3932 # current dpkg-committed patch series). For these purposes
3933 # `identical' disregards anything in debian/ - this wrinkle is
3934 # necessary because dpkg-source treates debian/ specially.
3936 # We can only traverse edges where at most one of the ancestors'
3937 # trees differs (in changes outside in debian/). And we cannot
3938 # handle edges which change .pc/ or debian/patches. To avoid
3939 # going down a rathole we avoid traversing edges which introduce
3940 # debian/rules or debian/control. And we set a limit on the
3941 # number of edges we are willing to look at.
3943 # If we succeed, we walk forwards again. For each traversed edge
3944 # PC (with P parent, C child) (starting with P=S and ending with
3945 # C=T) to we do this:
3947 # - dpkg-source --commit with a patch name and message derived from C
3948 # After traversing PT, we git commit the changes which
3949 # should be contained within debian/patches.
3951 # The search for the path S..T is breadth-first. We maintain a
3952 # todo list containing search nodes. A search node identifies a
3953 # commit, and looks something like this:
3955 # Commit => $git_commit_id,
3956 # Child => $c, # or undef if P=T
3957 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3958 # Nontrivial => true iff $p..$c has relevant changes
3965 my %considered; # saves being exponential on some weird graphs
3967 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3970 my ($search,$whynot) = @_;
3971 printdebug " search NOT $search->{Commit} $whynot\n";
3972 $search->{Whynot} = $whynot;
3973 push @nots, $search;
3974 no warnings qw(exiting);
3983 my $c = shift @todo;
3984 next if $considered{$c->{Commit}}++;
3986 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3988 printdebug "quiltify investigate $c->{Commit}\n";
3991 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3992 printdebug " search finished hooray!\n";
3997 if ($quilt_mode eq 'nofix') {
3998 fail "quilt fixup required but quilt mode is \`nofix'\n".
3999 "HEAD commit $c->{Commit} differs from tree implied by ".
4000 " debian/patches (tree object $oldtiptree)";
4002 if ($quilt_mode eq 'smash') {
4003 printdebug " search quitting smash\n";
4007 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4008 $not->($c, "has $c_sentinels not $t_sentinels")
4009 if $c_sentinels ne $t_sentinels;
4011 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4012 $commitdata =~ m/\n\n/;
4014 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4015 @parents = map { { Commit => $_, Child => $c } } @parents;
4017 $not->($c, "root commit") if !@parents;
4019 foreach my $p (@parents) {
4020 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4022 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4023 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4025 foreach my $p (@parents) {
4026 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4028 my @cmd= (@git, qw(diff-tree -r --name-only),
4029 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4030 my $patchstackchange = cmdoutput @cmd;
4031 if (length $patchstackchange) {
4032 $patchstackchange =~ s/\n/,/g;
4033 $not->($p, "changed $patchstackchange");
4036 printdebug " search queue P=$p->{Commit} ",
4037 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4043 printdebug "quiltify want to smash\n";
4046 my $x = $_[0]{Commit};
4047 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4050 my $reportnot = sub {
4052 my $s = $abbrev->($notp);
4053 my $c = $notp->{Child};
4054 $s .= "..".$abbrev->($c) if $c;
4055 $s .= ": ".$notp->{Whynot};
4058 if ($quilt_mode eq 'linear') {
4059 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4060 foreach my $notp (@nots) {
4061 print STDERR "$us: ", $reportnot->($notp), "\n";
4063 print STDERR "$us: $_\n" foreach @$failsuggestion;
4064 fail "quilt fixup naive history linearisation failed.\n".
4065 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4066 } elsif ($quilt_mode eq 'smash') {
4067 } elsif ($quilt_mode eq 'auto') {
4068 progress "quilt fixup cannot be linear, smashing...";
4070 die "$quilt_mode ?";
4073 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4074 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4076 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4078 quiltify_dpkg_commit "auto-$version-$target-$time",
4079 (getfield $clogp, 'Maintainer'),
4080 "Automatically generated patch ($clogp->{Version})\n".
4081 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4085 progress "quiltify linearisation planning successful, executing...";
4087 for (my $p = $sref_S;
4088 my $c = $p->{Child};
4090 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4091 next unless $p->{Nontrivial};
4093 my $cc = $c->{Commit};
4095 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4096 $commitdata =~ m/\n\n/ or die "$c ?";
4099 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4102 my $commitdate = cmdoutput
4103 @git, qw(log -n1 --pretty=format:%aD), $cc;
4105 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4107 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4114 my $gbp_check_suitable = sub {
4119 die "contains unexpected slashes\n" if m{//} || m{/$};
4120 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4121 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4122 die "too long" if length > 200;
4124 return $_ unless $@;
4125 print STDERR "quiltifying commit $cc:".
4126 " ignoring/dropping Gbp-Pq $what: $@";
4130 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4132 (\S+) \s* \n //ixm) {
4133 $patchname = $gbp_check_suitable->($1, 'Name');
4135 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4137 (\S+) \s* \n //ixm) {
4138 $patchdir = $gbp_check_suitable->($1, 'Topic');
4143 if (!defined $patchname) {
4144 $patchname = $title;
4145 $patchname =~ s/[.:]$//;
4146 $patchname =~ y/ A-Z/-a-z/;
4147 $patchname =~ y/-a-z0-9_.+=~//cd;
4148 $patchname =~ s/^\W/x-$&/;
4149 $patchname = substr($patchname,0,40);
4151 if (!defined $patchdir) {
4154 if (length $patchdir) {
4155 $patchname = "$patchdir/$patchname";
4157 if ($patchname =~ m{^(.*)/}) {
4158 mkpath "debian/patches/$1";
4163 stat "debian/patches/$patchname$index";
4165 $!==ENOENT or die "$patchname$index $!";
4167 runcmd @git, qw(checkout -q), $cc;
4169 # We use the tip's changelog so that dpkg-source doesn't
4170 # produce complaining messages from dpkg-parsechangelog. None
4171 # of the information dpkg-source gets from the changelog is
4172 # actually relevant - it gets put into the original message
4173 # which dpkg-source provides our stunt editor, and then
4175 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4177 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4178 "Date: $commitdate\n".
4179 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4181 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4184 runcmd @git, qw(checkout -q master);
4187 sub build_maybe_quilt_fixup () {
4188 my ($format,$fopts) = get_source_format;
4189 return unless madformat_wantfixup $format;
4192 check_for_vendor_patches();
4194 if (quiltmode_splitbrain) {
4195 foreach my $needtf (qw(new maint)) {
4196 next if grep { $_ eq $needtf } access_cfg_tagformats;
4198 quilt mode $quilt_mode requires split view so server needs to support
4199 both "new" and "maint" tag formats, but config says it doesn't.
4204 my $clogp = parsechangelog();
4205 my $headref = git_rev_parse('HEAD');
4210 my $upstreamversion=$version;
4211 $upstreamversion =~ s/-[^-]*$//;
4213 if ($fopts->{'single-debian-patch'}) {
4214 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4216 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4219 die 'bug' if $split_brain && !$need_split_build_invocation;
4221 changedir '../../../..';
4222 runcmd_ordryrun_local
4223 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4226 sub quilt_fixup_mkwork ($) {
4229 mkdir "work" or die $!;
4231 mktree_in_ud_here();
4232 runcmd @git, qw(reset -q --hard), $headref;
4235 sub quilt_fixup_linkorigs ($$) {
4236 my ($upstreamversion, $fn) = @_;
4237 # calls $fn->($leafname);
4239 foreach my $f (<../../../../*>) { #/){
4240 my $b=$f; $b =~ s{.*/}{};
4242 local ($debuglevel) = $debuglevel-1;
4243 printdebug "QF linkorigs $b, $f ?\n";
4245 next unless is_orig_file_of_vsn $b, $upstreamversion;
4246 printdebug "QF linkorigs $b, $f Y\n";
4247 link_ltarget $f, $b or die "$b $!";
4252 sub quilt_fixup_delete_pc () {
4253 runcmd @git, qw(rm -rqf .pc);
4255 Commit removal of .pc (quilt series tracking data)
4257 [dgit ($our_version) upgrade quilt-remove-pc]
4261 sub quilt_fixup_singlepatch ($$$) {
4262 my ($clogp, $headref, $upstreamversion) = @_;
4264 progress "starting quiltify (single-debian-patch)";
4266 # dpkg-source --commit generates new patches even if
4267 # single-debian-patch is in debian/source/options. In order to
4268 # get it to generate debian/patches/debian-changes, it is
4269 # necessary to build the source package.
4271 quilt_fixup_linkorigs($upstreamversion, sub { });
4272 quilt_fixup_mkwork($headref);
4274 rmtree("debian/patches");
4276 runcmd @dpkgsource, qw(-b .);
4278 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4279 rename srcfn("$upstreamversion", "/debian/patches"),
4280 "work/debian/patches";
4283 commit_quilty_patch();
4286 sub quilt_make_fake_dsc ($) {
4287 my ($upstreamversion) = @_;
4289 my $fakeversion="$upstreamversion-~~DGITFAKE";
4291 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4292 print $fakedsc <<END or die $!;
4295 Version: $fakeversion
4299 my $dscaddfile=sub {
4302 my $md = new Digest::MD5;
4304 my $fh = new IO::File $b, '<' or die "$b $!";
4309 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4312 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4314 my @files=qw(debian/source/format debian/rules
4315 debian/control debian/changelog);
4316 foreach my $maybe (qw(debian/patches debian/source/options
4317 debian/tests/control)) {
4318 next unless stat_exists "../../../$maybe";
4319 push @files, $maybe;
4322 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4323 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4325 $dscaddfile->($debtar);
4326 close $fakedsc or die $!;
4329 sub quilt_check_splitbrain_cache ($$) {
4330 my ($headref, $upstreamversion) = @_;
4331 # Called only if we are in (potentially) split brain mode.
4333 # Computes the cache key and looks in the cache.
4334 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4336 my $splitbrain_cachekey;
4339 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4340 # we look in the reflog of dgit-intern/quilt-cache
4341 # we look for an entry whose message is the key for the cache lookup
4342 my @cachekey = (qw(dgit), $our_version);
4343 push @cachekey, $upstreamversion;
4344 push @cachekey, $quilt_mode;
4345 push @cachekey, $headref;
4347 push @cachekey, hashfile('fake.dsc');
4349 my $srcshash = Digest::SHA->new(256);
4350 my %sfs = ( %INC, '$0(dgit)' => $0 );
4351 foreach my $sfk (sort keys %sfs) {
4352 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
4353 $srcshash->add($sfk," ");
4354 $srcshash->add(hashfile($sfs{$sfk}));
4355 $srcshash->add("\n");
4357 push @cachekey, $srcshash->hexdigest();
4358 $splitbrain_cachekey = "@cachekey";
4360 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
4362 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4363 debugcmd "|(probably)",@cmd;
4364 my $child = open GC, "-|"; defined $child or die $!;
4366 chdir '../../..' or die $!;
4367 if (!stat ".git/logs/refs/$splitbraincache") {
4368 $! == ENOENT or die $!;
4369 printdebug ">(no reflog)\n";
4376 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4377 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4380 quilt_fixup_mkwork($headref);
4381 if ($cachehit ne $headref) {
4382 progress "dgit view: found cached (commit id $cachehit)";
4383 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4385 return ($cachehit, $splitbrain_cachekey);
4387 progress "dgit view: found cached, no changes required";
4388 return ($headref, $splitbrain_cachekey);
4390 die $! if GC->error;
4391 failedcmd unless close GC;
4393 printdebug "splitbrain cache miss\n";
4394 return (undef, $splitbrain_cachekey);
4397 sub quilt_fixup_multipatch ($$$) {
4398 my ($clogp, $headref, $upstreamversion) = @_;
4400 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4403 # - honour any existing .pc in case it has any strangeness
4404 # - determine the git commit corresponding to the tip of
4405 # the patch stack (if there is one)
4406 # - if there is such a git commit, convert each subsequent
4407 # git commit into a quilt patch with dpkg-source --commit
4408 # - otherwise convert all the differences in the tree into
4409 # a single git commit
4413 # Our git tree doesn't necessarily contain .pc. (Some versions of
4414 # dgit would include the .pc in the git tree.) If there isn't
4415 # one, we need to generate one by unpacking the patches that we
4418 # We first look for a .pc in the git tree. If there is one, we
4419 # will use it. (This is not the normal case.)
4421 # Otherwise need to regenerate .pc so that dpkg-source --commit
4422 # can work. We do this as follows:
4423 # 1. Collect all relevant .orig from parent directory
4424 # 2. Generate a debian.tar.gz out of
4425 # debian/{patches,rules,source/format,source/options}
4426 # 3. Generate a fake .dsc containing just these fields:
4427 # Format Source Version Files
4428 # 4. Extract the fake .dsc
4429 # Now the fake .dsc has a .pc directory.
4430 # (In fact we do this in every case, because in future we will
4431 # want to search for a good base commit for generating patches.)
4433 # Then we can actually do the dpkg-source --commit
4434 # 1. Make a new working tree with the same object
4435 # store as our main tree and check out the main
4437 # 2. Copy .pc from the fake's extraction, if necessary
4438 # 3. Run dpkg-source --commit
4439 # 4. If the result has changes to debian/, then
4440 # - git-add them them
4441 # - git-add .pc if we had a .pc in-tree
4443 # 5. If we had a .pc in-tree, delete it, and git-commit
4444 # 6. Back in the main tree, fast forward to the new HEAD
4446 # Another situation we may have to cope with is gbp-style
4447 # patches-unapplied trees.
4449 # We would want to detect these, so we know to escape into
4450 # quilt_fixup_gbp. However, this is in general not possible.
4451 # Consider a package with a one patch which the dgit user reverts
4452 # (with git-revert or the moral equivalent).
4454 # That is indistinguishable in contents from a patches-unapplied
4455 # tree. And looking at the history to distinguish them is not
4456 # useful because the user might have made a confusing-looking git
4457 # history structure (which ought to produce an error if dgit can't
4458 # cope, not a silent reintroduction of an unwanted patch).
4460 # So gbp users will have to pass an option. But we can usually
4461 # detect their failure to do so: if the tree is not a clean
4462 # patches-applied tree, quilt linearisation fails, but the tree
4463 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4464 # they want --quilt=unapplied.
4466 # To help detect this, when we are extracting the fake dsc, we
4467 # first extract it with --skip-patches, and then apply the patches
4468 # afterwards with dpkg-source --before-build. That lets us save a
4469 # tree object corresponding to .origs.
4471 my $splitbrain_cachekey;
4473 quilt_make_fake_dsc($upstreamversion);
4475 if (quiltmode_splitbrain()) {
4477 ($cachehit, $splitbrain_cachekey) =
4478 quilt_check_splitbrain_cache($headref, $upstreamversion);
4479 return if $cachehit;
4483 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4485 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4486 rename $fakexdir, "fake" or die "$fakexdir $!";
4490 remove_stray_gits();
4491 mktree_in_ud_here();
4495 runcmd @git, qw(add -Af .);
4496 my $unapplied=git_write_tree();
4497 printdebug "fake orig tree object $unapplied\n";
4501 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4503 if (system @bbcmd) {
4504 failedcmd @bbcmd if $? < 0;
4506 failed to apply your git tree's patch stack (from debian/patches/) to
4507 the corresponding upstream tarball(s). Your source tree and .orig
4508 are probably too inconsistent. dgit can only fix up certain kinds of
4509 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4515 quilt_fixup_mkwork($headref);
4518 if (stat_exists ".pc") {
4520 progress "Tree already contains .pc - will use it then delete it.";
4523 rename '../fake/.pc','.pc' or die $!;
4526 changedir '../fake';
4528 runcmd @git, qw(add -Af .);
4529 my $oldtiptree=git_write_tree();
4530 printdebug "fake o+d/p tree object $unapplied\n";
4531 changedir '../work';
4534 # We calculate some guesswork now about what kind of tree this might
4535 # be. This is mostly for error reporting.
4541 # O = orig, without patches applied
4542 # A = "applied", ie orig with H's debian/patches applied
4543 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4544 \%editedignores, \@unrepres),
4545 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4546 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4550 foreach my $b (qw(01 02)) {
4551 foreach my $v (qw(O2H O2A H2A)) {
4552 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4555 printdebug "differences \@dl @dl.\n";
4558 "$us: base trees orig=%.20s o+d/p=%.20s",
4559 $unapplied, $oldtiptree;
4561 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4562 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4563 $dl[0], $dl[1], $dl[3], $dl[4],
4567 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4570 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4575 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4576 push @failsuggestion, "This might be a patches-unapplied branch.";
4577 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4578 push @failsuggestion, "This might be a patches-applied branch.";
4580 push @failsuggestion, "Maybe you need to specify one of".
4581 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4583 if (quiltmode_splitbrain()) {
4584 quiltify_splitbrain($clogp, $unapplied, $headref,
4585 $diffbits, \%editedignores,
4586 $splitbrain_cachekey);
4590 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4591 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4593 if (!open P, '>>', ".pc/applied-patches") {
4594 $!==&ENOENT or die $!;
4599 commit_quilty_patch();
4601 if ($mustdeletepc) {
4602 quilt_fixup_delete_pc();
4606 sub quilt_fixup_editor () {
4607 my $descfn = $ENV{$fakeeditorenv};
4608 my $editing = $ARGV[$#ARGV];
4609 open I1, '<', $descfn or die "$descfn: $!";
4610 open I2, '<', $editing or die "$editing: $!";
4611 unlink $editing or die "$editing: $!";
4612 open O, '>', $editing or die "$editing: $!";
4613 while (<I1>) { print O or die $!; } I1->error and die $!;
4616 $copying ||= m/^\-\-\- /;
4617 next unless $copying;
4620 I2->error and die $!;
4625 sub maybe_apply_patches_dirtily () {
4626 return unless $quilt_mode =~ m/gbp|unapplied/;
4627 print STDERR <<END or die $!;
4629 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4630 dgit: Have to apply the patches - making the tree dirty.
4631 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4634 $patches_applied_dirtily = 01;
4635 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4636 runcmd qw(dpkg-source --before-build .);
4639 sub maybe_unapply_patches_again () {
4640 progress "dgit: Unapplying patches again to tidy up the tree."
4641 if $patches_applied_dirtily;
4642 runcmd qw(dpkg-source --after-build .)
4643 if $patches_applied_dirtily & 01;
4645 if $patches_applied_dirtily & 02;
4646 $patches_applied_dirtily = 0;
4649 #----- other building -----
4651 our $clean_using_builder;
4652 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4653 # clean the tree before building (perhaps invoked indirectly by
4654 # whatever we are using to run the build), rather than separately
4655 # and explicitly by us.
4658 return if $clean_using_builder;
4659 if ($cleanmode eq 'dpkg-source') {
4660 maybe_apply_patches_dirtily();
4661 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4662 } elsif ($cleanmode eq 'dpkg-source-d') {
4663 maybe_apply_patches_dirtily();
4664 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4665 } elsif ($cleanmode eq 'git') {
4666 runcmd_ordryrun_local @git, qw(clean -xdf);
4667 } elsif ($cleanmode eq 'git-ff') {
4668 runcmd_ordryrun_local @git, qw(clean -xdff);
4669 } elsif ($cleanmode eq 'check') {
4670 my $leftovers = cmdoutput @git, qw(clean -xdn);
4671 if (length $leftovers) {
4672 print STDERR $leftovers, "\n" or die $!;
4673 fail "tree contains uncommitted files and --clean=check specified";
4675 } elsif ($cleanmode eq 'none') {
4682 badusage "clean takes no additional arguments" if @ARGV;
4685 maybe_unapply_patches_again();
4690 badusage "-p is not allowed when building" if defined $package;
4693 my $clogp = parsechangelog();
4694 $isuite = getfield $clogp, 'Distribution';
4695 $package = getfield $clogp, 'Source';
4696 $version = getfield $clogp, 'Version';
4697 build_maybe_quilt_fixup();
4699 my $pat = changespat $version;
4700 foreach my $f (glob "$buildproductsdir/$pat") {
4702 unlink $f or fail "remove old changes file $f: $!";
4704 progress "would remove $f";
4710 sub changesopts_initial () {
4711 my @opts =@changesopts[1..$#changesopts];
4714 sub changesopts_version () {
4715 if (!defined $changes_since_version) {
4716 my @vsns = archive_query('archive_query');
4717 my @quirk = access_quirk();
4718 if ($quirk[0] eq 'backports') {
4719 local $isuite = $quirk[2];
4721 canonicalise_suite();
4722 push @vsns, archive_query('archive_query');
4725 @vsns = map { $_->[0] } @vsns;
4726 @vsns = sort { -version_compare($a, $b) } @vsns;
4727 $changes_since_version = $vsns[0];
4728 progress "changelog will contain changes since $vsns[0]";
4730 $changes_since_version = '_';
4731 progress "package seems new, not specifying -v<version>";
4734 if ($changes_since_version ne '_') {
4735 return ("-v$changes_since_version");
4741 sub changesopts () {
4742 return (changesopts_initial(), changesopts_version());
4745 sub massage_dbp_args ($;$) {
4746 my ($cmd,$xargs) = @_;
4749 # - if we're going to split the source build out so we can
4750 # do strange things to it, massage the arguments to dpkg-buildpackage
4751 # so that the main build doessn't build source (or add an argument
4752 # to stop it building source by default).
4754 # - add -nc to stop dpkg-source cleaning the source tree,
4755 # unless we're not doing a split build and want dpkg-source
4756 # as cleanmode, in which case we can do nothing
4759 # 0 - source will NOT need to be built separately by caller
4760 # +1 - source will need to be built separately by caller
4761 # +2 - source will need to be built separately by caller AND
4762 # dpkg-buildpackage should not in fact be run at all!
4763 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4764 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4765 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4766 $clean_using_builder = 1;
4769 # -nc has the side effect of specifying -b if nothing else specified
4770 # and some combinations of -S, -b, et al, are errors, rather than
4771 # later simply overriding earlie. So we need to:
4772 # - search the command line for these options
4773 # - pick the last one
4774 # - perhaps add our own as a default
4775 # - perhaps adjust it to the corresponding non-source-building version
4777 foreach my $l ($cmd, $xargs) {
4779 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4782 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4784 if ($need_split_build_invocation) {
4785 printdebug "massage split $dmode.\n";
4786 $r = $dmode =~ m/[S]/ ? +2 :
4787 $dmode =~ y/gGF/ABb/ ? +1 :
4788 $dmode =~ m/[ABb]/ ? 0 :
4791 printdebug "massage done $r $dmode.\n";
4793 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4798 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4799 my $wantsrc = massage_dbp_args \@dbp;
4806 push @dbp, changesopts_version();
4807 maybe_apply_patches_dirtily();
4808 runcmd_ordryrun_local @dbp;
4810 maybe_unapply_patches_again();
4811 printdone "build successful\n";
4815 $quilt_mode //= 'gbp';
4819 my @dbp = @dpkgbuildpackage;
4821 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4823 if (!length $gbp_build[0]) {
4824 if (length executable_on_path('git-buildpackage')) {
4825 $gbp_build[0] = qw(git-buildpackage);
4827 $gbp_build[0] = 'gbp buildpackage';
4830 my @cmd = opts_opt_multi_cmd @gbp_build;
4832 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4837 if (!$clean_using_builder) {
4838 push @cmd, '--git-cleaner=true';
4842 maybe_unapply_patches_again();
4844 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4845 canonicalise_suite();
4846 push @cmd, "--git-debian-branch=".lbranch();
4848 push @cmd, changesopts();
4849 runcmd_ordryrun_local @cmd, @ARGV;
4851 printdone "build successful\n";
4853 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4856 my $our_cleanmode = $cleanmode;
4857 if ($need_split_build_invocation) {
4858 # Pretend that clean is being done some other way. This
4859 # forces us not to try to use dpkg-buildpackage to clean and
4860 # build source all in one go; and instead we run dpkg-source
4861 # (and build_prep() will do the clean since $clean_using_builder
4863 $our_cleanmode = 'ELSEWHERE';
4865 if ($our_cleanmode =~ m/^dpkg-source/) {
4866 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4867 $clean_using_builder = 1;
4870 $sourcechanges = changespat $version,'source';
4872 unlink "../$sourcechanges" or $!==ENOENT
4873 or fail "remove $sourcechanges: $!";
4875 $dscfn = dscfn($version);
4876 if ($our_cleanmode eq 'dpkg-source') {
4877 maybe_apply_patches_dirtily();
4878 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4880 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4881 maybe_apply_patches_dirtily();
4882 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4885 my @cmd = (@dpkgsource, qw(-b --));
4888 runcmd_ordryrun_local @cmd, "work";
4889 my @udfiles = <${package}_*>;
4890 changedir "../../..";
4891 foreach my $f (@udfiles) {
4892 printdebug "source copy, found $f\n";
4895 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4896 $f eq srcfn($version, $&));
4897 printdebug "source copy, found $f - renaming\n";
4898 rename "$ud/$f", "../$f" or $!==ENOENT
4899 or fail "put in place new source file ($f): $!";
4902 my $pwd = must_getcwd();
4903 my $leafdir = basename $pwd;
4905 runcmd_ordryrun_local @cmd, $leafdir;
4908 runcmd_ordryrun_local qw(sh -ec),
4909 'exec >$1; shift; exec "$@"','x',
4910 "../$sourcechanges",
4911 @dpkggenchanges, qw(-S), changesopts();
4915 sub cmd_build_source {
4916 badusage "build-source takes no additional arguments" if @ARGV;
4918 maybe_unapply_patches_again();
4919 printdone "source built, results in $dscfn and $sourcechanges";
4924 my $pat = changespat $version;
4926 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4927 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4928 fail "changes files other than source matching $pat".
4929 " already present (@unwanted);".
4930 " building would result in ambiguity about the intended results"
4933 my $wasdir = must_getcwd();
4936 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4937 stat_exists $sourcechanges
4938 or fail "$sourcechanges (in parent directory): $!";
4940 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4941 my @changesfiles = glob $pat;
4942 @changesfiles = sort {
4943 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4946 fail "wrong number of different changes files (@changesfiles)"
4947 unless @changesfiles==2;
4948 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4949 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4950 fail "$l found in binaries changes file $binchanges"
4953 runcmd_ordryrun_local @mergechanges, @changesfiles;
4954 my $multichanges = changespat $version,'multi';
4956 stat_exists $multichanges or fail "$multichanges: $!";
4957 foreach my $cf (glob $pat) {
4958 next if $cf eq $multichanges;
4959 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4963 maybe_unapply_patches_again();
4964 printdone "build successful, results in $multichanges\n" or die $!;
4967 sub cmd_quilt_fixup {
4968 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4969 my $clogp = parsechangelog();
4970 $version = getfield $clogp, 'Version';
4971 $package = getfield $clogp, 'Source';
4974 build_maybe_quilt_fixup();
4977 sub cmd_archive_api_query {
4978 badusage "need only 1 subpath argument" unless @ARGV==1;
4979 my ($subpath) = @ARGV;
4980 my @cmd = archive_api_query_cmd($subpath);
4982 exec @cmd or fail "exec curl: $!\n";
4985 sub cmd_clone_dgit_repos_server {
4986 badusage "need destination argument" unless @ARGV==1;
4987 my ($destdir) = @ARGV;
4988 $package = '_dgit-repos-server';
4989 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4991 exec @cmd or fail "exec git clone: $!\n";
4994 sub cmd_setup_mergechangelogs {
4995 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4996 setup_mergechangelogs(1);
4999 sub cmd_setup_useremail {
5000 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5004 sub cmd_setup_new_tree {
5005 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5009 #---------- argument parsing and main program ----------
5012 print "dgit version $our_version\n" or die $!;
5016 our (%valopts_long, %valopts_short);
5019 sub defvalopt ($$$$) {
5020 my ($long,$short,$val_re,$how) = @_;
5021 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5022 $valopts_long{$long} = $oi;
5023 $valopts_short{$short} = $oi;
5024 # $how subref should:
5025 # do whatever assignemnt or thing it likes with $_[0]
5026 # if the option should not be passed on to remote, @rvalopts=()
5027 # or $how can be a scalar ref, meaning simply assign the value
5030 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5031 defvalopt '--distro', '-d', '.+', \$idistro;
5032 defvalopt '', '-k', '.+', \$keyid;
5033 defvalopt '--existing-package','', '.*', \$existing_package;
5034 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5035 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5036 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5038 defvalopt '', '-C', '.+', sub {
5039 ($changesfile) = (@_);
5040 if ($changesfile =~ s#^(.*)/##) {
5041 $buildproductsdir = $1;
5045 defvalopt '--initiator-tempdir','','.*', sub {
5046 ($initiator_tempdir) = (@_);
5047 $initiator_tempdir =~ m#^/# or
5048 badusage "--initiator-tempdir must be used specify an".
5049 " absolute, not relative, directory."
5055 if (defined $ENV{'DGIT_SSH'}) {
5056 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5057 } elsif (defined $ENV{'GIT_SSH'}) {
5058 @ssh = ($ENV{'GIT_SSH'});
5066 if (!defined $val) {
5067 badusage "$what needs a value" unless @ARGV;
5069 push @rvalopts, $val;
5071 badusage "bad value \`$val' for $what" unless
5072 $val =~ m/^$oi->{Re}$(?!\n)/s;
5073 my $how = $oi->{How};
5074 if (ref($how) eq 'SCALAR') {
5079 push @ropts, @rvalopts;
5083 last unless $ARGV[0] =~ m/^-/;
5087 if (m/^--dry-run$/) {
5090 } elsif (m/^--damp-run$/) {
5093 } elsif (m/^--no-sign$/) {
5096 } elsif (m/^--help$/) {
5098 } elsif (m/^--version$/) {
5100 } elsif (m/^--new$/) {
5103 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5104 ($om = $opts_opt_map{$1}) &&
5108 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5109 !$opts_opt_cmdonly{$1} &&
5110 ($om = $opts_opt_map{$1})) {
5113 } elsif (m/^--ignore-dirty$/s) {
5116 } elsif (m/^--no-quilt-fixup$/s) {
5118 $quilt_mode = 'nocheck';
5119 } elsif (m/^--no-rm-on-error$/s) {
5122 } elsif (m/^--overwrite$/s) {
5124 $overwrite_version = '';
5125 } elsif (m/^--overwrite=(.+)$/s) {
5127 $overwrite_version = $1;
5128 } elsif (m/^--(no-)?rm-old-changes$/s) {
5131 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5133 push @deliberatelies, $&;
5134 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5135 # undocumented, for testing
5137 $tagformat_want = [ $1, 'command line', 1 ];
5138 # 1 menas overrides distro configuration
5139 } elsif (m/^--always-split-source-build$/s) {
5140 # undocumented, for testing
5142 $need_split_build_invocation = 1;
5143 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5144 $val = $2 ? $' : undef; #';
5145 $valopt->($oi->{Long});
5147 badusage "unknown long option \`$_'";
5154 } elsif (s/^-L/-/) {
5157 } elsif (s/^-h/-/) {
5159 } elsif (s/^-D/-/) {
5163 } elsif (s/^-N/-/) {
5168 push @changesopts, $_;
5170 } elsif (s/^-wn$//s) {
5172 $cleanmode = 'none';
5173 } elsif (s/^-wg$//s) {
5176 } elsif (s/^-wgf$//s) {
5178 $cleanmode = 'git-ff';
5179 } elsif (s/^-wd$//s) {
5181 $cleanmode = 'dpkg-source';
5182 } elsif (s/^-wdd$//s) {
5184 $cleanmode = 'dpkg-source-d';
5185 } elsif (s/^-wc$//s) {
5187 $cleanmode = 'check';
5188 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5189 push @git, '-c', $&;
5190 $gitcfgs{cmdline}{$1} = [ $2 ];
5191 } elsif (s/^-c([^=]+)$//s) {
5192 push @git, '-c', $&;
5193 $gitcfgs{cmdline}{$1} = [ 'true' ];
5194 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5196 $val = undef unless length $val;
5197 $valopt->($oi->{Short});
5200 badusage "unknown short option \`$_'";
5207 sub finalise_opts_opts () {
5208 foreach my $k (keys %opts_opt_map) {
5209 my $om = $opts_opt_map{$k};
5211 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5213 badcfg "cannot set command for $k"
5214 unless length $om->[0];
5218 foreach my $c (access_cfg_cfgs("opts-$k")) {
5220 map { $_ ? @$_ : () }
5221 map { $gitcfgs{$_}{$c} }
5222 reverse @gitcfgsources;
5223 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5224 "\n" if $debuglevel >= 4;
5226 badcfg "cannot configure options for $k"
5227 if $opts_opt_cmdonly{$k};
5228 my $insertpos = $opts_cfg_insertpos{$k};
5229 @$om = ( @$om[0..$insertpos-1],
5231 @$om[$insertpos..$#$om] );
5236 if ($ENV{$fakeeditorenv}) {
5238 quilt_fixup_editor();
5244 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5245 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5246 if $dryrun_level == 1;
5248 print STDERR $helpmsg or die $!;
5251 my $cmd = shift @ARGV;
5254 my $pre_fn = ${*::}{"pre_$cmd"};
5255 $pre_fn->() if $pre_fn;
5257 if (!defined $rmchanges) {
5258 local $access_forpush;
5259 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5262 if (!defined $quilt_mode) {
5263 local $access_forpush;
5264 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5265 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5267 $quilt_mode =~ m/^($quilt_modes_re)$/
5268 or badcfg "unknown quilt-mode \`$quilt_mode'";
5272 $need_split_build_invocation ||= quiltmode_splitbrain();
5274 if (!defined $cleanmode) {
5275 local $access_forpush;
5276 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5277 $cleanmode //= 'dpkg-source';
5279 badcfg "unknown clean-mode \`$cleanmode'" unless
5280 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5283 my $fn = ${*::}{"cmd_$cmd"};
5284 $fn or badusage "unknown operation $cmd";