3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 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 @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3215 debugcmd "+",@diffcmd;
3217 my $r = system @diffcmd;
3220 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3222 HEAD specifies a different tree to $dscfn:
3224 Perhaps you forgot to build. Or perhaps there is a problem with your
3225 source tree (see dgit(7) for some hints). To see a full diff, run
3232 if (!$changesfile) {
3233 my $pat = changespat $cversion;
3234 my @cs = glob "$buildproductsdir/$pat";
3235 fail "failed to find unique changes file".
3236 " (looked for $pat in $buildproductsdir);".
3237 " perhaps you need to use dgit -C"
3239 ($changesfile) = @cs;
3241 $changesfile = "$buildproductsdir/$changesfile";
3244 # Check that changes and .dsc agree enough
3245 $changesfile =~ m{[^/]*$};
3246 files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3248 # Checks complete, we're going to try and go ahead:
3250 responder_send_file('changes',$changesfile);
3251 responder_send_command("param head $dgithead");
3252 responder_send_command("param csuite $csuite");
3253 responder_send_command("param tagformat $tagformat");
3254 if (defined $maintviewhead) {
3255 die unless ($protovsn//4) >= 4;
3256 responder_send_command("param maint-view $maintviewhead");
3259 if (deliberately_not_fast_forward) {
3260 git_for_each_ref(lrfetchrefs, sub {
3261 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3262 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3263 responder_send_command("previously $rrefname=$objid");
3264 $previously{$rrefname} = $objid;
3268 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3272 supplementary_message(<<'END');
3273 Push failed, while signing the tag.
3274 You can retry the push, after fixing the problem, if you like.
3276 # If we manage to sign but fail to record it anywhere, it's fine.
3277 if ($we_are_responder) {
3278 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3279 responder_receive_files('signed-tag', @tagobjfns);
3281 @tagobjfns = push_mktags($clogp,$dscpath,
3282 $changesfile,$changesfile,
3285 supplementary_message(<<'END');
3286 Push failed, *after* signing the tag.
3287 If you want to try again, you should use a new version number.
3290 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3292 foreach my $tw (@tagwants) {
3293 my $tag = $tw->{Tag};
3294 my $tagobjfn = $tw->{TagObjFn};
3296 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3297 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3298 runcmd_ordryrun_local
3299 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3302 supplementary_message(<<'END');
3303 Push failed, while updating the remote git repository - see messages above.
3304 If you want to try again, you should use a new version number.
3306 if (!check_for_git()) {
3307 create_remote_git_repo();
3310 my @pushrefs = $forceflag.$dgithead.":".rrref();
3311 foreach my $tw (@tagwants) {
3312 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3315 runcmd_ordryrun @git,
3316 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3317 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3319 supplementary_message(<<'END');
3320 Push failed, after updating the remote git repository.
3321 If you want to try again, you must use a new version number.
3323 if ($we_are_responder) {
3324 my $dryrunsuffix = act_local() ? "" : ".tmp";
3325 responder_receive_files('signed-dsc-changes',
3326 "$dscpath$dryrunsuffix",
3327 "$changesfile$dryrunsuffix");
3330 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3332 progress "[new .dsc left in $dscpath.tmp]";
3334 sign_changes $changesfile;
3337 supplementary_message(<<END);
3338 Push failed, while uploading package(s) to the archive server.
3339 You can retry the upload of exactly these same files with dput of:
3341 If that .changes file is broken, you will need to use a new version
3342 number for your next attempt at the upload.
3344 my $host = access_cfg('upload-host','RETURN-UNDEF');
3345 my @hostarg = defined($host) ? ($host,) : ();
3346 runcmd_ordryrun @dput, @hostarg, $changesfile;
3347 printdone "pushed and uploaded $cversion";
3349 supplementary_message('');
3350 responder_send_command("complete");
3357 badusage "-p is not allowed with clone; specify as argument instead"
3358 if defined $package;
3361 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3362 ($package,$isuite) = @ARGV;
3363 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3364 ($package,$dstdir) = @ARGV;
3365 } elsif (@ARGV==3) {
3366 ($package,$isuite,$dstdir) = @ARGV;
3368 badusage "incorrect arguments to dgit clone";
3370 $dstdir ||= "$package";
3372 if (stat_exists $dstdir) {
3373 fail "$dstdir already exists";
3377 if ($rmonerror && !$dryrun_level) {
3378 $cwd_remove= getcwd();
3380 return unless defined $cwd_remove;
3381 if (!chdir "$cwd_remove") {
3382 return if $!==&ENOENT;
3383 die "chdir $cwd_remove: $!";
3386 rmtree($dstdir) or die "remove $dstdir: $!\n";
3387 } elsif (grep { $! == $_ }
3388 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3390 print STDERR "check whether to remove $dstdir: $!\n";
3396 $cwd_remove = undef;
3399 sub branchsuite () {
3400 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3401 if ($branch =~ m#$lbranch_re#o) {
3408 sub fetchpullargs () {
3410 if (!defined $package) {
3411 my $sourcep = parsecontrol('debian/control','debian/control');
3412 $package = getfield $sourcep, 'Source';
3415 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3417 my $clogp = parsechangelog();
3418 $isuite = getfield $clogp, 'Distribution';
3420 canonicalise_suite();
3421 progress "fetching from suite $csuite";
3422 } elsif (@ARGV==1) {
3424 canonicalise_suite();
3426 badusage "incorrect arguments to dgit fetch or dgit pull";
3445 badusage "-p is not allowed with dgit push" if defined $package;
3447 my $clogp = parsechangelog();
3448 $package = getfield $clogp, 'Source';
3451 } elsif (@ARGV==1) {
3452 ($specsuite) = (@ARGV);
3454 badusage "incorrect arguments to dgit push";
3456 $isuite = getfield $clogp, 'Distribution';
3458 local ($package) = $existing_package; # this is a hack
3459 canonicalise_suite();
3461 canonicalise_suite();
3463 if (defined $specsuite &&
3464 $specsuite ne $isuite &&
3465 $specsuite ne $csuite) {
3466 fail "dgit push: changelog specifies $isuite ($csuite)".
3467 " but command line specifies $specsuite";
3472 #---------- remote commands' implementation ----------
3474 sub cmd_remote_push_build_host {
3475 my ($nrargs) = shift @ARGV;
3476 my (@rargs) = @ARGV[0..$nrargs-1];
3477 @ARGV = @ARGV[$nrargs..$#ARGV];
3479 my ($dir,$vsnwant) = @rargs;
3480 # vsnwant is a comma-separated list; we report which we have
3481 # chosen in our ready response (so other end can tell if they
3484 $we_are_responder = 1;
3485 $us .= " (build host)";
3489 open PI, "<&STDIN" or die $!;
3490 open STDIN, "/dev/null" or die $!;
3491 open PO, ">&STDOUT" or die $!;
3493 open STDOUT, ">&STDERR" or die $!;
3497 ($protovsn) = grep {
3498 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3499 } @rpushprotovsn_support;
3501 fail "build host has dgit rpush protocol versions ".
3502 (join ",", @rpushprotovsn_support).
3503 " but invocation host has $vsnwant"
3504 unless defined $protovsn;
3506 responder_send_command("dgit-remote-push-ready $protovsn");
3507 rpush_handle_protovsn_bothends();
3512 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3513 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3514 # a good error message)
3516 sub rpush_handle_protovsn_bothends () {
3517 if ($protovsn < 4) {
3518 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3527 my $report = i_child_report();
3528 if (defined $report) {
3529 printdebug "($report)\n";
3530 } elsif ($i_child_pid) {
3531 printdebug "(killing build host child $i_child_pid)\n";
3532 kill 15, $i_child_pid;
3534 if (defined $i_tmp && !defined $initiator_tempdir) {
3536 eval { rmtree $i_tmp; };
3540 END { i_cleanup(); }
3543 my ($base,$selector,@args) = @_;
3544 $selector =~ s/\-/_/g;
3545 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3552 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3560 push @rargs, join ",", @rpushprotovsn_support;
3563 push @rdgit, @ropts;
3564 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3566 my @cmd = (@ssh, $host, shellquote @rdgit);
3569 if (defined $initiator_tempdir) {
3570 rmtree $initiator_tempdir;
3571 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3572 $i_tmp = $initiator_tempdir;
3576 $i_child_pid = open2(\*RO, \*RI, @cmd);
3578 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3579 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3580 $supplementary_message = '' unless $protovsn >= 3;
3582 fail "rpush negotiated protocol version $protovsn".
3583 " which does not support quilt mode $quilt_mode"
3584 if quiltmode_splitbrain;
3586 rpush_handle_protovsn_bothends();
3588 my ($icmd,$iargs) = initiator_expect {
3589 m/^(\S+)(?: (.*))?$/;
3592 i_method "i_resp", $icmd, $iargs;
3596 sub i_resp_progress ($) {
3598 my $msg = protocol_read_bytes \*RO, $rhs;
3602 sub i_resp_supplementary_message ($) {
3604 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3607 sub i_resp_complete {
3608 my $pid = $i_child_pid;
3609 $i_child_pid = undef; # prevents killing some other process with same pid
3610 printdebug "waiting for build host child $pid...\n";
3611 my $got = waitpid $pid, 0;
3612 die $! unless $got == $pid;
3613 die "build host child failed $?" if $?;
3616 printdebug "all done\n";
3620 sub i_resp_file ($) {
3622 my $localname = i_method "i_localname", $keyword;
3623 my $localpath = "$i_tmp/$localname";
3624 stat_exists $localpath and
3625 badproto \*RO, "file $keyword ($localpath) twice";
3626 protocol_receive_file \*RO, $localpath;
3627 i_method "i_file", $keyword;
3632 sub i_resp_param ($) {
3633 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3637 sub i_resp_previously ($) {
3638 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3639 or badproto \*RO, "bad previously spec";
3640 my $r = system qw(git check-ref-format), $1;
3641 die "bad previously ref spec ($r)" if $r;
3642 $previously{$1} = $2;
3647 sub i_resp_want ($) {
3649 die "$keyword ?" if $i_wanted{$keyword}++;
3650 my @localpaths = i_method "i_want", $keyword;
3651 printdebug "[[ $keyword @localpaths\n";
3652 foreach my $localpath (@localpaths) {
3653 protocol_send_file \*RI, $localpath;
3655 print RI "files-end\n" or die $!;
3658 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3660 sub i_localname_parsed_changelog {
3661 return "remote-changelog.822";
3663 sub i_file_parsed_changelog {
3664 ($i_clogp, $i_version, $i_dscfn) =
3665 push_parse_changelog "$i_tmp/remote-changelog.822";
3666 die if $i_dscfn =~ m#/|^\W#;
3669 sub i_localname_dsc {
3670 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3675 sub i_localname_changes {
3676 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3677 $i_changesfn = $i_dscfn;
3678 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3679 return $i_changesfn;
3681 sub i_file_changes { }
3683 sub i_want_signed_tag {
3684 printdebug Dumper(\%i_param, $i_dscfn);
3685 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3686 && defined $i_param{'csuite'}
3687 or badproto \*RO, "premature desire for signed-tag";
3688 my $head = $i_param{'head'};
3689 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3691 my $maintview = $i_param{'maint-view'};
3692 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3695 if ($protovsn >= 4) {
3696 my $p = $i_param{'tagformat'} // '<undef>';
3698 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3701 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3703 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3705 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3708 push_mktags $i_clogp, $i_dscfn,
3709 $i_changesfn, 'remote changes',
3713 sub i_want_signed_dsc_changes {
3714 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3715 sign_changes $i_changesfn;
3716 return ($i_dscfn, $i_changesfn);
3719 #---------- building etc. ----------
3725 #----- `3.0 (quilt)' handling -----
3727 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3729 sub quiltify_dpkg_commit ($$$;$) {
3730 my ($patchname,$author,$msg, $xinfo) = @_;
3734 my $descfn = ".git/dgit/quilt-description.tmp";
3735 open O, '>', $descfn or die "$descfn: $!";
3736 $msg =~ s/\n+/\n\n/;
3737 print O <<END or die $!;
3739 ${xinfo}Subject: $msg
3746 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3747 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3748 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3749 runcmd @dpkgsource, qw(--commit .), $patchname;
3753 sub quiltify_trees_differ ($$;$$$) {
3754 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3755 # returns true iff the two tree objects differ other than in debian/
3756 # with $finegrained,
3757 # returns bitmask 01 - differ in upstream files except .gitignore
3758 # 02 - differ in .gitignore
3759 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3760 # is set for each modified .gitignore filename $fn
3761 # if $unrepres is defined, array ref to which is appeneded
3762 # a list of unrepresentable changes (removals of upstream files
3765 my @cmd = (@git, qw(diff-tree -z));
3766 push @cmd, qw(--name-only) unless $unrepres;
3767 push @cmd, qw(-r) if $finegrained || $unrepres;
3769 my $diffs= cmdoutput @cmd;
3772 foreach my $f (split /\0/, $diffs) {
3773 if ($unrepres && !@lmodes) {
3774 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3777 my ($oldmode,$newmode) = @lmodes;
3780 next if $f =~ m#^debian(?:/.*)?$#s;
3784 die "deleted\n" unless $newmode =~ m/[^0]/;
3785 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3786 if ($oldmode =~ m/[^0]/) {
3787 die "mode changed\n" if $oldmode ne $newmode;
3789 die "non-default mode\n" unless $newmode =~ m/^100644$/;
3793 local $/="\n"; chomp $@;
3794 push @$unrepres, [ $f, $@ ];
3798 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3799 $r |= $isignore ? 02 : 01;
3800 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3802 printdebug "quiltify_trees_differ $x $y => $r\n";
3806 sub quiltify_tree_sentinelfiles ($) {
3807 # lists the `sentinel' files present in the tree
3809 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3810 qw(-- debian/rules debian/control);
3815 sub quiltify_splitbrain_needed () {
3816 if (!$split_brain) {
3817 progress "dgit view: changes are required...";
3818 runcmd @git, qw(checkout -q -b dgit-view);
3823 sub quiltify_splitbrain ($$$$$$) {
3824 my ($clogp, $unapplied, $headref, $diffbits,
3825 $editedignores, $cachekey) = @_;
3826 if ($quilt_mode !~ m/gbp|dpm/) {
3827 # treat .gitignore just like any other upstream file
3828 $diffbits = { %$diffbits };
3829 $_ = !!$_ foreach values %$diffbits;
3831 # We would like any commits we generate to be reproducible
3832 my @authline = clogp_authline($clogp);
3833 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3834 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3835 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3836 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3837 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3838 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3840 if ($quilt_mode =~ m/gbp|unapplied/ &&
3841 ($diffbits->{O2H} & 01)) {
3843 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3844 " but git tree differs from orig in upstream files.";
3845 if (!stat_exists "debian/patches") {
3847 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3851 if ($quilt_mode =~ m/dpm/ &&
3852 ($diffbits->{H2A} & 01)) {
3854 --quilt=$quilt_mode specified, implying patches-applied git tree
3855 but git tree differs from result of applying debian/patches to upstream
3858 if ($quilt_mode =~ m/gbp|unapplied/ &&
3859 ($diffbits->{O2A} & 01)) { # some patches
3860 quiltify_splitbrain_needed();
3861 progress "dgit view: creating patches-applied version using gbp pq";
3862 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3863 # gbp pq import creates a fresh branch; push back to dgit-view
3864 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3865 runcmd @git, qw(checkout -q dgit-view);
3867 if ($quilt_mode =~ m/gbp|dpm/ &&
3868 ($diffbits->{O2A} & 02)) {
3870 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3871 tool which does not create patches for changes to upstream
3872 .gitignores: but, such patches exist in debian/patches.
3875 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3876 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3877 quiltify_splitbrain_needed();
3878 progress "dgit view: creating patch to represent .gitignore changes";
3879 ensuredir "debian/patches";
3880 my $gipatch = "debian/patches/auto-gitignore";
3881 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3882 stat GIPATCH or die "$gipatch: $!";
3883 fail "$gipatch already exists; but want to create it".
3884 " to record .gitignore changes" if (stat _)[7];
3885 print GIPATCH <<END or die "$gipatch: $!";
3886 Subject: Update .gitignore from Debian packaging branch
3888 The Debian packaging git branch contains these updates to the upstream
3889 .gitignore file(s). This patch is autogenerated, to provide these
3890 updates to users of the official Debian archive view of the package.
3892 [dgit ($our_version) update-gitignore]
3895 close GIPATCH or die "$gipatch: $!";
3896 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3897 $unapplied, $headref, "--", sort keys %$editedignores;
3898 open SERIES, "+>>", "debian/patches/series" or die $!;
3899 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3901 defined read SERIES, $newline, 1 or die $!;
3902 print SERIES "\n" or die $! unless $newline eq "\n";
3903 print SERIES "auto-gitignore\n" or die $!;
3904 close SERIES or die $!;
3905 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3907 Commit patch to update .gitignore
3909 [dgit ($our_version) update-gitignore-quilt-fixup]
3913 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3915 changedir '../../../..';
3916 ensuredir ".git/logs/refs/dgit-intern";
3917 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3919 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3922 progress "dgit view: created (commit id $dgitview)";
3924 changedir '.git/dgit/unpack/work';
3927 sub quiltify ($$$$) {
3928 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3930 # Quilt patchification algorithm
3932 # We search backwards through the history of the main tree's HEAD
3933 # (T) looking for a start commit S whose tree object is identical
3934 # to to the patch tip tree (ie the tree corresponding to the
3935 # current dpkg-committed patch series). For these purposes
3936 # `identical' disregards anything in debian/ - this wrinkle is
3937 # necessary because dpkg-source treates debian/ specially.
3939 # We can only traverse edges where at most one of the ancestors'
3940 # trees differs (in changes outside in debian/). And we cannot
3941 # handle edges which change .pc/ or debian/patches. To avoid
3942 # going down a rathole we avoid traversing edges which introduce
3943 # debian/rules or debian/control. And we set a limit on the
3944 # number of edges we are willing to look at.
3946 # If we succeed, we walk forwards again. For each traversed edge
3947 # PC (with P parent, C child) (starting with P=S and ending with
3948 # C=T) to we do this:
3950 # - dpkg-source --commit with a patch name and message derived from C
3951 # After traversing PT, we git commit the changes which
3952 # should be contained within debian/patches.
3954 # The search for the path S..T is breadth-first. We maintain a
3955 # todo list containing search nodes. A search node identifies a
3956 # commit, and looks something like this:
3958 # Commit => $git_commit_id,
3959 # Child => $c, # or undef if P=T
3960 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3961 # Nontrivial => true iff $p..$c has relevant changes
3968 my %considered; # saves being exponential on some weird graphs
3970 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3973 my ($search,$whynot) = @_;
3974 printdebug " search NOT $search->{Commit} $whynot\n";
3975 $search->{Whynot} = $whynot;
3976 push @nots, $search;
3977 no warnings qw(exiting);
3986 my $c = shift @todo;
3987 next if $considered{$c->{Commit}}++;
3989 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3991 printdebug "quiltify investigate $c->{Commit}\n";
3994 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3995 printdebug " search finished hooray!\n";
4000 if ($quilt_mode eq 'nofix') {
4001 fail "quilt fixup required but quilt mode is \`nofix'\n".
4002 "HEAD commit $c->{Commit} differs from tree implied by ".
4003 " debian/patches (tree object $oldtiptree)";
4005 if ($quilt_mode eq 'smash') {
4006 printdebug " search quitting smash\n";
4010 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4011 $not->($c, "has $c_sentinels not $t_sentinels")
4012 if $c_sentinels ne $t_sentinels;
4014 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4015 $commitdata =~ m/\n\n/;
4017 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4018 @parents = map { { Commit => $_, Child => $c } } @parents;
4020 $not->($c, "root commit") if !@parents;
4022 foreach my $p (@parents) {
4023 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4025 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4026 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4028 foreach my $p (@parents) {
4029 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4031 my @cmd= (@git, qw(diff-tree -r --name-only),
4032 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4033 my $patchstackchange = cmdoutput @cmd;
4034 if (length $patchstackchange) {
4035 $patchstackchange =~ s/\n/,/g;
4036 $not->($p, "changed $patchstackchange");
4039 printdebug " search queue P=$p->{Commit} ",
4040 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4046 printdebug "quiltify want to smash\n";
4049 my $x = $_[0]{Commit};
4050 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4053 my $reportnot = sub {
4055 my $s = $abbrev->($notp);
4056 my $c = $notp->{Child};
4057 $s .= "..".$abbrev->($c) if $c;
4058 $s .= ": ".$notp->{Whynot};
4061 if ($quilt_mode eq 'linear') {
4062 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4063 foreach my $notp (@nots) {
4064 print STDERR "$us: ", $reportnot->($notp), "\n";
4066 print STDERR "$us: $_\n" foreach @$failsuggestion;
4067 fail "quilt fixup naive history linearisation failed.\n".
4068 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4069 } elsif ($quilt_mode eq 'smash') {
4070 } elsif ($quilt_mode eq 'auto') {
4071 progress "quilt fixup cannot be linear, smashing...";
4073 die "$quilt_mode ?";
4076 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4077 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4079 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4081 quiltify_dpkg_commit "auto-$version-$target-$time",
4082 (getfield $clogp, 'Maintainer'),
4083 "Automatically generated patch ($clogp->{Version})\n".
4084 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4088 progress "quiltify linearisation planning successful, executing...";
4090 for (my $p = $sref_S;
4091 my $c = $p->{Child};
4093 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4094 next unless $p->{Nontrivial};
4096 my $cc = $c->{Commit};
4098 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4099 $commitdata =~ m/\n\n/ or die "$c ?";
4102 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4105 my $commitdate = cmdoutput
4106 @git, qw(log -n1 --pretty=format:%aD), $cc;
4108 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4110 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4117 my $gbp_check_suitable = sub {
4122 die "contains unexpected slashes\n" if m{//} || m{/$};
4123 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4124 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4125 die "too long" if length > 200;
4127 return $_ unless $@;
4128 print STDERR "quiltifying commit $cc:".
4129 " ignoring/dropping Gbp-Pq $what: $@";
4133 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4135 (\S+) \s* \n //ixm) {
4136 $patchname = $gbp_check_suitable->($1, 'Name');
4138 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4140 (\S+) \s* \n //ixm) {
4141 $patchdir = $gbp_check_suitable->($1, 'Topic');
4146 if (!defined $patchname) {
4147 $patchname = $title;
4148 $patchname =~ s/[.:]$//;
4151 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4152 my $translitname = $converter->convert($patchname);
4153 die unless defined $translitname;
4154 $patchname = $translitname;
4157 "dgit: patch title transliteration error: $@"
4159 $patchname =~ y/ A-Z/-a-z/;
4160 $patchname =~ y/-a-z0-9_.+=~//cd;
4161 $patchname =~ s/^\W/x-$&/;
4162 $patchname = substr($patchname,0,40);
4164 if (!defined $patchdir) {
4167 if (length $patchdir) {
4168 $patchname = "$patchdir/$patchname";
4170 if ($patchname =~ m{^(.*)/}) {
4171 mkpath "debian/patches/$1";
4176 stat "debian/patches/$patchname$index";
4178 $!==ENOENT or die "$patchname$index $!";
4180 runcmd @git, qw(checkout -q), $cc;
4182 # We use the tip's changelog so that dpkg-source doesn't
4183 # produce complaining messages from dpkg-parsechangelog. None
4184 # of the information dpkg-source gets from the changelog is
4185 # actually relevant - it gets put into the original message
4186 # which dpkg-source provides our stunt editor, and then
4188 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4190 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4191 "Date: $commitdate\n".
4192 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4194 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4197 runcmd @git, qw(checkout -q master);
4200 sub build_maybe_quilt_fixup () {
4201 my ($format,$fopts) = get_source_format;
4202 return unless madformat_wantfixup $format;
4205 check_for_vendor_patches();
4207 if (quiltmode_splitbrain) {
4208 foreach my $needtf (qw(new maint)) {
4209 next if grep { $_ eq $needtf } access_cfg_tagformats;
4211 quilt mode $quilt_mode requires split view so server needs to support
4212 both "new" and "maint" tag formats, but config says it doesn't.
4217 my $clogp = parsechangelog();
4218 my $headref = git_rev_parse('HEAD');
4223 my $upstreamversion=$version;
4224 $upstreamversion =~ s/-[^-]*$//;
4226 if ($fopts->{'single-debian-patch'}) {
4227 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4229 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4232 die 'bug' if $split_brain && !$need_split_build_invocation;
4234 changedir '../../../..';
4235 runcmd_ordryrun_local
4236 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4239 sub quilt_fixup_mkwork ($) {
4242 mkdir "work" or die $!;
4244 mktree_in_ud_here();
4245 runcmd @git, qw(reset -q --hard), $headref;
4248 sub quilt_fixup_linkorigs ($$) {
4249 my ($upstreamversion, $fn) = @_;
4250 # calls $fn->($leafname);
4252 foreach my $f (<../../../../*>) { #/){
4253 my $b=$f; $b =~ s{.*/}{};
4255 local ($debuglevel) = $debuglevel-1;
4256 printdebug "QF linkorigs $b, $f ?\n";
4258 next unless is_orig_file_of_vsn $b, $upstreamversion;
4259 printdebug "QF linkorigs $b, $f Y\n";
4260 link_ltarget $f, $b or die "$b $!";
4265 sub quilt_fixup_delete_pc () {
4266 runcmd @git, qw(rm -rqf .pc);
4268 Commit removal of .pc (quilt series tracking data)
4270 [dgit ($our_version) upgrade quilt-remove-pc]
4274 sub quilt_fixup_singlepatch ($$$) {
4275 my ($clogp, $headref, $upstreamversion) = @_;
4277 progress "starting quiltify (single-debian-patch)";
4279 # dpkg-source --commit generates new patches even if
4280 # single-debian-patch is in debian/source/options. In order to
4281 # get it to generate debian/patches/debian-changes, it is
4282 # necessary to build the source package.
4284 quilt_fixup_linkorigs($upstreamversion, sub { });
4285 quilt_fixup_mkwork($headref);
4287 rmtree("debian/patches");
4289 runcmd @dpkgsource, qw(-b .);
4291 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4292 rename srcfn("$upstreamversion", "/debian/patches"),
4293 "work/debian/patches";
4296 commit_quilty_patch();
4299 sub quilt_make_fake_dsc ($) {
4300 my ($upstreamversion) = @_;
4302 my $fakeversion="$upstreamversion-~~DGITFAKE";
4304 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4305 print $fakedsc <<END or die $!;
4308 Version: $fakeversion
4312 my $dscaddfile=sub {
4315 my $md = new Digest::MD5;
4317 my $fh = new IO::File $b, '<' or die "$b $!";
4322 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4325 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4327 my @files=qw(debian/source/format debian/rules
4328 debian/control debian/changelog);
4329 foreach my $maybe (qw(debian/patches debian/source/options
4330 debian/tests/control)) {
4331 next unless stat_exists "../../../$maybe";
4332 push @files, $maybe;
4335 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4336 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4338 $dscaddfile->($debtar);
4339 close $fakedsc or die $!;
4342 sub quilt_check_splitbrain_cache ($$) {
4343 my ($headref, $upstreamversion) = @_;
4344 # Called only if we are in (potentially) split brain mode.
4346 # Computes the cache key and looks in the cache.
4347 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4349 my $splitbrain_cachekey;
4352 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4353 # we look in the reflog of dgit-intern/quilt-cache
4354 # we look for an entry whose message is the key for the cache lookup
4355 my @cachekey = (qw(dgit), $our_version);
4356 push @cachekey, $upstreamversion;
4357 push @cachekey, $quilt_mode;
4358 push @cachekey, $headref;
4360 push @cachekey, hashfile('fake.dsc');
4362 my $srcshash = Digest::SHA->new(256);
4363 my %sfs = ( %INC, '$0(dgit)' => $0 );
4364 foreach my $sfk (sort keys %sfs) {
4365 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
4366 $srcshash->add($sfk," ");
4367 $srcshash->add(hashfile($sfs{$sfk}));
4368 $srcshash->add("\n");
4370 push @cachekey, $srcshash->hexdigest();
4371 $splitbrain_cachekey = "@cachekey";
4373 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
4375 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4376 debugcmd "|(probably)",@cmd;
4377 my $child = open GC, "-|"; defined $child or die $!;
4379 chdir '../../..' or die $!;
4380 if (!stat ".git/logs/refs/$splitbraincache") {
4381 $! == ENOENT or die $!;
4382 printdebug ">(no reflog)\n";
4389 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4390 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4393 quilt_fixup_mkwork($headref);
4394 if ($cachehit ne $headref) {
4395 progress "dgit view: found cached (commit id $cachehit)";
4396 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4398 return ($cachehit, $splitbrain_cachekey);
4400 progress "dgit view: found cached, no changes required";
4401 return ($headref, $splitbrain_cachekey);
4403 die $! if GC->error;
4404 failedcmd unless close GC;
4406 printdebug "splitbrain cache miss\n";
4407 return (undef, $splitbrain_cachekey);
4410 sub quilt_fixup_multipatch ($$$) {
4411 my ($clogp, $headref, $upstreamversion) = @_;
4413 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4416 # - honour any existing .pc in case it has any strangeness
4417 # - determine the git commit corresponding to the tip of
4418 # the patch stack (if there is one)
4419 # - if there is such a git commit, convert each subsequent
4420 # git commit into a quilt patch with dpkg-source --commit
4421 # - otherwise convert all the differences in the tree into
4422 # a single git commit
4426 # Our git tree doesn't necessarily contain .pc. (Some versions of
4427 # dgit would include the .pc in the git tree.) If there isn't
4428 # one, we need to generate one by unpacking the patches that we
4431 # We first look for a .pc in the git tree. If there is one, we
4432 # will use it. (This is not the normal case.)
4434 # Otherwise need to regenerate .pc so that dpkg-source --commit
4435 # can work. We do this as follows:
4436 # 1. Collect all relevant .orig from parent directory
4437 # 2. Generate a debian.tar.gz out of
4438 # debian/{patches,rules,source/format,source/options}
4439 # 3. Generate a fake .dsc containing just these fields:
4440 # Format Source Version Files
4441 # 4. Extract the fake .dsc
4442 # Now the fake .dsc has a .pc directory.
4443 # (In fact we do this in every case, because in future we will
4444 # want to search for a good base commit for generating patches.)
4446 # Then we can actually do the dpkg-source --commit
4447 # 1. Make a new working tree with the same object
4448 # store as our main tree and check out the main
4450 # 2. Copy .pc from the fake's extraction, if necessary
4451 # 3. Run dpkg-source --commit
4452 # 4. If the result has changes to debian/, then
4453 # - git add them them
4454 # - git add .pc if we had a .pc in-tree
4456 # 5. If we had a .pc in-tree, delete it, and git commit
4457 # 6. Back in the main tree, fast forward to the new HEAD
4459 # Another situation we may have to cope with is gbp-style
4460 # patches-unapplied trees.
4462 # We would want to detect these, so we know to escape into
4463 # quilt_fixup_gbp. However, this is in general not possible.
4464 # Consider a package with a one patch which the dgit user reverts
4465 # (with git revert or the moral equivalent).
4467 # That is indistinguishable in contents from a patches-unapplied
4468 # tree. And looking at the history to distinguish them is not
4469 # useful because the user might have made a confusing-looking git
4470 # history structure (which ought to produce an error if dgit can't
4471 # cope, not a silent reintroduction of an unwanted patch).
4473 # So gbp users will have to pass an option. But we can usually
4474 # detect their failure to do so: if the tree is not a clean
4475 # patches-applied tree, quilt linearisation fails, but the tree
4476 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4477 # they want --quilt=unapplied.
4479 # To help detect this, when we are extracting the fake dsc, we
4480 # first extract it with --skip-patches, and then apply the patches
4481 # afterwards with dpkg-source --before-build. That lets us save a
4482 # tree object corresponding to .origs.
4484 my $splitbrain_cachekey;
4486 quilt_make_fake_dsc($upstreamversion);
4488 if (quiltmode_splitbrain()) {
4490 ($cachehit, $splitbrain_cachekey) =
4491 quilt_check_splitbrain_cache($headref, $upstreamversion);
4492 return if $cachehit;
4496 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4498 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4499 rename $fakexdir, "fake" or die "$fakexdir $!";
4503 remove_stray_gits();
4504 mktree_in_ud_here();
4508 runcmd @git, qw(add -Af .);
4509 my $unapplied=git_write_tree();
4510 printdebug "fake orig tree object $unapplied\n";
4514 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4516 if (system @bbcmd) {
4517 failedcmd @bbcmd if $? < 0;
4519 failed to apply your git tree's patch stack (from debian/patches/) to
4520 the corresponding upstream tarball(s). Your source tree and .orig
4521 are probably too inconsistent. dgit can only fix up certain kinds of
4522 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4528 quilt_fixup_mkwork($headref);
4531 if (stat_exists ".pc") {
4533 progress "Tree already contains .pc - will use it then delete it.";
4536 rename '../fake/.pc','.pc' or die $!;
4539 changedir '../fake';
4541 runcmd @git, qw(add -Af .);
4542 my $oldtiptree=git_write_tree();
4543 printdebug "fake o+d/p tree object $unapplied\n";
4544 changedir '../work';
4547 # We calculate some guesswork now about what kind of tree this might
4548 # be. This is mostly for error reporting.
4554 # O = orig, without patches applied
4555 # A = "applied", ie orig with H's debian/patches applied
4556 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4557 \%editedignores, \@unrepres),
4558 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4559 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4563 foreach my $b (qw(01 02)) {
4564 foreach my $v (qw(O2H O2A H2A)) {
4565 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4568 printdebug "differences \@dl @dl.\n";
4571 "$us: base trees orig=%.20s o+d/p=%.20s",
4572 $unapplied, $oldtiptree;
4574 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4575 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4576 $dl[0], $dl[1], $dl[3], $dl[4],
4580 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4583 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4588 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4589 push @failsuggestion, "This might be a patches-unapplied branch.";
4590 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4591 push @failsuggestion, "This might be a patches-applied branch.";
4593 push @failsuggestion, "Maybe you need to specify one of".
4594 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4596 if (quiltmode_splitbrain()) {
4597 quiltify_splitbrain($clogp, $unapplied, $headref,
4598 $diffbits, \%editedignores,
4599 $splitbrain_cachekey);
4603 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4604 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4606 if (!open P, '>>', ".pc/applied-patches") {
4607 $!==&ENOENT or die $!;
4612 commit_quilty_patch();
4614 if ($mustdeletepc) {
4615 quilt_fixup_delete_pc();
4619 sub quilt_fixup_editor () {
4620 my $descfn = $ENV{$fakeeditorenv};
4621 my $editing = $ARGV[$#ARGV];
4622 open I1, '<', $descfn or die "$descfn: $!";
4623 open I2, '<', $editing or die "$editing: $!";
4624 unlink $editing or die "$editing: $!";
4625 open O, '>', $editing or die "$editing: $!";
4626 while (<I1>) { print O or die $!; } I1->error and die $!;
4629 $copying ||= m/^\-\-\- /;
4630 next unless $copying;
4633 I2->error and die $!;
4638 sub maybe_apply_patches_dirtily () {
4639 return unless $quilt_mode =~ m/gbp|unapplied/;
4640 print STDERR <<END or die $!;
4642 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4643 dgit: Have to apply the patches - making the tree dirty.
4644 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4647 $patches_applied_dirtily = 01;
4648 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4649 runcmd qw(dpkg-source --before-build .);
4652 sub maybe_unapply_patches_again () {
4653 progress "dgit: Unapplying patches again to tidy up the tree."
4654 if $patches_applied_dirtily;
4655 runcmd qw(dpkg-source --after-build .)
4656 if $patches_applied_dirtily & 01;
4658 if $patches_applied_dirtily & 02;
4659 $patches_applied_dirtily = 0;
4662 #----- other building -----
4664 our $clean_using_builder;
4665 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4666 # clean the tree before building (perhaps invoked indirectly by
4667 # whatever we are using to run the build), rather than separately
4668 # and explicitly by us.
4671 return if $clean_using_builder;
4672 if ($cleanmode eq 'dpkg-source') {
4673 maybe_apply_patches_dirtily();
4674 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4675 } elsif ($cleanmode eq 'dpkg-source-d') {
4676 maybe_apply_patches_dirtily();
4677 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4678 } elsif ($cleanmode eq 'git') {
4679 runcmd_ordryrun_local @git, qw(clean -xdf);
4680 } elsif ($cleanmode eq 'git-ff') {
4681 runcmd_ordryrun_local @git, qw(clean -xdff);
4682 } elsif ($cleanmode eq 'check') {
4683 my $leftovers = cmdoutput @git, qw(clean -xdn);
4684 if (length $leftovers) {
4685 print STDERR $leftovers, "\n" or die $!;
4686 fail "tree contains uncommitted files and --clean=check specified";
4688 } elsif ($cleanmode eq 'none') {
4695 badusage "clean takes no additional arguments" if @ARGV;
4698 maybe_unapply_patches_again();
4703 badusage "-p is not allowed when building" if defined $package;
4706 my $clogp = parsechangelog();
4707 $isuite = getfield $clogp, 'Distribution';
4708 $package = getfield $clogp, 'Source';
4709 $version = getfield $clogp, 'Version';
4710 build_maybe_quilt_fixup();
4712 my $pat = changespat $version;
4713 foreach my $f (glob "$buildproductsdir/$pat") {
4715 unlink $f or fail "remove old changes file $f: $!";
4717 progress "would remove $f";
4723 sub changesopts_initial () {
4724 my @opts =@changesopts[1..$#changesopts];
4727 sub changesopts_version () {
4728 if (!defined $changes_since_version) {
4729 my @vsns = archive_query('archive_query');
4730 my @quirk = access_quirk();
4731 if ($quirk[0] eq 'backports') {
4732 local $isuite = $quirk[2];
4734 canonicalise_suite();
4735 push @vsns, archive_query('archive_query');
4738 @vsns = map { $_->[0] } @vsns;
4739 @vsns = sort { -version_compare($a, $b) } @vsns;
4740 $changes_since_version = $vsns[0];
4741 progress "changelog will contain changes since $vsns[0]";
4743 $changes_since_version = '_';
4744 progress "package seems new, not specifying -v<version>";
4747 if ($changes_since_version ne '_') {
4748 return ("-v$changes_since_version");
4754 sub changesopts () {
4755 return (changesopts_initial(), changesopts_version());
4758 sub massage_dbp_args ($;$) {
4759 my ($cmd,$xargs) = @_;
4762 # - if we're going to split the source build out so we can
4763 # do strange things to it, massage the arguments to dpkg-buildpackage
4764 # so that the main build doessn't build source (or add an argument
4765 # to stop it building source by default).
4767 # - add -nc to stop dpkg-source cleaning the source tree,
4768 # unless we're not doing a split build and want dpkg-source
4769 # as cleanmode, in which case we can do nothing
4772 # 0 - source will NOT need to be built separately by caller
4773 # +1 - source will need to be built separately by caller
4774 # +2 - source will need to be built separately by caller AND
4775 # dpkg-buildpackage should not in fact be run at all!
4776 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4777 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4778 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4779 $clean_using_builder = 1;
4782 # -nc has the side effect of specifying -b if nothing else specified
4783 # and some combinations of -S, -b, et al, are errors, rather than
4784 # later simply overriding earlie. So we need to:
4785 # - search the command line for these options
4786 # - pick the last one
4787 # - perhaps add our own as a default
4788 # - perhaps adjust it to the corresponding non-source-building version
4790 foreach my $l ($cmd, $xargs) {
4792 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4795 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4797 if ($need_split_build_invocation) {
4798 printdebug "massage split $dmode.\n";
4799 $r = $dmode =~ m/[S]/ ? +2 :
4800 $dmode =~ y/gGF/ABb/ ? +1 :
4801 $dmode =~ m/[ABb]/ ? 0 :
4804 printdebug "massage done $r $dmode.\n";
4806 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4811 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4812 my $wantsrc = massage_dbp_args \@dbp;
4819 push @dbp, changesopts_version();
4820 maybe_apply_patches_dirtily();
4821 runcmd_ordryrun_local @dbp;
4823 maybe_unapply_patches_again();
4824 printdone "build successful\n";
4828 $quilt_mode //= 'gbp';
4832 my @dbp = @dpkgbuildpackage;
4834 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4836 if (!length $gbp_build[0]) {
4837 if (length executable_on_path('git-buildpackage')) {
4838 $gbp_build[0] = qw(git-buildpackage);
4840 $gbp_build[0] = 'gbp buildpackage';
4843 my @cmd = opts_opt_multi_cmd @gbp_build;
4845 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4850 if (!$clean_using_builder) {
4851 push @cmd, '--git-cleaner=true';
4855 maybe_unapply_patches_again();
4857 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4858 canonicalise_suite();
4859 push @cmd, "--git-debian-branch=".lbranch();
4861 push @cmd, changesopts();
4862 runcmd_ordryrun_local @cmd, @ARGV;
4864 printdone "build successful\n";
4866 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4869 my $our_cleanmode = $cleanmode;
4870 if ($need_split_build_invocation) {
4871 # Pretend that clean is being done some other way. This
4872 # forces us not to try to use dpkg-buildpackage to clean and
4873 # build source all in one go; and instead we run dpkg-source
4874 # (and build_prep() will do the clean since $clean_using_builder
4876 $our_cleanmode = 'ELSEWHERE';
4878 if ($our_cleanmode =~ m/^dpkg-source/) {
4879 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4880 $clean_using_builder = 1;
4883 $sourcechanges = changespat $version,'source';
4885 unlink "../$sourcechanges" or $!==ENOENT
4886 or fail "remove $sourcechanges: $!";
4888 $dscfn = dscfn($version);
4889 if ($our_cleanmode eq 'dpkg-source') {
4890 maybe_apply_patches_dirtily();
4891 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4893 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4894 maybe_apply_patches_dirtily();
4895 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4898 my @cmd = (@dpkgsource, qw(-b --));
4901 runcmd_ordryrun_local @cmd, "work";
4902 my @udfiles = <${package}_*>;
4903 changedir "../../..";
4904 foreach my $f (@udfiles) {
4905 printdebug "source copy, found $f\n";
4908 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4909 $f eq srcfn($version, $&));
4910 printdebug "source copy, found $f - renaming\n";
4911 rename "$ud/$f", "../$f" or $!==ENOENT
4912 or fail "put in place new source file ($f): $!";
4915 my $pwd = must_getcwd();
4916 my $leafdir = basename $pwd;
4918 runcmd_ordryrun_local @cmd, $leafdir;
4921 runcmd_ordryrun_local qw(sh -ec),
4922 'exec >$1; shift; exec "$@"','x',
4923 "../$sourcechanges",
4924 @dpkggenchanges, qw(-S), changesopts();
4928 sub cmd_build_source {
4929 badusage "build-source takes no additional arguments" if @ARGV;
4931 maybe_unapply_patches_again();
4932 printdone "source built, results in $dscfn and $sourcechanges";
4937 my $pat = changespat $version;
4939 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4940 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4942 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
4943 Suggest you delete @unwanted.
4947 my $wasdir = must_getcwd();
4950 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4951 stat_exists $sourcechanges
4952 or fail "$sourcechanges (in parent directory): $!";
4954 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4955 my @changesfiles = glob $pat;
4956 @changesfiles = sort {
4957 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4960 fail <<END if @changesfiles==1;
4961 only one changes file from sbuild (@changesfiles)
4962 perhaps you need to pass -A ? (sbuild's default is to build only
4963 arch-specific binaries; dgit 1.4 used to override that.)
4965 fail "wrong number of different changes files (@changesfiles)"
4966 unless @changesfiles==2;
4967 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4968 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4969 fail "$l found in binaries changes file $binchanges"
4972 runcmd_ordryrun_local @mergechanges, @changesfiles;
4973 my $multichanges = changespat $version,'multi';
4975 stat_exists $multichanges or fail "$multichanges: $!";
4976 foreach my $cf (glob $pat) {
4977 next if $cf eq $multichanges;
4978 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4982 maybe_unapply_patches_again();
4983 printdone "build successful, results in $multichanges\n" or die $!;
4986 sub cmd_quilt_fixup {
4987 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4988 my $clogp = parsechangelog();
4989 $version = getfield $clogp, 'Version';
4990 $package = getfield $clogp, 'Source';
4993 build_maybe_quilt_fixup();
4996 sub cmd_archive_api_query {
4997 badusage "need only 1 subpath argument" unless @ARGV==1;
4998 my ($subpath) = @ARGV;
4999 my @cmd = archive_api_query_cmd($subpath);
5001 exec @cmd or fail "exec curl: $!\n";
5004 sub cmd_clone_dgit_repos_server {
5005 badusage "need destination argument" unless @ARGV==1;
5006 my ($destdir) = @ARGV;
5007 $package = '_dgit-repos-server';
5008 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5010 exec @cmd or fail "exec git clone: $!\n";
5013 sub cmd_setup_mergechangelogs {
5014 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5015 setup_mergechangelogs(1);
5018 sub cmd_setup_useremail {
5019 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5023 sub cmd_setup_new_tree {
5024 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5028 #---------- argument parsing and main program ----------
5031 print "dgit version $our_version\n" or die $!;
5035 our (%valopts_long, %valopts_short);
5038 sub defvalopt ($$$$) {
5039 my ($long,$short,$val_re,$how) = @_;
5040 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5041 $valopts_long{$long} = $oi;
5042 $valopts_short{$short} = $oi;
5043 # $how subref should:
5044 # do whatever assignemnt or thing it likes with $_[0]
5045 # if the option should not be passed on to remote, @rvalopts=()
5046 # or $how can be a scalar ref, meaning simply assign the value
5049 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5050 defvalopt '--distro', '-d', '.+', \$idistro;
5051 defvalopt '', '-k', '.+', \$keyid;
5052 defvalopt '--existing-package','', '.*', \$existing_package;
5053 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5054 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5055 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5057 defvalopt '', '-C', '.+', sub {
5058 ($changesfile) = (@_);
5059 if ($changesfile =~ s#^(.*)/##) {
5060 $buildproductsdir = $1;
5064 defvalopt '--initiator-tempdir','','.*', sub {
5065 ($initiator_tempdir) = (@_);
5066 $initiator_tempdir =~ m#^/# or
5067 badusage "--initiator-tempdir must be used specify an".
5068 " absolute, not relative, directory."
5074 if (defined $ENV{'DGIT_SSH'}) {
5075 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5076 } elsif (defined $ENV{'GIT_SSH'}) {
5077 @ssh = ($ENV{'GIT_SSH'});
5085 if (!defined $val) {
5086 badusage "$what needs a value" unless @ARGV;
5088 push @rvalopts, $val;
5090 badusage "bad value \`$val' for $what" unless
5091 $val =~ m/^$oi->{Re}$(?!\n)/s;
5092 my $how = $oi->{How};
5093 if (ref($how) eq 'SCALAR') {
5098 push @ropts, @rvalopts;
5102 last unless $ARGV[0] =~ m/^-/;
5106 if (m/^--dry-run$/) {
5109 } elsif (m/^--damp-run$/) {
5112 } elsif (m/^--no-sign$/) {
5115 } elsif (m/^--help$/) {
5117 } elsif (m/^--version$/) {
5119 } elsif (m/^--new$/) {
5122 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5123 ($om = $opts_opt_map{$1}) &&
5127 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5128 !$opts_opt_cmdonly{$1} &&
5129 ($om = $opts_opt_map{$1})) {
5132 } elsif (m/^--ignore-dirty$/s) {
5135 } elsif (m/^--no-quilt-fixup$/s) {
5137 $quilt_mode = 'nocheck';
5138 } elsif (m/^--no-rm-on-error$/s) {
5141 } elsif (m/^--overwrite$/s) {
5143 $overwrite_version = '';
5144 } elsif (m/^--overwrite=(.+)$/s) {
5146 $overwrite_version = $1;
5147 } elsif (m/^--(no-)?rm-old-changes$/s) {
5150 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5152 push @deliberatelies, $&;
5153 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5154 # undocumented, for testing
5156 $tagformat_want = [ $1, 'command line', 1 ];
5157 # 1 menas overrides distro configuration
5158 } elsif (m/^--always-split-source-build$/s) {
5159 # undocumented, for testing
5161 $need_split_build_invocation = 1;
5162 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5163 $val = $2 ? $' : undef; #';
5164 $valopt->($oi->{Long});
5166 badusage "unknown long option \`$_'";
5173 } elsif (s/^-L/-/) {
5176 } elsif (s/^-h/-/) {
5178 } elsif (s/^-D/-/) {
5182 } elsif (s/^-N/-/) {
5187 push @changesopts, $_;
5189 } elsif (s/^-wn$//s) {
5191 $cleanmode = 'none';
5192 } elsif (s/^-wg$//s) {
5195 } elsif (s/^-wgf$//s) {
5197 $cleanmode = 'git-ff';
5198 } elsif (s/^-wd$//s) {
5200 $cleanmode = 'dpkg-source';
5201 } elsif (s/^-wdd$//s) {
5203 $cleanmode = 'dpkg-source-d';
5204 } elsif (s/^-wc$//s) {
5206 $cleanmode = 'check';
5207 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5208 push @git, '-c', $&;
5209 $gitcfgs{cmdline}{$1} = [ $2 ];
5210 } elsif (s/^-c([^=]+)$//s) {
5211 push @git, '-c', $&;
5212 $gitcfgs{cmdline}{$1} = [ 'true' ];
5213 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5215 $val = undef unless length $val;
5216 $valopt->($oi->{Short});
5219 badusage "unknown short option \`$_'";
5226 sub finalise_opts_opts () {
5227 foreach my $k (keys %opts_opt_map) {
5228 my $om = $opts_opt_map{$k};
5230 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5232 badcfg "cannot set command for $k"
5233 unless length $om->[0];
5237 foreach my $c (access_cfg_cfgs("opts-$k")) {
5239 map { $_ ? @$_ : () }
5240 map { $gitcfgs{$_}{$c} }
5241 reverse @gitcfgsources;
5242 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5243 "\n" if $debuglevel >= 4;
5245 badcfg "cannot configure options for $k"
5246 if $opts_opt_cmdonly{$k};
5247 my $insertpos = $opts_cfg_insertpos{$k};
5248 @$om = ( @$om[0..$insertpos-1],
5250 @$om[$insertpos..$#$om] );
5255 if ($ENV{$fakeeditorenv}) {
5257 quilt_fixup_editor();
5263 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5264 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5265 if $dryrun_level == 1;
5267 print STDERR $helpmsg or die $!;
5270 my $cmd = shift @ARGV;
5273 my $pre_fn = ${*::}{"pre_$cmd"};
5274 $pre_fn->() if $pre_fn;
5276 if (!defined $rmchanges) {
5277 local $access_forpush;
5278 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5281 if (!defined $quilt_mode) {
5282 local $access_forpush;
5283 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5284 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5286 $quilt_mode =~ m/^($quilt_modes_re)$/
5287 or badcfg "unknown quilt-mode \`$quilt_mode'";
5291 $need_split_build_invocation ||= quiltmode_splitbrain();
5293 if (!defined $cleanmode) {
5294 local $access_forpush;
5295 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5296 $cleanmode //= 'dpkg-source';
5298 badcfg "unknown clean-mode \`$cleanmode'" unless
5299 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5302 my $fn = ${*::}{"cmd_$cmd"};
5303 $fn or badusage "unknown operation $cmd";