3 # Integration between git and Debian-style archives
5 # Copyright (C)2013-2015 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use Dpkg::Control::Hash;
30 use File::Temp qw(tempdir);
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
43 our $our_version = 'UNRELEASED'; ###substituted###
45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
48 our $isuite = 'unstable';
54 our $dryrun_level = 0;
56 our $buildproductsdir = '..';
62 our $existing_package = 'dpkg';
64 our $changes_since_version;
66 our $overwrite_version; # undef: not specified; '': check changelog
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
80 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
81 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
82 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
84 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
85 our $splitbraincache = 'dgit-intern/quilt-cache';
88 our (@dget) = qw(dget);
89 our (@curl) = qw(curl -f);
90 our (@dput) = qw(dput);
91 our (@debsign) = qw(debsign);
93 our (@sbuild) = qw(sbuild);
95 our (@dgit) = qw(dgit);
96 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
97 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
98 our (@dpkggenchanges) = qw(dpkg-genchanges);
99 our (@mergechanges) = qw(mergechanges -f);
100 our (@gbp) = qw(gbp);
101 our (@gbp_build) = ('');
102 our (@changesopts) = ('');
104 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
107 'debsign' => \@debsign,
109 'sbuild' => \@sbuild,
113 'dpkg-source' => \@dpkgsource,
114 'dpkg-buildpackage' => \@dpkgbuildpackage,
115 'dpkg-genchanges' => \@dpkggenchanges,
117 'gbp-build' => \@gbp_build,
118 'ch' => \@changesopts,
119 'mergechanges' => \@mergechanges);
121 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
122 our %opts_cfg_insertpos = map {
124 scalar @{ $opts_opt_map{$_} }
125 } keys %opts_opt_map;
127 sub finalise_opts_opts();
133 our $supplementary_message = '';
134 our $need_split_build_invocation = 0;
135 our $split_brain = 0;
139 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
142 our $remotename = 'dgit';
143 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
148 my ($v,$distro) = @_;
149 return $tagformatfn->($v, $distro);
152 sub debiantag_maintview ($$) {
153 my ($v,$distro) = @_;
158 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
160 sub lbranch () { return "$branchprefix/$csuite"; }
161 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
162 sub lref () { return "refs/heads/".lbranch(); }
163 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
164 sub rrref () { return server_ref($csuite); }
166 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
167 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
169 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
170 # locally fetched refs because they have unhelpful names and clutter
171 # up gitk etc. So we track whether we have "used up" head ref (ie,
172 # whether we have made another local ref which refers to this object).
174 # (If we deleted them unconditionally, then we might end up
175 # re-fetching the same git objects each time dgit fetch was run.)
177 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
178 # in git_fetch_us to fetch the refs in question, and possibly a call
179 # to lrfetchref_used.
181 our (%lrfetchrefs_f, %lrfetchrefs_d);
182 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
184 sub lrfetchref_used ($) {
185 my ($fullrefname) = @_;
186 my $objid = $lrfetchrefs_f{$fullrefname};
187 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
198 return "${package}_".(stripepoch $vsn).$sfx
203 return srcfn($vsn,".dsc");
206 sub changespat ($;$) {
207 my ($vsn, $arch) = @_;
208 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
217 foreach my $f (@end) {
219 print STDERR "$us: cleanup: $@" if length $@;
223 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
225 sub no_such_package () {
226 print STDERR "$us: package $package does not exist in suite $isuite\n";
232 printdebug "CD $newdir\n";
233 chdir $newdir or confess "chdir: $newdir: $!";
236 sub deliberately ($) {
238 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
241 sub deliberately_not_fast_forward () {
242 foreach (qw(not-fast-forward fresh-repo)) {
243 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
247 sub quiltmode_splitbrain () {
248 $quilt_mode =~ m/gbp|dpm|unapplied/;
251 sub opts_opt_multi_cmd {
253 push @cmd, split /\s+/, shift @_;
259 return (@gbp, qw(pq));
262 #---------- remote protocol support, common ----------
264 # remote push initiator/responder protocol:
265 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
266 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
267 # < dgit-remote-push-ready <actual-proto-vsn>
274 # > supplementary-message NBYTES # $protovsn >= 3
279 # > file parsed-changelog
280 # [indicates that output of dpkg-parsechangelog follows]
281 # > data-block NBYTES
282 # > [NBYTES bytes of data (no newline)]
283 # [maybe some more blocks]
292 # > param head DGIT-VIEW-HEAD
293 # > param csuite SUITE
294 # > param tagformat old|new
295 # > param maint-view MAINT-VIEW-HEAD
297 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
298 # # goes into tag, for replay prevention
301 # [indicates that signed tag is wanted]
302 # < data-block NBYTES
303 # < [NBYTES bytes of data (no newline)]
304 # [maybe some more blocks]
308 # > want signed-dsc-changes
309 # < data-block NBYTES [transfer of signed dsc]
311 # < data-block NBYTES [transfer of signed changes]
319 sub i_child_report () {
320 # Sees if our child has died, and reap it if so. Returns a string
321 # describing how it died if it failed, or undef otherwise.
322 return undef unless $i_child_pid;
323 my $got = waitpid $i_child_pid, WNOHANG;
324 return undef if $got <= 0;
325 die unless $got == $i_child_pid;
326 $i_child_pid = undef;
327 return undef unless $?;
328 return "build host child ".waitstatusmsg();
333 fail "connection lost: $!" if $fh->error;
334 fail "protocol violation; $m not expected";
337 sub badproto_badread ($$) {
339 fail "connection lost: $!" if $!;
340 my $report = i_child_report();
341 fail $report if defined $report;
342 badproto $fh, "eof (reading $wh)";
345 sub protocol_expect (&$) {
346 my ($match, $fh) = @_;
349 defined && chomp or badproto_badread $fh, "protocol message";
357 badproto $fh, "\`$_'";
360 sub protocol_send_file ($$) {
361 my ($fh, $ourfn) = @_;
362 open PF, "<", $ourfn or die "$ourfn: $!";
365 my $got = read PF, $d, 65536;
366 die "$ourfn: $!" unless defined $got;
368 print $fh "data-block ".length($d)."\n" or die $!;
369 print $fh $d or die $!;
371 PF->error and die "$ourfn $!";
372 print $fh "data-end\n" or die $!;
376 sub protocol_read_bytes ($$) {
377 my ($fh, $nbytes) = @_;
378 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
380 my $got = read $fh, $d, $nbytes;
381 $got==$nbytes or badproto_badread $fh, "data block";
385 sub protocol_receive_file ($$) {
386 my ($fh, $ourfn) = @_;
387 printdebug "() $ourfn\n";
388 open PF, ">", $ourfn or die "$ourfn: $!";
390 my ($y,$l) = protocol_expect {
391 m/^data-block (.*)$/ ? (1,$1) :
392 m/^data-end$/ ? (0,) :
396 my $d = protocol_read_bytes $fh, $l;
397 print PF $d or die $!;
402 #---------- remote protocol support, responder ----------
404 sub responder_send_command ($) {
406 return unless $we_are_responder;
407 # called even without $we_are_responder
408 printdebug ">> $command\n";
409 print PO $command, "\n" or die $!;
412 sub responder_send_file ($$) {
413 my ($keyword, $ourfn) = @_;
414 return unless $we_are_responder;
415 printdebug "]] $keyword $ourfn\n";
416 responder_send_command "file $keyword";
417 protocol_send_file \*PO, $ourfn;
420 sub responder_receive_files ($@) {
421 my ($keyword, @ourfns) = @_;
422 die unless $we_are_responder;
423 printdebug "[[ $keyword @ourfns\n";
424 responder_send_command "want $keyword";
425 foreach my $fn (@ourfns) {
426 protocol_receive_file \*PI, $fn;
429 protocol_expect { m/^files-end$/ } \*PI;
432 #---------- remote protocol support, initiator ----------
434 sub initiator_expect (&) {
436 protocol_expect { &$match } \*RO;
439 #---------- end remote code ----------
442 if ($we_are_responder) {
444 responder_send_command "progress ".length($m) or die $!;
445 print PO $m or die $!;
455 $ua = LWP::UserAgent->new();
459 progress "downloading $what...";
460 my $r = $ua->get(@_) or die $!;
461 return undef if $r->code == 404;
462 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
463 return $r->decoded_content(charset => 'none');
466 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
471 failedcmd @_ if system @_;
474 sub act_local () { return $dryrun_level <= 1; }
475 sub act_scary () { return !$dryrun_level; }
478 if (!$dryrun_level) {
479 progress "dgit ok: @_";
481 progress "would be ok: @_ (but dry run only)";
486 printcmd(\*STDERR,$debugprefix."#",@_);
489 sub runcmd_ordryrun {
497 sub runcmd_ordryrun_local {
506 my ($first_shell, @cmd) = @_;
507 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
510 our $helpmsg = <<END;
512 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
513 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
514 dgit [dgit-opts] build [dpkg-buildpackage-opts]
515 dgit [dgit-opts] sbuild [sbuild-opts]
516 dgit [dgit-opts] push [dgit-opts] [suite]
517 dgit [dgit-opts] rpush build-host:build-dir ...
518 important dgit options:
519 -k<keyid> sign tag and package with <keyid> instead of default
520 --dry-run -n do not change anything, but go through the motions
521 --damp-run -L like --dry-run but make local changes, without signing
522 --new -N allow introducing a new package
523 --debug -D increase debug level
524 -c<name>=<value> set git config option (used directly by dgit too)
527 our $later_warning_msg = <<END;
528 Perhaps the upload is stuck in incoming. Using the version from git.
532 print STDERR "$us: @_\n", $helpmsg or die $!;
537 @ARGV or badusage "too few arguments";
538 return scalar shift @ARGV;
542 print $helpmsg or die $!;
546 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
548 our %defcfg = ('dgit.default.distro' => 'debian',
549 'dgit.default.username' => '',
550 'dgit.default.archive-query-default-component' => 'main',
551 'dgit.default.ssh' => 'ssh',
552 'dgit.default.archive-query' => 'madison:',
553 'dgit.default.sshpsql-dbname' => 'service=projectb',
554 'dgit.default.dgit-tag-format' => 'old,new,maint',
555 # old means "repo server accepts pushes with old dgit tags"
556 # new means "repo server accepts pushes with new dgit tags"
557 # maint means "repo server accepts split brain pushes"
558 # hist means "repo server may have old pushes without new tag"
559 # ("hist" is implied by "old")
560 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
561 'dgit-distro.debian.git-check' => 'url',
562 'dgit-distro.debian.git-check-suffix' => '/info/refs',
563 'dgit-distro.debian.new-private-pushers' => 't',
564 'dgit-distro.debian.dgit-tag-format' => 'new',
565 'dgit-distro.debian/push.git-url' => '',
566 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
567 'dgit-distro.debian/push.git-user-force' => 'dgit',
568 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
569 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
570 'dgit-distro.debian/push.git-create' => 'true',
571 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
572 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
573 # 'dgit-distro.debian.archive-query-tls-key',
574 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
575 # ^ this does not work because curl is broken nowadays
576 # Fixing #790093 properly will involve providing providing the key
577 # in some pacagke and maybe updating these paths.
579 # 'dgit-distro.debian.archive-query-tls-curl-args',
580 # '--ca-path=/etc/ssl/ca-debian',
581 # ^ this is a workaround but works (only) on DSA-administered machines
582 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
583 'dgit-distro.debian.git-url-suffix' => '',
584 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
585 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
586 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
587 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
588 'dgit-distro.ubuntu.git-check' => 'false',
589 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
590 'dgit-distro.test-dummy.ssh' => "$td/ssh",
591 'dgit-distro.test-dummy.username' => "alice",
592 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
593 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
594 'dgit-distro.test-dummy.git-url' => "$td/git",
595 'dgit-distro.test-dummy.git-host' => "git",
596 'dgit-distro.test-dummy.git-path' => "$td/git",
597 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
598 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
599 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
600 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
605 sub git_slurp_config () {
606 local ($debuglevel) = $debuglevel-2;
609 my @cmd = (@git, qw(config -z --get-regexp .*));
612 open GITS, "-|", @cmd or die $!;
615 printdebug "=> ", (messagequote $_), "\n";
617 push @{ $gitcfg{$`} }, $'; #';
621 or ($!==0 && $?==256)
625 sub git_get_config ($) {
628 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
631 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
637 return undef if $c =~ /RETURN-UNDEF/;
638 my $v = git_get_config($c);
639 return $v if defined $v;
640 my $dv = $defcfg{$c};
641 return $dv if defined $dv;
643 badcfg "need value for one of: @_\n".
644 "$us: distro or suite appears not to be (properly) supported";
647 sub access_basedistro () {
648 if (defined $idistro) {
651 return cfg("dgit-suite.$isuite.distro",
652 "dgit.default.distro");
656 sub access_quirk () {
657 # returns (quirk name, distro to use instead or undef, quirk-specific info)
658 my $basedistro = access_basedistro();
659 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
661 if (defined $backports_quirk) {
662 my $re = $backports_quirk;
663 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
665 $re =~ s/\%/([-0-9a-z_]+)/
666 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
667 if ($isuite =~ m/^$re$/) {
668 return ('backports',"$basedistro-backports",$1);
671 return ('none',undef);
676 sub parse_cfg_bool ($$$) {
677 my ($what,$def,$v) = @_;
680 $v =~ m/^[ty1]/ ? 1 :
681 $v =~ m/^[fn0]/ ? 0 :
682 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
685 sub access_forpush_config () {
686 my $d = access_basedistro();
690 parse_cfg_bool('new-private-pushers', 0,
691 cfg("dgit-distro.$d.new-private-pushers",
694 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
697 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
698 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
699 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
700 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
703 sub access_forpush () {
704 $access_forpush //= access_forpush_config();
705 return $access_forpush;
709 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
710 badcfg "pushing but distro is configured readonly"
711 if access_forpush_config() eq '0';
713 $supplementary_message = <<'END' unless $we_are_responder;
714 Push failed, before we got started.
715 You can retry the push, after fixing the problem, if you like.
717 finalise_opts_opts();
721 finalise_opts_opts();
724 sub supplementary_message ($) {
726 if (!$we_are_responder) {
727 $supplementary_message = $msg;
729 } elsif ($protovsn >= 3) {
730 responder_send_command "supplementary-message ".length($msg)
732 print PO $msg or die $!;
736 sub access_distros () {
737 # Returns list of distros to try, in order
740 # 0. `instead of' distro name(s) we have been pointed to
741 # 1. the access_quirk distro, if any
742 # 2a. the user's specified distro, or failing that } basedistro
743 # 2b. the distro calculated from the suite }
744 my @l = access_basedistro();
746 my (undef,$quirkdistro) = access_quirk();
747 unshift @l, $quirkdistro;
748 unshift @l, $instead_distro;
749 @l = grep { defined } @l;
751 if (access_forpush()) {
752 @l = map { ("$_/push", $_) } @l;
757 sub access_cfg_cfgs (@) {
760 # The nesting of these loops determines the search order. We put
761 # the key loop on the outside so that we search all the distros
762 # for each key, before going on to the next key. That means that
763 # if access_cfg is called with a more specific, and then a less
764 # specific, key, an earlier distro can override the less specific
765 # without necessarily overriding any more specific keys. (If the
766 # distro wants to override the more specific keys it can simply do
767 # so; whereas if we did the loop the other way around, it would be
768 # impossible to for an earlier distro to override a less specific
769 # key but not the more specific ones without restating the unknown
770 # values of the more specific keys.
773 # We have to deal with RETURN-UNDEF specially, so that we don't
774 # terminate the search prematurely.
776 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
779 foreach my $d (access_distros()) {
780 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
782 push @cfgs, map { "dgit.default.$_" } @realkeys;
789 my (@cfgs) = access_cfg_cfgs(@keys);
790 my $value = cfg(@cfgs);
794 sub access_cfg_bool ($$) {
795 my ($def, @keys) = @_;
796 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
799 sub string_to_ssh ($) {
801 if ($spec =~ m/\s/) {
802 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
808 sub access_cfg_ssh () {
809 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
810 if (!defined $gitssh) {
813 return string_to_ssh $gitssh;
817 sub access_runeinfo ($) {
819 return ": dgit ".access_basedistro()." $info ;";
822 sub access_someuserhost ($) {
824 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
825 defined($user) && length($user) or
826 $user = access_cfg("$some-user",'username');
827 my $host = access_cfg("$some-host");
828 return length($user) ? "$user\@$host" : $host;
831 sub access_gituserhost () {
832 return access_someuserhost('git');
835 sub access_giturl (;$) {
837 my $url = access_cfg('git-url','RETURN-UNDEF');
840 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
841 return undef unless defined $proto;
844 access_gituserhost().
845 access_cfg('git-path');
847 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
850 return "$url/$package$suffix";
853 sub parsecontrolfh ($$;$) {
854 my ($fh, $desc, $allowsigned) = @_;
855 our $dpkgcontrolhash_noissigned;
858 my %opts = ('name' => $desc);
859 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
860 $c = Dpkg::Control::Hash->new(%opts);
861 $c->parse($fh,$desc) or die "parsing of $desc failed";
862 last if $allowsigned;
863 last if $dpkgcontrolhash_noissigned;
864 my $issigned= $c->get_option('is_pgp_signed');
865 if (!defined $issigned) {
866 $dpkgcontrolhash_noissigned= 1;
867 seek $fh, 0,0 or die "seek $desc: $!";
868 } elsif ($issigned) {
869 fail "control file $desc is (already) PGP-signed. ".
870 " Note that dgit push needs to modify the .dsc and then".
871 " do the signature itself";
880 my ($file, $desc) = @_;
881 my $fh = new IO::Handle;
882 open $fh, '<', $file or die "$file: $!";
883 my $c = parsecontrolfh($fh,$desc);
884 $fh->error and die $!;
890 my ($dctrl,$field) = @_;
891 my $v = $dctrl->{$field};
892 return $v if defined $v;
893 fail "missing field $field in ".$dctrl->get_option('name');
897 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
898 my $p = new IO::Handle;
899 my @cmd = (qw(dpkg-parsechangelog), @_);
900 open $p, '-|', @cmd or die $!;
902 $?=0; $!=0; close $p or failedcmd @cmd;
906 sub commit_getclogp ($) {
907 # Returns the parsed changelog hashref for a particular commit
909 our %commit_getclogp_memo;
910 my $memo = $commit_getclogp_memo{$objid};
911 return $memo if $memo;
913 my $mclog = ".git/dgit/clog-$objid";
914 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
915 "$objid:debian/changelog";
916 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
921 defined $d or fail "getcwd failed: $!";
927 sub archive_query ($) {
929 my $query = access_cfg('archive-query','RETURN-UNDEF');
930 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
933 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
936 sub pool_dsc_subpath ($$) {
937 my ($vsn,$component) = @_; # $package is implict arg
938 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
939 return "/pool/$component/$prefix/$package/".dscfn($vsn);
942 #---------- `ftpmasterapi' archive query method (nascent) ----------
944 sub archive_api_query_cmd ($) {
946 my @cmd = qw(curl -sS);
947 my $url = access_cfg('archive-query-url');
948 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
950 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
951 foreach my $key (split /\:/, $keys) {
952 $key =~ s/\%HOST\%/$host/g;
954 fail "for $url: stat $key: $!" unless $!==ENOENT;
957 fail "config requested specific TLS key but do not know".
958 " how to get curl to use exactly that EE key ($key)";
959 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
960 # # Sadly the above line does not work because of changes
961 # # to gnutls. The real fix for #790093 may involve
962 # # new curl options.
965 # Fixing #790093 properly will involve providing a value
966 # for this on clients.
967 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
968 push @cmd, split / /, $kargs if defined $kargs;
970 push @cmd, $url.$subpath;
976 my ($data, $subpath) = @_;
977 badcfg "ftpmasterapi archive query method takes no data part"
979 my @cmd = archive_api_query_cmd($subpath);
980 my $json = cmdoutput @cmd;
981 return decode_json($json);
984 sub canonicalise_suite_ftpmasterapi () {
985 my ($proto,$data) = @_;
986 my $suites = api_query($data, 'suites');
988 foreach my $entry (@$suites) {
990 my $v = $entry->{$_};
991 defined $v && $v eq $isuite;
993 push @matched, $entry;
995 fail "unknown suite $isuite" unless @matched;
998 @matched==1 or die "multiple matches for suite $isuite\n";
999 $cn = "$matched[0]{codename}";
1000 defined $cn or die "suite $isuite info has no codename\n";
1001 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1003 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1008 sub archive_query_ftpmasterapi () {
1009 my ($proto,$data) = @_;
1010 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1012 my $digester = Digest::SHA->new(256);
1013 foreach my $entry (@$info) {
1015 my $vsn = "$entry->{version}";
1016 my ($ok,$msg) = version_check $vsn;
1017 die "bad version: $msg\n" unless $ok;
1018 my $component = "$entry->{component}";
1019 $component =~ m/^$component_re$/ or die "bad component";
1020 my $filename = "$entry->{filename}";
1021 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1022 or die "bad filename";
1023 my $sha256sum = "$entry->{sha256sum}";
1024 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1025 push @rows, [ $vsn, "/pool/$component/$filename",
1026 $digester, $sha256sum ];
1028 die "bad ftpmaster api response: $@\n".Dumper($entry)
1031 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1035 #---------- `madison' archive query method ----------
1037 sub archive_query_madison {
1038 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1041 sub madison_get_parse {
1042 my ($proto,$data) = @_;
1043 die unless $proto eq 'madison';
1044 if (!length $data) {
1045 $data= access_cfg('madison-distro','RETURN-UNDEF');
1046 $data //= access_basedistro();
1048 $rmad{$proto,$data,$package} ||= cmdoutput
1049 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1050 my $rmad = $rmad{$proto,$data,$package};
1053 foreach my $l (split /\n/, $rmad) {
1054 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1055 \s*( [^ \t|]+ )\s* \|
1056 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1057 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1058 $1 eq $package or die "$rmad $package ?";
1065 $component = access_cfg('archive-query-default-component');
1067 $5 eq 'source' or die "$rmad ?";
1068 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1070 return sort { -version_compare($a->[0],$b->[0]); } @out;
1073 sub canonicalise_suite_madison {
1074 # madison canonicalises for us
1075 my @r = madison_get_parse(@_);
1077 "unable to canonicalise suite using package $package".
1078 " which does not appear to exist in suite $isuite;".
1079 " --existing-package may help";
1083 #---------- `sshpsql' archive query method ----------
1086 my ($data,$runeinfo,$sql) = @_;
1087 if (!length $data) {
1088 $data= access_someuserhost('sshpsql').':'.
1089 access_cfg('sshpsql-dbname');
1091 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1092 my ($userhost,$dbname) = ($`,$'); #';
1094 my @cmd = (access_cfg_ssh, $userhost,
1095 access_runeinfo("ssh-psql $runeinfo").
1096 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1097 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1099 open P, "-|", @cmd or die $!;
1102 printdebug(">|$_|\n");
1105 $!=0; $?=0; close P or failedcmd @cmd;
1107 my $nrows = pop @rows;
1108 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1109 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1110 @rows = map { [ split /\|/, $_ ] } @rows;
1111 my $ncols = scalar @{ shift @rows };
1112 die if grep { scalar @$_ != $ncols } @rows;
1116 sub sql_injection_check {
1117 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1120 sub archive_query_sshpsql ($$) {
1121 my ($proto,$data) = @_;
1122 sql_injection_check $isuite, $package;
1123 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1124 SELECT source.version, component.name, files.filename, files.sha256sum
1126 JOIN src_associations ON source.id = src_associations.source
1127 JOIN suite ON suite.id = src_associations.suite
1128 JOIN dsc_files ON dsc_files.source = source.id
1129 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1130 JOIN component ON component.id = files_archive_map.component_id
1131 JOIN files ON files.id = dsc_files.file
1132 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1133 AND source.source='$package'
1134 AND files.filename LIKE '%.dsc';
1136 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1137 my $digester = Digest::SHA->new(256);
1139 my ($vsn,$component,$filename,$sha256sum) = @$_;
1140 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1145 sub canonicalise_suite_sshpsql ($$) {
1146 my ($proto,$data) = @_;
1147 sql_injection_check $isuite;
1148 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1149 SELECT suite.codename
1150 FROM suite where suite_name='$isuite' or codename='$isuite';
1152 @rows = map { $_->[0] } @rows;
1153 fail "unknown suite $isuite" unless @rows;
1154 die "ambiguous $isuite: @rows ?" if @rows>1;
1158 #---------- `dummycat' archive query method ----------
1160 sub canonicalise_suite_dummycat ($$) {
1161 my ($proto,$data) = @_;
1162 my $dpath = "$data/suite.$isuite";
1163 if (!open C, "<", $dpath) {
1164 $!==ENOENT or die "$dpath: $!";
1165 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1169 chomp or die "$dpath: $!";
1171 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1175 sub archive_query_dummycat ($$) {
1176 my ($proto,$data) = @_;
1177 canonicalise_suite();
1178 my $dpath = "$data/package.$csuite.$package";
1179 if (!open C, "<", $dpath) {
1180 $!==ENOENT or die "$dpath: $!";
1181 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1189 printdebug "dummycat query $csuite $package $dpath | $_\n";
1190 my @row = split /\s+/, $_;
1191 @row==2 or die "$dpath: $_ ?";
1194 C->error and die "$dpath: $!";
1196 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1199 #---------- tag format handling ----------
1201 sub access_cfg_tagformats () {
1202 split /\,/, access_cfg('dgit-tag-format');
1205 sub need_tagformat ($$) {
1206 my ($fmt, $why) = @_;
1207 fail "need to use tag format $fmt ($why) but also need".
1208 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1209 " - no way to proceed"
1210 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1211 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1214 sub select_tagformat () {
1216 return if $tagformatfn && !$tagformat_want;
1217 die 'bug' if $tagformatfn && $tagformat_want;
1218 # ... $tagformat_want assigned after previous select_tagformat
1220 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1221 printdebug "select_tagformat supported @supported\n";
1223 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1224 printdebug "select_tagformat specified @$tagformat_want\n";
1226 my ($fmt,$why,$override) = @$tagformat_want;
1228 fail "target distro supports tag formats @supported".
1229 " but have to use $fmt ($why)"
1231 or grep { $_ eq $fmt } @supported;
1233 $tagformat_want = undef;
1235 $tagformatfn = ${*::}{"debiantag_$fmt"};
1237 fail "trying to use unknown tag format \`$fmt' ($why) !"
1238 unless $tagformatfn;
1241 #---------- archive query entrypoints and rest of program ----------
1243 sub canonicalise_suite () {
1244 return if defined $csuite;
1245 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1246 $csuite = archive_query('canonicalise_suite');
1247 if ($isuite ne $csuite) {
1248 progress "canonical suite name for $isuite is $csuite";
1252 sub get_archive_dsc () {
1253 canonicalise_suite();
1254 my @vsns = archive_query('archive_query');
1255 foreach my $vinfo (@vsns) {
1256 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1257 $dscurl = access_cfg('mirror').$subpath;
1258 $dscdata = url_get($dscurl);
1260 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1265 $digester->add($dscdata);
1266 my $got = $digester->hexdigest();
1268 fail "$dscurl has hash $got but".
1269 " archive told us to expect $digest";
1271 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1272 printdebug Dumper($dscdata) if $debuglevel>1;
1273 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1274 printdebug Dumper($dsc) if $debuglevel>1;
1275 my $fmt = getfield $dsc, 'Format';
1276 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1277 $dsc_checked = !!$digester;
1278 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1282 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1285 sub check_for_git ();
1286 sub check_for_git () {
1288 my $how = access_cfg('git-check');
1289 if ($how eq 'ssh-cmd') {
1291 (access_cfg_ssh, access_gituserhost(),
1292 access_runeinfo("git-check $package").
1293 " set -e; cd ".access_cfg('git-path').";".
1294 " if test -d $package.git; then echo 1; else echo 0; fi");
1295 my $r= cmdoutput @cmd;
1296 if (defined $r and $r =~ m/^divert (\w+)$/) {
1298 my ($usedistro,) = access_distros();
1299 # NB that if we are pushing, $usedistro will be $distro/push
1300 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1301 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1302 progress "diverting to $divert (using config for $instead_distro)";
1303 return check_for_git();
1305 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1307 } elsif ($how eq 'url') {
1308 my $prefix = access_cfg('git-check-url','git-url');
1309 my $suffix = access_cfg('git-check-suffix','git-suffix',
1310 'RETURN-UNDEF') // '.git';
1311 my $url = "$prefix/$package$suffix";
1312 my @cmd = (qw(curl -sS -I), $url);
1313 my $result = cmdoutput @cmd;
1314 $result =~ s/^\S+ 200 .*\n\r?\n//;
1315 # curl -sS -I with https_proxy prints
1316 # HTTP/1.0 200 Connection established
1317 $result =~ m/^\S+ (404|200) /s or
1318 fail "unexpected results from git check query - ".
1319 Dumper($prefix, $result);
1321 if ($code eq '404') {
1323 } elsif ($code eq '200') {
1328 } elsif ($how eq 'true') {
1330 } elsif ($how eq 'false') {
1333 badcfg "unknown git-check \`$how'";
1337 sub create_remote_git_repo () {
1338 my $how = access_cfg('git-create');
1339 if ($how eq 'ssh-cmd') {
1341 (access_cfg_ssh, access_gituserhost(),
1342 access_runeinfo("git-create $package").
1343 "set -e; cd ".access_cfg('git-path').";".
1344 " cp -a _template $package.git");
1345 } elsif ($how eq 'true') {
1348 badcfg "unknown git-create \`$how'";
1352 our ($dsc_hash,$lastpush_mergeinput);
1354 our $ud = '.git/dgit/unpack';
1364 sub mktree_in_ud_here () {
1365 runcmd qw(git init -q);
1366 runcmd qw(git config gc.auto 0);
1367 rmtree('.git/objects');
1368 symlink '../../../../objects','.git/objects' or die $!;
1371 sub git_write_tree () {
1372 my $tree = cmdoutput @git, qw(write-tree);
1373 $tree =~ m/^\w+$/ or die "$tree ?";
1377 sub remove_stray_gits () {
1378 my @gitscmd = qw(find -name .git -prune -print0);
1379 debugcmd "|",@gitscmd;
1380 open GITS, "-|", @gitscmd or die $!;
1385 print STDERR "$us: warning: removing from source package: ",
1386 (messagequote $_), "\n";
1390 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1393 sub mktree_in_ud_from_only_subdir (;$) {
1396 # changes into the subdir
1398 die "expected one subdir but found @dirs ?" unless @dirs==1;
1399 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1403 remove_stray_gits();
1404 mktree_in_ud_here();
1406 my ($format, $fopts) = get_source_format();
1407 if (madformat($format)) {
1412 runcmd @git, qw(add -Af);
1413 my $tree=git_write_tree();
1414 return ($tree,$dir);
1417 sub dsc_files_info () {
1418 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1419 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1420 ['Files', 'Digest::MD5', 'new()']) {
1421 my ($fname, $module, $method) = @$csumi;
1422 my $field = $dsc->{$fname};
1423 next unless defined $field;
1424 eval "use $module; 1;" or die $@;
1426 foreach (split /\n/, $field) {
1428 m/^(\w+) (\d+) (\S+)$/ or
1429 fail "could not parse .dsc $fname line \`$_'";
1430 my $digester = eval "$module"."->$method;" or die $@;
1435 Digester => $digester,
1440 fail "missing any supported Checksums-* or Files field in ".
1441 $dsc->get_option('name');
1445 map { $_->{Filename} } dsc_files_info();
1448 sub is_orig_file_in_dsc ($$) {
1449 my ($f, $dsc_files_info) = @_;
1450 return 0 if @$dsc_files_info <= 1;
1451 # One file means no origs, and the filename doesn't have a "what
1452 # part of dsc" component. (Consider versions ending `.orig'.)
1453 return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1457 sub is_orig_file_of_vsn ($$) {
1458 my ($f, $upstreamvsn) = @_;
1459 my $base = srcfn $upstreamvsn, '';
1460 return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1464 sub make_commit ($) {
1466 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1469 sub make_commit_text ($) {
1472 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1474 print Dumper($text) if $debuglevel > 1;
1475 my $child = open2($out, $in, @cmd) or die $!;
1478 print $in $text or die $!;
1479 close $in or die $!;
1481 $h =~ m/^\w+$/ or die;
1483 printdebug "=> $h\n";
1486 waitpid $child, 0 == $child or die "$child $!";
1487 $? and failedcmd @cmd;
1491 sub clogp_authline ($) {
1493 my $author = getfield $clogp, 'Maintainer';
1494 $author =~ s#,.*##ms;
1495 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1496 my $authline = "$author $date";
1497 $authline =~ m/$git_authline_re/o or
1498 fail "unexpected commit author line format \`$authline'".
1499 " (was generated from changelog Maintainer field)";
1500 return ($1,$2,$3) if wantarray;
1504 sub vendor_patches_distro ($$) {
1505 my ($checkdistro, $what) = @_;
1506 return unless defined $checkdistro;
1508 my $series = "debian/patches/\L$checkdistro\E.series";
1509 printdebug "checking for vendor-specific $series ($what)\n";
1511 if (!open SERIES, "<", $series) {
1512 die "$series $!" unless $!==ENOENT;
1521 Unfortunately, this source package uses a feature of dpkg-source where
1522 the same source package unpacks to different source code on different
1523 distros. dgit cannot safely operate on such packages on affected
1524 distros, because the meaning of source packages is not stable.
1526 Please ask the distro/maintainer to remove the distro-specific series
1527 files and use a different technique (if necessary, uploading actually
1528 different packages, if different distros are supposed to have
1532 fail "Found active distro-specific series file for".
1533 " $checkdistro ($what): $series, cannot continue";
1535 die "$series $!" if SERIES->error;
1539 sub check_for_vendor_patches () {
1540 # This dpkg-source feature doesn't seem to be documented anywhere!
1541 # But it can be found in the changelog (reformatted):
1543 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1544 # Author: Raphael Hertzog <hertzog@debian.org>
1545 # Date: Sun Oct 3 09:36:48 2010 +0200
1547 # dpkg-source: correctly create .pc/.quilt_series with alternate
1550 # If you have debian/patches/ubuntu.series and you were
1551 # unpacking the source package on ubuntu, quilt was still
1552 # directed to debian/patches/series instead of
1553 # debian/patches/ubuntu.series.
1555 # debian/changelog | 3 +++
1556 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1557 # 2 files changed, 6 insertions(+), 1 deletion(-)
1560 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1561 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1562 "Dpkg::Vendor \`current vendor'");
1563 vendor_patches_distro(access_basedistro(),
1564 "distro being accessed");
1567 sub generate_commits_from_dsc () {
1568 # See big comment in fetch_from_archive, below.
1572 my @dfi = dsc_files_info();
1573 foreach my $fi (@dfi) {
1574 my $f = $fi->{Filename};
1575 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1577 link_ltarget "../../../$f", $f
1581 complete_file_from_dsc('.', $fi)
1584 if (is_orig_file_in_dsc($f, \@dfi)) {
1585 link $f, "../../../../$f"
1591 # We unpack and record the orig tarballs first, so that we only
1592 # need disk space for one private copy of the unpacked source.
1593 # But we can't make them into commits until we have the metadata
1594 # from the debian/changelog, so we record the tree objects now and
1595 # make them into commits later.
1597 my $upstreamv = $dsc->{version};
1598 $upstreamv =~ s/-[^-]+$//;
1599 my $orig_f_base = srcfn $upstreamv, '';
1601 foreach my $fi (@dfi) {
1602 # We actually import, and record as a commit, every tarball
1603 # (unless there is only one file, in which case there seems
1606 my $f = $fi->{Filename};
1607 printdebug "import considering $f ";
1608 (printdebug "only one dfi\n"), next if @dfi == 1;
1609 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1610 (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1614 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1616 printdebug "Y ", (join ' ', map { $_//"(none)" }
1617 $compr_ext, $orig_f_part
1620 my $input = new IO::File $f, '<' or die "$f $!";
1624 if (defined $compr_ext) {
1626 Dpkg::Compression::compression_guess_from_filename $f;
1627 fail "Dpkg::Compression cannot handle file $f in source package"
1628 if defined $compr_ext && !defined $cname;
1630 new Dpkg::Compression::Process compression => $cname;
1631 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1632 my $compr_fh = new IO::Handle;
1633 my $compr_pid = open $compr_fh, "-|" // die $!;
1635 open STDIN, "<&", $input or die $!;
1637 die "dgit (child): exec $compr_cmd[0]: $!\n";
1642 rmtree "../unpack-tar";
1643 mkdir "../unpack-tar" or die $!;
1644 my @tarcmd = qw(tar -x -f -
1645 --no-same-owner --no-same-permissions
1646 --no-acls --no-xattrs --no-selinux);
1647 my $tar_pid = fork // die $!;
1649 chdir "../unpack-tar" or die $!;
1650 open STDIN, "<&", $input or die $!;
1652 die "dgit (child): exec $tarcmd[0]: $!";
1654 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1655 !$? or failedcmd @tarcmd;
1658 (@compr_cmd ? failedcmd @compr_cmd
1660 # finally, we have the results in "tarball", but maybe
1661 # with the wrong permissions
1663 runcmd qw(chmod -R +rwX ../unpack-tar);
1664 changedir "../unpack-tar";
1665 my ($tree) = mktree_in_ud_from_only_subdir(1);
1666 changedir "../../unpack";
1667 rmtree "../unpack-tar";
1669 my $ent = [ $f, $tree ];
1671 Orig => !!$orig_f_part,
1672 Sort => (!$orig_f_part ? 2 :
1673 $orig_f_part =~ m/-/g ? 1 :
1681 # put any without "_" first (spec is not clear whether files
1682 # are always in the usual order). Tarballs without "_" are
1683 # the main orig or the debian tarball.
1684 $a->{Sort} <=> $b->{Sort} or
1688 my $any_orig = grep { $_->{Orig} } @tartrees;
1690 my $dscfn = "$package.dsc";
1692 my $treeimporthow = 'package';
1694 open D, ">", $dscfn or die "$dscfn: $!";
1695 print D $dscdata or die "$dscfn: $!";
1696 close D or die "$dscfn: $!";
1697 my @cmd = qw(dpkg-source);
1698 push @cmd, '--no-check' if $dsc_checked;
1699 if (madformat $dsc->{format}) {
1700 push @cmd, '--skip-patches';
1701 $treeimporthow = 'unpatched';
1703 push @cmd, qw(-x --), $dscfn;
1706 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1707 if (madformat $dsc->{format}) {
1708 check_for_vendor_patches();
1712 if (madformat $dsc->{format}) {
1713 my @pcmd = qw(dpkg-source --before-build .);
1714 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1716 runcmd @git, qw(add -Af);
1717 $dappliedtree = git_write_tree();
1720 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1721 debugcmd "|",@clogcmd;
1722 open CLOGS, "-|", @clogcmd or die $!;
1727 printdebug "import clog search...\n";
1730 my $stanzatext = do { local $/=""; <CLOGS>; };
1731 printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1732 last if !defined $stanzatext;
1734 my $desc = "package changelog, entry no.$.";
1735 open my $stanzafh, "<", \$stanzatext or die;
1736 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1737 $clogp //= $thisstanza;
1739 printdebug "import clog $thisstanza->{version} $desc...\n";
1741 last if !$any_orig; # we don't need $r1clogp
1743 # We look for the first (most recent) changelog entry whose
1744 # version number is lower than the upstream version of this
1745 # package. Then the last (least recent) previous changelog
1746 # entry is treated as the one which introduced this upstream
1747 # version and used for the synthetic commits for the upstream
1750 # One might think that a more sophisticated algorithm would be
1751 # necessary. But: we do not want to scan the whole changelog
1752 # file. Stopping when we see an earlier version, which
1753 # necessarily then is an earlier upstream version, is the only
1754 # realistic way to do that. Then, either the earliest
1755 # changelog entry we have seen so far is indeed the earliest
1756 # upload of this upstream version; or there are only changelog
1757 # entries relating to later upstream versions (which is not
1758 # possible unless the changelog and .dsc disagree about the
1759 # version). Then it remains to choose between the physically
1760 # last entry in the file, and the one with the lowest version
1761 # number. If these are not the same, we guess that the
1762 # versions were created in a non-monotic order rather than
1763 # that the changelog entries have been misordered.
1765 printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1767 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1768 $r1clogp = $thisstanza;
1770 printdebug "import clog $r1clogp->{version} becomes r1\n";
1772 die $! if CLOGS->error;
1773 close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
1775 $clogp or fail "package changelog has no entries!";
1777 my $authline = clogp_authline $clogp;
1778 my $changes = getfield $clogp, 'Changes';
1779 my $cversion = getfield $clogp, 'Version';
1782 $r1clogp //= $clogp; # maybe there's only one entry;
1783 my $r1authline = clogp_authline $r1clogp;
1784 # Strictly, r1authline might now be wrong if it's going to be
1785 # unused because !$any_orig. Whatever.
1787 printdebug "import tartrees authline $authline\n";
1788 printdebug "import tartrees r1authline $r1authline\n";
1790 foreach my $tt (@tartrees) {
1791 printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1793 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1796 committer $r1authline
1800 [dgit import orig $tt->{F}]
1808 [dgit import tarball $package $cversion $tt->{F}]
1813 printdebug "import main commit\n";
1815 open C, ">../commit.tmp" or die $!;
1816 print C <<END or die $!;
1819 print C <<END or die $! foreach @tartrees;
1822 print C <<END or die $!;
1828 [dgit import $treeimporthow $package $cversion]
1832 my $rawimport_hash = make_commit qw(../commit.tmp);
1834 if (madformat $dsc->{format}) {
1835 printdebug "import apply patches...\n";
1837 # regularise the state of the working tree so that
1838 # the checkout of $rawimport_hash works nicely.
1839 my $dappliedcommit = make_commit_text(<<END);
1846 runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1848 runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1850 # We need the answers to be reproducible
1851 my @authline = clogp_authline($clogp);
1852 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
1853 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1854 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
1855 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
1856 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1857 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
1860 runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
1864 { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
1868 my $gapplied = git_rev_parse('HEAD');
1869 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1870 $gappliedtree eq $dappliedtree or
1872 gbp-pq import and dpkg-source disagree!
1873 gbp-pq import gave commit $gapplied
1874 gbp-pq import gave tree $gappliedtree
1875 dpkg-source --before-build gave tree $dappliedtree
1877 $rawimport_hash = $gapplied;
1880 progress "synthesised git commit from .dsc $cversion";
1882 my $rawimport_mergeinput = {
1883 Commit => $rawimport_hash,
1884 Info => "Import of source package",
1886 my @output = ($rawimport_mergeinput);
1888 if ($lastpush_mergeinput) {
1889 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1890 my $oversion = getfield $oldclogp, 'Version';
1892 version_compare($oversion, $cversion);
1894 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1895 { Message => <<END, ReverseParents => 1 });
1896 Record $package ($cversion) in archive suite $csuite
1898 } elsif ($vcmp > 0) {
1899 print STDERR <<END or die $!;
1901 Version actually in archive: $cversion (older)
1902 Last version pushed with dgit: $oversion (newer or same)
1905 @output = $lastpush_mergeinput;
1907 # Same version. Use what's in the server git branch,
1908 # discarding our own import. (This could happen if the
1909 # server automatically imports all packages into git.)
1910 @output = $lastpush_mergeinput;
1913 changedir '../../../..';
1918 sub complete_file_from_dsc ($$) {
1919 our ($dstdir, $fi) = @_;
1920 # Ensures that we have, in $dir, the file $fi, with the correct
1921 # contents. (Downloading it from alongside $dscurl if necessary.)
1923 my $f = $fi->{Filename};
1924 my $tf = "$dstdir/$f";
1927 if (stat_exists $tf) {
1928 progress "using existing $f";
1931 $furl =~ s{/[^/]+$}{};
1933 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1934 die "$f ?" if $f =~ m#/#;
1935 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1936 return 0 if !act_local();
1940 open F, "<", "$tf" or die "$tf: $!";
1941 $fi->{Digester}->reset();
1942 $fi->{Digester}->addfile(*F);
1943 F->error and die $!;
1944 my $got = $fi->{Digester}->hexdigest();
1945 $got eq $fi->{Hash} or
1946 fail "file $f has hash $got but .dsc".
1947 " demands hash $fi->{Hash} ".
1948 ($downloaded ? "(got wrong file from archive!)"
1949 : "(perhaps you should delete this file?)");
1954 sub ensure_we_have_orig () {
1955 my @dfi = dsc_files_info();
1956 foreach my $fi (@dfi) {
1957 my $f = $fi->{Filename};
1958 next unless is_orig_file_in_dsc($f, \@dfi);
1959 complete_file_from_dsc('..', $fi)
1964 sub git_fetch_us () {
1965 # Want to fetch only what we are going to use, unless
1966 # deliberately-not-ff, in which case we must fetch everything.
1968 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1970 (quiltmode_splitbrain
1971 ? (map { $_->('*',access_basedistro) }
1972 \&debiantag_new, \&debiantag_maintview)
1973 : debiantags('*',access_basedistro));
1974 push @specs, server_branch($csuite);
1975 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1977 # This is rather miserable:
1978 # When git-fetch --prune is passed a fetchspec ending with a *,
1979 # it does a plausible thing. If there is no * then:
1980 # - it matches subpaths too, even if the supplied refspec
1981 # starts refs, and behaves completely madly if the source
1982 # has refs/refs/something. (See, for example, Debian #NNNN.)
1983 # - if there is no matching remote ref, it bombs out the whole
1985 # We want to fetch a fixed ref, and we don't know in advance
1986 # if it exists, so this is not suitable.
1988 # Our workaround is to use git-ls-remote. git-ls-remote has its
1989 # own qairks. Notably, it has the absurd multi-tail-matching
1990 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1991 # refs/refs/foo etc.
1993 # Also, we want an idempotent snapshot, but we have to make two
1994 # calls to the remote: one to git-ls-remote and to git-fetch. The
1995 # solution is use git-ls-remote to obtain a target state, and
1996 # git-fetch to try to generate it. If we don't manage to generate
1997 # the target state, we try again.
1999 my $specre = join '|', map {
2005 printdebug "git_fetch_us specre=$specre\n";
2006 my $wanted_rref = sub {
2008 return m/^(?:$specre)$/o;
2011 my $fetch_iteration = 0;
2014 if (++$fetch_iteration > 10) {
2015 fail "too many iterations trying to get sane fetch!";
2018 my @look = map { "refs/$_" } @specs;
2019 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2023 open GITLS, "-|", @lcmd or die $!;
2025 printdebug "=> ", $_;
2026 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2027 my ($objid,$rrefname) = ($1,$2);
2028 if (!$wanted_rref->($rrefname)) {
2030 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
2034 $wantr{$rrefname} = $objid;
2037 close GITLS or failedcmd @lcmd;
2039 # OK, now %want is exactly what we want for refs in @specs
2041 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2042 "+refs/$_:".lrfetchrefs."/$_";
2045 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2046 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2049 %lrfetchrefs_f = ();
2052 git_for_each_ref(lrfetchrefs, sub {
2053 my ($objid,$objtype,$lrefname,$reftail) = @_;
2054 $lrfetchrefs_f{$lrefname} = $objid;
2055 $objgot{$objid} = 1;
2058 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2059 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2060 if (!exists $wantr{$rrefname}) {
2061 if ($wanted_rref->($rrefname)) {
2063 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
2067 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
2070 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2071 delete $lrfetchrefs_f{$lrefname};
2075 foreach my $rrefname (sort keys %wantr) {
2076 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2077 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2078 my $want = $wantr{$rrefname};
2079 next if $got eq $want;
2080 if (!defined $objgot{$want}) {
2082 warning: git-ls-remote suggests we want $lrefname
2083 warning: and it should refer to $want
2084 warning: but git-fetch didn't fetch that object to any relevant ref.
2085 warning: This may be due to a race with someone updating the server.
2086 warning: Will try again...
2088 next FETCH_ITERATION;
2091 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
2093 runcmd_ordryrun_local @git, qw(update-ref -m),
2094 "dgit fetch git-fetch fixup", $lrefname, $want;
2095 $lrfetchrefs_f{$lrefname} = $want;
2099 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
2100 Dumper(\%lrfetchrefs_f);
2103 my @tagpats = debiantags('*',access_basedistro);
2105 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2106 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2107 printdebug "currently $fullrefname=$objid\n";
2108 $here{$fullrefname} = $objid;
2110 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2111 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2112 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2113 printdebug "offered $lref=$objid\n";
2114 if (!defined $here{$lref}) {
2115 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2116 runcmd_ordryrun_local @upd;
2117 lrfetchref_used $fullrefname;
2118 } elsif ($here{$lref} eq $objid) {
2119 lrfetchref_used $fullrefname;
2122 "Not updateting $lref from $here{$lref} to $objid.\n";
2127 sub mergeinfo_getclogp ($) {
2128 # Ensures thit $mi->{Clogp} exists and returns it
2130 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2133 sub mergeinfo_version ($) {
2134 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2137 sub fetch_from_archive () {
2138 # Ensures that lrref() is what is actually in the archive, one way
2139 # or another, according to us - ie this client's
2140 # appropritaely-updated archive view. Also returns the commit id.
2141 # If there is nothing in the archive, leaves lrref alone and
2142 # returns undef. git_fetch_us must have already been called.
2146 foreach my $field (@ourdscfield) {
2147 $dsc_hash = $dsc->{$field};
2148 last if defined $dsc_hash;
2150 if (defined $dsc_hash) {
2151 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2153 progress "last upload to archive specified git hash";
2155 progress "last upload to archive has NO git hash";
2158 progress "no version available from the archive";
2161 # If the archive's .dsc has a Dgit field, there are three
2162 # relevant git commitids we need to choose between and/or merge
2164 # 1. $dsc_hash: the Dgit field from the archive
2165 # 2. $lastpush_hash: the suite branch on the dgit git server
2166 # 3. $lastfetch_hash: our local tracking brach for the suite
2168 # These may all be distinct and need not be in any fast forward
2171 # If the dsc was pushed to this suite, then the server suite
2172 # branch will have been updated; but it might have been pushed to
2173 # a different suite and copied by the archive. Conversely a more
2174 # recent version may have been pushed with dgit but not appeared
2175 # in the archive (yet).
2177 # $lastfetch_hash may be awkward because archive imports
2178 # (particularly, imports of Dgit-less .dscs) are performed only as
2179 # needed on individual clients, so different clients may perform a
2180 # different subset of them - and these imports are only made
2181 # public during push. So $lastfetch_hash may represent a set of
2182 # imports different to a subsequent upload by a different dgit
2185 # Our approach is as follows:
2187 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2188 # descendant of $dsc_hash, then it was pushed by a dgit user who
2189 # had based their work on $dsc_hash, so we should prefer it.
2190 # Otherwise, $dsc_hash was installed into this suite in the
2191 # archive other than by a dgit push, and (necessarily) after the
2192 # last dgit push into that suite (since a dgit push would have
2193 # been descended from the dgit server git branch); thus, in that
2194 # case, we prefer the archive's version (and produce a
2195 # pseudo-merge to overwrite the dgit server git branch).
2197 # (If there is no Dgit field in the archive's .dsc then
2198 # generate_commit_from_dsc uses the version numbers to decide
2199 # whether the suite branch or the archive is newer. If the suite
2200 # branch is newer it ignores the archive's .dsc; otherwise it
2201 # generates an import of the .dsc, and produces a pseudo-merge to
2202 # overwrite the suite branch with the archive contents.)
2204 # The outcome of that part of the algorithm is the `public view',
2205 # and is same for all dgit clients: it does not depend on any
2206 # unpublished history in the local tracking branch.
2208 # As between the public view and the local tracking branch: The
2209 # local tracking branch is only updated by dgit fetch, and
2210 # whenever dgit fetch runs it includes the public view in the
2211 # local tracking branch. Therefore if the public view is not
2212 # descended from the local tracking branch, the local tracking
2213 # branch must contain history which was imported from the archive
2214 # but never pushed; and, its tip is now out of date. So, we make
2215 # a pseudo-merge to overwrite the old imports and stitch the old
2218 # Finally: we do not necessarily reify the public view (as
2219 # described above). This is so that we do not end up stacking two
2220 # pseudo-merges. So what we actually do is figure out the inputs
2221 # to any public view pseudo-merge and put them in @mergeinputs.
2224 # $mergeinputs[]{Commit}
2225 # $mergeinputs[]{Info}
2226 # $mergeinputs[0] is the one whose tree we use
2227 # @mergeinputs is in the order we use in the actual commit)
2230 # $mergeinputs[]{Message} is a commit message to use
2231 # $mergeinputs[]{ReverseParents} if def specifies that parent
2232 # list should be in opposite order
2233 # Such an entry has no Commit or Info. It applies only when found
2234 # in the last entry. (This ugliness is to support making
2235 # identical imports to previous dgit versions.)
2237 my $lastpush_hash = git_get_ref(lrfetchref());
2238 printdebug "previous reference hash=$lastpush_hash\n";
2239 $lastpush_mergeinput = $lastpush_hash && {
2240 Commit => $lastpush_hash,
2241 Info => "dgit suite branch on dgit git server",
2244 my $lastfetch_hash = git_get_ref(lrref());
2245 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2246 my $lastfetch_mergeinput = $lastfetch_hash && {
2247 Commit => $lastfetch_hash,
2248 Info => "dgit client's archive history view",
2251 my $dsc_mergeinput = $dsc_hash && {
2252 Commit => $dsc_hash,
2253 Info => "Dgit field in .dsc from archive",
2257 my $del_lrfetchrefs = sub {
2260 printdebug "del_lrfetchrefs...\n";
2261 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2262 my $objid = $lrfetchrefs_d{$fullrefname};
2263 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2265 $gur ||= new IO::Handle;
2266 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2268 printf $gur "delete %s %s\n", $fullrefname, $objid;
2271 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2275 if (defined $dsc_hash) {
2276 fail "missing remote git history even though dsc has hash -".
2277 " could not find ref ".rref()." at ".access_giturl()
2278 unless $lastpush_hash;
2279 ensure_we_have_orig();
2280 if ($dsc_hash eq $lastpush_hash) {
2281 @mergeinputs = $dsc_mergeinput
2282 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2283 print STDERR <<END or die $!;
2285 Git commit in archive is behind the last version allegedly pushed/uploaded.
2286 Commit referred to by archive: $dsc_hash
2287 Last version pushed with dgit: $lastpush_hash
2290 @mergeinputs = ($lastpush_mergeinput);
2292 # Archive has .dsc which is not a descendant of the last dgit
2293 # push. This can happen if the archive moves .dscs about.
2294 # Just follow its lead.
2295 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2296 progress "archive .dsc names newer git commit";
2297 @mergeinputs = ($dsc_mergeinput);
2299 progress "archive .dsc names other git commit, fixing up";
2300 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2304 @mergeinputs = generate_commits_from_dsc();
2305 # We have just done an import. Now, our import algorithm might
2306 # have been improved. But even so we do not want to generate
2307 # a new different import of the same package. So if the
2308 # version numbers are the same, just use our existing version.
2309 # If the version numbers are different, the archive has changed
2310 # (perhaps, rewound).
2311 if ($lastfetch_mergeinput &&
2312 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2313 (mergeinfo_version $mergeinputs[0]) )) {
2314 @mergeinputs = ($lastfetch_mergeinput);
2316 } elsif ($lastpush_hash) {
2317 # only in git, not in the archive yet
2318 @mergeinputs = ($lastpush_mergeinput);
2319 print STDERR <<END or die $!;
2321 Package not found in the archive, but has allegedly been pushed using dgit.
2325 printdebug "nothing found!\n";
2326 if (defined $skew_warning_vsn) {
2327 print STDERR <<END or die $!;
2329 Warning: relevant archive skew detected.
2330 Archive allegedly contains $skew_warning_vsn
2331 But we were not able to obtain any version from the archive or git.
2335 unshift @end, $del_lrfetchrefs;
2339 if ($lastfetch_hash &&
2341 my $h = $_->{Commit};
2342 $h and is_fast_fwd($lastfetch_hash, $h);
2343 # If true, one of the existing parents of this commit
2344 # is a descendant of the $lastfetch_hash, so we'll
2345 # be ff from that automatically.
2349 push @mergeinputs, $lastfetch_mergeinput;
2352 printdebug "fetch mergeinfos:\n";
2353 foreach my $mi (@mergeinputs) {
2355 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2357 printdebug sprintf " ReverseParents=%d Message=%s",
2358 $mi->{ReverseParents}, $mi->{Message};
2362 my $compat_info= pop @mergeinputs
2363 if $mergeinputs[$#mergeinputs]{Message};
2365 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2368 if (@mergeinputs > 1) {
2370 my $tree_commit = $mergeinputs[0]{Commit};
2372 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2373 $tree =~ m/\n\n/; $tree = $`;
2374 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2377 # We use the changelog author of the package in question the
2378 # author of this pseudo-merge. This is (roughly) correct if
2379 # this commit is simply representing aa non-dgit upload.
2380 # (Roughly because it does not record sponsorship - but we
2381 # don't have sponsorship info because that's in the .changes,
2382 # which isn't in the archivw.)
2384 # But, it might be that we are representing archive history
2385 # updates (including in-archive copies). These are not really
2386 # the responsibility of the person who created the .dsc, but
2387 # there is no-one whose name we should better use. (The
2388 # author of the .dsc-named commit is clearly worse.)
2390 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2391 my $author = clogp_authline $useclogp;
2392 my $cversion = getfield $useclogp, 'Version';
2394 my $mcf = ".git/dgit/mergecommit";
2395 open MC, ">", $mcf or die "$mcf $!";
2396 print MC <<END or die $!;
2400 my @parents = grep { $_->{Commit} } @mergeinputs;
2401 @parents = reverse @parents if $compat_info->{ReverseParents};
2402 print MC <<END or die $! foreach @parents;
2406 print MC <<END or die $!;
2412 if (defined $compat_info->{Message}) {
2413 print MC $compat_info->{Message} or die $!;
2415 print MC <<END or die $!;
2416 Record $package ($cversion) in archive suite $csuite
2420 my $message_add_info = sub {
2422 my $mversion = mergeinfo_version $mi;
2423 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2427 $message_add_info->($mergeinputs[0]);
2428 print MC <<END or die $!;
2429 should be treated as descended from
2431 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2435 $hash = make_commit $mcf;
2437 $hash = $mergeinputs[0]{Commit};
2439 printdebug "fetch hash=$hash\n";
2442 my ($lasth, $what) = @_;
2443 return unless $lasth;
2444 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2447 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2448 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2450 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2451 'DGIT_ARCHIVE', $hash;
2452 cmdoutput @git, qw(log -n2), $hash;
2453 # ... gives git a chance to complain if our commit is malformed
2455 if (defined $skew_warning_vsn) {
2457 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2458 my $gotclogp = commit_getclogp($hash);
2459 my $got_vsn = getfield $gotclogp, 'Version';
2460 printdebug "SKEW CHECK GOT $got_vsn\n";
2461 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2462 print STDERR <<END or die $!;
2464 Warning: archive skew detected. Using the available version:
2465 Archive allegedly contains $skew_warning_vsn
2466 We were able to obtain only $got_vsn
2472 if ($lastfetch_hash ne $hash) {
2473 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2477 dryrun_report @upd_cmd;
2481 lrfetchref_used lrfetchref();
2483 unshift @end, $del_lrfetchrefs;
2487 sub set_local_git_config ($$) {
2489 runcmd @git, qw(config), $k, $v;
2492 sub setup_mergechangelogs (;$) {
2494 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2496 my $driver = 'dpkg-mergechangelogs';
2497 my $cb = "merge.$driver";
2498 my $attrs = '.git/info/attributes';
2499 ensuredir '.git/info';
2501 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2502 if (!open ATTRS, "<", $attrs) {
2503 $!==ENOENT or die "$attrs: $!";
2507 next if m{^debian/changelog\s};
2508 print NATTRS $_, "\n" or die $!;
2510 ATTRS->error and die $!;
2513 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2516 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2517 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2519 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2522 sub setup_useremail (;$) {
2524 return unless $always || access_cfg_bool(1, 'setup-useremail');
2527 my ($k, $envvar) = @_;
2528 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2529 return unless defined $v;
2530 set_local_git_config "user.$k", $v;
2533 $setup->('email', 'DEBEMAIL');
2534 $setup->('name', 'DEBFULLNAME');
2537 sub setup_new_tree () {
2538 setup_mergechangelogs();
2544 canonicalise_suite();
2545 badusage "dry run makes no sense with clone" unless act_local();
2546 my $hasgit = check_for_git();
2547 mkdir $dstdir or fail "create \`$dstdir': $!";
2549 runcmd @git, qw(init -q);
2550 my $giturl = access_giturl(1);
2551 if (defined $giturl) {
2552 open H, "> .git/HEAD" or die $!;
2553 print H "ref: ".lref()."\n" or die $!;
2555 runcmd @git, qw(remote add), 'origin', $giturl;
2558 progress "fetching existing git history";
2560 runcmd_ordryrun_local @git, qw(fetch origin);
2562 progress "starting new git history";
2564 fetch_from_archive() or no_such_package;
2565 my $vcsgiturl = $dsc->{'Vcs-Git'};
2566 if (length $vcsgiturl) {
2567 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2568 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2571 runcmd @git, qw(reset --hard), lrref();
2572 printdone "ready for work in $dstdir";
2576 if (check_for_git()) {
2579 fetch_from_archive() or no_such_package();
2580 printdone "fetched into ".lrref();
2585 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2587 printdone "fetched to ".lrref()." and merged into HEAD";
2590 sub check_not_dirty () {
2591 foreach my $f (qw(local-options local-patch-header)) {
2592 if (stat_exists "debian/source/$f") {
2593 fail "git tree contains debian/source/$f";
2597 return if $ignoredirty;
2599 my @cmd = (@git, qw(diff --quiet HEAD));
2601 $!=0; $?=-1; system @cmd;
2604 fail "working tree is dirty (does not match HEAD)";
2610 sub commit_admin ($) {
2613 runcmd_ordryrun_local @git, qw(commit -m), $m;
2616 sub commit_quilty_patch () {
2617 my $output = cmdoutput @git, qw(status --porcelain);
2619 foreach my $l (split /\n/, $output) {
2620 next unless $l =~ m/\S/;
2621 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2625 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2627 progress "nothing quilty to commit, ok.";
2630 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2631 runcmd_ordryrun_local @git, qw(add -f), @adds;
2632 commit_admin "Commit Debian 3.0 (quilt) metadata";
2635 sub get_source_format () {
2637 if (open F, "debian/source/options") {
2641 s/\s+$//; # ignore missing final newline
2643 my ($k, $v) = ($`, $'); #');
2644 $v =~ s/^"(.*)"$/$1/;
2650 F->error and die $!;
2653 die $! unless $!==&ENOENT;
2656 if (!open F, "debian/source/format") {
2657 die $! unless $!==&ENOENT;
2661 F->error and die $!;
2663 return ($_, \%options);
2666 sub madformat_wantfixup ($) {
2668 return 0 unless $format eq '3.0 (quilt)';
2669 our $quilt_mode_warned;
2670 if ($quilt_mode eq 'nocheck') {
2671 progress "Not doing any fixup of \`$format' due to".
2672 " ----no-quilt-fixup or --quilt=nocheck"
2673 unless $quilt_mode_warned++;
2676 progress "Format \`$format', need to check/update patch stack"
2677 unless $quilt_mode_warned++;
2681 # An "infopair" is a tuple [ $thing, $what ]
2682 # (often $thing is a commit hash; $what is a description)
2684 sub infopair_cond_equal ($$) {
2686 $x->[0] eq $y->[0] or fail <<END;
2687 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2691 sub infopair_lrf_tag_lookup ($$) {
2692 my ($tagnames, $what) = @_;
2693 # $tagname may be an array ref
2694 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2695 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2696 foreach my $tagname (@tagnames) {
2697 my $lrefname = lrfetchrefs."/tags/$tagname";
2698 my $tagobj = $lrfetchrefs_f{$lrefname};
2699 next unless defined $tagobj;
2700 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2701 return [ git_rev_parse($tagobj), $what ];
2703 fail @tagnames==1 ? <<END : <<END;
2704 Wanted tag $what (@tagnames) on dgit server, but not found
2706 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2710 sub infopair_cond_ff ($$) {
2711 my ($anc,$desc) = @_;
2712 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2713 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2717 sub pseudomerge_version_check ($$) {
2718 my ($clogp, $archive_hash) = @_;
2720 my $arch_clogp = commit_getclogp $archive_hash;
2721 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2722 'version currently in archive' ];
2723 if (defined $overwrite_version) {
2724 if (length $overwrite_version) {
2725 infopair_cond_equal([ $overwrite_version,
2726 '--overwrite= version' ],
2729 my $v = $i_arch_v->[0];
2730 progress "Checking package changelog for archive version $v ...";
2732 my @xa = ("-f$v", "-t$v");
2733 my $vclogp = parsechangelog @xa;
2734 my $cv = [ (getfield $vclogp, 'Version'),
2735 "Version field from dpkg-parsechangelog @xa" ];
2736 infopair_cond_equal($i_arch_v, $cv);
2739 $@ =~ s/^dgit: //gm;
2741 "Perhaps debian/changelog does not mention $v ?";
2746 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2750 sub pseudomerge_make_commit ($$$$ $$) {
2751 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2752 $msg_cmd, $msg_msg) = @_;
2753 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2755 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2756 my $authline = clogp_authline $clogp;
2760 !defined $overwrite_version ? ""
2761 : !length $overwrite_version ? " --overwrite"
2762 : " --overwrite=".$overwrite_version;
2765 my $pmf = ".git/dgit/pseudomerge";
2766 open MC, ">", $pmf or die "$pmf $!";
2767 print MC <<END or die $!;
2770 parent $archive_hash
2780 return make_commit($pmf);
2783 sub splitbrain_pseudomerge ($$$$) {
2784 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2785 # => $merged_dgitview
2786 printdebug "splitbrain_pseudomerge...\n";
2788 # We: debian/PREVIOUS HEAD($maintview)
2789 # expect: o ----------------- o
2792 # a/d/PREVIOUS $dgitview
2795 # we do: `------------------ o
2799 printdebug "splitbrain_pseudomerge...\n";
2801 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2803 return $dgitview unless defined $archive_hash;
2805 if (!defined $overwrite_version) {
2806 progress "Checking that HEAD inciudes all changes in archive...";
2809 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2811 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2812 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2813 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2814 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2815 my $i_archive = [ $archive_hash, "current archive contents" ];
2817 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2819 infopair_cond_equal($i_dgit, $i_archive);
2820 infopair_cond_ff($i_dep14, $i_dgit);
2821 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2823 my $r = pseudomerge_make_commit
2824 $clogp, $dgitview, $archive_hash, $i_arch_v,
2825 "dgit --quilt=$quilt_mode",
2826 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2827 Declare fast forward from $overwrite_version
2829 Make fast forward from $i_arch_v->[0]
2832 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2836 sub plain_overwrite_pseudomerge ($$$) {
2837 my ($clogp, $head, $archive_hash) = @_;
2839 printdebug "plain_overwrite_pseudomerge...";
2841 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2843 my @tagformats = access_cfg_tagformats();
2845 map { $_->($i_arch_v->[0], access_basedistro) }
2846 (grep { m/^(?:old|hist)$/ } @tagformats)
2847 ? \&debiantags : \&debiantag_new;
2848 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2849 my $i_archive = [ $archive_hash, "current archive contents" ];
2851 infopair_cond_equal($i_overwr, $i_archive);
2853 return $head if is_fast_fwd $archive_hash, $head;
2855 my $m = "Declare fast forward from $i_arch_v->[0]";
2857 my $r = pseudomerge_make_commit
2858 $clogp, $head, $archive_hash, $i_arch_v,
2861 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2863 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2867 sub push_parse_changelog ($) {
2870 my $clogp = Dpkg::Control::Hash->new();
2871 $clogp->load($clogpfn) or die;
2873 $package = getfield $clogp, 'Source';
2874 my $cversion = getfield $clogp, 'Version';
2875 my $tag = debiantag($cversion, access_basedistro);
2876 runcmd @git, qw(check-ref-format), $tag;
2878 my $dscfn = dscfn($cversion);
2880 return ($clogp, $cversion, $dscfn);
2883 sub push_parse_dsc ($$$) {
2884 my ($dscfn,$dscfnwhat, $cversion) = @_;
2885 $dsc = parsecontrol($dscfn,$dscfnwhat);
2886 my $dversion = getfield $dsc, 'Version';
2887 my $dscpackage = getfield $dsc, 'Source';
2888 ($dscpackage eq $package && $dversion eq $cversion) or
2889 fail "$dscfn is for $dscpackage $dversion".
2890 " but debian/changelog is for $package $cversion";
2893 sub push_tagwants ($$$$) {
2894 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2897 TagFn => \&debiantag,
2902 if (defined $maintviewhead) {
2904 TagFn => \&debiantag_maintview,
2905 Objid => $maintviewhead,
2906 TfSuffix => '-maintview',
2910 foreach my $tw (@tagwants) {
2911 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2912 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2914 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2918 sub push_mktags ($$ $$ $) {
2920 $changesfile,$changesfilewhat,
2923 die unless $tagwants->[0]{View} eq 'dgit';
2925 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2926 $dsc->save("$dscfn.tmp") or die $!;
2928 my $changes = parsecontrol($changesfile,$changesfilewhat);
2929 foreach my $field (qw(Source Distribution Version)) {
2930 $changes->{$field} eq $clogp->{$field} or
2931 fail "changes field $field \`$changes->{$field}'".
2932 " does not match changelog \`$clogp->{$field}'";
2935 my $cversion = getfield $clogp, 'Version';
2936 my $clogsuite = getfield $clogp, 'Distribution';
2938 # We make the git tag by hand because (a) that makes it easier
2939 # to control the "tagger" (b) we can do remote signing
2940 my $authline = clogp_authline $clogp;
2941 my $delibs = join(" ", "",@deliberatelies);
2942 my $declaredistro = access_basedistro();
2946 my $tfn = $tw->{Tfn};
2947 my $head = $tw->{Objid};
2948 my $tag = $tw->{Tag};
2950 open TO, '>', $tfn->('.tmp') or die $!;
2951 print TO <<END or die $!;
2958 if ($tw->{View} eq 'dgit') {
2959 print TO <<END or die $!;
2960 $package release $cversion for $clogsuite ($csuite) [dgit]
2961 [dgit distro=$declaredistro$delibs]
2963 foreach my $ref (sort keys %previously) {
2964 print TO <<END or die $!;
2965 [dgit previously:$ref=$previously{$ref}]
2968 } elsif ($tw->{View} eq 'maint') {
2969 print TO <<END or die $!;
2970 $package release $cversion for $clogsuite ($csuite)
2971 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2974 die Dumper($tw)."?";
2979 my $tagobjfn = $tfn->('.tmp');
2981 if (!defined $keyid) {
2982 $keyid = access_cfg('keyid','RETURN-UNDEF');
2984 if (!defined $keyid) {
2985 $keyid = getfield $clogp, 'Maintainer';
2987 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2988 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2989 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2990 push @sign_cmd, $tfn->('.tmp');
2991 runcmd_ordryrun @sign_cmd;
2993 $tagobjfn = $tfn->('.signed.tmp');
2994 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2995 $tfn->('.tmp'), $tfn->('.tmp.asc');
3001 my @r = map { $mktag->($_); } @$tagwants;
3005 sub sign_changes ($) {
3006 my ($changesfile) = @_;
3008 my @debsign_cmd = @debsign;
3009 push @debsign_cmd, "-k$keyid" if defined $keyid;
3010 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3011 push @debsign_cmd, $changesfile;
3012 runcmd_ordryrun @debsign_cmd;
3017 printdebug "actually entering push\n";
3019 supplementary_message(<<'END');
3020 Push failed, while checking state of the archive.
3021 You can retry the push, after fixing the problem, if you like.
3023 if (check_for_git()) {
3026 my $archive_hash = fetch_from_archive();
3027 if (!$archive_hash) {
3029 fail "package appears to be new in this suite;".
3030 " if this is intentional, use --new";
3033 supplementary_message(<<'END');
3034 Push failed, while preparing your push.
3035 You can retry the push, after fixing the problem, if you like.
3038 need_tagformat 'new', "quilt mode $quilt_mode"
3039 if quiltmode_splitbrain;
3043 access_giturl(); # check that success is vaguely likely
3046 my $clogpfn = ".git/dgit/changelog.822.tmp";
3047 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3049 responder_send_file('parsed-changelog', $clogpfn);
3051 my ($clogp, $cversion, $dscfn) =
3052 push_parse_changelog("$clogpfn");
3054 my $dscpath = "$buildproductsdir/$dscfn";
3055 stat_exists $dscpath or
3056 fail "looked for .dsc $dscfn, but $!;".
3057 " maybe you forgot to build";
3059 responder_send_file('dsc', $dscpath);
3061 push_parse_dsc($dscpath, $dscfn, $cversion);
3063 my $format = getfield $dsc, 'Format';
3064 printdebug "format $format\n";
3066 my $actualhead = git_rev_parse('HEAD');
3067 my $dgithead = $actualhead;
3068 my $maintviewhead = undef;
3070 if (madformat_wantfixup($format)) {
3071 # user might have not used dgit build, so maybe do this now:
3072 if (quiltmode_splitbrain()) {
3073 my $upstreamversion = $clogp->{Version};
3074 $upstreamversion =~ s/-[^-]*$//;
3076 quilt_make_fake_dsc($upstreamversion);
3077 my ($dgitview, $cachekey) =
3078 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3080 "--quilt=$quilt_mode but no cached dgit view:
3081 perhaps tree changed since dgit build[-source] ?";
3083 $dgithead = splitbrain_pseudomerge($clogp,
3084 $actualhead, $dgitview,
3086 $maintviewhead = $actualhead;
3087 changedir '../../../..';
3088 prep_ud(); # so _only_subdir() works, below
3090 commit_quilty_patch();
3094 if (defined $overwrite_version && !defined $maintviewhead) {
3095 $dgithead = plain_overwrite_pseudomerge($clogp,
3103 if ($archive_hash) {
3104 if (is_fast_fwd($archive_hash, $dgithead)) {
3106 } elsif (deliberately_not_fast_forward) {
3109 fail "dgit push: HEAD is not a descendant".
3110 " of the archive's version.\n".
3111 "To overwrite the archive's contents,".
3112 " pass --overwrite[=VERSION].\n".
3113 "To rewind history, if permitted by the archive,".
3114 " use --deliberately-not-fast-forward.";
3119 progress "checking that $dscfn corresponds to HEAD";
3120 runcmd qw(dpkg-source -x --),
3121 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3122 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3123 check_for_vendor_patches() if madformat($dsc->{format});
3124 changedir '../../../..';
3125 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
3126 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
3127 debugcmd "+",@diffcmd;
3129 my $r = system @diffcmd;
3132 fail "$dscfn specifies a different tree to your HEAD commit;".
3133 " perhaps you forgot to build".
3134 ($diffopt eq '--exit-code' ? "" :
3135 " (run with -D to see full diff output)");
3140 if (!$changesfile) {
3141 my $pat = changespat $cversion;
3142 my @cs = glob "$buildproductsdir/$pat";
3143 fail "failed to find unique changes file".
3144 " (looked for $pat in $buildproductsdir);".
3145 " perhaps you need to use dgit -C"
3147 ($changesfile) = @cs;
3149 $changesfile = "$buildproductsdir/$changesfile";
3152 # Checks complete, we're going to try and go ahead:
3154 responder_send_file('changes',$changesfile);
3155 responder_send_command("param head $dgithead");
3156 responder_send_command("param csuite $csuite");
3157 responder_send_command("param tagformat $tagformat");
3158 if (defined $maintviewhead) {
3159 die unless ($protovsn//4) >= 4;
3160 responder_send_command("param maint-view $maintviewhead");
3163 if (deliberately_not_fast_forward) {
3164 git_for_each_ref(lrfetchrefs, sub {
3165 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3166 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3167 responder_send_command("previously $rrefname=$objid");
3168 $previously{$rrefname} = $objid;
3172 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3176 supplementary_message(<<'END');
3177 Push failed, while signing the tag.
3178 You can retry the push, after fixing the problem, if you like.
3180 # If we manage to sign but fail to record it anywhere, it's fine.
3181 if ($we_are_responder) {
3182 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3183 responder_receive_files('signed-tag', @tagobjfns);
3185 @tagobjfns = push_mktags($clogp,$dscpath,
3186 $changesfile,$changesfile,
3189 supplementary_message(<<'END');
3190 Push failed, *after* signing the tag.
3191 If you want to try again, you should use a new version number.
3194 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3196 foreach my $tw (@tagwants) {
3197 my $tag = $tw->{Tag};
3198 my $tagobjfn = $tw->{TagObjFn};
3200 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3201 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3202 runcmd_ordryrun_local
3203 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3206 supplementary_message(<<'END');
3207 Push failed, while updating the remote git repository - see messages above.
3208 If you want to try again, you should use a new version number.
3210 if (!check_for_git()) {
3211 create_remote_git_repo();
3214 my @pushrefs = $forceflag.$dgithead.":".rrref();
3215 foreach my $tw (@tagwants) {
3216 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3219 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
3220 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3222 supplementary_message(<<'END');
3223 Push failed, after updating the remote git repository.
3224 If you want to try again, you must use a new version number.
3226 if ($we_are_responder) {
3227 my $dryrunsuffix = act_local() ? "" : ".tmp";
3228 responder_receive_files('signed-dsc-changes',
3229 "$dscpath$dryrunsuffix",
3230 "$changesfile$dryrunsuffix");
3233 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3235 progress "[new .dsc left in $dscpath.tmp]";
3237 sign_changes $changesfile;
3240 supplementary_message(<<END);
3241 Push failed, while uploading package(s) to the archive server.
3242 You can retry the upload of exactly these same files with dput of:
3244 If that .changes file is broken, you will need to use a new version
3245 number for your next attempt at the upload.
3247 my $host = access_cfg('upload-host','RETURN-UNDEF');
3248 my @hostarg = defined($host) ? ($host,) : ();
3249 runcmd_ordryrun @dput, @hostarg, $changesfile;
3250 printdone "pushed and uploaded $cversion";
3252 supplementary_message('');
3253 responder_send_command("complete");
3260 badusage "-p is not allowed with clone; specify as argument instead"
3261 if defined $package;
3264 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3265 ($package,$isuite) = @ARGV;
3266 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3267 ($package,$dstdir) = @ARGV;
3268 } elsif (@ARGV==3) {
3269 ($package,$isuite,$dstdir) = @ARGV;
3271 badusage "incorrect arguments to dgit clone";
3273 $dstdir ||= "$package";
3275 if (stat_exists $dstdir) {
3276 fail "$dstdir already exists";
3280 if ($rmonerror && !$dryrun_level) {
3281 $cwd_remove= getcwd();
3283 return unless defined $cwd_remove;
3284 if (!chdir "$cwd_remove") {
3285 return if $!==&ENOENT;
3286 die "chdir $cwd_remove: $!";
3289 rmtree($dstdir) or die "remove $dstdir: $!\n";
3290 } elsif (!grep { $! == $_ }
3291 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3293 print STDERR "check whether to remove $dstdir: $!\n";
3299 $cwd_remove = undef;
3302 sub branchsuite () {
3303 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3304 if ($branch =~ m#$lbranch_re#o) {
3311 sub fetchpullargs () {
3313 if (!defined $package) {
3314 my $sourcep = parsecontrol('debian/control','debian/control');
3315 $package = getfield $sourcep, 'Source';
3318 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3320 my $clogp = parsechangelog();
3321 $isuite = getfield $clogp, 'Distribution';
3323 canonicalise_suite();
3324 progress "fetching from suite $csuite";
3325 } elsif (@ARGV==1) {
3327 canonicalise_suite();
3329 badusage "incorrect arguments to dgit fetch or dgit pull";
3348 badusage "-p is not allowed with dgit push" if defined $package;
3350 my $clogp = parsechangelog();
3351 $package = getfield $clogp, 'Source';
3354 } elsif (@ARGV==1) {
3355 ($specsuite) = (@ARGV);
3357 badusage "incorrect arguments to dgit push";
3359 $isuite = getfield $clogp, 'Distribution';
3361 local ($package) = $existing_package; # this is a hack
3362 canonicalise_suite();
3364 canonicalise_suite();
3366 if (defined $specsuite &&
3367 $specsuite ne $isuite &&
3368 $specsuite ne $csuite) {
3369 fail "dgit push: changelog specifies $isuite ($csuite)".
3370 " but command line specifies $specsuite";
3375 #---------- remote commands' implementation ----------
3377 sub cmd_remote_push_build_host {
3378 my ($nrargs) = shift @ARGV;
3379 my (@rargs) = @ARGV[0..$nrargs-1];
3380 @ARGV = @ARGV[$nrargs..$#ARGV];
3382 my ($dir,$vsnwant) = @rargs;
3383 # vsnwant is a comma-separated list; we report which we have
3384 # chosen in our ready response (so other end can tell if they
3387 $we_are_responder = 1;
3388 $us .= " (build host)";
3392 open PI, "<&STDIN" or die $!;
3393 open STDIN, "/dev/null" or die $!;
3394 open PO, ">&STDOUT" or die $!;
3396 open STDOUT, ">&STDERR" or die $!;
3400 ($protovsn) = grep {
3401 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3402 } @rpushprotovsn_support;
3404 fail "build host has dgit rpush protocol versions ".
3405 (join ",", @rpushprotovsn_support).
3406 " but invocation host has $vsnwant"
3407 unless defined $protovsn;
3409 responder_send_command("dgit-remote-push-ready $protovsn");
3410 rpush_handle_protovsn_bothends();
3415 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3416 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3417 # a good error message)
3419 sub rpush_handle_protovsn_bothends () {
3420 if ($protovsn < 4) {
3421 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3430 my $report = i_child_report();
3431 if (defined $report) {
3432 printdebug "($report)\n";
3433 } elsif ($i_child_pid) {
3434 printdebug "(killing build host child $i_child_pid)\n";
3435 kill 15, $i_child_pid;
3437 if (defined $i_tmp && !defined $initiator_tempdir) {
3439 eval { rmtree $i_tmp; };
3443 END { i_cleanup(); }
3446 my ($base,$selector,@args) = @_;
3447 $selector =~ s/\-/_/g;
3448 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3455 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3463 push @rargs, join ",", @rpushprotovsn_support;
3466 push @rdgit, @ropts;
3467 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3469 my @cmd = (@ssh, $host, shellquote @rdgit);
3472 if (defined $initiator_tempdir) {
3473 rmtree $initiator_tempdir;
3474 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3475 $i_tmp = $initiator_tempdir;
3479 $i_child_pid = open2(\*RO, \*RI, @cmd);
3481 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3482 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3483 $supplementary_message = '' unless $protovsn >= 3;
3485 fail "rpush negotiated protocol version $protovsn".
3486 " which does not support quilt mode $quilt_mode"
3487 if quiltmode_splitbrain;
3489 rpush_handle_protovsn_bothends();
3491 my ($icmd,$iargs) = initiator_expect {
3492 m/^(\S+)(?: (.*))?$/;
3495 i_method "i_resp", $icmd, $iargs;
3499 sub i_resp_progress ($) {
3501 my $msg = protocol_read_bytes \*RO, $rhs;
3505 sub i_resp_supplementary_message ($) {
3507 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3510 sub i_resp_complete {
3511 my $pid = $i_child_pid;
3512 $i_child_pid = undef; # prevents killing some other process with same pid
3513 printdebug "waiting for build host child $pid...\n";
3514 my $got = waitpid $pid, 0;
3515 die $! unless $got == $pid;
3516 die "build host child failed $?" if $?;
3519 printdebug "all done\n";
3523 sub i_resp_file ($) {
3525 my $localname = i_method "i_localname", $keyword;
3526 my $localpath = "$i_tmp/$localname";
3527 stat_exists $localpath and
3528 badproto \*RO, "file $keyword ($localpath) twice";
3529 protocol_receive_file \*RO, $localpath;
3530 i_method "i_file", $keyword;
3535 sub i_resp_param ($) {
3536 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3540 sub i_resp_previously ($) {
3541 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3542 or badproto \*RO, "bad previously spec";
3543 my $r = system qw(git check-ref-format), $1;
3544 die "bad previously ref spec ($r)" if $r;
3545 $previously{$1} = $2;
3550 sub i_resp_want ($) {
3552 die "$keyword ?" if $i_wanted{$keyword}++;
3553 my @localpaths = i_method "i_want", $keyword;
3554 printdebug "[[ $keyword @localpaths\n";
3555 foreach my $localpath (@localpaths) {
3556 protocol_send_file \*RI, $localpath;
3558 print RI "files-end\n" or die $!;
3561 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3563 sub i_localname_parsed_changelog {
3564 return "remote-changelog.822";
3566 sub i_file_parsed_changelog {
3567 ($i_clogp, $i_version, $i_dscfn) =
3568 push_parse_changelog "$i_tmp/remote-changelog.822";
3569 die if $i_dscfn =~ m#/|^\W#;
3572 sub i_localname_dsc {
3573 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3578 sub i_localname_changes {
3579 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3580 $i_changesfn = $i_dscfn;
3581 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3582 return $i_changesfn;
3584 sub i_file_changes { }
3586 sub i_want_signed_tag {
3587 printdebug Dumper(\%i_param, $i_dscfn);
3588 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3589 && defined $i_param{'csuite'}
3590 or badproto \*RO, "premature desire for signed-tag";
3591 my $head = $i_param{'head'};
3592 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3594 my $maintview = $i_param{'maint-view'};
3595 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3598 if ($protovsn >= 4) {
3599 my $p = $i_param{'tagformat'} // '<undef>';
3601 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3604 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3606 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3608 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3611 push_mktags $i_clogp, $i_dscfn,
3612 $i_changesfn, 'remote changes',
3616 sub i_want_signed_dsc_changes {
3617 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3618 sign_changes $i_changesfn;
3619 return ($i_dscfn, $i_changesfn);
3622 #---------- building etc. ----------
3628 #----- `3.0 (quilt)' handling -----
3630 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3632 sub quiltify_dpkg_commit ($$$;$) {
3633 my ($patchname,$author,$msg, $xinfo) = @_;
3637 my $descfn = ".git/dgit/quilt-description.tmp";
3638 open O, '>', $descfn or die "$descfn: $!";
3641 $msg =~ s/^\s+$/ ./mg;
3642 print O <<END or die $!;
3652 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3653 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3654 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3655 runcmd @dpkgsource, qw(--commit .), $patchname;
3659 sub quiltify_trees_differ ($$;$$) {
3660 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3661 # returns true iff the two tree objects differ other than in debian/
3662 # with $finegrained,
3663 # returns bitmask 01 - differ in upstream files except .gitignore
3664 # 02 - differ in .gitignore
3665 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3666 # is set for each modified .gitignore filename $fn
3668 my @cmd = (@git, qw(diff-tree --name-only -z));
3669 push @cmd, qw(-r) if $finegrained;
3671 my $diffs= cmdoutput @cmd;
3673 foreach my $f (split /\0/, $diffs) {
3674 next if $f =~ m#^debian(?:/.*)?$#s;
3675 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3676 $r |= $isignore ? 02 : 01;
3677 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3679 printdebug "quiltify_trees_differ $x $y => $r\n";
3683 sub quiltify_tree_sentinelfiles ($) {
3684 # lists the `sentinel' files present in the tree
3686 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3687 qw(-- debian/rules debian/control);
3692 sub quiltify_splitbrain_needed () {
3693 if (!$split_brain) {
3694 progress "dgit view: changes are required...";
3695 runcmd @git, qw(checkout -q -b dgit-view);
3700 sub quiltify_splitbrain ($$$$$$) {
3701 my ($clogp, $unapplied, $headref, $diffbits,
3702 $editedignores, $cachekey) = @_;
3703 if ($quilt_mode !~ m/gbp|dpm/) {
3704 # treat .gitignore just like any other upstream file
3705 $diffbits = { %$diffbits };
3706 $_ = !!$_ foreach values %$diffbits;
3708 # We would like any commits we generate to be reproducible
3709 my @authline = clogp_authline($clogp);
3710 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3711 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3712 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3713 local $ENV{GIT_AUTHOR_NAME} = $authline[0];
3714 local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3715 local $ENV{GIT_AUTHOR_DATE} = $authline[2];
3717 if ($quilt_mode =~ m/gbp|unapplied/ &&
3718 ($diffbits->{H2O} & 01)) {
3720 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3721 " but git tree differs from orig in upstream files.";
3722 if (!stat_exists "debian/patches") {
3724 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3728 if ($quilt_mode =~ m/dpm/ &&
3729 ($diffbits->{H2A} & 01)) {
3731 --quilt=$quilt_mode specified, implying patches-applied git tree
3732 but git tree differs from result of applying debian/patches to upstream
3735 if ($quilt_mode =~ m/gbp|unapplied/ &&
3736 ($diffbits->{O2A} & 01)) { # some patches
3737 quiltify_splitbrain_needed();
3738 progress "dgit view: creating patches-applied version using gbp pq";
3739 runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3740 # gbp pq import creates a fresh branch; push back to dgit-view
3741 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3742 runcmd @git, qw(checkout -q dgit-view);
3744 if ($quilt_mode =~ m/gbp|dpm/ &&
3745 ($diffbits->{O2A} & 02)) {
3747 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3748 tool which does not create patches for changes to upstream
3749 .gitignores: but, such patches exist in debian/patches.
3752 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3753 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3754 quiltify_splitbrain_needed();
3755 progress "dgit view: creating patch to represent .gitignore changes";
3756 ensuredir "debian/patches";
3757 my $gipatch = "debian/patches/auto-gitignore";
3758 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3759 stat GIPATCH or die "$gipatch: $!";
3760 fail "$gipatch already exists; but want to create it".
3761 " to record .gitignore changes" if (stat _)[7];
3762 print GIPATCH <<END or die "$gipatch: $!";
3763 Subject: Update .gitignore from Debian packaging branch
3765 The Debian packaging git branch contains these updates to the upstream
3766 .gitignore file(s). This patch is autogenerated, to provide these
3767 updates to users of the official Debian archive view of the package.
3769 [dgit ($our_version) update-gitignore]
3772 close GIPATCH or die "$gipatch: $!";
3773 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3774 $unapplied, $headref, "--", sort keys %$editedignores;
3775 open SERIES, "+>>", "debian/patches/series" or die $!;
3776 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3778 defined read SERIES, $newline, 1 or die $!;
3779 print SERIES "\n" or die $! unless $newline eq "\n";
3780 print SERIES "auto-gitignore\n" or die $!;
3781 close SERIES or die $!;
3782 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3783 commit_admin "Commit patch to update .gitignore";
3786 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3788 changedir '../../../..';
3789 ensuredir ".git/logs/refs/dgit-intern";
3790 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3792 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3795 progress "dgit view: created (commit id $dgitview)";
3797 changedir '.git/dgit/unpack/work';
3800 sub quiltify ($$$$) {
3801 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3803 # Quilt patchification algorithm
3805 # We search backwards through the history of the main tree's HEAD
3806 # (T) looking for a start commit S whose tree object is identical
3807 # to to the patch tip tree (ie the tree corresponding to the
3808 # current dpkg-committed patch series). For these purposes
3809 # `identical' disregards anything in debian/ - this wrinkle is
3810 # necessary because dpkg-source treates debian/ specially.
3812 # We can only traverse edges where at most one of the ancestors'
3813 # trees differs (in changes outside in debian/). And we cannot
3814 # handle edges which change .pc/ or debian/patches. To avoid
3815 # going down a rathole we avoid traversing edges which introduce
3816 # debian/rules or debian/control. And we set a limit on the
3817 # number of edges we are willing to look at.
3819 # If we succeed, we walk forwards again. For each traversed edge
3820 # PC (with P parent, C child) (starting with P=S and ending with
3821 # C=T) to we do this:
3823 # - dpkg-source --commit with a patch name and message derived from C
3824 # After traversing PT, we git commit the changes which
3825 # should be contained within debian/patches.
3827 # The search for the path S..T is breadth-first. We maintain a
3828 # todo list containing search nodes. A search node identifies a
3829 # commit, and looks something like this:
3831 # Commit => $git_commit_id,
3832 # Child => $c, # or undef if P=T
3833 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3834 # Nontrivial => true iff $p..$c has relevant changes
3841 my %considered; # saves being exponential on some weird graphs
3843 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3846 my ($search,$whynot) = @_;
3847 printdebug " search NOT $search->{Commit} $whynot\n";
3848 $search->{Whynot} = $whynot;
3849 push @nots, $search;
3850 no warnings qw(exiting);
3859 my $c = shift @todo;
3860 next if $considered{$c->{Commit}}++;
3862 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3864 printdebug "quiltify investigate $c->{Commit}\n";
3867 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3868 printdebug " search finished hooray!\n";
3873 if ($quilt_mode eq 'nofix') {
3874 fail "quilt fixup required but quilt mode is \`nofix'\n".
3875 "HEAD commit $c->{Commit} differs from tree implied by ".
3876 " debian/patches (tree object $oldtiptree)";
3878 if ($quilt_mode eq 'smash') {
3879 printdebug " search quitting smash\n";
3883 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3884 $not->($c, "has $c_sentinels not $t_sentinels")
3885 if $c_sentinels ne $t_sentinels;
3887 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3888 $commitdata =~ m/\n\n/;
3890 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3891 @parents = map { { Commit => $_, Child => $c } } @parents;
3893 $not->($c, "root commit") if !@parents;
3895 foreach my $p (@parents) {
3896 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3898 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3899 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3901 foreach my $p (@parents) {
3902 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3904 my @cmd= (@git, qw(diff-tree -r --name-only),
3905 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3906 my $patchstackchange = cmdoutput @cmd;
3907 if (length $patchstackchange) {
3908 $patchstackchange =~ s/\n/,/g;
3909 $not->($p, "changed $patchstackchange");
3912 printdebug " search queue P=$p->{Commit} ",
3913 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3919 printdebug "quiltify want to smash\n";
3922 my $x = $_[0]{Commit};
3923 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3926 my $reportnot = sub {
3928 my $s = $abbrev->($notp);
3929 my $c = $notp->{Child};
3930 $s .= "..".$abbrev->($c) if $c;
3931 $s .= ": ".$notp->{Whynot};
3934 if ($quilt_mode eq 'linear') {
3935 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3936 foreach my $notp (@nots) {
3937 print STDERR "$us: ", $reportnot->($notp), "\n";
3939 print STDERR "$us: $_\n" foreach @$failsuggestion;
3940 fail "quilt fixup naive history linearisation failed.\n".
3941 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3942 } elsif ($quilt_mode eq 'smash') {
3943 } elsif ($quilt_mode eq 'auto') {
3944 progress "quilt fixup cannot be linear, smashing...";
3946 die "$quilt_mode ?";
3949 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3950 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3952 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3954 quiltify_dpkg_commit "auto-$version-$target-$time",
3955 (getfield $clogp, 'Maintainer'),
3956 "Automatically generated patch ($clogp->{Version})\n".
3957 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3961 progress "quiltify linearisation planning successful, executing...";
3963 for (my $p = $sref_S;
3964 my $c = $p->{Child};
3966 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3967 next unless $p->{Nontrivial};
3969 my $cc = $c->{Commit};
3971 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3972 $commitdata =~ m/\n\n/ or die "$c ?";
3975 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3978 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3981 my $patchname = $title;
3982 $patchname =~ s/[.:]$//;
3983 $patchname =~ y/ A-Z/-a-z/;
3984 $patchname =~ y/-a-z0-9_.+=~//cd;
3985 $patchname =~ s/^\W/x-$&/;
3986 $patchname = substr($patchname,0,40);
3989 stat "debian/patches/$patchname$index";
3991 $!==ENOENT or die "$patchname$index $!";
3993 runcmd @git, qw(checkout -q), $cc;
3995 # We use the tip's changelog so that dpkg-source doesn't
3996 # produce complaining messages from dpkg-parsechangelog. None
3997 # of the information dpkg-source gets from the changelog is
3998 # actually relevant - it gets put into the original message
3999 # which dpkg-source provides our stunt editor, and then
4001 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
4003 quiltify_dpkg_commit "$patchname$index", $author, $msg,
4004 "X-Dgit-Generated: $clogp->{Version} $cc\n";
4006 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
4009 runcmd @git, qw(checkout -q master);
4012 sub build_maybe_quilt_fixup () {
4013 my ($format,$fopts) = get_source_format;
4014 return unless madformat_wantfixup $format;
4017 check_for_vendor_patches();
4019 if (quiltmode_splitbrain) {
4020 foreach my $needtf (qw(new maint)) {
4021 next if grep { $_ eq $needtf } access_cfg_tagformats;
4023 quilt mode $quilt_mode requires split view so server needs to support
4024 both "new" and "maint" tag formats, but config says it doesn't.
4029 my $clogp = parsechangelog();
4030 my $headref = git_rev_parse('HEAD');
4035 my $upstreamversion=$version;
4036 $upstreamversion =~ s/-[^-]*$//;
4038 if ($fopts->{'single-debian-patch'}) {
4039 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
4041 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
4044 die 'bug' if $split_brain && !$need_split_build_invocation;
4046 changedir '../../../..';
4047 runcmd_ordryrun_local
4048 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
4051 sub quilt_fixup_mkwork ($) {
4054 mkdir "work" or die $!;
4056 mktree_in_ud_here();
4057 runcmd @git, qw(reset -q --hard), $headref;
4060 sub quilt_fixup_linkorigs ($$) {
4061 my ($upstreamversion, $fn) = @_;
4062 # calls $fn->($leafname);
4064 foreach my $f (<../../../../*>) { #/){
4065 my $b=$f; $b =~ s{.*/}{};
4067 local ($debuglevel) = $debuglevel-1;
4068 printdebug "QF linkorigs $b, $f ?\n";
4070 next unless is_orig_file_of_vsn $b, $upstreamversion;
4071 printdebug "QF linkorigs $b, $f Y\n";
4072 link_ltarget $f, $b or die "$b $!";
4077 sub quilt_fixup_delete_pc () {
4078 runcmd @git, qw(rm -rqf .pc);
4079 commit_admin "Commit removal of .pc (quilt series tracking data)";
4082 sub quilt_fixup_singlepatch ($$$) {
4083 my ($clogp, $headref, $upstreamversion) = @_;
4085 progress "starting quiltify (single-debian-patch)";
4087 # dpkg-source --commit generates new patches even if
4088 # single-debian-patch is in debian/source/options. In order to
4089 # get it to generate debian/patches/debian-changes, it is
4090 # necessary to build the source package.
4092 quilt_fixup_linkorigs($upstreamversion, sub { });
4093 quilt_fixup_mkwork($headref);
4095 rmtree("debian/patches");
4097 runcmd @dpkgsource, qw(-b .);
4099 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4100 rename srcfn("$upstreamversion", "/debian/patches"),
4101 "work/debian/patches";
4104 commit_quilty_patch();
4107 sub quilt_make_fake_dsc ($) {
4108 my ($upstreamversion) = @_;
4110 my $fakeversion="$upstreamversion-~~DGITFAKE";
4112 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4113 print $fakedsc <<END or die $!;
4116 Version: $fakeversion
4120 my $dscaddfile=sub {
4123 my $md = new Digest::MD5;
4125 my $fh = new IO::File $b, '<' or die "$b $!";
4130 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4133 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4135 my @files=qw(debian/source/format debian/rules
4136 debian/control debian/changelog);
4137 foreach my $maybe (qw(debian/patches debian/source/options
4138 debian/tests/control)) {
4139 next unless stat_exists "../../../$maybe";
4140 push @files, $maybe;
4143 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4144 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4146 $dscaddfile->($debtar);
4147 close $fakedsc or die $!;
4150 sub quilt_check_splitbrain_cache ($$) {
4151 my ($headref, $upstreamversion) = @_;
4152 # Called only if we are in (potentially) split brain mode.
4154 # Computes the cache key and looks in the cache.
4155 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4157 my $splitbrain_cachekey;
4160 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4161 # we look in the reflog of dgit-intern/quilt-cache
4162 # we look for an entry whose message is the key for the cache lookup
4163 my @cachekey = (qw(dgit), $our_version);
4164 push @cachekey, $upstreamversion;
4165 push @cachekey, $quilt_mode;
4166 push @cachekey, $headref;
4168 push @cachekey, hashfile('fake.dsc');
4170 my $srcshash = Digest::SHA->new(256);
4171 my %sfs = ( %INC, '$0(dgit)' => $0 );
4172 foreach my $sfk (sort keys %sfs) {
4173 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
4174 $srcshash->add($sfk," ");
4175 $srcshash->add(hashfile($sfs{$sfk}));
4176 $srcshash->add("\n");
4178 push @cachekey, $srcshash->hexdigest();
4179 $splitbrain_cachekey = "@cachekey";
4181 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
4183 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4184 debugcmd "|(probably)",@cmd;
4185 my $child = open GC, "-|"; defined $child or die $!;
4187 chdir '../../..' or die $!;
4188 if (!stat ".git/logs/refs/$splitbraincache") {
4189 $! == ENOENT or die $!;
4190 printdebug ">(no reflog)\n";
4197 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4198 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4201 quilt_fixup_mkwork($headref);
4202 if ($cachehit ne $headref) {
4203 progress "dgit view: found cached (commit id $cachehit)";
4204 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4206 return ($cachehit, $splitbrain_cachekey);
4208 progress "dgit view: found cached, no changes required";
4209 return ($headref, $splitbrain_cachekey);
4211 die $! if GC->error;
4212 failedcmd unless close GC;
4214 printdebug "splitbrain cache miss\n";
4215 return (undef, $splitbrain_cachekey);
4218 sub quilt_fixup_multipatch ($$$) {
4219 my ($clogp, $headref, $upstreamversion) = @_;
4221 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4224 # - honour any existing .pc in case it has any strangeness
4225 # - determine the git commit corresponding to the tip of
4226 # the patch stack (if there is one)
4227 # - if there is such a git commit, convert each subsequent
4228 # git commit into a quilt patch with dpkg-source --commit
4229 # - otherwise convert all the differences in the tree into
4230 # a single git commit
4234 # Our git tree doesn't necessarily contain .pc. (Some versions of
4235 # dgit would include the .pc in the git tree.) If there isn't
4236 # one, we need to generate one by unpacking the patches that we
4239 # We first look for a .pc in the git tree. If there is one, we
4240 # will use it. (This is not the normal case.)
4242 # Otherwise need to regenerate .pc so that dpkg-source --commit
4243 # can work. We do this as follows:
4244 # 1. Collect all relevant .orig from parent directory
4245 # 2. Generate a debian.tar.gz out of
4246 # debian/{patches,rules,source/format,source/options}
4247 # 3. Generate a fake .dsc containing just these fields:
4248 # Format Source Version Files
4249 # 4. Extract the fake .dsc
4250 # Now the fake .dsc has a .pc directory.
4251 # (In fact we do this in every case, because in future we will
4252 # want to search for a good base commit for generating patches.)
4254 # Then we can actually do the dpkg-source --commit
4255 # 1. Make a new working tree with the same object
4256 # store as our main tree and check out the main
4258 # 2. Copy .pc from the fake's extraction, if necessary
4259 # 3. Run dpkg-source --commit
4260 # 4. If the result has changes to debian/, then
4261 # - git-add them them
4262 # - git-add .pc if we had a .pc in-tree
4264 # 5. If we had a .pc in-tree, delete it, and git-commit
4265 # 6. Back in the main tree, fast forward to the new HEAD
4267 # Another situation we may have to cope with is gbp-style
4268 # patches-unapplied trees.
4270 # We would want to detect these, so we know to escape into
4271 # quilt_fixup_gbp. However, this is in general not possible.
4272 # Consider a package with a one patch which the dgit user reverts
4273 # (with git-revert or the moral equivalent).
4275 # That is indistinguishable in contents from a patches-unapplied
4276 # tree. And looking at the history to distinguish them is not
4277 # useful because the user might have made a confusing-looking git
4278 # history structure (which ought to produce an error if dgit can't
4279 # cope, not a silent reintroduction of an unwanted patch).
4281 # So gbp users will have to pass an option. But we can usually
4282 # detect their failure to do so: if the tree is not a clean
4283 # patches-applied tree, quilt linearisation fails, but the tree
4284 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4285 # they want --quilt=unapplied.
4287 # To help detect this, when we are extracting the fake dsc, we
4288 # first extract it with --skip-patches, and then apply the patches
4289 # afterwards with dpkg-source --before-build. That lets us save a
4290 # tree object corresponding to .origs.
4292 my $splitbrain_cachekey;
4294 quilt_make_fake_dsc($upstreamversion);
4296 if (quiltmode_splitbrain()) {
4298 ($cachehit, $splitbrain_cachekey) =
4299 quilt_check_splitbrain_cache($headref, $upstreamversion);
4300 return if $cachehit;
4304 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4306 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4307 rename $fakexdir, "fake" or die "$fakexdir $!";
4311 remove_stray_gits();
4312 mktree_in_ud_here();
4316 runcmd @git, qw(add -Af .);
4317 my $unapplied=git_write_tree();
4318 printdebug "fake orig tree object $unapplied\n";
4323 'exec dpkg-source --before-build . >/dev/null';
4327 quilt_fixup_mkwork($headref);
4330 if (stat_exists ".pc") {
4332 progress "Tree already contains .pc - will use it then delete it.";
4335 rename '../fake/.pc','.pc' or die $!;
4338 changedir '../fake';
4340 runcmd @git, qw(add -Af .);
4341 my $oldtiptree=git_write_tree();
4342 printdebug "fake o+d/p tree object $unapplied\n";
4343 changedir '../work';
4346 # We calculate some guesswork now about what kind of tree this might
4347 # be. This is mostly for error reporting.
4352 # O = orig, without patches applied
4353 # A = "applied", ie orig with H's debian/patches applied
4354 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4355 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4356 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4360 foreach my $b (qw(01 02)) {
4361 foreach my $v (qw(H2O O2A H2A)) {
4362 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4365 printdebug "differences \@dl @dl.\n";
4368 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4369 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4370 $dl[0], $dl[1], $dl[3], $dl[4],
4374 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4375 push @failsuggestion, "This might be a patches-unapplied branch.";
4376 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4377 push @failsuggestion, "This might be a patches-applied branch.";
4379 push @failsuggestion, "Maybe you need to specify one of".
4380 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4382 if (quiltmode_splitbrain()) {
4383 quiltify_splitbrain($clogp, $unapplied, $headref,
4384 $diffbits, \%editedignores,
4385 $splitbrain_cachekey);
4389 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4390 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4392 if (!open P, '>>', ".pc/applied-patches") {
4393 $!==&ENOENT or die $!;
4398 commit_quilty_patch();
4400 if ($mustdeletepc) {
4401 quilt_fixup_delete_pc();
4405 sub quilt_fixup_editor () {
4406 my $descfn = $ENV{$fakeeditorenv};
4407 my $editing = $ARGV[$#ARGV];
4408 open I1, '<', $descfn or die "$descfn: $!";
4409 open I2, '<', $editing or die "$editing: $!";
4410 unlink $editing or die "$editing: $!";
4411 open O, '>', $editing or die "$editing: $!";
4412 while (<I1>) { print O or die $!; } I1->error and die $!;
4415 $copying ||= m/^\-\-\- /;
4416 next unless $copying;
4419 I2->error and die $!;
4424 sub maybe_apply_patches_dirtily () {
4425 return unless $quilt_mode =~ m/gbp|unapplied/;
4426 print STDERR <<END or die $!;
4428 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4429 dgit: Have to apply the patches - making the tree dirty.
4430 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4433 $patches_applied_dirtily = 01;
4434 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4435 runcmd qw(dpkg-source --before-build .);
4438 sub maybe_unapply_patches_again () {
4439 progress "dgit: Unapplying patches again to tidy up the tree."
4440 if $patches_applied_dirtily;
4441 runcmd qw(dpkg-source --after-build .)
4442 if $patches_applied_dirtily & 01;
4444 if $patches_applied_dirtily & 02;
4445 $patches_applied_dirtily = 0;
4448 #----- other building -----
4450 our $clean_using_builder;
4451 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4452 # clean the tree before building (perhaps invoked indirectly by
4453 # whatever we are using to run the build), rather than separately
4454 # and explicitly by us.
4457 return if $clean_using_builder;
4458 if ($cleanmode eq 'dpkg-source') {
4459 maybe_apply_patches_dirtily();
4460 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4461 } elsif ($cleanmode eq 'dpkg-source-d') {
4462 maybe_apply_patches_dirtily();
4463 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4464 } elsif ($cleanmode eq 'git') {
4465 runcmd_ordryrun_local @git, qw(clean -xdf);
4466 } elsif ($cleanmode eq 'git-ff') {
4467 runcmd_ordryrun_local @git, qw(clean -xdff);
4468 } elsif ($cleanmode eq 'check') {
4469 my $leftovers = cmdoutput @git, qw(clean -xdn);
4470 if (length $leftovers) {
4471 print STDERR $leftovers, "\n" or die $!;
4472 fail "tree contains uncommitted files and --clean=check specified";
4474 } elsif ($cleanmode eq 'none') {
4481 badusage "clean takes no additional arguments" if @ARGV;
4484 maybe_unapply_patches_again();
4489 badusage "-p is not allowed when building" if defined $package;
4492 my $clogp = parsechangelog();
4493 $isuite = getfield $clogp, 'Distribution';
4494 $package = getfield $clogp, 'Source';
4495 $version = getfield $clogp, 'Version';
4496 build_maybe_quilt_fixup();
4498 my $pat = changespat $version;
4499 foreach my $f (glob "$buildproductsdir/$pat") {
4501 unlink $f or fail "remove old changes file $f: $!";
4503 progress "would remove $f";
4509 sub changesopts_initial () {
4510 my @opts =@changesopts[1..$#changesopts];
4513 sub changesopts_version () {
4514 if (!defined $changes_since_version) {
4515 my @vsns = archive_query('archive_query');
4516 my @quirk = access_quirk();
4517 if ($quirk[0] eq 'backports') {
4518 local $isuite = $quirk[2];
4520 canonicalise_suite();
4521 push @vsns, archive_query('archive_query');
4524 @vsns = map { $_->[0] } @vsns;
4525 @vsns = sort { -version_compare($a, $b) } @vsns;
4526 $changes_since_version = $vsns[0];
4527 progress "changelog will contain changes since $vsns[0]";
4529 $changes_since_version = '_';
4530 progress "package seems new, not specifying -v<version>";
4533 if ($changes_since_version ne '_') {
4534 return ("-v$changes_since_version");
4540 sub changesopts () {
4541 return (changesopts_initial(), changesopts_version());
4544 sub massage_dbp_args ($;$) {
4545 my ($cmd,$xargs) = @_;
4548 # - if we're going to split the source build out so we can
4549 # do strange things to it, massage the arguments to dpkg-buildpackage
4550 # so that the main build doessn't build source (or add an argument
4551 # to stop it building source by default).
4553 # - add -nc to stop dpkg-source cleaning the source tree,
4554 # unless we're not doing a split build and want dpkg-source
4555 # as cleanmode, in which case we can do nothing
4558 # 0 - source will NOT need to be built separately by caller
4559 # +1 - source will need to be built separately by caller
4560 # +2 - source will need to be built separately by caller AND
4561 # dpkg-buildpackage should not in fact be run at all!
4562 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4563 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4564 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4565 $clean_using_builder = 1;
4568 # -nc has the side effect of specifying -b if nothing else specified
4569 # and some combinations of -S, -b, et al, are errors, rather than
4570 # later simply overriding earlie. So we need to:
4571 # - search the command line for these options
4572 # - pick the last one
4573 # - perhaps add our own as a default
4574 # - perhaps adjust it to the corresponding non-source-building version
4576 foreach my $l ($cmd, $xargs) {
4578 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4581 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4583 if ($need_split_build_invocation) {
4584 printdebug "massage split $dmode.\n";
4585 $r = $dmode =~ m/[S]/ ? +2 :
4586 $dmode =~ y/gGF/ABb/ ? +1 :
4587 $dmode =~ m/[ABb]/ ? 0 :
4590 printdebug "massage done $r $dmode.\n";
4592 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4597 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4598 my $wantsrc = massage_dbp_args \@dbp;
4605 push @dbp, changesopts_version();
4606 maybe_apply_patches_dirtily();
4607 runcmd_ordryrun_local @dbp;
4609 maybe_unapply_patches_again();
4610 printdone "build successful\n";
4614 my @dbp = @dpkgbuildpackage;
4616 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4618 if (!length $gbp_build[0]) {
4619 if (length executable_on_path('git-buildpackage')) {
4620 $gbp_build[0] = qw(git-buildpackage);
4622 $gbp_build[0] = 'gbp buildpackage';
4625 my @cmd = opts_opt_multi_cmd @gbp_build;
4627 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4632 if (!$clean_using_builder) {
4633 push @cmd, '--git-cleaner=true';
4637 maybe_unapply_patches_again();
4639 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4640 canonicalise_suite();
4641 push @cmd, "--git-debian-branch=".lbranch();
4643 push @cmd, changesopts();
4644 runcmd_ordryrun_local @cmd, @ARGV;
4646 printdone "build successful\n";
4648 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4651 my $our_cleanmode = $cleanmode;
4652 if ($need_split_build_invocation) {
4653 # Pretend that clean is being done some other way. This
4654 # forces us not to try to use dpkg-buildpackage to clean and
4655 # build source all in one go; and instead we run dpkg-source
4656 # (and build_prep() will do the clean since $clean_using_builder
4658 $our_cleanmode = 'ELSEWHERE';
4660 if ($our_cleanmode =~ m/^dpkg-source/) {
4661 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4662 $clean_using_builder = 1;
4665 $sourcechanges = changespat $version,'source';
4667 unlink "../$sourcechanges" or $!==ENOENT
4668 or fail "remove $sourcechanges: $!";
4670 $dscfn = dscfn($version);
4671 if ($our_cleanmode eq 'dpkg-source') {
4672 maybe_apply_patches_dirtily();
4673 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4675 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4676 maybe_apply_patches_dirtily();
4677 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4680 my @cmd = (@dpkgsource, qw(-b --));
4683 runcmd_ordryrun_local @cmd, "work";
4684 my @udfiles = <${package}_*>;
4685 changedir "../../..";
4686 foreach my $f (@udfiles) {
4687 printdebug "source copy, found $f\n";
4690 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4691 $f eq srcfn($version, $&));
4692 printdebug "source copy, found $f - renaming\n";
4693 rename "$ud/$f", "../$f" or $!==ENOENT
4694 or fail "put in place new source file ($f): $!";
4697 my $pwd = must_getcwd();
4698 my $leafdir = basename $pwd;
4700 runcmd_ordryrun_local @cmd, $leafdir;
4703 runcmd_ordryrun_local qw(sh -ec),
4704 'exec >$1; shift; exec "$@"','x',
4705 "../$sourcechanges",
4706 @dpkggenchanges, qw(-S), changesopts();
4710 sub cmd_build_source {
4711 badusage "build-source takes no additional arguments" if @ARGV;
4713 maybe_unapply_patches_again();
4714 printdone "source built, results in $dscfn and $sourcechanges";
4719 my $pat = changespat $version;
4721 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4722 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4723 fail "changes files other than source matching $pat".
4724 " already present (@unwanted);".
4725 " building would result in ambiguity about the intended results"
4728 my $wasdir = must_getcwd();
4731 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4732 stat_exists $sourcechanges
4733 or fail "$sourcechanges (in parent directory): $!";
4735 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4736 my @changesfiles = glob $pat;
4737 @changesfiles = sort {
4738 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4741 fail "wrong number of different changes files (@changesfiles)"
4742 unless @changesfiles==2;
4743 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4744 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4745 fail "$l found in binaries changes file $binchanges"
4748 runcmd_ordryrun_local @mergechanges, @changesfiles;
4749 my $multichanges = changespat $version,'multi';
4751 stat_exists $multichanges or fail "$multichanges: $!";
4752 foreach my $cf (glob $pat) {
4753 next if $cf eq $multichanges;
4754 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4758 maybe_unapply_patches_again();
4759 printdone "build successful, results in $multichanges\n" or die $!;
4762 sub cmd_quilt_fixup {
4763 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4764 my $clogp = parsechangelog();
4765 $version = getfield $clogp, 'Version';
4766 $package = getfield $clogp, 'Source';
4769 build_maybe_quilt_fixup();
4772 sub cmd_archive_api_query {
4773 badusage "need only 1 subpath argument" unless @ARGV==1;
4774 my ($subpath) = @ARGV;
4775 my @cmd = archive_api_query_cmd($subpath);
4777 exec @cmd or fail "exec curl: $!\n";
4780 sub cmd_clone_dgit_repos_server {
4781 badusage "need destination argument" unless @ARGV==1;
4782 my ($destdir) = @ARGV;
4783 $package = '_dgit-repos-server';
4784 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4786 exec @cmd or fail "exec git clone: $!\n";
4789 sub cmd_setup_mergechangelogs {
4790 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4791 setup_mergechangelogs(1);
4794 sub cmd_setup_useremail {
4795 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4799 sub cmd_setup_new_tree {
4800 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4804 #---------- argument parsing and main program ----------
4807 print "dgit version $our_version\n" or die $!;
4811 our (%valopts_long, %valopts_short);
4814 sub defvalopt ($$$$) {
4815 my ($long,$short,$val_re,$how) = @_;
4816 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4817 $valopts_long{$long} = $oi;
4818 $valopts_short{$short} = $oi;
4819 # $how subref should:
4820 # do whatever assignemnt or thing it likes with $_[0]
4821 # if the option should not be passed on to remote, @rvalopts=()
4822 # or $how can be a scalar ref, meaning simply assign the value
4825 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4826 defvalopt '--distro', '-d', '.+', \$idistro;
4827 defvalopt '', '-k', '.+', \$keyid;
4828 defvalopt '--existing-package','', '.*', \$existing_package;
4829 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4830 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4831 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4833 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4835 defvalopt '', '-C', '.+', sub {
4836 ($changesfile) = (@_);
4837 if ($changesfile =~ s#^(.*)/##) {
4838 $buildproductsdir = $1;
4842 defvalopt '--initiator-tempdir','','.*', sub {
4843 ($initiator_tempdir) = (@_);
4844 $initiator_tempdir =~ m#^/# or
4845 badusage "--initiator-tempdir must be used specify an".
4846 " absolute, not relative, directory."
4852 if (defined $ENV{'DGIT_SSH'}) {
4853 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4854 } elsif (defined $ENV{'GIT_SSH'}) {
4855 @ssh = ($ENV{'GIT_SSH'});
4863 if (!defined $val) {
4864 badusage "$what needs a value" unless @ARGV;
4866 push @rvalopts, $val;
4868 badusage "bad value \`$val' for $what" unless
4869 $val =~ m/^$oi->{Re}$(?!\n)/s;
4870 my $how = $oi->{How};
4871 if (ref($how) eq 'SCALAR') {
4876 push @ropts, @rvalopts;
4880 last unless $ARGV[0] =~ m/^-/;
4884 if (m/^--dry-run$/) {
4887 } elsif (m/^--damp-run$/) {
4890 } elsif (m/^--no-sign$/) {
4893 } elsif (m/^--help$/) {
4895 } elsif (m/^--version$/) {
4897 } elsif (m/^--new$/) {
4900 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4901 ($om = $opts_opt_map{$1}) &&
4905 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4906 !$opts_opt_cmdonly{$1} &&
4907 ($om = $opts_opt_map{$1})) {
4910 } elsif (m/^--ignore-dirty$/s) {
4913 } elsif (m/^--no-quilt-fixup$/s) {
4915 $quilt_mode = 'nocheck';
4916 } elsif (m/^--no-rm-on-error$/s) {
4919 } elsif (m/^--overwrite$/s) {
4921 $overwrite_version = '';
4922 } elsif (m/^--overwrite=(.+)$/s) {
4924 $overwrite_version = $1;
4925 } elsif (m/^--(no-)?rm-old-changes$/s) {
4928 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4930 push @deliberatelies, $&;
4931 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4932 # undocumented, for testing
4934 $tagformat_want = [ $1, 'command line', 1 ];
4935 # 1 menas overrides distro configuration
4936 } elsif (m/^--always-split-source-build$/s) {
4937 # undocumented, for testing
4939 $need_split_build_invocation = 1;
4940 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4941 $val = $2 ? $' : undef; #';
4942 $valopt->($oi->{Long});
4944 badusage "unknown long option \`$_'";
4951 } elsif (s/^-L/-/) {
4954 } elsif (s/^-h/-/) {
4956 } elsif (s/^-D/-/) {
4960 } elsif (s/^-N/-/) {
4965 push @changesopts, $_;
4967 } elsif (s/^-wn$//s) {
4969 $cleanmode = 'none';
4970 } elsif (s/^-wg$//s) {
4973 } elsif (s/^-wgf$//s) {
4975 $cleanmode = 'git-ff';
4976 } elsif (s/^-wd$//s) {
4978 $cleanmode = 'dpkg-source';
4979 } elsif (s/^-wdd$//s) {
4981 $cleanmode = 'dpkg-source-d';
4982 } elsif (s/^-wc$//s) {
4984 $cleanmode = 'check';
4985 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4987 $val = undef unless length $val;
4988 $valopt->($oi->{Short});
4991 badusage "unknown short option \`$_'";
4998 sub finalise_opts_opts () {
4999 foreach my $k (keys %opts_opt_map) {
5000 my $om = $opts_opt_map{$k};
5002 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
5004 badcfg "cannot set command for $k"
5005 unless length $om->[0];
5009 foreach my $c (access_cfg_cfgs("opts-$k")) {
5010 my $vl = $gitcfg{$c};
5011 printdebug "CL $c ",
5012 ($vl ? join " ", map { shellquote } @$vl : ""),
5013 "\n" if $debuglevel >= 4;
5015 badcfg "cannot configure options for $k"
5016 if $opts_opt_cmdonly{$k};
5017 my $insertpos = $opts_cfg_insertpos{$k};
5018 @$om = ( @$om[0..$insertpos-1],
5020 @$om[$insertpos..$#$om] );
5025 if ($ENV{$fakeeditorenv}) {
5027 quilt_fixup_editor();
5033 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
5034 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
5035 if $dryrun_level == 1;
5037 print STDERR $helpmsg or die $!;
5040 my $cmd = shift @ARGV;
5043 if (!defined $rmchanges) {
5044 local $access_forpush;
5045 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
5048 if (!defined $quilt_mode) {
5049 local $access_forpush;
5050 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
5051 // access_cfg('quilt-mode', 'RETURN-UNDEF')
5053 $quilt_mode =~ m/^($quilt_modes_re)$/
5054 or badcfg "unknown quilt-mode \`$quilt_mode'";
5058 $need_split_build_invocation ||= quiltmode_splitbrain();
5060 if (!defined $cleanmode) {
5061 local $access_forpush;
5062 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5063 $cleanmode //= 'dpkg-source';
5065 badcfg "unknown clean-mode \`$cleanmode'" unless
5066 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5069 my $fn = ${*::}{"cmd_$cmd"};
5070 $fn or badusage "unknown operation $cmd";