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###
44 our $absurdity = undef; ###substituted###
46 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
49 our $isuite = 'unstable';
55 our $dryrun_level = 0;
57 our $buildproductsdir = '..';
63 our $existing_package = 'dpkg';
65 our $changes_since_version;
67 our $overwrite_version; # undef: not specified; '': check changelog
69 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
70 our $we_are_responder;
71 our $initiator_tempdir;
72 our $patches_applied_dirtily = 00;
77 our %forceopts = map { $_=>0 }
78 qw(unrepresentable unsupported-source-format);
80 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
82 our $suite_re = '[-+.0-9a-z]+';
83 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
84 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
85 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
86 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
88 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
89 our $splitbraincache = 'dgit-intern/quilt-cache';
92 our (@dget) = qw(dget);
93 our (@curl) = qw(curl);
94 our (@dput) = qw(dput);
95 our (@debsign) = qw(debsign);
97 our (@sbuild) = qw(sbuild);
99 our (@dgit) = qw(dgit);
100 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
101 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
102 our (@dpkggenchanges) = qw(dpkg-genchanges);
103 our (@mergechanges) = qw(mergechanges -f);
104 our (@gbp_build) = ('');
105 our (@gbp_pq) = ('gbp pq');
106 our (@changesopts) = ('');
108 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
111 'debsign' => \@debsign,
113 'sbuild' => \@sbuild,
117 'dpkg-source' => \@dpkgsource,
118 'dpkg-buildpackage' => \@dpkgbuildpackage,
119 'dpkg-genchanges' => \@dpkggenchanges,
120 'gbp-build' => \@gbp_build,
121 'gbp-pq' => \@gbp_pq,
122 'ch' => \@changesopts,
123 'mergechanges' => \@mergechanges);
125 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
126 our %opts_cfg_insertpos = map {
128 scalar @{ $opts_opt_map{$_} }
129 } keys %opts_opt_map;
131 sub finalise_opts_opts();
137 our $supplementary_message = '';
138 our $need_split_build_invocation = 0;
139 our $split_brain = 0;
143 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
146 our $remotename = 'dgit';
147 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
151 if (!defined $absurdity) {
153 $absurdity =~ s{/[^/]+$}{/absurd} or die;
157 my ($v,$distro) = @_;
158 return $tagformatfn->($v, $distro);
161 sub debiantag_maintview ($$) {
162 my ($v,$distro) = @_;
167 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
169 sub lbranch () { return "$branchprefix/$csuite"; }
170 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
171 sub lref () { return "refs/heads/".lbranch(); }
172 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
173 sub rrref () { return server_ref($csuite); }
175 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
176 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
178 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
179 # locally fetched refs because they have unhelpful names and clutter
180 # up gitk etc. So we track whether we have "used up" head ref (ie,
181 # whether we have made another local ref which refers to this object).
183 # (If we deleted them unconditionally, then we might end up
184 # re-fetching the same git objects each time dgit fetch was run.)
186 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
187 # in git_fetch_us to fetch the refs in question, and possibly a call
188 # to lrfetchref_used.
190 our (%lrfetchrefs_f, %lrfetchrefs_d);
191 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
193 sub lrfetchref_used ($) {
194 my ($fullrefname) = @_;
195 my $objid = $lrfetchrefs_f{$fullrefname};
196 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
207 return "${package}_".(stripepoch $vsn).$sfx
212 return srcfn($vsn,".dsc");
215 sub changespat ($;$) {
216 my ($vsn, $arch) = @_;
217 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
226 foreach my $f (@end) {
228 print STDERR "$us: cleanup: $@" if length $@;
232 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
234 sub forceable_fail ($$) {
235 my ($forceoptsl, $msg) = @_;
236 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
237 print STDERR "warning: overriding problem due to --force:\n". $msg;
240 sub no_such_package () {
241 print STDERR "$us: package $package does not exist in suite $isuite\n";
247 printdebug "CD $newdir\n";
248 chdir $newdir or confess "chdir: $newdir: $!";
251 sub deliberately ($) {
253 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
256 sub deliberately_not_fast_forward () {
257 foreach (qw(not-fast-forward fresh-repo)) {
258 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
262 sub quiltmode_splitbrain () {
263 $quilt_mode =~ m/gbp|dpm|unapplied/;
266 sub opts_opt_multi_cmd {
268 push @cmd, split /\s+/, shift @_;
274 return opts_opt_multi_cmd @gbp_pq;
277 #---------- remote protocol support, common ----------
279 # remote push initiator/responder protocol:
280 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
281 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
282 # < dgit-remote-push-ready <actual-proto-vsn>
289 # > supplementary-message NBYTES # $protovsn >= 3
294 # > file parsed-changelog
295 # [indicates that output of dpkg-parsechangelog follows]
296 # > data-block NBYTES
297 # > [NBYTES bytes of data (no newline)]
298 # [maybe some more blocks]
307 # > param head DGIT-VIEW-HEAD
308 # > param csuite SUITE
309 # > param tagformat old|new
310 # > param maint-view MAINT-VIEW-HEAD
312 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
313 # # goes into tag, for replay prevention
316 # [indicates that signed tag is wanted]
317 # < data-block NBYTES
318 # < [NBYTES bytes of data (no newline)]
319 # [maybe some more blocks]
323 # > want signed-dsc-changes
324 # < data-block NBYTES [transfer of signed dsc]
326 # < data-block NBYTES [transfer of signed changes]
334 sub i_child_report () {
335 # Sees if our child has died, and reap it if so. Returns a string
336 # describing how it died if it failed, or undef otherwise.
337 return undef unless $i_child_pid;
338 my $got = waitpid $i_child_pid, WNOHANG;
339 return undef if $got <= 0;
340 die unless $got == $i_child_pid;
341 $i_child_pid = undef;
342 return undef unless $?;
343 return "build host child ".waitstatusmsg();
348 fail "connection lost: $!" if $fh->error;
349 fail "protocol violation; $m not expected";
352 sub badproto_badread ($$) {
354 fail "connection lost: $!" if $!;
355 my $report = i_child_report();
356 fail $report if defined $report;
357 badproto $fh, "eof (reading $wh)";
360 sub protocol_expect (&$) {
361 my ($match, $fh) = @_;
364 defined && chomp or badproto_badread $fh, "protocol message";
372 badproto $fh, "\`$_'";
375 sub protocol_send_file ($$) {
376 my ($fh, $ourfn) = @_;
377 open PF, "<", $ourfn or die "$ourfn: $!";
380 my $got = read PF, $d, 65536;
381 die "$ourfn: $!" unless defined $got;
383 print $fh "data-block ".length($d)."\n" or die $!;
384 print $fh $d or die $!;
386 PF->error and die "$ourfn $!";
387 print $fh "data-end\n" or die $!;
391 sub protocol_read_bytes ($$) {
392 my ($fh, $nbytes) = @_;
393 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
395 my $got = read $fh, $d, $nbytes;
396 $got==$nbytes or badproto_badread $fh, "data block";
400 sub protocol_receive_file ($$) {
401 my ($fh, $ourfn) = @_;
402 printdebug "() $ourfn\n";
403 open PF, ">", $ourfn or die "$ourfn: $!";
405 my ($y,$l) = protocol_expect {
406 m/^data-block (.*)$/ ? (1,$1) :
407 m/^data-end$/ ? (0,) :
411 my $d = protocol_read_bytes $fh, $l;
412 print PF $d or die $!;
417 #---------- remote protocol support, responder ----------
419 sub responder_send_command ($) {
421 return unless $we_are_responder;
422 # called even without $we_are_responder
423 printdebug ">> $command\n";
424 print PO $command, "\n" or die $!;
427 sub responder_send_file ($$) {
428 my ($keyword, $ourfn) = @_;
429 return unless $we_are_responder;
430 printdebug "]] $keyword $ourfn\n";
431 responder_send_command "file $keyword";
432 protocol_send_file \*PO, $ourfn;
435 sub responder_receive_files ($@) {
436 my ($keyword, @ourfns) = @_;
437 die unless $we_are_responder;
438 printdebug "[[ $keyword @ourfns\n";
439 responder_send_command "want $keyword";
440 foreach my $fn (@ourfns) {
441 protocol_receive_file \*PI, $fn;
444 protocol_expect { m/^files-end$/ } \*PI;
447 #---------- remote protocol support, initiator ----------
449 sub initiator_expect (&) {
451 protocol_expect { &$match } \*RO;
454 #---------- end remote code ----------
457 if ($we_are_responder) {
459 responder_send_command "progress ".length($m) or die $!;
460 print PO $m or die $!;
470 $ua = LWP::UserAgent->new();
474 progress "downloading $what...";
475 my $r = $ua->get(@_) or die $!;
476 return undef if $r->code == 404;
477 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
478 return $r->decoded_content(charset => 'none');
481 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
486 failedcmd @_ if system @_;
489 sub act_local () { return $dryrun_level <= 1; }
490 sub act_scary () { return !$dryrun_level; }
493 if (!$dryrun_level) {
494 progress "dgit ok: @_";
496 progress "would be ok: @_ (but dry run only)";
501 printcmd(\*STDERR,$debugprefix."#",@_);
504 sub runcmd_ordryrun {
512 sub runcmd_ordryrun_local {
521 my ($first_shell, @cmd) = @_;
522 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
525 our $helpmsg = <<END;
527 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
528 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
529 dgit [dgit-opts] build [dpkg-buildpackage-opts]
530 dgit [dgit-opts] sbuild [sbuild-opts]
531 dgit [dgit-opts] push [dgit-opts] [suite]
532 dgit [dgit-opts] rpush build-host:build-dir ...
533 important dgit options:
534 -k<keyid> sign tag and package with <keyid> instead of default
535 --dry-run -n do not change anything, but go through the motions
536 --damp-run -L like --dry-run but make local changes, without signing
537 --new -N allow introducing a new package
538 --debug -D increase debug level
539 -c<name>=<value> set git config option (used directly by dgit too)
542 our $later_warning_msg = <<END;
543 Perhaps the upload is stuck in incoming. Using the version from git.
547 print STDERR "$us: @_\n", $helpmsg or die $!;
552 @ARGV or badusage "too few arguments";
553 return scalar shift @ARGV;
557 print $helpmsg or die $!;
561 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
563 our %defcfg = ('dgit.default.distro' => 'debian',
564 'dgit.default.username' => '',
565 'dgit.default.archive-query-default-component' => 'main',
566 'dgit.default.ssh' => 'ssh',
567 'dgit.default.archive-query' => 'madison:',
568 'dgit.default.sshpsql-dbname' => 'service=projectb',
569 'dgit.default.dgit-tag-format' => 'new,old,maint',
570 # old means "repo server accepts pushes with old dgit tags"
571 # new means "repo server accepts pushes with new dgit tags"
572 # maint means "repo server accepts split brain pushes"
573 # hist means "repo server may have old pushes without new tag"
574 # ("hist" is implied by "old")
575 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
576 'dgit-distro.debian.git-check' => 'url',
577 'dgit-distro.debian.git-check-suffix' => '/info/refs',
578 'dgit-distro.debian.new-private-pushers' => 't',
579 'dgit-distro.debian/push.git-url' => '',
580 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
581 'dgit-distro.debian/push.git-user-force' => 'dgit',
582 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
583 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
584 'dgit-distro.debian/push.git-create' => 'true',
585 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
586 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
587 # 'dgit-distro.debian.archive-query-tls-key',
588 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
589 # ^ this does not work because curl is broken nowadays
590 # Fixing #790093 properly will involve providing providing the key
591 # in some pacagke and maybe updating these paths.
593 # 'dgit-distro.debian.archive-query-tls-curl-args',
594 # '--ca-path=/etc/ssl/ca-debian',
595 # ^ this is a workaround but works (only) on DSA-administered machines
596 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
597 'dgit-distro.debian.git-url-suffix' => '',
598 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
599 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
600 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
601 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
602 'dgit-distro.ubuntu.git-check' => 'false',
603 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
604 'dgit-distro.test-dummy.ssh' => "$td/ssh",
605 'dgit-distro.test-dummy.username' => "alice",
606 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
607 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
608 'dgit-distro.test-dummy.git-url' => "$td/git",
609 'dgit-distro.test-dummy.git-host' => "git",
610 'dgit-distro.test-dummy.git-path' => "$td/git",
611 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
612 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
613 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
614 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
618 our @gitcfgsources = qw(cmdline local global system);
620 sub git_slurp_config () {
621 local ($debuglevel) = $debuglevel-2;
624 # This algoritm is a bit subtle, but this is needed so that for
625 # options which we want to be single-valued, we allow the
626 # different config sources to override properly. See #835858.
627 foreach my $src (@gitcfgsources) {
628 next if $src eq 'cmdline';
629 # we do this ourselves since git doesn't handle it
631 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
634 open GITS, "-|", @cmd or die $!;
637 printdebug "=> ", (messagequote $_), "\n";
639 push @{ $gitcfgs{$src}{$`} }, $'; #';
643 or ($!==0 && $?==256)
648 sub git_get_config ($) {
650 foreach my $src (@gitcfgsources) {
651 my $l = $gitcfgs{$src}{$c};
652 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
655 @$l==1 or badcfg "multiple values for $c".
656 " (in $src git config)" if @$l > 1;
664 return undef if $c =~ /RETURN-UNDEF/;
665 my $v = git_get_config($c);
666 return $v if defined $v;
667 my $dv = $defcfg{$c};
668 return $dv if defined $dv;
670 badcfg "need value for one of: @_\n".
671 "$us: distro or suite appears not to be (properly) supported";
674 sub access_basedistro () {
675 if (defined $idistro) {
678 return cfg("dgit-suite.$isuite.distro",
679 "dgit.default.distro");
683 sub access_quirk () {
684 # returns (quirk name, distro to use instead or undef, quirk-specific info)
685 my $basedistro = access_basedistro();
686 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
688 if (defined $backports_quirk) {
689 my $re = $backports_quirk;
690 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
692 $re =~ s/\%/([-0-9a-z_]+)/
693 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
694 if ($isuite =~ m/^$re$/) {
695 return ('backports',"$basedistro-backports",$1);
698 return ('none',undef);
703 sub parse_cfg_bool ($$$) {
704 my ($what,$def,$v) = @_;
707 $v =~ m/^[ty1]/ ? 1 :
708 $v =~ m/^[fn0]/ ? 0 :
709 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
712 sub access_forpush_config () {
713 my $d = access_basedistro();
717 parse_cfg_bool('new-private-pushers', 0,
718 cfg("dgit-distro.$d.new-private-pushers",
721 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
724 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
725 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
726 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
727 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
730 sub access_forpush () {
731 $access_forpush //= access_forpush_config();
732 return $access_forpush;
736 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
737 badcfg "pushing but distro is configured readonly"
738 if access_forpush_config() eq '0';
740 $supplementary_message = <<'END' unless $we_are_responder;
741 Push failed, before we got started.
742 You can retry the push, after fixing the problem, if you like.
744 finalise_opts_opts();
748 finalise_opts_opts();
751 sub supplementary_message ($) {
753 if (!$we_are_responder) {
754 $supplementary_message = $msg;
756 } elsif ($protovsn >= 3) {
757 responder_send_command "supplementary-message ".length($msg)
759 print PO $msg or die $!;
763 sub access_distros () {
764 # Returns list of distros to try, in order
767 # 0. `instead of' distro name(s) we have been pointed to
768 # 1. the access_quirk distro, if any
769 # 2a. the user's specified distro, or failing that } basedistro
770 # 2b. the distro calculated from the suite }
771 my @l = access_basedistro();
773 my (undef,$quirkdistro) = access_quirk();
774 unshift @l, $quirkdistro;
775 unshift @l, $instead_distro;
776 @l = grep { defined } @l;
778 if (access_forpush()) {
779 @l = map { ("$_/push", $_) } @l;
784 sub access_cfg_cfgs (@) {
787 # The nesting of these loops determines the search order. We put
788 # the key loop on the outside so that we search all the distros
789 # for each key, before going on to the next key. That means that
790 # if access_cfg is called with a more specific, and then a less
791 # specific, key, an earlier distro can override the less specific
792 # without necessarily overriding any more specific keys. (If the
793 # distro wants to override the more specific keys it can simply do
794 # so; whereas if we did the loop the other way around, it would be
795 # impossible to for an earlier distro to override a less specific
796 # key but not the more specific ones without restating the unknown
797 # values of the more specific keys.
800 # We have to deal with RETURN-UNDEF specially, so that we don't
801 # terminate the search prematurely.
803 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
806 foreach my $d (access_distros()) {
807 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
809 push @cfgs, map { "dgit.default.$_" } @realkeys;
816 my (@cfgs) = access_cfg_cfgs(@keys);
817 my $value = cfg(@cfgs);
821 sub access_cfg_bool ($$) {
822 my ($def, @keys) = @_;
823 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
826 sub string_to_ssh ($) {
828 if ($spec =~ m/\s/) {
829 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
835 sub access_cfg_ssh () {
836 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
837 if (!defined $gitssh) {
840 return string_to_ssh $gitssh;
844 sub access_runeinfo ($) {
846 return ": dgit ".access_basedistro()." $info ;";
849 sub access_someuserhost ($) {
851 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
852 defined($user) && length($user) or
853 $user = access_cfg("$some-user",'username');
854 my $host = access_cfg("$some-host");
855 return length($user) ? "$user\@$host" : $host;
858 sub access_gituserhost () {
859 return access_someuserhost('git');
862 sub access_giturl (;$) {
864 my $url = access_cfg('git-url','RETURN-UNDEF');
867 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
868 return undef unless defined $proto;
871 access_gituserhost().
872 access_cfg('git-path');
874 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
877 return "$url/$package$suffix";
880 sub parsecontrolfh ($$;$) {
881 my ($fh, $desc, $allowsigned) = @_;
882 our $dpkgcontrolhash_noissigned;
885 my %opts = ('name' => $desc);
886 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
887 $c = Dpkg::Control::Hash->new(%opts);
888 $c->parse($fh,$desc) or die "parsing of $desc failed";
889 last if $allowsigned;
890 last if $dpkgcontrolhash_noissigned;
891 my $issigned= $c->get_option('is_pgp_signed');
892 if (!defined $issigned) {
893 $dpkgcontrolhash_noissigned= 1;
894 seek $fh, 0,0 or die "seek $desc: $!";
895 } elsif ($issigned) {
896 fail "control file $desc is (already) PGP-signed. ".
897 " Note that dgit push needs to modify the .dsc and then".
898 " do the signature itself";
907 my ($file, $desc) = @_;
908 my $fh = new IO::Handle;
909 open $fh, '<', $file or die "$file: $!";
910 my $c = parsecontrolfh($fh,$desc);
911 $fh->error and die $!;
917 my ($dctrl,$field) = @_;
918 my $v = $dctrl->{$field};
919 return $v if defined $v;
920 fail "missing field $field in ".$dctrl->get_option('name');
924 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
925 my $p = new IO::Handle;
926 my @cmd = (qw(dpkg-parsechangelog), @_);
927 open $p, '-|', @cmd or die $!;
929 $?=0; $!=0; close $p or failedcmd @cmd;
933 sub commit_getclogp ($) {
934 # Returns the parsed changelog hashref for a particular commit
936 our %commit_getclogp_memo;
937 my $memo = $commit_getclogp_memo{$objid};
938 return $memo if $memo;
940 my $mclog = ".git/dgit/clog-$objid";
941 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
942 "$objid:debian/changelog";
943 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
948 defined $d or fail "getcwd failed: $!";
954 sub archive_query ($) {
956 my $query = access_cfg('archive-query','RETURN-UNDEF');
957 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
960 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
963 sub pool_dsc_subpath ($$) {
964 my ($vsn,$component) = @_; # $package is implict arg
965 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
966 return "/pool/$component/$prefix/$package/".dscfn($vsn);
969 #---------- `ftpmasterapi' archive query method (nascent) ----------
971 sub archive_api_query_cmd ($) {
973 my @cmd = (@curl, qw(-sS));
974 my $url = access_cfg('archive-query-url');
975 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
977 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
978 foreach my $key (split /\:/, $keys) {
979 $key =~ s/\%HOST\%/$host/g;
981 fail "for $url: stat $key: $!" unless $!==ENOENT;
984 fail "config requested specific TLS key but do not know".
985 " how to get curl to use exactly that EE key ($key)";
986 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
987 # # Sadly the above line does not work because of changes
988 # # to gnutls. The real fix for #790093 may involve
989 # # new curl options.
992 # Fixing #790093 properly will involve providing a value
993 # for this on clients.
994 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
995 push @cmd, split / /, $kargs if defined $kargs;
997 push @cmd, $url.$subpath;
1001 sub api_query ($$) {
1003 my ($data, $subpath) = @_;
1004 badcfg "ftpmasterapi archive query method takes no data part"
1006 my @cmd = archive_api_query_cmd($subpath);
1007 my $url = $cmd[$#cmd];
1008 push @cmd, qw(-w %{http_code});
1009 my $json = cmdoutput @cmd;
1010 unless ($json =~ s/\d+\d+\d$//) {
1011 failedcmd_report_cmd undef, @cmd;
1012 fail "curl failed to print 3-digit HTTP code";
1015 fail "fetch of $url gave HTTP code $code"
1016 unless $url =~ m#^file://# or $code =~ m/^2/;
1017 return decode_json($json);
1020 sub canonicalise_suite_ftpmasterapi () {
1021 my ($proto,$data) = @_;
1022 my $suites = api_query($data, 'suites');
1024 foreach my $entry (@$suites) {
1026 my $v = $entry->{$_};
1027 defined $v && $v eq $isuite;
1028 } qw(codename name);
1029 push @matched, $entry;
1031 fail "unknown suite $isuite" unless @matched;
1034 @matched==1 or die "multiple matches for suite $isuite\n";
1035 $cn = "$matched[0]{codename}";
1036 defined $cn or die "suite $isuite info has no codename\n";
1037 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1039 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1044 sub archive_query_ftpmasterapi () {
1045 my ($proto,$data) = @_;
1046 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1048 my $digester = Digest::SHA->new(256);
1049 foreach my $entry (@$info) {
1051 my $vsn = "$entry->{version}";
1052 my ($ok,$msg) = version_check $vsn;
1053 die "bad version: $msg\n" unless $ok;
1054 my $component = "$entry->{component}";
1055 $component =~ m/^$component_re$/ or die "bad component";
1056 my $filename = "$entry->{filename}";
1057 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1058 or die "bad filename";
1059 my $sha256sum = "$entry->{sha256sum}";
1060 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1061 push @rows, [ $vsn, "/pool/$component/$filename",
1062 $digester, $sha256sum ];
1064 die "bad ftpmaster api response: $@\n".Dumper($entry)
1067 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1071 #---------- `madison' archive query method ----------
1073 sub archive_query_madison {
1074 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1077 sub madison_get_parse {
1078 my ($proto,$data) = @_;
1079 die unless $proto eq 'madison';
1080 if (!length $data) {
1081 $data= access_cfg('madison-distro','RETURN-UNDEF');
1082 $data //= access_basedistro();
1084 $rmad{$proto,$data,$package} ||= cmdoutput
1085 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1086 my $rmad = $rmad{$proto,$data,$package};
1089 foreach my $l (split /\n/, $rmad) {
1090 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1091 \s*( [^ \t|]+ )\s* \|
1092 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1093 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1094 $1 eq $package or die "$rmad $package ?";
1101 $component = access_cfg('archive-query-default-component');
1103 $5 eq 'source' or die "$rmad ?";
1104 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1106 return sort { -version_compare($a->[0],$b->[0]); } @out;
1109 sub canonicalise_suite_madison {
1110 # madison canonicalises for us
1111 my @r = madison_get_parse(@_);
1113 "unable to canonicalise suite using package $package".
1114 " which does not appear to exist in suite $isuite;".
1115 " --existing-package may help";
1119 #---------- `sshpsql' archive query method ----------
1122 my ($data,$runeinfo,$sql) = @_;
1123 if (!length $data) {
1124 $data= access_someuserhost('sshpsql').':'.
1125 access_cfg('sshpsql-dbname');
1127 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1128 my ($userhost,$dbname) = ($`,$'); #';
1130 my @cmd = (access_cfg_ssh, $userhost,
1131 access_runeinfo("ssh-psql $runeinfo").
1132 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1133 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1135 open P, "-|", @cmd or die $!;
1138 printdebug(">|$_|\n");
1141 $!=0; $?=0; close P or failedcmd @cmd;
1143 my $nrows = pop @rows;
1144 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1145 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1146 @rows = map { [ split /\|/, $_ ] } @rows;
1147 my $ncols = scalar @{ shift @rows };
1148 die if grep { scalar @$_ != $ncols } @rows;
1152 sub sql_injection_check {
1153 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1156 sub archive_query_sshpsql ($$) {
1157 my ($proto,$data) = @_;
1158 sql_injection_check $isuite, $package;
1159 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1160 SELECT source.version, component.name, files.filename, files.sha256sum
1162 JOIN src_associations ON source.id = src_associations.source
1163 JOIN suite ON suite.id = src_associations.suite
1164 JOIN dsc_files ON dsc_files.source = source.id
1165 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1166 JOIN component ON component.id = files_archive_map.component_id
1167 JOIN files ON files.id = dsc_files.file
1168 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1169 AND source.source='$package'
1170 AND files.filename LIKE '%.dsc';
1172 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1173 my $digester = Digest::SHA->new(256);
1175 my ($vsn,$component,$filename,$sha256sum) = @$_;
1176 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1181 sub canonicalise_suite_sshpsql ($$) {
1182 my ($proto,$data) = @_;
1183 sql_injection_check $isuite;
1184 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1185 SELECT suite.codename
1186 FROM suite where suite_name='$isuite' or codename='$isuite';
1188 @rows = map { $_->[0] } @rows;
1189 fail "unknown suite $isuite" unless @rows;
1190 die "ambiguous $isuite: @rows ?" if @rows>1;
1194 #---------- `dummycat' archive query method ----------
1196 sub canonicalise_suite_dummycat ($$) {
1197 my ($proto,$data) = @_;
1198 my $dpath = "$data/suite.$isuite";
1199 if (!open C, "<", $dpath) {
1200 $!==ENOENT or die "$dpath: $!";
1201 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1205 chomp or die "$dpath: $!";
1207 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1211 sub archive_query_dummycat ($$) {
1212 my ($proto,$data) = @_;
1213 canonicalise_suite();
1214 my $dpath = "$data/package.$csuite.$package";
1215 if (!open C, "<", $dpath) {
1216 $!==ENOENT or die "$dpath: $!";
1217 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1225 printdebug "dummycat query $csuite $package $dpath | $_\n";
1226 my @row = split /\s+/, $_;
1227 @row==2 or die "$dpath: $_ ?";
1230 C->error and die "$dpath: $!";
1232 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1235 #---------- tag format handling ----------
1237 sub access_cfg_tagformats () {
1238 split /\,/, access_cfg('dgit-tag-format');
1241 sub need_tagformat ($$) {
1242 my ($fmt, $why) = @_;
1243 fail "need to use tag format $fmt ($why) but also need".
1244 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1245 " - no way to proceed"
1246 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1247 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1250 sub select_tagformat () {
1252 return if $tagformatfn && !$tagformat_want;
1253 die 'bug' if $tagformatfn && $tagformat_want;
1254 # ... $tagformat_want assigned after previous select_tagformat
1256 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1257 printdebug "select_tagformat supported @supported\n";
1259 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1260 printdebug "select_tagformat specified @$tagformat_want\n";
1262 my ($fmt,$why,$override) = @$tagformat_want;
1264 fail "target distro supports tag formats @supported".
1265 " but have to use $fmt ($why)"
1267 or grep { $_ eq $fmt } @supported;
1269 $tagformat_want = undef;
1271 $tagformatfn = ${*::}{"debiantag_$fmt"};
1273 fail "trying to use unknown tag format \`$fmt' ($why) !"
1274 unless $tagformatfn;
1277 #---------- archive query entrypoints and rest of program ----------
1279 sub canonicalise_suite () {
1280 return if defined $csuite;
1281 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1282 $csuite = archive_query('canonicalise_suite');
1283 if ($isuite ne $csuite) {
1284 progress "canonical suite name for $isuite is $csuite";
1288 sub get_archive_dsc () {
1289 canonicalise_suite();
1290 my @vsns = archive_query('archive_query');
1291 foreach my $vinfo (@vsns) {
1292 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1293 $dscurl = access_cfg('mirror').$subpath;
1294 $dscdata = url_get($dscurl);
1296 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1301 $digester->add($dscdata);
1302 my $got = $digester->hexdigest();
1304 fail "$dscurl has hash $got but".
1305 " archive told us to expect $digest";
1307 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1308 printdebug Dumper($dscdata) if $debuglevel>1;
1309 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1310 printdebug Dumper($dsc) if $debuglevel>1;
1311 my $fmt = getfield $dsc, 'Format';
1312 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1313 "unsupported source format $fmt, sorry";
1315 $dsc_checked = !!$digester;
1316 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1320 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1323 sub check_for_git ();
1324 sub check_for_git () {
1326 my $how = access_cfg('git-check');
1327 if ($how eq 'ssh-cmd') {
1329 (access_cfg_ssh, access_gituserhost(),
1330 access_runeinfo("git-check $package").
1331 " set -e; cd ".access_cfg('git-path').";".
1332 " if test -d $package.git; then echo 1; else echo 0; fi");
1333 my $r= cmdoutput @cmd;
1334 if (defined $r and $r =~ m/^divert (\w+)$/) {
1336 my ($usedistro,) = access_distros();
1337 # NB that if we are pushing, $usedistro will be $distro/push
1338 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1339 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1340 progress "diverting to $divert (using config for $instead_distro)";
1341 return check_for_git();
1343 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1345 } elsif ($how eq 'url') {
1346 my $prefix = access_cfg('git-check-url','git-url');
1347 my $suffix = access_cfg('git-check-suffix','git-suffix',
1348 'RETURN-UNDEF') // '.git';
1349 my $url = "$prefix/$package$suffix";
1350 my @cmd = (@curl, qw(-sS -I), $url);
1351 my $result = cmdoutput @cmd;
1352 $result =~ s/^\S+ 200 .*\n\r?\n//;
1353 # curl -sS -I with https_proxy prints
1354 # HTTP/1.0 200 Connection established
1355 $result =~ m/^\S+ (404|200) /s or
1356 fail "unexpected results from git check query - ".
1357 Dumper($prefix, $result);
1359 if ($code eq '404') {
1361 } elsif ($code eq '200') {
1366 } elsif ($how eq 'true') {
1368 } elsif ($how eq 'false') {
1371 badcfg "unknown git-check \`$how'";
1375 sub create_remote_git_repo () {
1376 my $how = access_cfg('git-create');
1377 if ($how eq 'ssh-cmd') {
1379 (access_cfg_ssh, access_gituserhost(),
1380 access_runeinfo("git-create $package").
1381 "set -e; cd ".access_cfg('git-path').";".
1382 " cp -a _template $package.git");
1383 } elsif ($how eq 'true') {
1386 badcfg "unknown git-create \`$how'";
1390 our ($dsc_hash,$lastpush_mergeinput);
1392 our $ud = '.git/dgit/unpack';
1402 sub mktree_in_ud_here () {
1403 runcmd qw(git init -q);
1404 runcmd qw(git config gc.auto 0);
1405 rmtree('.git/objects');
1406 symlink '../../../../objects','.git/objects' or die $!;
1409 sub git_write_tree () {
1410 my $tree = cmdoutput @git, qw(write-tree);
1411 $tree =~ m/^\w+$/ or die "$tree ?";
1415 sub remove_stray_gits () {
1416 my @gitscmd = qw(find -name .git -prune -print0);
1417 debugcmd "|",@gitscmd;
1418 open GITS, "-|", @gitscmd or die $!;
1423 print STDERR "$us: warning: removing from source package: ",
1424 (messagequote $_), "\n";
1428 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1431 sub mktree_in_ud_from_only_subdir (;$) {
1434 # changes into the subdir
1436 die "expected one subdir but found @dirs ?" unless @dirs==1;
1437 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1441 remove_stray_gits();
1442 mktree_in_ud_here();
1444 my ($format, $fopts) = get_source_format();
1445 if (madformat($format)) {
1450 runcmd @git, qw(add -Af);
1451 my $tree=git_write_tree();
1452 return ($tree,$dir);
1455 our @files_csum_info_fields =
1456 (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1457 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1458 ['Files', 'Digest::MD5', 'new()']);
1460 sub dsc_files_info () {
1461 foreach my $csumi (@files_csum_info_fields) {
1462 my ($fname, $module, $method) = @$csumi;
1463 my $field = $dsc->{$fname};
1464 next unless defined $field;
1465 eval "use $module; 1;" or die $@;
1467 foreach (split /\n/, $field) {
1469 m/^(\w+) (\d+) (\S+)$/ or
1470 fail "could not parse .dsc $fname line \`$_'";
1471 my $digester = eval "$module"."->$method;" or die $@;
1476 Digester => $digester,
1481 fail "missing any supported Checksums-* or Files field in ".
1482 $dsc->get_option('name');
1486 map { $_->{Filename} } dsc_files_info();
1489 sub files_compare_inputs (@) {
1494 my $showinputs = sub {
1495 return join "; ", map { $_->get_option('name') } @$inputs;
1498 foreach my $in (@$inputs) {
1500 my $in_name = $in->get_option('name');
1502 printdebug "files_compare_inputs $in_name\n";
1504 foreach my $csumi (@files_csum_info_fields) {
1505 my ($fname) = @$csumi;
1506 printdebug "files_compare_inputs $in_name $fname\n";
1508 my $field = $in->{$fname};
1509 next unless defined $field;
1512 foreach (split /\n/, $field) {
1515 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1516 fail "could not parse $in_name $fname line \`$_'";
1518 printdebug "files_compare_inputs $in_name $fname $f\n";
1522 my $re = \ $record{$f}{$fname};
1524 $fchecked{$f}{$in_name} = 1;
1526 fail "hash or size of $f varies in $fname fields".
1527 " (between: ".$showinputs->().")";
1532 @files = sort @files;
1533 $expected_files //= \@files;
1534 "@$expected_files" eq "@files" or
1535 fail "file list in $in_name varies between hash fields!";
1538 fail "$in_name has no files list field(s)";
1540 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1543 grep { keys %$_ == @$inputs-1 } values %fchecked
1544 or fail "no file appears in all file lists".
1545 " (looked in: ".$showinputs->().")";
1548 sub is_orig_file_in_dsc ($$) {
1549 my ($f, $dsc_files_info) = @_;
1550 return 0 if @$dsc_files_info <= 1;
1551 # One file means no origs, and the filename doesn't have a "what
1552 # part of dsc" component. (Consider versions ending `.orig'.)
1553 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1557 sub is_orig_file_of_vsn ($$) {
1558 my ($f, $upstreamvsn) = @_;
1559 my $base = srcfn $upstreamvsn, '';
1560 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1564 sub make_commit ($) {
1566 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1569 sub make_commit_text ($) {
1572 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1574 print Dumper($text) if $debuglevel > 1;
1575 my $child = open2($out, $in, @cmd) or die $!;
1578 print $in $text or die $!;
1579 close $in or die $!;
1581 $h =~ m/^\w+$/ or die;
1583 printdebug "=> $h\n";
1586 waitpid $child, 0 == $child or die "$child $!";
1587 $? and failedcmd @cmd;
1591 sub clogp_authline ($) {
1593 my $author = getfield $clogp, 'Maintainer';
1594 $author =~ s#,.*##ms;
1595 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1596 my $authline = "$author $date";
1597 $authline =~ m/$git_authline_re/o or
1598 fail "unexpected commit author line format \`$authline'".
1599 " (was generated from changelog Maintainer field)";
1600 return ($1,$2,$3) if wantarray;
1604 sub vendor_patches_distro ($$) {
1605 my ($checkdistro, $what) = @_;
1606 return unless defined $checkdistro;
1608 my $series = "debian/patches/\L$checkdistro\E.series";
1609 printdebug "checking for vendor-specific $series ($what)\n";
1611 if (!open SERIES, "<", $series) {
1612 die "$series $!" unless $!==ENOENT;
1621 Unfortunately, this source package uses a feature of dpkg-source where
1622 the same source package unpacks to different source code on different
1623 distros. dgit cannot safely operate on such packages on affected
1624 distros, because the meaning of source packages is not stable.
1626 Please ask the distro/maintainer to remove the distro-specific series
1627 files and use a different technique (if necessary, uploading actually
1628 different packages, if different distros are supposed to have
1632 fail "Found active distro-specific series file for".
1633 " $checkdistro ($what): $series, cannot continue";
1635 die "$series $!" if SERIES->error;
1639 sub check_for_vendor_patches () {
1640 # This dpkg-source feature doesn't seem to be documented anywhere!
1641 # But it can be found in the changelog (reformatted):
1643 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1644 # Author: Raphael Hertzog <hertzog@debian.org>
1645 # Date: Sun Oct 3 09:36:48 2010 +0200
1647 # dpkg-source: correctly create .pc/.quilt_series with alternate
1650 # If you have debian/patches/ubuntu.series and you were
1651 # unpacking the source package on ubuntu, quilt was still
1652 # directed to debian/patches/series instead of
1653 # debian/patches/ubuntu.series.
1655 # debian/changelog | 3 +++
1656 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1657 # 2 files changed, 6 insertions(+), 1 deletion(-)
1660 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1661 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1662 "Dpkg::Vendor \`current vendor'");
1663 vendor_patches_distro(access_basedistro(),
1664 "distro being accessed");
1667 sub generate_commits_from_dsc () {
1668 # See big comment in fetch_from_archive, below.
1669 # See also README.dsc-import.
1673 my @dfi = dsc_files_info();
1674 foreach my $fi (@dfi) {
1675 my $f = $fi->{Filename};
1676 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1678 link_ltarget "../../../$f", $f
1682 complete_file_from_dsc('.', $fi)
1685 if (is_orig_file_in_dsc($f, \@dfi)) {
1686 link $f, "../../../../$f"
1692 # We unpack and record the orig tarballs first, so that we only
1693 # need disk space for one private copy of the unpacked source.
1694 # But we can't make them into commits until we have the metadata
1695 # from the debian/changelog, so we record the tree objects now and
1696 # make them into commits later.
1698 my $upstreamv = $dsc->{version};
1699 $upstreamv =~ s/-[^-]+$//;
1700 my $orig_f_base = srcfn $upstreamv, '';
1702 foreach my $fi (@dfi) {
1703 # We actually import, and record as a commit, every tarball
1704 # (unless there is only one file, in which case there seems
1707 my $f = $fi->{Filename};
1708 printdebug "import considering $f ";
1709 (printdebug "only one dfi\n"), next if @dfi == 1;
1710 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1711 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1715 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1717 printdebug "Y ", (join ' ', map { $_//"(none)" }
1718 $compr_ext, $orig_f_part
1721 my $input = new IO::File $f, '<' or die "$f $!";
1725 if (defined $compr_ext) {
1727 Dpkg::Compression::compression_guess_from_filename $f;
1728 fail "Dpkg::Compression cannot handle file $f in source package"
1729 if defined $compr_ext && !defined $cname;
1731 new Dpkg::Compression::Process compression => $cname;
1732 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1733 my $compr_fh = new IO::Handle;
1734 my $compr_pid = open $compr_fh, "-|" // die $!;
1736 open STDIN, "<&", $input or die $!;
1738 die "dgit (child): exec $compr_cmd[0]: $!\n";
1743 rmtree "../unpack-tar";
1744 mkdir "../unpack-tar" or die $!;
1745 my @tarcmd = qw(tar -x -f -
1746 --no-same-owner --no-same-permissions
1747 --no-acls --no-xattrs --no-selinux);
1748 my $tar_pid = fork // die $!;
1750 chdir "../unpack-tar" or die $!;
1751 open STDIN, "<&", $input or die $!;
1753 die "dgit (child): exec $tarcmd[0]: $!";
1755 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1756 !$? or failedcmd @tarcmd;
1759 (@compr_cmd ? failedcmd @compr_cmd
1761 # finally, we have the results in "tarball", but maybe
1762 # with the wrong permissions
1764 runcmd qw(chmod -R +rwX ../unpack-tar);
1765 changedir "../unpack-tar";
1766 my ($tree) = mktree_in_ud_from_only_subdir(1);
1767 changedir "../../unpack";
1768 rmtree "../unpack-tar";
1770 my $ent = [ $f, $tree ];
1772 Orig => !!$orig_f_part,
1773 Sort => (!$orig_f_part ? 2 :
1774 $orig_f_part =~ m/-/g ? 1 :
1782 # put any without "_" first (spec is not clear whether files
1783 # are always in the usual order). Tarballs without "_" are
1784 # the main orig or the debian tarball.
1785 $a->{Sort} <=> $b->{Sort} or
1789 my $any_orig = grep { $_->{Orig} } @tartrees;
1791 my $dscfn = "$package.dsc";
1793 my $treeimporthow = 'package';
1795 open D, ">", $dscfn or die "$dscfn: $!";
1796 print D $dscdata or die "$dscfn: $!";
1797 close D or die "$dscfn: $!";
1798 my @cmd = qw(dpkg-source);
1799 push @cmd, '--no-check' if $dsc_checked;
1800 if (madformat $dsc->{format}) {
1801 push @cmd, '--skip-patches';
1802 $treeimporthow = 'unpatched';
1804 push @cmd, qw(-x --), $dscfn;
1807 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1808 if (madformat $dsc->{format}) {
1809 check_for_vendor_patches();
1813 if (madformat $dsc->{format}) {
1814 my @pcmd = qw(dpkg-source --before-build .);
1815 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1817 runcmd @git, qw(add -Af);
1818 $dappliedtree = git_write_tree();
1821 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1822 debugcmd "|",@clogcmd;
1823 open CLOGS, "-|", @clogcmd or die $!;
1828 printdebug "import clog search...\n";
1831 my $stanzatext = do { local $/=""; <CLOGS>; };
1832 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1833 last if !defined $stanzatext;
1835 my $desc = "package changelog, entry no.$.";
1836 open my $stanzafh, "<", \$stanzatext or die;
1837 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1838 $clogp //= $thisstanza;
1840 printdebug "import clog $thisstanza->{version} $desc...\n";
1842 last if !$any_orig; # we don't need $r1clogp
1844 # We look for the first (most recent) changelog entry whose
1845 # version number is lower than the upstream version of this
1846 # package. Then the last (least recent) previous changelog
1847 # entry is treated as the one which introduced this upstream
1848 # version and used for the synthetic commits for the upstream
1851 # One might think that a more sophisticated algorithm would be
1852 # necessary. But: we do not want to scan the whole changelog
1853 # file. Stopping when we see an earlier version, which
1854 # necessarily then is an earlier upstream version, is the only
1855 # realistic way to do that. Then, either the earliest
1856 # changelog entry we have seen so far is indeed the earliest
1857 # upload of this upstream version; or there are only changelog
1858 # entries relating to later upstream versions (which is not
1859 # possible unless the changelog and .dsc disagree about the
1860 # version). Then it remains to choose between the physically
1861 # last entry in the file, and the one with the lowest version
1862 # number. If these are not the same, we guess that the
1863 # versions were created in a non-monotic order rather than
1864 # that the changelog entries have been misordered.
1866 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1868 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1869 $r1clogp = $thisstanza;
1871 printdebug "import clog $r1clogp->{version} becomes r1\n";
1873 die $! if CLOGS->error;
1874 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
1876 $clogp or fail "package changelog has no entries!";
1878 my $authline = clogp_authline $clogp;
1879 my $changes = getfield $clogp, 'Changes';
1880 my $cversion = getfield $clogp, 'Version';
1883 $r1clogp //= $clogp; # maybe there's only one entry;
1884 my $r1authline = clogp_authline $r1clogp;
1885 # Strictly, r1authline might now be wrong if it's going to be
1886 # unused because !$any_orig. Whatever.
1888 printdebug "import tartrees authline $authline\n";
1889 printdebug "import tartrees r1authline $r1authline\n";
1891 foreach my $tt (@tartrees) {
1892 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1894 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1897 committer $r1authline
1901 [dgit import orig $tt->{F}]
1909 [dgit import tarball $package $cversion $tt->{F}]
1914 printdebug "import main commit\n";
1916 open C, ">../commit.tmp" or die $!;
1917 print C <<END or die $!;
1920 print C <<END or die $! foreach @tartrees;
1923 print C <<END or die $!;
1929 [dgit import $treeimporthow $package $cversion]
1933 my $rawimport_hash = make_commit qw(../commit.tmp);
1935 if (madformat $dsc->{format}) {
1936 printdebug "import apply patches...\n";
1938 # regularise the state of the working tree so that
1939 # the checkout of $rawimport_hash works nicely.
1940 my $dappliedcommit = make_commit_text(<<END);
1947 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1949 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1951 # We need the answers to be reproducible
1952 my @authline = clogp_authline($clogp);
1953 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1954 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1955 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1956 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1957 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1958 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1960 my $path = $ENV{PATH} or die;
1962 foreach my $use_absurd (qw(0 1)) {
1963 local $ENV{PATH} = $path;
1966 progress "warning: $@";
1967 $path = "$absurdity:$path";
1968 progress "$us: trying slow absurd-git-apply...";
1969 rename "../../gbp-pq-output","../../gbp-pq-output.0"
1973 local $ENV{PATH} = $path if $use_absurd;
1975 my @showcmd = (gbp_pq, qw(import));
1976 my @realcmd = shell_cmd
1977 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
1978 debugcmd "+",@realcmd;
1979 if (system @realcmd) {
1980 die +(shellquote @showcmd).
1982 failedcmd_waitstatus()."\n";
1985 my $gapplied = git_rev_parse('HEAD');
1986 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1987 $gappliedtree eq $dappliedtree or
1989 gbp-pq import and dpkg-source disagree!
1990 gbp-pq import gave commit $gapplied
1991 gbp-pq import gave tree $gappliedtree
1992 dpkg-source --before-build gave tree $dappliedtree
1994 $rawimport_hash = $gapplied;
1999 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2004 progress "synthesised git commit from .dsc $cversion";
2006 my $rawimport_mergeinput = {
2007 Commit => $rawimport_hash,
2008 Info => "Import of source package",
2010 my @output = ($rawimport_mergeinput);
2012 if ($lastpush_mergeinput) {
2013 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2014 my $oversion = getfield $oldclogp, 'Version';
2016 version_compare($oversion, $cversion);
2018 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2019 { Message => <<END, ReverseParents => 1 });
2020 Record $package ($cversion) in archive suite $csuite
2022 } elsif ($vcmp > 0) {
2023 print STDERR <<END or die $!;
2025 Version actually in archive: $cversion (older)
2026 Last version pushed with dgit: $oversion (newer or same)
2029 @output = $lastpush_mergeinput;
2031 # Same version. Use what's in the server git branch,
2032 # discarding our own import. (This could happen if the
2033 # server automatically imports all packages into git.)
2034 @output = $lastpush_mergeinput;
2037 changedir '../../../..';
2042 sub complete_file_from_dsc ($$) {
2043 our ($dstdir, $fi) = @_;
2044 # Ensures that we have, in $dir, the file $fi, with the correct
2045 # contents. (Downloading it from alongside $dscurl if necessary.)
2047 my $f = $fi->{Filename};
2048 my $tf = "$dstdir/$f";
2051 if (stat_exists $tf) {
2052 progress "using existing $f";
2055 $furl =~ s{/[^/]+$}{};
2057 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2058 die "$f ?" if $f =~ m#/#;
2059 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2060 return 0 if !act_local();
2064 open F, "<", "$tf" or die "$tf: $!";
2065 $fi->{Digester}->reset();
2066 $fi->{Digester}->addfile(*F);
2067 F->error and die $!;
2068 my $got = $fi->{Digester}->hexdigest();
2069 $got eq $fi->{Hash} or
2070 fail "file $f has hash $got but .dsc".
2071 " demands hash $fi->{Hash} ".
2072 ($downloaded ? "(got wrong file from archive!)"
2073 : "(perhaps you should delete this file?)");
2078 sub ensure_we_have_orig () {
2079 my @dfi = dsc_files_info();
2080 foreach my $fi (@dfi) {
2081 my $f = $fi->{Filename};
2082 next unless is_orig_file_in_dsc($f, \@dfi);
2083 complete_file_from_dsc('..', $fi)
2088 sub git_fetch_us () {
2089 # Want to fetch only what we are going to use, unless
2090 # deliberately-not-ff, in which case we must fetch everything.
2092 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2094 (quiltmode_splitbrain
2095 ? (map { $_->('*',access_basedistro) }
2096 \&debiantag_new, \&debiantag_maintview)
2097 : debiantags('*',access_basedistro));
2098 push @specs, server_branch($csuite);
2099 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2101 # This is rather miserable:
2102 # When git fetch --prune is passed a fetchspec ending with a *,
2103 # it does a plausible thing. If there is no * then:
2104 # - it matches subpaths too, even if the supplied refspec
2105 # starts refs, and behaves completely madly if the source
2106 # has refs/refs/something. (See, for example, Debian #NNNN.)
2107 # - if there is no matching remote ref, it bombs out the whole
2109 # We want to fetch a fixed ref, and we don't know in advance
2110 # if it exists, so this is not suitable.
2112 # Our workaround is to use git ls-remote. git ls-remote has its
2113 # own qairks. Notably, it has the absurd multi-tail-matching
2114 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2115 # refs/refs/foo etc.
2117 # Also, we want an idempotent snapshot, but we have to make two
2118 # calls to the remote: one to git ls-remote and to git fetch. The
2119 # solution is use git ls-remote to obtain a target state, and
2120 # git fetch to try to generate it. If we don't manage to generate
2121 # the target state, we try again.
2123 my $specre = join '|', map {
2129 printdebug "git_fetch_us specre=$specre\n";
2130 my $wanted_rref = sub {
2132 return m/^(?:$specre)$/o;
2135 my $fetch_iteration = 0;
2138 if (++$fetch_iteration > 10) {
2139 fail "too many iterations trying to get sane fetch!";
2142 my @look = map { "refs/$_" } @specs;
2143 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2147 open GITLS, "-|", @lcmd or die $!;
2149 printdebug "=> ", $_;
2150 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2151 my ($objid,$rrefname) = ($1,$2);
2152 if (!$wanted_rref->($rrefname)) {
2154 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2158 $wantr{$rrefname} = $objid;
2161 close GITLS or failedcmd @lcmd;
2163 # OK, now %want is exactly what we want for refs in @specs
2165 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2166 "+refs/$_:".lrfetchrefs."/$_";
2169 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2170 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2173 %lrfetchrefs_f = ();
2176 git_for_each_ref(lrfetchrefs, sub {
2177 my ($objid,$objtype,$lrefname,$reftail) = @_;
2178 $lrfetchrefs_f{$lrefname} = $objid;
2179 $objgot{$objid} = 1;
2182 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2183 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2184 if (!exists $wantr{$rrefname}) {
2185 if ($wanted_rref->($rrefname)) {
2187 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2191 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2194 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2195 delete $lrfetchrefs_f{$lrefname};
2199 foreach my $rrefname (sort keys %wantr) {
2200 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2201 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2202 my $want = $wantr{$rrefname};
2203 next if $got eq $want;
2204 if (!defined $objgot{$want}) {
2206 warning: git ls-remote suggests we want $lrefname
2207 warning: and it should refer to $want
2208 warning: but git fetch didn't fetch that object to any relevant ref.
2209 warning: This may be due to a race with someone updating the server.
2210 warning: Will try again...
2212 next FETCH_ITERATION;
2215 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2217 runcmd_ordryrun_local @git, qw(update-ref -m),
2218 "dgit fetch git fetch fixup", $lrefname, $want;
2219 $lrfetchrefs_f{$lrefname} = $want;
2223 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2224 Dumper(\%lrfetchrefs_f);
2227 my @tagpats = debiantags('*',access_basedistro);
2229 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2230 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2231 printdebug "currently $fullrefname=$objid\n";
2232 $here{$fullrefname} = $objid;
2234 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2235 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2236 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2237 printdebug "offered $lref=$objid\n";
2238 if (!defined $here{$lref}) {
2239 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2240 runcmd_ordryrun_local @upd;
2241 lrfetchref_used $fullrefname;
2242 } elsif ($here{$lref} eq $objid) {
2243 lrfetchref_used $fullrefname;
2246 "Not updateting $lref from $here{$lref} to $objid.\n";
2251 sub mergeinfo_getclogp ($) {
2252 # Ensures thit $mi->{Clogp} exists and returns it
2254 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2257 sub mergeinfo_version ($) {
2258 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2261 sub fetch_from_archive () {
2262 ensure_setup_existing_tree();
2264 # Ensures that lrref() is what is actually in the archive, one way
2265 # or another, according to us - ie this client's
2266 # appropritaely-updated archive view. Also returns the commit id.
2267 # If there is nothing in the archive, leaves lrref alone and
2268 # returns undef. git_fetch_us must have already been called.
2272 foreach my $field (@ourdscfield) {
2273 $dsc_hash = $dsc->{$field};
2274 last if defined $dsc_hash;
2276 if (defined $dsc_hash) {
2277 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2279 progress "last upload to archive specified git hash";
2281 progress "last upload to archive has NO git hash";
2284 progress "no version available from the archive";
2287 # If the archive's .dsc has a Dgit field, there are three
2288 # relevant git commitids we need to choose between and/or merge
2290 # 1. $dsc_hash: the Dgit field from the archive
2291 # 2. $lastpush_hash: the suite branch on the dgit git server
2292 # 3. $lastfetch_hash: our local tracking brach for the suite
2294 # These may all be distinct and need not be in any fast forward
2297 # If the dsc was pushed to this suite, then the server suite
2298 # branch will have been updated; but it might have been pushed to
2299 # a different suite and copied by the archive. Conversely a more
2300 # recent version may have been pushed with dgit but not appeared
2301 # in the archive (yet).
2303 # $lastfetch_hash may be awkward because archive imports
2304 # (particularly, imports of Dgit-less .dscs) are performed only as
2305 # needed on individual clients, so different clients may perform a
2306 # different subset of them - and these imports are only made
2307 # public during push. So $lastfetch_hash may represent a set of
2308 # imports different to a subsequent upload by a different dgit
2311 # Our approach is as follows:
2313 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2314 # descendant of $dsc_hash, then it was pushed by a dgit user who
2315 # had based their work on $dsc_hash, so we should prefer it.
2316 # Otherwise, $dsc_hash was installed into this suite in the
2317 # archive other than by a dgit push, and (necessarily) after the
2318 # last dgit push into that suite (since a dgit push would have
2319 # been descended from the dgit server git branch); thus, in that
2320 # case, we prefer the archive's version (and produce a
2321 # pseudo-merge to overwrite the dgit server git branch).
2323 # (If there is no Dgit field in the archive's .dsc then
2324 # generate_commit_from_dsc uses the version numbers to decide
2325 # whether the suite branch or the archive is newer. If the suite
2326 # branch is newer it ignores the archive's .dsc; otherwise it
2327 # generates an import of the .dsc, and produces a pseudo-merge to
2328 # overwrite the suite branch with the archive contents.)
2330 # The outcome of that part of the algorithm is the `public view',
2331 # and is same for all dgit clients: it does not depend on any
2332 # unpublished history in the local tracking branch.
2334 # As between the public view and the local tracking branch: The
2335 # local tracking branch is only updated by dgit fetch, and
2336 # whenever dgit fetch runs it includes the public view in the
2337 # local tracking branch. Therefore if the public view is not
2338 # descended from the local tracking branch, the local tracking
2339 # branch must contain history which was imported from the archive
2340 # but never pushed; and, its tip is now out of date. So, we make
2341 # a pseudo-merge to overwrite the old imports and stitch the old
2344 # Finally: we do not necessarily reify the public view (as
2345 # described above). This is so that we do not end up stacking two
2346 # pseudo-merges. So what we actually do is figure out the inputs
2347 # to any public view pseudo-merge and put them in @mergeinputs.
2350 # $mergeinputs[]{Commit}
2351 # $mergeinputs[]{Info}
2352 # $mergeinputs[0] is the one whose tree we use
2353 # @mergeinputs is in the order we use in the actual commit)
2356 # $mergeinputs[]{Message} is a commit message to use
2357 # $mergeinputs[]{ReverseParents} if def specifies that parent
2358 # list should be in opposite order
2359 # Such an entry has no Commit or Info. It applies only when found
2360 # in the last entry. (This ugliness is to support making
2361 # identical imports to previous dgit versions.)
2363 my $lastpush_hash = git_get_ref(lrfetchref());
2364 printdebug "previous reference hash=$lastpush_hash\n";
2365 $lastpush_mergeinput = $lastpush_hash && {
2366 Commit => $lastpush_hash,
2367 Info => "dgit suite branch on dgit git server",
2370 my $lastfetch_hash = git_get_ref(lrref());
2371 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2372 my $lastfetch_mergeinput = $lastfetch_hash && {
2373 Commit => $lastfetch_hash,
2374 Info => "dgit client's archive history view",
2377 my $dsc_mergeinput = $dsc_hash && {
2378 Commit => $dsc_hash,
2379 Info => "Dgit field in .dsc from archive",
2383 my $del_lrfetchrefs = sub {
2386 printdebug "del_lrfetchrefs...\n";
2387 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2388 my $objid = $lrfetchrefs_d{$fullrefname};
2389 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2391 $gur ||= new IO::Handle;
2392 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2394 printf $gur "delete %s %s\n", $fullrefname, $objid;
2397 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2401 if (defined $dsc_hash) {
2402 fail "missing remote git history even though dsc has hash -".
2403 " could not find ref ".rref()." at ".access_giturl()
2404 unless $lastpush_hash;
2405 ensure_we_have_orig();
2406 if ($dsc_hash eq $lastpush_hash) {
2407 @mergeinputs = $dsc_mergeinput
2408 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2409 print STDERR <<END or die $!;
2411 Git commit in archive is behind the last version allegedly pushed/uploaded.
2412 Commit referred to by archive: $dsc_hash
2413 Last version pushed with dgit: $lastpush_hash
2416 @mergeinputs = ($lastpush_mergeinput);
2418 # Archive has .dsc which is not a descendant of the last dgit
2419 # push. This can happen if the archive moves .dscs about.
2420 # Just follow its lead.
2421 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2422 progress "archive .dsc names newer git commit";
2423 @mergeinputs = ($dsc_mergeinput);
2425 progress "archive .dsc names other git commit, fixing up";
2426 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2430 @mergeinputs = generate_commits_from_dsc();
2431 # We have just done an import. Now, our import algorithm might
2432 # have been improved. But even so we do not want to generate
2433 # a new different import of the same package. So if the
2434 # version numbers are the same, just use our existing version.
2435 # If the version numbers are different, the archive has changed
2436 # (perhaps, rewound).
2437 if ($lastfetch_mergeinput &&
2438 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2439 (mergeinfo_version $mergeinputs[0]) )) {
2440 @mergeinputs = ($lastfetch_mergeinput);
2442 } elsif ($lastpush_hash) {
2443 # only in git, not in the archive yet
2444 @mergeinputs = ($lastpush_mergeinput);
2445 print STDERR <<END or die $!;
2447 Package not found in the archive, but has allegedly been pushed using dgit.
2451 printdebug "nothing found!\n";
2452 if (defined $skew_warning_vsn) {
2453 print STDERR <<END or die $!;
2455 Warning: relevant archive skew detected.
2456 Archive allegedly contains $skew_warning_vsn
2457 But we were not able to obtain any version from the archive or git.
2461 unshift @end, $del_lrfetchrefs;
2465 if ($lastfetch_hash &&
2467 my $h = $_->{Commit};
2468 $h and is_fast_fwd($lastfetch_hash, $h);
2469 # If true, one of the existing parents of this commit
2470 # is a descendant of the $lastfetch_hash, so we'll
2471 # be ff from that automatically.
2475 push @mergeinputs, $lastfetch_mergeinput;
2478 printdebug "fetch mergeinfos:\n";
2479 foreach my $mi (@mergeinputs) {
2481 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2483 printdebug sprintf " ReverseParents=%d Message=%s",
2484 $mi->{ReverseParents}, $mi->{Message};
2488 my $compat_info= pop @mergeinputs
2489 if $mergeinputs[$#mergeinputs]{Message};
2491 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2494 if (@mergeinputs > 1) {
2496 my $tree_commit = $mergeinputs[0]{Commit};
2498 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2499 $tree =~ m/\n\n/; $tree = $`;
2500 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2503 # We use the changelog author of the package in question the
2504 # author of this pseudo-merge. This is (roughly) correct if
2505 # this commit is simply representing aa non-dgit upload.
2506 # (Roughly because it does not record sponsorship - but we
2507 # don't have sponsorship info because that's in the .changes,
2508 # which isn't in the archivw.)
2510 # But, it might be that we are representing archive history
2511 # updates (including in-archive copies). These are not really
2512 # the responsibility of the person who created the .dsc, but
2513 # there is no-one whose name we should better use. (The
2514 # author of the .dsc-named commit is clearly worse.)
2516 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2517 my $author = clogp_authline $useclogp;
2518 my $cversion = getfield $useclogp, 'Version';
2520 my $mcf = ".git/dgit/mergecommit";
2521 open MC, ">", $mcf or die "$mcf $!";
2522 print MC <<END or die $!;
2526 my @parents = grep { $_->{Commit} } @mergeinputs;
2527 @parents = reverse @parents if $compat_info->{ReverseParents};
2528 print MC <<END or die $! foreach @parents;
2532 print MC <<END or die $!;
2538 if (defined $compat_info->{Message}) {
2539 print MC $compat_info->{Message} or die $!;
2541 print MC <<END or die $!;
2542 Record $package ($cversion) in archive suite $csuite
2546 my $message_add_info = sub {
2548 my $mversion = mergeinfo_version $mi;
2549 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2553 $message_add_info->($mergeinputs[0]);
2554 print MC <<END or die $!;
2555 should be treated as descended from
2557 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2561 $hash = make_commit $mcf;
2563 $hash = $mergeinputs[0]{Commit};
2565 printdebug "fetch hash=$hash\n";
2568 my ($lasth, $what) = @_;
2569 return unless $lasth;
2570 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2573 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2574 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2576 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2577 'DGIT_ARCHIVE', $hash;
2578 cmdoutput @git, qw(log -n2), $hash;
2579 # ... gives git a chance to complain if our commit is malformed
2581 if (defined $skew_warning_vsn) {
2583 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2584 my $gotclogp = commit_getclogp($hash);
2585 my $got_vsn = getfield $gotclogp, 'Version';
2586 printdebug "SKEW CHECK GOT $got_vsn\n";
2587 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2588 print STDERR <<END or die $!;
2590 Warning: archive skew detected. Using the available version:
2591 Archive allegedly contains $skew_warning_vsn
2592 We were able to obtain only $got_vsn
2598 if ($lastfetch_hash ne $hash) {
2599 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2603 dryrun_report @upd_cmd;
2607 lrfetchref_used lrfetchref();
2609 unshift @end, $del_lrfetchrefs;
2613 sub set_local_git_config ($$) {
2615 runcmd @git, qw(config), $k, $v;
2618 sub setup_mergechangelogs (;$) {
2620 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2622 my $driver = 'dpkg-mergechangelogs';
2623 my $cb = "merge.$driver";
2624 my $attrs = '.git/info/attributes';
2625 ensuredir '.git/info';
2627 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2628 if (!open ATTRS, "<", $attrs) {
2629 $!==ENOENT or die "$attrs: $!";
2633 next if m{^debian/changelog\s};
2634 print NATTRS $_, "\n" or die $!;
2636 ATTRS->error and die $!;
2639 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2642 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2643 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2645 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2648 sub setup_useremail (;$) {
2650 return unless $always || access_cfg_bool(1, 'setup-useremail');
2653 my ($k, $envvar) = @_;
2654 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2655 return unless defined $v;
2656 set_local_git_config "user.$k", $v;
2659 $setup->('email', 'DEBEMAIL');
2660 $setup->('name', 'DEBFULLNAME');
2663 sub ensure_setup_existing_tree () {
2664 my $k = "remote.$remotename.skipdefaultupdate";
2665 my $c = git_get_config $k;
2666 return if defined $c;
2667 set_local_git_config $k, 'true';
2670 sub setup_new_tree () {
2671 setup_mergechangelogs();
2677 canonicalise_suite();
2678 badusage "dry run makes no sense with clone" unless act_local();
2679 my $hasgit = check_for_git();
2680 mkdir $dstdir or fail "create \`$dstdir': $!";
2682 runcmd @git, qw(init -q);
2683 my $giturl = access_giturl(1);
2684 if (defined $giturl) {
2685 open H, "> .git/HEAD" or die $!;
2686 print H "ref: ".lref()."\n" or die $!;
2688 runcmd @git, qw(remote add), 'origin', $giturl;
2691 progress "fetching existing git history";
2693 runcmd_ordryrun_local @git, qw(fetch origin);
2695 progress "starting new git history";
2697 fetch_from_archive() or no_such_package;
2698 my $vcsgiturl = $dsc->{'Vcs-Git'};
2699 if (length $vcsgiturl) {
2700 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2701 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2704 runcmd @git, qw(reset --hard), lrref();
2705 printdone "ready for work in $dstdir";
2709 if (check_for_git()) {
2712 fetch_from_archive() or no_such_package();
2713 printdone "fetched into ".lrref();
2718 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2720 printdone "fetched to ".lrref()." and merged into HEAD";
2723 sub check_not_dirty () {
2724 foreach my $f (qw(local-options local-patch-header)) {
2725 if (stat_exists "debian/source/$f") {
2726 fail "git tree contains debian/source/$f";
2730 return if $ignoredirty;
2732 my @cmd = (@git, qw(diff --quiet HEAD));
2734 $!=0; $?=-1; system @cmd;
2737 fail "working tree is dirty (does not match HEAD)";
2743 sub commit_admin ($) {
2746 runcmd_ordryrun_local @git, qw(commit -m), $m;
2749 sub commit_quilty_patch () {
2750 my $output = cmdoutput @git, qw(status --porcelain);
2752 foreach my $l (split /\n/, $output) {
2753 next unless $l =~ m/\S/;
2754 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2758 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2760 progress "nothing quilty to commit, ok.";
2763 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2764 runcmd_ordryrun_local @git, qw(add -f), @adds;
2766 Commit Debian 3.0 (quilt) metadata
2768 [dgit ($our_version) quilt-fixup]
2772 sub get_source_format () {
2774 if (open F, "debian/source/options") {
2778 s/\s+$//; # ignore missing final newline
2780 my ($k, $v) = ($`, $'); #');
2781 $v =~ s/^"(.*)"$/$1/;
2787 F->error and die $!;
2790 die $! unless $!==&ENOENT;
2793 if (!open F, "debian/source/format") {
2794 die $! unless $!==&ENOENT;
2798 F->error and die $!;
2800 return ($_, \%options);
2803 sub madformat_wantfixup ($) {
2805 return 0 unless $format eq '3.0 (quilt)';
2806 our $quilt_mode_warned;
2807 if ($quilt_mode eq 'nocheck') {
2808 progress "Not doing any fixup of \`$format' due to".
2809 " ----no-quilt-fixup or --quilt=nocheck"
2810 unless $quilt_mode_warned++;
2813 progress "Format \`$format', need to check/update patch stack"
2814 unless $quilt_mode_warned++;
2818 # An "infopair" is a tuple [ $thing, $what ]
2819 # (often $thing is a commit hash; $what is a description)
2821 sub infopair_cond_equal ($$) {
2823 $x->[0] eq $y->[0] or fail <<END;
2824 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2828 sub infopair_lrf_tag_lookup ($$) {
2829 my ($tagnames, $what) = @_;
2830 # $tagname may be an array ref
2831 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2832 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2833 foreach my $tagname (@tagnames) {
2834 my $lrefname = lrfetchrefs."/tags/$tagname";
2835 my $tagobj = $lrfetchrefs_f{$lrefname};
2836 next unless defined $tagobj;
2837 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2838 return [ git_rev_parse($tagobj), $what ];
2840 fail @tagnames==1 ? <<END : <<END;
2841 Wanted tag $what (@tagnames) on dgit server, but not found
2843 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2847 sub infopair_cond_ff ($$) {
2848 my ($anc,$desc) = @_;
2849 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2850 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2854 sub pseudomerge_version_check ($$) {
2855 my ($clogp, $archive_hash) = @_;
2857 my $arch_clogp = commit_getclogp $archive_hash;
2858 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2859 'version currently in archive' ];
2860 if (defined $overwrite_version) {
2861 if (length $overwrite_version) {
2862 infopair_cond_equal([ $overwrite_version,
2863 '--overwrite= version' ],
2866 my $v = $i_arch_v->[0];
2867 progress "Checking package changelog for archive version $v ...";
2869 my @xa = ("-f$v", "-t$v");
2870 my $vclogp = parsechangelog @xa;
2871 my $cv = [ (getfield $vclogp, 'Version'),
2872 "Version field from dpkg-parsechangelog @xa" ];
2873 infopair_cond_equal($i_arch_v, $cv);
2876 $@ =~ s/^dgit: //gm;
2878 "Perhaps debian/changelog does not mention $v ?";
2883 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2887 sub pseudomerge_make_commit ($$$$ $$) {
2888 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2889 $msg_cmd, $msg_msg) = @_;
2890 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2892 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2893 my $authline = clogp_authline $clogp;
2897 !defined $overwrite_version ? ""
2898 : !length $overwrite_version ? " --overwrite"
2899 : " --overwrite=".$overwrite_version;
2902 my $pmf = ".git/dgit/pseudomerge";
2903 open MC, ">", $pmf or die "$pmf $!";
2904 print MC <<END or die $!;
2907 parent $archive_hash
2917 return make_commit($pmf);
2920 sub splitbrain_pseudomerge ($$$$) {
2921 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2922 # => $merged_dgitview
2923 printdebug "splitbrain_pseudomerge...\n";
2925 # We: debian/PREVIOUS HEAD($maintview)
2926 # expect: o ----------------- o
2929 # a/d/PREVIOUS $dgitview
2932 # we do: `------------------ o
2936 printdebug "splitbrain_pseudomerge...\n";
2938 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2940 return $dgitview unless defined $archive_hash;
2942 if (!defined $overwrite_version) {
2943 progress "Checking that HEAD inciudes all changes in archive...";
2946 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2948 if (defined $overwrite_version) {
2950 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2951 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2952 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2953 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2954 my $i_archive = [ $archive_hash, "current archive contents" ];
2956 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2958 infopair_cond_equal($i_dgit, $i_archive);
2959 infopair_cond_ff($i_dep14, $i_dgit);
2960 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2964 $us: check failed (maybe --overwrite is needed, consult documentation)
2969 my $r = pseudomerge_make_commit
2970 $clogp, $dgitview, $archive_hash, $i_arch_v,
2971 "dgit --quilt=$quilt_mode",
2972 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2973 Declare fast forward from $i_arch_v->[0]
2975 Make fast forward from $i_arch_v->[0]
2978 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2982 sub plain_overwrite_pseudomerge ($$$) {
2983 my ($clogp, $head, $archive_hash) = @_;
2985 printdebug "plain_overwrite_pseudomerge...";
2987 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2989 return $head if is_fast_fwd $archive_hash, $head;
2991 my $m = "Declare fast forward from $i_arch_v->[0]";
2993 my $r = pseudomerge_make_commit
2994 $clogp, $head, $archive_hash, $i_arch_v,
2997 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2999 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3003 sub push_parse_changelog ($) {
3006 my $clogp = Dpkg::Control::Hash->new();
3007 $clogp->load($clogpfn) or die;
3009 $package = getfield $clogp, 'Source';
3010 my $cversion = getfield $clogp, 'Version';
3011 my $tag = debiantag($cversion, access_basedistro);
3012 runcmd @git, qw(check-ref-format), $tag;
3014 my $dscfn = dscfn($cversion);
3016 return ($clogp, $cversion, $dscfn);
3019 sub push_parse_dsc ($$$) {
3020 my ($dscfn,$dscfnwhat, $cversion) = @_;
3021 $dsc = parsecontrol($dscfn,$dscfnwhat);
3022 my $dversion = getfield $dsc, 'Version';
3023 my $dscpackage = getfield $dsc, 'Source';
3024 ($dscpackage eq $package && $dversion eq $cversion) or
3025 fail "$dscfn is for $dscpackage $dversion".
3026 " but debian/changelog is for $package $cversion";
3029 sub push_tagwants ($$$$) {
3030 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3033 TagFn => \&debiantag,
3038 if (defined $maintviewhead) {
3040 TagFn => \&debiantag_maintview,
3041 Objid => $maintviewhead,
3042 TfSuffix => '-maintview',
3046 foreach my $tw (@tagwants) {
3047 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3048 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3050 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3054 sub push_mktags ($$ $$ $) {
3056 $changesfile,$changesfilewhat,
3059 die unless $tagwants->[0]{View} eq 'dgit';
3061 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3062 $dsc->save("$dscfn.tmp") or die $!;
3064 my $changes = parsecontrol($changesfile,$changesfilewhat);
3065 foreach my $field (qw(Source Distribution Version)) {
3066 $changes->{$field} eq $clogp->{$field} or
3067 fail "changes field $field \`$changes->{$field}'".
3068 " does not match changelog \`$clogp->{$field}'";
3071 my $cversion = getfield $clogp, 'Version';
3072 my $clogsuite = getfield $clogp, 'Distribution';
3074 # We make the git tag by hand because (a) that makes it easier
3075 # to control the "tagger" (b) we can do remote signing
3076 my $authline = clogp_authline $clogp;
3077 my $delibs = join(" ", "",@deliberatelies);
3078 my $declaredistro = access_basedistro();
3082 my $tfn = $tw->{Tfn};
3083 my $head = $tw->{Objid};
3084 my $tag = $tw->{Tag};
3086 open TO, '>', $tfn->('.tmp') or die $!;
3087 print TO <<END or die $!;
3094 if ($tw->{View} eq 'dgit') {
3095 print TO <<END or die $!;
3096 $package release $cversion for $clogsuite ($csuite) [dgit]
3097 [dgit distro=$declaredistro$delibs]
3099 foreach my $ref (sort keys %previously) {
3100 print TO <<END or die $!;
3101 [dgit previously:$ref=$previously{$ref}]
3104 } elsif ($tw->{View} eq 'maint') {
3105 print TO <<END or die $!;
3106 $package release $cversion for $clogsuite ($csuite)
3107 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3110 die Dumper($tw)."?";
3115 my $tagobjfn = $tfn->('.tmp');
3117 if (!defined $keyid) {
3118 $keyid = access_cfg('keyid','RETURN-UNDEF');
3120 if (!defined $keyid) {
3121 $keyid = getfield $clogp, 'Maintainer';
3123 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3124 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3125 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3126 push @sign_cmd, $tfn->('.tmp');
3127 runcmd_ordryrun @sign_cmd;
3129 $tagobjfn = $tfn->('.signed.tmp');
3130 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3131 $tfn->('.tmp'), $tfn->('.tmp.asc');
3137 my @r = map { $mktag->($_); } @$tagwants;
3141 sub sign_changes ($) {
3142 my ($changesfile) = @_;
3144 my @debsign_cmd = @debsign;
3145 push @debsign_cmd, "-k$keyid" if defined $keyid;
3146 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3147 push @debsign_cmd, $changesfile;
3148 runcmd_ordryrun @debsign_cmd;
3153 printdebug "actually entering push\n";
3155 supplementary_message(<<'END');
3156 Push failed, while checking state of the archive.
3157 You can retry the push, after fixing the problem, if you like.
3159 if (check_for_git()) {
3162 my $archive_hash = fetch_from_archive();
3163 if (!$archive_hash) {
3165 fail "package appears to be new in this suite;".
3166 " if this is intentional, use --new";
3169 supplementary_message(<<'END');
3170 Push failed, while preparing your push.
3171 You can retry the push, after fixing the problem, if you like.
3174 need_tagformat 'new', "quilt mode $quilt_mode"
3175 if quiltmode_splitbrain;
3179 access_giturl(); # check that success is vaguely likely
3182 my $clogpfn = ".git/dgit/changelog.822.tmp";
3183 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3185 responder_send_file('parsed-changelog', $clogpfn);
3187 my ($clogp, $cversion, $dscfn) =
3188 push_parse_changelog("$clogpfn");
3190 my $dscpath = "$buildproductsdir/$dscfn";
3191 stat_exists $dscpath or
3192 fail "looked for .dsc $dscfn, but $!;".
3193 " maybe you forgot to build";
3195 responder_send_file('dsc', $dscpath);
3197 push_parse_dsc($dscpath, $dscfn, $cversion);
3199 my $format = getfield $dsc, 'Format';
3200 printdebug "format $format\n";
3202 my $actualhead = git_rev_parse('HEAD');
3203 my $dgithead = $actualhead;
3204 my $maintviewhead = undef;
3206 if (madformat_wantfixup($format)) {
3207 # user might have not used dgit build, so maybe do this now:
3208 if (quiltmode_splitbrain()) {
3209 my $upstreamversion = $clogp->{Version};
3210 $upstreamversion =~ s/-[^-]*$//;
3212 quilt_make_fake_dsc($upstreamversion);
3214 ($dgithead, $cachekey) =
3215 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3217 "--quilt=$quilt_mode but no cached dgit view:
3218 perhaps tree changed since dgit build[-source] ?";
3220 $dgithead = splitbrain_pseudomerge($clogp,
3221 $actualhead, $dgithead,
3223 $maintviewhead = $actualhead;
3224 changedir '../../../..';
3225 prep_ud(); # so _only_subdir() works, below
3227 commit_quilty_patch();
3231 if (defined $overwrite_version && !defined $maintviewhead) {
3232 $dgithead = plain_overwrite_pseudomerge($clogp,
3240 if ($archive_hash) {
3241 if (is_fast_fwd($archive_hash, $dgithead)) {
3243 } elsif (deliberately_not_fast_forward) {
3246 fail "dgit push: HEAD is not a descendant".
3247 " of the archive's version.\n".
3248 "To overwrite the archive's contents,".
3249 " pass --overwrite[=VERSION].\n".
3250 "To rewind history, if permitted by the archive,".
3251 " use --deliberately-not-fast-forward.";
3256 progress "checking that $dscfn corresponds to HEAD";
3257 runcmd qw(dpkg-source -x --),
3258 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3259 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3260 check_for_vendor_patches() if madformat($dsc->{format});
3261 changedir '../../../..';
3262 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3263 debugcmd "+",@diffcmd;
3265 my $r = system @diffcmd;
3268 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3270 HEAD specifies a different tree to $dscfn:
3272 Perhaps you forgot to build. Or perhaps there is a problem with your
3273 source tree (see dgit(7) for some hints). To see a full diff, run
3280 if (!$changesfile) {
3281 my $pat = changespat $cversion;
3282 my @cs = glob "$buildproductsdir/$pat";
3283 fail "failed to find unique changes file".
3284 " (looked for $pat in $buildproductsdir);".
3285 " perhaps you need to use dgit -C"
3287 ($changesfile) = @cs;
3289 $changesfile = "$buildproductsdir/$changesfile";
3292 # Check that changes and .dsc agree enough
3293 $changesfile =~ m{[^/]*$};
3294 files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3296 # Checks complete, we're going to try and go ahead:
3298 responder_send_file('changes',$changesfile);
3299 responder_send_command("param head $dgithead");
3300 responder_send_command("param csuite $csuite");
3301 responder_send_command("param tagformat $tagformat");
3302 if (defined $maintviewhead) {
3303 die unless ($protovsn//4) >= 4;
3304 responder_send_command("param maint-view $maintviewhead");
3307 if (deliberately_not_fast_forward) {
3308 git_for_each_ref(lrfetchrefs, sub {
3309 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3310 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3311 responder_send_command("previously $rrefname=$objid");
3312 $previously{$rrefname} = $objid;
3316 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3320 supplementary_message(<<'END');
3321 Push failed, while signing the tag.
3322 You can retry the push, after fixing the problem, if you like.
3324 # If we manage to sign but fail to record it anywhere, it's fine.
3325 if ($we_are_responder) {
3326 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3327 responder_receive_files('signed-tag', @tagobjfns);
3329 @tagobjfns = push_mktags($clogp,$dscpath,
3330 $changesfile,$changesfile,
3333 supplementary_message(<<'END');
3334 Push failed, *after* signing the tag.
3335 If you want to try again, you should use a new version number.
3338 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3340 foreach my $tw (@tagwants) {
3341 my $tag = $tw->{Tag};
3342 my $tagobjfn = $tw->{TagObjFn};
3344 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3345 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3346 runcmd_ordryrun_local
3347 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3350 supplementary_message(<<'END');
3351 Push failed, while updating the remote git repository - see messages above.
3352 If you want to try again, you should use a new version number.
3354 if (!check_for_git()) {
3355 create_remote_git_repo();
3358 my @pushrefs = $forceflag.$dgithead.":".rrref();
3359 foreach my $tw (@tagwants) {
3360 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3363 runcmd_ordryrun @git,
3364 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3365 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3367 supplementary_message(<<'END');
3368 Push failed, after updating the remote git repository.
3369 If you want to try again, you must use a new version number.
3371 if ($we_are_responder) {
3372 my $dryrunsuffix = act_local() ? "" : ".tmp";
3373 responder_receive_files('signed-dsc-changes',
3374 "$dscpath$dryrunsuffix",
3375 "$changesfile$dryrunsuffix");
3378 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3380 progress "[new .dsc left in $dscpath.tmp]";
3382 sign_changes $changesfile;
3385 supplementary_message(<<END);
3386 Push failed, while uploading package(s) to the archive server.
3387 You can retry the upload of exactly these same files with dput of:
3389 If that .changes file is broken, you will need to use a new version
3390 number for your next attempt at the upload.
3392 my $host = access_cfg('upload-host','RETURN-UNDEF');
3393 my @hostarg = defined($host) ? ($host,) : ();
3394 runcmd_ordryrun @dput, @hostarg, $changesfile;
3395 printdone "pushed and uploaded $cversion";
3397 supplementary_message('');
3398 responder_send_command("complete");
3405 badusage "-p is not allowed with clone; specify as argument instead"
3406 if defined $package;
3409 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3410 ($package,$isuite) = @ARGV;
3411 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3412 ($package,$dstdir) = @ARGV;
3413 } elsif (@ARGV==3) {
3414 ($package,$isuite,$dstdir) = @ARGV;
3416 badusage "incorrect arguments to dgit clone";
3418 $dstdir ||= "$package";
3420 if (stat_exists $dstdir) {
3421 fail "$dstdir already exists";
3425 if ($rmonerror && !$dryrun_level) {
3426 $cwd_remove= getcwd();
3428 return unless defined $cwd_remove;
3429 if (!chdir "$cwd_remove") {
3430 return if $!==&ENOENT;
3431 die "chdir $cwd_remove: $!";
3434 rmtree($dstdir) or die "remove $dstdir: $!\n";
3435 } elsif (grep { $! == $_ }
3436 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3438 print STDERR "check whether to remove $dstdir: $!\n";
3444 $cwd_remove = undef;
3447 sub branchsuite () {
3448 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3449 if ($branch =~ m#$lbranch_re#o) {
3456 sub fetchpullargs () {
3458 if (!defined $package) {
3459 my $sourcep = parsecontrol('debian/control','debian/control');
3460 $package = getfield $sourcep, 'Source';
3463 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3465 my $clogp = parsechangelog();
3466 $isuite = getfield $clogp, 'Distribution';
3468 canonicalise_suite();
3469 progress "fetching from suite $csuite";
3470 } elsif (@ARGV==1) {
3472 canonicalise_suite();
3474 badusage "incorrect arguments to dgit fetch or dgit pull";
3493 badusage "-p is not allowed with dgit push" if defined $package;
3495 my $clogp = parsechangelog();
3496 $package = getfield $clogp, 'Source';
3499 } elsif (@ARGV==1) {
3500 ($specsuite) = (@ARGV);
3502 badusage "incorrect arguments to dgit push";
3504 $isuite = getfield $clogp, 'Distribution';
3506 local ($package) = $existing_package; # this is a hack
3507 canonicalise_suite();
3509 canonicalise_suite();
3511 if (defined $specsuite &&
3512 $specsuite ne $isuite &&
3513 $specsuite ne $csuite) {
3514 fail "dgit push: changelog specifies $isuite ($csuite)".
3515 " but command line specifies $specsuite";
3520 #---------- remote commands' implementation ----------
3522 sub cmd_remote_push_build_host {
3523 my ($nrargs) = shift @ARGV;
3524 my (@rargs) = @ARGV[0..$nrargs-1];
3525 @ARGV = @ARGV[$nrargs..$#ARGV];
3527 my ($dir,$vsnwant) = @rargs;
3528 # vsnwant is a comma-separated list; we report which we have
3529 # chosen in our ready response (so other end can tell if they
3532 $we_are_responder = 1;
3533 $us .= " (build host)";
3537 open PI, "<&STDIN" or die $!;
3538 open STDIN, "/dev/null" or die $!;
3539 open PO, ">&STDOUT" or die $!;
3541 open STDOUT, ">&STDERR" or die $!;
3545 ($protovsn) = grep {
3546 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3547 } @rpushprotovsn_support;
3549 fail "build host has dgit rpush protocol versions ".
3550 (join ",", @rpushprotovsn_support).
3551 " but invocation host has $vsnwant"
3552 unless defined $protovsn;
3554 responder_send_command("dgit-remote-push-ready $protovsn");
3555 rpush_handle_protovsn_bothends();
3560 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3561 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3562 # a good error message)
3564 sub rpush_handle_protovsn_bothends () {
3565 if ($protovsn < 4) {
3566 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3575 my $report = i_child_report();
3576 if (defined $report) {
3577 printdebug "($report)\n";
3578 } elsif ($i_child_pid) {
3579 printdebug "(killing build host child $i_child_pid)\n";
3580 kill 15, $i_child_pid;
3582 if (defined $i_tmp && !defined $initiator_tempdir) {
3584 eval { rmtree $i_tmp; };
3588 END { i_cleanup(); }
3591 my ($base,$selector,@args) = @_;
3592 $selector =~ s/\-/_/g;
3593 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3600 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3608 push @rargs, join ",", @rpushprotovsn_support;
3611 push @rdgit, @ropts;
3612 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3614 my @cmd = (@ssh, $host, shellquote @rdgit);
3617 if (defined $initiator_tempdir) {
3618 rmtree $initiator_tempdir;
3619 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3620 $i_tmp = $initiator_tempdir;
3624 $i_child_pid = open2(\*RO, \*RI, @cmd);
3626 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3627 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3628 $supplementary_message = '' unless $protovsn >= 3;
3630 fail "rpush negotiated protocol version $protovsn".
3631 " which does not support quilt mode $quilt_mode"
3632 if quiltmode_splitbrain;
3634 rpush_handle_protovsn_bothends();
3636 my ($icmd,$iargs) = initiator_expect {
3637 m/^(\S+)(?: (.*))?$/;
3640 i_method "i_resp", $icmd, $iargs;
3644 sub i_resp_progress ($) {
3646 my $msg = protocol_read_bytes \*RO, $rhs;
3650 sub i_resp_supplementary_message ($) {
3652 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3655 sub i_resp_complete {
3656 my $pid = $i_child_pid;
3657 $i_child_pid = undef; # prevents killing some other process with same pid
3658 printdebug "waiting for build host child $pid...\n";
3659 my $got = waitpid $pid, 0;
3660 die $! unless $got == $pid;
3661 die "build host child failed $?" if $?;
3664 printdebug "all done\n";
3668 sub i_resp_file ($) {
3670 my $localname = i_method "i_localname", $keyword;
3671 my $localpath = "$i_tmp/$localname";
3672 stat_exists $localpath and
3673 badproto \*RO, "file $keyword ($localpath) twice";
3674 protocol_receive_file \*RO, $localpath;
3675 i_method "i_file", $keyword;
3680 sub i_resp_param ($) {
3681 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3685 sub i_resp_previously ($) {
3686 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3687 or badproto \*RO, "bad previously spec";
3688 my $r = system qw(git check-ref-format), $1;
3689 die "bad previously ref spec ($r)" if $r;
3690 $previously{$1} = $2;
3695 sub i_resp_want ($) {
3697 die "$keyword ?" if $i_wanted{$keyword}++;
3698 my @localpaths = i_method "i_want", $keyword;
3699 printdebug "[[ $keyword @localpaths\n";
3700 foreach my $localpath (@localpaths) {
3701 protocol_send_file \*RI, $localpath;
3703 print RI "files-end\n" or die $!;
3706 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3708 sub i_localname_parsed_changelog {
3709 return "remote-changelog.822";
3711 sub i_file_parsed_changelog {
3712 ($i_clogp, $i_version, $i_dscfn) =
3713 push_parse_changelog "$i_tmp/remote-changelog.822";
3714 die if $i_dscfn =~ m#/|^\W#;
3717 sub i_localname_dsc {
3718 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3723 sub i_localname_changes {
3724 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3725 $i_changesfn = $i_dscfn;
3726 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3727 return $i_changesfn;
3729 sub i_file_changes { }
3731 sub i_want_signed_tag {
3732 printdebug Dumper(\%i_param, $i_dscfn);
3733 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3734 && defined $i_param{'csuite'}
3735 or badproto \*RO, "premature desire for signed-tag";
3736 my $head = $i_param{'head'};
3737 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3739 my $maintview = $i_param{'maint-view'};
3740 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3743 if ($protovsn >= 4) {
3744 my $p = $i_param{'tagformat'} // '<undef>';
3746 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3749 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3751 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3753 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3756 push_mktags $i_clogp, $i_dscfn,
3757 $i_changesfn, 'remote changes',
3761 sub i_want_signed_dsc_changes {
3762 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3763 sign_changes $i_changesfn;
3764 return ($i_dscfn, $i_changesfn);
3767 #---------- building etc. ----------
3773 #----- `3.0 (quilt)' handling -----
3775 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3777 sub quiltify_dpkg_commit ($$$;$) {
3778 my ($patchname,$author,$msg, $xinfo) = @_;
3782 my $descfn = ".git/dgit/quilt-description.tmp";
3783 open O, '>', $descfn or die "$descfn: $!";
3784 $msg =~ s/\n+/\n\n/;
3785 print O <<END or die $!;
3787 ${xinfo}Subject: $msg
3794 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3795 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3796 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3797 runcmd @dpkgsource, qw(--commit .), $patchname;
3801 sub quiltify_trees_differ ($$;$$$) {
3802 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3803 # returns true iff the two tree objects differ other than in debian/
3804 # with $finegrained,
3805 # returns bitmask 01 - differ in upstream files except .gitignore
3806 # 02 - differ in .gitignore
3807 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3808 # is set for each modified .gitignore filename $fn
3809 # if $unrepres is defined, array ref to which is appeneded
3810 # a list of unrepresentable changes (removals of upstream files
3813 my @cmd = (@git, qw(diff-tree -z));
3814 push @cmd, qw(--name-only) unless $unrepres;
3815 push @cmd, qw(-r) if $finegrained || $unrepres;
3817 my $diffs= cmdoutput @cmd;
3820 foreach my $f (split /\0/, $diffs) {
3821 if ($unrepres && !@lmodes) {
3822 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3825 my ($oldmode,$newmode) = @lmodes;
3828 next if $f =~ m#^debian(?:/.*)?$#s;
3832 die "deleted\n" unless $newmode =~ m/[^0]/;
3833 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3834 if ($oldmode =~ m/[^0]/) {
3835 die "mode changed\n" if $oldmode ne $newmode;
3837 die "non-default mode\n" unless $newmode =~ m/^100644$/;
3841 local $/="\n"; chomp $@;
3842 push @$unrepres, [ $f, $@ ];
3846 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3847 $r |= $isignore ? 02 : 01;
3848 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3850 printdebug "quiltify_trees_differ $x $y => $r\n";
3854 sub quiltify_tree_sentinelfiles ($) {
3855 # lists the `sentinel' files present in the tree
3857 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3858 qw(-- debian/rules debian/control);
3863 sub quiltify_splitbrain_needed () {
3864 if (!$split_brain) {
3865 progress "dgit view: changes are required...";
3866 runcmd @git, qw(checkout -q -b dgit-view);
3871 sub quiltify_splitbrain ($$$$$$) {
3872 my ($clogp, $unapplied, $headref, $diffbits,
3873 $editedignores, $cachekey) = @_;
3874 if ($quilt_mode !~ m/gbp|dpm/) {
3875 # treat .gitignore just like any other upstream file
3876 $diffbits = { %$diffbits };
3877 $_ = !!$_ foreach values %$diffbits;
3879 # We would like any commits we generate to be reproducible
3880 my @authline = clogp_authline($clogp);
3881 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3882 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3883 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3884 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3885 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3886 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3888 if ($quilt_mode =~ m/gbp|unapplied/ &&
3889 ($diffbits->{O2H} & 01)) {
3891 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3892 " but git tree differs from orig in upstream files.";
3893 if (!stat_exists "debian/patches") {
3895 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3899 if ($quilt_mode =~ m/dpm/ &&
3900 ($diffbits->{H2A} & 01)) {
3902 --quilt=$quilt_mode specified, implying patches-applied git tree
3903 but git tree differs from result of applying debian/patches to upstream
3906 if ($quilt_mode =~ m/gbp|unapplied/ &&
3907 ($diffbits->{O2A} & 01)) { # some patches
3908 quiltify_splitbrain_needed();
3909 progress "dgit view: creating patches-applied version using gbp pq";
3910 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3911 # gbp pq import creates a fresh branch; push back to dgit-view
3912 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3913 runcmd @git, qw(checkout -q dgit-view);
3915 if ($quilt_mode =~ m/gbp|dpm/ &&
3916 ($diffbits->{O2A} & 02)) {
3918 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3919 tool which does not create patches for changes to upstream
3920 .gitignores: but, such patches exist in debian/patches.
3923 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3924 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3925 quiltify_splitbrain_needed();
3926 progress "dgit view: creating patch to represent .gitignore changes";
3927 ensuredir "debian/patches";
3928 my $gipatch = "debian/patches/auto-gitignore";
3929 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3930 stat GIPATCH or die "$gipatch: $!";
3931 fail "$gipatch already exists; but want to create it".
3932 " to record .gitignore changes" if (stat _)[7];
3933 print GIPATCH <<END or die "$gipatch: $!";
3934 Subject: Update .gitignore from Debian packaging branch
3936 The Debian packaging git branch contains these updates to the upstream
3937 .gitignore file(s). This patch is autogenerated, to provide these
3938 updates to users of the official Debian archive view of the package.
3940 [dgit ($our_version) update-gitignore]
3943 close GIPATCH or die "$gipatch: $!";
3944 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3945 $unapplied, $headref, "--", sort keys %$editedignores;
3946 open SERIES, "+>>", "debian/patches/series" or die $!;
3947 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3949 defined read SERIES, $newline, 1 or die $!;
3950 print SERIES "\n" or die $! unless $newline eq "\n";
3951 print SERIES "auto-gitignore\n" or die $!;
3952 close SERIES or die $!;
3953 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3955 Commit patch to update .gitignore
3957 [dgit ($our_version) update-gitignore-quilt-fixup]
3961 my $dgitview = git_rev_parse 'HEAD';
3963 changedir '../../../..';
3964 # When we no longer need to support squeeze, use --create-reflog
3966 ensuredir ".git/logs/refs/dgit-intern";
3967 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3970 my $oldcache = git_get_ref "refs/$splitbraincache";
3971 if ($oldcache eq $dgitview) {
3972 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
3973 # git update-ref doesn't always update, in this case. *sigh*
3974 my $dummy = make_commit_text <<END;
3977 author Dgit <dgit\@example.com> 1000000000 +0000
3978 committer Dgit <dgit\@example.com> 1000000000 +0000
3980 Dummy commit - do not use
3982 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
3983 "refs/$splitbraincache", $dummy;
3985 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3988 progress "dgit view: created (commit id $dgitview)";
3990 changedir '.git/dgit/unpack/work';
3993 sub quiltify ($$$$) {
3994 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3996 # Quilt patchification algorithm
3998 # We search backwards through the history of the main tree's HEAD
3999 # (T) looking for a start commit S whose tree object is identical
4000 # to to the patch tip tree (ie the tree corresponding to the
4001 # current dpkg-committed patch series). For these purposes
4002 # `identical' disregards anything in debian/ - this wrinkle is
4003 # necessary because dpkg-source treates debian/ specially.
4005 # We can only traverse edges where at most one of the ancestors'
4006 # trees differs (in changes outside in debian/). And we cannot
4007 # handle edges which change .pc/ or debian/patches. To avoid
4008 # going down a rathole we avoid traversing edges which introduce
4009 # debian/rules or debian/control. And we set a limit on the
4010 # number of edges we are willing to look at.
4012 # If we succeed, we walk forwards again. For each traversed edge
4013 # PC (with P parent, C child) (starting with P=S and ending with
4014 # C=T) to we do this:
4016 # - dpkg-source --commit with a patch name and message derived from C
4017 # After traversing PT, we git commit the changes which
4018 # should be contained within debian/patches.
4020 # The search for the path S..T is breadth-first. We maintain a
4021 # todo list containing search nodes. A search node identifies a
4022 # commit, and looks something like this:
4024 # Commit => $git_commit_id,
4025 # Child => $c, # or undef if P=T
4026 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4027 # Nontrivial => true iff $p..$c has relevant changes
4034 my %considered; # saves being exponential on some weird graphs
4036 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4039 my ($search,$whynot) = @_;
4040 printdebug " search NOT $search->{Commit} $whynot\n";
4041 $search->{Whynot} = $whynot;
4042 push @nots, $search;
4043 no warnings qw(exiting);
4052 my $c = shift @todo;
4053 next if $considered{$c->{Commit}}++;
4055 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4057 printdebug "quiltify investigate $c->{Commit}\n";
4060 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4061 printdebug " search finished hooray!\n";
4066 if ($quilt_mode eq 'nofix') {
4067 fail "quilt fixup required but quilt mode is \`nofix'\n".
4068 "HEAD commit $c->{Commit} differs from tree implied by ".
4069 " debian/patches (tree object $oldtiptree)";
4071 if ($quilt_mode eq 'smash') {
4072 printdebug " search quitting smash\n";
4076 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4077 $not->($c, "has $c_sentinels not $t_sentinels")
4078 if $c_sentinels ne $t_sentinels;
4080 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4081 $commitdata =~ m/\n\n/;
4083 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4084 @parents = map { { Commit => $_, Child => $c } } @parents;
4086 $not->($c, "root commit") if !@parents;
4088 foreach my $p (@parents) {
4089 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4091 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4092 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4094 foreach my $p (@parents) {
4095 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4097 my @cmd= (@git, qw(diff-tree -r --name-only),
4098 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4099 my $patchstackchange = cmdoutput @cmd;
4100 if (length $patchstackchange) {
4101 $patchstackchange =~ s/\n/,/g;
4102 $not->($p, "changed $patchstackchange");
4105 printdebug " search queue P=$p->{Commit} ",
4106 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4112 printdebug "quiltify want to smash\n";
4115 my $x = $_[0]{Commit};
4116 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4119 my $reportnot = sub {
4121 my $s = $abbrev->($notp);
4122 my $c = $notp->{Child};
4123 $s .= "..".$abbrev->($c) if $c;
4124 $s .= ": ".$notp->{Whynot};
4127 if ($quilt_mode eq 'linear') {
4128 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4129 foreach my $notp (@nots) {
4130 print STDERR "$us: ", $reportnot->($notp), "\n";
4132 print STDERR "$us: $_\n" foreach @$failsuggestion;
4133 fail "quilt fixup naive history linearisation failed.\n".
4134 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4135 } elsif ($quilt_mode eq 'smash') {
4136 } elsif ($quilt_mode eq 'auto') {
4137 progress "quilt fixup cannot be linear, smashing...";
4139 die "$quilt_mode ?";
4142 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4143 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4145 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4147 quiltify_dpkg_commit "auto-$version-$target-$time",
4148 (getfield $clogp, 'Maintainer'),
4149 "Automatically generated patch ($clogp->{Version})\n".
4150 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4154 progress "quiltify linearisation planning successful, executing...";
4156 for (my $p = $sref_S;
4157 my $c = $p->{Child};
4159 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4160 next unless $p->{Nontrivial};
4162 my $cc = $c->{Commit};
4164 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4165 $commitdata =~ m/\n\n/ or die "$c ?";
4168 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4171 my $commitdate = cmdoutput
4172 @git, qw(log -n1 --pretty=format:%aD), $cc;
4174 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4176 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4183 my $gbp_check_suitable = sub {
4188 die "contains unexpected slashes\n" if m{//} || m{/$};
4189 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4190 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4191 die "too long" if length > 200;
4193 return $_ unless $@;
4194 print STDERR "quiltifying commit $cc:".
4195 " ignoring/dropping Gbp-Pq $what: $@";
4199 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4201 (\S+) \s* \n //ixm) {
4202 $patchname = $gbp_check_suitable->($1, 'Name');
4204 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4206 (\S+) \s* \n //ixm) {
4207 $patchdir = $gbp_check_suitable->($1, 'Topic');
4212 if (!defined $patchname) {
4213 $patchname = $title;
4214 $patchname =~ s/[.:]$//;
4217 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4218 my $translitname = $converter->convert($patchname);
4219 die unless defined $translitname;
4220 $patchname = $translitname;
4223 "dgit: patch title transliteration error: $@"
4225 $patchname =~ y/ A-Z/-a-z/;
4226 $patchname =~ y/-a-z0-9_.+=~//cd;
4227 $patchname =~ s/^\W/x-$&/;
4228 $patchname = substr($patchname,0,40);
4230 if (!defined $patchdir) {
4233 if (length $patchdir) {
4234 $patchname = "$patchdir/$patchname";
4236 if ($patchname =~ m{^(.*)/}) {
4237 mkpath "debian/patches/$1";
4242 stat "debian/patches/$patchname$index";
4244 $!==ENOENT or die "$patchname$index $!";
4246 runcmd @git, qw(checkout -q), $cc;
4248 # We use the tip's changelog so that dpkg-source doesn't
4249 # produce complaining messages from dpkg-parsechangelog. None
4250 # of the information dpkg-source gets from the changelog is
4251 # actually relevant - it gets put into the original message
4252 # which dpkg-source provides our stunt editor, and then
4254 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4256 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4257 "Date: $commitdate\n".
4258 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4260 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4263 runcmd @git, qw(checkout -q master);
4266 sub build_maybe_quilt_fixup () {
4267 my ($format,$fopts) = get_source_format;
4268 return unless madformat_wantfixup $format;
4271 check_for_vendor_patches();
4273 if (quiltmode_splitbrain) {
4274 foreach my $needtf (qw(new maint)) {
4275 next if grep { $_ eq $needtf } access_cfg_tagformats;
4277 quilt mode $quilt_mode requires split view so server needs to support
4278 both "new" and "maint" tag formats, but config says it doesn't.
4283 my $clogp = parsechangelog();
4284 my $headref = git_rev_parse('HEAD');
4289 my $upstreamversion=$version;
4290 $upstreamversion =~ s/-[^-]*$//;
4292 if ($fopts->{'single-debian-patch'}) {
4293 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4295 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4298 die 'bug' if $split_brain && !$need_split_build_invocation;
4300 changedir '../../../..';
4301 runcmd_ordryrun_local
4302 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4305 sub quilt_fixup_mkwork ($) {
4308 mkdir "work" or die $!;
4310 mktree_in_ud_here();
4311 runcmd @git, qw(reset -q --hard), $headref;
4314 sub quilt_fixup_linkorigs ($$) {
4315 my ($upstreamversion, $fn) = @_;
4316 # calls $fn->($leafname);
4318 foreach my $f (<../../../../*>) { #/){
4319 my $b=$f; $b =~ s{.*/}{};
4321 local ($debuglevel) = $debuglevel-1;
4322 printdebug "QF linkorigs $b, $f ?\n";
4324 next unless is_orig_file_of_vsn $b, $upstreamversion;
4325 printdebug "QF linkorigs $b, $f Y\n";
4326 link_ltarget $f, $b or die "$b $!";
4331 sub quilt_fixup_delete_pc () {
4332 runcmd @git, qw(rm -rqf .pc);
4334 Commit removal of .pc (quilt series tracking data)
4336 [dgit ($our_version) upgrade quilt-remove-pc]
4340 sub quilt_fixup_singlepatch ($$$) {
4341 my ($clogp, $headref, $upstreamversion) = @_;
4343 progress "starting quiltify (single-debian-patch)";
4345 # dpkg-source --commit generates new patches even if
4346 # single-debian-patch is in debian/source/options. In order to
4347 # get it to generate debian/patches/debian-changes, it is
4348 # necessary to build the source package.
4350 quilt_fixup_linkorigs($upstreamversion, sub { });
4351 quilt_fixup_mkwork($headref);
4353 rmtree("debian/patches");
4355 runcmd @dpkgsource, qw(-b .);
4357 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4358 rename srcfn("$upstreamversion", "/debian/patches"),
4359 "work/debian/patches";
4362 commit_quilty_patch();
4365 sub quilt_make_fake_dsc ($) {
4366 my ($upstreamversion) = @_;
4368 my $fakeversion="$upstreamversion-~~DGITFAKE";
4370 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4371 print $fakedsc <<END or die $!;
4374 Version: $fakeversion
4378 my $dscaddfile=sub {
4381 my $md = new Digest::MD5;
4383 my $fh = new IO::File $b, '<' or die "$b $!";
4388 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4391 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4393 my @files=qw(debian/source/format debian/rules
4394 debian/control debian/changelog);
4395 foreach my $maybe (qw(debian/patches debian/source/options
4396 debian/tests/control)) {
4397 next unless stat_exists "../../../$maybe";
4398 push @files, $maybe;
4401 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4402 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4404 $dscaddfile->($debtar);
4405 close $fakedsc or die $!;
4408 sub quilt_check_splitbrain_cache ($$) {
4409 my ($headref, $upstreamversion) = @_;
4410 # Called only if we are in (potentially) split brain mode.
4412 # Computes the cache key and looks in the cache.
4413 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4415 my $splitbrain_cachekey;
4418 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4419 # we look in the reflog of dgit-intern/quilt-cache
4420 # we look for an entry whose message is the key for the cache lookup
4421 my @cachekey = (qw(dgit), $our_version);
4422 push @cachekey, $upstreamversion;
4423 push @cachekey, $quilt_mode;
4424 push @cachekey, $headref;
4426 push @cachekey, hashfile('fake.dsc');
4428 my $srcshash = Digest::SHA->new(256);
4429 my %sfs = ( %INC, '$0(dgit)' => $0 );
4430 foreach my $sfk (sort keys %sfs) {
4431 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4432 $srcshash->add($sfk," ");
4433 $srcshash->add(hashfile($sfs{$sfk}));
4434 $srcshash->add("\n");
4436 push @cachekey, $srcshash->hexdigest();
4437 $splitbrain_cachekey = "@cachekey";
4439 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4441 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4442 debugcmd "|(probably)",@cmd;
4443 my $child = open GC, "-|"; defined $child or die $!;
4445 chdir '../../..' or die $!;
4446 if (!stat ".git/logs/refs/$splitbraincache") {
4447 $! == ENOENT or die $!;
4448 printdebug ">(no reflog)\n";
4455 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4456 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4459 quilt_fixup_mkwork($headref);
4460 if ($cachehit ne $headref) {
4461 progress "dgit view: found cached (commit id $cachehit)";
4462 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4464 return ($cachehit, $splitbrain_cachekey);
4466 progress "dgit view: found cached, no changes required";
4467 return ($headref, $splitbrain_cachekey);
4469 die $! if GC->error;
4470 failedcmd unless close GC;
4472 printdebug "splitbrain cache miss\n";
4473 return (undef, $splitbrain_cachekey);
4476 sub quilt_fixup_multipatch ($$$) {
4477 my ($clogp, $headref, $upstreamversion) = @_;
4479 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4482 # - honour any existing .pc in case it has any strangeness
4483 # - determine the git commit corresponding to the tip of
4484 # the patch stack (if there is one)
4485 # - if there is such a git commit, convert each subsequent
4486 # git commit into a quilt patch with dpkg-source --commit
4487 # - otherwise convert all the differences in the tree into
4488 # a single git commit
4492 # Our git tree doesn't necessarily contain .pc. (Some versions of
4493 # dgit would include the .pc in the git tree.) If there isn't
4494 # one, we need to generate one by unpacking the patches that we
4497 # We first look for a .pc in the git tree. If there is one, we
4498 # will use it. (This is not the normal case.)
4500 # Otherwise need to regenerate .pc so that dpkg-source --commit
4501 # can work. We do this as follows:
4502 # 1. Collect all relevant .orig from parent directory
4503 # 2. Generate a debian.tar.gz out of
4504 # debian/{patches,rules,source/format,source/options}
4505 # 3. Generate a fake .dsc containing just these fields:
4506 # Format Source Version Files
4507 # 4. Extract the fake .dsc
4508 # Now the fake .dsc has a .pc directory.
4509 # (In fact we do this in every case, because in future we will
4510 # want to search for a good base commit for generating patches.)
4512 # Then we can actually do the dpkg-source --commit
4513 # 1. Make a new working tree with the same object
4514 # store as our main tree and check out the main
4516 # 2. Copy .pc from the fake's extraction, if necessary
4517 # 3. Run dpkg-source --commit
4518 # 4. If the result has changes to debian/, then
4519 # - git add them them
4520 # - git add .pc if we had a .pc in-tree
4522 # 5. If we had a .pc in-tree, delete it, and git commit
4523 # 6. Back in the main tree, fast forward to the new HEAD
4525 # Another situation we may have to cope with is gbp-style
4526 # patches-unapplied trees.
4528 # We would want to detect these, so we know to escape into
4529 # quilt_fixup_gbp. However, this is in general not possible.
4530 # Consider a package with a one patch which the dgit user reverts
4531 # (with git revert or the moral equivalent).
4533 # That is indistinguishable in contents from a patches-unapplied
4534 # tree. And looking at the history to distinguish them is not
4535 # useful because the user might have made a confusing-looking git
4536 # history structure (which ought to produce an error if dgit can't
4537 # cope, not a silent reintroduction of an unwanted patch).
4539 # So gbp users will have to pass an option. But we can usually
4540 # detect their failure to do so: if the tree is not a clean
4541 # patches-applied tree, quilt linearisation fails, but the tree
4542 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4543 # they want --quilt=unapplied.
4545 # To help detect this, when we are extracting the fake dsc, we
4546 # first extract it with --skip-patches, and then apply the patches
4547 # afterwards with dpkg-source --before-build. That lets us save a
4548 # tree object corresponding to .origs.
4550 my $splitbrain_cachekey;
4552 quilt_make_fake_dsc($upstreamversion);
4554 if (quiltmode_splitbrain()) {
4556 ($cachehit, $splitbrain_cachekey) =
4557 quilt_check_splitbrain_cache($headref, $upstreamversion);
4558 return if $cachehit;
4562 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4564 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4565 rename $fakexdir, "fake" or die "$fakexdir $!";
4569 remove_stray_gits();
4570 mktree_in_ud_here();
4574 runcmd @git, qw(add -Af .);
4575 my $unapplied=git_write_tree();
4576 printdebug "fake orig tree object $unapplied\n";
4580 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4582 if (system @bbcmd) {
4583 failedcmd @bbcmd if $? < 0;
4585 failed to apply your git tree's patch stack (from debian/patches/) to
4586 the corresponding upstream tarball(s). Your source tree and .orig
4587 are probably too inconsistent. dgit can only fix up certain kinds of
4588 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4594 quilt_fixup_mkwork($headref);
4597 if (stat_exists ".pc") {
4599 progress "Tree already contains .pc - will use it then delete it.";
4602 rename '../fake/.pc','.pc' or die $!;
4605 changedir '../fake';
4607 runcmd @git, qw(add -Af .);
4608 my $oldtiptree=git_write_tree();
4609 printdebug "fake o+d/p tree object $unapplied\n";
4610 changedir '../work';
4613 # We calculate some guesswork now about what kind of tree this might
4614 # be. This is mostly for error reporting.
4620 # O = orig, without patches applied
4621 # A = "applied", ie orig with H's debian/patches applied
4622 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4623 \%editedignores, \@unrepres),
4624 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4625 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4629 foreach my $b (qw(01 02)) {
4630 foreach my $v (qw(O2H O2A H2A)) {
4631 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4634 printdebug "differences \@dl @dl.\n";
4637 "$us: base trees orig=%.20s o+d/p=%.20s",
4638 $unapplied, $oldtiptree;
4640 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4641 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4642 $dl[0], $dl[1], $dl[3], $dl[4],
4646 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4648 forceable_fail [qw(unrepresentable)], <<END;
4649 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4654 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4655 push @failsuggestion, "This might be a patches-unapplied branch.";
4656 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4657 push @failsuggestion, "This might be a patches-applied branch.";
4659 push @failsuggestion, "Maybe you need to specify one of".
4660 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4662 if (quiltmode_splitbrain()) {
4663 quiltify_splitbrain($clogp, $unapplied, $headref,
4664 $diffbits, \%editedignores,
4665 $splitbrain_cachekey);
4669 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4670 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4672 if (!open P, '>>', ".pc/applied-patches") {
4673 $!==&ENOENT or die $!;
4678 commit_quilty_patch();
4680 if ($mustdeletepc) {
4681 quilt_fixup_delete_pc();
4685 sub quilt_fixup_editor () {
4686 my $descfn = $ENV{$fakeeditorenv};
4687 my $editing = $ARGV[$#ARGV];
4688 open I1, '<', $descfn or die "$descfn: $!";
4689 open I2, '<', $editing or die "$editing: $!";
4690 unlink $editing or die "$editing: $!";
4691 open O, '>', $editing or die "$editing: $!";
4692 while (<I1>) { print O or die $!; } I1->error and die $!;
4695 $copying ||= m/^\-\-\- /;
4696 next unless $copying;
4699 I2->error and die $!;
4704 sub maybe_apply_patches_dirtily () {
4705 return unless $quilt_mode =~ m/gbp|unapplied/;
4706 print STDERR <<END or die $!;
4708 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4709 dgit: Have to apply the patches - making the tree dirty.
4710 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4713 $patches_applied_dirtily = 01;
4714 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4715 runcmd qw(dpkg-source --before-build .);
4718 sub maybe_unapply_patches_again () {
4719 progress "dgit: Unapplying patches again to tidy up the tree."
4720 if $patches_applied_dirtily;
4721 runcmd qw(dpkg-source --after-build .)
4722 if $patches_applied_dirtily & 01;
4724 if $patches_applied_dirtily & 02;
4725 $patches_applied_dirtily = 0;
4728 #----- other building -----
4730 our $clean_using_builder;
4731 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4732 # clean the tree before building (perhaps invoked indirectly by
4733 # whatever we are using to run the build), rather than separately
4734 # and explicitly by us.
4737 return if $clean_using_builder;
4738 if ($cleanmode eq 'dpkg-source') {
4739 maybe_apply_patches_dirtily();
4740 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4741 } elsif ($cleanmode eq 'dpkg-source-d') {
4742 maybe_apply_patches_dirtily();
4743 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4744 } elsif ($cleanmode eq 'git') {
4745 runcmd_ordryrun_local @git, qw(clean -xdf);
4746 } elsif ($cleanmode eq 'git-ff') {
4747 runcmd_ordryrun_local @git, qw(clean -xdff);
4748 } elsif ($cleanmode eq 'check') {
4749 my $leftovers = cmdoutput @git, qw(clean -xdn);
4750 if (length $leftovers) {
4751 print STDERR $leftovers, "\n" or die $!;
4752 fail "tree contains uncommitted files and --clean=check specified";
4754 } elsif ($cleanmode eq 'none') {
4761 badusage "clean takes no additional arguments" if @ARGV;
4764 maybe_unapply_patches_again();
4769 badusage "-p is not allowed when building" if defined $package;
4772 my $clogp = parsechangelog();
4773 $isuite = getfield $clogp, 'Distribution';
4774 $package = getfield $clogp, 'Source';
4775 $version = getfield $clogp, 'Version';
4776 build_maybe_quilt_fixup();
4778 my $pat = changespat $version;
4779 foreach my $f (glob "$buildproductsdir/$pat") {
4781 unlink $f or fail "remove old changes file $f: $!";
4783 progress "would remove $f";
4789 sub changesopts_initial () {
4790 my @opts =@changesopts[1..$#changesopts];
4793 sub changesopts_version () {
4794 if (!defined $changes_since_version) {
4795 my @vsns = archive_query('archive_query');
4796 my @quirk = access_quirk();
4797 if ($quirk[0] eq 'backports') {
4798 local $isuite = $quirk[2];
4800 canonicalise_suite();
4801 push @vsns, archive_query('archive_query');
4804 @vsns = map { $_->[0] } @vsns;
4805 @vsns = sort { -version_compare($a, $b) } @vsns;
4806 $changes_since_version = $vsns[0];
4807 progress "changelog will contain changes since $vsns[0]";
4809 $changes_since_version = '_';
4810 progress "package seems new, not specifying -v<version>";
4813 if ($changes_since_version ne '_') {
4814 return ("-v$changes_since_version");
4820 sub changesopts () {
4821 return (changesopts_initial(), changesopts_version());
4824 sub massage_dbp_args ($;$) {
4825 my ($cmd,$xargs) = @_;
4828 # - if we're going to split the source build out so we can
4829 # do strange things to it, massage the arguments to dpkg-buildpackage
4830 # so that the main build doessn't build source (or add an argument
4831 # to stop it building source by default).
4833 # - add -nc to stop dpkg-source cleaning the source tree,
4834 # unless we're not doing a split build and want dpkg-source
4835 # as cleanmode, in which case we can do nothing
4838 # 0 - source will NOT need to be built separately by caller
4839 # +1 - source will need to be built separately by caller
4840 # +2 - source will need to be built separately by caller AND
4841 # dpkg-buildpackage should not in fact be run at all!
4842 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4843 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4844 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4845 $clean_using_builder = 1;
4848 # -nc has the side effect of specifying -b if nothing else specified
4849 # and some combinations of -S, -b, et al, are errors, rather than
4850 # later simply overriding earlie. So we need to:
4851 # - search the command line for these options
4852 # - pick the last one
4853 # - perhaps add our own as a default
4854 # - perhaps adjust it to the corresponding non-source-building version
4856 foreach my $l ($cmd, $xargs) {
4858 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4861 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4863 if ($need_split_build_invocation) {
4864 printdebug "massage split $dmode.\n";
4865 $r = $dmode =~ m/[S]/ ? +2 :
4866 $dmode =~ y/gGF/ABb/ ? +1 :
4867 $dmode =~ m/[ABb]/ ? 0 :
4870 printdebug "massage done $r $dmode.\n";
4872 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4877 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4878 my $wantsrc = massage_dbp_args \@dbp;
4885 push @dbp, changesopts_version();
4886 maybe_apply_patches_dirtily();
4887 runcmd_ordryrun_local @dbp;
4889 maybe_unapply_patches_again();
4890 printdone "build successful\n";
4894 $quilt_mode //= 'gbp';
4898 my @dbp = @dpkgbuildpackage;
4900 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4902 if (!length $gbp_build[0]) {
4903 if (length executable_on_path('git-buildpackage')) {
4904 $gbp_build[0] = qw(git-buildpackage);
4906 $gbp_build[0] = 'gbp buildpackage';
4909 my @cmd = opts_opt_multi_cmd @gbp_build;
4911 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4916 if (!$clean_using_builder) {
4917 push @cmd, '--git-cleaner=true';
4921 maybe_unapply_patches_again();
4923 push @cmd, changesopts();
4924 runcmd_ordryrun_local @cmd, @ARGV;
4926 printdone "build successful\n";
4928 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4931 my $our_cleanmode = $cleanmode;
4932 if ($need_split_build_invocation) {
4933 # Pretend that clean is being done some other way. This
4934 # forces us not to try to use dpkg-buildpackage to clean and
4935 # build source all in one go; and instead we run dpkg-source
4936 # (and build_prep() will do the clean since $clean_using_builder
4938 $our_cleanmode = 'ELSEWHERE';
4940 if ($our_cleanmode =~ m/^dpkg-source/) {
4941 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4942 $clean_using_builder = 1;
4945 $sourcechanges = changespat $version,'source';
4947 unlink "../$sourcechanges" or $!==ENOENT
4948 or fail "remove $sourcechanges: $!";
4950 $dscfn = dscfn($version);
4951 if ($our_cleanmode eq 'dpkg-source') {
4952 maybe_apply_patches_dirtily();
4953 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4955 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4956 maybe_apply_patches_dirtily();
4957 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4960 my @cmd = (@dpkgsource, qw(-b --));
4963 runcmd_ordryrun_local @cmd, "work";
4964 my @udfiles = <${package}_*>;
4965 changedir "../../..";
4966 foreach my $f (@udfiles) {
4967 printdebug "source copy, found $f\n";
4970 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4971 $f eq srcfn($version, $&));
4972 printdebug "source copy, found $f - renaming\n";
4973 rename "$ud/$f", "../$f" or $!==ENOENT
4974 or fail "put in place new source file ($f): $!";
4977 my $pwd = must_getcwd();
4978 my $leafdir = basename $pwd;
4980 runcmd_ordryrun_local @cmd, $leafdir;
4983 runcmd_ordryrun_local qw(sh -ec),
4984 'exec >$1; shift; exec "$@"','x',
4985 "../$sourcechanges",
4986 @dpkggenchanges, qw(-S), changesopts();
4990 sub cmd_build_source {
4991 badusage "build-source takes no additional arguments" if @ARGV;
4993 maybe_unapply_patches_again();
4994 printdone "source built, results in $dscfn and $sourcechanges";
4999 my $pat = changespat $version;
5001 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5002 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5004 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5005 Suggest you delete @unwanted.
5009 my $wasdir = must_getcwd();
5012 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5013 stat_exists $sourcechanges
5014 or fail "$sourcechanges (in parent directory): $!";
5016 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5017 my @changesfiles = glob $pat;
5018 @changesfiles = sort {
5019 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5022 fail <<END if @changesfiles==1;
5023 only one changes file from sbuild (@changesfiles)
5024 perhaps you need to pass -A ? (sbuild's default is to build only
5025 arch-specific binaries; dgit 1.4 used to override that.)
5027 fail "wrong number of different changes files (@changesfiles)"
5028 unless @changesfiles==2;
5029 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5030 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5031 fail "$l found in binaries changes file $binchanges"
5034 runcmd_ordryrun_local @mergechanges, @changesfiles;
5035 my $multichanges = changespat $version,'multi';
5037 stat_exists $multichanges or fail "$multichanges: $!";
5038 foreach my $cf (glob $pat) {
5039 next if $cf eq $multichanges;
5040 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5044 maybe_unapply_patches_again();
5045 printdone "build successful, results in $multichanges\n" or die $!;
5048 sub cmd_quilt_fixup {
5049 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5050 my $clogp = parsechangelog();
5051 $version = getfield $clogp, 'Version';
5052 $package = getfield $clogp, 'Source';
5055 build_maybe_quilt_fixup();
5058 sub cmd_archive_api_query {
5059 badusage "need only 1 subpath argument" unless @ARGV==1;
5060 my ($subpath) = @ARGV;
5061 my @cmd = archive_api_query_cmd($subpath);
5064 exec @cmd or fail "exec curl: $!\n";
5067 sub cmd_clone_dgit_repos_server {
5068 badusage "need destination argument" unless @ARGV==1;
5069 my ($destdir) = @ARGV;
5070 $package = '_dgit-repos-server';
5071 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5073 exec @cmd or fail "exec git clone: $!\n";
5076 sub cmd_setup_mergechangelogs {
5077 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5078 setup_mergechangelogs(1);
5081 sub cmd_setup_useremail {
5082 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5086 sub cmd_setup_new_tree {
5087 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5091 #---------- argument parsing and main program ----------
5094 print "dgit version $our_version\n" or die $!;
5098 our (%valopts_long, %valopts_short);
5101 sub defvalopt ($$$$) {
5102 my ($long,$short,$val_re,$how) = @_;
5103 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5104 $valopts_long{$long} = $oi;
5105 $valopts_short{$short} = $oi;
5106 # $how subref should:
5107 # do whatever assignemnt or thing it likes with $_[0]
5108 # if the option should not be passed on to remote, @rvalopts=()
5109 # or $how can be a scalar ref, meaning simply assign the value
5112 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5113 defvalopt '--distro', '-d', '.+', \$idistro;
5114 defvalopt '', '-k', '.+', \$keyid;
5115 defvalopt '--existing-package','', '.*', \$existing_package;
5116 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5117 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5118 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5120 defvalopt '', '-C', '.+', sub {
5121 ($changesfile) = (@_);
5122 if ($changesfile =~ s#^(.*)/##) {
5123 $buildproductsdir = $1;
5127 defvalopt '--initiator-tempdir','','.*', sub {
5128 ($initiator_tempdir) = (@_);
5129 $initiator_tempdir =~ m#^/# or
5130 badusage "--initiator-tempdir must be used specify an".
5131 " absolute, not relative, directory."
5137 if (defined $ENV{'DGIT_SSH'}) {
5138 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5139 } elsif (defined $ENV{'GIT_SSH'}) {
5140 @ssh = ($ENV{'GIT_SSH'});
5148 if (!defined $val) {
5149 badusage "$what needs a value" unless @ARGV;
5151 push @rvalopts, $val;
5153 badusage "bad value \`$val' for $what" unless
5154 $val =~ m/^$oi->{Re}$(?!\n)/s;
5155 my $how = $oi->{How};
5156 if (ref($how) eq 'SCALAR') {
5161 push @ropts, @rvalopts;
5165 last unless $ARGV[0] =~ m/^-/;
5169 if (m/^--dry-run$/) {
5172 } elsif (m/^--damp-run$/) {
5175 } elsif (m/^--no-sign$/) {
5178 } elsif (m/^--help$/) {
5180 } elsif (m/^--version$/) {
5182 } elsif (m/^--new$/) {
5185 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5186 ($om = $opts_opt_map{$1}) &&
5190 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5191 !$opts_opt_cmdonly{$1} &&
5192 ($om = $opts_opt_map{$1})) {
5195 } elsif (m/^--(gbp|dpm)$/s) {
5196 push @ropts, "--quilt=$1";
5198 } elsif (m/^--ignore-dirty$/s) {
5201 } elsif (m/^--no-quilt-fixup$/s) {
5203 $quilt_mode = 'nocheck';
5204 } elsif (m/^--no-rm-on-error$/s) {
5207 } elsif (m/^--overwrite$/s) {
5209 $overwrite_version = '';
5210 } elsif (m/^--overwrite=(.+)$/s) {
5212 $overwrite_version = $1;
5213 } elsif (m/^--(no-)?rm-old-changes$/s) {
5216 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5218 push @deliberatelies, $&;
5219 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5223 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5224 # undocumented, for testing
5226 $tagformat_want = [ $1, 'command line', 1 ];
5227 # 1 menas overrides distro configuration
5228 } elsif (m/^--always-split-source-build$/s) {
5229 # undocumented, for testing
5231 $need_split_build_invocation = 1;
5232 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5233 $val = $2 ? $' : undef; #';
5234 $valopt->($oi->{Long});
5236 badusage "unknown long option \`$_'";
5243 } elsif (s/^-L/-/) {
5246 } elsif (s/^-h/-/) {
5248 } elsif (s/^-D/-/) {
5252 } elsif (s/^-N/-/) {
5257 push @changesopts, $_;
5259 } elsif (s/^-wn$//s) {
5261 $cleanmode = 'none';
5262 } elsif (s/^-wg$//s) {
5265 } elsif (s/^-wgf$//s) {
5267 $cleanmode = 'git-ff';
5268 } elsif (s/^-wd$//s) {
5270 $cleanmode = 'dpkg-source';
5271 } elsif (s/^-wdd$//s) {
5273 $cleanmode = 'dpkg-source-d';
5274 } elsif (s/^-wc$//s) {
5276 $cleanmode = 'check';
5277 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5278 push @git, '-c', $&;
5279 $gitcfgs{cmdline}{$1} = [ $2 ];
5280 } elsif (s/^-c([^=]+)$//s) {
5281 push @git, '-c', $&;
5282 $gitcfgs{cmdline}{$1} = [ 'true' ];
5283 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5285 $val = undef unless length $val;
5286 $valopt->($oi->{Short});
5289 badusage "unknown short option \`$_'";
5296 sub check_env_sanity () {
5297 my $blocked = new POSIX::SigSet;
5298 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5301 foreach my $name (qw(PIPE CHLD)) {
5302 my $signame = "SIG$name";
5303 my $signum = eval "POSIX::$signame" // die;
5304 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5305 die "$signame is set to something other than SIG_DFL\n";
5306 $blocked->ismember($signum) and
5307 die "$signame is blocked\n";
5313 On entry to dgit, $@
5314 This is a bug produced by something in in your execution environment.
5320 sub finalise_opts_opts () {
5321 foreach my $k (keys %opts_opt_map) {
5322 my $om = $opts_opt_map{$k};
5324 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5326 badcfg "cannot set command for $k"
5327 unless length $om->[0];
5331 foreach my $c (access_cfg_cfgs("opts-$k")) {
5333 map { $_ ? @$_ : () }
5334 map { $gitcfgs{$_}{$c} }
5335 reverse @gitcfgsources;
5336 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5337 "\n" if $debuglevel >= 4;
5339 badcfg "cannot configure options for $k"
5340 if $opts_opt_cmdonly{$k};
5341 my $insertpos = $opts_cfg_insertpos{$k};
5342 @$om = ( @$om[0..$insertpos-1],
5344 @$om[$insertpos..$#$om] );
5349 if ($ENV{$fakeeditorenv}) {
5351 quilt_fixup_editor();
5358 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5359 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5360 if $dryrun_level == 1;
5362 print STDERR $helpmsg or die $!;
5365 my $cmd = shift @ARGV;
5368 my $pre_fn = ${*::}{"pre_$cmd"};
5369 $pre_fn->() if $pre_fn;
5371 if (!defined $rmchanges) {
5372 local $access_forpush;
5373 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5376 if (!defined $quilt_mode) {
5377 local $access_forpush;
5378 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5379 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5381 $quilt_mode =~ m/^($quilt_modes_re)$/
5382 or badcfg "unknown quilt-mode \`$quilt_mode'";
5386 $need_split_build_invocation ||= quiltmode_splitbrain();
5388 if (!defined $cleanmode) {
5389 local $access_forpush;
5390 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5391 $cleanmode //= 'dpkg-source';
5393 badcfg "unknown clean-mode \`$cleanmode'" unless
5394 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5397 my $fn = ${*::}{"cmd_$cmd"};
5398 $fn or badusage "unknown operation $cmd";