3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
44 our $absurdity = undef; ###substituted###
46 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
49 our $isuite = 'unstable';
55 our $dryrun_level = 0;
57 our $buildproductsdir = '..';
63 our $existing_package = 'dpkg';
65 our $changes_since_version;
67 our $overwrite_version; # undef: not specified; '': check changelog
69 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
70 our $we_are_responder;
71 our $initiator_tempdir;
72 our $patches_applied_dirtily = 00;
77 our %forceopts = map { $_=>0 }
78 qw(unrepresentable unsupported-source-format
79 dsc-changes-mismatch);
81 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
83 our $suite_re = '[-+.0-9a-z]+';
84 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
85 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
86 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
87 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
89 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
90 our $splitbraincache = 'dgit-intern/quilt-cache';
93 our (@dget) = qw(dget);
94 our (@curl) = qw(curl);
95 our (@dput) = qw(dput);
96 our (@debsign) = qw(debsign);
98 our (@sbuild) = qw(sbuild);
100 our (@dgit) = qw(dgit);
101 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
102 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
103 our (@dpkggenchanges) = qw(dpkg-genchanges);
104 our (@mergechanges) = qw(mergechanges -f);
105 our (@gbp_build) = ('');
106 our (@gbp_pq) = ('gbp pq');
107 our (@changesopts) = ('');
109 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
112 'debsign' => \@debsign,
114 'sbuild' => \@sbuild,
118 'dpkg-source' => \@dpkgsource,
119 'dpkg-buildpackage' => \@dpkgbuildpackage,
120 'dpkg-genchanges' => \@dpkggenchanges,
121 'gbp-build' => \@gbp_build,
122 'gbp-pq' => \@gbp_pq,
123 'ch' => \@changesopts,
124 'mergechanges' => \@mergechanges);
126 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
127 our %opts_cfg_insertpos = map {
129 scalar @{ $opts_opt_map{$_} }
130 } keys %opts_opt_map;
132 sub finalise_opts_opts();
138 our $supplementary_message = '';
139 our $need_split_build_invocation = 0;
140 our $split_brain = 0;
144 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
147 our $remotename = 'dgit';
148 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
152 if (!defined $absurdity) {
154 $absurdity =~ s{/[^/]+$}{/absurd} or die;
158 my ($v,$distro) = @_;
159 return $tagformatfn->($v, $distro);
162 sub debiantag_maintview ($$) {
163 my ($v,$distro) = @_;
168 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
170 sub lbranch () { return "$branchprefix/$csuite"; }
171 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
172 sub lref () { return "refs/heads/".lbranch(); }
173 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
174 sub rrref () { return server_ref($csuite); }
176 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
177 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
179 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
180 # locally fetched refs because they have unhelpful names and clutter
181 # up gitk etc. So we track whether we have "used up" head ref (ie,
182 # whether we have made another local ref which refers to this object).
184 # (If we deleted them unconditionally, then we might end up
185 # re-fetching the same git objects each time dgit fetch was run.)
187 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
188 # in git_fetch_us to fetch the refs in question, and possibly a call
189 # to lrfetchref_used.
191 our (%lrfetchrefs_f, %lrfetchrefs_d);
192 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
194 sub lrfetchref_used ($) {
195 my ($fullrefname) = @_;
196 my $objid = $lrfetchrefs_f{$fullrefname};
197 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
208 return "${package}_".(stripepoch $vsn).$sfx
213 return srcfn($vsn,".dsc");
216 sub changespat ($;$) {
217 my ($vsn, $arch) = @_;
218 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
227 foreach my $f (@end) {
229 print STDERR "$us: cleanup: $@" if length $@;
233 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
235 sub forceable_fail ($$) {
236 my ($forceoptsl, $msg) = @_;
237 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
238 print STDERR "warning: overriding problem due to --force:\n". $msg;
242 my ($forceoptsl) = @_;
243 my @got = grep { $forceopts{$_} } @$forceoptsl;
244 return 0 unless @got;
246 "warning: skipping checks or functionality due to --force-$got[0]\n";
249 sub no_such_package () {
250 print STDERR "$us: package $package does not exist in suite $isuite\n";
256 printdebug "CD $newdir\n";
257 chdir $newdir or confess "chdir: $newdir: $!";
260 sub deliberately ($) {
262 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
265 sub deliberately_not_fast_forward () {
266 foreach (qw(not-fast-forward fresh-repo)) {
267 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
271 sub quiltmode_splitbrain () {
272 $quilt_mode =~ m/gbp|dpm|unapplied/;
275 sub opts_opt_multi_cmd {
277 push @cmd, split /\s+/, shift @_;
283 return opts_opt_multi_cmd @gbp_pq;
286 #---------- remote protocol support, common ----------
288 # remote push initiator/responder protocol:
289 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
290 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
291 # < dgit-remote-push-ready <actual-proto-vsn>
298 # > supplementary-message NBYTES # $protovsn >= 3
303 # > file parsed-changelog
304 # [indicates that output of dpkg-parsechangelog follows]
305 # > data-block NBYTES
306 # > [NBYTES bytes of data (no newline)]
307 # [maybe some more blocks]
316 # > param head DGIT-VIEW-HEAD
317 # > param csuite SUITE
318 # > param tagformat old|new
319 # > param maint-view MAINT-VIEW-HEAD
321 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
322 # # goes into tag, for replay prevention
325 # [indicates that signed tag is wanted]
326 # < data-block NBYTES
327 # < [NBYTES bytes of data (no newline)]
328 # [maybe some more blocks]
332 # > want signed-dsc-changes
333 # < data-block NBYTES [transfer of signed dsc]
335 # < data-block NBYTES [transfer of signed changes]
343 sub i_child_report () {
344 # Sees if our child has died, and reap it if so. Returns a string
345 # describing how it died if it failed, or undef otherwise.
346 return undef unless $i_child_pid;
347 my $got = waitpid $i_child_pid, WNOHANG;
348 return undef if $got <= 0;
349 die unless $got == $i_child_pid;
350 $i_child_pid = undef;
351 return undef unless $?;
352 return "build host child ".waitstatusmsg();
357 fail "connection lost: $!" if $fh->error;
358 fail "protocol violation; $m not expected";
361 sub badproto_badread ($$) {
363 fail "connection lost: $!" if $!;
364 my $report = i_child_report();
365 fail $report if defined $report;
366 badproto $fh, "eof (reading $wh)";
369 sub protocol_expect (&$) {
370 my ($match, $fh) = @_;
373 defined && chomp or badproto_badread $fh, "protocol message";
381 badproto $fh, "\`$_'";
384 sub protocol_send_file ($$) {
385 my ($fh, $ourfn) = @_;
386 open PF, "<", $ourfn or die "$ourfn: $!";
389 my $got = read PF, $d, 65536;
390 die "$ourfn: $!" unless defined $got;
392 print $fh "data-block ".length($d)."\n" or die $!;
393 print $fh $d or die $!;
395 PF->error and die "$ourfn $!";
396 print $fh "data-end\n" or die $!;
400 sub protocol_read_bytes ($$) {
401 my ($fh, $nbytes) = @_;
402 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
404 my $got = read $fh, $d, $nbytes;
405 $got==$nbytes or badproto_badread $fh, "data block";
409 sub protocol_receive_file ($$) {
410 my ($fh, $ourfn) = @_;
411 printdebug "() $ourfn\n";
412 open PF, ">", $ourfn or die "$ourfn: $!";
414 my ($y,$l) = protocol_expect {
415 m/^data-block (.*)$/ ? (1,$1) :
416 m/^data-end$/ ? (0,) :
420 my $d = protocol_read_bytes $fh, $l;
421 print PF $d or die $!;
426 #---------- remote protocol support, responder ----------
428 sub responder_send_command ($) {
430 return unless $we_are_responder;
431 # called even without $we_are_responder
432 printdebug ">> $command\n";
433 print PO $command, "\n" or die $!;
436 sub responder_send_file ($$) {
437 my ($keyword, $ourfn) = @_;
438 return unless $we_are_responder;
439 printdebug "]] $keyword $ourfn\n";
440 responder_send_command "file $keyword";
441 protocol_send_file \*PO, $ourfn;
444 sub responder_receive_files ($@) {
445 my ($keyword, @ourfns) = @_;
446 die unless $we_are_responder;
447 printdebug "[[ $keyword @ourfns\n";
448 responder_send_command "want $keyword";
449 foreach my $fn (@ourfns) {
450 protocol_receive_file \*PI, $fn;
453 protocol_expect { m/^files-end$/ } \*PI;
456 #---------- remote protocol support, initiator ----------
458 sub initiator_expect (&) {
460 protocol_expect { &$match } \*RO;
463 #---------- end remote code ----------
466 if ($we_are_responder) {
468 responder_send_command "progress ".length($m) or die $!;
469 print PO $m or die $!;
479 $ua = LWP::UserAgent->new();
483 progress "downloading $what...";
484 my $r = $ua->get(@_) or die $!;
485 return undef if $r->code == 404;
486 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
487 return $r->decoded_content(charset => 'none');
490 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
495 failedcmd @_ if system @_;
498 sub act_local () { return $dryrun_level <= 1; }
499 sub act_scary () { return !$dryrun_level; }
502 if (!$dryrun_level) {
503 progress "dgit ok: @_";
505 progress "would be ok: @_ (but dry run only)";
510 printcmd(\*STDERR,$debugprefix."#",@_);
513 sub runcmd_ordryrun {
521 sub runcmd_ordryrun_local {
530 my ($first_shell, @cmd) = @_;
531 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
534 our $helpmsg = <<END;
536 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
537 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
538 dgit [dgit-opts] build [dpkg-buildpackage-opts]
539 dgit [dgit-opts] sbuild [sbuild-opts]
540 dgit [dgit-opts] push [dgit-opts] [suite]
541 dgit [dgit-opts] rpush build-host:build-dir ...
542 important dgit options:
543 -k<keyid> sign tag and package with <keyid> instead of default
544 --dry-run -n do not change anything, but go through the motions
545 --damp-run -L like --dry-run but make local changes, without signing
546 --new -N allow introducing a new package
547 --debug -D increase debug level
548 -c<name>=<value> set git config option (used directly by dgit too)
551 our $later_warning_msg = <<END;
552 Perhaps the upload is stuck in incoming. Using the version from git.
556 print STDERR "$us: @_\n", $helpmsg or die $!;
561 @ARGV or badusage "too few arguments";
562 return scalar shift @ARGV;
566 print $helpmsg or die $!;
570 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
572 our %defcfg = ('dgit.default.distro' => 'debian',
573 'dgit.default.username' => '',
574 'dgit.default.archive-query-default-component' => 'main',
575 'dgit.default.ssh' => 'ssh',
576 'dgit.default.archive-query' => 'madison:',
577 'dgit.default.sshpsql-dbname' => 'service=projectb',
578 'dgit.default.dgit-tag-format' => 'new,old,maint',
579 # old means "repo server accepts pushes with old dgit tags"
580 # new means "repo server accepts pushes with new dgit tags"
581 # maint means "repo server accepts split brain pushes"
582 # hist means "repo server may have old pushes without new tag"
583 # ("hist" is implied by "old")
584 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
585 'dgit-distro.debian.git-check' => 'url',
586 'dgit-distro.debian.git-check-suffix' => '/info/refs',
587 'dgit-distro.debian.new-private-pushers' => 't',
588 'dgit-distro.debian/push.git-url' => '',
589 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
590 'dgit-distro.debian/push.git-user-force' => 'dgit',
591 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
592 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
593 'dgit-distro.debian/push.git-create' => 'true',
594 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
595 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
596 # 'dgit-distro.debian.archive-query-tls-key',
597 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
598 # ^ this does not work because curl is broken nowadays
599 # Fixing #790093 properly will involve providing providing the key
600 # in some pacagke and maybe updating these paths.
602 # 'dgit-distro.debian.archive-query-tls-curl-args',
603 # '--ca-path=/etc/ssl/ca-debian',
604 # ^ this is a workaround but works (only) on DSA-administered machines
605 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
606 'dgit-distro.debian.git-url-suffix' => '',
607 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
608 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
609 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
610 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
611 'dgit-distro.ubuntu.git-check' => 'false',
612 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
613 'dgit-distro.test-dummy.ssh' => "$td/ssh",
614 'dgit-distro.test-dummy.username' => "alice",
615 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
616 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
617 'dgit-distro.test-dummy.git-url' => "$td/git",
618 'dgit-distro.test-dummy.git-host' => "git",
619 'dgit-distro.test-dummy.git-path' => "$td/git",
620 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
621 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
622 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
623 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
627 our @gitcfgsources = qw(cmdline local global system);
629 sub git_slurp_config () {
630 local ($debuglevel) = $debuglevel-2;
633 # This algoritm is a bit subtle, but this is needed so that for
634 # options which we want to be single-valued, we allow the
635 # different config sources to override properly. See #835858.
636 foreach my $src (@gitcfgsources) {
637 next if $src eq 'cmdline';
638 # we do this ourselves since git doesn't handle it
640 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
643 open GITS, "-|", @cmd or die $!;
646 printdebug "=> ", (messagequote $_), "\n";
648 push @{ $gitcfgs{$src}{$`} }, $'; #';
652 or ($!==0 && $?==256)
657 sub git_get_config ($) {
659 foreach my $src (@gitcfgsources) {
660 my $l = $gitcfgs{$src}{$c};
661 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
664 @$l==1 or badcfg "multiple values for $c".
665 " (in $src git config)" if @$l > 1;
673 return undef if $c =~ /RETURN-UNDEF/;
674 my $v = git_get_config($c);
675 return $v if defined $v;
676 my $dv = $defcfg{$c};
677 return $dv if defined $dv;
679 badcfg "need value for one of: @_\n".
680 "$us: distro or suite appears not to be (properly) supported";
683 sub access_basedistro () {
684 if (defined $idistro) {
687 return cfg("dgit-suite.$isuite.distro",
688 "dgit.default.distro");
692 sub access_quirk () {
693 # returns (quirk name, distro to use instead or undef, quirk-specific info)
694 my $basedistro = access_basedistro();
695 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
697 if (defined $backports_quirk) {
698 my $re = $backports_quirk;
699 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
701 $re =~ s/\%/([-0-9a-z_]+)/
702 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
703 if ($isuite =~ m/^$re$/) {
704 return ('backports',"$basedistro-backports",$1);
707 return ('none',undef);
712 sub parse_cfg_bool ($$$) {
713 my ($what,$def,$v) = @_;
716 $v =~ m/^[ty1]/ ? 1 :
717 $v =~ m/^[fn0]/ ? 0 :
718 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
721 sub access_forpush_config () {
722 my $d = access_basedistro();
726 parse_cfg_bool('new-private-pushers', 0,
727 cfg("dgit-distro.$d.new-private-pushers",
730 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
733 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
734 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
735 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
736 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
739 sub access_forpush () {
740 $access_forpush //= access_forpush_config();
741 return $access_forpush;
745 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
746 badcfg "pushing but distro is configured readonly"
747 if access_forpush_config() eq '0';
749 $supplementary_message = <<'END' unless $we_are_responder;
750 Push failed, before we got started.
751 You can retry the push, after fixing the problem, if you like.
753 finalise_opts_opts();
757 finalise_opts_opts();
760 sub supplementary_message ($) {
762 if (!$we_are_responder) {
763 $supplementary_message = $msg;
765 } elsif ($protovsn >= 3) {
766 responder_send_command "supplementary-message ".length($msg)
768 print PO $msg or die $!;
772 sub access_distros () {
773 # Returns list of distros to try, in order
776 # 0. `instead of' distro name(s) we have been pointed to
777 # 1. the access_quirk distro, if any
778 # 2a. the user's specified distro, or failing that } basedistro
779 # 2b. the distro calculated from the suite }
780 my @l = access_basedistro();
782 my (undef,$quirkdistro) = access_quirk();
783 unshift @l, $quirkdistro;
784 unshift @l, $instead_distro;
785 @l = grep { defined } @l;
787 if (access_forpush()) {
788 @l = map { ("$_/push", $_) } @l;
793 sub access_cfg_cfgs (@) {
796 # The nesting of these loops determines the search order. We put
797 # the key loop on the outside so that we search all the distros
798 # for each key, before going on to the next key. That means that
799 # if access_cfg is called with a more specific, and then a less
800 # specific, key, an earlier distro can override the less specific
801 # without necessarily overriding any more specific keys. (If the
802 # distro wants to override the more specific keys it can simply do
803 # so; whereas if we did the loop the other way around, it would be
804 # impossible to for an earlier distro to override a less specific
805 # key but not the more specific ones without restating the unknown
806 # values of the more specific keys.
809 # We have to deal with RETURN-UNDEF specially, so that we don't
810 # terminate the search prematurely.
812 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
815 foreach my $d (access_distros()) {
816 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
818 push @cfgs, map { "dgit.default.$_" } @realkeys;
825 my (@cfgs) = access_cfg_cfgs(@keys);
826 my $value = cfg(@cfgs);
830 sub access_cfg_bool ($$) {
831 my ($def, @keys) = @_;
832 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
835 sub string_to_ssh ($) {
837 if ($spec =~ m/\s/) {
838 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
844 sub access_cfg_ssh () {
845 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
846 if (!defined $gitssh) {
849 return string_to_ssh $gitssh;
853 sub access_runeinfo ($) {
855 return ": dgit ".access_basedistro()." $info ;";
858 sub access_someuserhost ($) {
860 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
861 defined($user) && length($user) or
862 $user = access_cfg("$some-user",'username');
863 my $host = access_cfg("$some-host");
864 return length($user) ? "$user\@$host" : $host;
867 sub access_gituserhost () {
868 return access_someuserhost('git');
871 sub access_giturl (;$) {
873 my $url = access_cfg('git-url','RETURN-UNDEF');
876 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
877 return undef unless defined $proto;
880 access_gituserhost().
881 access_cfg('git-path');
883 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
886 return "$url/$package$suffix";
889 sub parsecontrolfh ($$;$) {
890 my ($fh, $desc, $allowsigned) = @_;
891 our $dpkgcontrolhash_noissigned;
894 my %opts = ('name' => $desc);
895 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
896 $c = Dpkg::Control::Hash->new(%opts);
897 $c->parse($fh,$desc) or die "parsing of $desc failed";
898 last if $allowsigned;
899 last if $dpkgcontrolhash_noissigned;
900 my $issigned= $c->get_option('is_pgp_signed');
901 if (!defined $issigned) {
902 $dpkgcontrolhash_noissigned= 1;
903 seek $fh, 0,0 or die "seek $desc: $!";
904 } elsif ($issigned) {
905 fail "control file $desc is (already) PGP-signed. ".
906 " Note that dgit push needs to modify the .dsc and then".
907 " do the signature itself";
916 my ($file, $desc) = @_;
917 my $fh = new IO::Handle;
918 open $fh, '<', $file or die "$file: $!";
919 my $c = parsecontrolfh($fh,$desc);
920 $fh->error and die $!;
926 my ($dctrl,$field) = @_;
927 my $v = $dctrl->{$field};
928 return $v if defined $v;
929 fail "missing field $field in ".$dctrl->get_option('name');
933 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
934 my $p = new IO::Handle;
935 my @cmd = (qw(dpkg-parsechangelog), @_);
936 open $p, '-|', @cmd or die $!;
938 $?=0; $!=0; close $p or failedcmd @cmd;
942 sub commit_getclogp ($) {
943 # Returns the parsed changelog hashref for a particular commit
945 our %commit_getclogp_memo;
946 my $memo = $commit_getclogp_memo{$objid};
947 return $memo if $memo;
949 my $mclog = ".git/dgit/clog-$objid";
950 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
951 "$objid:debian/changelog";
952 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
957 defined $d or fail "getcwd failed: $!";
963 sub archive_query ($) {
965 my $query = access_cfg('archive-query','RETURN-UNDEF');
966 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
969 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
972 sub pool_dsc_subpath ($$) {
973 my ($vsn,$component) = @_; # $package is implict arg
974 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
975 return "/pool/$component/$prefix/$package/".dscfn($vsn);
978 #---------- `ftpmasterapi' archive query method (nascent) ----------
980 sub archive_api_query_cmd ($) {
982 my @cmd = (@curl, qw(-sS));
983 my $url = access_cfg('archive-query-url');
984 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
986 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
987 foreach my $key (split /\:/, $keys) {
988 $key =~ s/\%HOST\%/$host/g;
990 fail "for $url: stat $key: $!" unless $!==ENOENT;
993 fail "config requested specific TLS key but do not know".
994 " how to get curl to use exactly that EE key ($key)";
995 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
996 # # Sadly the above line does not work because of changes
997 # # to gnutls. The real fix for #790093 may involve
998 # # new curl options.
1001 # Fixing #790093 properly will involve providing a value
1002 # for this on clients.
1003 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1004 push @cmd, split / /, $kargs if defined $kargs;
1006 push @cmd, $url.$subpath;
1010 sub api_query ($$) {
1012 my ($data, $subpath) = @_;
1013 badcfg "ftpmasterapi archive query method takes no data part"
1015 my @cmd = archive_api_query_cmd($subpath);
1016 my $url = $cmd[$#cmd];
1017 push @cmd, qw(-w %{http_code});
1018 my $json = cmdoutput @cmd;
1019 unless ($json =~ s/\d+\d+\d$//) {
1020 failedcmd_report_cmd undef, @cmd;
1021 fail "curl failed to print 3-digit HTTP code";
1024 fail "fetch of $url gave HTTP code $code"
1025 unless $url =~ m#^file://# or $code =~ m/^2/;
1026 return decode_json($json);
1029 sub canonicalise_suite_ftpmasterapi () {
1030 my ($proto,$data) = @_;
1031 my $suites = api_query($data, 'suites');
1033 foreach my $entry (@$suites) {
1035 my $v = $entry->{$_};
1036 defined $v && $v eq $isuite;
1037 } qw(codename name);
1038 push @matched, $entry;
1040 fail "unknown suite $isuite" unless @matched;
1043 @matched==1 or die "multiple matches for suite $isuite\n";
1044 $cn = "$matched[0]{codename}";
1045 defined $cn or die "suite $isuite info has no codename\n";
1046 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1048 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1053 sub archive_query_ftpmasterapi () {
1054 my ($proto,$data) = @_;
1055 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1057 my $digester = Digest::SHA->new(256);
1058 foreach my $entry (@$info) {
1060 my $vsn = "$entry->{version}";
1061 my ($ok,$msg) = version_check $vsn;
1062 die "bad version: $msg\n" unless $ok;
1063 my $component = "$entry->{component}";
1064 $component =~ m/^$component_re$/ or die "bad component";
1065 my $filename = "$entry->{filename}";
1066 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1067 or die "bad filename";
1068 my $sha256sum = "$entry->{sha256sum}";
1069 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1070 push @rows, [ $vsn, "/pool/$component/$filename",
1071 $digester, $sha256sum ];
1073 die "bad ftpmaster api response: $@\n".Dumper($entry)
1076 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1080 #---------- `madison' archive query method ----------
1082 sub archive_query_madison {
1083 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1086 sub madison_get_parse {
1087 my ($proto,$data) = @_;
1088 die unless $proto eq 'madison';
1089 if (!length $data) {
1090 $data= access_cfg('madison-distro','RETURN-UNDEF');
1091 $data //= access_basedistro();
1093 $rmad{$proto,$data,$package} ||= cmdoutput
1094 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1095 my $rmad = $rmad{$proto,$data,$package};
1098 foreach my $l (split /\n/, $rmad) {
1099 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1100 \s*( [^ \t|]+ )\s* \|
1101 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1102 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1103 $1 eq $package or die "$rmad $package ?";
1110 $component = access_cfg('archive-query-default-component');
1112 $5 eq 'source' or die "$rmad ?";
1113 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1115 return sort { -version_compare($a->[0],$b->[0]); } @out;
1118 sub canonicalise_suite_madison {
1119 # madison canonicalises for us
1120 my @r = madison_get_parse(@_);
1122 "unable to canonicalise suite using package $package".
1123 " which does not appear to exist in suite $isuite;".
1124 " --existing-package may help";
1128 #---------- `sshpsql' archive query method ----------
1131 my ($data,$runeinfo,$sql) = @_;
1132 if (!length $data) {
1133 $data= access_someuserhost('sshpsql').':'.
1134 access_cfg('sshpsql-dbname');
1136 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1137 my ($userhost,$dbname) = ($`,$'); #';
1139 my @cmd = (access_cfg_ssh, $userhost,
1140 access_runeinfo("ssh-psql $runeinfo").
1141 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1142 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1144 open P, "-|", @cmd or die $!;
1147 printdebug(">|$_|\n");
1150 $!=0; $?=0; close P or failedcmd @cmd;
1152 my $nrows = pop @rows;
1153 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1154 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1155 @rows = map { [ split /\|/, $_ ] } @rows;
1156 my $ncols = scalar @{ shift @rows };
1157 die if grep { scalar @$_ != $ncols } @rows;
1161 sub sql_injection_check {
1162 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1165 sub archive_query_sshpsql ($$) {
1166 my ($proto,$data) = @_;
1167 sql_injection_check $isuite, $package;
1168 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1169 SELECT source.version, component.name, files.filename, files.sha256sum
1171 JOIN src_associations ON source.id = src_associations.source
1172 JOIN suite ON suite.id = src_associations.suite
1173 JOIN dsc_files ON dsc_files.source = source.id
1174 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1175 JOIN component ON component.id = files_archive_map.component_id
1176 JOIN files ON files.id = dsc_files.file
1177 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1178 AND source.source='$package'
1179 AND files.filename LIKE '%.dsc';
1181 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1182 my $digester = Digest::SHA->new(256);
1184 my ($vsn,$component,$filename,$sha256sum) = @$_;
1185 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1190 sub canonicalise_suite_sshpsql ($$) {
1191 my ($proto,$data) = @_;
1192 sql_injection_check $isuite;
1193 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1194 SELECT suite.codename
1195 FROM suite where suite_name='$isuite' or codename='$isuite';
1197 @rows = map { $_->[0] } @rows;
1198 fail "unknown suite $isuite" unless @rows;
1199 die "ambiguous $isuite: @rows ?" if @rows>1;
1203 #---------- `dummycat' archive query method ----------
1205 sub canonicalise_suite_dummycat ($$) {
1206 my ($proto,$data) = @_;
1207 my $dpath = "$data/suite.$isuite";
1208 if (!open C, "<", $dpath) {
1209 $!==ENOENT or die "$dpath: $!";
1210 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1214 chomp or die "$dpath: $!";
1216 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1220 sub archive_query_dummycat ($$) {
1221 my ($proto,$data) = @_;
1222 canonicalise_suite();
1223 my $dpath = "$data/package.$csuite.$package";
1224 if (!open C, "<", $dpath) {
1225 $!==ENOENT or die "$dpath: $!";
1226 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1234 printdebug "dummycat query $csuite $package $dpath | $_\n";
1235 my @row = split /\s+/, $_;
1236 @row==2 or die "$dpath: $_ ?";
1239 C->error and die "$dpath: $!";
1241 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1244 #---------- tag format handling ----------
1246 sub access_cfg_tagformats () {
1247 split /\,/, access_cfg('dgit-tag-format');
1250 sub need_tagformat ($$) {
1251 my ($fmt, $why) = @_;
1252 fail "need to use tag format $fmt ($why) but also need".
1253 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1254 " - no way to proceed"
1255 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1256 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1259 sub select_tagformat () {
1261 return if $tagformatfn && !$tagformat_want;
1262 die 'bug' if $tagformatfn && $tagformat_want;
1263 # ... $tagformat_want assigned after previous select_tagformat
1265 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1266 printdebug "select_tagformat supported @supported\n";
1268 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1269 printdebug "select_tagformat specified @$tagformat_want\n";
1271 my ($fmt,$why,$override) = @$tagformat_want;
1273 fail "target distro supports tag formats @supported".
1274 " but have to use $fmt ($why)"
1276 or grep { $_ eq $fmt } @supported;
1278 $tagformat_want = undef;
1280 $tagformatfn = ${*::}{"debiantag_$fmt"};
1282 fail "trying to use unknown tag format \`$fmt' ($why) !"
1283 unless $tagformatfn;
1286 #---------- archive query entrypoints and rest of program ----------
1288 sub canonicalise_suite () {
1289 return if defined $csuite;
1290 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1291 $csuite = archive_query('canonicalise_suite');
1292 if ($isuite ne $csuite) {
1293 progress "canonical suite name for $isuite is $csuite";
1297 sub get_archive_dsc () {
1298 canonicalise_suite();
1299 my @vsns = archive_query('archive_query');
1300 foreach my $vinfo (@vsns) {
1301 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1302 $dscurl = access_cfg('mirror').$subpath;
1303 $dscdata = url_get($dscurl);
1305 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1310 $digester->add($dscdata);
1311 my $got = $digester->hexdigest();
1313 fail "$dscurl has hash $got but".
1314 " archive told us to expect $digest";
1316 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1317 printdebug Dumper($dscdata) if $debuglevel>1;
1318 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1319 printdebug Dumper($dsc) if $debuglevel>1;
1320 my $fmt = getfield $dsc, 'Format';
1321 $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1322 "unsupported source format $fmt, sorry";
1324 $dsc_checked = !!$digester;
1325 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1329 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1332 sub check_for_git ();
1333 sub check_for_git () {
1335 my $how = access_cfg('git-check');
1336 if ($how eq 'ssh-cmd') {
1338 (access_cfg_ssh, access_gituserhost(),
1339 access_runeinfo("git-check $package").
1340 " set -e; cd ".access_cfg('git-path').";".
1341 " if test -d $package.git; then echo 1; else echo 0; fi");
1342 my $r= cmdoutput @cmd;
1343 if (defined $r and $r =~ m/^divert (\w+)$/) {
1345 my ($usedistro,) = access_distros();
1346 # NB that if we are pushing, $usedistro will be $distro/push
1347 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1348 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1349 progress "diverting to $divert (using config for $instead_distro)";
1350 return check_for_git();
1352 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1354 } elsif ($how eq 'url') {
1355 my $prefix = access_cfg('git-check-url','git-url');
1356 my $suffix = access_cfg('git-check-suffix','git-suffix',
1357 'RETURN-UNDEF') // '.git';
1358 my $url = "$prefix/$package$suffix";
1359 my @cmd = (@curl, qw(-sS -I), $url);
1360 my $result = cmdoutput @cmd;
1361 $result =~ s/^\S+ 200 .*\n\r?\n//;
1362 # curl -sS -I with https_proxy prints
1363 # HTTP/1.0 200 Connection established
1364 $result =~ m/^\S+ (404|200) /s or
1365 fail "unexpected results from git check query - ".
1366 Dumper($prefix, $result);
1368 if ($code eq '404') {
1370 } elsif ($code eq '200') {
1375 } elsif ($how eq 'true') {
1377 } elsif ($how eq 'false') {
1380 badcfg "unknown git-check \`$how'";
1384 sub create_remote_git_repo () {
1385 my $how = access_cfg('git-create');
1386 if ($how eq 'ssh-cmd') {
1388 (access_cfg_ssh, access_gituserhost(),
1389 access_runeinfo("git-create $package").
1390 "set -e; cd ".access_cfg('git-path').";".
1391 " cp -a _template $package.git");
1392 } elsif ($how eq 'true') {
1395 badcfg "unknown git-create \`$how'";
1399 our ($dsc_hash,$lastpush_mergeinput);
1401 our $ud = '.git/dgit/unpack';
1411 sub mktree_in_ud_here () {
1412 runcmd qw(git init -q);
1413 runcmd qw(git config gc.auto 0);
1414 rmtree('.git/objects');
1415 symlink '../../../../objects','.git/objects' or die $!;
1418 sub git_write_tree () {
1419 my $tree = cmdoutput @git, qw(write-tree);
1420 $tree =~ m/^\w+$/ or die "$tree ?";
1424 sub remove_stray_gits () {
1425 my @gitscmd = qw(find -name .git -prune -print0);
1426 debugcmd "|",@gitscmd;
1427 open GITS, "-|", @gitscmd or die $!;
1432 print STDERR "$us: warning: removing from source package: ",
1433 (messagequote $_), "\n";
1437 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1440 sub mktree_in_ud_from_only_subdir (;$) {
1443 # changes into the subdir
1445 die "expected one subdir but found @dirs ?" unless @dirs==1;
1446 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1450 remove_stray_gits();
1451 mktree_in_ud_here();
1453 my ($format, $fopts) = get_source_format();
1454 if (madformat($format)) {
1459 runcmd @git, qw(add -Af);
1460 my $tree=git_write_tree();
1461 return ($tree,$dir);
1464 our @files_csum_info_fields =
1465 (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1466 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1467 ['Files', 'Digest::MD5', 'new()']);
1469 sub dsc_files_info () {
1470 foreach my $csumi (@files_csum_info_fields) {
1471 my ($fname, $module, $method) = @$csumi;
1472 my $field = $dsc->{$fname};
1473 next unless defined $field;
1474 eval "use $module; 1;" or die $@;
1476 foreach (split /\n/, $field) {
1478 m/^(\w+) (\d+) (\S+)$/ or
1479 fail "could not parse .dsc $fname line \`$_'";
1480 my $digester = eval "$module"."->$method;" or die $@;
1485 Digester => $digester,
1490 fail "missing any supported Checksums-* or Files field in ".
1491 $dsc->get_option('name');
1495 map { $_->{Filename} } dsc_files_info();
1498 sub files_compare_inputs (@) {
1503 my $showinputs = sub {
1504 return join "; ", map { $_->get_option('name') } @$inputs;
1507 foreach my $in (@$inputs) {
1509 my $in_name = $in->get_option('name');
1511 printdebug "files_compare_inputs $in_name\n";
1513 foreach my $csumi (@files_csum_info_fields) {
1514 my ($fname) = @$csumi;
1515 printdebug "files_compare_inputs $in_name $fname\n";
1517 my $field = $in->{$fname};
1518 next unless defined $field;
1521 foreach (split /\n/, $field) {
1524 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1525 fail "could not parse $in_name $fname line \`$_'";
1527 printdebug "files_compare_inputs $in_name $fname $f\n";
1531 my $re = \ $record{$f}{$fname};
1533 $fchecked{$f}{$in_name} = 1;
1535 fail "hash or size of $f varies in $fname fields".
1536 " (between: ".$showinputs->().")";
1541 @files = sort @files;
1542 $expected_files //= \@files;
1543 "@$expected_files" eq "@files" or
1544 fail "file list in $in_name varies between hash fields!";
1547 fail "$in_name has no files list field(s)";
1549 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1552 grep { keys %$_ == @$inputs-1 } values %fchecked
1553 or fail "no file appears in all file lists".
1554 " (looked in: ".$showinputs->().")";
1557 sub is_orig_file_in_dsc ($$) {
1558 my ($f, $dsc_files_info) = @_;
1559 return 0 if @$dsc_files_info <= 1;
1560 # One file means no origs, and the filename doesn't have a "what
1561 # part of dsc" component. (Consider versions ending `.orig'.)
1562 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1566 sub is_orig_file_of_vsn ($$) {
1567 my ($f, $upstreamvsn) = @_;
1568 my $base = srcfn $upstreamvsn, '';
1569 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1573 sub make_commit ($) {
1575 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1578 sub make_commit_text ($) {
1581 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1583 print Dumper($text) if $debuglevel > 1;
1584 my $child = open2($out, $in, @cmd) or die $!;
1587 print $in $text or die $!;
1588 close $in or die $!;
1590 $h =~ m/^\w+$/ or die;
1592 printdebug "=> $h\n";
1595 waitpid $child, 0 == $child or die "$child $!";
1596 $? and failedcmd @cmd;
1600 sub clogp_authline ($) {
1602 my $author = getfield $clogp, 'Maintainer';
1603 $author =~ s#,.*##ms;
1604 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1605 my $authline = "$author $date";
1606 $authline =~ m/$git_authline_re/o or
1607 fail "unexpected commit author line format \`$authline'".
1608 " (was generated from changelog Maintainer field)";
1609 return ($1,$2,$3) if wantarray;
1613 sub vendor_patches_distro ($$) {
1614 my ($checkdistro, $what) = @_;
1615 return unless defined $checkdistro;
1617 my $series = "debian/patches/\L$checkdistro\E.series";
1618 printdebug "checking for vendor-specific $series ($what)\n";
1620 if (!open SERIES, "<", $series) {
1621 die "$series $!" unless $!==ENOENT;
1630 Unfortunately, this source package uses a feature of dpkg-source where
1631 the same source package unpacks to different source code on different
1632 distros. dgit cannot safely operate on such packages on affected
1633 distros, because the meaning of source packages is not stable.
1635 Please ask the distro/maintainer to remove the distro-specific series
1636 files and use a different technique (if necessary, uploading actually
1637 different packages, if different distros are supposed to have
1641 fail "Found active distro-specific series file for".
1642 " $checkdistro ($what): $series, cannot continue";
1644 die "$series $!" if SERIES->error;
1648 sub check_for_vendor_patches () {
1649 # This dpkg-source feature doesn't seem to be documented anywhere!
1650 # But it can be found in the changelog (reformatted):
1652 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1653 # Author: Raphael Hertzog <hertzog@debian.org>
1654 # Date: Sun Oct 3 09:36:48 2010 +0200
1656 # dpkg-source: correctly create .pc/.quilt_series with alternate
1659 # If you have debian/patches/ubuntu.series and you were
1660 # unpacking the source package on ubuntu, quilt was still
1661 # directed to debian/patches/series instead of
1662 # debian/patches/ubuntu.series.
1664 # debian/changelog | 3 +++
1665 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1666 # 2 files changed, 6 insertions(+), 1 deletion(-)
1669 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1670 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1671 "Dpkg::Vendor \`current vendor'");
1672 vendor_patches_distro(access_basedistro(),
1673 "distro being accessed");
1676 sub generate_commits_from_dsc () {
1677 # See big comment in fetch_from_archive, below.
1678 # See also README.dsc-import.
1682 my @dfi = dsc_files_info();
1683 foreach my $fi (@dfi) {
1684 my $f = $fi->{Filename};
1685 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1687 link_ltarget "../../../$f", $f
1691 complete_file_from_dsc('.', $fi)
1694 if (is_orig_file_in_dsc($f, \@dfi)) {
1695 link $f, "../../../../$f"
1701 # We unpack and record the orig tarballs first, so that we only
1702 # need disk space for one private copy of the unpacked source.
1703 # But we can't make them into commits until we have the metadata
1704 # from the debian/changelog, so we record the tree objects now and
1705 # make them into commits later.
1707 my $upstreamv = $dsc->{version};
1708 $upstreamv =~ s/-[^-]+$//;
1709 my $orig_f_base = srcfn $upstreamv, '';
1711 foreach my $fi (@dfi) {
1712 # We actually import, and record as a commit, every tarball
1713 # (unless there is only one file, in which case there seems
1716 my $f = $fi->{Filename};
1717 printdebug "import considering $f ";
1718 (printdebug "only one dfi\n"), next if @dfi == 1;
1719 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1720 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1724 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1726 printdebug "Y ", (join ' ', map { $_//"(none)" }
1727 $compr_ext, $orig_f_part
1730 my $input = new IO::File $f, '<' or die "$f $!";
1734 if (defined $compr_ext) {
1736 Dpkg::Compression::compression_guess_from_filename $f;
1737 fail "Dpkg::Compression cannot handle file $f in source package"
1738 if defined $compr_ext && !defined $cname;
1740 new Dpkg::Compression::Process compression => $cname;
1741 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1742 my $compr_fh = new IO::Handle;
1743 my $compr_pid = open $compr_fh, "-|" // die $!;
1745 open STDIN, "<&", $input or die $!;
1747 die "dgit (child): exec $compr_cmd[0]: $!\n";
1752 rmtree "../unpack-tar";
1753 mkdir "../unpack-tar" or die $!;
1754 my @tarcmd = qw(tar -x -f -
1755 --no-same-owner --no-same-permissions
1756 --no-acls --no-xattrs --no-selinux);
1757 my $tar_pid = fork // die $!;
1759 chdir "../unpack-tar" or die $!;
1760 open STDIN, "<&", $input or die $!;
1762 die "dgit (child): exec $tarcmd[0]: $!";
1764 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1765 !$? or failedcmd @tarcmd;
1768 (@compr_cmd ? failedcmd @compr_cmd
1770 # finally, we have the results in "tarball", but maybe
1771 # with the wrong permissions
1773 runcmd qw(chmod -R +rwX ../unpack-tar);
1774 changedir "../unpack-tar";
1775 my ($tree) = mktree_in_ud_from_only_subdir(1);
1776 changedir "../../unpack";
1777 rmtree "../unpack-tar";
1779 my $ent = [ $f, $tree ];
1781 Orig => !!$orig_f_part,
1782 Sort => (!$orig_f_part ? 2 :
1783 $orig_f_part =~ m/-/g ? 1 :
1791 # put any without "_" first (spec is not clear whether files
1792 # are always in the usual order). Tarballs without "_" are
1793 # the main orig or the debian tarball.
1794 $a->{Sort} <=> $b->{Sort} or
1798 my $any_orig = grep { $_->{Orig} } @tartrees;
1800 my $dscfn = "$package.dsc";
1802 my $treeimporthow = 'package';
1804 open D, ">", $dscfn or die "$dscfn: $!";
1805 print D $dscdata or die "$dscfn: $!";
1806 close D or die "$dscfn: $!";
1807 my @cmd = qw(dpkg-source);
1808 push @cmd, '--no-check' if $dsc_checked;
1809 if (madformat $dsc->{format}) {
1810 push @cmd, '--skip-patches';
1811 $treeimporthow = 'unpatched';
1813 push @cmd, qw(-x --), $dscfn;
1816 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1817 if (madformat $dsc->{format}) {
1818 check_for_vendor_patches();
1822 if (madformat $dsc->{format}) {
1823 my @pcmd = qw(dpkg-source --before-build .);
1824 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1826 runcmd @git, qw(add -Af);
1827 $dappliedtree = git_write_tree();
1830 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1831 debugcmd "|",@clogcmd;
1832 open CLOGS, "-|", @clogcmd or die $!;
1837 printdebug "import clog search...\n";
1840 my $stanzatext = do { local $/=""; <CLOGS>; };
1841 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1842 last if !defined $stanzatext;
1844 my $desc = "package changelog, entry no.$.";
1845 open my $stanzafh, "<", \$stanzatext or die;
1846 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1847 $clogp //= $thisstanza;
1849 printdebug "import clog $thisstanza->{version} $desc...\n";
1851 last if !$any_orig; # we don't need $r1clogp
1853 # We look for the first (most recent) changelog entry whose
1854 # version number is lower than the upstream version of this
1855 # package. Then the last (least recent) previous changelog
1856 # entry is treated as the one which introduced this upstream
1857 # version and used for the synthetic commits for the upstream
1860 # One might think that a more sophisticated algorithm would be
1861 # necessary. But: we do not want to scan the whole changelog
1862 # file. Stopping when we see an earlier version, which
1863 # necessarily then is an earlier upstream version, is the only
1864 # realistic way to do that. Then, either the earliest
1865 # changelog entry we have seen so far is indeed the earliest
1866 # upload of this upstream version; or there are only changelog
1867 # entries relating to later upstream versions (which is not
1868 # possible unless the changelog and .dsc disagree about the
1869 # version). Then it remains to choose between the physically
1870 # last entry in the file, and the one with the lowest version
1871 # number. If these are not the same, we guess that the
1872 # versions were created in a non-monotic order rather than
1873 # that the changelog entries have been misordered.
1875 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1877 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1878 $r1clogp = $thisstanza;
1880 printdebug "import clog $r1clogp->{version} becomes r1\n";
1882 die $! if CLOGS->error;
1883 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
1885 $clogp or fail "package changelog has no entries!";
1887 my $authline = clogp_authline $clogp;
1888 my $changes = getfield $clogp, 'Changes';
1889 my $cversion = getfield $clogp, 'Version';
1892 $r1clogp //= $clogp; # maybe there's only one entry;
1893 my $r1authline = clogp_authline $r1clogp;
1894 # Strictly, r1authline might now be wrong if it's going to be
1895 # unused because !$any_orig. Whatever.
1897 printdebug "import tartrees authline $authline\n";
1898 printdebug "import tartrees r1authline $r1authline\n";
1900 foreach my $tt (@tartrees) {
1901 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1903 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1906 committer $r1authline
1910 [dgit import orig $tt->{F}]
1918 [dgit import tarball $package $cversion $tt->{F}]
1923 printdebug "import main commit\n";
1925 open C, ">../commit.tmp" or die $!;
1926 print C <<END or die $!;
1929 print C <<END or die $! foreach @tartrees;
1932 print C <<END or die $!;
1938 [dgit import $treeimporthow $package $cversion]
1942 my $rawimport_hash = make_commit qw(../commit.tmp);
1944 if (madformat $dsc->{format}) {
1945 printdebug "import apply patches...\n";
1947 # regularise the state of the working tree so that
1948 # the checkout of $rawimport_hash works nicely.
1949 my $dappliedcommit = make_commit_text(<<END);
1956 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1958 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1960 # We need the answers to be reproducible
1961 my @authline = clogp_authline($clogp);
1962 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1963 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1964 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1965 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1966 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1967 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1969 my $path = $ENV{PATH} or die;
1971 foreach my $use_absurd (qw(0 1)) {
1972 local $ENV{PATH} = $path;
1975 progress "warning: $@";
1976 $path = "$absurdity:$path";
1977 progress "$us: trying slow absurd-git-apply...";
1978 rename "../../gbp-pq-output","../../gbp-pq-output.0"
1982 local $ENV{PATH} = $path if $use_absurd;
1984 my @showcmd = (gbp_pq, qw(import));
1985 my @realcmd = shell_cmd
1986 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
1987 debugcmd "+",@realcmd;
1988 if (system @realcmd) {
1989 die +(shellquote @showcmd).
1991 failedcmd_waitstatus()."\n";
1994 my $gapplied = git_rev_parse('HEAD');
1995 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1996 $gappliedtree eq $dappliedtree or
1998 gbp-pq import and dpkg-source disagree!
1999 gbp-pq import gave commit $gapplied
2000 gbp-pq import gave tree $gappliedtree
2001 dpkg-source --before-build gave tree $dappliedtree
2003 $rawimport_hash = $gapplied;
2008 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2013 progress "synthesised git commit from .dsc $cversion";
2015 my $rawimport_mergeinput = {
2016 Commit => $rawimport_hash,
2017 Info => "Import of source package",
2019 my @output = ($rawimport_mergeinput);
2021 if ($lastpush_mergeinput) {
2022 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2023 my $oversion = getfield $oldclogp, 'Version';
2025 version_compare($oversion, $cversion);
2027 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2028 { Message => <<END, ReverseParents => 1 });
2029 Record $package ($cversion) in archive suite $csuite
2031 } elsif ($vcmp > 0) {
2032 print STDERR <<END or die $!;
2034 Version actually in archive: $cversion (older)
2035 Last version pushed with dgit: $oversion (newer or same)
2038 @output = $lastpush_mergeinput;
2040 # Same version. Use what's in the server git branch,
2041 # discarding our own import. (This could happen if the
2042 # server automatically imports all packages into git.)
2043 @output = $lastpush_mergeinput;
2046 changedir '../../../..';
2051 sub complete_file_from_dsc ($$) {
2052 our ($dstdir, $fi) = @_;
2053 # Ensures that we have, in $dir, the file $fi, with the correct
2054 # contents. (Downloading it from alongside $dscurl if necessary.)
2056 my $f = $fi->{Filename};
2057 my $tf = "$dstdir/$f";
2060 if (stat_exists $tf) {
2061 progress "using existing $f";
2064 $furl =~ s{/[^/]+$}{};
2066 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2067 die "$f ?" if $f =~ m#/#;
2068 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2069 return 0 if !act_local();
2073 open F, "<", "$tf" or die "$tf: $!";
2074 $fi->{Digester}->reset();
2075 $fi->{Digester}->addfile(*F);
2076 F->error and die $!;
2077 my $got = $fi->{Digester}->hexdigest();
2078 $got eq $fi->{Hash} or
2079 fail "file $f has hash $got but .dsc".
2080 " demands hash $fi->{Hash} ".
2081 ($downloaded ? "(got wrong file from archive!)"
2082 : "(perhaps you should delete this file?)");
2087 sub ensure_we_have_orig () {
2088 my @dfi = dsc_files_info();
2089 foreach my $fi (@dfi) {
2090 my $f = $fi->{Filename};
2091 next unless is_orig_file_in_dsc($f, \@dfi);
2092 complete_file_from_dsc('..', $fi)
2097 sub git_fetch_us () {
2098 # Want to fetch only what we are going to use, unless
2099 # deliberately-not-ff, in which case we must fetch everything.
2101 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2103 (quiltmode_splitbrain
2104 ? (map { $_->('*',access_basedistro) }
2105 \&debiantag_new, \&debiantag_maintview)
2106 : debiantags('*',access_basedistro));
2107 push @specs, server_branch($csuite);
2108 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2110 # This is rather miserable:
2111 # When git fetch --prune is passed a fetchspec ending with a *,
2112 # it does a plausible thing. If there is no * then:
2113 # - it matches subpaths too, even if the supplied refspec
2114 # starts refs, and behaves completely madly if the source
2115 # has refs/refs/something. (See, for example, Debian #NNNN.)
2116 # - if there is no matching remote ref, it bombs out the whole
2118 # We want to fetch a fixed ref, and we don't know in advance
2119 # if it exists, so this is not suitable.
2121 # Our workaround is to use git ls-remote. git ls-remote has its
2122 # own qairks. Notably, it has the absurd multi-tail-matching
2123 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2124 # refs/refs/foo etc.
2126 # Also, we want an idempotent snapshot, but we have to make two
2127 # calls to the remote: one to git ls-remote and to git fetch. The
2128 # solution is use git ls-remote to obtain a target state, and
2129 # git fetch to try to generate it. If we don't manage to generate
2130 # the target state, we try again.
2132 my $specre = join '|', map {
2138 printdebug "git_fetch_us specre=$specre\n";
2139 my $wanted_rref = sub {
2141 return m/^(?:$specre)$/o;
2144 my $fetch_iteration = 0;
2147 if (++$fetch_iteration > 10) {
2148 fail "too many iterations trying to get sane fetch!";
2151 my @look = map { "refs/$_" } @specs;
2152 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2156 open GITLS, "-|", @lcmd or die $!;
2158 printdebug "=> ", $_;
2159 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2160 my ($objid,$rrefname) = ($1,$2);
2161 if (!$wanted_rref->($rrefname)) {
2163 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2167 $wantr{$rrefname} = $objid;
2170 close GITLS or failedcmd @lcmd;
2172 # OK, now %want is exactly what we want for refs in @specs
2174 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2175 "+refs/$_:".lrfetchrefs."/$_";
2178 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2179 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2182 %lrfetchrefs_f = ();
2185 git_for_each_ref(lrfetchrefs, sub {
2186 my ($objid,$objtype,$lrefname,$reftail) = @_;
2187 $lrfetchrefs_f{$lrefname} = $objid;
2188 $objgot{$objid} = 1;
2191 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2192 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2193 if (!exists $wantr{$rrefname}) {
2194 if ($wanted_rref->($rrefname)) {
2196 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2200 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2203 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2204 delete $lrfetchrefs_f{$lrefname};
2208 foreach my $rrefname (sort keys %wantr) {
2209 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2210 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2211 my $want = $wantr{$rrefname};
2212 next if $got eq $want;
2213 if (!defined $objgot{$want}) {
2215 warning: git ls-remote suggests we want $lrefname
2216 warning: and it should refer to $want
2217 warning: but git fetch didn't fetch that object to any relevant ref.
2218 warning: This may be due to a race with someone updating the server.
2219 warning: Will try again...
2221 next FETCH_ITERATION;
2224 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2226 runcmd_ordryrun_local @git, qw(update-ref -m),
2227 "dgit fetch git fetch fixup", $lrefname, $want;
2228 $lrfetchrefs_f{$lrefname} = $want;
2232 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2233 Dumper(\%lrfetchrefs_f);
2236 my @tagpats = debiantags('*',access_basedistro);
2238 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2239 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2240 printdebug "currently $fullrefname=$objid\n";
2241 $here{$fullrefname} = $objid;
2243 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2244 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2245 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2246 printdebug "offered $lref=$objid\n";
2247 if (!defined $here{$lref}) {
2248 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2249 runcmd_ordryrun_local @upd;
2250 lrfetchref_used $fullrefname;
2251 } elsif ($here{$lref} eq $objid) {
2252 lrfetchref_used $fullrefname;
2255 "Not updateting $lref from $here{$lref} to $objid.\n";
2260 sub mergeinfo_getclogp ($) {
2261 # Ensures thit $mi->{Clogp} exists and returns it
2263 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2266 sub mergeinfo_version ($) {
2267 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2270 sub fetch_from_archive () {
2271 ensure_setup_existing_tree();
2273 # Ensures that lrref() is what is actually in the archive, one way
2274 # or another, according to us - ie this client's
2275 # appropritaely-updated archive view. Also returns the commit id.
2276 # If there is nothing in the archive, leaves lrref alone and
2277 # returns undef. git_fetch_us must have already been called.
2281 foreach my $field (@ourdscfield) {
2282 $dsc_hash = $dsc->{$field};
2283 last if defined $dsc_hash;
2285 if (defined $dsc_hash) {
2286 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2288 progress "last upload to archive specified git hash";
2290 progress "last upload to archive has NO git hash";
2293 progress "no version available from the archive";
2296 # If the archive's .dsc has a Dgit field, there are three
2297 # relevant git commitids we need to choose between and/or merge
2299 # 1. $dsc_hash: the Dgit field from the archive
2300 # 2. $lastpush_hash: the suite branch on the dgit git server
2301 # 3. $lastfetch_hash: our local tracking brach for the suite
2303 # These may all be distinct and need not be in any fast forward
2306 # If the dsc was pushed to this suite, then the server suite
2307 # branch will have been updated; but it might have been pushed to
2308 # a different suite and copied by the archive. Conversely a more
2309 # recent version may have been pushed with dgit but not appeared
2310 # in the archive (yet).
2312 # $lastfetch_hash may be awkward because archive imports
2313 # (particularly, imports of Dgit-less .dscs) are performed only as
2314 # needed on individual clients, so different clients may perform a
2315 # different subset of them - and these imports are only made
2316 # public during push. So $lastfetch_hash may represent a set of
2317 # imports different to a subsequent upload by a different dgit
2320 # Our approach is as follows:
2322 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2323 # descendant of $dsc_hash, then it was pushed by a dgit user who
2324 # had based their work on $dsc_hash, so we should prefer it.
2325 # Otherwise, $dsc_hash was installed into this suite in the
2326 # archive other than by a dgit push, and (necessarily) after the
2327 # last dgit push into that suite (since a dgit push would have
2328 # been descended from the dgit server git branch); thus, in that
2329 # case, we prefer the archive's version (and produce a
2330 # pseudo-merge to overwrite the dgit server git branch).
2332 # (If there is no Dgit field in the archive's .dsc then
2333 # generate_commit_from_dsc uses the version numbers to decide
2334 # whether the suite branch or the archive is newer. If the suite
2335 # branch is newer it ignores the archive's .dsc; otherwise it
2336 # generates an import of the .dsc, and produces a pseudo-merge to
2337 # overwrite the suite branch with the archive contents.)
2339 # The outcome of that part of the algorithm is the `public view',
2340 # and is same for all dgit clients: it does not depend on any
2341 # unpublished history in the local tracking branch.
2343 # As between the public view and the local tracking branch: The
2344 # local tracking branch is only updated by dgit fetch, and
2345 # whenever dgit fetch runs it includes the public view in the
2346 # local tracking branch. Therefore if the public view is not
2347 # descended from the local tracking branch, the local tracking
2348 # branch must contain history which was imported from the archive
2349 # but never pushed; and, its tip is now out of date. So, we make
2350 # a pseudo-merge to overwrite the old imports and stitch the old
2353 # Finally: we do not necessarily reify the public view (as
2354 # described above). This is so that we do not end up stacking two
2355 # pseudo-merges. So what we actually do is figure out the inputs
2356 # to any public view pseudo-merge and put them in @mergeinputs.
2359 # $mergeinputs[]{Commit}
2360 # $mergeinputs[]{Info}
2361 # $mergeinputs[0] is the one whose tree we use
2362 # @mergeinputs is in the order we use in the actual commit)
2365 # $mergeinputs[]{Message} is a commit message to use
2366 # $mergeinputs[]{ReverseParents} if def specifies that parent
2367 # list should be in opposite order
2368 # Such an entry has no Commit or Info. It applies only when found
2369 # in the last entry. (This ugliness is to support making
2370 # identical imports to previous dgit versions.)
2372 my $lastpush_hash = git_get_ref(lrfetchref());
2373 printdebug "previous reference hash=$lastpush_hash\n";
2374 $lastpush_mergeinput = $lastpush_hash && {
2375 Commit => $lastpush_hash,
2376 Info => "dgit suite branch on dgit git server",
2379 my $lastfetch_hash = git_get_ref(lrref());
2380 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2381 my $lastfetch_mergeinput = $lastfetch_hash && {
2382 Commit => $lastfetch_hash,
2383 Info => "dgit client's archive history view",
2386 my $dsc_mergeinput = $dsc_hash && {
2387 Commit => $dsc_hash,
2388 Info => "Dgit field in .dsc from archive",
2392 my $del_lrfetchrefs = sub {
2395 printdebug "del_lrfetchrefs...\n";
2396 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2397 my $objid = $lrfetchrefs_d{$fullrefname};
2398 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2400 $gur ||= new IO::Handle;
2401 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2403 printf $gur "delete %s %s\n", $fullrefname, $objid;
2406 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2410 if (defined $dsc_hash) {
2411 fail "missing remote git history even though dsc has hash -".
2412 " could not find ref ".rref()." at ".access_giturl()
2413 unless $lastpush_hash;
2414 ensure_we_have_orig();
2415 if ($dsc_hash eq $lastpush_hash) {
2416 @mergeinputs = $dsc_mergeinput
2417 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2418 print STDERR <<END or die $!;
2420 Git commit in archive is behind the last version allegedly pushed/uploaded.
2421 Commit referred to by archive: $dsc_hash
2422 Last version pushed with dgit: $lastpush_hash
2425 @mergeinputs = ($lastpush_mergeinput);
2427 # Archive has .dsc which is not a descendant of the last dgit
2428 # push. This can happen if the archive moves .dscs about.
2429 # Just follow its lead.
2430 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2431 progress "archive .dsc names newer git commit";
2432 @mergeinputs = ($dsc_mergeinput);
2434 progress "archive .dsc names other git commit, fixing up";
2435 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2439 @mergeinputs = generate_commits_from_dsc();
2440 # We have just done an import. Now, our import algorithm might
2441 # have been improved. But even so we do not want to generate
2442 # a new different import of the same package. So if the
2443 # version numbers are the same, just use our existing version.
2444 # If the version numbers are different, the archive has changed
2445 # (perhaps, rewound).
2446 if ($lastfetch_mergeinput &&
2447 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2448 (mergeinfo_version $mergeinputs[0]) )) {
2449 @mergeinputs = ($lastfetch_mergeinput);
2451 } elsif ($lastpush_hash) {
2452 # only in git, not in the archive yet
2453 @mergeinputs = ($lastpush_mergeinput);
2454 print STDERR <<END or die $!;
2456 Package not found in the archive, but has allegedly been pushed using dgit.
2460 printdebug "nothing found!\n";
2461 if (defined $skew_warning_vsn) {
2462 print STDERR <<END or die $!;
2464 Warning: relevant archive skew detected.
2465 Archive allegedly contains $skew_warning_vsn
2466 But we were not able to obtain any version from the archive or git.
2470 unshift @end, $del_lrfetchrefs;
2474 if ($lastfetch_hash &&
2476 my $h = $_->{Commit};
2477 $h and is_fast_fwd($lastfetch_hash, $h);
2478 # If true, one of the existing parents of this commit
2479 # is a descendant of the $lastfetch_hash, so we'll
2480 # be ff from that automatically.
2484 push @mergeinputs, $lastfetch_mergeinput;
2487 printdebug "fetch mergeinfos:\n";
2488 foreach my $mi (@mergeinputs) {
2490 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2492 printdebug sprintf " ReverseParents=%d Message=%s",
2493 $mi->{ReverseParents}, $mi->{Message};
2497 my $compat_info= pop @mergeinputs
2498 if $mergeinputs[$#mergeinputs]{Message};
2500 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2503 if (@mergeinputs > 1) {
2505 my $tree_commit = $mergeinputs[0]{Commit};
2507 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2508 $tree =~ m/\n\n/; $tree = $`;
2509 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2512 # We use the changelog author of the package in question the
2513 # author of this pseudo-merge. This is (roughly) correct if
2514 # this commit is simply representing aa non-dgit upload.
2515 # (Roughly because it does not record sponsorship - but we
2516 # don't have sponsorship info because that's in the .changes,
2517 # which isn't in the archivw.)
2519 # But, it might be that we are representing archive history
2520 # updates (including in-archive copies). These are not really
2521 # the responsibility of the person who created the .dsc, but
2522 # there is no-one whose name we should better use. (The
2523 # author of the .dsc-named commit is clearly worse.)
2525 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2526 my $author = clogp_authline $useclogp;
2527 my $cversion = getfield $useclogp, 'Version';
2529 my $mcf = ".git/dgit/mergecommit";
2530 open MC, ">", $mcf or die "$mcf $!";
2531 print MC <<END or die $!;
2535 my @parents = grep { $_->{Commit} } @mergeinputs;
2536 @parents = reverse @parents if $compat_info->{ReverseParents};
2537 print MC <<END or die $! foreach @parents;
2541 print MC <<END or die $!;
2547 if (defined $compat_info->{Message}) {
2548 print MC $compat_info->{Message} or die $!;
2550 print MC <<END or die $!;
2551 Record $package ($cversion) in archive suite $csuite
2555 my $message_add_info = sub {
2557 my $mversion = mergeinfo_version $mi;
2558 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2562 $message_add_info->($mergeinputs[0]);
2563 print MC <<END or die $!;
2564 should be treated as descended from
2566 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2570 $hash = make_commit $mcf;
2572 $hash = $mergeinputs[0]{Commit};
2574 printdebug "fetch hash=$hash\n";
2577 my ($lasth, $what) = @_;
2578 return unless $lasth;
2579 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2582 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2583 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2585 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2586 'DGIT_ARCHIVE', $hash;
2587 cmdoutput @git, qw(log -n2), $hash;
2588 # ... gives git a chance to complain if our commit is malformed
2590 if (defined $skew_warning_vsn) {
2592 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2593 my $gotclogp = commit_getclogp($hash);
2594 my $got_vsn = getfield $gotclogp, 'Version';
2595 printdebug "SKEW CHECK GOT $got_vsn\n";
2596 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2597 print STDERR <<END or die $!;
2599 Warning: archive skew detected. Using the available version:
2600 Archive allegedly contains $skew_warning_vsn
2601 We were able to obtain only $got_vsn
2607 if ($lastfetch_hash ne $hash) {
2608 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2612 dryrun_report @upd_cmd;
2616 lrfetchref_used lrfetchref();
2618 unshift @end, $del_lrfetchrefs;
2622 sub set_local_git_config ($$) {
2624 runcmd @git, qw(config), $k, $v;
2627 sub setup_mergechangelogs (;$) {
2629 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2631 my $driver = 'dpkg-mergechangelogs';
2632 my $cb = "merge.$driver";
2633 my $attrs = '.git/info/attributes';
2634 ensuredir '.git/info';
2636 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2637 if (!open ATTRS, "<", $attrs) {
2638 $!==ENOENT or die "$attrs: $!";
2642 next if m{^debian/changelog\s};
2643 print NATTRS $_, "\n" or die $!;
2645 ATTRS->error and die $!;
2648 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2651 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2652 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2654 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2657 sub setup_useremail (;$) {
2659 return unless $always || access_cfg_bool(1, 'setup-useremail');
2662 my ($k, $envvar) = @_;
2663 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2664 return unless defined $v;
2665 set_local_git_config "user.$k", $v;
2668 $setup->('email', 'DEBEMAIL');
2669 $setup->('name', 'DEBFULLNAME');
2672 sub ensure_setup_existing_tree () {
2673 my $k = "remote.$remotename.skipdefaultupdate";
2674 my $c = git_get_config $k;
2675 return if defined $c;
2676 set_local_git_config $k, 'true';
2679 sub setup_new_tree () {
2680 setup_mergechangelogs();
2686 canonicalise_suite();
2687 badusage "dry run makes no sense with clone" unless act_local();
2688 my $hasgit = check_for_git();
2689 mkdir $dstdir or fail "create \`$dstdir': $!";
2691 runcmd @git, qw(init -q);
2692 my $giturl = access_giturl(1);
2693 if (defined $giturl) {
2694 open H, "> .git/HEAD" or die $!;
2695 print H "ref: ".lref()."\n" or die $!;
2697 runcmd @git, qw(remote add), 'origin', $giturl;
2700 progress "fetching existing git history";
2702 runcmd_ordryrun_local @git, qw(fetch origin);
2704 progress "starting new git history";
2706 fetch_from_archive() or no_such_package;
2707 my $vcsgiturl = $dsc->{'Vcs-Git'};
2708 if (length $vcsgiturl) {
2709 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2710 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2713 runcmd @git, qw(reset --hard), lrref();
2714 printdone "ready for work in $dstdir";
2718 if (check_for_git()) {
2721 fetch_from_archive() or no_such_package();
2722 printdone "fetched into ".lrref();
2727 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2729 printdone "fetched to ".lrref()." and merged into HEAD";
2732 sub check_not_dirty () {
2733 foreach my $f (qw(local-options local-patch-header)) {
2734 if (stat_exists "debian/source/$f") {
2735 fail "git tree contains debian/source/$f";
2739 return if $ignoredirty;
2741 my @cmd = (@git, qw(diff --quiet HEAD));
2743 $!=0; $?=-1; system @cmd;
2746 fail "working tree is dirty (does not match HEAD)";
2752 sub commit_admin ($) {
2755 runcmd_ordryrun_local @git, qw(commit -m), $m;
2758 sub commit_quilty_patch () {
2759 my $output = cmdoutput @git, qw(status --porcelain);
2761 foreach my $l (split /\n/, $output) {
2762 next unless $l =~ m/\S/;
2763 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2767 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2769 progress "nothing quilty to commit, ok.";
2772 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2773 runcmd_ordryrun_local @git, qw(add -f), @adds;
2775 Commit Debian 3.0 (quilt) metadata
2777 [dgit ($our_version) quilt-fixup]
2781 sub get_source_format () {
2783 if (open F, "debian/source/options") {
2787 s/\s+$//; # ignore missing final newline
2789 my ($k, $v) = ($`, $'); #');
2790 $v =~ s/^"(.*)"$/$1/;
2796 F->error and die $!;
2799 die $! unless $!==&ENOENT;
2802 if (!open F, "debian/source/format") {
2803 die $! unless $!==&ENOENT;
2807 F->error and die $!;
2809 return ($_, \%options);
2812 sub madformat_wantfixup ($) {
2814 return 0 unless $format eq '3.0 (quilt)';
2815 our $quilt_mode_warned;
2816 if ($quilt_mode eq 'nocheck') {
2817 progress "Not doing any fixup of \`$format' due to".
2818 " ----no-quilt-fixup or --quilt=nocheck"
2819 unless $quilt_mode_warned++;
2822 progress "Format \`$format', need to check/update patch stack"
2823 unless $quilt_mode_warned++;
2827 # An "infopair" is a tuple [ $thing, $what ]
2828 # (often $thing is a commit hash; $what is a description)
2830 sub infopair_cond_equal ($$) {
2832 $x->[0] eq $y->[0] or fail <<END;
2833 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2837 sub infopair_lrf_tag_lookup ($$) {
2838 my ($tagnames, $what) = @_;
2839 # $tagname may be an array ref
2840 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2841 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2842 foreach my $tagname (@tagnames) {
2843 my $lrefname = lrfetchrefs."/tags/$tagname";
2844 my $tagobj = $lrfetchrefs_f{$lrefname};
2845 next unless defined $tagobj;
2846 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2847 return [ git_rev_parse($tagobj), $what ];
2849 fail @tagnames==1 ? <<END : <<END;
2850 Wanted tag $what (@tagnames) on dgit server, but not found
2852 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2856 sub infopair_cond_ff ($$) {
2857 my ($anc,$desc) = @_;
2858 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2859 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2863 sub pseudomerge_version_check ($$) {
2864 my ($clogp, $archive_hash) = @_;
2866 my $arch_clogp = commit_getclogp $archive_hash;
2867 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2868 'version currently in archive' ];
2869 if (defined $overwrite_version) {
2870 if (length $overwrite_version) {
2871 infopair_cond_equal([ $overwrite_version,
2872 '--overwrite= version' ],
2875 my $v = $i_arch_v->[0];
2876 progress "Checking package changelog for archive version $v ...";
2878 my @xa = ("-f$v", "-t$v");
2879 my $vclogp = parsechangelog @xa;
2880 my $cv = [ (getfield $vclogp, 'Version'),
2881 "Version field from dpkg-parsechangelog @xa" ];
2882 infopair_cond_equal($i_arch_v, $cv);
2885 $@ =~ s/^dgit: //gm;
2887 "Perhaps debian/changelog does not mention $v ?";
2892 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2896 sub pseudomerge_make_commit ($$$$ $$) {
2897 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2898 $msg_cmd, $msg_msg) = @_;
2899 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2901 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2902 my $authline = clogp_authline $clogp;
2906 !defined $overwrite_version ? ""
2907 : !length $overwrite_version ? " --overwrite"
2908 : " --overwrite=".$overwrite_version;
2911 my $pmf = ".git/dgit/pseudomerge";
2912 open MC, ">", $pmf or die "$pmf $!";
2913 print MC <<END or die $!;
2916 parent $archive_hash
2926 return make_commit($pmf);
2929 sub splitbrain_pseudomerge ($$$$) {
2930 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2931 # => $merged_dgitview
2932 printdebug "splitbrain_pseudomerge...\n";
2934 # We: debian/PREVIOUS HEAD($maintview)
2935 # expect: o ----------------- o
2938 # a/d/PREVIOUS $dgitview
2941 # we do: `------------------ o
2945 printdebug "splitbrain_pseudomerge...\n";
2947 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2949 return $dgitview unless defined $archive_hash;
2951 if (!defined $overwrite_version) {
2952 progress "Checking that HEAD inciudes all changes in archive...";
2955 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2957 if (defined $overwrite_version) {
2959 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2960 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2961 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2962 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2963 my $i_archive = [ $archive_hash, "current archive contents" ];
2965 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2967 infopair_cond_equal($i_dgit, $i_archive);
2968 infopair_cond_ff($i_dep14, $i_dgit);
2969 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2973 $us: check failed (maybe --overwrite is needed, consult documentation)
2978 my $r = pseudomerge_make_commit
2979 $clogp, $dgitview, $archive_hash, $i_arch_v,
2980 "dgit --quilt=$quilt_mode",
2981 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2982 Declare fast forward from $i_arch_v->[0]
2984 Make fast forward from $i_arch_v->[0]
2987 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2991 sub plain_overwrite_pseudomerge ($$$) {
2992 my ($clogp, $head, $archive_hash) = @_;
2994 printdebug "plain_overwrite_pseudomerge...";
2996 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2998 return $head if is_fast_fwd $archive_hash, $head;
3000 my $m = "Declare fast forward from $i_arch_v->[0]";
3002 my $r = pseudomerge_make_commit
3003 $clogp, $head, $archive_hash, $i_arch_v,
3006 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3008 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3012 sub push_parse_changelog ($) {
3015 my $clogp = Dpkg::Control::Hash->new();
3016 $clogp->load($clogpfn) or die;
3018 $package = getfield $clogp, 'Source';
3019 my $cversion = getfield $clogp, 'Version';
3020 my $tag = debiantag($cversion, access_basedistro);
3021 runcmd @git, qw(check-ref-format), $tag;
3023 my $dscfn = dscfn($cversion);
3025 return ($clogp, $cversion, $dscfn);
3028 sub push_parse_dsc ($$$) {
3029 my ($dscfn,$dscfnwhat, $cversion) = @_;
3030 $dsc = parsecontrol($dscfn,$dscfnwhat);
3031 my $dversion = getfield $dsc, 'Version';
3032 my $dscpackage = getfield $dsc, 'Source';
3033 ($dscpackage eq $package && $dversion eq $cversion) or
3034 fail "$dscfn is for $dscpackage $dversion".
3035 " but debian/changelog is for $package $cversion";
3038 sub push_tagwants ($$$$) {
3039 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3042 TagFn => \&debiantag,
3047 if (defined $maintviewhead) {
3049 TagFn => \&debiantag_maintview,
3050 Objid => $maintviewhead,
3051 TfSuffix => '-maintview',
3055 foreach my $tw (@tagwants) {
3056 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3057 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3059 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3063 sub push_mktags ($$ $$ $) {
3065 $changesfile,$changesfilewhat,
3068 die unless $tagwants->[0]{View} eq 'dgit';
3070 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3071 $dsc->save("$dscfn.tmp") or die $!;
3073 my $changes = parsecontrol($changesfile,$changesfilewhat);
3074 foreach my $field (qw(Source Distribution Version)) {
3075 $changes->{$field} eq $clogp->{$field} or
3076 fail "changes field $field \`$changes->{$field}'".
3077 " does not match changelog \`$clogp->{$field}'";
3080 my $cversion = getfield $clogp, 'Version';
3081 my $clogsuite = getfield $clogp, 'Distribution';
3083 # We make the git tag by hand because (a) that makes it easier
3084 # to control the "tagger" (b) we can do remote signing
3085 my $authline = clogp_authline $clogp;
3086 my $delibs = join(" ", "",@deliberatelies);
3087 my $declaredistro = access_basedistro();
3091 my $tfn = $tw->{Tfn};
3092 my $head = $tw->{Objid};
3093 my $tag = $tw->{Tag};
3095 open TO, '>', $tfn->('.tmp') or die $!;
3096 print TO <<END or die $!;
3103 if ($tw->{View} eq 'dgit') {
3104 print TO <<END or die $!;
3105 $package release $cversion for $clogsuite ($csuite) [dgit]
3106 [dgit distro=$declaredistro$delibs]
3108 foreach my $ref (sort keys %previously) {
3109 print TO <<END or die $!;
3110 [dgit previously:$ref=$previously{$ref}]
3113 } elsif ($tw->{View} eq 'maint') {
3114 print TO <<END or die $!;
3115 $package release $cversion for $clogsuite ($csuite)
3116 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3119 die Dumper($tw)."?";
3124 my $tagobjfn = $tfn->('.tmp');
3126 if (!defined $keyid) {
3127 $keyid = access_cfg('keyid','RETURN-UNDEF');
3129 if (!defined $keyid) {
3130 $keyid = getfield $clogp, 'Maintainer';
3132 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3133 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3134 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3135 push @sign_cmd, $tfn->('.tmp');
3136 runcmd_ordryrun @sign_cmd;
3138 $tagobjfn = $tfn->('.signed.tmp');
3139 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3140 $tfn->('.tmp'), $tfn->('.tmp.asc');
3146 my @r = map { $mktag->($_); } @$tagwants;
3150 sub sign_changes ($) {
3151 my ($changesfile) = @_;
3153 my @debsign_cmd = @debsign;
3154 push @debsign_cmd, "-k$keyid" if defined $keyid;
3155 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3156 push @debsign_cmd, $changesfile;
3157 runcmd_ordryrun @debsign_cmd;
3162 printdebug "actually entering push\n";
3164 supplementary_message(<<'END');
3165 Push failed, while checking state of the archive.
3166 You can retry the push, after fixing the problem, if you like.
3168 if (check_for_git()) {
3171 my $archive_hash = fetch_from_archive();
3172 if (!$archive_hash) {
3174 fail "package appears to be new in this suite;".
3175 " if this is intentional, use --new";
3178 supplementary_message(<<'END');
3179 Push failed, while preparing your push.
3180 You can retry the push, after fixing the problem, if you like.
3183 need_tagformat 'new', "quilt mode $quilt_mode"
3184 if quiltmode_splitbrain;
3188 access_giturl(); # check that success is vaguely likely
3191 my $clogpfn = ".git/dgit/changelog.822.tmp";
3192 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3194 responder_send_file('parsed-changelog', $clogpfn);
3196 my ($clogp, $cversion, $dscfn) =
3197 push_parse_changelog("$clogpfn");
3199 my $dscpath = "$buildproductsdir/$dscfn";
3200 stat_exists $dscpath or
3201 fail "looked for .dsc $dscfn, but $!;".
3202 " maybe you forgot to build";
3204 responder_send_file('dsc', $dscpath);
3206 push_parse_dsc($dscpath, $dscfn, $cversion);
3208 my $format = getfield $dsc, 'Format';
3209 printdebug "format $format\n";
3211 my $actualhead = git_rev_parse('HEAD');
3212 my $dgithead = $actualhead;
3213 my $maintviewhead = undef;
3215 if (madformat_wantfixup($format)) {
3216 # user might have not used dgit build, so maybe do this now:
3217 if (quiltmode_splitbrain()) {
3218 my $upstreamversion = $clogp->{Version};
3219 $upstreamversion =~ s/-[^-]*$//;
3221 quilt_make_fake_dsc($upstreamversion);
3223 ($dgithead, $cachekey) =
3224 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3226 "--quilt=$quilt_mode but no cached dgit view:
3227 perhaps tree changed since dgit build[-source] ?";
3229 $dgithead = splitbrain_pseudomerge($clogp,
3230 $actualhead, $dgithead,
3232 $maintviewhead = $actualhead;
3233 changedir '../../../..';
3234 prep_ud(); # so _only_subdir() works, below
3236 commit_quilty_patch();
3240 if (defined $overwrite_version && !defined $maintviewhead) {
3241 $dgithead = plain_overwrite_pseudomerge($clogp,
3249 if ($archive_hash) {
3250 if (is_fast_fwd($archive_hash, $dgithead)) {
3252 } elsif (deliberately_not_fast_forward) {
3255 fail "dgit push: HEAD is not a descendant".
3256 " of the archive's version.\n".
3257 "To overwrite the archive's contents,".
3258 " pass --overwrite[=VERSION].\n".
3259 "To rewind history, if permitted by the archive,".
3260 " use --deliberately-not-fast-forward.";
3265 progress "checking that $dscfn corresponds to HEAD";
3266 runcmd qw(dpkg-source -x --),
3267 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3268 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3269 check_for_vendor_patches() if madformat($dsc->{format});
3270 changedir '../../../..';
3271 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3272 debugcmd "+",@diffcmd;
3274 my $r = system @diffcmd;
3277 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3279 HEAD specifies a different tree to $dscfn:
3281 Perhaps you forgot to build. Or perhaps there is a problem with your
3282 source tree (see dgit(7) for some hints). To see a full diff, run
3289 if (!$changesfile) {
3290 my $pat = changespat $cversion;
3291 my @cs = glob "$buildproductsdir/$pat";
3292 fail "failed to find unique changes file".
3293 " (looked for $pat in $buildproductsdir);".
3294 " perhaps you need to use dgit -C"
3296 ($changesfile) = @cs;
3298 $changesfile = "$buildproductsdir/$changesfile";
3301 # Check that changes and .dsc agree enough
3302 $changesfile =~ m{[^/]*$};
3303 files_compare_inputs($dsc, parsecontrol($changesfile,$&))
3304 unless forceing [qw(dsc-changes-mismatch)];
3306 # Checks complete, we're going to try and go ahead:
3308 responder_send_file('changes',$changesfile);
3309 responder_send_command("param head $dgithead");
3310 responder_send_command("param csuite $csuite");
3311 responder_send_command("param tagformat $tagformat");
3312 if (defined $maintviewhead) {
3313 die unless ($protovsn//4) >= 4;
3314 responder_send_command("param maint-view $maintviewhead");
3317 if (deliberately_not_fast_forward) {
3318 git_for_each_ref(lrfetchrefs, sub {
3319 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3320 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3321 responder_send_command("previously $rrefname=$objid");
3322 $previously{$rrefname} = $objid;
3326 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3330 supplementary_message(<<'END');
3331 Push failed, while signing the tag.
3332 You can retry the push, after fixing the problem, if you like.
3334 # If we manage to sign but fail to record it anywhere, it's fine.
3335 if ($we_are_responder) {
3336 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3337 responder_receive_files('signed-tag', @tagobjfns);
3339 @tagobjfns = push_mktags($clogp,$dscpath,
3340 $changesfile,$changesfile,
3343 supplementary_message(<<'END');
3344 Push failed, *after* signing the tag.
3345 If you want to try again, you should use a new version number.
3348 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3350 foreach my $tw (@tagwants) {
3351 my $tag = $tw->{Tag};
3352 my $tagobjfn = $tw->{TagObjFn};
3354 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3355 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3356 runcmd_ordryrun_local
3357 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3360 supplementary_message(<<'END');
3361 Push failed, while updating the remote git repository - see messages above.
3362 If you want to try again, you should use a new version number.
3364 if (!check_for_git()) {
3365 create_remote_git_repo();
3368 my @pushrefs = $forceflag.$dgithead.":".rrref();
3369 foreach my $tw (@tagwants) {
3370 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3373 runcmd_ordryrun @git,
3374 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3375 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3377 supplementary_message(<<'END');
3378 Push failed, after updating the remote git repository.
3379 If you want to try again, you must use a new version number.
3381 if ($we_are_responder) {
3382 my $dryrunsuffix = act_local() ? "" : ".tmp";
3383 responder_receive_files('signed-dsc-changes',
3384 "$dscpath$dryrunsuffix",
3385 "$changesfile$dryrunsuffix");
3388 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3390 progress "[new .dsc left in $dscpath.tmp]";
3392 sign_changes $changesfile;
3395 supplementary_message(<<END);
3396 Push failed, while uploading package(s) to the archive server.
3397 You can retry the upload of exactly these same files with dput of:
3399 If that .changes file is broken, you will need to use a new version
3400 number for your next attempt at the upload.
3402 my $host = access_cfg('upload-host','RETURN-UNDEF');
3403 my @hostarg = defined($host) ? ($host,) : ();
3404 runcmd_ordryrun @dput, @hostarg, $changesfile;
3405 printdone "pushed and uploaded $cversion";
3407 supplementary_message('');
3408 responder_send_command("complete");
3415 badusage "-p is not allowed with clone; specify as argument instead"
3416 if defined $package;
3419 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3420 ($package,$isuite) = @ARGV;
3421 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3422 ($package,$dstdir) = @ARGV;
3423 } elsif (@ARGV==3) {
3424 ($package,$isuite,$dstdir) = @ARGV;
3426 badusage "incorrect arguments to dgit clone";
3428 $dstdir ||= "$package";
3430 if (stat_exists $dstdir) {
3431 fail "$dstdir already exists";
3435 if ($rmonerror && !$dryrun_level) {
3436 $cwd_remove= getcwd();
3438 return unless defined $cwd_remove;
3439 if (!chdir "$cwd_remove") {
3440 return if $!==&ENOENT;
3441 die "chdir $cwd_remove: $!";
3444 rmtree($dstdir) or die "remove $dstdir: $!\n";
3445 } elsif (grep { $! == $_ }
3446 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3448 print STDERR "check whether to remove $dstdir: $!\n";
3454 $cwd_remove = undef;
3457 sub branchsuite () {
3458 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3459 if ($branch =~ m#$lbranch_re#o) {
3466 sub fetchpullargs () {
3468 if (!defined $package) {
3469 my $sourcep = parsecontrol('debian/control','debian/control');
3470 $package = getfield $sourcep, 'Source';
3473 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3475 my $clogp = parsechangelog();
3476 $isuite = getfield $clogp, 'Distribution';
3478 canonicalise_suite();
3479 progress "fetching from suite $csuite";
3480 } elsif (@ARGV==1) {
3482 canonicalise_suite();
3484 badusage "incorrect arguments to dgit fetch or dgit pull";
3503 badusage "-p is not allowed with dgit push" if defined $package;
3505 my $clogp = parsechangelog();
3506 $package = getfield $clogp, 'Source';
3509 } elsif (@ARGV==1) {
3510 ($specsuite) = (@ARGV);
3512 badusage "incorrect arguments to dgit push";
3514 $isuite = getfield $clogp, 'Distribution';
3516 local ($package) = $existing_package; # this is a hack
3517 canonicalise_suite();
3519 canonicalise_suite();
3521 if (defined $specsuite &&
3522 $specsuite ne $isuite &&
3523 $specsuite ne $csuite) {
3524 fail "dgit push: changelog specifies $isuite ($csuite)".
3525 " but command line specifies $specsuite";
3530 #---------- remote commands' implementation ----------
3532 sub cmd_remote_push_build_host {
3533 my ($nrargs) = shift @ARGV;
3534 my (@rargs) = @ARGV[0..$nrargs-1];
3535 @ARGV = @ARGV[$nrargs..$#ARGV];
3537 my ($dir,$vsnwant) = @rargs;
3538 # vsnwant is a comma-separated list; we report which we have
3539 # chosen in our ready response (so other end can tell if they
3542 $we_are_responder = 1;
3543 $us .= " (build host)";
3547 open PI, "<&STDIN" or die $!;
3548 open STDIN, "/dev/null" or die $!;
3549 open PO, ">&STDOUT" or die $!;
3551 open STDOUT, ">&STDERR" or die $!;
3555 ($protovsn) = grep {
3556 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3557 } @rpushprotovsn_support;
3559 fail "build host has dgit rpush protocol versions ".
3560 (join ",", @rpushprotovsn_support).
3561 " but invocation host has $vsnwant"
3562 unless defined $protovsn;
3564 responder_send_command("dgit-remote-push-ready $protovsn");
3565 rpush_handle_protovsn_bothends();
3570 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3571 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3572 # a good error message)
3574 sub rpush_handle_protovsn_bothends () {
3575 if ($protovsn < 4) {
3576 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3585 my $report = i_child_report();
3586 if (defined $report) {
3587 printdebug "($report)\n";
3588 } elsif ($i_child_pid) {
3589 printdebug "(killing build host child $i_child_pid)\n";
3590 kill 15, $i_child_pid;
3592 if (defined $i_tmp && !defined $initiator_tempdir) {
3594 eval { rmtree $i_tmp; };
3598 END { i_cleanup(); }
3601 my ($base,$selector,@args) = @_;
3602 $selector =~ s/\-/_/g;
3603 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3610 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3618 push @rargs, join ",", @rpushprotovsn_support;
3621 push @rdgit, @ropts;
3622 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3624 my @cmd = (@ssh, $host, shellquote @rdgit);
3627 if (defined $initiator_tempdir) {
3628 rmtree $initiator_tempdir;
3629 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3630 $i_tmp = $initiator_tempdir;
3634 $i_child_pid = open2(\*RO, \*RI, @cmd);
3636 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3637 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3638 $supplementary_message = '' unless $protovsn >= 3;
3640 fail "rpush negotiated protocol version $protovsn".
3641 " which does not support quilt mode $quilt_mode"
3642 if quiltmode_splitbrain;
3644 rpush_handle_protovsn_bothends();
3646 my ($icmd,$iargs) = initiator_expect {
3647 m/^(\S+)(?: (.*))?$/;
3650 i_method "i_resp", $icmd, $iargs;
3654 sub i_resp_progress ($) {
3656 my $msg = protocol_read_bytes \*RO, $rhs;
3660 sub i_resp_supplementary_message ($) {
3662 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3665 sub i_resp_complete {
3666 my $pid = $i_child_pid;
3667 $i_child_pid = undef; # prevents killing some other process with same pid
3668 printdebug "waiting for build host child $pid...\n";
3669 my $got = waitpid $pid, 0;
3670 die $! unless $got == $pid;
3671 die "build host child failed $?" if $?;
3674 printdebug "all done\n";
3678 sub i_resp_file ($) {
3680 my $localname = i_method "i_localname", $keyword;
3681 my $localpath = "$i_tmp/$localname";
3682 stat_exists $localpath and
3683 badproto \*RO, "file $keyword ($localpath) twice";
3684 protocol_receive_file \*RO, $localpath;
3685 i_method "i_file", $keyword;
3690 sub i_resp_param ($) {
3691 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3695 sub i_resp_previously ($) {
3696 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3697 or badproto \*RO, "bad previously spec";
3698 my $r = system qw(git check-ref-format), $1;
3699 die "bad previously ref spec ($r)" if $r;
3700 $previously{$1} = $2;
3705 sub i_resp_want ($) {
3707 die "$keyword ?" if $i_wanted{$keyword}++;
3708 my @localpaths = i_method "i_want", $keyword;
3709 printdebug "[[ $keyword @localpaths\n";
3710 foreach my $localpath (@localpaths) {
3711 protocol_send_file \*RI, $localpath;
3713 print RI "files-end\n" or die $!;
3716 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3718 sub i_localname_parsed_changelog {
3719 return "remote-changelog.822";
3721 sub i_file_parsed_changelog {
3722 ($i_clogp, $i_version, $i_dscfn) =
3723 push_parse_changelog "$i_tmp/remote-changelog.822";
3724 die if $i_dscfn =~ m#/|^\W#;
3727 sub i_localname_dsc {
3728 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3733 sub i_localname_changes {
3734 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3735 $i_changesfn = $i_dscfn;
3736 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3737 return $i_changesfn;
3739 sub i_file_changes { }
3741 sub i_want_signed_tag {
3742 printdebug Dumper(\%i_param, $i_dscfn);
3743 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3744 && defined $i_param{'csuite'}
3745 or badproto \*RO, "premature desire for signed-tag";
3746 my $head = $i_param{'head'};
3747 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3749 my $maintview = $i_param{'maint-view'};
3750 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3753 if ($protovsn >= 4) {
3754 my $p = $i_param{'tagformat'} // '<undef>';
3756 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3759 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3761 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3763 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3766 push_mktags $i_clogp, $i_dscfn,
3767 $i_changesfn, 'remote changes',
3771 sub i_want_signed_dsc_changes {
3772 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3773 sign_changes $i_changesfn;
3774 return ($i_dscfn, $i_changesfn);
3777 #---------- building etc. ----------
3783 #----- `3.0 (quilt)' handling -----
3785 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3787 sub quiltify_dpkg_commit ($$$;$) {
3788 my ($patchname,$author,$msg, $xinfo) = @_;
3792 my $descfn = ".git/dgit/quilt-description.tmp";
3793 open O, '>', $descfn or die "$descfn: $!";
3794 $msg =~ s/\n+/\n\n/;
3795 print O <<END or die $!;
3797 ${xinfo}Subject: $msg
3804 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3805 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3806 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3807 runcmd @dpkgsource, qw(--commit .), $patchname;
3811 sub quiltify_trees_differ ($$;$$$) {
3812 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3813 # returns true iff the two tree objects differ other than in debian/
3814 # with $finegrained,
3815 # returns bitmask 01 - differ in upstream files except .gitignore
3816 # 02 - differ in .gitignore
3817 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3818 # is set for each modified .gitignore filename $fn
3819 # if $unrepres is defined, array ref to which is appeneded
3820 # a list of unrepresentable changes (removals of upstream files
3823 my @cmd = (@git, qw(diff-tree -z));
3824 push @cmd, qw(--name-only) unless $unrepres;
3825 push @cmd, qw(-r) if $finegrained || $unrepres;
3827 my $diffs= cmdoutput @cmd;
3830 foreach my $f (split /\0/, $diffs) {
3831 if ($unrepres && !@lmodes) {
3832 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3835 my ($oldmode,$newmode) = @lmodes;
3838 next if $f =~ m#^debian(?:/.*)?$#s;
3842 die "deleted\n" unless $newmode =~ m/[^0]/;
3843 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3844 if ($oldmode =~ m/[^0]/) {
3845 die "mode changed\n" if $oldmode ne $newmode;
3847 die "non-default mode\n" unless $newmode =~ m/^100644$/;
3851 local $/="\n"; chomp $@;
3852 push @$unrepres, [ $f, $@ ];
3856 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3857 $r |= $isignore ? 02 : 01;
3858 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3860 printdebug "quiltify_trees_differ $x $y => $r\n";
3864 sub quiltify_tree_sentinelfiles ($) {
3865 # lists the `sentinel' files present in the tree
3867 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3868 qw(-- debian/rules debian/control);
3873 sub quiltify_splitbrain_needed () {
3874 if (!$split_brain) {
3875 progress "dgit view: changes are required...";
3876 runcmd @git, qw(checkout -q -b dgit-view);
3881 sub quiltify_splitbrain ($$$$$$) {
3882 my ($clogp, $unapplied, $headref, $diffbits,
3883 $editedignores, $cachekey) = @_;
3884 if ($quilt_mode !~ m/gbp|dpm/) {
3885 # treat .gitignore just like any other upstream file
3886 $diffbits = { %$diffbits };
3887 $_ = !!$_ foreach values %$diffbits;
3889 # We would like any commits we generate to be reproducible
3890 my @authline = clogp_authline($clogp);
3891 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3892 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3893 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3894 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3895 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3896 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3898 if ($quilt_mode =~ m/gbp|unapplied/ &&
3899 ($diffbits->{O2H} & 01)) {
3901 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3902 " but git tree differs from orig in upstream files.";
3903 if (!stat_exists "debian/patches") {
3905 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3909 if ($quilt_mode =~ m/dpm/ &&
3910 ($diffbits->{H2A} & 01)) {
3912 --quilt=$quilt_mode specified, implying patches-applied git tree
3913 but git tree differs from result of applying debian/patches to upstream
3916 if ($quilt_mode =~ m/gbp|unapplied/ &&
3917 ($diffbits->{O2A} & 01)) { # some patches
3918 quiltify_splitbrain_needed();
3919 progress "dgit view: creating patches-applied version using gbp pq";
3920 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3921 # gbp pq import creates a fresh branch; push back to dgit-view
3922 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3923 runcmd @git, qw(checkout -q dgit-view);
3925 if ($quilt_mode =~ m/gbp|dpm/ &&
3926 ($diffbits->{O2A} & 02)) {
3928 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3929 tool which does not create patches for changes to upstream
3930 .gitignores: but, such patches exist in debian/patches.
3933 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3934 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3935 quiltify_splitbrain_needed();
3936 progress "dgit view: creating patch to represent .gitignore changes";
3937 ensuredir "debian/patches";
3938 my $gipatch = "debian/patches/auto-gitignore";
3939 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3940 stat GIPATCH or die "$gipatch: $!";
3941 fail "$gipatch already exists; but want to create it".
3942 " to record .gitignore changes" if (stat _)[7];
3943 print GIPATCH <<END or die "$gipatch: $!";
3944 Subject: Update .gitignore from Debian packaging branch
3946 The Debian packaging git branch contains these updates to the upstream
3947 .gitignore file(s). This patch is autogenerated, to provide these
3948 updates to users of the official Debian archive view of the package.
3950 [dgit ($our_version) update-gitignore]
3953 close GIPATCH or die "$gipatch: $!";
3954 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3955 $unapplied, $headref, "--", sort keys %$editedignores;
3956 open SERIES, "+>>", "debian/patches/series" or die $!;
3957 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3959 defined read SERIES, $newline, 1 or die $!;
3960 print SERIES "\n" or die $! unless $newline eq "\n";
3961 print SERIES "auto-gitignore\n" or die $!;
3962 close SERIES or die $!;
3963 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3965 Commit patch to update .gitignore
3967 [dgit ($our_version) update-gitignore-quilt-fixup]
3971 my $dgitview = git_rev_parse 'HEAD';
3973 changedir '../../../..';
3974 # When we no longer need to support squeeze, use --create-reflog
3976 ensuredir ".git/logs/refs/dgit-intern";
3977 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3980 my $oldcache = git_get_ref "refs/$splitbraincache";
3981 if ($oldcache eq $dgitview) {
3982 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
3983 # git update-ref doesn't always update, in this case. *sigh*
3984 my $dummy = make_commit_text <<END;
3987 author Dgit <dgit\@example.com> 1000000000 +0000
3988 committer Dgit <dgit\@example.com> 1000000000 +0000
3990 Dummy commit - do not use
3992 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
3993 "refs/$splitbraincache", $dummy;
3995 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3998 progress "dgit view: created (commit id $dgitview)";
4000 changedir '.git/dgit/unpack/work';
4003 sub quiltify ($$$$) {
4004 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4006 # Quilt patchification algorithm
4008 # We search backwards through the history of the main tree's HEAD
4009 # (T) looking for a start commit S whose tree object is identical
4010 # to to the patch tip tree (ie the tree corresponding to the
4011 # current dpkg-committed patch series). For these purposes
4012 # `identical' disregards anything in debian/ - this wrinkle is
4013 # necessary because dpkg-source treates debian/ specially.
4015 # We can only traverse edges where at most one of the ancestors'
4016 # trees differs (in changes outside in debian/). And we cannot
4017 # handle edges which change .pc/ or debian/patches. To avoid
4018 # going down a rathole we avoid traversing edges which introduce
4019 # debian/rules or debian/control. And we set a limit on the
4020 # number of edges we are willing to look at.
4022 # If we succeed, we walk forwards again. For each traversed edge
4023 # PC (with P parent, C child) (starting with P=S and ending with
4024 # C=T) to we do this:
4026 # - dpkg-source --commit with a patch name and message derived from C
4027 # After traversing PT, we git commit the changes which
4028 # should be contained within debian/patches.
4030 # The search for the path S..T is breadth-first. We maintain a
4031 # todo list containing search nodes. A search node identifies a
4032 # commit, and looks something like this:
4034 # Commit => $git_commit_id,
4035 # Child => $c, # or undef if P=T
4036 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
4037 # Nontrivial => true iff $p..$c has relevant changes
4044 my %considered; # saves being exponential on some weird graphs
4046 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4049 my ($search,$whynot) = @_;
4050 printdebug " search NOT $search->{Commit} $whynot\n";
4051 $search->{Whynot} = $whynot;
4052 push @nots, $search;
4053 no warnings qw(exiting);
4062 my $c = shift @todo;
4063 next if $considered{$c->{Commit}}++;
4065 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4067 printdebug "quiltify investigate $c->{Commit}\n";
4070 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4071 printdebug " search finished hooray!\n";
4076 if ($quilt_mode eq 'nofix') {
4077 fail "quilt fixup required but quilt mode is \`nofix'\n".
4078 "HEAD commit $c->{Commit} differs from tree implied by ".
4079 " debian/patches (tree object $oldtiptree)";
4081 if ($quilt_mode eq 'smash') {
4082 printdebug " search quitting smash\n";
4086 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4087 $not->($c, "has $c_sentinels not $t_sentinels")
4088 if $c_sentinels ne $t_sentinels;
4090 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4091 $commitdata =~ m/\n\n/;
4093 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4094 @parents = map { { Commit => $_, Child => $c } } @parents;
4096 $not->($c, "root commit") if !@parents;
4098 foreach my $p (@parents) {
4099 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4101 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4102 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4104 foreach my $p (@parents) {
4105 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4107 my @cmd= (@git, qw(diff-tree -r --name-only),
4108 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4109 my $patchstackchange = cmdoutput @cmd;
4110 if (length $patchstackchange) {
4111 $patchstackchange =~ s/\n/,/g;
4112 $not->($p, "changed $patchstackchange");
4115 printdebug " search queue P=$p->{Commit} ",
4116 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4122 printdebug "quiltify want to smash\n";
4125 my $x = $_[0]{Commit};
4126 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4129 my $reportnot = sub {
4131 my $s = $abbrev->($notp);
4132 my $c = $notp->{Child};
4133 $s .= "..".$abbrev->($c) if $c;
4134 $s .= ": ".$notp->{Whynot};
4137 if ($quilt_mode eq 'linear') {
4138 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4139 foreach my $notp (@nots) {
4140 print STDERR "$us: ", $reportnot->($notp), "\n";
4142 print STDERR "$us: $_\n" foreach @$failsuggestion;
4143 fail "quilt fixup naive history linearisation failed.\n".
4144 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4145 } elsif ($quilt_mode eq 'smash') {
4146 } elsif ($quilt_mode eq 'auto') {
4147 progress "quilt fixup cannot be linear, smashing...";
4149 die "$quilt_mode ?";
4152 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4153 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4155 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4157 quiltify_dpkg_commit "auto-$version-$target-$time",
4158 (getfield $clogp, 'Maintainer'),
4159 "Automatically generated patch ($clogp->{Version})\n".
4160 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4164 progress "quiltify linearisation planning successful, executing...";
4166 for (my $p = $sref_S;
4167 my $c = $p->{Child};
4169 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4170 next unless $p->{Nontrivial};
4172 my $cc = $c->{Commit};
4174 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4175 $commitdata =~ m/\n\n/ or die "$c ?";
4178 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4181 my $commitdate = cmdoutput
4182 @git, qw(log -n1 --pretty=format:%aD), $cc;
4184 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4186 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4193 my $gbp_check_suitable = sub {
4198 die "contains unexpected slashes\n" if m{//} || m{/$};
4199 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4200 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4201 die "too long" if length > 200;
4203 return $_ unless $@;
4204 print STDERR "quiltifying commit $cc:".
4205 " ignoring/dropping Gbp-Pq $what: $@";
4209 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4211 (\S+) \s* \n //ixm) {
4212 $patchname = $gbp_check_suitable->($1, 'Name');
4214 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4216 (\S+) \s* \n //ixm) {
4217 $patchdir = $gbp_check_suitable->($1, 'Topic');
4222 if (!defined $patchname) {
4223 $patchname = $title;
4224 $patchname =~ s/[.:]$//;
4227 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4228 my $translitname = $converter->convert($patchname);
4229 die unless defined $translitname;
4230 $patchname = $translitname;
4233 "dgit: patch title transliteration error: $@"
4235 $patchname =~ y/ A-Z/-a-z/;
4236 $patchname =~ y/-a-z0-9_.+=~//cd;
4237 $patchname =~ s/^\W/x-$&/;
4238 $patchname = substr($patchname,0,40);
4240 if (!defined $patchdir) {
4243 if (length $patchdir) {
4244 $patchname = "$patchdir/$patchname";
4246 if ($patchname =~ m{^(.*)/}) {
4247 mkpath "debian/patches/$1";
4252 stat "debian/patches/$patchname$index";
4254 $!==ENOENT or die "$patchname$index $!";
4256 runcmd @git, qw(checkout -q), $cc;
4258 # We use the tip's changelog so that dpkg-source doesn't
4259 # produce complaining messages from dpkg-parsechangelog. None
4260 # of the information dpkg-source gets from the changelog is
4261 # actually relevant - it gets put into the original message
4262 # which dpkg-source provides our stunt editor, and then
4264 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4266 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4267 "Date: $commitdate\n".
4268 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4270 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4273 runcmd @git, qw(checkout -q master);
4276 sub build_maybe_quilt_fixup () {
4277 my ($format,$fopts) = get_source_format;
4278 return unless madformat_wantfixup $format;
4281 check_for_vendor_patches();
4283 if (quiltmode_splitbrain) {
4284 foreach my $needtf (qw(new maint)) {
4285 next if grep { $_ eq $needtf } access_cfg_tagformats;
4287 quilt mode $quilt_mode requires split view so server needs to support
4288 both "new" and "maint" tag formats, but config says it doesn't.
4293 my $clogp = parsechangelog();
4294 my $headref = git_rev_parse('HEAD');
4299 my $upstreamversion=$version;
4300 $upstreamversion =~ s/-[^-]*$//;
4302 if ($fopts->{'single-debian-patch'}) {
4303 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4305 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4308 die 'bug' if $split_brain && !$need_split_build_invocation;
4310 changedir '../../../..';
4311 runcmd_ordryrun_local
4312 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4315 sub quilt_fixup_mkwork ($) {
4318 mkdir "work" or die $!;
4320 mktree_in_ud_here();
4321 runcmd @git, qw(reset -q --hard), $headref;
4324 sub quilt_fixup_linkorigs ($$) {
4325 my ($upstreamversion, $fn) = @_;
4326 # calls $fn->($leafname);
4328 foreach my $f (<../../../../*>) { #/){
4329 my $b=$f; $b =~ s{.*/}{};
4331 local ($debuglevel) = $debuglevel-1;
4332 printdebug "QF linkorigs $b, $f ?\n";
4334 next unless is_orig_file_of_vsn $b, $upstreamversion;
4335 printdebug "QF linkorigs $b, $f Y\n";
4336 link_ltarget $f, $b or die "$b $!";
4341 sub quilt_fixup_delete_pc () {
4342 runcmd @git, qw(rm -rqf .pc);
4344 Commit removal of .pc (quilt series tracking data)
4346 [dgit ($our_version) upgrade quilt-remove-pc]
4350 sub quilt_fixup_singlepatch ($$$) {
4351 my ($clogp, $headref, $upstreamversion) = @_;
4353 progress "starting quiltify (single-debian-patch)";
4355 # dpkg-source --commit generates new patches even if
4356 # single-debian-patch is in debian/source/options. In order to
4357 # get it to generate debian/patches/debian-changes, it is
4358 # necessary to build the source package.
4360 quilt_fixup_linkorigs($upstreamversion, sub { });
4361 quilt_fixup_mkwork($headref);
4363 rmtree("debian/patches");
4365 runcmd @dpkgsource, qw(-b .);
4367 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4368 rename srcfn("$upstreamversion", "/debian/patches"),
4369 "work/debian/patches";
4372 commit_quilty_patch();
4375 sub quilt_make_fake_dsc ($) {
4376 my ($upstreamversion) = @_;
4378 my $fakeversion="$upstreamversion-~~DGITFAKE";
4380 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4381 print $fakedsc <<END or die $!;
4384 Version: $fakeversion
4388 my $dscaddfile=sub {
4391 my $md = new Digest::MD5;
4393 my $fh = new IO::File $b, '<' or die "$b $!";
4398 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4401 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4403 my @files=qw(debian/source/format debian/rules
4404 debian/control debian/changelog);
4405 foreach my $maybe (qw(debian/patches debian/source/options
4406 debian/tests/control)) {
4407 next unless stat_exists "../../../$maybe";
4408 push @files, $maybe;
4411 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4412 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4414 $dscaddfile->($debtar);
4415 close $fakedsc or die $!;
4418 sub quilt_check_splitbrain_cache ($$) {
4419 my ($headref, $upstreamversion) = @_;
4420 # Called only if we are in (potentially) split brain mode.
4422 # Computes the cache key and looks in the cache.
4423 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4425 my $splitbrain_cachekey;
4428 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4429 # we look in the reflog of dgit-intern/quilt-cache
4430 # we look for an entry whose message is the key for the cache lookup
4431 my @cachekey = (qw(dgit), $our_version);
4432 push @cachekey, $upstreamversion;
4433 push @cachekey, $quilt_mode;
4434 push @cachekey, $headref;
4436 push @cachekey, hashfile('fake.dsc');
4438 my $srcshash = Digest::SHA->new(256);
4439 my %sfs = ( %INC, '$0(dgit)' => $0 );
4440 foreach my $sfk (sort keys %sfs) {
4441 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4442 $srcshash->add($sfk," ");
4443 $srcshash->add(hashfile($sfs{$sfk}));
4444 $srcshash->add("\n");
4446 push @cachekey, $srcshash->hexdigest();
4447 $splitbrain_cachekey = "@cachekey";
4449 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4451 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4452 debugcmd "|(probably)",@cmd;
4453 my $child = open GC, "-|"; defined $child or die $!;
4455 chdir '../../..' or die $!;
4456 if (!stat ".git/logs/refs/$splitbraincache") {
4457 $! == ENOENT or die $!;
4458 printdebug ">(no reflog)\n";
4465 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4466 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4469 quilt_fixup_mkwork($headref);
4470 if ($cachehit ne $headref) {
4471 progress "dgit view: found cached (commit id $cachehit)";
4472 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4474 return ($cachehit, $splitbrain_cachekey);
4476 progress "dgit view: found cached, no changes required";
4477 return ($headref, $splitbrain_cachekey);
4479 die $! if GC->error;
4480 failedcmd unless close GC;
4482 printdebug "splitbrain cache miss\n";
4483 return (undef, $splitbrain_cachekey);
4486 sub quilt_fixup_multipatch ($$$) {
4487 my ($clogp, $headref, $upstreamversion) = @_;
4489 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4492 # - honour any existing .pc in case it has any strangeness
4493 # - determine the git commit corresponding to the tip of
4494 # the patch stack (if there is one)
4495 # - if there is such a git commit, convert each subsequent
4496 # git commit into a quilt patch with dpkg-source --commit
4497 # - otherwise convert all the differences in the tree into
4498 # a single git commit
4502 # Our git tree doesn't necessarily contain .pc. (Some versions of
4503 # dgit would include the .pc in the git tree.) If there isn't
4504 # one, we need to generate one by unpacking the patches that we
4507 # We first look for a .pc in the git tree. If there is one, we
4508 # will use it. (This is not the normal case.)
4510 # Otherwise need to regenerate .pc so that dpkg-source --commit
4511 # can work. We do this as follows:
4512 # 1. Collect all relevant .orig from parent directory
4513 # 2. Generate a debian.tar.gz out of
4514 # debian/{patches,rules,source/format,source/options}
4515 # 3. Generate a fake .dsc containing just these fields:
4516 # Format Source Version Files
4517 # 4. Extract the fake .dsc
4518 # Now the fake .dsc has a .pc directory.
4519 # (In fact we do this in every case, because in future we will
4520 # want to search for a good base commit for generating patches.)
4522 # Then we can actually do the dpkg-source --commit
4523 # 1. Make a new working tree with the same object
4524 # store as our main tree and check out the main
4526 # 2. Copy .pc from the fake's extraction, if necessary
4527 # 3. Run dpkg-source --commit
4528 # 4. If the result has changes to debian/, then
4529 # - git add them them
4530 # - git add .pc if we had a .pc in-tree
4532 # 5. If we had a .pc in-tree, delete it, and git commit
4533 # 6. Back in the main tree, fast forward to the new HEAD
4535 # Another situation we may have to cope with is gbp-style
4536 # patches-unapplied trees.
4538 # We would want to detect these, so we know to escape into
4539 # quilt_fixup_gbp. However, this is in general not possible.
4540 # Consider a package with a one patch which the dgit user reverts
4541 # (with git revert or the moral equivalent).
4543 # That is indistinguishable in contents from a patches-unapplied
4544 # tree. And looking at the history to distinguish them is not
4545 # useful because the user might have made a confusing-looking git
4546 # history structure (which ought to produce an error if dgit can't
4547 # cope, not a silent reintroduction of an unwanted patch).
4549 # So gbp users will have to pass an option. But we can usually
4550 # detect their failure to do so: if the tree is not a clean
4551 # patches-applied tree, quilt linearisation fails, but the tree
4552 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4553 # they want --quilt=unapplied.
4555 # To help detect this, when we are extracting the fake dsc, we
4556 # first extract it with --skip-patches, and then apply the patches
4557 # afterwards with dpkg-source --before-build. That lets us save a
4558 # tree object corresponding to .origs.
4560 my $splitbrain_cachekey;
4562 quilt_make_fake_dsc($upstreamversion);
4564 if (quiltmode_splitbrain()) {
4566 ($cachehit, $splitbrain_cachekey) =
4567 quilt_check_splitbrain_cache($headref, $upstreamversion);
4568 return if $cachehit;
4572 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4574 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4575 rename $fakexdir, "fake" or die "$fakexdir $!";
4579 remove_stray_gits();
4580 mktree_in_ud_here();
4584 runcmd @git, qw(add -Af .);
4585 my $unapplied=git_write_tree();
4586 printdebug "fake orig tree object $unapplied\n";
4590 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4592 if (system @bbcmd) {
4593 failedcmd @bbcmd if $? < 0;
4595 failed to apply your git tree's patch stack (from debian/patches/) to
4596 the corresponding upstream tarball(s). Your source tree and .orig
4597 are probably too inconsistent. dgit can only fix up certain kinds of
4598 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4604 quilt_fixup_mkwork($headref);
4607 if (stat_exists ".pc") {
4609 progress "Tree already contains .pc - will use it then delete it.";
4612 rename '../fake/.pc','.pc' or die $!;
4615 changedir '../fake';
4617 runcmd @git, qw(add -Af .);
4618 my $oldtiptree=git_write_tree();
4619 printdebug "fake o+d/p tree object $unapplied\n";
4620 changedir '../work';
4623 # We calculate some guesswork now about what kind of tree this might
4624 # be. This is mostly for error reporting.
4630 # O = orig, without patches applied
4631 # A = "applied", ie orig with H's debian/patches applied
4632 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4633 \%editedignores, \@unrepres),
4634 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4635 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4639 foreach my $b (qw(01 02)) {
4640 foreach my $v (qw(O2H O2A H2A)) {
4641 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4644 printdebug "differences \@dl @dl.\n";
4647 "$us: base trees orig=%.20s o+d/p=%.20s",
4648 $unapplied, $oldtiptree;
4650 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4651 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4652 $dl[0], $dl[1], $dl[3], $dl[4],
4656 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4658 forceable_fail [qw(unrepresentable)], <<END;
4659 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4664 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4665 push @failsuggestion, "This might be a patches-unapplied branch.";
4666 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4667 push @failsuggestion, "This might be a patches-applied branch.";
4669 push @failsuggestion, "Maybe you need to specify one of".
4670 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4672 if (quiltmode_splitbrain()) {
4673 quiltify_splitbrain($clogp, $unapplied, $headref,
4674 $diffbits, \%editedignores,
4675 $splitbrain_cachekey);
4679 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4680 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4682 if (!open P, '>>', ".pc/applied-patches") {
4683 $!==&ENOENT or die $!;
4688 commit_quilty_patch();
4690 if ($mustdeletepc) {
4691 quilt_fixup_delete_pc();
4695 sub quilt_fixup_editor () {
4696 my $descfn = $ENV{$fakeeditorenv};
4697 my $editing = $ARGV[$#ARGV];
4698 open I1, '<', $descfn or die "$descfn: $!";
4699 open I2, '<', $editing or die "$editing: $!";
4700 unlink $editing or die "$editing: $!";
4701 open O, '>', $editing or die "$editing: $!";
4702 while (<I1>) { print O or die $!; } I1->error and die $!;
4705 $copying ||= m/^\-\-\- /;
4706 next unless $copying;
4709 I2->error and die $!;
4714 sub maybe_apply_patches_dirtily () {
4715 return unless $quilt_mode =~ m/gbp|unapplied/;
4716 print STDERR <<END or die $!;
4718 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4719 dgit: Have to apply the patches - making the tree dirty.
4720 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4723 $patches_applied_dirtily = 01;
4724 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4725 runcmd qw(dpkg-source --before-build .);
4728 sub maybe_unapply_patches_again () {
4729 progress "dgit: Unapplying patches again to tidy up the tree."
4730 if $patches_applied_dirtily;
4731 runcmd qw(dpkg-source --after-build .)
4732 if $patches_applied_dirtily & 01;
4734 if $patches_applied_dirtily & 02;
4735 $patches_applied_dirtily = 0;
4738 #----- other building -----
4740 our $clean_using_builder;
4741 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4742 # clean the tree before building (perhaps invoked indirectly by
4743 # whatever we are using to run the build), rather than separately
4744 # and explicitly by us.
4747 return if $clean_using_builder;
4748 if ($cleanmode eq 'dpkg-source') {
4749 maybe_apply_patches_dirtily();
4750 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4751 } elsif ($cleanmode eq 'dpkg-source-d') {
4752 maybe_apply_patches_dirtily();
4753 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4754 } elsif ($cleanmode eq 'git') {
4755 runcmd_ordryrun_local @git, qw(clean -xdf);
4756 } elsif ($cleanmode eq 'git-ff') {
4757 runcmd_ordryrun_local @git, qw(clean -xdff);
4758 } elsif ($cleanmode eq 'check') {
4759 my $leftovers = cmdoutput @git, qw(clean -xdn);
4760 if (length $leftovers) {
4761 print STDERR $leftovers, "\n" or die $!;
4762 fail "tree contains uncommitted files and --clean=check specified";
4764 } elsif ($cleanmode eq 'none') {
4771 badusage "clean takes no additional arguments" if @ARGV;
4774 maybe_unapply_patches_again();
4779 badusage "-p is not allowed when building" if defined $package;
4782 my $clogp = parsechangelog();
4783 $isuite = getfield $clogp, 'Distribution';
4784 $package = getfield $clogp, 'Source';
4785 $version = getfield $clogp, 'Version';
4786 build_maybe_quilt_fixup();
4788 my $pat = changespat $version;
4789 foreach my $f (glob "$buildproductsdir/$pat") {
4791 unlink $f or fail "remove old changes file $f: $!";
4793 progress "would remove $f";
4799 sub changesopts_initial () {
4800 my @opts =@changesopts[1..$#changesopts];
4803 sub changesopts_version () {
4804 if (!defined $changes_since_version) {
4805 my @vsns = archive_query('archive_query');
4806 my @quirk = access_quirk();
4807 if ($quirk[0] eq 'backports') {
4808 local $isuite = $quirk[2];
4810 canonicalise_suite();
4811 push @vsns, archive_query('archive_query');
4814 @vsns = map { $_->[0] } @vsns;
4815 @vsns = sort { -version_compare($a, $b) } @vsns;
4816 $changes_since_version = $vsns[0];
4817 progress "changelog will contain changes since $vsns[0]";
4819 $changes_since_version = '_';
4820 progress "package seems new, not specifying -v<version>";
4823 if ($changes_since_version ne '_') {
4824 return ("-v$changes_since_version");
4830 sub changesopts () {
4831 return (changesopts_initial(), changesopts_version());
4834 sub massage_dbp_args ($;$) {
4835 my ($cmd,$xargs) = @_;
4838 # - if we're going to split the source build out so we can
4839 # do strange things to it, massage the arguments to dpkg-buildpackage
4840 # so that the main build doessn't build source (or add an argument
4841 # to stop it building source by default).
4843 # - add -nc to stop dpkg-source cleaning the source tree,
4844 # unless we're not doing a split build and want dpkg-source
4845 # as cleanmode, in which case we can do nothing
4848 # 0 - source will NOT need to be built separately by caller
4849 # +1 - source will need to be built separately by caller
4850 # +2 - source will need to be built separately by caller AND
4851 # dpkg-buildpackage should not in fact be run at all!
4852 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4853 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4854 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4855 $clean_using_builder = 1;
4858 # -nc has the side effect of specifying -b if nothing else specified
4859 # and some combinations of -S, -b, et al, are errors, rather than
4860 # later simply overriding earlie. So we need to:
4861 # - search the command line for these options
4862 # - pick the last one
4863 # - perhaps add our own as a default
4864 # - perhaps adjust it to the corresponding non-source-building version
4866 foreach my $l ($cmd, $xargs) {
4868 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4871 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4873 if ($need_split_build_invocation) {
4874 printdebug "massage split $dmode.\n";
4875 $r = $dmode =~ m/[S]/ ? +2 :
4876 $dmode =~ y/gGF/ABb/ ? +1 :
4877 $dmode =~ m/[ABb]/ ? 0 :
4880 printdebug "massage done $r $dmode.\n";
4882 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4887 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4888 my $wantsrc = massage_dbp_args \@dbp;
4895 push @dbp, changesopts_version();
4896 maybe_apply_patches_dirtily();
4897 runcmd_ordryrun_local @dbp;
4899 maybe_unapply_patches_again();
4900 printdone "build successful\n";
4904 $quilt_mode //= 'gbp';
4908 my @dbp = @dpkgbuildpackage;
4910 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4912 if (!length $gbp_build[0]) {
4913 if (length executable_on_path('git-buildpackage')) {
4914 $gbp_build[0] = qw(git-buildpackage);
4916 $gbp_build[0] = 'gbp buildpackage';
4919 my @cmd = opts_opt_multi_cmd @gbp_build;
4921 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4926 if (!$clean_using_builder) {
4927 push @cmd, '--git-cleaner=true';
4931 maybe_unapply_patches_again();
4933 push @cmd, changesopts();
4934 runcmd_ordryrun_local @cmd, @ARGV;
4936 printdone "build successful\n";
4938 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4941 my $our_cleanmode = $cleanmode;
4942 if ($need_split_build_invocation) {
4943 # Pretend that clean is being done some other way. This
4944 # forces us not to try to use dpkg-buildpackage to clean and
4945 # build source all in one go; and instead we run dpkg-source
4946 # (and build_prep() will do the clean since $clean_using_builder
4948 $our_cleanmode = 'ELSEWHERE';
4950 if ($our_cleanmode =~ m/^dpkg-source/) {
4951 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4952 $clean_using_builder = 1;
4955 $sourcechanges = changespat $version,'source';
4957 unlink "../$sourcechanges" or $!==ENOENT
4958 or fail "remove $sourcechanges: $!";
4960 $dscfn = dscfn($version);
4961 if ($our_cleanmode eq 'dpkg-source') {
4962 maybe_apply_patches_dirtily();
4963 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4965 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4966 maybe_apply_patches_dirtily();
4967 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4970 my @cmd = (@dpkgsource, qw(-b --));
4973 runcmd_ordryrun_local @cmd, "work";
4974 my @udfiles = <${package}_*>;
4975 changedir "../../..";
4976 foreach my $f (@udfiles) {
4977 printdebug "source copy, found $f\n";
4980 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4981 $f eq srcfn($version, $&));
4982 printdebug "source copy, found $f - renaming\n";
4983 rename "$ud/$f", "../$f" or $!==ENOENT
4984 or fail "put in place new source file ($f): $!";
4987 my $pwd = must_getcwd();
4988 my $leafdir = basename $pwd;
4990 runcmd_ordryrun_local @cmd, $leafdir;
4993 runcmd_ordryrun_local qw(sh -ec),
4994 'exec >$1; shift; exec "$@"','x',
4995 "../$sourcechanges",
4996 @dpkggenchanges, qw(-S), changesopts();
5000 sub cmd_build_source {
5001 badusage "build-source takes no additional arguments" if @ARGV;
5003 maybe_unapply_patches_again();
5004 printdone "source built, results in $dscfn and $sourcechanges";
5009 my $pat = changespat $version;
5011 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
5012 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
5014 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
5015 Suggest you delete @unwanted.
5019 my $wasdir = must_getcwd();
5022 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
5023 stat_exists $sourcechanges
5024 or fail "$sourcechanges (in parent directory): $!";
5026 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
5027 my @changesfiles = glob $pat;
5028 @changesfiles = sort {
5029 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
5032 fail <<END if @changesfiles==1;
5033 only one changes file from sbuild (@changesfiles)
5034 perhaps you need to pass -A ? (sbuild's default is to build only
5035 arch-specific binaries; dgit 1.4 used to override that.)
5037 fail "wrong number of different changes files (@changesfiles)"
5038 unless @changesfiles==2;
5039 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
5040 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
5041 fail "$l found in binaries changes file $binchanges"
5044 runcmd_ordryrun_local @mergechanges, @changesfiles;
5045 my $multichanges = changespat $version,'multi';
5047 stat_exists $multichanges or fail "$multichanges: $!";
5048 foreach my $cf (glob $pat) {
5049 next if $cf eq $multichanges;
5050 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5054 maybe_unapply_patches_again();
5055 printdone "build successful, results in $multichanges\n" or die $!;
5058 sub cmd_quilt_fixup {
5059 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5060 my $clogp = parsechangelog();
5061 $version = getfield $clogp, 'Version';
5062 $package = getfield $clogp, 'Source';
5065 build_maybe_quilt_fixup();
5068 sub cmd_archive_api_query {
5069 badusage "need only 1 subpath argument" unless @ARGV==1;
5070 my ($subpath) = @ARGV;
5071 my @cmd = archive_api_query_cmd($subpath);
5074 exec @cmd or fail "exec curl: $!\n";
5077 sub cmd_clone_dgit_repos_server {
5078 badusage "need destination argument" unless @ARGV==1;
5079 my ($destdir) = @ARGV;
5080 $package = '_dgit-repos-server';
5081 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5083 exec @cmd or fail "exec git clone: $!\n";
5086 sub cmd_setup_mergechangelogs {
5087 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5088 setup_mergechangelogs(1);
5091 sub cmd_setup_useremail {
5092 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5096 sub cmd_setup_new_tree {
5097 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5101 #---------- argument parsing and main program ----------
5104 print "dgit version $our_version\n" or die $!;
5108 our (%valopts_long, %valopts_short);
5111 sub defvalopt ($$$$) {
5112 my ($long,$short,$val_re,$how) = @_;
5113 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5114 $valopts_long{$long} = $oi;
5115 $valopts_short{$short} = $oi;
5116 # $how subref should:
5117 # do whatever assignemnt or thing it likes with $_[0]
5118 # if the option should not be passed on to remote, @rvalopts=()
5119 # or $how can be a scalar ref, meaning simply assign the value
5122 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5123 defvalopt '--distro', '-d', '.+', \$idistro;
5124 defvalopt '', '-k', '.+', \$keyid;
5125 defvalopt '--existing-package','', '.*', \$existing_package;
5126 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5127 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5128 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5130 defvalopt '', '-C', '.+', sub {
5131 ($changesfile) = (@_);
5132 if ($changesfile =~ s#^(.*)/##) {
5133 $buildproductsdir = $1;
5137 defvalopt '--initiator-tempdir','','.*', sub {
5138 ($initiator_tempdir) = (@_);
5139 $initiator_tempdir =~ m#^/# or
5140 badusage "--initiator-tempdir must be used specify an".
5141 " absolute, not relative, directory."
5147 if (defined $ENV{'DGIT_SSH'}) {
5148 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5149 } elsif (defined $ENV{'GIT_SSH'}) {
5150 @ssh = ($ENV{'GIT_SSH'});
5158 if (!defined $val) {
5159 badusage "$what needs a value" unless @ARGV;
5161 push @rvalopts, $val;
5163 badusage "bad value \`$val' for $what" unless
5164 $val =~ m/^$oi->{Re}$(?!\n)/s;
5165 my $how = $oi->{How};
5166 if (ref($how) eq 'SCALAR') {
5171 push @ropts, @rvalopts;
5175 last unless $ARGV[0] =~ m/^-/;
5179 if (m/^--dry-run$/) {
5182 } elsif (m/^--damp-run$/) {
5185 } elsif (m/^--no-sign$/) {
5188 } elsif (m/^--help$/) {
5190 } elsif (m/^--version$/) {
5192 } elsif (m/^--new$/) {
5195 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5196 ($om = $opts_opt_map{$1}) &&
5200 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5201 !$opts_opt_cmdonly{$1} &&
5202 ($om = $opts_opt_map{$1})) {
5205 } elsif (m/^--(gbp|dpm)$/s) {
5206 push @ropts, "--quilt=$1";
5208 } elsif (m/^--ignore-dirty$/s) {
5211 } elsif (m/^--no-quilt-fixup$/s) {
5213 $quilt_mode = 'nocheck';
5214 } elsif (m/^--no-rm-on-error$/s) {
5217 } elsif (m/^--overwrite$/s) {
5219 $overwrite_version = '';
5220 } elsif (m/^--overwrite=(.+)$/s) {
5222 $overwrite_version = $1;
5223 } elsif (m/^--(no-)?rm-old-changes$/s) {
5226 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5228 push @deliberatelies, $&;
5229 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5233 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5234 # undocumented, for testing
5236 $tagformat_want = [ $1, 'command line', 1 ];
5237 # 1 menas overrides distro configuration
5238 } elsif (m/^--always-split-source-build$/s) {
5239 # undocumented, for testing
5241 $need_split_build_invocation = 1;
5242 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5243 $val = $2 ? $' : undef; #';
5244 $valopt->($oi->{Long});
5246 badusage "unknown long option \`$_'";
5253 } elsif (s/^-L/-/) {
5256 } elsif (s/^-h/-/) {
5258 } elsif (s/^-D/-/) {
5262 } elsif (s/^-N/-/) {
5267 push @changesopts, $_;
5269 } elsif (s/^-wn$//s) {
5271 $cleanmode = 'none';
5272 } elsif (s/^-wg$//s) {
5275 } elsif (s/^-wgf$//s) {
5277 $cleanmode = 'git-ff';
5278 } elsif (s/^-wd$//s) {
5280 $cleanmode = 'dpkg-source';
5281 } elsif (s/^-wdd$//s) {
5283 $cleanmode = 'dpkg-source-d';
5284 } elsif (s/^-wc$//s) {
5286 $cleanmode = 'check';
5287 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5288 push @git, '-c', $&;
5289 $gitcfgs{cmdline}{$1} = [ $2 ];
5290 } elsif (s/^-c([^=]+)$//s) {
5291 push @git, '-c', $&;
5292 $gitcfgs{cmdline}{$1} = [ 'true' ];
5293 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5295 $val = undef unless length $val;
5296 $valopt->($oi->{Short});
5299 badusage "unknown short option \`$_'";
5306 sub check_env_sanity () {
5307 my $blocked = new POSIX::SigSet;
5308 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5311 foreach my $name (qw(PIPE CHLD)) {
5312 my $signame = "SIG$name";
5313 my $signum = eval "POSIX::$signame" // die;
5314 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5315 die "$signame is set to something other than SIG_DFL\n";
5316 $blocked->ismember($signum) and
5317 die "$signame is blocked\n";
5323 On entry to dgit, $@
5324 This is a bug produced by something in in your execution environment.
5330 sub finalise_opts_opts () {
5331 foreach my $k (keys %opts_opt_map) {
5332 my $om = $opts_opt_map{$k};
5334 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5336 badcfg "cannot set command for $k"
5337 unless length $om->[0];
5341 foreach my $c (access_cfg_cfgs("opts-$k")) {
5343 map { $_ ? @$_ : () }
5344 map { $gitcfgs{$_}{$c} }
5345 reverse @gitcfgsources;
5346 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5347 "\n" if $debuglevel >= 4;
5349 badcfg "cannot configure options for $k"
5350 if $opts_opt_cmdonly{$k};
5351 my $insertpos = $opts_cfg_insertpos{$k};
5352 @$om = ( @$om[0..$insertpos-1],
5354 @$om[$insertpos..$#$om] );
5359 if ($ENV{$fakeeditorenv}) {
5361 quilt_fixup_editor();
5368 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5369 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5370 if $dryrun_level == 1;
5372 print STDERR $helpmsg or die $!;
5375 my $cmd = shift @ARGV;
5378 my $pre_fn = ${*::}{"pre_$cmd"};
5379 $pre_fn->() if $pre_fn;
5381 if (!defined $rmchanges) {
5382 local $access_forpush;
5383 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5386 if (!defined $quilt_mode) {
5387 local $access_forpush;
5388 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5389 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5391 $quilt_mode =~ m/^($quilt_modes_re)$/
5392 or badcfg "unknown quilt-mode \`$quilt_mode'";
5396 $need_split_build_invocation ||= quiltmode_splitbrain();
5398 if (!defined $cleanmode) {
5399 local $access_forpush;
5400 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5401 $cleanmode //= 'dpkg-source';
5403 badcfg "unknown clean-mode \`$cleanmode'" unless
5404 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5407 my $fn = ${*::}{"cmd_$cmd"};
5408 $fn or badusage "unknown operation $cmd";