3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2016 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
48 our $isuite = 'unstable';
54 our $dryrun_level = 0;
56 our $buildproductsdir = '..';
62 our $existing_package = 'dpkg';
64 our $changes_since_version;
66 our $overwrite_version; # undef: not specified; '': check changelog
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %forceopts = map { $_=>0 } qw(unrepresentable);
78 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
80 our $suite_re = '[-+.0-9a-z]+';
81 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
82 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
83 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
84 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
86 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
87 our $splitbraincache = 'dgit-intern/quilt-cache';
90 our (@dget) = qw(dget);
91 our (@curl) = qw(curl);
92 our (@dput) = qw(dput);
93 our (@debsign) = qw(debsign);
95 our (@sbuild) = qw(sbuild);
97 our (@dgit) = qw(dgit);
98 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
99 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
100 our (@dpkggenchanges) = qw(dpkg-genchanges);
101 our (@mergechanges) = qw(mergechanges -f);
102 our (@gbp_build) = ('');
103 our (@gbp_pq) = ('gbp pq');
104 our (@changesopts) = ('');
106 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
109 'debsign' => \@debsign,
111 'sbuild' => \@sbuild,
115 'dpkg-source' => \@dpkgsource,
116 'dpkg-buildpackage' => \@dpkgbuildpackage,
117 'dpkg-genchanges' => \@dpkggenchanges,
118 'gbp-build' => \@gbp_build,
119 'gbp-pq' => \@gbp_pq,
120 'ch' => \@changesopts,
121 'mergechanges' => \@mergechanges);
123 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
124 our %opts_cfg_insertpos = map {
126 scalar @{ $opts_opt_map{$_} }
127 } keys %opts_opt_map;
129 sub finalise_opts_opts();
135 our $supplementary_message = '';
136 our $need_split_build_invocation = 0;
137 our $split_brain = 0;
141 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
144 our $remotename = 'dgit';
145 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
150 my ($v,$distro) = @_;
151 return $tagformatfn->($v, $distro);
154 sub debiantag_maintview ($$) {
155 my ($v,$distro) = @_;
160 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
162 sub lbranch () { return "$branchprefix/$csuite"; }
163 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
164 sub lref () { return "refs/heads/".lbranch(); }
165 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
166 sub rrref () { return server_ref($csuite); }
168 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
169 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
171 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
172 # locally fetched refs because they have unhelpful names and clutter
173 # up gitk etc. So we track whether we have "used up" head ref (ie,
174 # whether we have made another local ref which refers to this object).
176 # (If we deleted them unconditionally, then we might end up
177 # re-fetching the same git objects each time dgit fetch was run.)
179 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
180 # in git_fetch_us to fetch the refs in question, and possibly a call
181 # to lrfetchref_used.
183 our (%lrfetchrefs_f, %lrfetchrefs_d);
184 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
186 sub lrfetchref_used ($) {
187 my ($fullrefname) = @_;
188 my $objid = $lrfetchrefs_f{$fullrefname};
189 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
200 return "${package}_".(stripepoch $vsn).$sfx
205 return srcfn($vsn,".dsc");
208 sub changespat ($;$) {
209 my ($vsn, $arch) = @_;
210 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
219 foreach my $f (@end) {
221 print STDERR "$us: cleanup: $@" if length $@;
225 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
227 sub forceable_fail ($$) {
228 my ($forceoptsl, $msg) = @_;
229 fail $msg unless grep { $forceopts{$_} } @$forceoptsl;
230 print STDERR "warning: overriding problem due to --force:\n". $msg;
233 sub no_such_package () {
234 print STDERR "$us: package $package does not exist in suite $isuite\n";
240 printdebug "CD $newdir\n";
241 chdir $newdir or confess "chdir: $newdir: $!";
244 sub deliberately ($) {
246 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
249 sub deliberately_not_fast_forward () {
250 foreach (qw(not-fast-forward fresh-repo)) {
251 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
255 sub quiltmode_splitbrain () {
256 $quilt_mode =~ m/gbp|dpm|unapplied/;
259 sub opts_opt_multi_cmd {
261 push @cmd, split /\s+/, shift @_;
267 return opts_opt_multi_cmd @gbp_pq;
270 #---------- remote protocol support, common ----------
272 # remote push initiator/responder protocol:
273 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
274 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
275 # < dgit-remote-push-ready <actual-proto-vsn>
282 # > supplementary-message NBYTES # $protovsn >= 3
287 # > file parsed-changelog
288 # [indicates that output of dpkg-parsechangelog follows]
289 # > data-block NBYTES
290 # > [NBYTES bytes of data (no newline)]
291 # [maybe some more blocks]
300 # > param head DGIT-VIEW-HEAD
301 # > param csuite SUITE
302 # > param tagformat old|new
303 # > param maint-view MAINT-VIEW-HEAD
305 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
306 # # goes into tag, for replay prevention
309 # [indicates that signed tag is wanted]
310 # < data-block NBYTES
311 # < [NBYTES bytes of data (no newline)]
312 # [maybe some more blocks]
316 # > want signed-dsc-changes
317 # < data-block NBYTES [transfer of signed dsc]
319 # < data-block NBYTES [transfer of signed changes]
327 sub i_child_report () {
328 # Sees if our child has died, and reap it if so. Returns a string
329 # describing how it died if it failed, or undef otherwise.
330 return undef unless $i_child_pid;
331 my $got = waitpid $i_child_pid, WNOHANG;
332 return undef if $got <= 0;
333 die unless $got == $i_child_pid;
334 $i_child_pid = undef;
335 return undef unless $?;
336 return "build host child ".waitstatusmsg();
341 fail "connection lost: $!" if $fh->error;
342 fail "protocol violation; $m not expected";
345 sub badproto_badread ($$) {
347 fail "connection lost: $!" if $!;
348 my $report = i_child_report();
349 fail $report if defined $report;
350 badproto $fh, "eof (reading $wh)";
353 sub protocol_expect (&$) {
354 my ($match, $fh) = @_;
357 defined && chomp or badproto_badread $fh, "protocol message";
365 badproto $fh, "\`$_'";
368 sub protocol_send_file ($$) {
369 my ($fh, $ourfn) = @_;
370 open PF, "<", $ourfn or die "$ourfn: $!";
373 my $got = read PF, $d, 65536;
374 die "$ourfn: $!" unless defined $got;
376 print $fh "data-block ".length($d)."\n" or die $!;
377 print $fh $d or die $!;
379 PF->error and die "$ourfn $!";
380 print $fh "data-end\n" or die $!;
384 sub protocol_read_bytes ($$) {
385 my ($fh, $nbytes) = @_;
386 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
388 my $got = read $fh, $d, $nbytes;
389 $got==$nbytes or badproto_badread $fh, "data block";
393 sub protocol_receive_file ($$) {
394 my ($fh, $ourfn) = @_;
395 printdebug "() $ourfn\n";
396 open PF, ">", $ourfn or die "$ourfn: $!";
398 my ($y,$l) = protocol_expect {
399 m/^data-block (.*)$/ ? (1,$1) :
400 m/^data-end$/ ? (0,) :
404 my $d = protocol_read_bytes $fh, $l;
405 print PF $d or die $!;
410 #---------- remote protocol support, responder ----------
412 sub responder_send_command ($) {
414 return unless $we_are_responder;
415 # called even without $we_are_responder
416 printdebug ">> $command\n";
417 print PO $command, "\n" or die $!;
420 sub responder_send_file ($$) {
421 my ($keyword, $ourfn) = @_;
422 return unless $we_are_responder;
423 printdebug "]] $keyword $ourfn\n";
424 responder_send_command "file $keyword";
425 protocol_send_file \*PO, $ourfn;
428 sub responder_receive_files ($@) {
429 my ($keyword, @ourfns) = @_;
430 die unless $we_are_responder;
431 printdebug "[[ $keyword @ourfns\n";
432 responder_send_command "want $keyword";
433 foreach my $fn (@ourfns) {
434 protocol_receive_file \*PI, $fn;
437 protocol_expect { m/^files-end$/ } \*PI;
440 #---------- remote protocol support, initiator ----------
442 sub initiator_expect (&) {
444 protocol_expect { &$match } \*RO;
447 #---------- end remote code ----------
450 if ($we_are_responder) {
452 responder_send_command "progress ".length($m) or die $!;
453 print PO $m or die $!;
463 $ua = LWP::UserAgent->new();
467 progress "downloading $what...";
468 my $r = $ua->get(@_) or die $!;
469 return undef if $r->code == 404;
470 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
471 return $r->decoded_content(charset => 'none');
474 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
479 failedcmd @_ if system @_;
482 sub act_local () { return $dryrun_level <= 1; }
483 sub act_scary () { return !$dryrun_level; }
486 if (!$dryrun_level) {
487 progress "dgit ok: @_";
489 progress "would be ok: @_ (but dry run only)";
494 printcmd(\*STDERR,$debugprefix."#",@_);
497 sub runcmd_ordryrun {
505 sub runcmd_ordryrun_local {
514 my ($first_shell, @cmd) = @_;
515 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
518 our $helpmsg = <<END;
520 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
521 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
522 dgit [dgit-opts] build [dpkg-buildpackage-opts]
523 dgit [dgit-opts] sbuild [sbuild-opts]
524 dgit [dgit-opts] push [dgit-opts] [suite]
525 dgit [dgit-opts] rpush build-host:build-dir ...
526 important dgit options:
527 -k<keyid> sign tag and package with <keyid> instead of default
528 --dry-run -n do not change anything, but go through the motions
529 --damp-run -L like --dry-run but make local changes, without signing
530 --new -N allow introducing a new package
531 --debug -D increase debug level
532 -c<name>=<value> set git config option (used directly by dgit too)
535 our $later_warning_msg = <<END;
536 Perhaps the upload is stuck in incoming. Using the version from git.
540 print STDERR "$us: @_\n", $helpmsg or die $!;
545 @ARGV or badusage "too few arguments";
546 return scalar shift @ARGV;
550 print $helpmsg or die $!;
554 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
556 our %defcfg = ('dgit.default.distro' => 'debian',
557 'dgit.default.username' => '',
558 'dgit.default.archive-query-default-component' => 'main',
559 'dgit.default.ssh' => 'ssh',
560 'dgit.default.archive-query' => 'madison:',
561 'dgit.default.sshpsql-dbname' => 'service=projectb',
562 'dgit.default.dgit-tag-format' => 'new,old,maint',
563 # old means "repo server accepts pushes with old dgit tags"
564 # new means "repo server accepts pushes with new dgit tags"
565 # maint means "repo server accepts split brain pushes"
566 # hist means "repo server may have old pushes without new tag"
567 # ("hist" is implied by "old")
568 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
569 'dgit-distro.debian.git-check' => 'url',
570 'dgit-distro.debian.git-check-suffix' => '/info/refs',
571 'dgit-distro.debian.new-private-pushers' => 't',
572 'dgit-distro.debian/push.git-url' => '',
573 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
574 'dgit-distro.debian/push.git-user-force' => 'dgit',
575 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
576 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
577 'dgit-distro.debian/push.git-create' => 'true',
578 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
579 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
580 # 'dgit-distro.debian.archive-query-tls-key',
581 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
582 # ^ this does not work because curl is broken nowadays
583 # Fixing #790093 properly will involve providing providing the key
584 # in some pacagke and maybe updating these paths.
586 # 'dgit-distro.debian.archive-query-tls-curl-args',
587 # '--ca-path=/etc/ssl/ca-debian',
588 # ^ this is a workaround but works (only) on DSA-administered machines
589 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
590 'dgit-distro.debian.git-url-suffix' => '',
591 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
592 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
593 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
594 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
595 'dgit-distro.ubuntu.git-check' => 'false',
596 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
597 'dgit-distro.test-dummy.ssh' => "$td/ssh",
598 'dgit-distro.test-dummy.username' => "alice",
599 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
600 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
601 'dgit-distro.test-dummy.git-url' => "$td/git",
602 'dgit-distro.test-dummy.git-host' => "git",
603 'dgit-distro.test-dummy.git-path' => "$td/git",
604 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
605 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
606 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
607 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
611 our @gitcfgsources = qw(cmdline local global system);
613 sub git_slurp_config () {
614 local ($debuglevel) = $debuglevel-2;
617 # This algoritm is a bit subtle, but this is needed so that for
618 # options which we want to be single-valued, we allow the
619 # different config sources to override properly. See #835858.
620 foreach my $src (@gitcfgsources) {
621 next if $src eq 'cmdline';
622 # we do this ourselves since git doesn't handle it
624 my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
627 open GITS, "-|", @cmd or die $!;
630 printdebug "=> ", (messagequote $_), "\n";
632 push @{ $gitcfgs{$src}{$`} }, $'; #';
636 or ($!==0 && $?==256)
641 sub git_get_config ($) {
643 foreach my $src (@gitcfgsources) {
644 my $l = $gitcfgs{$src}{$c};
645 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
648 @$l==1 or badcfg "multiple values for $c".
649 " (in $src git config)" if @$l > 1;
657 return undef if $c =~ /RETURN-UNDEF/;
658 my $v = git_get_config($c);
659 return $v if defined $v;
660 my $dv = $defcfg{$c};
661 return $dv if defined $dv;
663 badcfg "need value for one of: @_\n".
664 "$us: distro or suite appears not to be (properly) supported";
667 sub access_basedistro () {
668 if (defined $idistro) {
671 return cfg("dgit-suite.$isuite.distro",
672 "dgit.default.distro");
676 sub access_quirk () {
677 # returns (quirk name, distro to use instead or undef, quirk-specific info)
678 my $basedistro = access_basedistro();
679 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
681 if (defined $backports_quirk) {
682 my $re = $backports_quirk;
683 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
685 $re =~ s/\%/([-0-9a-z_]+)/
686 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
687 if ($isuite =~ m/^$re$/) {
688 return ('backports',"$basedistro-backports",$1);
691 return ('none',undef);
696 sub parse_cfg_bool ($$$) {
697 my ($what,$def,$v) = @_;
700 $v =~ m/^[ty1]/ ? 1 :
701 $v =~ m/^[fn0]/ ? 0 :
702 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
705 sub access_forpush_config () {
706 my $d = access_basedistro();
710 parse_cfg_bool('new-private-pushers', 0,
711 cfg("dgit-distro.$d.new-private-pushers",
714 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
717 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
718 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
719 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
720 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
723 sub access_forpush () {
724 $access_forpush //= access_forpush_config();
725 return $access_forpush;
729 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
730 badcfg "pushing but distro is configured readonly"
731 if access_forpush_config() eq '0';
733 $supplementary_message = <<'END' unless $we_are_responder;
734 Push failed, before we got started.
735 You can retry the push, after fixing the problem, if you like.
737 finalise_opts_opts();
741 finalise_opts_opts();
744 sub supplementary_message ($) {
746 if (!$we_are_responder) {
747 $supplementary_message = $msg;
749 } elsif ($protovsn >= 3) {
750 responder_send_command "supplementary-message ".length($msg)
752 print PO $msg or die $!;
756 sub access_distros () {
757 # Returns list of distros to try, in order
760 # 0. `instead of' distro name(s) we have been pointed to
761 # 1. the access_quirk distro, if any
762 # 2a. the user's specified distro, or failing that } basedistro
763 # 2b. the distro calculated from the suite }
764 my @l = access_basedistro();
766 my (undef,$quirkdistro) = access_quirk();
767 unshift @l, $quirkdistro;
768 unshift @l, $instead_distro;
769 @l = grep { defined } @l;
771 if (access_forpush()) {
772 @l = map { ("$_/push", $_) } @l;
777 sub access_cfg_cfgs (@) {
780 # The nesting of these loops determines the search order. We put
781 # the key loop on the outside so that we search all the distros
782 # for each key, before going on to the next key. That means that
783 # if access_cfg is called with a more specific, and then a less
784 # specific, key, an earlier distro can override the less specific
785 # without necessarily overriding any more specific keys. (If the
786 # distro wants to override the more specific keys it can simply do
787 # so; whereas if we did the loop the other way around, it would be
788 # impossible to for an earlier distro to override a less specific
789 # key but not the more specific ones without restating the unknown
790 # values of the more specific keys.
793 # We have to deal with RETURN-UNDEF specially, so that we don't
794 # terminate the search prematurely.
796 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
799 foreach my $d (access_distros()) {
800 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
802 push @cfgs, map { "dgit.default.$_" } @realkeys;
809 my (@cfgs) = access_cfg_cfgs(@keys);
810 my $value = cfg(@cfgs);
814 sub access_cfg_bool ($$) {
815 my ($def, @keys) = @_;
816 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
819 sub string_to_ssh ($) {
821 if ($spec =~ m/\s/) {
822 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
828 sub access_cfg_ssh () {
829 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
830 if (!defined $gitssh) {
833 return string_to_ssh $gitssh;
837 sub access_runeinfo ($) {
839 return ": dgit ".access_basedistro()." $info ;";
842 sub access_someuserhost ($) {
844 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
845 defined($user) && length($user) or
846 $user = access_cfg("$some-user",'username');
847 my $host = access_cfg("$some-host");
848 return length($user) ? "$user\@$host" : $host;
851 sub access_gituserhost () {
852 return access_someuserhost('git');
855 sub access_giturl (;$) {
857 my $url = access_cfg('git-url','RETURN-UNDEF');
860 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
861 return undef unless defined $proto;
864 access_gituserhost().
865 access_cfg('git-path');
867 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
870 return "$url/$package$suffix";
873 sub parsecontrolfh ($$;$) {
874 my ($fh, $desc, $allowsigned) = @_;
875 our $dpkgcontrolhash_noissigned;
878 my %opts = ('name' => $desc);
879 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
880 $c = Dpkg::Control::Hash->new(%opts);
881 $c->parse($fh,$desc) or die "parsing of $desc failed";
882 last if $allowsigned;
883 last if $dpkgcontrolhash_noissigned;
884 my $issigned= $c->get_option('is_pgp_signed');
885 if (!defined $issigned) {
886 $dpkgcontrolhash_noissigned= 1;
887 seek $fh, 0,0 or die "seek $desc: $!";
888 } elsif ($issigned) {
889 fail "control file $desc is (already) PGP-signed. ".
890 " Note that dgit push needs to modify the .dsc and then".
891 " do the signature itself";
900 my ($file, $desc) = @_;
901 my $fh = new IO::Handle;
902 open $fh, '<', $file or die "$file: $!";
903 my $c = parsecontrolfh($fh,$desc);
904 $fh->error and die $!;
910 my ($dctrl,$field) = @_;
911 my $v = $dctrl->{$field};
912 return $v if defined $v;
913 fail "missing field $field in ".$dctrl->get_option('name');
917 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
918 my $p = new IO::Handle;
919 my @cmd = (qw(dpkg-parsechangelog), @_);
920 open $p, '-|', @cmd or die $!;
922 $?=0; $!=0; close $p or failedcmd @cmd;
926 sub commit_getclogp ($) {
927 # Returns the parsed changelog hashref for a particular commit
929 our %commit_getclogp_memo;
930 my $memo = $commit_getclogp_memo{$objid};
931 return $memo if $memo;
933 my $mclog = ".git/dgit/clog-$objid";
934 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
935 "$objid:debian/changelog";
936 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
941 defined $d or fail "getcwd failed: $!";
947 sub archive_query ($) {
949 my $query = access_cfg('archive-query','RETURN-UNDEF');
950 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
953 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
956 sub pool_dsc_subpath ($$) {
957 my ($vsn,$component) = @_; # $package is implict arg
958 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
959 return "/pool/$component/$prefix/$package/".dscfn($vsn);
962 #---------- `ftpmasterapi' archive query method (nascent) ----------
964 sub archive_api_query_cmd ($) {
966 my @cmd = (@curl, qw(-sS));
967 my $url = access_cfg('archive-query-url');
968 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
970 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
971 foreach my $key (split /\:/, $keys) {
972 $key =~ s/\%HOST\%/$host/g;
974 fail "for $url: stat $key: $!" unless $!==ENOENT;
977 fail "config requested specific TLS key but do not know".
978 " how to get curl to use exactly that EE key ($key)";
979 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
980 # # Sadly the above line does not work because of changes
981 # # to gnutls. The real fix for #790093 may involve
982 # # new curl options.
985 # Fixing #790093 properly will involve providing a value
986 # for this on clients.
987 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
988 push @cmd, split / /, $kargs if defined $kargs;
990 push @cmd, $url.$subpath;
996 my ($data, $subpath) = @_;
997 badcfg "ftpmasterapi archive query method takes no data part"
999 my @cmd = archive_api_query_cmd($subpath);
1000 my $url = $cmd[$#cmd];
1001 push @cmd, qw(-w %{http_code});
1002 my $json = cmdoutput @cmd;
1003 unless ($json =~ s/\d+\d+\d$//) {
1004 failedcmd_report_cmd undef, @cmd;
1005 fail "curl failed to print 3-digit HTTP code";
1008 fail "fetch of $url gave HTTP code $code"
1009 unless $url =~ m#^file://# or $code =~ m/^2/;
1010 return decode_json($json);
1013 sub canonicalise_suite_ftpmasterapi () {
1014 my ($proto,$data) = @_;
1015 my $suites = api_query($data, 'suites');
1017 foreach my $entry (@$suites) {
1019 my $v = $entry->{$_};
1020 defined $v && $v eq $isuite;
1021 } qw(codename name);
1022 push @matched, $entry;
1024 fail "unknown suite $isuite" unless @matched;
1027 @matched==1 or die "multiple matches for suite $isuite\n";
1028 $cn = "$matched[0]{codename}";
1029 defined $cn or die "suite $isuite info has no codename\n";
1030 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1032 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1037 sub archive_query_ftpmasterapi () {
1038 my ($proto,$data) = @_;
1039 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1041 my $digester = Digest::SHA->new(256);
1042 foreach my $entry (@$info) {
1044 my $vsn = "$entry->{version}";
1045 my ($ok,$msg) = version_check $vsn;
1046 die "bad version: $msg\n" unless $ok;
1047 my $component = "$entry->{component}";
1048 $component =~ m/^$component_re$/ or die "bad component";
1049 my $filename = "$entry->{filename}";
1050 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1051 or die "bad filename";
1052 my $sha256sum = "$entry->{sha256sum}";
1053 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1054 push @rows, [ $vsn, "/pool/$component/$filename",
1055 $digester, $sha256sum ];
1057 die "bad ftpmaster api response: $@\n".Dumper($entry)
1060 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1064 #---------- `madison' archive query method ----------
1066 sub archive_query_madison {
1067 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1070 sub madison_get_parse {
1071 my ($proto,$data) = @_;
1072 die unless $proto eq 'madison';
1073 if (!length $data) {
1074 $data= access_cfg('madison-distro','RETURN-UNDEF');
1075 $data //= access_basedistro();
1077 $rmad{$proto,$data,$package} ||= cmdoutput
1078 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1079 my $rmad = $rmad{$proto,$data,$package};
1082 foreach my $l (split /\n/, $rmad) {
1083 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1084 \s*( [^ \t|]+ )\s* \|
1085 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1086 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1087 $1 eq $package or die "$rmad $package ?";
1094 $component = access_cfg('archive-query-default-component');
1096 $5 eq 'source' or die "$rmad ?";
1097 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1099 return sort { -version_compare($a->[0],$b->[0]); } @out;
1102 sub canonicalise_suite_madison {
1103 # madison canonicalises for us
1104 my @r = madison_get_parse(@_);
1106 "unable to canonicalise suite using package $package".
1107 " which does not appear to exist in suite $isuite;".
1108 " --existing-package may help";
1112 #---------- `sshpsql' archive query method ----------
1115 my ($data,$runeinfo,$sql) = @_;
1116 if (!length $data) {
1117 $data= access_someuserhost('sshpsql').':'.
1118 access_cfg('sshpsql-dbname');
1120 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1121 my ($userhost,$dbname) = ($`,$'); #';
1123 my @cmd = (access_cfg_ssh, $userhost,
1124 access_runeinfo("ssh-psql $runeinfo").
1125 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1126 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1128 open P, "-|", @cmd or die $!;
1131 printdebug(">|$_|\n");
1134 $!=0; $?=0; close P or failedcmd @cmd;
1136 my $nrows = pop @rows;
1137 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1138 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1139 @rows = map { [ split /\|/, $_ ] } @rows;
1140 my $ncols = scalar @{ shift @rows };
1141 die if grep { scalar @$_ != $ncols } @rows;
1145 sub sql_injection_check {
1146 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1149 sub archive_query_sshpsql ($$) {
1150 my ($proto,$data) = @_;
1151 sql_injection_check $isuite, $package;
1152 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1153 SELECT source.version, component.name, files.filename, files.sha256sum
1155 JOIN src_associations ON source.id = src_associations.source
1156 JOIN suite ON suite.id = src_associations.suite
1157 JOIN dsc_files ON dsc_files.source = source.id
1158 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1159 JOIN component ON component.id = files_archive_map.component_id
1160 JOIN files ON files.id = dsc_files.file
1161 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1162 AND source.source='$package'
1163 AND files.filename LIKE '%.dsc';
1165 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1166 my $digester = Digest::SHA->new(256);
1168 my ($vsn,$component,$filename,$sha256sum) = @$_;
1169 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1174 sub canonicalise_suite_sshpsql ($$) {
1175 my ($proto,$data) = @_;
1176 sql_injection_check $isuite;
1177 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1178 SELECT suite.codename
1179 FROM suite where suite_name='$isuite' or codename='$isuite';
1181 @rows = map { $_->[0] } @rows;
1182 fail "unknown suite $isuite" unless @rows;
1183 die "ambiguous $isuite: @rows ?" if @rows>1;
1187 #---------- `dummycat' archive query method ----------
1189 sub canonicalise_suite_dummycat ($$) {
1190 my ($proto,$data) = @_;
1191 my $dpath = "$data/suite.$isuite";
1192 if (!open C, "<", $dpath) {
1193 $!==ENOENT or die "$dpath: $!";
1194 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1198 chomp or die "$dpath: $!";
1200 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1204 sub archive_query_dummycat ($$) {
1205 my ($proto,$data) = @_;
1206 canonicalise_suite();
1207 my $dpath = "$data/package.$csuite.$package";
1208 if (!open C, "<", $dpath) {
1209 $!==ENOENT or die "$dpath: $!";
1210 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1218 printdebug "dummycat query $csuite $package $dpath | $_\n";
1219 my @row = split /\s+/, $_;
1220 @row==2 or die "$dpath: $_ ?";
1223 C->error and die "$dpath: $!";
1225 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1228 #---------- tag format handling ----------
1230 sub access_cfg_tagformats () {
1231 split /\,/, access_cfg('dgit-tag-format');
1234 sub need_tagformat ($$) {
1235 my ($fmt, $why) = @_;
1236 fail "need to use tag format $fmt ($why) but also need".
1237 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1238 " - no way to proceed"
1239 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1240 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1243 sub select_tagformat () {
1245 return if $tagformatfn && !$tagformat_want;
1246 die 'bug' if $tagformatfn && $tagformat_want;
1247 # ... $tagformat_want assigned after previous select_tagformat
1249 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1250 printdebug "select_tagformat supported @supported\n";
1252 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1253 printdebug "select_tagformat specified @$tagformat_want\n";
1255 my ($fmt,$why,$override) = @$tagformat_want;
1257 fail "target distro supports tag formats @supported".
1258 " but have to use $fmt ($why)"
1260 or grep { $_ eq $fmt } @supported;
1262 $tagformat_want = undef;
1264 $tagformatfn = ${*::}{"debiantag_$fmt"};
1266 fail "trying to use unknown tag format \`$fmt' ($why) !"
1267 unless $tagformatfn;
1270 #---------- archive query entrypoints and rest of program ----------
1272 sub canonicalise_suite () {
1273 return if defined $csuite;
1274 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1275 $csuite = archive_query('canonicalise_suite');
1276 if ($isuite ne $csuite) {
1277 progress "canonical suite name for $isuite is $csuite";
1281 sub get_archive_dsc () {
1282 canonicalise_suite();
1283 my @vsns = archive_query('archive_query');
1284 foreach my $vinfo (@vsns) {
1285 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1286 $dscurl = access_cfg('mirror').$subpath;
1287 $dscdata = url_get($dscurl);
1289 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1294 $digester->add($dscdata);
1295 my $got = $digester->hexdigest();
1297 fail "$dscurl has hash $got but".
1298 " archive told us to expect $digest";
1300 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1301 printdebug Dumper($dscdata) if $debuglevel>1;
1302 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1303 printdebug Dumper($dsc) if $debuglevel>1;
1304 my $fmt = getfield $dsc, 'Format';
1305 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1306 $dsc_checked = !!$digester;
1307 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1311 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1314 sub check_for_git ();
1315 sub check_for_git () {
1317 my $how = access_cfg('git-check');
1318 if ($how eq 'ssh-cmd') {
1320 (access_cfg_ssh, access_gituserhost(),
1321 access_runeinfo("git-check $package").
1322 " set -e; cd ".access_cfg('git-path').";".
1323 " if test -d $package.git; then echo 1; else echo 0; fi");
1324 my $r= cmdoutput @cmd;
1325 if (defined $r and $r =~ m/^divert (\w+)$/) {
1327 my ($usedistro,) = access_distros();
1328 # NB that if we are pushing, $usedistro will be $distro/push
1329 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1330 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1331 progress "diverting to $divert (using config for $instead_distro)";
1332 return check_for_git();
1334 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1336 } elsif ($how eq 'url') {
1337 my $prefix = access_cfg('git-check-url','git-url');
1338 my $suffix = access_cfg('git-check-suffix','git-suffix',
1339 'RETURN-UNDEF') // '.git';
1340 my $url = "$prefix/$package$suffix";
1341 my @cmd = (@curl, qw(-sS -I), $url);
1342 my $result = cmdoutput @cmd;
1343 $result =~ s/^\S+ 200 .*\n\r?\n//;
1344 # curl -sS -I with https_proxy prints
1345 # HTTP/1.0 200 Connection established
1346 $result =~ m/^\S+ (404|200) /s or
1347 fail "unexpected results from git check query - ".
1348 Dumper($prefix, $result);
1350 if ($code eq '404') {
1352 } elsif ($code eq '200') {
1357 } elsif ($how eq 'true') {
1359 } elsif ($how eq 'false') {
1362 badcfg "unknown git-check \`$how'";
1366 sub create_remote_git_repo () {
1367 my $how = access_cfg('git-create');
1368 if ($how eq 'ssh-cmd') {
1370 (access_cfg_ssh, access_gituserhost(),
1371 access_runeinfo("git-create $package").
1372 "set -e; cd ".access_cfg('git-path').";".
1373 " cp -a _template $package.git");
1374 } elsif ($how eq 'true') {
1377 badcfg "unknown git-create \`$how'";
1381 our ($dsc_hash,$lastpush_mergeinput);
1383 our $ud = '.git/dgit/unpack';
1393 sub mktree_in_ud_here () {
1394 runcmd qw(git init -q);
1395 runcmd qw(git config gc.auto 0);
1396 rmtree('.git/objects');
1397 symlink '../../../../objects','.git/objects' or die $!;
1400 sub git_write_tree () {
1401 my $tree = cmdoutput @git, qw(write-tree);
1402 $tree =~ m/^\w+$/ or die "$tree ?";
1406 sub remove_stray_gits () {
1407 my @gitscmd = qw(find -name .git -prune -print0);
1408 debugcmd "|",@gitscmd;
1409 open GITS, "-|", @gitscmd or die $!;
1414 print STDERR "$us: warning: removing from source package: ",
1415 (messagequote $_), "\n";
1419 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1422 sub mktree_in_ud_from_only_subdir (;$) {
1425 # changes into the subdir
1427 die "expected one subdir but found @dirs ?" unless @dirs==1;
1428 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1432 remove_stray_gits();
1433 mktree_in_ud_here();
1435 my ($format, $fopts) = get_source_format();
1436 if (madformat($format)) {
1441 runcmd @git, qw(add -Af);
1442 my $tree=git_write_tree();
1443 return ($tree,$dir);
1446 our @files_csum_info_fields =
1447 (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1448 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1449 ['Files', 'Digest::MD5', 'new()']);
1451 sub dsc_files_info () {
1452 foreach my $csumi (@files_csum_info_fields) {
1453 my ($fname, $module, $method) = @$csumi;
1454 my $field = $dsc->{$fname};
1455 next unless defined $field;
1456 eval "use $module; 1;" or die $@;
1458 foreach (split /\n/, $field) {
1460 m/^(\w+) (\d+) (\S+)$/ or
1461 fail "could not parse .dsc $fname line \`$_'";
1462 my $digester = eval "$module"."->$method;" or die $@;
1467 Digester => $digester,
1472 fail "missing any supported Checksums-* or Files field in ".
1473 $dsc->get_option('name');
1477 map { $_->{Filename} } dsc_files_info();
1480 sub files_compare_inputs (@) {
1485 my $showinputs = sub {
1486 return join "; ", map { $_->get_option('name') } @$inputs;
1489 foreach my $in (@$inputs) {
1491 my $in_name = $in->get_option('name');
1493 printdebug "files_compare_inputs $in_name\n";
1495 foreach my $csumi (@files_csum_info_fields) {
1496 my ($fname) = @$csumi;
1497 printdebug "files_compare_inputs $in_name $fname\n";
1499 my $field = $in->{$fname};
1500 next unless defined $field;
1503 foreach (split /\n/, $field) {
1506 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1507 fail "could not parse $in_name $fname line \`$_'";
1509 printdebug "files_compare_inputs $in_name $fname $f\n";
1513 my $re = \ $record{$f}{$fname};
1515 $fchecked{$f}{$in_name} = 1;
1517 fail "hash or size of $f varies in $fname fields".
1518 " (between: ".$showinputs->().")";
1523 @files = sort @files;
1524 $expected_files //= \@files;
1525 "@$expected_files" eq "@files" or
1526 fail "file list in $in_name varies between hash fields!";
1529 fail "$in_name has no files list field(s)";
1531 printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1534 grep { keys %$_ == @$inputs-1 } values %fchecked
1535 or fail "no file appears in all file lists".
1536 " (looked in: ".$showinputs->().")";
1539 sub is_orig_file_in_dsc ($$) {
1540 my ($f, $dsc_files_info) = @_;
1541 return 0 if @$dsc_files_info <= 1;
1542 # One file means no origs, and the filename doesn't have a "what
1543 # part of dsc" component. (Consider versions ending `.orig'.)
1544 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1548 sub is_orig_file_of_vsn ($$) {
1549 my ($f, $upstreamvsn) = @_;
1550 my $base = srcfn $upstreamvsn, '';
1551 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1555 sub make_commit ($) {
1557 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1560 sub make_commit_text ($) {
1563 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1565 print Dumper($text) if $debuglevel > 1;
1566 my $child = open2($out, $in, @cmd) or die $!;
1569 print $in $text or die $!;
1570 close $in or die $!;
1572 $h =~ m/^\w+$/ or die;
1574 printdebug "=> $h\n";
1577 waitpid $child, 0 == $child or die "$child $!";
1578 $? and failedcmd @cmd;
1582 sub clogp_authline ($) {
1584 my $author = getfield $clogp, 'Maintainer';
1585 $author =~ s#,.*##ms;
1586 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1587 my $authline = "$author $date";
1588 $authline =~ m/$git_authline_re/o or
1589 fail "unexpected commit author line format \`$authline'".
1590 " (was generated from changelog Maintainer field)";
1591 return ($1,$2,$3) if wantarray;
1595 sub vendor_patches_distro ($$) {
1596 my ($checkdistro, $what) = @_;
1597 return unless defined $checkdistro;
1599 my $series = "debian/patches/\L$checkdistro\E.series";
1600 printdebug "checking for vendor-specific $series ($what)\n";
1602 if (!open SERIES, "<", $series) {
1603 die "$series $!" unless $!==ENOENT;
1612 Unfortunately, this source package uses a feature of dpkg-source where
1613 the same source package unpacks to different source code on different
1614 distros. dgit cannot safely operate on such packages on affected
1615 distros, because the meaning of source packages is not stable.
1617 Please ask the distro/maintainer to remove the distro-specific series
1618 files and use a different technique (if necessary, uploading actually
1619 different packages, if different distros are supposed to have
1623 fail "Found active distro-specific series file for".
1624 " $checkdistro ($what): $series, cannot continue";
1626 die "$series $!" if SERIES->error;
1630 sub check_for_vendor_patches () {
1631 # This dpkg-source feature doesn't seem to be documented anywhere!
1632 # But it can be found in the changelog (reformatted):
1634 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1635 # Author: Raphael Hertzog <hertzog@debian.org>
1636 # Date: Sun Oct 3 09:36:48 2010 +0200
1638 # dpkg-source: correctly create .pc/.quilt_series with alternate
1641 # If you have debian/patches/ubuntu.series and you were
1642 # unpacking the source package on ubuntu, quilt was still
1643 # directed to debian/patches/series instead of
1644 # debian/patches/ubuntu.series.
1646 # debian/changelog | 3 +++
1647 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1648 # 2 files changed, 6 insertions(+), 1 deletion(-)
1651 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1652 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1653 "Dpkg::Vendor \`current vendor'");
1654 vendor_patches_distro(access_basedistro(),
1655 "distro being accessed");
1658 sub generate_commits_from_dsc () {
1659 # See big comment in fetch_from_archive, below.
1660 # See also README.dsc-import.
1664 my @dfi = dsc_files_info();
1665 foreach my $fi (@dfi) {
1666 my $f = $fi->{Filename};
1667 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1669 link_ltarget "../../../$f", $f
1673 complete_file_from_dsc('.', $fi)
1676 if (is_orig_file_in_dsc($f, \@dfi)) {
1677 link $f, "../../../../$f"
1683 # We unpack and record the orig tarballs first, so that we only
1684 # need disk space for one private copy of the unpacked source.
1685 # But we can't make them into commits until we have the metadata
1686 # from the debian/changelog, so we record the tree objects now and
1687 # make them into commits later.
1689 my $upstreamv = $dsc->{version};
1690 $upstreamv =~ s/-[^-]+$//;
1691 my $orig_f_base = srcfn $upstreamv, '';
1693 foreach my $fi (@dfi) {
1694 # We actually import, and record as a commit, every tarball
1695 # (unless there is only one file, in which case there seems
1698 my $f = $fi->{Filename};
1699 printdebug "import considering $f ";
1700 (printdebug "only one dfi\n"), next if @dfi == 1;
1701 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1702 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1706 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1708 printdebug "Y ", (join ' ', map { $_//"(none)" }
1709 $compr_ext, $orig_f_part
1712 my $input = new IO::File $f, '<' or die "$f $!";
1716 if (defined $compr_ext) {
1718 Dpkg::Compression::compression_guess_from_filename $f;
1719 fail "Dpkg::Compression cannot handle file $f in source package"
1720 if defined $compr_ext && !defined $cname;
1722 new Dpkg::Compression::Process compression => $cname;
1723 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1724 my $compr_fh = new IO::Handle;
1725 my $compr_pid = open $compr_fh, "-|" // die $!;
1727 open STDIN, "<&", $input or die $!;
1729 die "dgit (child): exec $compr_cmd[0]: $!\n";
1734 rmtree "../unpack-tar";
1735 mkdir "../unpack-tar" or die $!;
1736 my @tarcmd = qw(tar -x -f -
1737 --no-same-owner --no-same-permissions
1738 --no-acls --no-xattrs --no-selinux);
1739 my $tar_pid = fork // die $!;
1741 chdir "../unpack-tar" or die $!;
1742 open STDIN, "<&", $input or die $!;
1744 die "dgit (child): exec $tarcmd[0]: $!";
1746 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1747 !$? or failedcmd @tarcmd;
1750 (@compr_cmd ? failedcmd @compr_cmd
1752 # finally, we have the results in "tarball", but maybe
1753 # with the wrong permissions
1755 runcmd qw(chmod -R +rwX ../unpack-tar);
1756 changedir "../unpack-tar";
1757 my ($tree) = mktree_in_ud_from_only_subdir(1);
1758 changedir "../../unpack";
1759 rmtree "../unpack-tar";
1761 my $ent = [ $f, $tree ];
1763 Orig => !!$orig_f_part,
1764 Sort => (!$orig_f_part ? 2 :
1765 $orig_f_part =~ m/-/g ? 1 :
1773 # put any without "_" first (spec is not clear whether files
1774 # are always in the usual order). Tarballs without "_" are
1775 # the main orig or the debian tarball.
1776 $a->{Sort} <=> $b->{Sort} or
1780 my $any_orig = grep { $_->{Orig} } @tartrees;
1782 my $dscfn = "$package.dsc";
1784 my $treeimporthow = 'package';
1786 open D, ">", $dscfn or die "$dscfn: $!";
1787 print D $dscdata or die "$dscfn: $!";
1788 close D or die "$dscfn: $!";
1789 my @cmd = qw(dpkg-source);
1790 push @cmd, '--no-check' if $dsc_checked;
1791 if (madformat $dsc->{format}) {
1792 push @cmd, '--skip-patches';
1793 $treeimporthow = 'unpatched';
1795 push @cmd, qw(-x --), $dscfn;
1798 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1799 if (madformat $dsc->{format}) {
1800 check_for_vendor_patches();
1804 if (madformat $dsc->{format}) {
1805 my @pcmd = qw(dpkg-source --before-build .);
1806 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1808 runcmd @git, qw(add -Af);
1809 $dappliedtree = git_write_tree();
1812 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1813 debugcmd "|",@clogcmd;
1814 open CLOGS, "-|", @clogcmd or die $!;
1819 printdebug "import clog search...\n";
1822 my $stanzatext = do { local $/=""; <CLOGS>; };
1823 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1824 last if !defined $stanzatext;
1826 my $desc = "package changelog, entry no.$.";
1827 open my $stanzafh, "<", \$stanzatext or die;
1828 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1829 $clogp //= $thisstanza;
1831 printdebug "import clog $thisstanza->{version} $desc...\n";
1833 last if !$any_orig; # we don't need $r1clogp
1835 # We look for the first (most recent) changelog entry whose
1836 # version number is lower than the upstream version of this
1837 # package. Then the last (least recent) previous changelog
1838 # entry is treated as the one which introduced this upstream
1839 # version and used for the synthetic commits for the upstream
1842 # One might think that a more sophisticated algorithm would be
1843 # necessary. But: we do not want to scan the whole changelog
1844 # file. Stopping when we see an earlier version, which
1845 # necessarily then is an earlier upstream version, is the only
1846 # realistic way to do that. Then, either the earliest
1847 # changelog entry we have seen so far is indeed the earliest
1848 # upload of this upstream version; or there are only changelog
1849 # entries relating to later upstream versions (which is not
1850 # possible unless the changelog and .dsc disagree about the
1851 # version). Then it remains to choose between the physically
1852 # last entry in the file, and the one with the lowest version
1853 # number. If these are not the same, we guess that the
1854 # versions were created in a non-monotic order rather than
1855 # that the changelog entries have been misordered.
1857 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1859 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1860 $r1clogp = $thisstanza;
1862 printdebug "import clog $r1clogp->{version} becomes r1\n";
1864 die $! if CLOGS->error;
1865 close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
1867 $clogp or fail "package changelog has no entries!";
1869 my $authline = clogp_authline $clogp;
1870 my $changes = getfield $clogp, 'Changes';
1871 my $cversion = getfield $clogp, 'Version';
1874 $r1clogp //= $clogp; # maybe there's only one entry;
1875 my $r1authline = clogp_authline $r1clogp;
1876 # Strictly, r1authline might now be wrong if it's going to be
1877 # unused because !$any_orig. Whatever.
1879 printdebug "import tartrees authline $authline\n";
1880 printdebug "import tartrees r1authline $r1authline\n";
1882 foreach my $tt (@tartrees) {
1883 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1885 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1888 committer $r1authline
1892 [dgit import orig $tt->{F}]
1900 [dgit import tarball $package $cversion $tt->{F}]
1905 printdebug "import main commit\n";
1907 open C, ">../commit.tmp" or die $!;
1908 print C <<END or die $!;
1911 print C <<END or die $! foreach @tartrees;
1914 print C <<END or die $!;
1920 [dgit import $treeimporthow $package $cversion]
1924 my $rawimport_hash = make_commit qw(../commit.tmp);
1926 if (madformat $dsc->{format}) {
1927 printdebug "import apply patches...\n";
1929 # regularise the state of the working tree so that
1930 # the checkout of $rawimport_hash works nicely.
1931 my $dappliedcommit = make_commit_text(<<END);
1938 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1940 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1942 # We need the answers to be reproducible
1943 my @authline = clogp_authline($clogp);
1944 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1945 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1946 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1947 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1948 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1949 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1952 runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
1956 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
1960 my $gapplied = git_rev_parse('HEAD');
1961 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1962 $gappliedtree eq $dappliedtree or
1964 gbp-pq import and dpkg-source disagree!
1965 gbp-pq import gave commit $gapplied
1966 gbp-pq import gave tree $gappliedtree
1967 dpkg-source --before-build gave tree $dappliedtree
1969 $rawimport_hash = $gapplied;
1972 progress "synthesised git commit from .dsc $cversion";
1974 my $rawimport_mergeinput = {
1975 Commit => $rawimport_hash,
1976 Info => "Import of source package",
1978 my @output = ($rawimport_mergeinput);
1980 if ($lastpush_mergeinput) {
1981 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1982 my $oversion = getfield $oldclogp, 'Version';
1984 version_compare($oversion, $cversion);
1986 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1987 { Message => <<END, ReverseParents => 1 });
1988 Record $package ($cversion) in archive suite $csuite
1990 } elsif ($vcmp > 0) {
1991 print STDERR <<END or die $!;
1993 Version actually in archive: $cversion (older)
1994 Last version pushed with dgit: $oversion (newer or same)
1997 @output = $lastpush_mergeinput;
1999 # Same version. Use what's in the server git branch,
2000 # discarding our own import. (This could happen if the
2001 # server automatically imports all packages into git.)
2002 @output = $lastpush_mergeinput;
2005 changedir '../../../..';
2010 sub complete_file_from_dsc ($$) {
2011 our ($dstdir, $fi) = @_;
2012 # Ensures that we have, in $dir, the file $fi, with the correct
2013 # contents. (Downloading it from alongside $dscurl if necessary.)
2015 my $f = $fi->{Filename};
2016 my $tf = "$dstdir/$f";
2019 if (stat_exists $tf) {
2020 progress "using existing $f";
2023 $furl =~ s{/[^/]+$}{};
2025 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2026 die "$f ?" if $f =~ m#/#;
2027 runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2028 return 0 if !act_local();
2032 open F, "<", "$tf" or die "$tf: $!";
2033 $fi->{Digester}->reset();
2034 $fi->{Digester}->addfile(*F);
2035 F->error and die $!;
2036 my $got = $fi->{Digester}->hexdigest();
2037 $got eq $fi->{Hash} or
2038 fail "file $f has hash $got but .dsc".
2039 " demands hash $fi->{Hash} ".
2040 ($downloaded ? "(got wrong file from archive!)"
2041 : "(perhaps you should delete this file?)");
2046 sub ensure_we_have_orig () {
2047 my @dfi = dsc_files_info();
2048 foreach my $fi (@dfi) {
2049 my $f = $fi->{Filename};
2050 next unless is_orig_file_in_dsc($f, \@dfi);
2051 complete_file_from_dsc('..', $fi)
2056 sub git_fetch_us () {
2057 # Want to fetch only what we are going to use, unless
2058 # deliberately-not-ff, in which case we must fetch everything.
2060 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2062 (quiltmode_splitbrain
2063 ? (map { $_->('*',access_basedistro) }
2064 \&debiantag_new, \&debiantag_maintview)
2065 : debiantags('*',access_basedistro));
2066 push @specs, server_branch($csuite);
2067 push @specs, qw(heads/*) if deliberately_not_fast_forward;
2069 # This is rather miserable:
2070 # When git fetch --prune is passed a fetchspec ending with a *,
2071 # it does a plausible thing. If there is no * then:
2072 # - it matches subpaths too, even if the supplied refspec
2073 # starts refs, and behaves completely madly if the source
2074 # has refs/refs/something. (See, for example, Debian #NNNN.)
2075 # - if there is no matching remote ref, it bombs out the whole
2077 # We want to fetch a fixed ref, and we don't know in advance
2078 # if it exists, so this is not suitable.
2080 # Our workaround is to use git ls-remote. git ls-remote has its
2081 # own qairks. Notably, it has the absurd multi-tail-matching
2082 # behaviour: git ls-remote R refs/foo can report refs/foo AND
2083 # refs/refs/foo etc.
2085 # Also, we want an idempotent snapshot, but we have to make two
2086 # calls to the remote: one to git ls-remote and to git fetch. The
2087 # solution is use git ls-remote to obtain a target state, and
2088 # git fetch to try to generate it. If we don't manage to generate
2089 # the target state, we try again.
2091 my $specre = join '|', map {
2097 printdebug "git_fetch_us specre=$specre\n";
2098 my $wanted_rref = sub {
2100 return m/^(?:$specre)$/o;
2103 my $fetch_iteration = 0;
2106 if (++$fetch_iteration > 10) {
2107 fail "too many iterations trying to get sane fetch!";
2110 my @look = map { "refs/$_" } @specs;
2111 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2115 open GITLS, "-|", @lcmd or die $!;
2117 printdebug "=> ", $_;
2118 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2119 my ($objid,$rrefname) = ($1,$2);
2120 if (!$wanted_rref->($rrefname)) {
2122 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2126 $wantr{$rrefname} = $objid;
2129 close GITLS or failedcmd @lcmd;
2131 # OK, now %want is exactly what we want for refs in @specs
2133 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2134 "+refs/$_:".lrfetchrefs."/$_";
2137 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2138 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2141 %lrfetchrefs_f = ();
2144 git_for_each_ref(lrfetchrefs, sub {
2145 my ($objid,$objtype,$lrefname,$reftail) = @_;
2146 $lrfetchrefs_f{$lrefname} = $objid;
2147 $objgot{$objid} = 1;
2150 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2151 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2152 if (!exists $wantr{$rrefname}) {
2153 if ($wanted_rref->($rrefname)) {
2155 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2159 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2162 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2163 delete $lrfetchrefs_f{$lrefname};
2167 foreach my $rrefname (sort keys %wantr) {
2168 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2169 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2170 my $want = $wantr{$rrefname};
2171 next if $got eq $want;
2172 if (!defined $objgot{$want}) {
2174 warning: git ls-remote suggests we want $lrefname
2175 warning: and it should refer to $want
2176 warning: but git fetch didn't fetch that object to any relevant ref.
2177 warning: This may be due to a race with someone updating the server.
2178 warning: Will try again...
2180 next FETCH_ITERATION;
2183 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2185 runcmd_ordryrun_local @git, qw(update-ref -m),
2186 "dgit fetch git fetch fixup", $lrefname, $want;
2187 $lrfetchrefs_f{$lrefname} = $want;
2191 printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2192 Dumper(\%lrfetchrefs_f);
2195 my @tagpats = debiantags('*',access_basedistro);
2197 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2198 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2199 printdebug "currently $fullrefname=$objid\n";
2200 $here{$fullrefname} = $objid;
2202 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2203 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2204 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2205 printdebug "offered $lref=$objid\n";
2206 if (!defined $here{$lref}) {
2207 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2208 runcmd_ordryrun_local @upd;
2209 lrfetchref_used $fullrefname;
2210 } elsif ($here{$lref} eq $objid) {
2211 lrfetchref_used $fullrefname;
2214 "Not updateting $lref from $here{$lref} to $objid.\n";
2219 sub mergeinfo_getclogp ($) {
2220 # Ensures thit $mi->{Clogp} exists and returns it
2222 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2225 sub mergeinfo_version ($) {
2226 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2229 sub fetch_from_archive () {
2230 ensure_setup_existing_tree();
2232 # Ensures that lrref() is what is actually in the archive, one way
2233 # or another, according to us - ie this client's
2234 # appropritaely-updated archive view. Also returns the commit id.
2235 # If there is nothing in the archive, leaves lrref alone and
2236 # returns undef. git_fetch_us must have already been called.
2240 foreach my $field (@ourdscfield) {
2241 $dsc_hash = $dsc->{$field};
2242 last if defined $dsc_hash;
2244 if (defined $dsc_hash) {
2245 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2247 progress "last upload to archive specified git hash";
2249 progress "last upload to archive has NO git hash";
2252 progress "no version available from the archive";
2255 # If the archive's .dsc has a Dgit field, there are three
2256 # relevant git commitids we need to choose between and/or merge
2258 # 1. $dsc_hash: the Dgit field from the archive
2259 # 2. $lastpush_hash: the suite branch on the dgit git server
2260 # 3. $lastfetch_hash: our local tracking brach for the suite
2262 # These may all be distinct and need not be in any fast forward
2265 # If the dsc was pushed to this suite, then the server suite
2266 # branch will have been updated; but it might have been pushed to
2267 # a different suite and copied by the archive. Conversely a more
2268 # recent version may have been pushed with dgit but not appeared
2269 # in the archive (yet).
2271 # $lastfetch_hash may be awkward because archive imports
2272 # (particularly, imports of Dgit-less .dscs) are performed only as
2273 # needed on individual clients, so different clients may perform a
2274 # different subset of them - and these imports are only made
2275 # public during push. So $lastfetch_hash may represent a set of
2276 # imports different to a subsequent upload by a different dgit
2279 # Our approach is as follows:
2281 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2282 # descendant of $dsc_hash, then it was pushed by a dgit user who
2283 # had based their work on $dsc_hash, so we should prefer it.
2284 # Otherwise, $dsc_hash was installed into this suite in the
2285 # archive other than by a dgit push, and (necessarily) after the
2286 # last dgit push into that suite (since a dgit push would have
2287 # been descended from the dgit server git branch); thus, in that
2288 # case, we prefer the archive's version (and produce a
2289 # pseudo-merge to overwrite the dgit server git branch).
2291 # (If there is no Dgit field in the archive's .dsc then
2292 # generate_commit_from_dsc uses the version numbers to decide
2293 # whether the suite branch or the archive is newer. If the suite
2294 # branch is newer it ignores the archive's .dsc; otherwise it
2295 # generates an import of the .dsc, and produces a pseudo-merge to
2296 # overwrite the suite branch with the archive contents.)
2298 # The outcome of that part of the algorithm is the `public view',
2299 # and is same for all dgit clients: it does not depend on any
2300 # unpublished history in the local tracking branch.
2302 # As between the public view and the local tracking branch: The
2303 # local tracking branch is only updated by dgit fetch, and
2304 # whenever dgit fetch runs it includes the public view in the
2305 # local tracking branch. Therefore if the public view is not
2306 # descended from the local tracking branch, the local tracking
2307 # branch must contain history which was imported from the archive
2308 # but never pushed; and, its tip is now out of date. So, we make
2309 # a pseudo-merge to overwrite the old imports and stitch the old
2312 # Finally: we do not necessarily reify the public view (as
2313 # described above). This is so that we do not end up stacking two
2314 # pseudo-merges. So what we actually do is figure out the inputs
2315 # to any public view pseudo-merge and put them in @mergeinputs.
2318 # $mergeinputs[]{Commit}
2319 # $mergeinputs[]{Info}
2320 # $mergeinputs[0] is the one whose tree we use
2321 # @mergeinputs is in the order we use in the actual commit)
2324 # $mergeinputs[]{Message} is a commit message to use
2325 # $mergeinputs[]{ReverseParents} if def specifies that parent
2326 # list should be in opposite order
2327 # Such an entry has no Commit or Info. It applies only when found
2328 # in the last entry. (This ugliness is to support making
2329 # identical imports to previous dgit versions.)
2331 my $lastpush_hash = git_get_ref(lrfetchref());
2332 printdebug "previous reference hash=$lastpush_hash\n";
2333 $lastpush_mergeinput = $lastpush_hash && {
2334 Commit => $lastpush_hash,
2335 Info => "dgit suite branch on dgit git server",
2338 my $lastfetch_hash = git_get_ref(lrref());
2339 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2340 my $lastfetch_mergeinput = $lastfetch_hash && {
2341 Commit => $lastfetch_hash,
2342 Info => "dgit client's archive history view",
2345 my $dsc_mergeinput = $dsc_hash && {
2346 Commit => $dsc_hash,
2347 Info => "Dgit field in .dsc from archive",
2351 my $del_lrfetchrefs = sub {
2354 printdebug "del_lrfetchrefs...\n";
2355 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2356 my $objid = $lrfetchrefs_d{$fullrefname};
2357 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2359 $gur ||= new IO::Handle;
2360 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2362 printf $gur "delete %s %s\n", $fullrefname, $objid;
2365 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2369 if (defined $dsc_hash) {
2370 fail "missing remote git history even though dsc has hash -".
2371 " could not find ref ".rref()." at ".access_giturl()
2372 unless $lastpush_hash;
2373 ensure_we_have_orig();
2374 if ($dsc_hash eq $lastpush_hash) {
2375 @mergeinputs = $dsc_mergeinput
2376 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2377 print STDERR <<END or die $!;
2379 Git commit in archive is behind the last version allegedly pushed/uploaded.
2380 Commit referred to by archive: $dsc_hash
2381 Last version pushed with dgit: $lastpush_hash
2384 @mergeinputs = ($lastpush_mergeinput);
2386 # Archive has .dsc which is not a descendant of the last dgit
2387 # push. This can happen if the archive moves .dscs about.
2388 # Just follow its lead.
2389 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2390 progress "archive .dsc names newer git commit";
2391 @mergeinputs = ($dsc_mergeinput);
2393 progress "archive .dsc names other git commit, fixing up";
2394 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2398 @mergeinputs = generate_commits_from_dsc();
2399 # We have just done an import. Now, our import algorithm might
2400 # have been improved. But even so we do not want to generate
2401 # a new different import of the same package. So if the
2402 # version numbers are the same, just use our existing version.
2403 # If the version numbers are different, the archive has changed
2404 # (perhaps, rewound).
2405 if ($lastfetch_mergeinput &&
2406 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2407 (mergeinfo_version $mergeinputs[0]) )) {
2408 @mergeinputs = ($lastfetch_mergeinput);
2410 } elsif ($lastpush_hash) {
2411 # only in git, not in the archive yet
2412 @mergeinputs = ($lastpush_mergeinput);
2413 print STDERR <<END or die $!;
2415 Package not found in the archive, but has allegedly been pushed using dgit.
2419 printdebug "nothing found!\n";
2420 if (defined $skew_warning_vsn) {
2421 print STDERR <<END or die $!;
2423 Warning: relevant archive skew detected.
2424 Archive allegedly contains $skew_warning_vsn
2425 But we were not able to obtain any version from the archive or git.
2429 unshift @end, $del_lrfetchrefs;
2433 if ($lastfetch_hash &&
2435 my $h = $_->{Commit};
2436 $h and is_fast_fwd($lastfetch_hash, $h);
2437 # If true, one of the existing parents of this commit
2438 # is a descendant of the $lastfetch_hash, so we'll
2439 # be ff from that automatically.
2443 push @mergeinputs, $lastfetch_mergeinput;
2446 printdebug "fetch mergeinfos:\n";
2447 foreach my $mi (@mergeinputs) {
2449 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2451 printdebug sprintf " ReverseParents=%d Message=%s",
2452 $mi->{ReverseParents}, $mi->{Message};
2456 my $compat_info= pop @mergeinputs
2457 if $mergeinputs[$#mergeinputs]{Message};
2459 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2462 if (@mergeinputs > 1) {
2464 my $tree_commit = $mergeinputs[0]{Commit};
2466 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2467 $tree =~ m/\n\n/; $tree = $`;
2468 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2471 # We use the changelog author of the package in question the
2472 # author of this pseudo-merge. This is (roughly) correct if
2473 # this commit is simply representing aa non-dgit upload.
2474 # (Roughly because it does not record sponsorship - but we
2475 # don't have sponsorship info because that's in the .changes,
2476 # which isn't in the archivw.)
2478 # But, it might be that we are representing archive history
2479 # updates (including in-archive copies). These are not really
2480 # the responsibility of the person who created the .dsc, but
2481 # there is no-one whose name we should better use. (The
2482 # author of the .dsc-named commit is clearly worse.)
2484 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2485 my $author = clogp_authline $useclogp;
2486 my $cversion = getfield $useclogp, 'Version';
2488 my $mcf = ".git/dgit/mergecommit";
2489 open MC, ">", $mcf or die "$mcf $!";
2490 print MC <<END or die $!;
2494 my @parents = grep { $_->{Commit} } @mergeinputs;
2495 @parents = reverse @parents if $compat_info->{ReverseParents};
2496 print MC <<END or die $! foreach @parents;
2500 print MC <<END or die $!;
2506 if (defined $compat_info->{Message}) {
2507 print MC $compat_info->{Message} or die $!;
2509 print MC <<END or die $!;
2510 Record $package ($cversion) in archive suite $csuite
2514 my $message_add_info = sub {
2516 my $mversion = mergeinfo_version $mi;
2517 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2521 $message_add_info->($mergeinputs[0]);
2522 print MC <<END or die $!;
2523 should be treated as descended from
2525 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2529 $hash = make_commit $mcf;
2531 $hash = $mergeinputs[0]{Commit};
2533 printdebug "fetch hash=$hash\n";
2536 my ($lasth, $what) = @_;
2537 return unless $lasth;
2538 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2541 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2542 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2544 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2545 'DGIT_ARCHIVE', $hash;
2546 cmdoutput @git, qw(log -n2), $hash;
2547 # ... gives git a chance to complain if our commit is malformed
2549 if (defined $skew_warning_vsn) {
2551 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2552 my $gotclogp = commit_getclogp($hash);
2553 my $got_vsn = getfield $gotclogp, 'Version';
2554 printdebug "SKEW CHECK GOT $got_vsn\n";
2555 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2556 print STDERR <<END or die $!;
2558 Warning: archive skew detected. Using the available version:
2559 Archive allegedly contains $skew_warning_vsn
2560 We were able to obtain only $got_vsn
2566 if ($lastfetch_hash ne $hash) {
2567 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2571 dryrun_report @upd_cmd;
2575 lrfetchref_used lrfetchref();
2577 unshift @end, $del_lrfetchrefs;
2581 sub set_local_git_config ($$) {
2583 runcmd @git, qw(config), $k, $v;
2586 sub setup_mergechangelogs (;$) {
2588 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2590 my $driver = 'dpkg-mergechangelogs';
2591 my $cb = "merge.$driver";
2592 my $attrs = '.git/info/attributes';
2593 ensuredir '.git/info';
2595 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2596 if (!open ATTRS, "<", $attrs) {
2597 $!==ENOENT or die "$attrs: $!";
2601 next if m{^debian/changelog\s};
2602 print NATTRS $_, "\n" or die $!;
2604 ATTRS->error and die $!;
2607 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2610 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2611 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2613 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2616 sub setup_useremail (;$) {
2618 return unless $always || access_cfg_bool(1, 'setup-useremail');
2621 my ($k, $envvar) = @_;
2622 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2623 return unless defined $v;
2624 set_local_git_config "user.$k", $v;
2627 $setup->('email', 'DEBEMAIL');
2628 $setup->('name', 'DEBFULLNAME');
2631 sub ensure_setup_existing_tree () {
2632 my $k = "remote.$remotename.skipdefaultupdate";
2633 my $c = git_get_config $k;
2634 return if defined $c;
2635 set_local_git_config $k, 'true';
2638 sub setup_new_tree () {
2639 setup_mergechangelogs();
2645 canonicalise_suite();
2646 badusage "dry run makes no sense with clone" unless act_local();
2647 my $hasgit = check_for_git();
2648 mkdir $dstdir or fail "create \`$dstdir': $!";
2650 runcmd @git, qw(init -q);
2651 my $giturl = access_giturl(1);
2652 if (defined $giturl) {
2653 open H, "> .git/HEAD" or die $!;
2654 print H "ref: ".lref()."\n" or die $!;
2656 runcmd @git, qw(remote add), 'origin', $giturl;
2659 progress "fetching existing git history";
2661 runcmd_ordryrun_local @git, qw(fetch origin);
2663 progress "starting new git history";
2665 fetch_from_archive() or no_such_package;
2666 my $vcsgiturl = $dsc->{'Vcs-Git'};
2667 if (length $vcsgiturl) {
2668 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2669 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2672 runcmd @git, qw(reset --hard), lrref();
2673 printdone "ready for work in $dstdir";
2677 if (check_for_git()) {
2680 fetch_from_archive() or no_such_package();
2681 printdone "fetched into ".lrref();
2686 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2688 printdone "fetched to ".lrref()." and merged into HEAD";
2691 sub check_not_dirty () {
2692 foreach my $f (qw(local-options local-patch-header)) {
2693 if (stat_exists "debian/source/$f") {
2694 fail "git tree contains debian/source/$f";
2698 return if $ignoredirty;
2700 my @cmd = (@git, qw(diff --quiet HEAD));
2702 $!=0; $?=-1; system @cmd;
2705 fail "working tree is dirty (does not match HEAD)";
2711 sub commit_admin ($) {
2714 runcmd_ordryrun_local @git, qw(commit -m), $m;
2717 sub commit_quilty_patch () {
2718 my $output = cmdoutput @git, qw(status --porcelain);
2720 foreach my $l (split /\n/, $output) {
2721 next unless $l =~ m/\S/;
2722 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2726 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2728 progress "nothing quilty to commit, ok.";
2731 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2732 runcmd_ordryrun_local @git, qw(add -f), @adds;
2734 Commit Debian 3.0 (quilt) metadata
2736 [dgit ($our_version) quilt-fixup]
2740 sub get_source_format () {
2742 if (open F, "debian/source/options") {
2746 s/\s+$//; # ignore missing final newline
2748 my ($k, $v) = ($`, $'); #');
2749 $v =~ s/^"(.*)"$/$1/;
2755 F->error and die $!;
2758 die $! unless $!==&ENOENT;
2761 if (!open F, "debian/source/format") {
2762 die $! unless $!==&ENOENT;
2766 F->error and die $!;
2768 return ($_, \%options);
2771 sub madformat_wantfixup ($) {
2773 return 0 unless $format eq '3.0 (quilt)';
2774 our $quilt_mode_warned;
2775 if ($quilt_mode eq 'nocheck') {
2776 progress "Not doing any fixup of \`$format' due to".
2777 " ----no-quilt-fixup or --quilt=nocheck"
2778 unless $quilt_mode_warned++;
2781 progress "Format \`$format', need to check/update patch stack"
2782 unless $quilt_mode_warned++;
2786 # An "infopair" is a tuple [ $thing, $what ]
2787 # (often $thing is a commit hash; $what is a description)
2789 sub infopair_cond_equal ($$) {
2791 $x->[0] eq $y->[0] or fail <<END;
2792 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2796 sub infopair_lrf_tag_lookup ($$) {
2797 my ($tagnames, $what) = @_;
2798 # $tagname may be an array ref
2799 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2800 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2801 foreach my $tagname (@tagnames) {
2802 my $lrefname = lrfetchrefs."/tags/$tagname";
2803 my $tagobj = $lrfetchrefs_f{$lrefname};
2804 next unless defined $tagobj;
2805 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2806 return [ git_rev_parse($tagobj), $what ];
2808 fail @tagnames==1 ? <<END : <<END;
2809 Wanted tag $what (@tagnames) on dgit server, but not found
2811 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2815 sub infopair_cond_ff ($$) {
2816 my ($anc,$desc) = @_;
2817 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2818 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2822 sub pseudomerge_version_check ($$) {
2823 my ($clogp, $archive_hash) = @_;
2825 my $arch_clogp = commit_getclogp $archive_hash;
2826 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2827 'version currently in archive' ];
2828 if (defined $overwrite_version) {
2829 if (length $overwrite_version) {
2830 infopair_cond_equal([ $overwrite_version,
2831 '--overwrite= version' ],
2834 my $v = $i_arch_v->[0];
2835 progress "Checking package changelog for archive version $v ...";
2837 my @xa = ("-f$v", "-t$v");
2838 my $vclogp = parsechangelog @xa;
2839 my $cv = [ (getfield $vclogp, 'Version'),
2840 "Version field from dpkg-parsechangelog @xa" ];
2841 infopair_cond_equal($i_arch_v, $cv);
2844 $@ =~ s/^dgit: //gm;
2846 "Perhaps debian/changelog does not mention $v ?";
2851 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2855 sub pseudomerge_make_commit ($$$$ $$) {
2856 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2857 $msg_cmd, $msg_msg) = @_;
2858 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2860 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2861 my $authline = clogp_authline $clogp;
2865 !defined $overwrite_version ? ""
2866 : !length $overwrite_version ? " --overwrite"
2867 : " --overwrite=".$overwrite_version;
2870 my $pmf = ".git/dgit/pseudomerge";
2871 open MC, ">", $pmf or die "$pmf $!";
2872 print MC <<END or die $!;
2875 parent $archive_hash
2885 return make_commit($pmf);
2888 sub splitbrain_pseudomerge ($$$$) {
2889 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2890 # => $merged_dgitview
2891 printdebug "splitbrain_pseudomerge...\n";
2893 # We: debian/PREVIOUS HEAD($maintview)
2894 # expect: o ----------------- o
2897 # a/d/PREVIOUS $dgitview
2900 # we do: `------------------ o
2904 printdebug "splitbrain_pseudomerge...\n";
2906 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2908 return $dgitview unless defined $archive_hash;
2910 if (!defined $overwrite_version) {
2911 progress "Checking that HEAD inciudes all changes in archive...";
2914 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2916 if (defined $overwrite_version) {
2918 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2919 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2920 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2921 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2922 my $i_archive = [ $archive_hash, "current archive contents" ];
2924 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2926 infopair_cond_equal($i_dgit, $i_archive);
2927 infopair_cond_ff($i_dep14, $i_dgit);
2928 infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2932 $us: check failed (maybe --overwrite is needed, consult documentation)
2937 my $r = pseudomerge_make_commit
2938 $clogp, $dgitview, $archive_hash, $i_arch_v,
2939 "dgit --quilt=$quilt_mode",
2940 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2941 Declare fast forward from $i_arch_v->[0]
2943 Make fast forward from $i_arch_v->[0]
2946 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2950 sub plain_overwrite_pseudomerge ($$$) {
2951 my ($clogp, $head, $archive_hash) = @_;
2953 printdebug "plain_overwrite_pseudomerge...";
2955 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2957 return $head if is_fast_fwd $archive_hash, $head;
2959 my $m = "Declare fast forward from $i_arch_v->[0]";
2961 my $r = pseudomerge_make_commit
2962 $clogp, $head, $archive_hash, $i_arch_v,
2965 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2967 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2971 sub push_parse_changelog ($) {
2974 my $clogp = Dpkg::Control::Hash->new();
2975 $clogp->load($clogpfn) or die;
2977 $package = getfield $clogp, 'Source';
2978 my $cversion = getfield $clogp, 'Version';
2979 my $tag = debiantag($cversion, access_basedistro);
2980 runcmd @git, qw(check-ref-format), $tag;
2982 my $dscfn = dscfn($cversion);
2984 return ($clogp, $cversion, $dscfn);
2987 sub push_parse_dsc ($$$) {
2988 my ($dscfn,$dscfnwhat, $cversion) = @_;
2989 $dsc = parsecontrol($dscfn,$dscfnwhat);
2990 my $dversion = getfield $dsc, 'Version';
2991 my $dscpackage = getfield $dsc, 'Source';
2992 ($dscpackage eq $package && $dversion eq $cversion) or
2993 fail "$dscfn is for $dscpackage $dversion".
2994 " but debian/changelog is for $package $cversion";
2997 sub push_tagwants ($$$$) {
2998 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3001 TagFn => \&debiantag,
3006 if (defined $maintviewhead) {
3008 TagFn => \&debiantag_maintview,
3009 Objid => $maintviewhead,
3010 TfSuffix => '-maintview',
3014 foreach my $tw (@tagwants) {
3015 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3016 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3018 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3022 sub push_mktags ($$ $$ $) {
3024 $changesfile,$changesfilewhat,
3027 die unless $tagwants->[0]{View} eq 'dgit';
3029 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3030 $dsc->save("$dscfn.tmp") or die $!;
3032 my $changes = parsecontrol($changesfile,$changesfilewhat);
3033 foreach my $field (qw(Source Distribution Version)) {
3034 $changes->{$field} eq $clogp->{$field} or
3035 fail "changes field $field \`$changes->{$field}'".
3036 " does not match changelog \`$clogp->{$field}'";
3039 my $cversion = getfield $clogp, 'Version';
3040 my $clogsuite = getfield $clogp, 'Distribution';
3042 # We make the git tag by hand because (a) that makes it easier
3043 # to control the "tagger" (b) we can do remote signing
3044 my $authline = clogp_authline $clogp;
3045 my $delibs = join(" ", "",@deliberatelies);
3046 my $declaredistro = access_basedistro();
3050 my $tfn = $tw->{Tfn};
3051 my $head = $tw->{Objid};
3052 my $tag = $tw->{Tag};
3054 open TO, '>', $tfn->('.tmp') or die $!;
3055 print TO <<END or die $!;
3062 if ($tw->{View} eq 'dgit') {
3063 print TO <<END or die $!;
3064 $package release $cversion for $clogsuite ($csuite) [dgit]
3065 [dgit distro=$declaredistro$delibs]
3067 foreach my $ref (sort keys %previously) {
3068 print TO <<END or die $!;
3069 [dgit previously:$ref=$previously{$ref}]
3072 } elsif ($tw->{View} eq 'maint') {
3073 print TO <<END or die $!;
3074 $package release $cversion for $clogsuite ($csuite)
3075 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3078 die Dumper($tw)."?";
3083 my $tagobjfn = $tfn->('.tmp');
3085 if (!defined $keyid) {
3086 $keyid = access_cfg('keyid','RETURN-UNDEF');
3088 if (!defined $keyid) {
3089 $keyid = getfield $clogp, 'Maintainer';
3091 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3092 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3093 push @sign_cmd, qw(-u),$keyid if defined $keyid;
3094 push @sign_cmd, $tfn->('.tmp');
3095 runcmd_ordryrun @sign_cmd;
3097 $tagobjfn = $tfn->('.signed.tmp');
3098 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3099 $tfn->('.tmp'), $tfn->('.tmp.asc');
3105 my @r = map { $mktag->($_); } @$tagwants;
3109 sub sign_changes ($) {
3110 my ($changesfile) = @_;
3112 my @debsign_cmd = @debsign;
3113 push @debsign_cmd, "-k$keyid" if defined $keyid;
3114 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3115 push @debsign_cmd, $changesfile;
3116 runcmd_ordryrun @debsign_cmd;
3121 printdebug "actually entering push\n";
3123 supplementary_message(<<'END');
3124 Push failed, while checking state of the archive.
3125 You can retry the push, after fixing the problem, if you like.
3127 if (check_for_git()) {
3130 my $archive_hash = fetch_from_archive();
3131 if (!$archive_hash) {
3133 fail "package appears to be new in this suite;".
3134 " if this is intentional, use --new";
3137 supplementary_message(<<'END');
3138 Push failed, while preparing your push.
3139 You can retry the push, after fixing the problem, if you like.
3142 need_tagformat 'new', "quilt mode $quilt_mode"
3143 if quiltmode_splitbrain;
3147 access_giturl(); # check that success is vaguely likely
3150 my $clogpfn = ".git/dgit/changelog.822.tmp";
3151 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3153 responder_send_file('parsed-changelog', $clogpfn);
3155 my ($clogp, $cversion, $dscfn) =
3156 push_parse_changelog("$clogpfn");
3158 my $dscpath = "$buildproductsdir/$dscfn";
3159 stat_exists $dscpath or
3160 fail "looked for .dsc $dscfn, but $!;".
3161 " maybe you forgot to build";
3163 responder_send_file('dsc', $dscpath);
3165 push_parse_dsc($dscpath, $dscfn, $cversion);
3167 my $format = getfield $dsc, 'Format';
3168 printdebug "format $format\n";
3170 my $actualhead = git_rev_parse('HEAD');
3171 my $dgithead = $actualhead;
3172 my $maintviewhead = undef;
3174 if (madformat_wantfixup($format)) {
3175 # user might have not used dgit build, so maybe do this now:
3176 if (quiltmode_splitbrain()) {
3177 my $upstreamversion = $clogp->{Version};
3178 $upstreamversion =~ s/-[^-]*$//;
3180 quilt_make_fake_dsc($upstreamversion);
3182 ($dgithead, $cachekey) =
3183 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3185 "--quilt=$quilt_mode but no cached dgit view:
3186 perhaps tree changed since dgit build[-source] ?";
3188 $dgithead = splitbrain_pseudomerge($clogp,
3189 $actualhead, $dgithead,
3191 $maintviewhead = $actualhead;
3192 changedir '../../../..';
3193 prep_ud(); # so _only_subdir() works, below
3195 commit_quilty_patch();
3199 if (defined $overwrite_version && !defined $maintviewhead) {
3200 $dgithead = plain_overwrite_pseudomerge($clogp,
3208 if ($archive_hash) {
3209 if (is_fast_fwd($archive_hash, $dgithead)) {
3211 } elsif (deliberately_not_fast_forward) {
3214 fail "dgit push: HEAD is not a descendant".
3215 " of the archive's version.\n".
3216 "To overwrite the archive's contents,".
3217 " pass --overwrite[=VERSION].\n".
3218 "To rewind history, if permitted by the archive,".
3219 " use --deliberately-not-fast-forward.";
3224 progress "checking that $dscfn corresponds to HEAD";
3225 runcmd qw(dpkg-source -x --),
3226 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3227 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3228 check_for_vendor_patches() if madformat($dsc->{format});
3229 changedir '../../../..';
3230 my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3231 debugcmd "+",@diffcmd;
3233 my $r = system @diffcmd;
3236 my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3238 HEAD specifies a different tree to $dscfn:
3240 Perhaps you forgot to build. Or perhaps there is a problem with your
3241 source tree (see dgit(7) for some hints). To see a full diff, run
3248 if (!$changesfile) {
3249 my $pat = changespat $cversion;
3250 my @cs = glob "$buildproductsdir/$pat";
3251 fail "failed to find unique changes file".
3252 " (looked for $pat in $buildproductsdir);".
3253 " perhaps you need to use dgit -C"
3255 ($changesfile) = @cs;
3257 $changesfile = "$buildproductsdir/$changesfile";
3260 # Check that changes and .dsc agree enough
3261 $changesfile =~ m{[^/]*$};
3262 files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3264 # Checks complete, we're going to try and go ahead:
3266 responder_send_file('changes',$changesfile);
3267 responder_send_command("param head $dgithead");
3268 responder_send_command("param csuite $csuite");
3269 responder_send_command("param tagformat $tagformat");
3270 if (defined $maintviewhead) {
3271 die unless ($protovsn//4) >= 4;
3272 responder_send_command("param maint-view $maintviewhead");
3275 if (deliberately_not_fast_forward) {
3276 git_for_each_ref(lrfetchrefs, sub {
3277 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3278 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3279 responder_send_command("previously $rrefname=$objid");
3280 $previously{$rrefname} = $objid;
3284 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3288 supplementary_message(<<'END');
3289 Push failed, while signing the tag.
3290 You can retry the push, after fixing the problem, if you like.
3292 # If we manage to sign but fail to record it anywhere, it's fine.
3293 if ($we_are_responder) {
3294 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3295 responder_receive_files('signed-tag', @tagobjfns);
3297 @tagobjfns = push_mktags($clogp,$dscpath,
3298 $changesfile,$changesfile,
3301 supplementary_message(<<'END');
3302 Push failed, *after* signing the tag.
3303 If you want to try again, you should use a new version number.
3306 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3308 foreach my $tw (@tagwants) {
3309 my $tag = $tw->{Tag};
3310 my $tagobjfn = $tw->{TagObjFn};
3312 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3313 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3314 runcmd_ordryrun_local
3315 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3318 supplementary_message(<<'END');
3319 Push failed, while updating the remote git repository - see messages above.
3320 If you want to try again, you should use a new version number.
3322 if (!check_for_git()) {
3323 create_remote_git_repo();
3326 my @pushrefs = $forceflag.$dgithead.":".rrref();
3327 foreach my $tw (@tagwants) {
3328 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3331 runcmd_ordryrun @git,
3332 qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3333 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3335 supplementary_message(<<'END');
3336 Push failed, after updating the remote git repository.
3337 If you want to try again, you must use a new version number.
3339 if ($we_are_responder) {
3340 my $dryrunsuffix = act_local() ? "" : ".tmp";
3341 responder_receive_files('signed-dsc-changes',
3342 "$dscpath$dryrunsuffix",
3343 "$changesfile$dryrunsuffix");
3346 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3348 progress "[new .dsc left in $dscpath.tmp]";
3350 sign_changes $changesfile;
3353 supplementary_message(<<END);
3354 Push failed, while uploading package(s) to the archive server.
3355 You can retry the upload of exactly these same files with dput of:
3357 If that .changes file is broken, you will need to use a new version
3358 number for your next attempt at the upload.
3360 my $host = access_cfg('upload-host','RETURN-UNDEF');
3361 my @hostarg = defined($host) ? ($host,) : ();
3362 runcmd_ordryrun @dput, @hostarg, $changesfile;
3363 printdone "pushed and uploaded $cversion";
3365 supplementary_message('');
3366 responder_send_command("complete");
3373 badusage "-p is not allowed with clone; specify as argument instead"
3374 if defined $package;
3377 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3378 ($package,$isuite) = @ARGV;
3379 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3380 ($package,$dstdir) = @ARGV;
3381 } elsif (@ARGV==3) {
3382 ($package,$isuite,$dstdir) = @ARGV;
3384 badusage "incorrect arguments to dgit clone";
3386 $dstdir ||= "$package";
3388 if (stat_exists $dstdir) {
3389 fail "$dstdir already exists";
3393 if ($rmonerror && !$dryrun_level) {
3394 $cwd_remove= getcwd();
3396 return unless defined $cwd_remove;
3397 if (!chdir "$cwd_remove") {
3398 return if $!==&ENOENT;
3399 die "chdir $cwd_remove: $!";
3402 rmtree($dstdir) or die "remove $dstdir: $!\n";
3403 } elsif (grep { $! == $_ }
3404 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3406 print STDERR "check whether to remove $dstdir: $!\n";
3412 $cwd_remove = undef;
3415 sub branchsuite () {
3416 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3417 if ($branch =~ m#$lbranch_re#o) {
3424 sub fetchpullargs () {
3426 if (!defined $package) {
3427 my $sourcep = parsecontrol('debian/control','debian/control');
3428 $package = getfield $sourcep, 'Source';
3431 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3433 my $clogp = parsechangelog();
3434 $isuite = getfield $clogp, 'Distribution';
3436 canonicalise_suite();
3437 progress "fetching from suite $csuite";
3438 } elsif (@ARGV==1) {
3440 canonicalise_suite();
3442 badusage "incorrect arguments to dgit fetch or dgit pull";
3461 badusage "-p is not allowed with dgit push" if defined $package;
3463 my $clogp = parsechangelog();
3464 $package = getfield $clogp, 'Source';
3467 } elsif (@ARGV==1) {
3468 ($specsuite) = (@ARGV);
3470 badusage "incorrect arguments to dgit push";
3472 $isuite = getfield $clogp, 'Distribution';
3474 local ($package) = $existing_package; # this is a hack
3475 canonicalise_suite();
3477 canonicalise_suite();
3479 if (defined $specsuite &&
3480 $specsuite ne $isuite &&
3481 $specsuite ne $csuite) {
3482 fail "dgit push: changelog specifies $isuite ($csuite)".
3483 " but command line specifies $specsuite";
3488 #---------- remote commands' implementation ----------
3490 sub cmd_remote_push_build_host {
3491 my ($nrargs) = shift @ARGV;
3492 my (@rargs) = @ARGV[0..$nrargs-1];
3493 @ARGV = @ARGV[$nrargs..$#ARGV];
3495 my ($dir,$vsnwant) = @rargs;
3496 # vsnwant is a comma-separated list; we report which we have
3497 # chosen in our ready response (so other end can tell if they
3500 $we_are_responder = 1;
3501 $us .= " (build host)";
3505 open PI, "<&STDIN" or die $!;
3506 open STDIN, "/dev/null" or die $!;
3507 open PO, ">&STDOUT" or die $!;
3509 open STDOUT, ">&STDERR" or die $!;
3513 ($protovsn) = grep {
3514 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3515 } @rpushprotovsn_support;
3517 fail "build host has dgit rpush protocol versions ".
3518 (join ",", @rpushprotovsn_support).
3519 " but invocation host has $vsnwant"
3520 unless defined $protovsn;
3522 responder_send_command("dgit-remote-push-ready $protovsn");
3523 rpush_handle_protovsn_bothends();
3528 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3529 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3530 # a good error message)
3532 sub rpush_handle_protovsn_bothends () {
3533 if ($protovsn < 4) {
3534 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3543 my $report = i_child_report();
3544 if (defined $report) {
3545 printdebug "($report)\n";
3546 } elsif ($i_child_pid) {
3547 printdebug "(killing build host child $i_child_pid)\n";
3548 kill 15, $i_child_pid;
3550 if (defined $i_tmp && !defined $initiator_tempdir) {
3552 eval { rmtree $i_tmp; };
3556 END { i_cleanup(); }
3559 my ($base,$selector,@args) = @_;
3560 $selector =~ s/\-/_/g;
3561 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3568 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3576 push @rargs, join ",", @rpushprotovsn_support;
3579 push @rdgit, @ropts;
3580 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3582 my @cmd = (@ssh, $host, shellquote @rdgit);
3585 if (defined $initiator_tempdir) {
3586 rmtree $initiator_tempdir;
3587 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3588 $i_tmp = $initiator_tempdir;
3592 $i_child_pid = open2(\*RO, \*RI, @cmd);
3594 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3595 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3596 $supplementary_message = '' unless $protovsn >= 3;
3598 fail "rpush negotiated protocol version $protovsn".
3599 " which does not support quilt mode $quilt_mode"
3600 if quiltmode_splitbrain;
3602 rpush_handle_protovsn_bothends();
3604 my ($icmd,$iargs) = initiator_expect {
3605 m/^(\S+)(?: (.*))?$/;
3608 i_method "i_resp", $icmd, $iargs;
3612 sub i_resp_progress ($) {
3614 my $msg = protocol_read_bytes \*RO, $rhs;
3618 sub i_resp_supplementary_message ($) {
3620 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3623 sub i_resp_complete {
3624 my $pid = $i_child_pid;
3625 $i_child_pid = undef; # prevents killing some other process with same pid
3626 printdebug "waiting for build host child $pid...\n";
3627 my $got = waitpid $pid, 0;
3628 die $! unless $got == $pid;
3629 die "build host child failed $?" if $?;
3632 printdebug "all done\n";
3636 sub i_resp_file ($) {
3638 my $localname = i_method "i_localname", $keyword;
3639 my $localpath = "$i_tmp/$localname";
3640 stat_exists $localpath and
3641 badproto \*RO, "file $keyword ($localpath) twice";
3642 protocol_receive_file \*RO, $localpath;
3643 i_method "i_file", $keyword;
3648 sub i_resp_param ($) {
3649 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3653 sub i_resp_previously ($) {
3654 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3655 or badproto \*RO, "bad previously spec";
3656 my $r = system qw(git check-ref-format), $1;
3657 die "bad previously ref spec ($r)" if $r;
3658 $previously{$1} = $2;
3663 sub i_resp_want ($) {
3665 die "$keyword ?" if $i_wanted{$keyword}++;
3666 my @localpaths = i_method "i_want", $keyword;
3667 printdebug "[[ $keyword @localpaths\n";
3668 foreach my $localpath (@localpaths) {
3669 protocol_send_file \*RI, $localpath;
3671 print RI "files-end\n" or die $!;
3674 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3676 sub i_localname_parsed_changelog {
3677 return "remote-changelog.822";
3679 sub i_file_parsed_changelog {
3680 ($i_clogp, $i_version, $i_dscfn) =
3681 push_parse_changelog "$i_tmp/remote-changelog.822";
3682 die if $i_dscfn =~ m#/|^\W#;
3685 sub i_localname_dsc {
3686 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3691 sub i_localname_changes {
3692 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3693 $i_changesfn = $i_dscfn;
3694 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3695 return $i_changesfn;
3697 sub i_file_changes { }
3699 sub i_want_signed_tag {
3700 printdebug Dumper(\%i_param, $i_dscfn);
3701 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3702 && defined $i_param{'csuite'}
3703 or badproto \*RO, "premature desire for signed-tag";
3704 my $head = $i_param{'head'};
3705 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3707 my $maintview = $i_param{'maint-view'};
3708 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3711 if ($protovsn >= 4) {
3712 my $p = $i_param{'tagformat'} // '<undef>';
3714 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3717 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3719 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3721 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3724 push_mktags $i_clogp, $i_dscfn,
3725 $i_changesfn, 'remote changes',
3729 sub i_want_signed_dsc_changes {
3730 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3731 sign_changes $i_changesfn;
3732 return ($i_dscfn, $i_changesfn);
3735 #---------- building etc. ----------
3741 #----- `3.0 (quilt)' handling -----
3743 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3745 sub quiltify_dpkg_commit ($$$;$) {
3746 my ($patchname,$author,$msg, $xinfo) = @_;
3750 my $descfn = ".git/dgit/quilt-description.tmp";
3751 open O, '>', $descfn or die "$descfn: $!";
3752 $msg =~ s/\n+/\n\n/;
3753 print O <<END or die $!;
3755 ${xinfo}Subject: $msg
3762 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3763 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3764 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3765 runcmd @dpkgsource, qw(--commit .), $patchname;
3769 sub quiltify_trees_differ ($$;$$$) {
3770 my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3771 # returns true iff the two tree objects differ other than in debian/
3772 # with $finegrained,
3773 # returns bitmask 01 - differ in upstream files except .gitignore
3774 # 02 - differ in .gitignore
3775 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3776 # is set for each modified .gitignore filename $fn
3777 # if $unrepres is defined, array ref to which is appeneded
3778 # a list of unrepresentable changes (removals of upstream files
3781 my @cmd = (@git, qw(diff-tree -z));
3782 push @cmd, qw(--name-only) unless $unrepres;
3783 push @cmd, qw(-r) if $finegrained || $unrepres;
3785 my $diffs= cmdoutput @cmd;
3788 foreach my $f (split /\0/, $diffs) {
3789 if ($unrepres && !@lmodes) {
3790 @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3793 my ($oldmode,$newmode) = @lmodes;
3796 next if $f =~ m#^debian(?:/.*)?$#s;
3800 die "deleted\n" unless $newmode =~ m/[^0]/;
3801 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
3802 if ($oldmode =~ m/[^0]/) {
3803 die "mode changed\n" if $oldmode ne $newmode;
3805 die "non-default mode\n" unless $newmode =~ m/^100644$/;
3809 local $/="\n"; chomp $@;
3810 push @$unrepres, [ $f, $@ ];
3814 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3815 $r |= $isignore ? 02 : 01;
3816 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3818 printdebug "quiltify_trees_differ $x $y => $r\n";
3822 sub quiltify_tree_sentinelfiles ($) {
3823 # lists the `sentinel' files present in the tree
3825 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3826 qw(-- debian/rules debian/control);
3831 sub quiltify_splitbrain_needed () {
3832 if (!$split_brain) {
3833 progress "dgit view: changes are required...";
3834 runcmd @git, qw(checkout -q -b dgit-view);
3839 sub quiltify_splitbrain ($$$$$$) {
3840 my ($clogp, $unapplied, $headref, $diffbits,
3841 $editedignores, $cachekey) = @_;
3842 if ($quilt_mode !~ m/gbp|dpm/) {
3843 # treat .gitignore just like any other upstream file
3844 $diffbits = { %$diffbits };
3845 $_ = !!$_ foreach values %$diffbits;
3847 # We would like any commits we generate to be reproducible
3848 my @authline = clogp_authline($clogp);
3849 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3850 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3851 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3852 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3853 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3854 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3856 if ($quilt_mode =~ m/gbp|unapplied/ &&
3857 ($diffbits->{O2H} & 01)) {
3859 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3860 " but git tree differs from orig in upstream files.";
3861 if (!stat_exists "debian/patches") {
3863 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3867 if ($quilt_mode =~ m/dpm/ &&
3868 ($diffbits->{H2A} & 01)) {
3870 --quilt=$quilt_mode specified, implying patches-applied git tree
3871 but git tree differs from result of applying debian/patches to upstream
3874 if ($quilt_mode =~ m/gbp|unapplied/ &&
3875 ($diffbits->{O2A} & 01)) { # some patches
3876 quiltify_splitbrain_needed();
3877 progress "dgit view: creating patches-applied version using gbp pq";
3878 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3879 # gbp pq import creates a fresh branch; push back to dgit-view
3880 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3881 runcmd @git, qw(checkout -q dgit-view);
3883 if ($quilt_mode =~ m/gbp|dpm/ &&
3884 ($diffbits->{O2A} & 02)) {
3886 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3887 tool which does not create patches for changes to upstream
3888 .gitignores: but, such patches exist in debian/patches.
3891 if (($diffbits->{O2H} & 02) && # user has modified .gitignore
3892 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3893 quiltify_splitbrain_needed();
3894 progress "dgit view: creating patch to represent .gitignore changes";
3895 ensuredir "debian/patches";
3896 my $gipatch = "debian/patches/auto-gitignore";
3897 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3898 stat GIPATCH or die "$gipatch: $!";
3899 fail "$gipatch already exists; but want to create it".
3900 " to record .gitignore changes" if (stat _)[7];
3901 print GIPATCH <<END or die "$gipatch: $!";
3902 Subject: Update .gitignore from Debian packaging branch
3904 The Debian packaging git branch contains these updates to the upstream
3905 .gitignore file(s). This patch is autogenerated, to provide these
3906 updates to users of the official Debian archive view of the package.
3908 [dgit ($our_version) update-gitignore]
3911 close GIPATCH or die "$gipatch: $!";
3912 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3913 $unapplied, $headref, "--", sort keys %$editedignores;
3914 open SERIES, "+>>", "debian/patches/series" or die $!;
3915 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3917 defined read SERIES, $newline, 1 or die $!;
3918 print SERIES "\n" or die $! unless $newline eq "\n";
3919 print SERIES "auto-gitignore\n" or die $!;
3920 close SERIES or die $!;
3921 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3923 Commit patch to update .gitignore
3925 [dgit ($our_version) update-gitignore-quilt-fixup]
3929 my $dgitview = git_rev_parse 'HEAD';
3931 changedir '../../../..';
3932 # When we no longer need to support squeeze, use --create-reflog
3934 ensuredir ".git/logs/refs/dgit-intern";
3935 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3938 my $oldcache = git_get_ref "refs/$splitbraincache";
3939 if ($oldcache eq $dgitview) {
3940 my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
3941 # git update-ref doesn't always update, in this case. *sigh*
3942 my $dummy = make_commit_text <<END;
3945 author Dgit <dgit\@example.com> 1000000000 +0000
3946 committer Dgit <dgit\@example.com> 1000000000 +0000
3948 Dummy commit - do not use
3950 runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
3951 "refs/$splitbraincache", $dummy;
3953 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3956 progress "dgit view: created (commit id $dgitview)";
3958 changedir '.git/dgit/unpack/work';
3961 sub quiltify ($$$$) {
3962 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3964 # Quilt patchification algorithm
3966 # We search backwards through the history of the main tree's HEAD
3967 # (T) looking for a start commit S whose tree object is identical
3968 # to to the patch tip tree (ie the tree corresponding to the
3969 # current dpkg-committed patch series). For these purposes
3970 # `identical' disregards anything in debian/ - this wrinkle is
3971 # necessary because dpkg-source treates debian/ specially.
3973 # We can only traverse edges where at most one of the ancestors'
3974 # trees differs (in changes outside in debian/). And we cannot
3975 # handle edges which change .pc/ or debian/patches. To avoid
3976 # going down a rathole we avoid traversing edges which introduce
3977 # debian/rules or debian/control. And we set a limit on the
3978 # number of edges we are willing to look at.
3980 # If we succeed, we walk forwards again. For each traversed edge
3981 # PC (with P parent, C child) (starting with P=S and ending with
3982 # C=T) to we do this:
3984 # - dpkg-source --commit with a patch name and message derived from C
3985 # After traversing PT, we git commit the changes which
3986 # should be contained within debian/patches.
3988 # The search for the path S..T is breadth-first. We maintain a
3989 # todo list containing search nodes. A search node identifies a
3990 # commit, and looks something like this:
3992 # Commit => $git_commit_id,
3993 # Child => $c, # or undef if P=T
3994 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3995 # Nontrivial => true iff $p..$c has relevant changes
4002 my %considered; # saves being exponential on some weird graphs
4004 my $t_sentinels = quiltify_tree_sentinelfiles $target;
4007 my ($search,$whynot) = @_;
4008 printdebug " search NOT $search->{Commit} $whynot\n";
4009 $search->{Whynot} = $whynot;
4010 push @nots, $search;
4011 no warnings qw(exiting);
4020 my $c = shift @todo;
4021 next if $considered{$c->{Commit}}++;
4023 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4025 printdebug "quiltify investigate $c->{Commit}\n";
4028 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4029 printdebug " search finished hooray!\n";
4034 if ($quilt_mode eq 'nofix') {
4035 fail "quilt fixup required but quilt mode is \`nofix'\n".
4036 "HEAD commit $c->{Commit} differs from tree implied by ".
4037 " debian/patches (tree object $oldtiptree)";
4039 if ($quilt_mode eq 'smash') {
4040 printdebug " search quitting smash\n";
4044 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4045 $not->($c, "has $c_sentinels not $t_sentinels")
4046 if $c_sentinels ne $t_sentinels;
4048 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4049 $commitdata =~ m/\n\n/;
4051 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4052 @parents = map { { Commit => $_, Child => $c } } @parents;
4054 $not->($c, "root commit") if !@parents;
4056 foreach my $p (@parents) {
4057 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4059 my $ndiffers = grep { $_->{Nontrivial} } @parents;
4060 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4062 foreach my $p (@parents) {
4063 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4065 my @cmd= (@git, qw(diff-tree -r --name-only),
4066 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4067 my $patchstackchange = cmdoutput @cmd;
4068 if (length $patchstackchange) {
4069 $patchstackchange =~ s/\n/,/g;
4070 $not->($p, "changed $patchstackchange");
4073 printdebug " search queue P=$p->{Commit} ",
4074 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4080 printdebug "quiltify want to smash\n";
4083 my $x = $_[0]{Commit};
4084 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4087 my $reportnot = sub {
4089 my $s = $abbrev->($notp);
4090 my $c = $notp->{Child};
4091 $s .= "..".$abbrev->($c) if $c;
4092 $s .= ": ".$notp->{Whynot};
4095 if ($quilt_mode eq 'linear') {
4096 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
4097 foreach my $notp (@nots) {
4098 print STDERR "$us: ", $reportnot->($notp), "\n";
4100 print STDERR "$us: $_\n" foreach @$failsuggestion;
4101 fail "quilt fixup naive history linearisation failed.\n".
4102 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4103 } elsif ($quilt_mode eq 'smash') {
4104 } elsif ($quilt_mode eq 'auto') {
4105 progress "quilt fixup cannot be linear, smashing...";
4107 die "$quilt_mode ?";
4110 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4111 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4113 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4115 quiltify_dpkg_commit "auto-$version-$target-$time",
4116 (getfield $clogp, 'Maintainer'),
4117 "Automatically generated patch ($clogp->{Version})\n".
4118 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4122 progress "quiltify linearisation planning successful, executing...";
4124 for (my $p = $sref_S;
4125 my $c = $p->{Child};
4127 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4128 next unless $p->{Nontrivial};
4130 my $cc = $c->{Commit};
4132 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4133 $commitdata =~ m/\n\n/ or die "$c ?";
4136 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4139 my $commitdate = cmdoutput
4140 @git, qw(log -n1 --pretty=format:%aD), $cc;
4142 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4144 my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4151 my $gbp_check_suitable = sub {
4156 die "contains unexpected slashes\n" if m{//} || m{/$};
4157 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4158 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4159 die "too long" if length > 200;
4161 return $_ unless $@;
4162 print STDERR "quiltifying commit $cc:".
4163 " ignoring/dropping Gbp-Pq $what: $@";
4167 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4169 (\S+) \s* \n //ixm) {
4170 $patchname = $gbp_check_suitable->($1, 'Name');
4172 if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4174 (\S+) \s* \n //ixm) {
4175 $patchdir = $gbp_check_suitable->($1, 'Topic');
4180 if (!defined $patchname) {
4181 $patchname = $title;
4182 $patchname =~ s/[.:]$//;
4185 my $converter = new Text::Iconv qw(UTF-8 ASCII//TRANSLIT);
4186 my $translitname = $converter->convert($patchname);
4187 die unless defined $translitname;
4188 $patchname = $translitname;
4191 "dgit: patch title transliteration error: $@"
4193 $patchname =~ y/ A-Z/-a-z/;
4194 $patchname =~ y/-a-z0-9_.+=~//cd;
4195 $patchname =~ s/^\W/x-$&/;
4196 $patchname = substr($patchname,0,40);
4198 if (!defined $patchdir) {
4201 if (length $patchdir) {
4202 $patchname = "$patchdir/$patchname";
4204 if ($patchname =~ m{^(.*)/}) {
4205 mkpath "debian/patches/$1";
4210 stat "debian/patches/$patchname$index";
4212 $!==ENOENT or die "$patchname$index $!";
4214 runcmd @git, qw(checkout -q), $cc;
4216 # We use the tip's changelog so that dpkg-source doesn't
4217 # produce complaining messages from dpkg-parsechangelog. None
4218 # of the information dpkg-source gets from the changelog is
4219 # actually relevant - it gets put into the original message
4220 # which dpkg-source provides our stunt editor, and then
4222 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4224 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4225 "Date: $commitdate\n".
4226 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4228 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4231 runcmd @git, qw(checkout -q master);
4234 sub build_maybe_quilt_fixup () {
4235 my ($format,$fopts) = get_source_format;
4236 return unless madformat_wantfixup $format;
4239 check_for_vendor_patches();
4241 if (quiltmode_splitbrain) {
4242 foreach my $needtf (qw(new maint)) {
4243 next if grep { $_ eq $needtf } access_cfg_tagformats;
4245 quilt mode $quilt_mode requires split view so server needs to support
4246 both "new" and "maint" tag formats, but config says it doesn't.
4251 my $clogp = parsechangelog();
4252 my $headref = git_rev_parse('HEAD');
4257 my $upstreamversion=$version;
4258 $upstreamversion =~ s/-[^-]*$//;
4260 if ($fopts->{'single-debian-patch'}) {
4261 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4263 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4266 die 'bug' if $split_brain && !$need_split_build_invocation;
4268 changedir '../../../..';
4269 runcmd_ordryrun_local
4270 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4273 sub quilt_fixup_mkwork ($) {
4276 mkdir "work" or die $!;
4278 mktree_in_ud_here();
4279 runcmd @git, qw(reset -q --hard), $headref;
4282 sub quilt_fixup_linkorigs ($$) {
4283 my ($upstreamversion, $fn) = @_;
4284 # calls $fn->($leafname);
4286 foreach my $f (<../../../../*>) { #/){
4287 my $b=$f; $b =~ s{.*/}{};
4289 local ($debuglevel) = $debuglevel-1;
4290 printdebug "QF linkorigs $b, $f ?\n";
4292 next unless is_orig_file_of_vsn $b, $upstreamversion;
4293 printdebug "QF linkorigs $b, $f Y\n";
4294 link_ltarget $f, $b or die "$b $!";
4299 sub quilt_fixup_delete_pc () {
4300 runcmd @git, qw(rm -rqf .pc);
4302 Commit removal of .pc (quilt series tracking data)
4304 [dgit ($our_version) upgrade quilt-remove-pc]
4308 sub quilt_fixup_singlepatch ($$$) {
4309 my ($clogp, $headref, $upstreamversion) = @_;
4311 progress "starting quiltify (single-debian-patch)";
4313 # dpkg-source --commit generates new patches even if
4314 # single-debian-patch is in debian/source/options. In order to
4315 # get it to generate debian/patches/debian-changes, it is
4316 # necessary to build the source package.
4318 quilt_fixup_linkorigs($upstreamversion, sub { });
4319 quilt_fixup_mkwork($headref);
4321 rmtree("debian/patches");
4323 runcmd @dpkgsource, qw(-b .);
4325 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4326 rename srcfn("$upstreamversion", "/debian/patches"),
4327 "work/debian/patches";
4330 commit_quilty_patch();
4333 sub quilt_make_fake_dsc ($) {
4334 my ($upstreamversion) = @_;
4336 my $fakeversion="$upstreamversion-~~DGITFAKE";
4338 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4339 print $fakedsc <<END or die $!;
4342 Version: $fakeversion
4346 my $dscaddfile=sub {
4349 my $md = new Digest::MD5;
4351 my $fh = new IO::File $b, '<' or die "$b $!";
4356 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4359 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4361 my @files=qw(debian/source/format debian/rules
4362 debian/control debian/changelog);
4363 foreach my $maybe (qw(debian/patches debian/source/options
4364 debian/tests/control)) {
4365 next unless stat_exists "../../../$maybe";
4366 push @files, $maybe;
4369 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4370 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4372 $dscaddfile->($debtar);
4373 close $fakedsc or die $!;
4376 sub quilt_check_splitbrain_cache ($$) {
4377 my ($headref, $upstreamversion) = @_;
4378 # Called only if we are in (potentially) split brain mode.
4380 # Computes the cache key and looks in the cache.
4381 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4383 my $splitbrain_cachekey;
4386 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4387 # we look in the reflog of dgit-intern/quilt-cache
4388 # we look for an entry whose message is the key for the cache lookup
4389 my @cachekey = (qw(dgit), $our_version);
4390 push @cachekey, $upstreamversion;
4391 push @cachekey, $quilt_mode;
4392 push @cachekey, $headref;
4394 push @cachekey, hashfile('fake.dsc');
4396 my $srcshash = Digest::SHA->new(256);
4397 my %sfs = ( %INC, '$0(dgit)' => $0 );
4398 foreach my $sfk (sort keys %sfs) {
4399 next unless $sfk =~ m/^\$0\b/ || $sfk =~ m{^Debian/Dgit\b};
4400 $srcshash->add($sfk," ");
4401 $srcshash->add(hashfile($sfs{$sfk}));
4402 $srcshash->add("\n");
4404 push @cachekey, $srcshash->hexdigest();
4405 $splitbrain_cachekey = "@cachekey";
4407 my @cmd = (@git, qw(log -g), '--pretty=format:%H %gs',
4409 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4410 debugcmd "|(probably)",@cmd;
4411 my $child = open GC, "-|"; defined $child or die $!;
4413 chdir '../../..' or die $!;
4414 if (!stat ".git/logs/refs/$splitbraincache") {
4415 $! == ENOENT or die $!;
4416 printdebug ">(no reflog)\n";
4423 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4424 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4427 quilt_fixup_mkwork($headref);
4428 if ($cachehit ne $headref) {
4429 progress "dgit view: found cached (commit id $cachehit)";
4430 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4432 return ($cachehit, $splitbrain_cachekey);
4434 progress "dgit view: found cached, no changes required";
4435 return ($headref, $splitbrain_cachekey);
4437 die $! if GC->error;
4438 failedcmd unless close GC;
4440 printdebug "splitbrain cache miss\n";
4441 return (undef, $splitbrain_cachekey);
4444 sub quilt_fixup_multipatch ($$$) {
4445 my ($clogp, $headref, $upstreamversion) = @_;
4447 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4450 # - honour any existing .pc in case it has any strangeness
4451 # - determine the git commit corresponding to the tip of
4452 # the patch stack (if there is one)
4453 # - if there is such a git commit, convert each subsequent
4454 # git commit into a quilt patch with dpkg-source --commit
4455 # - otherwise convert all the differences in the tree into
4456 # a single git commit
4460 # Our git tree doesn't necessarily contain .pc. (Some versions of
4461 # dgit would include the .pc in the git tree.) If there isn't
4462 # one, we need to generate one by unpacking the patches that we
4465 # We first look for a .pc in the git tree. If there is one, we
4466 # will use it. (This is not the normal case.)
4468 # Otherwise need to regenerate .pc so that dpkg-source --commit
4469 # can work. We do this as follows:
4470 # 1. Collect all relevant .orig from parent directory
4471 # 2. Generate a debian.tar.gz out of
4472 # debian/{patches,rules,source/format,source/options}
4473 # 3. Generate a fake .dsc containing just these fields:
4474 # Format Source Version Files
4475 # 4. Extract the fake .dsc
4476 # Now the fake .dsc has a .pc directory.
4477 # (In fact we do this in every case, because in future we will
4478 # want to search for a good base commit for generating patches.)
4480 # Then we can actually do the dpkg-source --commit
4481 # 1. Make a new working tree with the same object
4482 # store as our main tree and check out the main
4484 # 2. Copy .pc from the fake's extraction, if necessary
4485 # 3. Run dpkg-source --commit
4486 # 4. If the result has changes to debian/, then
4487 # - git add them them
4488 # - git add .pc if we had a .pc in-tree
4490 # 5. If we had a .pc in-tree, delete it, and git commit
4491 # 6. Back in the main tree, fast forward to the new HEAD
4493 # Another situation we may have to cope with is gbp-style
4494 # patches-unapplied trees.
4496 # We would want to detect these, so we know to escape into
4497 # quilt_fixup_gbp. However, this is in general not possible.
4498 # Consider a package with a one patch which the dgit user reverts
4499 # (with git revert or the moral equivalent).
4501 # That is indistinguishable in contents from a patches-unapplied
4502 # tree. And looking at the history to distinguish them is not
4503 # useful because the user might have made a confusing-looking git
4504 # history structure (which ought to produce an error if dgit can't
4505 # cope, not a silent reintroduction of an unwanted patch).
4507 # So gbp users will have to pass an option. But we can usually
4508 # detect their failure to do so: if the tree is not a clean
4509 # patches-applied tree, quilt linearisation fails, but the tree
4510 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4511 # they want --quilt=unapplied.
4513 # To help detect this, when we are extracting the fake dsc, we
4514 # first extract it with --skip-patches, and then apply the patches
4515 # afterwards with dpkg-source --before-build. That lets us save a
4516 # tree object corresponding to .origs.
4518 my $splitbrain_cachekey;
4520 quilt_make_fake_dsc($upstreamversion);
4522 if (quiltmode_splitbrain()) {
4524 ($cachehit, $splitbrain_cachekey) =
4525 quilt_check_splitbrain_cache($headref, $upstreamversion);
4526 return if $cachehit;
4530 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4532 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4533 rename $fakexdir, "fake" or die "$fakexdir $!";
4537 remove_stray_gits();
4538 mktree_in_ud_here();
4542 runcmd @git, qw(add -Af .);
4543 my $unapplied=git_write_tree();
4544 printdebug "fake orig tree object $unapplied\n";
4548 my @bbcmd = (qw(sh -ec), 'exec dpkg-source --before-build . >/dev/null');
4550 if (system @bbcmd) {
4551 failedcmd @bbcmd if $? < 0;
4553 failed to apply your git tree's patch stack (from debian/patches/) to
4554 the corresponding upstream tarball(s). Your source tree and .orig
4555 are probably too inconsistent. dgit can only fix up certain kinds of
4556 anomaly (depending on the quilt mode). See --quilt= in dgit(1).
4562 quilt_fixup_mkwork($headref);
4565 if (stat_exists ".pc") {
4567 progress "Tree already contains .pc - will use it then delete it.";
4570 rename '../fake/.pc','.pc' or die $!;
4573 changedir '../fake';
4575 runcmd @git, qw(add -Af .);
4576 my $oldtiptree=git_write_tree();
4577 printdebug "fake o+d/p tree object $unapplied\n";
4578 changedir '../work';
4581 # We calculate some guesswork now about what kind of tree this might
4582 # be. This is mostly for error reporting.
4588 # O = orig, without patches applied
4589 # A = "applied", ie orig with H's debian/patches applied
4590 O2H => quiltify_trees_differ($unapplied,$headref, 1,
4591 \%editedignores, \@unrepres),
4592 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4593 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4597 foreach my $b (qw(01 02)) {
4598 foreach my $v (qw(O2H O2A H2A)) {
4599 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4602 printdebug "differences \@dl @dl.\n";
4605 "$us: base trees orig=%.20s o+d/p=%.20s",
4606 $unapplied, $oldtiptree;
4608 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4609 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4610 $dl[0], $dl[1], $dl[3], $dl[4],
4614 print STDERR "dgit: cannot represent change: $_->[1]: $_->[0]\n"
4616 forceable_fail [qw(unrepresentable)], <<END;
4617 HEAD has changes to .orig[s] which are not representable by `3.0 (quilt)'
4622 if (!($diffbits->{O2H} & $diffbits->{O2A})) {
4623 push @failsuggestion, "This might be a patches-unapplied branch.";
4624 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4625 push @failsuggestion, "This might be a patches-applied branch.";
4627 push @failsuggestion, "Maybe you need to specify one of".
4628 " --[quilt=]gbp --[quilt=]dpm --quilt=unapplied ?";
4630 if (quiltmode_splitbrain()) {
4631 quiltify_splitbrain($clogp, $unapplied, $headref,
4632 $diffbits, \%editedignores,
4633 $splitbrain_cachekey);
4637 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4638 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4640 if (!open P, '>>', ".pc/applied-patches") {
4641 $!==&ENOENT or die $!;
4646 commit_quilty_patch();
4648 if ($mustdeletepc) {
4649 quilt_fixup_delete_pc();
4653 sub quilt_fixup_editor () {
4654 my $descfn = $ENV{$fakeeditorenv};
4655 my $editing = $ARGV[$#ARGV];
4656 open I1, '<', $descfn or die "$descfn: $!";
4657 open I2, '<', $editing or die "$editing: $!";
4658 unlink $editing or die "$editing: $!";
4659 open O, '>', $editing or die "$editing: $!";
4660 while (<I1>) { print O or die $!; } I1->error and die $!;
4663 $copying ||= m/^\-\-\- /;
4664 next unless $copying;
4667 I2->error and die $!;
4672 sub maybe_apply_patches_dirtily () {
4673 return unless $quilt_mode =~ m/gbp|unapplied/;
4674 print STDERR <<END or die $!;
4676 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4677 dgit: Have to apply the patches - making the tree dirty.
4678 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4681 $patches_applied_dirtily = 01;
4682 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4683 runcmd qw(dpkg-source --before-build .);
4686 sub maybe_unapply_patches_again () {
4687 progress "dgit: Unapplying patches again to tidy up the tree."
4688 if $patches_applied_dirtily;
4689 runcmd qw(dpkg-source --after-build .)
4690 if $patches_applied_dirtily & 01;
4692 if $patches_applied_dirtily & 02;
4693 $patches_applied_dirtily = 0;
4696 #----- other building -----
4698 our $clean_using_builder;
4699 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4700 # clean the tree before building (perhaps invoked indirectly by
4701 # whatever we are using to run the build), rather than separately
4702 # and explicitly by us.
4705 return if $clean_using_builder;
4706 if ($cleanmode eq 'dpkg-source') {
4707 maybe_apply_patches_dirtily();
4708 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4709 } elsif ($cleanmode eq 'dpkg-source-d') {
4710 maybe_apply_patches_dirtily();
4711 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4712 } elsif ($cleanmode eq 'git') {
4713 runcmd_ordryrun_local @git, qw(clean -xdf);
4714 } elsif ($cleanmode eq 'git-ff') {
4715 runcmd_ordryrun_local @git, qw(clean -xdff);
4716 } elsif ($cleanmode eq 'check') {
4717 my $leftovers = cmdoutput @git, qw(clean -xdn);
4718 if (length $leftovers) {
4719 print STDERR $leftovers, "\n" or die $!;
4720 fail "tree contains uncommitted files and --clean=check specified";
4722 } elsif ($cleanmode eq 'none') {
4729 badusage "clean takes no additional arguments" if @ARGV;
4732 maybe_unapply_patches_again();
4737 badusage "-p is not allowed when building" if defined $package;
4740 my $clogp = parsechangelog();
4741 $isuite = getfield $clogp, 'Distribution';
4742 $package = getfield $clogp, 'Source';
4743 $version = getfield $clogp, 'Version';
4744 build_maybe_quilt_fixup();
4746 my $pat = changespat $version;
4747 foreach my $f (glob "$buildproductsdir/$pat") {
4749 unlink $f or fail "remove old changes file $f: $!";
4751 progress "would remove $f";
4757 sub changesopts_initial () {
4758 my @opts =@changesopts[1..$#changesopts];
4761 sub changesopts_version () {
4762 if (!defined $changes_since_version) {
4763 my @vsns = archive_query('archive_query');
4764 my @quirk = access_quirk();
4765 if ($quirk[0] eq 'backports') {
4766 local $isuite = $quirk[2];
4768 canonicalise_suite();
4769 push @vsns, archive_query('archive_query');
4772 @vsns = map { $_->[0] } @vsns;
4773 @vsns = sort { -version_compare($a, $b) } @vsns;
4774 $changes_since_version = $vsns[0];
4775 progress "changelog will contain changes since $vsns[0]";
4777 $changes_since_version = '_';
4778 progress "package seems new, not specifying -v<version>";
4781 if ($changes_since_version ne '_') {
4782 return ("-v$changes_since_version");
4788 sub changesopts () {
4789 return (changesopts_initial(), changesopts_version());
4792 sub massage_dbp_args ($;$) {
4793 my ($cmd,$xargs) = @_;
4796 # - if we're going to split the source build out so we can
4797 # do strange things to it, massage the arguments to dpkg-buildpackage
4798 # so that the main build doessn't build source (or add an argument
4799 # to stop it building source by default).
4801 # - add -nc to stop dpkg-source cleaning the source tree,
4802 # unless we're not doing a split build and want dpkg-source
4803 # as cleanmode, in which case we can do nothing
4806 # 0 - source will NOT need to be built separately by caller
4807 # +1 - source will need to be built separately by caller
4808 # +2 - source will need to be built separately by caller AND
4809 # dpkg-buildpackage should not in fact be run at all!
4810 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4811 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4812 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4813 $clean_using_builder = 1;
4816 # -nc has the side effect of specifying -b if nothing else specified
4817 # and some combinations of -S, -b, et al, are errors, rather than
4818 # later simply overriding earlie. So we need to:
4819 # - search the command line for these options
4820 # - pick the last one
4821 # - perhaps add our own as a default
4822 # - perhaps adjust it to the corresponding non-source-building version
4824 foreach my $l ($cmd, $xargs) {
4826 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4829 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4831 if ($need_split_build_invocation) {
4832 printdebug "massage split $dmode.\n";
4833 $r = $dmode =~ m/[S]/ ? +2 :
4834 $dmode =~ y/gGF/ABb/ ? +1 :
4835 $dmode =~ m/[ABb]/ ? 0 :
4838 printdebug "massage done $r $dmode.\n";
4840 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4845 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4846 my $wantsrc = massage_dbp_args \@dbp;
4853 push @dbp, changesopts_version();
4854 maybe_apply_patches_dirtily();
4855 runcmd_ordryrun_local @dbp;
4857 maybe_unapply_patches_again();
4858 printdone "build successful\n";
4862 $quilt_mode //= 'gbp';
4866 my @dbp = @dpkgbuildpackage;
4868 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4870 if (!length $gbp_build[0]) {
4871 if (length executable_on_path('git-buildpackage')) {
4872 $gbp_build[0] = qw(git-buildpackage);
4874 $gbp_build[0] = 'gbp buildpackage';
4877 my @cmd = opts_opt_multi_cmd @gbp_build;
4879 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4884 if (!$clean_using_builder) {
4885 push @cmd, '--git-cleaner=true';
4889 maybe_unapply_patches_again();
4891 push @cmd, changesopts();
4892 runcmd_ordryrun_local @cmd, @ARGV;
4894 printdone "build successful\n";
4896 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4899 my $our_cleanmode = $cleanmode;
4900 if ($need_split_build_invocation) {
4901 # Pretend that clean is being done some other way. This
4902 # forces us not to try to use dpkg-buildpackage to clean and
4903 # build source all in one go; and instead we run dpkg-source
4904 # (and build_prep() will do the clean since $clean_using_builder
4906 $our_cleanmode = 'ELSEWHERE';
4908 if ($our_cleanmode =~ m/^dpkg-source/) {
4909 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4910 $clean_using_builder = 1;
4913 $sourcechanges = changespat $version,'source';
4915 unlink "../$sourcechanges" or $!==ENOENT
4916 or fail "remove $sourcechanges: $!";
4918 $dscfn = dscfn($version);
4919 if ($our_cleanmode eq 'dpkg-source') {
4920 maybe_apply_patches_dirtily();
4921 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4923 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4924 maybe_apply_patches_dirtily();
4925 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4928 my @cmd = (@dpkgsource, qw(-b --));
4931 runcmd_ordryrun_local @cmd, "work";
4932 my @udfiles = <${package}_*>;
4933 changedir "../../..";
4934 foreach my $f (@udfiles) {
4935 printdebug "source copy, found $f\n";
4938 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4939 $f eq srcfn($version, $&));
4940 printdebug "source copy, found $f - renaming\n";
4941 rename "$ud/$f", "../$f" or $!==ENOENT
4942 or fail "put in place new source file ($f): $!";
4945 my $pwd = must_getcwd();
4946 my $leafdir = basename $pwd;
4948 runcmd_ordryrun_local @cmd, $leafdir;
4951 runcmd_ordryrun_local qw(sh -ec),
4952 'exec >$1; shift; exec "$@"','x',
4953 "../$sourcechanges",
4954 @dpkggenchanges, qw(-S), changesopts();
4958 sub cmd_build_source {
4959 badusage "build-source takes no additional arguments" if @ARGV;
4961 maybe_unapply_patches_again();
4962 printdone "source built, results in $dscfn and $sourcechanges";
4967 my $pat = changespat $version;
4969 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4970 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4972 changes files other than source matching $pat already present; building would result in ambiguity about the intended results.
4973 Suggest you delete @unwanted.
4977 my $wasdir = must_getcwd();
4980 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4981 stat_exists $sourcechanges
4982 or fail "$sourcechanges (in parent directory): $!";
4984 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4985 my @changesfiles = glob $pat;
4986 @changesfiles = sort {
4987 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4990 fail <<END if @changesfiles==1;
4991 only one changes file from sbuild (@changesfiles)
4992 perhaps you need to pass -A ? (sbuild's default is to build only
4993 arch-specific binaries; dgit 1.4 used to override that.)
4995 fail "wrong number of different changes files (@changesfiles)"
4996 unless @changesfiles==2;
4997 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4998 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4999 fail "$l found in binaries changes file $binchanges"
5002 runcmd_ordryrun_local @mergechanges, @changesfiles;
5003 my $multichanges = changespat $version,'multi';
5005 stat_exists $multichanges or fail "$multichanges: $!";
5006 foreach my $cf (glob $pat) {
5007 next if $cf eq $multichanges;
5008 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
5012 maybe_unapply_patches_again();
5013 printdone "build successful, results in $multichanges\n" or die $!;
5016 sub cmd_quilt_fixup {
5017 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
5018 my $clogp = parsechangelog();
5019 $version = getfield $clogp, 'Version';
5020 $package = getfield $clogp, 'Source';
5023 build_maybe_quilt_fixup();
5026 sub cmd_archive_api_query {
5027 badusage "need only 1 subpath argument" unless @ARGV==1;
5028 my ($subpath) = @ARGV;
5029 my @cmd = archive_api_query_cmd($subpath);
5032 exec @cmd or fail "exec curl: $!\n";
5035 sub cmd_clone_dgit_repos_server {
5036 badusage "need destination argument" unless @ARGV==1;
5037 my ($destdir) = @ARGV;
5038 $package = '_dgit-repos-server';
5039 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
5041 exec @cmd or fail "exec git clone: $!\n";
5044 sub cmd_setup_mergechangelogs {
5045 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5046 setup_mergechangelogs(1);
5049 sub cmd_setup_useremail {
5050 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
5054 sub cmd_setup_new_tree {
5055 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
5059 #---------- argument parsing and main program ----------
5062 print "dgit version $our_version\n" or die $!;
5066 our (%valopts_long, %valopts_short);
5069 sub defvalopt ($$$$) {
5070 my ($long,$short,$val_re,$how) = @_;
5071 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
5072 $valopts_long{$long} = $oi;
5073 $valopts_short{$short} = $oi;
5074 # $how subref should:
5075 # do whatever assignemnt or thing it likes with $_[0]
5076 # if the option should not be passed on to remote, @rvalopts=()
5077 # or $how can be a scalar ref, meaning simply assign the value
5080 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
5081 defvalopt '--distro', '-d', '.+', \$idistro;
5082 defvalopt '', '-k', '.+', \$keyid;
5083 defvalopt '--existing-package','', '.*', \$existing_package;
5084 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
5085 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
5086 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
5088 defvalopt '', '-C', '.+', sub {
5089 ($changesfile) = (@_);
5090 if ($changesfile =~ s#^(.*)/##) {
5091 $buildproductsdir = $1;
5095 defvalopt '--initiator-tempdir','','.*', sub {
5096 ($initiator_tempdir) = (@_);
5097 $initiator_tempdir =~ m#^/# or
5098 badusage "--initiator-tempdir must be used specify an".
5099 " absolute, not relative, directory."
5105 if (defined $ENV{'DGIT_SSH'}) {
5106 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
5107 } elsif (defined $ENV{'GIT_SSH'}) {
5108 @ssh = ($ENV{'GIT_SSH'});
5116 if (!defined $val) {
5117 badusage "$what needs a value" unless @ARGV;
5119 push @rvalopts, $val;
5121 badusage "bad value \`$val' for $what" unless
5122 $val =~ m/^$oi->{Re}$(?!\n)/s;
5123 my $how = $oi->{How};
5124 if (ref($how) eq 'SCALAR') {
5129 push @ropts, @rvalopts;
5133 last unless $ARGV[0] =~ m/^-/;
5137 if (m/^--dry-run$/) {
5140 } elsif (m/^--damp-run$/) {
5143 } elsif (m/^--no-sign$/) {
5146 } elsif (m/^--help$/) {
5148 } elsif (m/^--version$/) {
5150 } elsif (m/^--new$/) {
5153 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
5154 ($om = $opts_opt_map{$1}) &&
5158 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
5159 !$opts_opt_cmdonly{$1} &&
5160 ($om = $opts_opt_map{$1})) {
5163 } elsif (m/^--(gbp|dpm)$/s) {
5164 push @ropts, "--quilt=$1";
5166 } elsif (m/^--ignore-dirty$/s) {
5169 } elsif (m/^--no-quilt-fixup$/s) {
5171 $quilt_mode = 'nocheck';
5172 } elsif (m/^--no-rm-on-error$/s) {
5175 } elsif (m/^--overwrite$/s) {
5177 $overwrite_version = '';
5178 } elsif (m/^--overwrite=(.+)$/s) {
5180 $overwrite_version = $1;
5181 } elsif (m/^--(no-)?rm-old-changes$/s) {
5184 } elsif (m/^--deliberately-($deliberately_re)$/s) {
5186 push @deliberatelies, $&;
5187 } elsif (m/^--force-(.*)/ && defined $forceopts{$1}) {
5191 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
5192 # undocumented, for testing
5194 $tagformat_want = [ $1, 'command line', 1 ];
5195 # 1 menas overrides distro configuration
5196 } elsif (m/^--always-split-source-build$/s) {
5197 # undocumented, for testing
5199 $need_split_build_invocation = 1;
5200 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
5201 $val = $2 ? $' : undef; #';
5202 $valopt->($oi->{Long});
5204 badusage "unknown long option \`$_'";
5211 } elsif (s/^-L/-/) {
5214 } elsif (s/^-h/-/) {
5216 } elsif (s/^-D/-/) {
5220 } elsif (s/^-N/-/) {
5225 push @changesopts, $_;
5227 } elsif (s/^-wn$//s) {
5229 $cleanmode = 'none';
5230 } elsif (s/^-wg$//s) {
5233 } elsif (s/^-wgf$//s) {
5235 $cleanmode = 'git-ff';
5236 } elsif (s/^-wd$//s) {
5238 $cleanmode = 'dpkg-source';
5239 } elsif (s/^-wdd$//s) {
5241 $cleanmode = 'dpkg-source-d';
5242 } elsif (s/^-wc$//s) {
5244 $cleanmode = 'check';
5245 } elsif (s/^-c([^=]*)\=(.*)$//s) {
5246 push @git, '-c', $&;
5247 $gitcfgs{cmdline}{$1} = [ $2 ];
5248 } elsif (s/^-c([^=]+)$//s) {
5249 push @git, '-c', $&;
5250 $gitcfgs{cmdline}{$1} = [ 'true' ];
5251 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
5253 $val = undef unless length $val;
5254 $valopt->($oi->{Short});
5257 badusage "unknown short option \`$_'";
5264 sub check_env_sanity () {
5265 my $blocked = new POSIX::SigSet;
5266 sigprocmask SIG_UNBLOCK, $blocked, $blocked or die $!;
5269 foreach my $name (qw(PIPE CHLD)) {
5270 my $signame = "SIG$name";
5271 my $signum = eval "POSIX::$signame" // die;
5272 ($SIG{$name} // 'DEFAULT') eq 'DEFAULT' or
5273 die "$signame is set to something other than SIG_DFL\n";
5274 $blocked->ismember($signum) and
5275 die "$signame is blocked\n";
5281 On entry to dgit, $@
5282 This is a bug produced by something in in your execution environment.
5288 sub finalise_opts_opts () {
5289 foreach my $k (keys %opts_opt_map) {
5290 my $om = $opts_opt_map{$k};
5292 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5294 badcfg "cannot set command for $k"
5295 unless length $om->[0];
5299 foreach my $c (access_cfg_cfgs("opts-$k")) {
5301 map { $_ ? @$_ : () }
5302 map { $gitcfgs{$_}{$c} }
5303 reverse @gitcfgsources;
5304 printdebug "CL $c ", (join " ", map { shellquote } @vl),
5305 "\n" if $debuglevel >= 4;
5307 badcfg "cannot configure options for $k"
5308 if $opts_opt_cmdonly{$k};
5309 my $insertpos = $opts_cfg_insertpos{$k};
5310 @$om = ( @$om[0..$insertpos-1],
5312 @$om[$insertpos..$#$om] );
5317 if ($ENV{$fakeeditorenv}) {
5319 quilt_fixup_editor();
5326 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5327 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5328 if $dryrun_level == 1;
5330 print STDERR $helpmsg or die $!;
5333 my $cmd = shift @ARGV;
5336 my $pre_fn = ${*::}{"pre_$cmd"};
5337 $pre_fn->() if $pre_fn;
5339 if (!defined $rmchanges) {
5340 local $access_forpush;
5341 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5344 if (!defined $quilt_mode) {
5345 local $access_forpush;
5346 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5347 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5349 $quilt_mode =~ m/^($quilt_modes_re)$/
5350 or badcfg "unknown quilt-mode \`$quilt_mode'";
5354 $need_split_build_invocation ||= quiltmode_splitbrain();
5356 if (!defined $cleanmode) {
5357 local $access_forpush;
5358 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5359 $cleanmode //= 'dpkg-source';
5361 badcfg "unknown clean-mode \`$cleanmode'" unless
5362 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5365 my $fn = ${*::}{"cmd_$cmd"};
5366 $fn or badusage "unknown operation $cmd";