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 } qw(unrepresentable);
79 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
81 our $suite_re = '[-+.0-9a-z]+';
82 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
83 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
84 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
85 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
87 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
88 our $splitbraincache = 'dgit-intern/quilt-cache';
91 our (@dget) = qw(dget);
92 our (@curl) = qw(curl);
93 our (@dput) = qw(dput);
94 our (@debsign) = qw(debsign);
96 our (@sbuild) = qw(sbuild);
98 our (@dgit) = qw(dgit);
99 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
100 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
101 our (@dpkggenchanges) = qw(dpkg-genchanges);
102 our (@mergechanges) = qw(mergechanges -f);
103 our (@gbp_build) = ('');
104 our (@gbp_pq) = ('gbp pq');
105 our (@changesopts) = ('');
107 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
110 'debsign' => \@debsign,
112 'sbuild' => \@sbuild,
116 'dpkg-source' => \@dpkgsource,
117 'dpkg-buildpackage' => \@dpkgbuildpackage,
118 'dpkg-genchanges' => \@dpkggenchanges,
119 'gbp-build' => \@gbp_build,
120 'gbp-pq' => \@gbp_pq,
121 'ch' => \@changesopts,
122 'mergechanges' => \@mergechanges);
124 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
125 our %opts_cfg_insertpos = map {
127 scalar @{ $opts_opt_map{$_} }
128 } keys %opts_opt_map;
130 sub finalise_opts_opts();
136 our $supplementary_message = '';
137 our $need_split_build_invocation = 0;
138 our $split_brain = 0;
142 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
145 our $remotename = 'dgit';
146 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
150 if (!defined $absurdity) {
152 $absurdity =~ s{/[^/]+$}{/absurd} or die;
156 my ($v,$distro) = @_;
157 return $tagformatfn->($v, $distro);
160 sub debiantag_maintview ($$) {
161 my ($v,$distro) = @_;
166 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
168 sub lbranch () { return "$branchprefix/$csuite"; }
169 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
170 sub lref () { return "refs/heads/".lbranch(); }
171 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
172 sub rrref () { return server_ref($csuite); }
174 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
175 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
177 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
178 # locally fetched refs because they have unhelpful names and clutter
179 # up gitk etc. So we track whether we have "used up" head ref (ie,
180 # whether we have made another local ref which refers to this object).
182 # (If we deleted them unconditionally, then we might end up
183 # re-fetching the same git objects each time dgit fetch was run.)
185 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
186 # in git_fetch_us to fetch the refs in question, and possibly a call
187 # to lrfetchref_used.
189 our (%lrfetchrefs_f, %lrfetchrefs_d);
190 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
192 sub lrfetchref_used ($) {
193 my ($fullrefname) = @_;
194 my $objid = $lrfetchrefs_f{$fullrefname};
195 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
206 return "${package}_".(stripepoch $vsn).$sfx
211 return srcfn($vsn,".dsc");
214 sub changespat ($;$) {
215 my ($vsn, $arch) = @_;
216 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
225 foreach my $f (@end) {
227 print STDERR "$us: cleanup: $@" if length $@;
231 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
233 sub forceable_fail ($$) {
234 my ($forceoptsl, $msg) = @_;
235 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
236 print STDERR "warning: overriding problem due to --force:\n". $msg;
239 sub no_such_package () {
240 print STDERR "$us: package $package does not exist in suite $isuite\n";
246 printdebug "CD $newdir\n";
247 chdir $newdir or confess "chdir: $newdir: $!";
250 sub deliberately ($) {
252 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
255 sub deliberately_not_fast_forward () {
256 foreach (qw(not-fast-forward fresh-repo)) {
257 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
261 sub quiltmode_splitbrain () {
262 $quilt_mode =~ m/gbp|dpm|unapplied/;
265 sub opts_opt_multi_cmd {
267 push @cmd, split /\s+/, shift @_;
273 return opts_opt_multi_cmd @gbp_pq;
276 #---------- remote protocol support, common ----------
278 # remote push initiator/responder protocol:
279 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
280 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
281 # < dgit-remote-push-ready <actual-proto-vsn>
288 # > supplementary-message NBYTES # $protovsn >= 3
293 # > file parsed-changelog
294 # [indicates that output of dpkg-parsechangelog follows]
295 # > data-block NBYTES
296 # > [NBYTES bytes of data (no newline)]
297 # [maybe some more blocks]
306 # > param head DGIT-VIEW-HEAD
307 # > param csuite SUITE
308 # > param tagformat old|new
309 # > param maint-view MAINT-VIEW-HEAD
311 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
312 # # goes into tag, for replay prevention
315 # [indicates that signed tag is wanted]
316 # < data-block NBYTES
317 # < [NBYTES bytes of data (no newline)]
318 # [maybe some more blocks]
322 # > want signed-dsc-changes
323 # < data-block NBYTES [transfer of signed dsc]
325 # < data-block NBYTES [transfer of signed changes]
333 sub i_child_report () {
334 # Sees if our child has died, and reap it if so. Returns a string
335 # describing how it died if it failed, or undef otherwise.
336 return undef unless $i_child_pid;
337 my $got = waitpid $i_child_pid, WNOHANG;
338 return undef if $got <= 0;
339 die unless $got == $i_child_pid;
340 $i_child_pid = undef;
341 return undef unless $?;
342 return "build host child ".waitstatusmsg();
347 fail "connection lost: $!" if $fh->error;
348 fail "protocol violation; $m not expected";
351 sub badproto_badread ($$) {
353 fail "connection lost: $!" if $!;
354 my $report = i_child_report();
355 fail $report if defined $report;
356 badproto $fh, "eof (reading $wh)";
359 sub protocol_expect (&$) {
360 my ($match, $fh) = @_;
363 defined && chomp or badproto_badread $fh, "protocol message";
371 badproto $fh, "\`$_'";
374 sub protocol_send_file ($$) {
375 my ($fh, $ourfn) = @_;
376 open PF, "<", $ourfn or die "$ourfn: $!";
379 my $got = read PF, $d, 65536;
380 die "$ourfn: $!" unless defined $got;
382 print $fh "data-block ".length($d)."\n" or die $!;
383 print $fh $d or die $!;
385 PF->error and die "$ourfn $!";
386 print $fh "data-end\n" or die $!;
390 sub protocol_read_bytes ($$) {
391 my ($fh, $nbytes) = @_;
392 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
394 my $got = read $fh, $d, $nbytes;
395 $got==$nbytes or badproto_badread $fh, "data block";
399 sub protocol_receive_file ($$) {
400 my ($fh, $ourfn) = @_;
401 printdebug "() $ourfn\n";
402 open PF, ">", $ourfn or die "$ourfn: $!";
404 my ($y,$l) = protocol_expect {
405 m/^data-block (.*)$/ ? (1,$1) :
406 m/^data-end$/ ? (0,) :
410 my $d = protocol_read_bytes $fh, $l;
411 print PF $d or die $!;
416 #---------- remote protocol support, responder ----------
418 sub responder_send_command ($) {
420 return unless $we_are_responder;
421 # called even without $we_are_responder
422 printdebug ">> $command\n";
423 print PO $command, "\n" or die $!;
426 sub responder_send_file ($$) {
427 my ($keyword, $ourfn) = @_;
428 return unless $we_are_responder;
429 printdebug "]] $keyword $ourfn\n";
430 responder_send_command "file $keyword";
431 protocol_send_file \*PO, $ourfn;
434 sub responder_receive_files ($@) {
435 my ($keyword, @ourfns) = @_;
436 die unless $we_are_responder;
437 printdebug "[[ $keyword @ourfns\n";
438 responder_send_command "want $keyword";
439 foreach my $fn (@ourfns) {
440 protocol_receive_file \*PI, $fn;
443 protocol_expect { m/^files-end$/ } \*PI;
446 #---------- remote protocol support, initiator ----------
448 sub initiator_expect (&) {
450 protocol_expect { &$match } \*RO;
453 #---------- end remote code ----------
456 if ($we_are_responder) {
458 responder_send_command "progress ".length($m) or die $!;
459 print PO $m or die $!;
469 $ua = LWP::UserAgent->new();
473 progress "downloading $what...";
474 my $r = $ua->get(@_) or die $!;
475 return undef if $r->code == 404;
476 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
477 return $r->decoded_content(charset => 'none');
480 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
485 failedcmd @_ if system @_;
488 sub act_local () { return $dryrun_level <= 1; }
489 sub act_scary () { return !$dryrun_level; }
492 if (!$dryrun_level) {
493 progress "dgit ok: @_";
495 progress "would be ok: @_ (but dry run only)";
500 printcmd(\*STDERR,$debugprefix."#",@_);
503 sub runcmd_ordryrun {
511 sub runcmd_ordryrun_local {
520 my ($first_shell, @cmd) = @_;
521 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
524 our $helpmsg = <<END;
526 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
527 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
528 dgit [dgit-opts] build [dpkg-buildpackage-opts]
529 dgit [dgit-opts] sbuild [sbuild-opts]
530 dgit [dgit-opts] push [dgit-opts] [suite]
531 dgit [dgit-opts] rpush build-host:build-dir ...
532 important dgit options:
533 -k<keyid> sign tag and package with <keyid> instead of default
534 --dry-run -n do not change anything, but go through the motions
535 --damp-run -L like --dry-run but make local changes, without signing
536 --new -N allow introducing a new package
537 --debug -D increase debug level
538 -c<name>=<value> set git config option (used directly by dgit too)
541 our $later_warning_msg = <<END;
542 Perhaps the upload is stuck in incoming. Using the version from git.
546 print STDERR "$us: @_\n", $helpmsg or die $!;
551 @ARGV or badusage "too few arguments";
552 return scalar shift @ARGV;
556 print $helpmsg or die $!;
560 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
562 our %defcfg = ('dgit.default.distro' => 'debian',
563 'dgit.default.username' => '',
564 'dgit.default.archive-query-default-component' => 'main',
565 'dgit.default.ssh' => 'ssh',
566 'dgit.default.archive-query' => 'madison:',
567 'dgit.default.sshpsql-dbname' => 'service=projectb',
568 'dgit.default.dgit-tag-format' => 'new,old,maint',
569 # old means "repo server accepts pushes with old dgit tags"
570 # new means "repo server accepts pushes with new dgit tags"
571 # maint means "repo server accepts split brain pushes"
572 # hist means "repo server may have old pushes without new tag"
573 # ("hist" is implied by "old")
574 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
575 'dgit-distro.debian.git-check' => 'url',
576 'dgit-distro.debian.git-check-suffix' => '/info/refs',
577 'dgit-distro.debian.new-private-pushers' => 't',
578 'dgit-distro.debian/push.git-url' => '',
579 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
580 'dgit-distro.debian/push.git-user-force' => 'dgit',
581 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
582 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
583 'dgit-distro.debian/push.git-create' => 'true',
584 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
585 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
586 # 'dgit-distro.debian.archive-query-tls-key',
587 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
588 # ^ this does not work because curl is broken nowadays
589 # Fixing #790093 properly will involve providing providing the key
590 # in some pacagke and maybe updating these paths.
592 # 'dgit-distro.debian.archive-query-tls-curl-args',
593 # '--ca-path=/etc/ssl/ca-debian',
594 # ^ this is a workaround but works (only) on DSA-administered machines
595 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
596 'dgit-distro.debian.git-url-suffix' => '',
597 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
598 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
599 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
600 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
601 'dgit-distro.ubuntu.git-check' => 'false',
602 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
603 'dgit-distro.test-dummy.ssh' => "$td/ssh",
604 'dgit-distro.test-dummy.username' => "alice",
605 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
606 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
607 'dgit-distro.test-dummy.git-url' => "$td/git",
608 'dgit-distro.test-dummy.git-host' => "git",
609 'dgit-distro.test-dummy.git-path' => "$td/git",
610 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
611 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
612 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
613 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
617 our @gitcfgsources = qw(cmdline local global system);
619 sub git_slurp_config () {
620 local ($debuglevel) = $debuglevel-2;
623 # This algoritm is a bit subtle, but this is needed so that for
624 # options which we want to be single-valued, we allow the
625 # different config sources to override properly. See #835858.
626 foreach my $src (@gitcfgsources) {
627 next if $src eq 'cmdline';
628 # we do this ourselves since git doesn't handle it
630 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
633 open GITS, "-|", @cmd or die $!;
636 printdebug "=> ", (messagequote $_), "\n";
638 push @{ $gitcfgs{$src}{$`} }, $'; #';
642 or ($!==0 && $?==256)
647 sub git_get_config ($) {
649 foreach my $src (@gitcfgsources) {
650 my $l = $gitcfgs{$src}{$c};
651 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
654 @$l==1 or badcfg "multiple values for $c".
655 " (in $src git config)" if @$l > 1;
663 return undef if $c =~ /RETURN-UNDEF/;
664 my $v = git_get_config($c);
665 return $v if defined $v;
666 my $dv = $defcfg{$c};
667 return $dv if defined $dv;
669 badcfg "need value for one of: @_\n".
670 "$us: distro or suite appears not to be (properly) supported";
673 sub access_basedistro () {
674 if (defined $idistro) {
677 return cfg("dgit-suite.$isuite.distro",
678 "dgit.default.distro");
682 sub access_quirk () {
683 # returns (quirk name, distro to use instead or undef, quirk-specific info)
684 my $basedistro = access_basedistro();
685 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
687 if (defined $backports_quirk) {
688 my $re = $backports_quirk;
689 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
691 $re =~ s/\%/([-0-9a-z_]+)/
692 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
693 if ($isuite =~ m/^$re$/) {
694 return ('backports',"$basedistro-backports",$1);
697 return ('none',undef);
702 sub parse_cfg_bool ($$$) {
703 my ($what,$def,$v) = @_;
706 $v =~ m/^[ty1]/ ? 1 :
707 $v =~ m/^[fn0]/ ? 0 :
708 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
711 sub access_forpush_config () {
712 my $d = access_basedistro();
716 parse_cfg_bool('new-private-pushers', 0,
717 cfg("dgit-distro.$d.new-private-pushers",
720 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
723 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
724 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
725 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
726 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
729 sub access_forpush () {
730 $access_forpush //= access_forpush_config();
731 return $access_forpush;
735 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
736 badcfg "pushing but distro is configured readonly"
737 if access_forpush_config() eq '0';
739 $supplementary_message = <<'END' unless $we_are_responder;
740 Push failed, before we got started.
741 You can retry the push, after fixing the problem, if you like.
743 finalise_opts_opts();
747 finalise_opts_opts();
750 sub supplementary_message ($) {
752 if (!$we_are_responder) {
753 $supplementary_message = $msg;
755 } elsif ($protovsn >= 3) {
756 responder_send_command "supplementary-message ".length($msg)
758 print PO $msg or die $!;
762 sub access_distros () {
763 # Returns list of distros to try, in order
766 # 0. `instead of' distro name(s) we have been pointed to
767 # 1. the access_quirk distro, if any
768 # 2a. the user's specified distro, or failing that } basedistro
769 # 2b. the distro calculated from the suite }
770 my @l = access_basedistro();
772 my (undef,$quirkdistro) = access_quirk();
773 unshift @l, $quirkdistro;
774 unshift @l, $instead_distro;
775 @l = grep { defined } @l;
777 if (access_forpush()) {
778 @l = map { ("$_/push", $_) } @l;
783 sub access_cfg_cfgs (@) {
786 # The nesting of these loops determines the search order. We put
787 # the key loop on the outside so that we search all the distros
788 # for each key, before going on to the next key. That means that
789 # if access_cfg is called with a more specific, and then a less
790 # specific, key, an earlier distro can override the less specific
791 # without necessarily overriding any more specific keys. (If the
792 # distro wants to override the more specific keys it can simply do
793 # so; whereas if we did the loop the other way around, it would be
794 # impossible to for an earlier distro to override a less specific
795 # key but not the more specific ones without restating the unknown
796 # values of the more specific keys.
799 # We have to deal with RETURN-UNDEF specially, so that we don't
800 # terminate the search prematurely.
802 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
805 foreach my $d (access_distros()) {
806 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
808 push @cfgs, map { "dgit.default.$_" } @realkeys;
815 my (@cfgs) = access_cfg_cfgs(@keys);
816 my $value = cfg(@cfgs);
820 sub access_cfg_bool ($$) {
821 my ($def, @keys) = @_;
822 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
825 sub string_to_ssh ($) {
827 if ($spec =~ m/\s/) {
828 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
834 sub access_cfg_ssh () {
835 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
836 if (!defined $gitssh) {
839 return string_to_ssh $gitssh;
843 sub access_runeinfo ($) {
845 return ": dgit ".access_basedistro()." $info ;";
848 sub access_someuserhost ($) {
850 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
851 defined($user) && length($user) or
852 $user = access_cfg("$some-user",'username');
853 my $host = access_cfg("$some-host");
854 return length($user) ? "$user\@$host" : $host;
857 sub access_gituserhost () {
858 return access_someuserhost('git');
861 sub access_giturl (;$) {
863 my $url = access_cfg('git-url','RETURN-UNDEF');
866 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
867 return undef unless defined $proto;
870 access_gituserhost().
871 access_cfg('git-path');
873 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
876 return "$url/$package$suffix";
879 sub parsecontrolfh ($$;$) {
880 my ($fh, $desc, $allowsigned) = @_;
881 our $dpkgcontrolhash_noissigned;
884 my %opts = ('name' => $desc);
885 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
886 $c = Dpkg::Control::Hash->new(%opts);
887 $c->parse($fh,$desc) or die "parsing of $desc failed";
888 last if $allowsigned;
889 last if $dpkgcontrolhash_noissigned;
890 my $issigned= $c->get_option('is_pgp_signed');
891 if (!defined $issigned) {
892 $dpkgcontrolhash_noissigned= 1;
893 seek $fh, 0,0 or die "seek $desc: $!";
894 } elsif ($issigned) {
895 fail "control file $desc is (already) PGP-signed. ".
896 " Note that dgit push needs to modify the .dsc and then".
897 " do the signature itself";
906 my ($file, $desc) = @_;
907 my $fh = new IO::Handle;
908 open $fh, '<', $file or die "$file: $!";
909 my $c = parsecontrolfh($fh,$desc);
910 $fh->error and die $!;
916 my ($dctrl,$field) = @_;
917 my $v = $dctrl->{$field};
918 return $v if defined $v;
919 fail "missing field $field in ".$dctrl->get_option('name');
923 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
924 my $p = new IO::Handle;
925 my @cmd = (qw(dpkg-parsechangelog), @_);
926 open $p, '-|', @cmd or die $!;
928 $?=0; $!=0; close $p or failedcmd @cmd;
932 sub commit_getclogp ($) {
933 # Returns the parsed changelog hashref for a particular commit
935 our %commit_getclogp_memo;
936 my $memo = $commit_getclogp_memo{$objid};
937 return $memo if $memo;
939 my $mclog = ".git/dgit/clog-$objid";
940 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
941 "$objid:debian/changelog";
942 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
947 defined $d or fail "getcwd failed: $!";
953 sub archive_query ($) {
955 my $query = access_cfg('archive-query','RETURN-UNDEF');
956 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
959 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
962 sub pool_dsc_subpath ($$) {
963 my ($vsn,$component) = @_; # $package is implict arg
964 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
965 return "/pool/$component/$prefix/$package/".dscfn($vsn);
968 #---------- `ftpmasterapi' archive query method (nascent) ----------
970 sub archive_api_query_cmd ($) {
972 my @cmd = (@curl, qw(-sS));
973 my $url = access_cfg('archive-query-url');
974 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
976 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
977 foreach my $key (split /\:/, $keys) {
978 $key =~ s/\%HOST\%/$host/g;
980 fail "for $url: stat $key: $!" unless $!==ENOENT;
983 fail "config requested specific TLS key but do not know".
984 " how to get curl to use exactly that EE key ($key)";
985 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
986 # # Sadly the above line does not work because of changes
987 # # to gnutls. The real fix for #790093 may involve
988 # # new curl options.
991 # Fixing #790093 properly will involve providing a value
992 # for this on clients.
993 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
994 push @cmd, split / /, $kargs if defined $kargs;
996 push @cmd, $url.$subpath;
1000 sub api_query ($$) {
1002 my ($data, $subpath) = @_;
1003 badcfg "ftpmasterapi archive query method takes no data part"
1005 my @cmd = archive_api_query_cmd($subpath);
1006 my $url = $cmd[$#cmd];
1007 push @cmd, qw(-w %{http_code});
1008 my $json = cmdoutput @cmd;
1009 unless ($json =~ s/\d+\d+\d$//) {
1010 failedcmd_report_cmd undef, @cmd;
1011 fail "curl failed to print 3-digit HTTP code";
1014 fail "fetch of $url gave HTTP code $code"
1015 unless $url =~ m#^file://# or $code =~ m/^2/;
1016 return decode_json($json);
1019 sub canonicalise_suite_ftpmasterapi () {
1020 my ($proto,$data) = @_;
1021 my $suites = api_query($data, 'suites');
1023 foreach my $entry (@$suites) {
1025 my $v = $entry->{$_};
1026 defined $v && $v eq $isuite;
1027 } qw(codename name);
1028 push @matched, $entry;
1030 fail "unknown suite $isuite" unless @matched;
1033 @matched==1 or die "multiple matches for suite $isuite\n";
1034 $cn = "$matched[0]{codename}";
1035 defined $cn or die "suite $isuite info has no codename\n";
1036 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1038 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1043 sub archive_query_ftpmasterapi () {
1044 my ($proto,$data) = @_;
1045 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1047 my $digester = Digest::SHA->new(256);
1048 foreach my $entry (@$info) {
1050 my $vsn = "$entry->{version}";
1051 my ($ok,$msg) = version_check $vsn;
1052 die "bad version: $msg\n" unless $ok;
1053 my $component = "$entry->{component}";
1054 $component =~ m/^$component_re$/ or die "bad component";
1055 my $filename = "$entry->{filename}";
1056 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1057 or die "bad filename";
1058 my $sha256sum = "$entry->{sha256sum}";
1059 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1060 push @rows, [ $vsn, "/pool/$component/$filename",
1061 $digester, $sha256sum ];
1063 die "bad ftpmaster api response: $@\n".Dumper($entry)
1066 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1070 #---------- `madison' archive query method ----------
1072 sub archive_query_madison {
1073 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1076 sub madison_get_parse {
1077 my ($proto,$data) = @_;
1078 die unless $proto eq 'madison';
1079 if (!length $data) {
1080 $data= access_cfg('madison-distro','RETURN-UNDEF');
1081 $data //= access_basedistro();
1083 $rmad{$proto,$data,$package} ||= cmdoutput
1084 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1085 my $rmad = $rmad{$proto,$data,$package};
1088 foreach my $l (split /\n/, $rmad) {
1089 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1090 \s*( [^ \t|]+ )\s* \|
1091 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1092 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1093 $1 eq $package or die "$rmad $package ?";
1100 $component = access_cfg('archive-query-default-component');
1102 $5 eq 'source' or die "$rmad ?";
1103 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1105 return sort { -version_compare($a->[0],$b->[0]); } @out;
1108 sub canonicalise_suite_madison {
1109 # madison canonicalises for us
1110 my @r = madison_get_parse(@_);
1112 "unable to canonicalise suite using package $package".
1113 " which does not appear to exist in suite $isuite;".
1114 " --existing-package may help";
1118 #---------- `sshpsql' archive query method ----------
1121 my ($data,$runeinfo,$sql) = @_;
1122 if (!length $data) {
1123 $data= access_someuserhost('sshpsql').':'.
1124 access_cfg('sshpsql-dbname');
1126 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1127 my ($userhost,$dbname) = ($`,$'); #';
1129 my @cmd = (access_cfg_ssh, $userhost,
1130 access_runeinfo("ssh-psql $runeinfo").
1131 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1132 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1134 open P, "-|", @cmd or die $!;
1137 printdebug(">|$_|\n");
1140 $!=0; $?=0; close P or failedcmd @cmd;
1142 my $nrows = pop @rows;
1143 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1144 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1145 @rows = map { [ split /\|/, $_ ] } @rows;
1146 my $ncols = scalar @{ shift @rows };
1147 die if grep { scalar @$_ != $ncols } @rows;
1151 sub sql_injection_check {
1152 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1155 sub archive_query_sshpsql ($$) {
1156 my ($proto,$data) = @_;
1157 sql_injection_check $isuite, $package;
1158 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1159 SELECT source.version, component.name, files.filename, files.sha256sum
1161 JOIN src_associations ON source.id = src_associations.source
1162 JOIN suite ON suite.id = src_associations.suite
1163 JOIN dsc_files ON dsc_files.source = source.id
1164 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1165 JOIN component ON component.id = files_archive_map.component_id
1166 JOIN files ON files.id = dsc_files.file
1167 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1168 AND source.source='$package'
1169 AND files.filename LIKE '%.dsc';
1171 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1172 my $digester = Digest::SHA->new(256);
1174 my ($vsn,$component,$filename,$sha256sum) = @$_;
1175 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1180 sub canonicalise_suite_sshpsql ($$) {
1181 my ($proto,$data) = @_;
1182 sql_injection_check $isuite;
1183 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1184 SELECT suite.codename
1185 FROM suite where suite_name='$isuite' or codename='$isuite';
1187 @rows = map { $_->[0] } @rows;
1188 fail "unknown suite $isuite" unless @rows;
1189 die "ambiguous $isuite: @rows ?" if @rows>1;
1193 #---------- `dummycat' archive query method ----------
1195 sub canonicalise_suite_dummycat ($$) {
1196 my ($proto,$data) = @_;
1197 my $dpath = "$data/suite.$isuite";
1198 if (!open C, "<", $dpath) {
1199 $!==ENOENT or die "$dpath: $!";
1200 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1204 chomp or die "$dpath: $!";
1206 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1210 sub archive_query_dummycat ($$) {
1211 my ($proto,$data) = @_;
1212 canonicalise_suite();
1213 my $dpath = "$data/package.$csuite.$package";
1214 if (!open C, "<", $dpath) {
1215 $!==ENOENT or die "$dpath: $!";
1216 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1224 printdebug "dummycat query $csuite $package $dpath | $_\n";
1225 my @row = split /\s+/, $_;
1226 @row==2 or die "$dpath: $_ ?";
1229 C->error and die "$dpath: $!";
1231 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1234 #---------- tag format handling ----------
1236 sub access_cfg_tagformats () {
1237 split /\,/, access_cfg('dgit-tag-format');
1240 sub need_tagformat ($$) {
1241 my ($fmt, $why) = @_;
1242 fail "need to use tag format $fmt ($why) but also need".
1243 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1244 " - no way to proceed"
1245 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1246 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1249 sub select_tagformat () {
1251 return if $tagformatfn && !$tagformat_want;
1252 die 'bug' if $tagformatfn && $tagformat_want;
1253 # ... $tagformat_want assigned after previous select_tagformat
1255 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1256 printdebug "select_tagformat supported @supported\n";
1258 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1259 printdebug "select_tagformat specified @$tagformat_want\n";
1261 my ($fmt,$why,$override) = @$tagformat_want;
1263 fail "target distro supports tag formats @supported".
1264 " but have to use $fmt ($why)"
1266 or grep { $_ eq $fmt } @supported;
1268 $tagformat_want = undef;
1270 $tagformatfn = ${*::}{"debiantag_$fmt"};
1272 fail "trying to use unknown tag format \`$fmt' ($why) !"
1273 unless $tagformatfn;
1276 #---------- archive query entrypoints and rest of program ----------
1278 sub canonicalise_suite () {
1279 return if defined $csuite;
1280 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1281 $csuite = archive_query('canonicalise_suite');
1282 if ($isuite ne $csuite) {
1283 progress "canonical suite name for $isuite is $csuite";
1287 sub get_archive_dsc () {
1288 canonicalise_suite();
1289 my @vsns = archive_query('archive_query');
1290 foreach my $vinfo (@vsns) {
1291 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1292 $dscurl = access_cfg('mirror').$subpath;
1293 $dscdata = url_get($dscurl);
1295 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1300 $digester->add($dscdata);
1301 my $got = $digester->hexdigest();
1303 fail "$dscurl has hash $got but".
1304 " archive told us to expect $digest";
1306 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1307 printdebug Dumper($dscdata) if $debuglevel>1;
1308 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1309 printdebug Dumper($dsc) if $debuglevel>1;
1310 my $fmt = getfield $dsc, 'Format';
1311 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1312 $dsc_checked = !!$digester;
1313 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1317 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1320 sub check_for_git ();
1321 sub check_for_git () {
1323 my $how = access_cfg('git-check');
1324 if ($how eq 'ssh-cmd') {
1326 (access_cfg_ssh, access_gituserhost(),
1327 access_runeinfo("git-check $package").
1328 " set -e; cd ".access_cfg('git-path').";".
1329 " if test -d $package.git; then echo 1; else echo 0; fi");
1330 my $r= cmdoutput @cmd;
1331 if (defined $r and $r =~ m/^divert (\w+)$/) {
1333 my ($usedistro,) = access_distros();
1334 # NB that if we are pushing, $usedistro will be $distro/push
1335 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1336 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1337 progress "diverting to $divert (using config for $instead_distro)";
1338 return check_for_git();
1340 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1342 } elsif ($how eq 'url') {
1343 my $prefix = access_cfg('git-check-url','git-url');
1344 my $suffix = access_cfg('git-check-suffix','git-suffix',
1345 'RETURN-UNDEF') // '.git';
1346 my $url = "$prefix/$package$suffix";
1347 my @cmd = (@curl, qw(-sS -I), $url);
1348 my $result = cmdoutput @cmd;
1349 $result =~ s/^\S+ 200 .*\n\r?\n//;
1350 # curl -sS -I with https_proxy prints
1351 # HTTP/1.0 200 Connection established
1352 $result =~ m/^\S+ (404|200) /s or
1353 fail "unexpected results from git check query - ".
1354 Dumper($prefix, $result);
1356 if ($code eq '404') {
1358 } elsif ($code eq '200') {
1363 } elsif ($how eq 'true') {
1365 } elsif ($how eq 'false') {
1368 badcfg "unknown git-check \`$how'";
1372 sub create_remote_git_repo () {
1373 my $how = access_cfg('git-create');
1374 if ($how eq 'ssh-cmd') {
1376 (access_cfg_ssh, access_gituserhost(),
1377 access_runeinfo("git-create $package").
1378 "set -e; cd ".access_cfg('git-path').";".
1379 " cp -a _template $package.git");
1380 } elsif ($how eq 'true') {
1383 badcfg "unknown git-create \`$how'";
1387 our ($dsc_hash,$lastpush_mergeinput);
1389 our $ud = '.git/dgit/unpack';
1399 sub mktree_in_ud_here () {
1400 runcmd qw(git init -q);
1401 runcmd qw(git config gc.auto 0);
1402 rmtree('.git/objects');
1403 symlink '../../../../objects','.git/objects' or die $!;
1406 sub git_write_tree () {
1407 my $tree = cmdoutput @git, qw(write-tree);
1408 $tree =~ m/^\w+$/ or die "$tree ?";
1412 sub remove_stray_gits () {
1413 my @gitscmd = qw(find -name .git -prune -print0);
1414 debugcmd "|",@gitscmd;
1415 open GITS, "-|", @gitscmd or die $!;
1420 print STDERR "$us: warning: removing from source package: ",
1421 (messagequote $_), "\n";
1425 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1428 sub mktree_in_ud_from_only_subdir (;$) {
1431 # changes into the subdir
1433 die "expected one subdir but found @dirs ?" unless @dirs==1;
1434 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1438 remove_stray_gits();
1439 mktree_in_ud_here();
1441 my ($format, $fopts) = get_source_format();
1442 if (madformat($format)) {
1447 runcmd @git, qw(add -Af);
1448 my $tree=git_write_tree();
1449 return ($tree,$dir);
1452 our @files_csum_info_fields =
1453 (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1454 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1455 ['Files', 'Digest::MD5', 'new()']);
1457 sub dsc_files_info () {
1458 foreach my $csumi (@files_csum_info_fields) {
1459 my ($fname, $module, $method) = @$csumi;
1460 my $field = $dsc->{$fname};
1461 next unless defined $field;
1462 eval "use $module; 1;" or die $@;
1464 foreach (split /\n/, $field) {
1466 m/^(\w+) (\d+) (\S+)$/ or
1467 fail "could not parse .dsc $fname line \`$_'";
1468 my $digester = eval "$module"."->$method;" or die $@;
1473 Digester => $digester,
1478 fail "missing any supported Checksums-* or Files field in ".
1479 $dsc->get_option('name');
1483 map { $_->{Filename} } dsc_files_info();
1486 sub files_compare_inputs (@) {
1491 my $showinputs = sub {
1492 return join "; ", map { $_->get_option('name') } @$inputs;
1495 foreach my $in (@$inputs) {
1497 my $in_name = $in->get_option('name');
1499 printdebug "files_compare_inputs $in_name\n";
1501 foreach my $csumi (@files_csum_info_fields) {
1502 my ($fname) = @$csumi;
1503 printdebug "files_compare_inputs $in_name $fname\n";
1505 my $field = $in->{$fname};
1506 next unless defined $field;
1509 foreach (split /\n/, $field) {
1512 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1513 fail "could not parse $in_name $fname line \`$_'";
1515 printdebug "files_compare_inputs $in_name $fname $f\n";
1519 my $re = \ $record{$f}{$fname};
1521 $fchecked{$f}{$in_name} = 1;
1523 fail "hash or size of $f varies in $fname fields".
1524 " (between: ".$showinputs->().")";
1529 @files = sort @files;
1530 $expected_files //= \@files;
1531 "@$expected_files" eq "@files" or
1532 fail "file list in $in_name varies between hash fields!";
1535 fail "$in_name has no files list field(s)";
1537 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1540 grep { keys %$_ == @$inputs-1 } values %fchecked
1541 or fail "no file appears in all file lists".
1542 " (looked in: ".$showinputs->().")";
1545 sub is_orig_file_in_dsc ($$) {
1546 my ($f, $dsc_files_info) = @_;
1547 return 0 if @$dsc_files_info <= 1;
1548 # One file means no origs, and the filename doesn't have a "what
1549 # part of dsc" component. (Consider versions ending `.orig'.)
1550 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1554 sub is_orig_file_of_vsn ($$) {
1555 my ($f, $upstreamvsn) = @_;
1556 my $base = srcfn $upstreamvsn, '';
1557 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1561 sub make_commit ($) {
1563 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1566 sub make_commit_text ($) {
1569 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1571 print Dumper($text) if $debuglevel > 1;
1572 my $child = open2($out, $in, @cmd) or die $!;
1575 print $in $text or die $!;
1576 close $in or die $!;
1578 $h =~ m/^\w+$/ or die;
1580 printdebug "=> $h\n";
1583 waitpid $child, 0 == $child or die "$child $!";
1584 $? and failedcmd @cmd;
1588 sub clogp_authline ($) {
1590 my $author = getfield $clogp, 'Maintainer';
1591 $author =~ s#,.*##ms;
1592 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1593 my $authline = "$author $date";
1594 $authline =~ m/$git_authline_re/o or
1595 fail "unexpected commit author line format \`$authline'".
1596 " (was generated from changelog Maintainer field)";
1597 return ($1,$2,$3) if wantarray;
1601 sub vendor_patches_distro ($$) {
1602 my ($checkdistro, $what) = @_;
1603 return unless defined $checkdistro;
1605 my $series = "debian/patches/\L$checkdistro\E.series";
1606 printdebug "checking for vendor-specific $series ($what)\n";
1608 if (!open SERIES, "<", $series) {
1609 die "$series $!" unless $!==ENOENT;
1618 Unfortunately, this source package uses a feature of dpkg-source where
1619 the same source package unpacks to different source code on different
1620 distros. dgit cannot safely operate on such packages on affected
1621 distros, because the meaning of source packages is not stable.
1623 Please ask the distro/maintainer to remove the distro-specific series
1624 files and use a different technique (if necessary, uploading actually
1625 different packages, if different distros are supposed to have
1629 fail "Found active distro-specific series file for".
1630 " $checkdistro ($what): $series, cannot continue";
1632 die "$series $!" if SERIES->error;
1636 sub check_for_vendor_patches () {
1637 # This dpkg-source feature doesn't seem to be documented anywhere!
1638 # But it can be found in the changelog (reformatted):
1640 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1641 # Author: Raphael Hertzog <hertzog@debian.org>
1642 # Date: Sun Oct 3 09:36:48 2010 +0200
1644 # dpkg-source: correctly create .pc/.quilt_series with alternate
1647 # If you have debian/patches/ubuntu.series and you were
1648 # unpacking the source package on ubuntu, quilt was still
1649 # directed to debian/patches/series instead of
1650 # debian/patches/ubuntu.series.
1652 # debian/changelog | 3 +++
1653 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1654 # 2 files changed, 6 insertions(+), 1 deletion(-)
1657 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1658 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1659 "Dpkg::Vendor \`current vendor'");
1660 vendor_patches_distro(access_basedistro(),
1661 "distro being accessed");
1664 sub generate_commits_from_dsc () {
1665 # See big comment in fetch_from_archive, below.
1666 # See also README.dsc-import.
1670 my @dfi = dsc_files_info();
1671 foreach my $fi (@dfi) {
1672 my $f = $fi->{Filename};
1673 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1675 link_ltarget "../../../$f", $f
1679 complete_file_from_dsc('.', $fi)
1682 if (is_orig_file_in_dsc($f, \@dfi)) {
1683 link $f, "../../../../$f"
1689 # We unpack and record the orig tarballs first, so that we only
1690 # need disk space for one private copy of the unpacked source.
1691 # But we can't make them into commits until we have the metadata
1692 # from the debian/changelog, so we record the tree objects now and
1693 # make them into commits later.
1695 my $upstreamv = $dsc->{version};
1696 $upstreamv =~ s/-[^-]+$//;
1697 my $orig_f_base = srcfn $upstreamv, '';
1699 foreach my $fi (@dfi) {
1700 # We actually import, and record as a commit, every tarball
1701 # (unless there is only one file, in which case there seems
1704 my $f = $fi->{Filename};
1705 printdebug "import considering $f ";
1706 (printdebug "only one dfi\n"), next if @dfi == 1;
1707 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1708 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1712 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1714 printdebug "Y ", (join ' ', map { $_//"(none)" }
1715 $compr_ext, $orig_f_part
1718 my $input = new IO::File $f, '<' or die "$f $!";
1722 if (defined $compr_ext) {
1724 Dpkg::Compression::compression_guess_from_filename $f;
1725 fail "Dpkg::Compression cannot handle file $f in source package"
1726 if defined $compr_ext && !defined $cname;
1728 new Dpkg::Compression::Process compression => $cname;
1729 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1730 my $compr_fh = new IO::Handle;
1731 my $compr_pid = open $compr_fh, "-|" // die $!;
1733 open STDIN, "<&", $input or die $!;
1735 die "dgit (child): exec $compr_cmd[0]: $!\n";
1740 rmtree "../unpack-tar";
1741 mkdir "../unpack-tar" or die $!;
1742 my @tarcmd = qw(tar -x -f -
1743 --no-same-owner --no-same-permissions
1744 --no-acls --no-xattrs --no-selinux);
1745 my $tar_pid = fork // die $!;
1747 chdir "../unpack-tar" or die $!;
1748 open STDIN, "<&", $input or die $!;
1750 die "dgit (child): exec $tarcmd[0]: $!";
1752 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1753 !$? or failedcmd @tarcmd;
1756 (@compr_cmd ? failedcmd @compr_cmd
1758 # finally, we have the results in "tarball", but maybe
1759 # with the wrong permissions
1761 runcmd qw(chmod -R +rwX ../unpack-tar);
1762 changedir "../unpack-tar";
1763 my ($tree) = mktree_in_ud_from_only_subdir(1);
1764 changedir "../../unpack";
1765 rmtree "../unpack-tar";
1767 my $ent = [ $f, $tree ];
1769 Orig => !!$orig_f_part,
1770 Sort => (!$orig_f_part ? 2 :
1771 $orig_f_part =~ m/-/g ? 1 :
1779 # put any without "_" first (spec is not clear whether files
1780 # are always in the usual order). Tarballs without "_" are
1781 # the main orig or the debian tarball.
1782 $a->{Sort} <=> $b->{Sort} or
1786 my $any_orig = grep { $_->{Orig} } @tartrees;
1788 my $dscfn = "$package.dsc";
1790 my $treeimporthow = 'package';
1792 open D, ">", $dscfn or die "$dscfn: $!";
1793 print D $dscdata or die "$dscfn: $!";
1794 close D or die "$dscfn: $!";
1795 my @cmd = qw(dpkg-source);
1796 push @cmd, '--no-check' if $dsc_checked;
1797 if (madformat $dsc->{format}) {
1798 push @cmd, '--skip-patches';
1799 $treeimporthow = 'unpatched';
1801 push @cmd, qw(-x --), $dscfn;
1804 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1805 if (madformat $dsc->{format}) {
1806 check_for_vendor_patches();
1810 if (madformat $dsc->{format}) {
1811 my @pcmd = qw(dpkg-source --before-build .);
1812 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1814 runcmd @git, qw(add -Af);
1815 $dappliedtree = git_write_tree();
1818 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1819 debugcmd "|",@clogcmd;
1820 open CLOGS, "-|", @clogcmd or die $!;
1825 printdebug "import clog search...\n";
1828 my $stanzatext = do { local $/=""; <CLOGS>; };
1829 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1830 last if !defined $stanzatext;
1832 my $desc = "package changelog, entry no.$.";
1833 open my $stanzafh, "<", \$stanzatext or die;
1834 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1835 $clogp //= $thisstanza;
1837 printdebug "import clog $thisstanza->{version} $desc...\n";
1839 last if !$any_orig; # we don't need $r1clogp
1841 # We look for the first (most recent) changelog entry whose
1842 # version number is lower than the upstream version of this
1843 # package. Then the last (least recent) previous changelog
1844 # entry is treated as the one which introduced this upstream
1845 # version and used for the synthetic commits for the upstream
1848 # One might think that a more sophisticated algorithm would be
1849 # necessary. But: we do not want to scan the whole changelog
1850 # file. Stopping when we see an earlier version, which
1851 # necessarily then is an earlier upstream version, is the only
1852 # realistic way to do that. Then, either the earliest
1853 # changelog entry we have seen so far is indeed the earliest
1854 # upload of this upstream version; or there are only changelog
1855 # entries relating to later upstream versions (which is not
1856 # possible unless the changelog and .dsc disagree about the
1857 # version). Then it remains to choose between the physically
1858 # last entry in the file, and the one with the lowest version
1859 # number. If these are not the same, we guess that the
1860 # versions were created in a non-monotic order rather than
1861 # that the changelog entries have been misordered.
1863 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1865 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1866 $r1clogp = $thisstanza;
1868 printdebug "import clog $r1clogp->{version} becomes r1\n";
1870 die $! if CLOGS->error;
1871 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
1873 $clogp or fail "package changelog has no entries!";
1875 my $authline = clogp_authline $clogp;
1876 my $changes = getfield $clogp, 'Changes';
1877 my $cversion = getfield $clogp, 'Version';
1880 $r1clogp //= $clogp; # maybe there's only one entry;
1881 my $r1authline = clogp_authline $r1clogp;
1882 # Strictly, r1authline might now be wrong if it's going to be
1883 # unused because !$any_orig. Whatever.
1885 printdebug "import tartrees authline $authline\n";
1886 printdebug "import tartrees r1authline $r1authline\n";
1888 foreach my $tt (@tartrees) {
1889 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1891 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1894 committer $r1authline
1898 [dgit import orig $tt->{F}]
1906 [dgit import tarball $package $cversion $tt->{F}]
1911 printdebug "import main commit\n";
1913 open C, ">../commit.tmp" or die $!;
1914 print C <<END or die $!;
1917 print C <<END or die $! foreach @tartrees;
1920 print C <<END or die $!;
1926 [dgit import $treeimporthow $package $cversion]
1930 my $rawimport_hash = make_commit qw(../commit.tmp);
1932 if (madformat $dsc->{format}) {
1933 printdebug "import apply patches...\n";
1935 # regularise the state of the working tree so that
1936 # the checkout of $rawimport_hash works nicely.
1937 my $dappliedcommit = make_commit_text(<<END);
1944 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1946 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1948 # We need the answers to be reproducible
1949 my @authline = clogp_authline($clogp);
1950 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1951 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1952 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1953 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1954 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1955 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1957 my $path = $ENV{PATH} or die;
1959 foreach my $use_absurd (qw(0 1)) {
1960 local $ENV{PATH} = $path;
1963 progress "warning: $@";
1964 $path = "$absurdity:$path";
1965 progress "$us: trying slow absurd-git-apply...";
1966 rename "../../gbp-pq-output","../../gbp-pq-output.0"
1970 local $ENV{PATH} = $path if $use_absurd;
1972 my @showcmd = (gbp_pq, qw(import));
1973 my @realcmd = shell_cmd
1974 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
1975 debugcmd "+",@realcmd;
1976 if (system @realcmd) {
1977 die +(shellquote @showcmd).
1979 failedcmd_waitstatus()."\n";
1982 my $gapplied = git_rev_parse('HEAD');
1983 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1984 $gappliedtree eq $dappliedtree or
1986 gbp-pq import and dpkg-source disagree!
1987 gbp-pq import gave commit $gapplied
1988 gbp-pq import gave tree $gappliedtree
1989 dpkg-source --before-build gave tree $dappliedtree
1991 $rawimport_hash = $gapplied;
1996 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2001 progress "synthesised git commit from .dsc $cversion";
2003 my $rawimport_mergeinput = {
2004 Commit => $rawimport_hash,
2005 Info => "Import of source package",
2007 my @output = ($rawimport_mergeinput);
2009 if ($lastpush_mergeinput) {
2010 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2011 my $oversion = getfield $oldclogp, 'Version';
2013 version_compare($oversion, $cversion);
2015 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2016 { Message => <<END, ReverseParents => 1 });
2017 Record $package ($cversion) in archive suite $csuite
2019 } elsif ($vcmp > 0) {
2020 print STDERR <<END or die $!;
2022 Version actually in archive: $cversion (older)
2023 Last version pushed with dgit: $oversion (newer or same)
2026 @output = $lastpush_mergeinput;
2028 # Same version. Use what's in the server git branch,
2029 # discarding our own import. (This could happen if the
2030 # server automatically imports all packages into git.)
2031 @output = $lastpush_mergeinput;
2034 changedir '../../../..';
2039 sub complete_file_from_dsc ($$) {
2040 our ($dstdir, $fi) = @_;
2041 # Ensures that we have, in $dir, the file $fi, with the correct
2042 # contents. (Downloading it from alongside $dscurl if necessary.)
2044 my $f = $fi->{Filename};
2045 my $tf = "$dstdir/$f";
2048 if (stat_exists $tf) {
2049 progress "using existing $f";
2052 $furl =~ s{/[^/]+$}{};
2054 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2055 die "$f ?" if $f =~ m#/#;
2056 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2057 return 0 if !act_local();
2061 open F, "<", "$tf" or die "$tf: $!";
2062 $fi->{Digester}->reset();
2063 $fi->{Digester}->addfile(*F);
2064 F->error and die $!;
2065 my $got = $fi->{Digester}->hexdigest();
2066 $got eq $fi->{Hash} or
2067 fail "file $f has hash $got but .dsc".
2068 " demands hash $fi->{Hash} ".
2069 ($downloaded ? "(got wrong file from archive!)"
2070 : "(perhaps you should delete this file?)");
2075 sub ensure_we_have_orig () {
2076 my @dfi = dsc_files_info();
2077 foreach my $fi (@dfi) {
2078 my $f = $fi->{Filename};
2079 next unless is_orig_file_in_dsc($f, \@dfi);
2080 complete_file_from_dsc('..', $fi)
2085 sub git_fetch_us () {
2086 # Want to fetch only what we are going to use, unless
2087 # deliberately-not-ff, in which case we must fetch everything.
2089 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2091 (quiltmode_splitbrain
2092 ? (map { $_->('*',access_basedistro) }
2093 \&debiantag_new, \&debiantag_maintview)
2094 : debiantags('*',access_basedistro));
2095 push @specs, server_branch($csuite);
2096 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2098 # This is rather miserable:
2099 # When git fetch --prune is passed a fetchspec ending with a *,
2100 # it does a plausible thing. If there is no * then:
2101 # - it matches subpaths too, even if the supplied refspec
2102 # starts refs, and behaves completely madly if the source
2103 # has refs/refs/something. (See, for example, Debian #NNNN.)
2104 # - if there is no matching remote ref, it bombs out the whole
2106 # We want to fetch a fixed ref, and we don't know in advance
2107 # if it exists, so this is not suitable.
2109 # Our workaround is to use git ls-remote. git ls-remote has its
2110 # own qairks. Notably, it has the absurd multi-tail-matching
2111 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2112 # refs/refs/foo etc.
2114 # Also, we want an idempotent snapshot, but we have to make two
2115 # calls to the remote: one to git ls-remote and to git fetch. The
2116 # solution is use git ls-remote to obtain a target state, and
2117 # git fetch to try to generate it. If we don't manage to generate
2118 # the target state, we try again.
2120 my $specre = join '|', map {
2126 printdebug "git_fetch_us specre=$specre\n";
2127 my $wanted_rref = sub {
2129 return m/^(?:$specre)$/o;
2132 my $fetch_iteration = 0;
2135 if (++$fetch_iteration > 10) {
2136 fail "too many iterations trying to get sane fetch!";
2139 my @look = map { "refs/$_" } @specs;
2140 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2144 open GITLS, "-|", @lcmd or die $!;
2146 printdebug "=> ", $_;
2147 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2148 my ($objid,$rrefname) = ($1,$2);
2149 if (!$wanted_rref->($rrefname)) {
2151 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2155 $wantr{$rrefname} = $objid;
2158 close GITLS or failedcmd @lcmd;
2160 # OK, now %want is exactly what we want for refs in @specs
2162 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2163 "+refs/$_:".lrfetchrefs."/$_";
2166 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2167 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2170 %lrfetchrefs_f = ();
2173 git_for_each_ref(lrfetchrefs, sub {
2174 my ($objid,$objtype,$lrefname,$reftail) = @_;
2175 $lrfetchrefs_f{$lrefname} = $objid;
2176 $objgot{$objid} = 1;
2179 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2180 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2181 if (!exists $wantr{$rrefname}) {
2182 if ($wanted_rref->($rrefname)) {
2184 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2188 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2191 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2192 delete $lrfetchrefs_f{$lrefname};
2196 foreach my $rrefname (sort keys %wantr) {
2197 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2198 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2199 my $want = $wantr{$rrefname};
2200 next if $got eq $want;
2201 if (!defined $objgot{$want}) {
2203 warning: git ls-remote suggests we want $lrefname
2204 warning: and it should refer to $want
2205 warning: but git fetch didn't fetch that object to any relevant ref.
2206 warning: This may be due to a race with someone updating the server.
2207 warning: Will try again...
2209 next FETCH_ITERATION;
2212 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2214 runcmd_ordryrun_local @git, qw(update-ref -m),
2215 "dgit fetch git fetch fixup", $lrefname, $want;
2216 $lrfetchrefs_f{$lrefname} = $want;
2220 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2221 Dumper(\%lrfetchrefs_f);
2224 my @tagpats = debiantags('*',access_basedistro);
2226 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2227 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2228 printdebug "currently $fullrefname=$objid\n";
2229 $here{$fullrefname} = $objid;
2231 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2232 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2233 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2234 printdebug "offered $lref=$objid\n";
2235 if (!defined $here{$lref}) {
2236 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2237 runcmd_ordryrun_local @upd;
2238 lrfetchref_used $fullrefname;
2239 } elsif ($here{$lref} eq $objid) {
2240 lrfetchref_used $fullrefname;
2243 "Not updateting $lref from $here{$lref} to $objid.\n";
2248 sub mergeinfo_getclogp ($) {
2249 # Ensures thit $mi->{Clogp} exists and returns it
2251 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2254 sub mergeinfo_version ($) {
2255 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2258 sub fetch_from_archive () {
2259 ensure_setup_existing_tree();
2261 # Ensures that lrref() is what is actually in the archive, one way
2262 # or another, according to us - ie this client's
2263 # appropritaely-updated archive view. Also returns the commit id.
2264 # If there is nothing in the archive, leaves lrref alone and
2265 # returns undef. git_fetch_us must have already been called.
2269 foreach my $field (@ourdscfield) {
2270 $dsc_hash = $dsc->{$field};
2271 last if defined $dsc_hash;
2273 if (defined $dsc_hash) {
2274 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2276 progress "last upload to archive specified git hash";
2278 progress "last upload to archive has NO git hash";
2281 progress "no version available from the archive";
2284 # If the archive's .dsc has a Dgit field, there are three
2285 # relevant git commitids we need to choose between and/or merge
2287 # 1. $dsc_hash: the Dgit field from the archive
2288 # 2. $lastpush_hash: the suite branch on the dgit git server
2289 # 3. $lastfetch_hash: our local tracking brach for the suite
2291 # These may all be distinct and need not be in any fast forward
2294 # If the dsc was pushed to this suite, then the server suite
2295 # branch will have been updated; but it might have been pushed to
2296 # a different suite and copied by the archive. Conversely a more
2297 # recent version may have been pushed with dgit but not appeared
2298 # in the archive (yet).
2300 # $lastfetch_hash may be awkward because archive imports
2301 # (particularly, imports of Dgit-less .dscs) are performed only as
2302 # needed on individual clients, so different clients may perform a
2303 # different subset of them - and these imports are only made
2304 # public during push. So $lastfetch_hash may represent a set of
2305 # imports different to a subsequent upload by a different dgit
2308 # Our approach is as follows:
2310 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2311 # descendant of $dsc_hash, then it was pushed by a dgit user who
2312 # had based their work on $dsc_hash, so we should prefer it.
2313 # Otherwise, $dsc_hash was installed into this suite in the
2314 # archive other than by a dgit push, and (necessarily) after the
2315 # last dgit push into that suite (since a dgit push would have
2316 # been descended from the dgit server git branch); thus, in that
2317 # case, we prefer the archive's version (and produce a
2318 # pseudo-merge to overwrite the dgit server git branch).
2320 # (If there is no Dgit field in the archive's .dsc then
2321 # generate_commit_from_dsc uses the version numbers to decide
2322 # whether the suite branch or the archive is newer. If the suite
2323 # branch is newer it ignores the archive's .dsc; otherwise it
2324 # generates an import of the .dsc, and produces a pseudo-merge to
2325 # overwrite the suite branch with the archive contents.)
2327 # The outcome of that part of the algorithm is the `public view',
2328 # and is same for all dgit clients: it does not depend on any
2329 # unpublished history in the local tracking branch.
2331 # As between the public view and the local tracking branch: The
2332 # local tracking branch is only updated by dgit fetch, and
2333 # whenever dgit fetch runs it includes the public view in the
2334 # local tracking branch. Therefore if the public view is not
2335 # descended from the local tracking branch, the local tracking
2336 # branch must contain history which was imported from the archive
2337 # but never pushed; and, its tip is now out of date. So, we make
2338 # a pseudo-merge to overwrite the old imports and stitch the old
2341 # Finally: we do not necessarily reify the public view (as
2342 # described above). This is so that we do not end up stacking two
2343 # pseudo-merges. So what we actually do is figure out the inputs
2344 # to any public view pseudo-merge and put them in @mergeinputs.
2347 # $mergeinputs[]{Commit}
2348 # $mergeinputs[]{Info}
2349 # $mergeinputs[0] is the one whose tree we use
2350 # @mergeinputs is in the order we use in the actual commit)
2353 # $mergeinputs[]{Message} is a commit message to use
2354 # $mergeinputs[]{ReverseParents} if def specifies that parent
2355 # list should be in opposite order
2356 # Such an entry has no Commit or Info. It applies only when found
2357 # in the last entry. (This ugliness is to support making
2358 # identical imports to previous dgit versions.)
2360 my $lastpush_hash = git_get_ref(lrfetchref());
2361 printdebug "previous reference hash=$lastpush_hash\n";
2362 $lastpush_mergeinput = $lastpush_hash && {
2363 Commit => $lastpush_hash,
2364 Info => "dgit suite branch on dgit git server",
2367 my $lastfetch_hash = git_get_ref(lrref());
2368 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2369 my $lastfetch_mergeinput = $lastfetch_hash && {
2370 Commit => $lastfetch_hash,
2371 Info => "dgit client's archive history view",
2374 my $dsc_mergeinput = $dsc_hash && {
2375 Commit => $dsc_hash,
2376 Info => "Dgit field in .dsc from archive",
2380 my $del_lrfetchrefs = sub {
2383 printdebug "del_lrfetchrefs...\n";
2384 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2385 my $objid = $lrfetchrefs_d{$fullrefname};
2386 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2388 $gur ||= new IO::Handle;
2389 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2391 printf $gur "delete %s %s\n", $fullrefname, $objid;
2394 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2398 if (defined $dsc_hash) {
2399 fail "missing remote git history even though dsc has hash -".
2400 " could not find ref ".rref()." at ".access_giturl()
2401 unless $lastpush_hash;
2402 ensure_we_have_orig();
2403 if ($dsc_hash eq $lastpush_hash) {
2404 @mergeinputs = $dsc_mergeinput
2405 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2406 print STDERR <<END or die $!;
2408 Git commit in archive is behind the last version allegedly pushed/uploaded.
2409 Commit referred to by archive: $dsc_hash
2410 Last version pushed with dgit: $lastpush_hash
2413 @mergeinputs = ($lastpush_mergeinput);
2415 # Archive has .dsc which is not a descendant of the last dgit
2416 # push. This can happen if the archive moves .dscs about.
2417 # Just follow its lead.
2418 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2419 progress "archive .dsc names newer git commit";
2420 @mergeinputs = ($dsc_mergeinput);
2422 progress "archive .dsc names other git commit, fixing up";
2423 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2427 @mergeinputs = generate_commits_from_dsc();
2428 # We have just done an import. Now, our import algorithm might
2429 # have been improved. But even so we do not want to generate
2430 # a new different import of the same package. So if the
2431 # version numbers are the same, just use our existing version.
2432 # If the version numbers are different, the archive has changed
2433 # (perhaps, rewound).
2434 if ($lastfetch_mergeinput &&
2435 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2436 (mergeinfo_version $mergeinputs[0]) )) {
2437 @mergeinputs = ($lastfetch_mergeinput);
2439 } elsif ($lastpush_hash) {
2440 # only in git, not in the archive yet
2441 @mergeinputs = ($lastpush_mergeinput);
2442 print STDERR <<END or die $!;
2444 Package not found in the archive, but has allegedly been pushed using dgit.
2448 printdebug "nothing found!\n";
2449 if (defined $skew_warning_vsn) {
2450 print STDERR <<END or die $!;
2452 Warning: relevant archive skew detected.
2453 Archive allegedly contains $skew_warning_vsn
2454 But we were not able to obtain any version from the archive or git.
2458 unshift @end, $del_lrfetchrefs;
2462 if ($lastfetch_hash &&
2464 my $h = $_->{Commit};
2465 $h and is_fast_fwd($lastfetch_hash, $h);
2466 # If true, one of the existing parents of this commit
2467 # is a descendant of the $lastfetch_hash, so we'll
2468 # be ff from that automatically.
2472 push @mergeinputs, $lastfetch_mergeinput;
2475 printdebug "fetch mergeinfos:\n";
2476 foreach my $mi (@mergeinputs) {
2478 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2480 printdebug sprintf " ReverseParents=%d Message=%s",
2481 $mi->{ReverseParents}, $mi->{Message};
2485 my $compat_info= pop @mergeinputs
2486 if $mergeinputs[$#mergeinputs]{Message};
2488 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2491 if (@mergeinputs > 1) {
2493 my $tree_commit = $mergeinputs[0]{Commit};
2495 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2496 $tree =~ m/\n\n/; $tree = $`;
2497 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2500 # We use the changelog author of the package in question the
2501 # author of this pseudo-merge. This is (roughly) correct if
2502 # this commit is simply representing aa non-dgit upload.
2503 # (Roughly because it does not record sponsorship - but we
2504 # don't have sponsorship info because that's in the .changes,
2505 # which isn't in the archivw.)
2507 # But, it might be that we are representing archive history
2508 # updates (including in-archive copies). These are not really
2509 # the responsibility of the person who created the .dsc, but
2510 # there is no-one whose name we should better use. (The
2511 # author of the .dsc-named commit is clearly worse.)
2513 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2514 my $author = clogp_authline $useclogp;
2515 my $cversion = getfield $useclogp, 'Version';
2517 my $mcf = ".git/dgit/mergecommit";
2518 open MC, ">", $mcf or die "$mcf $!";
2519 print MC <<END or die $!;
2523 my @parents = grep { $_->{Commit} } @mergeinputs;
2524 @parents = reverse @parents if $compat_info->{ReverseParents};
2525 print MC <<END or die $! foreach @parents;
2529 print MC <<END or die $!;
2535 if (defined $compat_info->{Message}) {
2536 print MC $compat_info->{Message} or die $!;
2538 print MC <<END or die $!;
2539 Record $package ($cversion) in archive suite $csuite
2543 my $message_add_info = sub {
2545 my $mversion = mergeinfo_version $mi;
2546 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2550 $message_add_info->($mergeinputs[0]);
2551 print MC <<END or die $!;
2552 should be treated as descended from
2554 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2558 $hash = make_commit $mcf;
2560 $hash = $mergeinputs[0]{Commit};
2562 printdebug "fetch hash=$hash\n";
2565 my ($lasth, $what) = @_;
2566 return unless $lasth;
2567 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2570 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2571 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2573 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2574 'DGIT_ARCHIVE', $hash;
2575 cmdoutput @git, qw(log -n2), $hash;
2576 # ... gives git a chance to complain if our commit is malformed
2578 if (defined $skew_warning_vsn) {
2580 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2581 my $gotclogp = commit_getclogp($hash);
2582 my $got_vsn = getfield $gotclogp, 'Version';
2583 printdebug "SKEW CHECK GOT $got_vsn\n";
2584 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2585 print STDERR <<END or die $!;
2587 Warning: archive skew detected. Using the available version:
2588 Archive allegedly contains $skew_warning_vsn
2589 We were able to obtain only $got_vsn
2595 if ($lastfetch_hash ne $hash) {
2596 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2600 dryrun_report @upd_cmd;
2604 lrfetchref_used lrfetchref();
2606 unshift @end, $del_lrfetchrefs;
2610 sub set_local_git_config ($$) {
2612 runcmd @git, qw(config), $k, $v;
2615 sub setup_mergechangelogs (;$) {
2617 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2619 my $driver = 'dpkg-mergechangelogs';
2620 my $cb = "merge.$driver";
2621 my $attrs = '.git/info/attributes';
2622 ensuredir '.git/info';
2624 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2625 if (!open ATTRS, "<", $attrs) {
2626 $!==ENOENT or die "$attrs: $!";
2630 next if m{^debian/changelog\s};
2631 print NATTRS $_, "\n" or die $!;
2633 ATTRS->error and die $!;
2636 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2639 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2640 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2642 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2645 sub setup_useremail (;$) {
2647 return unless $always || access_cfg_bool(1, 'setup-useremail');
2650 my ($k, $envvar) = @_;
2651 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2652 return unless defined $v;
2653 set_local_git_config "user.$k", $v;
2656 $setup->('email', 'DEBEMAIL');
2657 $setup->('name', 'DEBFULLNAME');
2660 sub ensure_setup_existing_tree () {
2661 my $k = "remote.$remotename.skipdefaultupdate";
2662 my $c = git_get_config $k;
2663 return if defined $c;
2664 set_local_git_config $k, 'true';
2667 sub setup_new_tree () {
2668 setup_mergechangelogs();
2674 canonicalise_suite();
2675 badusage "dry run makes no sense with clone" unless act_local();
2676 my $hasgit = check_for_git();
2677 mkdir $dstdir or fail "create \`$dstdir': $!";
2679 runcmd @git, qw(init -q);
2680 my $giturl = access_giturl(1);
2681 if (defined $giturl) {
2682 open H, "> .git/HEAD" or die $!;
2683 print H "ref: ".lref()."\n" or die $!;
2685 runcmd @git, qw(remote add), 'origin', $giturl;
2688 progress "fetching existing git history";
2690 runcmd_ordryrun_local @git, qw(fetch origin);
2692 progress "starting new git history";
2694 fetch_from_archive() or no_such_package;
2695 my $vcsgiturl = $dsc->{'Vcs-Git'};
2696 if (length $vcsgiturl) {
2697 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2698 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2701 runcmd @git, qw(reset --hard), lrref();
2702 printdone "ready for work in $dstdir";
2706 if (check_for_git()) {
2709 fetch_from_archive() or no_such_package();
2710 printdone "fetched into ".lrref();
2715 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2717 printdone "fetched to ".lrref()." and merged into HEAD";
2720 sub check_not_dirty () {
2721 foreach my $f (qw(local-options local-patch-header)) {
2722 if (stat_exists "debian/source/$f") {
2723 fail "git tree contains debian/source/$f";
2727 return if $ignoredirty;
2729 my @cmd = (@git, qw(diff --quiet HEAD));
2731 $!=0; $?=-1; system @cmd;
2734 fail "working tree is dirty (does not match HEAD)";
2740 sub commit_admin ($) {
2743 runcmd_ordryrun_local @git, qw(commit -m), $m;
2746 sub commit_quilty_patch () {
2747 my $output = cmdoutput @git, qw(status --porcelain);
2749 foreach my $l (split /\n/, $output) {
2750 next unless $l =~ m/\S/;
2751 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2755 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2757 progress "nothing quilty to commit, ok.";
2760 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2761 runcmd_ordryrun_local @git, qw(add -f), @adds;
2763 Commit Debian 3.0 (quilt) metadata
2765 [dgit ($our_version) quilt-fixup]
2769 sub get_source_format () {
2771 if (open F, "debian/source/options") {
2775 s/\s+$//; # ignore missing final newline
2777 my ($k, $v) = ($`, $'); #');
2778 $v =~ s/^"(.*)"$/$1/;
2784 F->error and die $!;
2787 die $! unless $!==&ENOENT;
2790 if (!open F, "debian/source/format") {
2791 die $! unless $!==&ENOENT;
2795 F->error and die $!;
2797 return ($_, \%options);
2800 sub madformat_wantfixup ($) {
2802 return 0 unless $format eq '3.0 (quilt)';
2803 our $quilt_mode_warned;
2804 if ($quilt_mode eq 'nocheck') {
2805 progress "Not doing any fixup of \`$format' due to".
2806 " ----no-quilt-fixup or --quilt=nocheck"
2807 unless $quilt_mode_warned++;
2810 progress "Format \`$format', need to check/update patch stack"
2811 unless $quilt_mode_warned++;
2815 # An "infopair" is a tuple [ $thing, $what ]
2816 # (often $thing is a commit hash; $what is a description)
2818 sub infopair_cond_equal ($$) {
2820 $x->[0] eq $y->[0] or fail <<END;
2821 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2825 sub infopair_lrf_tag_lookup ($$) {
2826 my ($tagnames, $what) = @_;
2827 # $tagname may be an array ref
2828 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2829 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2830 foreach my $tagname (@tagnames) {
2831 my $lrefname = lrfetchrefs."/tags/$tagname";
2832 my $tagobj = $lrfetchrefs_f{$lrefname};
2833 next unless defined $tagobj;
2834 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2835 return [ git_rev_parse($tagobj), $what ];
2837 fail @tagnames==1 ? <<END : <<END;
2838 Wanted tag $what (@tagnames) on dgit server, but not found
2840 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2844 sub infopair_cond_ff ($$) {
2845 my ($anc,$desc) = @_;
2846 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2847 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2851 sub pseudomerge_version_check ($$) {
2852 my ($clogp, $archive_hash) = @_;
2854 my $arch_clogp = commit_getclogp $archive_hash;
2855 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2856 'version currently in archive' ];
2857 if (defined $overwrite_version) {
2858 if (length $overwrite_version) {
2859 infopair_cond_equal([ $overwrite_version,
2860 '--overwrite= version' ],
2863 my $v = $i_arch_v->[0];
2864 progress "Checking package changelog for archive version $v ...";
2866 my @xa = ("-f$v", "-t$v");
2867 my $vclogp = parsechangelog @xa;
2868 my $cv = [ (getfield $vclogp, 'Version'),
2869 "Version field from dpkg-parsechangelog @xa" ];
2870 infopair_cond_equal($i_arch_v, $cv);
2873 $@ =~ s/^dgit: //gm;
2875 "Perhaps debian/changelog does not mention $v ?";
2880 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2884 sub pseudomerge_make_commit ($$$$ $$) {
2885 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2886 $msg_cmd, $msg_msg) = @_;
2887 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2889 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2890 my $authline = clogp_authline $clogp;
2894 !defined $overwrite_version ? ""
2895 : !length $overwrite_version ? " --overwrite"
2896 : " --overwrite=".$overwrite_version;
2899 my $pmf = ".git/dgit/pseudomerge";
2900 open MC, ">", $pmf or die "$pmf $!";
2901 print MC <<END or die $!;
2904 parent $archive_hash
2914 return make_commit($pmf);
2917 sub splitbrain_pseudomerge ($$$$) {
2918 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2919 # => $merged_dgitview
2920 printdebug "splitbrain_pseudomerge...\n";
2922 # We: debian/PREVIOUS HEAD($maintview)
2923 # expect: o ----------------- o
2926 # a/d/PREVIOUS $dgitview
2929 # we do: `------------------ o
2933 printdebug "splitbrain_pseudomerge...\n";
2935 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2937 return $dgitview unless defined $archive_hash;
2939 if (!defined $overwrite_version) {
2940 progress "Checking that HEAD inciudes all changes in archive...";
2943 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2945 if (defined $overwrite_version) {
2947 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2948 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2949 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2950 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2951 my $i_archive = [ $archive_hash, "current archive contents" ];
2953 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2955 infopair_cond_equal($i_dgit, $i_archive);
2956 infopair_cond_ff($i_dep14, $i_dgit);
2957 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2961 $us: check failed (maybe --overwrite is needed, consult documentation)
2966 my $r = pseudomerge_make_commit
2967 $clogp, $dgitview, $archive_hash, $i_arch_v,
2968 "dgit --quilt=$quilt_mode",
2969 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2970 Declare fast forward from $i_arch_v->[0]
2972 Make fast forward from $i_arch_v->[0]
2975 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2979 sub plain_overwrite_pseudomerge ($$$) {
2980 my ($clogp, $head, $archive_hash) = @_;
2982 printdebug "plain_overwrite_pseudomerge...";
2984 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2986 return $head if is_fast_fwd $archive_hash, $head;
2988 my $m = "Declare fast forward from $i_arch_v->[0]";
2990 my $r = pseudomerge_make_commit
2991 $clogp, $head, $archive_hash, $i_arch_v,
2994 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2996 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3000 sub push_parse_changelog ($) {
3003 my $clogp = Dpkg::Control::Hash->new();
3004 $clogp->load($clogpfn) or die;
3006 $package = getfield $clogp, 'Source';
3007 my $cversion = getfield $clogp, 'Version';
3008 my $tag = debiantag($cversion, access_basedistro);
3009 runcmd @git, qw(check-ref-format), $tag;
3011 my $dscfn = dscfn($cversion);
3013 return ($clogp, $cversion, $dscfn);
3016 sub push_parse_dsc ($$$) {
3017 my ($dscfn,$dscfnwhat, $cversion) = @_;
3018 $dsc = parsecontrol($dscfn,$dscfnwhat);
3019 my $dversion = getfield $dsc, 'Version';
3020 my $dscpackage = getfield $dsc, 'Source';
3021 ($dscpackage eq $package && $dversion eq $cversion) or
3022 fail "$dscfn is for $dscpackage $dversion".
3023 " but debian/changelog is for $package $cversion";
3026 sub push_tagwants ($$$$) {
3027 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3030 TagFn => \&debiantag,
3035 if (defined $maintviewhead) {
3037 TagFn => \&debiantag_maintview,
3038 Objid => $maintviewhead,
3039 TfSuffix => '-maintview',
3043 foreach my $tw (@tagwants) {
3044 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3045 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3047 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3051 sub push_mktags ($$ $$ $) {
3053 $changesfile,$changesfilewhat,
3056 die unless $tagwants->[0]{View} eq 'dgit';
3058 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3059 $dsc->save("$dscfn.tmp") or die $!;
3061 my $changes = parsecontrol($changesfile,$changesfilewhat);
3062 foreach my $field (qw(Source Distribution Version)) {
3063 $changes->{$field} eq $clogp->{$field} or
3064 fail "changes field $field \`$changes->{$field}'".
3065 " does not match changelog \`$clogp->{$field}'";
3068 my $cversion = getfield $clogp, 'Version';
3069 my $clogsuite = getfield $clogp, 'Distribution';
3071 # We make the git tag by hand because (a) that makes it easier
3072 # to control the "tagger" (b) we can do remote signing
3073 my $authline = clogp_authline $clogp;
3074 my $delibs = join(" ", "",@deliberatelies);
3075 my $declaredistro = access_basedistro();
3079 my $tfn = $tw->{Tfn};
3080 my $head = $tw->{Objid};
3081 my $tag = $tw->{Tag};
3083 open TO, '>', $tfn->('.tmp') or die $!;
3084 print TO <<END or die $!;
3091 if ($tw->{View} eq 'dgit') {
3092 print TO <<END or die $!;
3093 $package release $cversion for $clogsuite ($csuite) [dgit]
3094 [dgit distro=$declaredistro$delibs]
3096 foreach my $ref (sort keys %previously) {
3097 print TO <<END or die $!;
3098 [dgit previously:$ref=$previously{$ref}]
3101 } elsif ($tw->{View} eq 'maint') {
3102 print TO <<END or die $!;
3103 $package release $cversion for $clogsuite ($csuite)
3104 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3107 die Dumper($tw)."?";
3112 my $tagobjfn = $tfn->('.tmp');
3114 if (!defined $keyid) {
3115 $keyid = access_cfg('keyid','RETURN-UNDEF');
3117 if (!defined $keyid) {
3118 $keyid = getfield $clogp, 'Maintainer';
3120 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3121 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3122 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3123 push @sign_cmd, $tfn->('.tmp');
3124 runcmd_ordryrun @sign_cmd;
3126 $tagobjfn = $tfn->('.signed.tmp');
3127 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3128 $tfn->('.tmp'), $tfn->('.tmp.asc');
3134 my @r = map { $mktag->($_); } @$tagwants;
3138 sub sign_changes ($) {
3139 my ($changesfile) = @_;
3141 my @debsign_cmd = @debsign;
3142 push @debsign_cmd, "-k$keyid" if defined $keyid;
3143 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3144 push @debsign_cmd, $changesfile;
3145 runcmd_ordryrun @debsign_cmd;
3150 printdebug "actually entering push\n";
3152 supplementary_message(<<'END');
3153 Push failed, while checking state of the archive.
3154 You can retry the push, after fixing the problem, if you like.
3156 if (check_for_git()) {
3159 my $archive_hash = fetch_from_archive();
3160 if (!$archive_hash) {
3162 fail "package appears to be new in this suite;".
3163 " if this is intentional, use --new";
3166 supplementary_message(<<'END');
3167 Push failed, while preparing your push.
3168 You can retry the push, after fixing the problem, if you like.
3171 need_tagformat 'new', "quilt mode $quilt_mode"
3172 if quiltmode_splitbrain;
3176 access_giturl(); # check that success is vaguely likely
3179 my $clogpfn = ".git/dgit/changelog.822.tmp";
3180 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3182 responder_send_file('parsed-changelog', $clogpfn);
3184 my ($clogp, $cversion, $dscfn) =
3185 push_parse_changelog("$clogpfn");
3187 my $dscpath = "$buildproductsdir/$dscfn";
3188 stat_exists $dscpath or
3189 fail "looked for .dsc $dscfn, but $!;".
3190 " maybe you forgot to build";
3192 responder_send_file('dsc', $dscpath);
3194 push_parse_dsc($dscpath, $dscfn, $cversion);
3196 my $format = getfield $dsc, 'Format';
3197 printdebug "format $format\n";
3199 my $actualhead = git_rev_parse('HEAD');
3200 my $dgithead = $actualhead;
3201 my $maintviewhead = undef;
3203 if (madformat_wantfixup($format)) {
3204 # user might have not used dgit build, so maybe do this now:
3205 if (quiltmode_splitbrain()) {
3206 my $upstreamversion = $clogp->{Version};
3207 $upstreamversion =~ s/-[^-]*$//;
3209 quilt_make_fake_dsc($upstreamversion);
3211 ($dgithead, $cachekey) =
3212 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3214 "--quilt=$quilt_mode but no cached dgit view:
3215 perhaps tree changed since dgit build[-source] ?";
3217 $dgithead = splitbrain_pseudomerge($clogp,
3218 $actualhead, $dgithead,
3220 $maintviewhead = $actualhead;
3221 changedir '../../../..';
3222 prep_ud(); # so _only_subdir() works, below
3224 commit_quilty_patch();
3228 if (defined $overwrite_version && !defined $maintviewhead) {
3229 $dgithead = plain_overwrite_pseudomerge($clogp,
3237 if ($archive_hash) {
3238 if (is_fast_fwd($archive_hash, $dgithead)) {
3240 } elsif (deliberately_not_fast_forward) {
3243 fail "dgit push: HEAD is not a descendant".
3244 " of the archive's version.\n".
3245 "To overwrite the archive's contents,".
3246 " pass --overwrite[=VERSION].\n".
3247 "To rewind history, if permitted by the archive,".
3248 " use --deliberately-not-fast-forward.";
3253 progress "checking that $dscfn corresponds to HEAD";
3254 runcmd qw(dpkg-source -x --),
3255 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3256 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3257 check_for_vendor_patches() if madformat($dsc->{format});
3258 changedir '../../../..';
3259 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3260 debugcmd "+",@diffcmd;
3262 my $r = system @diffcmd;
3265 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3267 HEAD specifies a different tree to $dscfn:
3269 Perhaps you forgot to build. Or perhaps there is a problem with your
3270 source tree (see dgit(7) for some hints). To see a full diff, run
3277 if (!$changesfile) {
3278 my $pat = changespat $cversion;
3279 my @cs = glob "$buildproductsdir/$pat";
3280 fail "failed to find unique changes file".
3281 " (looked for $pat in $buildproductsdir);".
3282 " perhaps you need to use dgit -C"
3284 ($changesfile) = @cs;
3286 $changesfile = "$buildproductsdir/$changesfile";
3289 # Check that changes and .dsc agree enough
3290 $changesfile =~ m{[^/]*$};
3291 files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3293 # Checks complete, we're going to try and go ahead:
3295 responder_send_file('changes',$changesfile);
3296 responder_send_command("param head $dgithead");
3297 responder_send_command("param csuite $csuite");
3298 responder_send_command("param tagformat $tagformat");
3299 if (defined $maintviewhead) {
3300 die unless ($protovsn//4) >= 4;
3301 responder_send_command("param maint-view $maintviewhead");
3304 if (deliberately_not_fast_forward) {
3305 git_for_each_ref(lrfetchrefs, sub {
3306 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3307 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3308 responder_send_command("previously $rrefname=$objid");
3309 $previously{$rrefname} = $objid;
3313 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3317 supplementary_message(<<'END');
3318 Push failed, while signing the tag.
3319 You can retry the push, after fixing the problem, if you like.
3321 # If we manage to sign but fail to record it anywhere, it's fine.
3322 if ($we_are_responder) {
3323 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3324 responder_receive_files('signed-tag', @tagobjfns);
3326 @tagobjfns = push_mktags($clogp,$dscpath,
3327 $changesfile,$changesfile,
3330 supplementary_message(<<'END');
3331 Push failed, *after* signing the tag.
3332 If you want to try again, you should use a new version number.
3335 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3337 foreach my $tw (@tagwants) {
3338 my $tag = $tw->{Tag};
3339 my $tagobjfn = $tw->{TagObjFn};
3341 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3342 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3343 runcmd_ordryrun_local
3344 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3347 supplementary_message(<<'END');
3348 Push failed, while updating the remote git repository - see messages above.
3349 If you want to try again, you should use a new version number.
3351 if (!check_for_git()) {
3352 create_remote_git_repo();
3355 my @pushrefs = $forceflag.$dgithead.":".rrref();
3356 foreach my $tw (@tagwants) {
3357 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3360 runcmd_ordryrun @git,
3361 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3362 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3364 supplementary_message(<<'END');
3365 Push failed, after updating the remote git repository.
3366 If you want to try again, you must use a new version number.
3368 if ($we_are_responder) {
3369 my $dryrunsuffix = act_local() ? "" : ".tmp";
3370 responder_receive_files('signed-dsc-changes',
3371 "$dscpath$dryrunsuffix",
3372 "$changesfile$dryrunsuffix");
3375 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3377 progress "[new .dsc left in $dscpath.tmp]";
3379 sign_changes $changesfile;
3382 supplementary_message(<<END);
3383 Push failed, while uploading package(s) to the archive server.
3384 You can retry the upload of exactly these same files with dput of:
3386 If that .changes file is broken, you will need to use a new version
3387 number for your next attempt at the upload.
3389 my $host = access_cfg('upload-host','RETURN-UNDEF');
3390 my @hostarg = defined($host) ? ($host,) : ();
3391 runcmd_ordryrun @dput, @hostarg, $changesfile;
3392 printdone "pushed and uploaded $cversion";
3394 supplementary_message('');
3395 responder_send_command("complete");
3402 badusage "-p is not allowed with clone; specify as argument instead"
3403 if defined $package;
3406 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3407 ($package,$isuite) = @ARGV;
3408 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3409 ($package,$dstdir) = @ARGV;
3410 } elsif (@ARGV==3) {
3411 ($package,$isuite,$dstdir) = @ARGV;
3413 badusage "incorrect arguments to dgit clone";
3415 $dstdir ||= "$package";
3417 if (stat_exists $dstdir) {
3418 fail "$dstdir already exists";
3422 if ($rmonerror && !$dryrun_level) {
3423 $cwd_remove= getcwd();
3425 return unless defined $cwd_remove;
3426 if (!chdir "$cwd_remove") {
3427 return if $!==&ENOENT;
3428 die "chdir $cwd_remove: $!";
3431 rmtree($dstdir) or die "remove $dstdir: $!\n";
3432 } elsif (grep { $! == $_ }
3433 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3435 print STDERR "check whether to remove $dstdir: $!\n";
3441 $cwd_remove = undef;
3444 sub branchsuite () {
3445 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3446 if ($branch =~ m#$lbranch_re#o) {
3453 sub fetchpullargs () {
3455 if (!defined $package) {
3456 my $sourcep = parsecontrol('debian/control','debian/control');
3457 $package = getfield $sourcep, 'Source';
3460 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3462 my $clogp = parsechangelog();
3463 $isuite = getfield $clogp, 'Distribution';
3465 canonicalise_suite();
3466 progress "fetching from suite $csuite";
3467 } elsif (@ARGV==1) {
3469 canonicalise_suite();
3471 badusage "incorrect arguments to dgit fetch or dgit pull";
3490 badusage "-p is not allowed with dgit push" if defined $package;
3492 my $clogp = parsechangelog();
3493 $package = getfield $clogp, 'Source';
3496 } elsif (@ARGV==1) {
3497 ($specsuite) = (@ARGV);
3499 badusage "incorrect arguments to dgit push";
3501 $isuite = getfield $clogp, 'Distribution';
3503 local ($package) = $existing_package; # this is a hack
3504 canonicalise_suite();
3506 canonicalise_suite();
3508 if (defined $specsuite &&
3509 $specsuite ne $isuite &&
3510 $specsuite ne $csuite) {
3511 fail "dgit push: changelog specifies $isuite ($csuite)".
3512 " but command line specifies $specsuite";
3517 #---------- remote commands' implementation ----------
3519 sub cmd_remote_push_build_host {
3520 my ($nrargs) = shift @ARGV;
3521 my (@rargs) = @ARGV[0..$nrargs-1];
3522 @ARGV = @ARGV[$nrargs..$#ARGV];
3524 my ($dir,$vsnwant) = @rargs;
3525 # vsnwant is a comma-separated list; we report which we have
3526 # chosen in our ready response (so other end can tell if they
3529 $we_are_responder = 1;
3530 $us .= " (build host)";
3534 open PI, "<&STDIN" or die $!;
3535 open STDIN, "/dev/null" or die $!;
3536 open PO, ">&STDOUT" or die $!;
3538 open STDOUT, ">&STDERR" or die $!;
3542 ($protovsn) = grep {
3543 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3544 } @rpushprotovsn_support;
3546 fail "build host has dgit rpush protocol versions ".
3547 (join ",", @rpushprotovsn_support).
3548 " but invocation host has $vsnwant"
3549 unless defined $protovsn;
3551 responder_send_command("dgit-remote-push-ready $protovsn");
3552 rpush_handle_protovsn_bothends();
3557 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3558 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3559 # a good error message)
3561 sub rpush_handle_protovsn_bothends () {
3562 if ($protovsn < 4) {
3563 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3572 my $report = i_child_report();
3573 if (defined $report) {
3574 printdebug "($report)\n";
3575 } elsif ($i_child_pid) {
3576 printdebug "(killing build host child $i_child_pid)\n";
3577 kill 15, $i_child_pid;
3579 if (defined $i_tmp && !defined $initiator_tempdir) {
3581 eval { rmtree $i_tmp; };
3585 END { i_cleanup(); }
3588 my ($base,$selector,@args) = @_;
3589 $selector =~ s/\-/_/g;
3590 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3597 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3605 push @rargs, join ",", @rpushprotovsn_support;
3608 push @rdgit, @ropts;
3609 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3611 my @cmd = (@ssh, $host, shellquote @rdgit);
3614 if (defined $initiator_tempdir) {
3615 rmtree $initiator_tempdir;
3616 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3617 $i_tmp = $initiator_tempdir;
3621 $i_child_pid = open2(\*RO, \*RI, @cmd);
3623 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3624 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3625 $supplementary_message = '' unless $protovsn >= 3;
3627 fail "rpush negotiated protocol version $protovsn".
3628 " which does not support quilt mode $quilt_mode"
3629 if quiltmode_splitbrain;
3631 rpush_handle_protovsn_bothends();
3633 my ($icmd,$iargs) = initiator_expect {
3634 m/^(\S+)(?: (.*))?$/;
3637 i_method "i_resp", $icmd, $iargs;
3641 sub i_resp_progress ($) {
3643 my $msg = protocol_read_bytes \*RO, $rhs;
3647 sub i_resp_supplementary_message ($) {
3649 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3652 sub i_resp_complete {
3653 my $pid = $i_child_pid;
3654 $i_child_pid = undef; # prevents killing some other process with same pid
3655 printdebug "waiting for build host child $pid...\n";
3656 my $got = waitpid $pid, 0;
3657 die $! unless $got == $pid;
3658 die "build host child failed $?" if $?;
3661 printdebug "all done\n";
3665 sub i_resp_file ($) {
3667 my $localname = i_method "i_localname", $keyword;
3668 my $localpath = "$i_tmp/$localname";
3669 stat_exists $localpath and
3670 badproto \*RO, "file $keyword ($localpath) twice";
3671 protocol_receive_file \*RO, $localpath;
3672 i_method "i_file", $keyword;
3677 sub i_resp_param ($) {
3678 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3682 sub i_resp_previously ($) {
3683 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3684 or badproto \*RO, "bad previously spec";
3685 my $r = system qw(git check-ref-format), $1;
3686 die "bad previously ref spec ($r)" if $r;
3687 $previously{$1} = $2;
3692 sub i_resp_want ($) {
3694 die "$keyword ?" if $i_wanted{$keyword}++;
3695 my @localpaths = i_method "i_want", $keyword;
3696 printdebug "[[ $keyword @localpaths\n";
3697 foreach my $localpath (@localpaths) {
3698 protocol_send_file \*RI, $localpath;
3700 print RI "files-end\n" or die $!;
3703 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3705 sub i_localname_parsed_changelog {
3706 return "remote-changelog.822";
3708 sub i_file_parsed_changelog {
3709 ($i_clogp, $i_version, $i_dscfn) =
3710 push_parse_changelog "$i_tmp/remote-changelog.822";
3711 die if $i_dscfn =~ m#/|^\W#;
3714 sub i_localname_dsc {
3715 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3720 sub i_localname_changes {
3721 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3722 $i_changesfn = $i_dscfn;
3723 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3724 return $i_changesfn;
3726 sub i_file_changes { }
3728 sub i_want_signed_tag {
3729 printdebug Dumper(\%i_param, $i_dscfn);
3730 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3731 && defined $i_param{'csuite'}
3732 or badproto \*RO, "premature desire for signed-tag";
3733 my $head = $i_param{'head'};
3734 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3736 my $maintview = $i_param{'maint-view'};
3737 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3740 if ($protovsn >= 4) {
3741 my $p = $i_param{'tagformat'} // '<undef>';
3743 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3746 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3748 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3750 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3753 push_mktags $i_clogp, $i_dscfn,
3754 $i_changesfn, 'remote changes',
3758 sub i_want_signed_dsc_changes {
3759 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3760 sign_changes $i_changesfn;
3761 return ($i_dscfn, $i_changesfn);
3764 #---------- building etc. ----------
3770 #----- `3.0 (quilt)' handling -----
3772 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3774 sub quiltify_dpkg_commit ($$$;$) {
3775 my ($patchname,$author,$msg, $xinfo) = @_;
3779 my $descfn = ".git/dgit/quilt-description.tmp";
3780 open O, '>', $descfn or die "$descfn: $!";
3781 $msg =~ s/\n+/\n\n/;
3782 print O <<END or die $!;
3784 ${xinfo}Subject: $msg
3791 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3792 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3793 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3794 runcmd @dpkgsource, qw(--commit .), $patchname;
3798 sub quiltify_trees_differ ($$;$$$) {
3799 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3800 # returns true iff the two tree objects differ other than in debian/
3801 # with $finegrained,
3802 # returns bitmask 01 - differ in upstream files except .gitignore
3803 # 02 - differ in .gitignore
3804 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3805 # is set for each modified .gitignore filename $fn
3806 # if $unrepres is defined, array ref to which is appeneded
3807 # a list of unrepresentable changes (removals of upstream files
3810 my @cmd = (@git, qw(diff-tree -z));
3811 push @cmd, qw(--name-only) unless $unrepres;
3812 push @cmd, qw(-r) if $finegrained || $unrepres;
3814 my $diffs= cmdoutput @cmd;
3817 foreach my $f (split /\0/, $diffs) {
3818 if ($unrepres && !@lmodes) {
3819 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3822 my ($oldmode,$newmode) = @lmodes;
3825 next if $f =~ m#^debian(?:/.*)?$#s;
3829 die "deleted\n" unless $newmode =~ m/[^0]/;
3830 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3831 if ($oldmode =~ m/[^0]/) {
3832 die "mode changed\n" if $oldmode ne $newmode;
3834 die "non-default mode\n" unless $newmode =~ m/^100644$/;
3838 local $/="\n"; chomp $@;
3839 push @$unrepres, [ $f, $@ ];
3843 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3844 $r |= $isignore ? 02 : 01;
3845 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3847 printdebug "quiltify_trees_differ $x $y => $r\n";
3851 sub quiltify_tree_sentinelfiles ($) {
3852 # lists the `sentinel' files present in the tree
3854 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3855 qw(-- debian/rules debian/control);
3860 sub quiltify_splitbrain_needed () {
3861 if (!$split_brain) {
3862 progress "dgit view: changes are required...";
3863 runcmd @git, qw(checkout -q -b dgit-view);
3868 sub quiltify_splitbrain ($$$$$$) {
3869 my ($clogp, $unapplied, $headref, $diffbits,
3870 $editedignores, $cachekey) = @_;
3871 if ($quilt_mode !~ m/gbp|dpm/) {
3872 # treat .gitignore just like any other upstream file
3873 $diffbits = { %$diffbits };
3874 $_ = !!$_ foreach values %$diffbits;
3876 # We would like any commits we generate to be reproducible
3877 my @authline = clogp_authline($clogp);
3878 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3879 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3880 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3881 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3882 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3883 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3885 if ($quilt_mode =~ m/gbp|unapplied/ &&
3886 ($diffbits->{O2H} & 01)) {
3888 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3889 " but git tree differs from orig in upstream files.";
3890 if (!stat_exists "debian/patches") {
3892 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3896 if ($quilt_mode =~ m/dpm/ &&
3897 ($diffbits->{H2A} & 01)) {
3899 --quilt=$quilt_mode specified, implying patches-applied git tree
3900 but git tree differs from result of applying debian/patches to upstream
3903 if ($quilt_mode =~ m/gbp|unapplied/ &&
3904 ($diffbits->{O2A} & 01)) { # some patches
3905 quiltify_splitbrain_needed();
3906 progress "dgit view: creating patches-applied version using gbp pq";
3907 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3908 # gbp pq import creates a fresh branch; push back to dgit-view
3909 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3910 runcmd @git, qw(checkout -q dgit-view);
3912 if ($quilt_mode =~ m/gbp|dpm/ &&
3913 ($diffbits->{O2A} & 02)) {
3915 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3916 tool which does not create patches for changes to upstream
3917 .gitignores: but, such patches exist in debian/patches.
3920 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3921 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3922 quiltify_splitbrain_needed();
3923 progress "dgit view: creating patch to represent .gitignore changes";
3924 ensuredir "debian/patches";
3925 my $gipatch = "debian/patches/auto-gitignore";
3926 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3927 stat GIPATCH or die "$gipatch: $!";
3928 fail "$gipatch already exists; but want to create it".
3929 " to record .gitignore changes" if (stat _)[7];
3930 print GIPATCH <<END or die "$gipatch: $!";
3931 Subject: Update .gitignore from Debian packaging branch
3933 The Debian packaging git branch contains these updates to the upstream
3934 .gitignore file(s). This patch is autogenerated, to provide these
3935 updates to users of the official Debian archive view of the package.
3937 [dgit ($our_version) update-gitignore]
3940 close GIPATCH or die "$gipatch: $!";
3941 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3942 $unapplied, $headref, "--", sort keys %$editedignores;
3943 open SERIES, "+>>", "debian/patches/series" or die $!;
3944 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3946 defined read SERIES, $newline, 1 or die $!;
3947 print SERIES "\n" or die $! unless $newline eq "\n";
3948 print SERIES "auto-gitignore\n" or die $!;
3949 close SERIES or die $!;
3950 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3952 Commit patch to update .gitignore
3954 [dgit ($our_version) update-gitignore-quilt-fixup]
3958 my $dgitview = git_rev_parse 'HEAD';
3960 changedir '../../../..';
3961 # When we no longer need to support squeeze, use --create-reflog
3963 ensuredir ".git/logs/refs/dgit-intern";
3964 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3967 my $oldcache = git_get_ref "refs/$splitbraincache";
3968 if ($oldcache eq $dgitview) {
3969 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
3970 # git update-ref doesn't always update, in this case. *sigh*
3971 my $dummy = make_commit_text <<END;
3974 author Dgit <dgit\@example.com> 1000000000 +0000
3975 committer Dgit <dgit\@example.com> 1000000000 +0000
3977 Dummy commit - do not use
3979 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
3980 "refs/$splitbraincache", $dummy;
3982 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3985 progress "dgit view: created (commit id $dgitview)";
3987 changedir '.git/dgit/unpack/work';
3990 sub quiltify ($$$$) {
3991 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3993 # Quilt patchification algorithm
3995 # We search backwards through the history of the main tree's HEAD
3996 # (T) looking for a start commit S whose tree object is identical
3997 # to to the patch tip tree (ie the tree corresponding to the
3998 # current dpkg-committed patch series). For these purposes
3999 # `identical' disregards anything in debian/ - this wrinkle is
4000 # necessary because dpkg-source treates debian/ specially.
4002 # We can only traverse edges where at most one of the ancestors'
4003 # trees differs (in changes outside in debian/). And we cannot
4004 # handle edges which change .pc/ or debian/patches. To avoid
4005 # going down a rathole we avoid traversing edges which introduce
4006 # debian/rules or debian/control. And we set a limit on the
4007 # number of edges we are willing to look at.
4009 # If we succeed, we walk forwards again. For each traversed edge
4010 # PC (with P parent, C child) (starting with P=S and ending with
4011 # C=T) to we do this:
4013 # - dpkg-source --commit with a patch name and message derived from C
4014 # After traversing PT, we git commit the changes which
4015 # should be contained within debian/patches.
4017 # The search for the path S..T is breadth-first. We maintain a
4018 # todo list containing search nodes. A search node identifies a
4019 # commit, and looks something like this:
4021 # Commit => $git_commit_id,
4022 # Child => $c, # or undef if P=T
4023 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4024 # Nontrivial => true iff $p..$c has relevant changes
4031 my %considered; # saves being exponential on some weird graphs
4033 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4036 my ($search,$whynot) = @_;
4037 printdebug " search NOT $search->{Commit} $whynot\n";
4038 $search->{Whynot} = $whynot;
4039 push @nots, $search;
4040 no warnings qw(exiting);
4049 my $c = shift @todo;
4050 next if $considered{$c->{Commit}}++;
4052 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4054 printdebug "quiltify investigate $c->{Commit}\n";
4057 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4058 printdebug " search finished hooray!\n";
4063 if ($quilt_mode eq 'nofix') {
4064 fail "quilt fixup required but quilt mode is \`nofix'\n".
4065 "HEAD commit $c->{Commit} differs from tree implied by ".
4066 " debian/patches (tree object $oldtiptree)";
4068 if ($quilt_mode eq 'smash') {
4069 printdebug " search quitting smash\n";
4073 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4074 $not->($c, "has $c_sentinels not $t_sentinels")
4075 if $c_sentinels ne $t_sentinels;
4077 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4078 $commitdata =~ m/\n\n/;
4080 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4081 @parents = map { { Commit => $_, Child => $c } } @parents;
4083 $not->($c, "root commit") if !@parents;
4085 foreach my $p (@parents) {
4086 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4088 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4089 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4091 foreach my $p (@parents) {
4092 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4094 my @cmd= (@git, qw(diff-tree -r --name-only),
4095 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4096 my $patchstackchange = cmdoutput @cmd;
4097 if (length $patchstackchange) {
4098 $patchstackchange =~ s/\n/,/g;
4099 $not->($p, "changed $patchstackchange");
4102 printdebug " search queue P=$p->{Commit} ",
4103 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4109 printdebug "quiltify want to smash\n";
4112 my $x = $_[0]{Commit};
4113 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4116 my $reportnot = sub {
4118 my $s = $abbrev->($notp);
4119 my $c = $notp->{Child};
4120 $s .= "..".$abbrev->($c) if $c;
4121 $s .= ": ".$notp->{Whynot};
4124 if ($quilt_mode eq 'linear') {
4125 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4126 foreach my $notp (@nots) {
4127 print STDERR "$us: ", $reportnot->($notp), "\n";
4129 print STDERR "$us: $_\n" foreach @$failsuggestion;
4130 fail "quilt fixup naive history linearisation failed.\n".
4131 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4132 } elsif ($quilt_mode eq 'smash') {
4133 } elsif ($quilt_mode eq 'auto') {
4134 progress "quilt fixup cannot be linear, smashing...";
4136 die "$quilt_mode ?";
4139 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4140 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4142 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4144 quiltify_dpkg_commit "auto-$version-$target-$time",
4145 (getfield $clogp, 'Maintainer'),
4146 "Automatically generated patch ($clogp->{Version})\n".
4147 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4151 progress "quiltify linearisation planning successful, executing...";
4153 for (my $p = $sref_S;
4154 my $c = $p->{Child};
4156 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4157 next unless $p->{Nontrivial};
4159 my $cc = $c->{Commit};
4161 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4162 $commitdata =~ m/\n\n/ or die "$c ?";
4165 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4168 my $commitdate = cmdoutput
4169 @git, qw(log -n1 --pretty=format:%aD), $cc;
4171 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4173 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4180 my $gbp_check_suitable = sub {
4185 die "contains unexpected slashes\n" if m{//} || m{/$};
4186 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4187 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4188 die "too long" if length > 200;
4190 return $_ unless $@;
4191 print STDERR "quiltifying commit $cc:".
4192 " ignoring/dropping Gbp-Pq $what: $@";
4196 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4198 (\S+) \s* \n //ixm) {
4199 $patchname = $gbp_check_suitable->($1, 'Name');
4201 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4203 (\S+) \s* \n //ixm) {
4204 $patchdir = $gbp_check_suitable->($1, 'Topic');
4209 if (!defined $patchname) {
4210 $patchname = $title;
4211 $patchname =~ s/[.:]$//;
4214 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4215 my $translitname = $converter->convert($patchname);
4216 die unless defined $translitname;
4217 $patchname = $translitname;
4220 "dgit: patch title transliteration error: $@"
4222 $patchname =~ y/ A-Z/-a-z/;
4223 $patchname =~ y/-a-z0-9_.+=~//cd;
4224 $patchname =~ s/^\W/x-$&/;
4225 $patchname = substr($patchname,0,40);
4227 if (!defined $patchdir) {
4230 if (length $patchdir) {
4231 $patchname = "$patchdir/$patchname";
4233 if ($patchname =~ m{^(.*)/}) {
4234 mkpath "debian/patches/$1";
4239 stat "debian/patches/$patchname$index";
4241 $!==ENOENT or die "$patchname$index $!";
4243 runcmd @git, qw(checkout -q), $cc;
4245 # We use the tip's changelog so that dpkg-source doesn't
4246 # produce complaining messages from dpkg-parsechangelog. None
4247 # of the information dpkg-source gets from the changelog is
4248 # actually relevant - it gets put into the original message
4249 # which dpkg-source provides our stunt editor, and then
4251 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4253 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4254 "Date: $commitdate\n".
4255 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4257 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4260 runcmd @git, qw(checkout -q master);
4263 sub build_maybe_quilt_fixup () {
4264 my ($format,$fopts) = get_source_format;
4265 return unless madformat_wantfixup $format;
4268 check_for_vendor_patches();
4270 if (quiltmode_splitbrain) {
4271 foreach my $needtf (qw(new maint)) {
4272 next if grep { $_ eq $needtf } access_cfg_tagformats;
4274 quilt mode $quilt_mode requires split view so server needs to support
4275 both "new" and "maint" tag formats, but config says it doesn't.
4280 my $clogp = parsechangelog();
4281 my $headref = git_rev_parse('HEAD');
4286 my $upstreamversion=$version;
4287 $upstreamversion =~ s/-[^-]*$//;
4289 if ($fopts->{'single-debian-patch'}) {
4290 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4292 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4295 die 'bug' if $split_brain && !$need_split_build_invocation;
4297 changedir '../../../..';
4298 runcmd_ordryrun_local
4299 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4302 sub quilt_fixup_mkwork ($) {
4305 mkdir "work" or die $!;
4307 mktree_in_ud_here();
4308 runcmd @git, qw(reset -q --hard), $headref;
4311 sub quilt_fixup_linkorigs ($$) {
4312 my ($upstreamversion, $fn) = @_;
4313 # calls $fn->($leafname);
4315 foreach my $f (<../../../../*>) { #/){
4316 my $b=$f; $b =~ s{.*/}{};
4318 local ($debuglevel) = $debuglevel-1;
4319 printdebug "QF linkorigs $b, $f ?\n";
4321 next unless is_orig_file_of_vsn $b, $upstreamversion;
4322 printdebug "QF linkorigs $b, $f Y\n";
4323 link_ltarget $f, $b or die "$b $!";
4328 sub quilt_fixup_delete_pc () {
4329 runcmd @git, qw(rm -rqf .pc);
4331 Commit removal of .pc (quilt series tracking data)
4333 [dgit ($our_version) upgrade quilt-remove-pc]
4337 sub quilt_fixup_singlepatch ($$$) {
4338 my ($clogp, $headref, $upstreamversion) = @_;
4340 progress "starting quiltify (single-debian-patch)";
4342 # dpkg-source --commit generates new patches even if
4343 # single-debian-patch is in debian/source/options. In order to
4344 # get it to generate debian/patches/debian-changes, it is
4345 # necessary to build the source package.
4347 quilt_fixup_linkorigs($upstreamversion, sub { });
4348 quilt_fixup_mkwork($headref);
4350 rmtree("debian/patches");
4352 runcmd @dpkgsource, qw(-b .);
4354 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4355 rename srcfn("$upstreamversion", "/debian/patches"),
4356 "work/debian/patches";
4359 commit_quilty_patch();
4362 sub quilt_make_fake_dsc ($) {
4363 my ($upstreamversion) = @_;
4365 my $fakeversion="$upstreamversion-~~DGITFAKE";
4367 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4368 print $fakedsc <<END or die $!;
4371 Version: $fakeversion
4375 my $dscaddfile=sub {
4378 my $md = new Digest::MD5;
4380 my $fh = new IO::File $b, '<' or die "$b $!";
4385 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4388 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4390 my @files=qw(debian/source/format debian/rules
4391 debian/control debian/changelog);
4392 foreach my $maybe (qw(debian/patches debian/source/options
4393 debian/tests/control)) {
4394 next unless stat_exists "../../../$maybe";
4395 push @files, $maybe;
4398 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4399 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4401 $dscaddfile->($debtar);
4402 close $fakedsc or die $!;
4405 sub quilt_check_splitbrain_cache ($$) {
4406 my ($headref, $upstreamversion) = @_;
4407 # Called only if we are in (potentially) split brain mode.
4409 # Computes the cache key and looks in the cache.
4410 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4412 my $splitbrain_cachekey;
4415 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4416 # we look in the reflog of dgit-intern/quilt-cache
4417 # we look for an entry whose message is the key for the cache lookup
4418 my @cachekey = (qw(dgit), $our_version);
4419 push @cachekey, $upstreamversion;
4420 push @cachekey, $quilt_mode;
4421 push @cachekey, $headref;
4423 push @cachekey, hashfile('fake.dsc');
4425 my $srcshash = Digest::SHA->new(256);
4426 my %sfs = ( %INC, '$0(dgit)' => $0 );
4427 foreach my $sfk (sort keys %sfs) {
4428 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4429 $srcshash->add($sfk," ");
4430 $srcshash->add(hashfile($sfs{$sfk}));
4431 $srcshash->add("\n");
4433 push @cachekey, $srcshash->hexdigest();
4434 $splitbrain_cachekey = "@cachekey";
4436 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4438 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4439 debugcmd "|(probably)",@cmd;
4440 my $child = open GC, "-|"; defined $child or die $!;
4442 chdir '../../..' or die $!;
4443 if (!stat ".git/logs/refs/$splitbraincache") {
4444 $! == ENOENT or die $!;
4445 printdebug ">(no reflog)\n";
4452 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4453 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4456 quilt_fixup_mkwork($headref);
4457 if ($cachehit ne $headref) {
4458 progress "dgit view: found cached (commit id $cachehit)";
4459 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4461 return ($cachehit, $splitbrain_cachekey);
4463 progress "dgit view: found cached, no changes required";
4464 return ($headref, $splitbrain_cachekey);
4466 die $! if GC->error;
4467 failedcmd unless close GC;
4469 printdebug "splitbrain cache miss\n";
4470 return (undef, $splitbrain_cachekey);
4473 sub quilt_fixup_multipatch ($$$) {
4474 my ($clogp, $headref, $upstreamversion) = @_;
4476 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4479 # - honour any existing .pc in case it has any strangeness
4480 # - determine the git commit corresponding to the tip of
4481 # the patch stack (if there is one)
4482 # - if there is such a git commit, convert each subsequent
4483 # git commit into a quilt patch with dpkg-source --commit
4484 # - otherwise convert all the differences in the tree into
4485 # a single git commit
4489 # Our git tree doesn't necessarily contain .pc. (Some versions of
4490 # dgit would include the .pc in the git tree.) If there isn't
4491 # one, we need to generate one by unpacking the patches that we
4494 # We first look for a .pc in the git tree. If there is one, we
4495 # will use it. (This is not the normal case.)
4497 # Otherwise need to regenerate .pc so that dpkg-source --commit
4498 # can work. We do this as follows:
4499 # 1. Collect all relevant .orig from parent directory
4500 # 2. Generate a debian.tar.gz out of
4501 # debian/{patches,rules,source/format,source/options}
4502 # 3. Generate a fake .dsc containing just these fields:
4503 # Format Source Version Files
4504 # 4. Extract the fake .dsc
4505 # Now the fake .dsc has a .pc directory.
4506 # (In fact we do this in every case, because in future we will
4507 # want to search for a good base commit for generating patches.)
4509 # Then we can actually do the dpkg-source --commit
4510 # 1. Make a new working tree with the same object
4511 # store as our main tree and check out the main
4513 # 2. Copy .pc from the fake's extraction, if necessary
4514 # 3. Run dpkg-source --commit
4515 # 4. If the result has changes to debian/, then
4516 # - git add them them
4517 # - git add .pc if we had a .pc in-tree
4519 # 5. If we had a .pc in-tree, delete it, and git commit
4520 # 6. Back in the main tree, fast forward to the new HEAD
4522 # Another situation we may have to cope with is gbp-style
4523 # patches-unapplied trees.
4525 # We would want to detect these, so we know to escape into
4526 # quilt_fixup_gbp. However, this is in general not possible.
4527 # Consider a package with a one patch which the dgit user reverts
4528 # (with git revert or the moral equivalent).
4530 # That is indistinguishable in contents from a patches-unapplied
4531 # tree. And looking at the history to distinguish them is not
4532 # useful because the user might have made a confusing-looking git
4533 # history structure (which ought to produce an error if dgit can't
4534 # cope, not a silent reintroduction of an unwanted patch).
4536 # So gbp users will have to pass an option. But we can usually
4537 # detect their failure to do so: if the tree is not a clean
4538 # patches-applied tree, quilt linearisation fails, but the tree
4539 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4540 # they want --quilt=unapplied.
4542 # To help detect this, when we are extracting the fake dsc, we
4543 # first extract it with --skip-patches, and then apply the patches
4544 # afterwards with dpkg-source --before-build. That lets us save a
4545 # tree object corresponding to .origs.
4547 my $splitbrain_cachekey;
4549 quilt_make_fake_dsc($upstreamversion);
4551 if (quiltmode_splitbrain()) {
4553 ($cachehit, $splitbrain_cachekey) =
4554 quilt_check_splitbrain_cache($headref, $upstreamversion);
4555 return if $cachehit;
4559 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4561 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4562 rename $fakexdir, "fake" or die "$fakexdir $!";
4566 remove_stray_gits();
4567 mktree_in_ud_here();
4571 runcmd @git, qw(add -Af .);
4572 my $unapplied=git_write_tree();
4573 printdebug "fake orig tree object $unapplied\n";
4577 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4579 if (system @bbcmd) {
4580 failedcmd @bbcmd if $? < 0;
4582 failed to apply your git tree's patch stack (from debian/patches/) to
4583 the corresponding upstream tarball(s). Your source tree and .orig
4584 are probably too inconsistent. dgit can only fix up certain kinds of
4585 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4591 quilt_fixup_mkwork($headref);
4594 if (stat_exists ".pc") {
4596 progress "Tree already contains .pc - will use it then delete it.";
4599 rename '../fake/.pc','.pc' or die $!;
4602 changedir '../fake';
4604 runcmd @git, qw(add -Af .);
4605 my $oldtiptree=git_write_tree();
4606 printdebug "fake o+d/p tree object $unapplied\n";
4607 changedir '../work';
4610 # We calculate some guesswork now about what kind of tree this might
4611 # be. This is mostly for error reporting.
4617 # O = orig, without patches applied
4618 # A = "applied", ie orig with H's debian/patches applied
4619 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4620 \%editedignores, \@unrepres),
4621 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4622 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4626 foreach my $b (qw(01 02)) {
4627 foreach my $v (qw(O2H O2A H2A)) {
4628 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4631 printdebug "differences \@dl @dl.\n";
4634 "$us: base trees orig=%.20s o+d/p=%.20s",
4635 $unapplied, $oldtiptree;
4637 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4638 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4639 $dl[0], $dl[1], $dl[3], $dl[4],
4643 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4645 forceable_fail [qw(unrepresentable)], <<END;
4646 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4651 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4652 push @failsuggestion, "This might be a patches-unapplied branch.";
4653 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4654 push @failsuggestion, "This might be a patches-applied branch.";
4656 push @failsuggestion, "Maybe you need to specify one of".
4657 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4659 if (quiltmode_splitbrain()) {
4660 quiltify_splitbrain($clogp, $unapplied, $headref,
4661 $diffbits, \%editedignores,
4662 $splitbrain_cachekey);
4666 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4667 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4669 if (!open P, '>>', ".pc/applied-patches") {
4670 $!==&ENOENT or die $!;
4675 commit_quilty_patch();
4677 if ($mustdeletepc) {
4678 quilt_fixup_delete_pc();
4682 sub quilt_fixup_editor () {
4683 my $descfn = $ENV{$fakeeditorenv};
4684 my $editing = $ARGV[$#ARGV];
4685 open I1, '<', $descfn or die "$descfn: $!";
4686 open I2, '<', $editing or die "$editing: $!";
4687 unlink $editing or die "$editing: $!";
4688 open O, '>', $editing or die "$editing: $!";
4689 while (<I1>) { print O or die $!; } I1->error and die $!;
4692 $copying ||= m/^\-\-\- /;
4693 next unless $copying;
4696 I2->error and die $!;
4701 sub maybe_apply_patches_dirtily () {
4702 return unless $quilt_mode =~ m/gbp|unapplied/;
4703 print STDERR <<END or die $!;
4705 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4706 dgit: Have to apply the patches - making the tree dirty.
4707 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4710 $patches_applied_dirtily = 01;
4711 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4712 runcmd qw(dpkg-source --before-build .);
4715 sub maybe_unapply_patches_again () {
4716 progress "dgit: Unapplying patches again to tidy up the tree."
4717 if $patches_applied_dirtily;
4718 runcmd qw(dpkg-source --after-build .)
4719 if $patches_applied_dirtily & 01;
4721 if $patches_applied_dirtily & 02;
4722 $patches_applied_dirtily = 0;
4725 #----- other building -----
4727 our $clean_using_builder;
4728 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4729 # clean the tree before building (perhaps invoked indirectly by
4730 # whatever we are using to run the build), rather than separately
4731 # and explicitly by us.
4734 return if $clean_using_builder;
4735 if ($cleanmode eq 'dpkg-source') {
4736 maybe_apply_patches_dirtily();
4737 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4738 } elsif ($cleanmode eq 'dpkg-source-d') {
4739 maybe_apply_patches_dirtily();
4740 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4741 } elsif ($cleanmode eq 'git') {
4742 runcmd_ordryrun_local @git, qw(clean -xdf);
4743 } elsif ($cleanmode eq 'git-ff') {
4744 runcmd_ordryrun_local @git, qw(clean -xdff);
4745 } elsif ($cleanmode eq 'check') {
4746 my $leftovers = cmdoutput @git, qw(clean -xdn);
4747 if (length $leftovers) {
4748 print STDERR $leftovers, "\n" or die $!;
4749 fail "tree contains uncommitted files and --clean=check specified";
4751 } elsif ($cleanmode eq 'none') {
4758 badusage "clean takes no additional arguments" if @ARGV;
4761 maybe_unapply_patches_again();
4766 badusage "-p is not allowed when building" if defined $package;
4769 my $clogp = parsechangelog();
4770 $isuite = getfield $clogp, 'Distribution';
4771 $package = getfield $clogp, 'Source';
4772 $version = getfield $clogp, 'Version';
4773 build_maybe_quilt_fixup();
4775 my $pat = changespat $version;
4776 foreach my $f (glob "$buildproductsdir/$pat") {
4778 unlink $f or fail "remove old changes file $f: $!";
4780 progress "would remove $f";
4786 sub changesopts_initial () {
4787 my @opts =@changesopts[1..$#changesopts];
4790 sub changesopts_version () {
4791 if (!defined $changes_since_version) {
4792 my @vsns = archive_query('archive_query');
4793 my @quirk = access_quirk();
4794 if ($quirk[0] eq 'backports') {
4795 local $isuite = $quirk[2];
4797 canonicalise_suite();
4798 push @vsns, archive_query('archive_query');
4801 @vsns = map { $_->[0] } @vsns;
4802 @vsns = sort { -version_compare($a, $b) } @vsns;
4803 $changes_since_version = $vsns[0];
4804 progress "changelog will contain changes since $vsns[0]";
4806 $changes_since_version = '_';
4807 progress "package seems new, not specifying -v<version>";
4810 if ($changes_since_version ne '_') {
4811 return ("-v$changes_since_version");
4817 sub changesopts () {
4818 return (changesopts_initial(), changesopts_version());
4821 sub massage_dbp_args ($;$) {
4822 my ($cmd,$xargs) = @_;
4825 # - if we're going to split the source build out so we can
4826 # do strange things to it, massage the arguments to dpkg-buildpackage
4827 # so that the main build doessn't build source (or add an argument
4828 # to stop it building source by default).
4830 # - add -nc to stop dpkg-source cleaning the source tree,
4831 # unless we're not doing a split build and want dpkg-source
4832 # as cleanmode, in which case we can do nothing
4835 # 0 - source will NOT need to be built separately by caller
4836 # +1 - source will need to be built separately by caller
4837 # +2 - source will need to be built separately by caller AND
4838 # dpkg-buildpackage should not in fact be run at all!
4839 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4840 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4841 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4842 $clean_using_builder = 1;
4845 # -nc has the side effect of specifying -b if nothing else specified
4846 # and some combinations of -S, -b, et al, are errors, rather than
4847 # later simply overriding earlie. So we need to:
4848 # - search the command line for these options
4849 # - pick the last one
4850 # - perhaps add our own as a default
4851 # - perhaps adjust it to the corresponding non-source-building version
4853 foreach my $l ($cmd, $xargs) {
4855 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4858 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4860 if ($need_split_build_invocation) {
4861 printdebug "massage split $dmode.\n";
4862 $r = $dmode =~ m/[S]/ ? +2 :
4863 $dmode =~ y/gGF/ABb/ ? +1 :
4864 $dmode =~ m/[ABb]/ ? 0 :
4867 printdebug "massage done $r $dmode.\n";
4869 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4874 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4875 my $wantsrc = massage_dbp_args \@dbp;
4882 push @dbp, changesopts_version();
4883 maybe_apply_patches_dirtily();
4884 runcmd_ordryrun_local @dbp;
4886 maybe_unapply_patches_again();
4887 printdone "build successful\n";
4891 $quilt_mode //= 'gbp';
4895 my @dbp = @dpkgbuildpackage;
4897 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4899 if (!length $gbp_build[0]) {
4900 if (length executable_on_path('git-buildpackage')) {
4901 $gbp_build[0] = qw(git-buildpackage);
4903 $gbp_build[0] = 'gbp buildpackage';
4906 my @cmd = opts_opt_multi_cmd @gbp_build;
4908 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4913 if (!$clean_using_builder) {
4914 push @cmd, '--git-cleaner=true';
4918 maybe_unapply_patches_again();
4920 push @cmd, changesopts();
4921 runcmd_ordryrun_local @cmd, @ARGV;
4923 printdone "build successful\n";
4925 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4928 my $our_cleanmode = $cleanmode;
4929 if ($need_split_build_invocation) {
4930 # Pretend that clean is being done some other way. This
4931 # forces us not to try to use dpkg-buildpackage to clean and
4932 # build source all in one go; and instead we run dpkg-source
4933 # (and build_prep() will do the clean since $clean_using_builder
4935 $our_cleanmode = 'ELSEWHERE';
4937 if ($our_cleanmode =~ m/^dpkg-source/) {
4938 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4939 $clean_using_builder = 1;
4942 $sourcechanges = changespat $version,'source';
4944 unlink "../$sourcechanges" or $!==ENOENT
4945 or fail "remove $sourcechanges: $!";
4947 $dscfn = dscfn($version);
4948 if ($our_cleanmode eq 'dpkg-source') {
4949 maybe_apply_patches_dirtily();
4950 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4952 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4953 maybe_apply_patches_dirtily();
4954 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4957 my @cmd = (@dpkgsource, qw(-b --));
4960 runcmd_ordryrun_local @cmd, "work";
4961 my @udfiles = <${package}_*>;
4962 changedir "../../..";
4963 foreach my $f (@udfiles) {
4964 printdebug "source copy, found $f\n";
4967 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4968 $f eq srcfn($version, $&));
4969 printdebug "source copy, found $f - renaming\n";
4970 rename "$ud/$f", "../$f" or $!==ENOENT
4971 or fail "put in place new source file ($f): $!";
4974 my $pwd = must_getcwd();
4975 my $leafdir = basename $pwd;
4977 runcmd_ordryrun_local @cmd, $leafdir;
4980 runcmd_ordryrun_local qw(sh -ec),
4981 'exec >$1; shift; exec "$@"','x',
4982 "../$sourcechanges",
4983 @dpkggenchanges, qw(-S), changesopts();
4987 sub cmd_build_source {
4988 badusage "build-source takes no additional arguments" if @ARGV;
4990 maybe_unapply_patches_again();
4991 printdone "source built, results in $dscfn and $sourcechanges";
4996 my $pat = changespat $version;
4998 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4999 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5001 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5002 Suggest you delete @unwanted.
5006 my $wasdir = must_getcwd();
5009 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5010 stat_exists $sourcechanges
5011 or fail "$sourcechanges (in parent directory): $!";
5013 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5014 my @changesfiles = glob $pat;
5015 @changesfiles = sort {
5016 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5019 fail <<END if @changesfiles==1;
5020 only one changes file from sbuild (@changesfiles)
5021 perhaps you need to pass -A ? (sbuild's default is to build only
5022 arch-specific binaries; dgit 1.4 used to override that.)
5024 fail "wrong number of different changes files (@changesfiles)"
5025 unless @changesfiles==2;
5026 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5027 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5028 fail "$l found in binaries changes file $binchanges"
5031 runcmd_ordryrun_local @mergechanges, @changesfiles;
5032 my $multichanges = changespat $version,'multi';
5034 stat_exists $multichanges or fail "$multichanges: $!";
5035 foreach my $cf (glob $pat) {
5036 next if $cf eq $multichanges;
5037 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5041 maybe_unapply_patches_again();
5042 printdone "build successful, results in $multichanges\n" or die $!;
5045 sub cmd_quilt_fixup {
5046 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5047 my $clogp = parsechangelog();
5048 $version = getfield $clogp, 'Version';
5049 $package = getfield $clogp, 'Source';
5052 build_maybe_quilt_fixup();
5055 sub cmd_archive_api_query {
5056 badusage "need only 1 subpath argument" unless @ARGV==1;
5057 my ($subpath) = @ARGV;
5058 my @cmd = archive_api_query_cmd($subpath);
5061 exec @cmd or fail "exec curl: $!\n";
5064 sub cmd_clone_dgit_repos_server {
5065 badusage "need destination argument" unless @ARGV==1;
5066 my ($destdir) = @ARGV;
5067 $package = '_dgit-repos-server';
5068 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5070 exec @cmd or fail "exec git clone: $!\n";
5073 sub cmd_setup_mergechangelogs {
5074 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5075 setup_mergechangelogs(1);
5078 sub cmd_setup_useremail {
5079 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5083 sub cmd_setup_new_tree {
5084 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5088 #---------- argument parsing and main program ----------
5091 print "dgit version $our_version\n" or die $!;
5095 our (%valopts_long, %valopts_short);
5098 sub defvalopt ($$$$) {
5099 my ($long,$short,$val_re,$how) = @_;
5100 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5101 $valopts_long{$long} = $oi;
5102 $valopts_short{$short} = $oi;
5103 # $how subref should:
5104 # do whatever assignemnt or thing it likes with $_[0]
5105 # if the option should not be passed on to remote, @rvalopts=()
5106 # or $how can be a scalar ref, meaning simply assign the value
5109 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5110 defvalopt '--distro', '-d', '.+', \$idistro;
5111 defvalopt '', '-k', '.+', \$keyid;
5112 defvalopt '--existing-package','', '.*', \$existing_package;
5113 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5114 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5115 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5117 defvalopt '', '-C', '.+', sub {
5118 ($changesfile) = (@_);
5119 if ($changesfile =~ s#^(.*)/##) {
5120 $buildproductsdir = $1;
5124 defvalopt '--initiator-tempdir','','.*', sub {
5125 ($initiator_tempdir) = (@_);
5126 $initiator_tempdir =~ m#^/# or
5127 badusage "--initiator-tempdir must be used specify an".
5128 " absolute, not relative, directory."
5134 if (defined $ENV{'DGIT_SSH'}) {
5135 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5136 } elsif (defined $ENV{'GIT_SSH'}) {
5137 @ssh = ($ENV{'GIT_SSH'});
5145 if (!defined $val) {
5146 badusage "$what needs a value" unless @ARGV;
5148 push @rvalopts, $val;
5150 badusage "bad value \`$val' for $what" unless
5151 $val =~ m/^$oi->{Re}$(?!\n)/s;
5152 my $how = $oi->{How};
5153 if (ref($how) eq 'SCALAR') {
5158 push @ropts, @rvalopts;
5162 last unless $ARGV[0] =~ m/^-/;
5166 if (m/^--dry-run$/) {
5169 } elsif (m/^--damp-run$/) {
5172 } elsif (m/^--no-sign$/) {
5175 } elsif (m/^--help$/) {
5177 } elsif (m/^--version$/) {
5179 } elsif (m/^--new$/) {
5182 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5183 ($om = $opts_opt_map{$1}) &&
5187 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5188 !$opts_opt_cmdonly{$1} &&
5189 ($om = $opts_opt_map{$1})) {
5192 } elsif (m/^--(gbp|dpm)$/s) {
5193 push @ropts, "--quilt=$1";
5195 } elsif (m/^--ignore-dirty$/s) {
5198 } elsif (m/^--no-quilt-fixup$/s) {
5200 $quilt_mode = 'nocheck';
5201 } elsif (m/^--no-rm-on-error$/s) {
5204 } elsif (m/^--overwrite$/s) {
5206 $overwrite_version = '';
5207 } elsif (m/^--overwrite=(.+)$/s) {
5209 $overwrite_version = $1;
5210 } elsif (m/^--(no-)?rm-old-changes$/s) {
5213 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5215 push @deliberatelies, $&;
5216 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5220 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5221 # undocumented, for testing
5223 $tagformat_want = [ $1, 'command line', 1 ];
5224 # 1 menas overrides distro configuration
5225 } elsif (m/^--always-split-source-build$/s) {
5226 # undocumented, for testing
5228 $need_split_build_invocation = 1;
5229 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5230 $val = $2 ? $' : undef; #';
5231 $valopt->($oi->{Long});
5233 badusage "unknown long option \`$_'";
5240 } elsif (s/^-L/-/) {
5243 } elsif (s/^-h/-/) {
5245 } elsif (s/^-D/-/) {
5249 } elsif (s/^-N/-/) {
5254 push @changesopts, $_;
5256 } elsif (s/^-wn$//s) {
5258 $cleanmode = 'none';
5259 } elsif (s/^-wg$//s) {
5262 } elsif (s/^-wgf$//s) {
5264 $cleanmode = 'git-ff';
5265 } elsif (s/^-wd$//s) {
5267 $cleanmode = 'dpkg-source';
5268 } elsif (s/^-wdd$//s) {
5270 $cleanmode = 'dpkg-source-d';
5271 } elsif (s/^-wc$//s) {
5273 $cleanmode = 'check';
5274 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5275 push @git, '-c', $&;
5276 $gitcfgs{cmdline}{$1} = [ $2 ];
5277 } elsif (s/^-c([^=]+)$//s) {
5278 push @git, '-c', $&;
5279 $gitcfgs{cmdline}{$1} = [ 'true' ];
5280 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5282 $val = undef unless length $val;
5283 $valopt->($oi->{Short});
5286 badusage "unknown short option \`$_'";
5293 sub check_env_sanity () {
5294 my $blocked = new POSIX::SigSet;
5295 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5298 foreach my $name (qw(PIPE CHLD)) {
5299 my $signame = "SIG$name";
5300 my $signum = eval "POSIX::$signame" // die;
5301 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5302 die "$signame is set to something other than SIG_DFL\n";
5303 $blocked->ismember($signum) and
5304 die "$signame is blocked\n";
5310 On entry to dgit, $@
5311 This is a bug produced by something in in your execution environment.
5317 sub finalise_opts_opts () {
5318 foreach my $k (keys %opts_opt_map) {
5319 my $om = $opts_opt_map{$k};
5321 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5323 badcfg "cannot set command for $k"
5324 unless length $om->[0];
5328 foreach my $c (access_cfg_cfgs("opts-$k")) {
5330 map { $_ ? @$_ : () }
5331 map { $gitcfgs{$_}{$c} }
5332 reverse @gitcfgsources;
5333 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5334 "\n" if $debuglevel >= 4;
5336 badcfg "cannot configure options for $k"
5337 if $opts_opt_cmdonly{$k};
5338 my $insertpos = $opts_cfg_insertpos{$k};
5339 @$om = ( @$om[0..$insertpos-1],
5341 @$om[$insertpos..$#$om] );
5346 if ($ENV{$fakeeditorenv}) {
5348 quilt_fixup_editor();
5355 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5356 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5357 if $dryrun_level == 1;
5359 print STDERR $helpmsg or die $!;
5362 my $cmd = shift @ARGV;
5365 my $pre_fn = ${*::}{"pre_$cmd"};
5366 $pre_fn->() if $pre_fn;
5368 if (!defined $rmchanges) {
5369 local $access_forpush;
5370 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5373 if (!defined $quilt_mode) {
5374 local $access_forpush;
5375 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5376 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5378 $quilt_mode =~ m/^($quilt_modes_re)$/
5379 or badcfg "unknown quilt-mode \`$quilt_mode'";
5383 $need_split_build_invocation ||= quiltmode_splitbrain();
5385 if (!defined $cleanmode) {
5386 local $access_forpush;
5387 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5388 $cleanmode //= 'dpkg-source';
5390 badcfg "unknown clean-mode \`$cleanmode'" unless
5391 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5394 my $fn = ${*::}{"cmd_$cmd"};
5395 $fn or badusage "unknown operation $cmd";