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';
81 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
82 our $splitbraincache = 'dgit-intern/quilt-cache';
85 our (@dget) = qw(dget);
86 our (@curl) = qw(curl -f);
87 our (@dput) = qw(dput);
88 our (@debsign) = qw(debsign);
90 our (@sbuild) = qw(sbuild);
92 our (@dgit) = qw(dgit);
93 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
94 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
95 our (@dpkggenchanges) = qw(dpkg-genchanges);
96 our (@mergechanges) = qw(mergechanges -f);
98 our (@changesopts) = ('');
100 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
103 'debsign' => \@debsign,
105 'sbuild' => \@sbuild,
109 'dpkg-source' => \@dpkgsource,
110 'dpkg-buildpackage' => \@dpkgbuildpackage,
111 'dpkg-genchanges' => \@dpkggenchanges,
113 'ch' => \@changesopts,
114 'mergechanges' => \@mergechanges);
116 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
117 our %opts_cfg_insertpos = map {
119 scalar @{ $opts_opt_map{$_} }
120 } keys %opts_opt_map;
122 sub finalise_opts_opts();
128 our $supplementary_message = '';
129 our $need_split_build_invocation = 0;
130 our $split_brain = 0;
134 print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
137 our $remotename = 'dgit';
138 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
143 my ($v,$distro) = @_;
144 return $tagformatfn->($v, $distro);
147 sub debiantag_maintview ($$) {
148 my ($v,$distro) = @_;
153 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
155 sub lbranch () { return "$branchprefix/$csuite"; }
156 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
157 sub lref () { return "refs/heads/".lbranch(); }
158 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
159 sub rrref () { return server_ref($csuite); }
161 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
162 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
164 # We fetch some parts of lrfetchrefs/*. Ideally we delete these
165 # locally fetched refs because they have unhelpful names and clutter
166 # up gitk etc. So we track whether we have "used up" head ref (ie,
167 # whether we have made another local ref which refers to this object).
169 # (If we deleted them unconditionally, then we might end up
170 # re-fetching the same git objects each time dgit fetch was run.)
172 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
173 # in git_fetch_us to fetch the refs in question, and possibly a call
174 # to lrfetchref_used.
176 our (%lrfetchrefs_f, %lrfetchrefs_d);
177 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
179 sub lrfetchref_used ($) {
180 my ($fullrefname) = @_;
181 my $objid = $lrfetchrefs_f{$fullrefname};
182 $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
193 return "${package}_".(stripepoch $vsn).$sfx
198 return srcfn($vsn,".dsc");
201 sub changespat ($;$) {
202 my ($vsn, $arch) = @_;
203 return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
212 foreach my $f (@end) {
214 print STDERR "$us: cleanup: $@" if length $@;
218 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
220 sub no_such_package () {
221 print STDERR "$us: package $package does not exist in suite $isuite\n";
227 printdebug "CD $newdir\n";
228 chdir $newdir or confess "chdir: $newdir: $!";
231 sub deliberately ($) {
233 return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
236 sub deliberately_not_fast_forward () {
237 foreach (qw(not-fast-forward fresh-repo)) {
238 return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
242 sub quiltmode_splitbrain () {
243 $quilt_mode =~ m/gbp|dpm|unapplied/;
246 #---------- remote protocol support, common ----------
248 # remote push initiator/responder protocol:
249 # $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
250 # where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
251 # < dgit-remote-push-ready <actual-proto-vsn>
258 # > supplementary-message NBYTES # $protovsn >= 3
263 # > file parsed-changelog
264 # [indicates that output of dpkg-parsechangelog follows]
265 # > data-block NBYTES
266 # > [NBYTES bytes of data (no newline)]
267 # [maybe some more blocks]
276 # > param head DGIT-VIEW-HEAD
277 # > param csuite SUITE
278 # > param tagformat old|new
279 # > param maint-view MAINT-VIEW-HEAD
281 # > previously REFNAME=OBJNAME # if --deliberately-not-fast-forward
282 # # goes into tag, for replay prevention
285 # [indicates that signed tag is wanted]
286 # < data-block NBYTES
287 # < [NBYTES bytes of data (no newline)]
288 # [maybe some more blocks]
292 # > want signed-dsc-changes
293 # < data-block NBYTES [transfer of signed dsc]
295 # < data-block NBYTES [transfer of signed changes]
303 sub i_child_report () {
304 # Sees if our child has died, and reap it if so. Returns a string
305 # describing how it died if it failed, or undef otherwise.
306 return undef unless $i_child_pid;
307 my $got = waitpid $i_child_pid, WNOHANG;
308 return undef if $got <= 0;
309 die unless $got == $i_child_pid;
310 $i_child_pid = undef;
311 return undef unless $?;
312 return "build host child ".waitstatusmsg();
317 fail "connection lost: $!" if $fh->error;
318 fail "protocol violation; $m not expected";
321 sub badproto_badread ($$) {
323 fail "connection lost: $!" if $!;
324 my $report = i_child_report();
325 fail $report if defined $report;
326 badproto $fh, "eof (reading $wh)";
329 sub protocol_expect (&$) {
330 my ($match, $fh) = @_;
333 defined && chomp or badproto_badread $fh, "protocol message";
341 badproto $fh, "\`$_'";
344 sub protocol_send_file ($$) {
345 my ($fh, $ourfn) = @_;
346 open PF, "<", $ourfn or die "$ourfn: $!";
349 my $got = read PF, $d, 65536;
350 die "$ourfn: $!" unless defined $got;
352 print $fh "data-block ".length($d)."\n" or die $!;
353 print $fh $d or die $!;
355 PF->error and die "$ourfn $!";
356 print $fh "data-end\n" or die $!;
360 sub protocol_read_bytes ($$) {
361 my ($fh, $nbytes) = @_;
362 $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
364 my $got = read $fh, $d, $nbytes;
365 $got==$nbytes or badproto_badread $fh, "data block";
369 sub protocol_receive_file ($$) {
370 my ($fh, $ourfn) = @_;
371 printdebug "() $ourfn\n";
372 open PF, ">", $ourfn or die "$ourfn: $!";
374 my ($y,$l) = protocol_expect {
375 m/^data-block (.*)$/ ? (1,$1) :
376 m/^data-end$/ ? (0,) :
380 my $d = protocol_read_bytes $fh, $l;
381 print PF $d or die $!;
386 #---------- remote protocol support, responder ----------
388 sub responder_send_command ($) {
390 return unless $we_are_responder;
391 # called even without $we_are_responder
392 printdebug ">> $command\n";
393 print PO $command, "\n" or die $!;
396 sub responder_send_file ($$) {
397 my ($keyword, $ourfn) = @_;
398 return unless $we_are_responder;
399 printdebug "]] $keyword $ourfn\n";
400 responder_send_command "file $keyword";
401 protocol_send_file \*PO, $ourfn;
404 sub responder_receive_files ($@) {
405 my ($keyword, @ourfns) = @_;
406 die unless $we_are_responder;
407 printdebug "[[ $keyword @ourfns\n";
408 responder_send_command "want $keyword";
409 foreach my $fn (@ourfns) {
410 protocol_receive_file \*PI, $fn;
413 protocol_expect { m/^files-end$/ } \*PI;
416 #---------- remote protocol support, initiator ----------
418 sub initiator_expect (&) {
420 protocol_expect { &$match } \*RO;
423 #---------- end remote code ----------
426 if ($we_are_responder) {
428 responder_send_command "progress ".length($m) or die $!;
429 print PO $m or die $!;
439 $ua = LWP::UserAgent->new();
443 progress "downloading $what...";
444 my $r = $ua->get(@_) or die $!;
445 return undef if $r->code == 404;
446 $r->is_success or fail "failed to fetch $what: ".$r->status_line;
447 return $r->decoded_content(charset => 'none');
450 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
455 failedcmd @_ if system @_;
458 sub act_local () { return $dryrun_level <= 1; }
459 sub act_scary () { return !$dryrun_level; }
462 if (!$dryrun_level) {
463 progress "dgit ok: @_";
465 progress "would be ok: @_ (but dry run only)";
470 printcmd(\*STDERR,$debugprefix."#",@_);
473 sub runcmd_ordryrun {
481 sub runcmd_ordryrun_local {
490 my ($first_shell, @cmd) = @_;
491 return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
494 our $helpmsg = <<END;
496 dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
497 dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
498 dgit [dgit-opts] build [dpkg-buildpackage-opts]
499 dgit [dgit-opts] sbuild [sbuild-opts]
500 dgit [dgit-opts] push [dgit-opts] [suite]
501 dgit [dgit-opts] rpush build-host:build-dir ...
502 important dgit options:
503 -k<keyid> sign tag and package with <keyid> instead of default
504 --dry-run -n do not change anything, but go through the motions
505 --damp-run -L like --dry-run but make local changes, without signing
506 --new -N allow introducing a new package
507 --debug -D increase debug level
508 -c<name>=<value> set git config option (used directly by dgit too)
511 our $later_warning_msg = <<END;
512 Perhaps the upload is stuck in incoming. Using the version from git.
516 print STDERR "$us: @_\n", $helpmsg or die $!;
521 @ARGV or badusage "too few arguments";
522 return scalar shift @ARGV;
526 print $helpmsg or die $!;
530 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
532 our %defcfg = ('dgit.default.distro' => 'debian',
533 'dgit.default.username' => '',
534 'dgit.default.archive-query-default-component' => 'main',
535 'dgit.default.ssh' => 'ssh',
536 'dgit.default.archive-query' => 'madison:',
537 'dgit.default.sshpsql-dbname' => 'service=projectb',
538 'dgit.default.dgit-tag-format' => 'old,new,maint',
539 # old means "repo server accepts pushes with old dgit tags"
540 # new means "repo server accepts pushes with new dgit tags"
541 # maint means "repo server accepts split brain pushes"
542 # hist means "repo server may have old pushes without new tag"
543 # ("hist" is implied by "old")
544 'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
545 'dgit-distro.debian.git-check' => 'url',
546 'dgit-distro.debian.git-check-suffix' => '/info/refs',
547 'dgit-distro.debian.new-private-pushers' => 't',
548 'dgit-distro.debian.dgit-tag-format' => 'new',
549 'dgit-distro.debian/push.git-url' => '',
550 'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
551 'dgit-distro.debian/push.git-user-force' => 'dgit',
552 'dgit-distro.debian/push.git-proto' => 'git+ssh://',
553 'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
554 'dgit-distro.debian/push.git-create' => 'true',
555 'dgit-distro.debian/push.git-check' => 'ssh-cmd',
556 'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
557 # 'dgit-distro.debian.archive-query-tls-key',
558 # '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
559 # ^ this does not work because curl is broken nowadays
560 # Fixing #790093 properly will involve providing providing the key
561 # in some pacagke and maybe updating these paths.
563 # 'dgit-distro.debian.archive-query-tls-curl-args',
564 # '--ca-path=/etc/ssl/ca-debian',
565 # ^ this is a workaround but works (only) on DSA-administered machines
566 'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
567 'dgit-distro.debian.git-url-suffix' => '',
568 'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
569 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
570 'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
571 'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
572 'dgit-distro.ubuntu.git-check' => 'false',
573 'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
574 'dgit-distro.test-dummy.ssh' => "$td/ssh",
575 'dgit-distro.test-dummy.username' => "alice",
576 'dgit-distro.test-dummy.git-check' => "ssh-cmd",
577 'dgit-distro.test-dummy.git-create' => "ssh-cmd",
578 'dgit-distro.test-dummy.git-url' => "$td/git",
579 'dgit-distro.test-dummy.git-host' => "git",
580 'dgit-distro.test-dummy.git-path' => "$td/git",
581 'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
582 'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
583 'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
584 'dgit-distro.test-dummy.upload-host' => 'test-dummy',
589 sub git_slurp_config () {
590 local ($debuglevel) = $debuglevel-2;
593 my @cmd = (@git, qw(config -z --get-regexp .*));
596 open GITS, "-|", @cmd or die $!;
599 printdebug "=> ", (messagequote $_), "\n";
601 push @{ $gitcfg{$`} }, $'; #';
605 or ($!==0 && $?==256)
609 sub git_get_config ($) {
612 printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
615 @$l==1 or badcfg "multiple values for $c" if @$l > 1;
621 return undef if $c =~ /RETURN-UNDEF/;
622 my $v = git_get_config($c);
623 return $v if defined $v;
624 my $dv = $defcfg{$c};
625 return $dv if defined $dv;
627 badcfg "need value for one of: @_\n".
628 "$us: distro or suite appears not to be (properly) supported";
631 sub access_basedistro () {
632 if (defined $idistro) {
635 return cfg("dgit-suite.$isuite.distro",
636 "dgit.default.distro");
640 sub access_quirk () {
641 # returns (quirk name, distro to use instead or undef, quirk-specific info)
642 my $basedistro = access_basedistro();
643 my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
645 if (defined $backports_quirk) {
646 my $re = $backports_quirk;
647 $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
649 $re =~ s/\%/([-0-9a-z_]+)/
650 or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
651 if ($isuite =~ m/^$re$/) {
652 return ('backports',"$basedistro-backports",$1);
655 return ('none',undef);
660 sub parse_cfg_bool ($$$) {
661 my ($what,$def,$v) = @_;
664 $v =~ m/^[ty1]/ ? 1 :
665 $v =~ m/^[fn0]/ ? 0 :
666 badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
669 sub access_forpush_config () {
670 my $d = access_basedistro();
674 parse_cfg_bool('new-private-pushers', 0,
675 cfg("dgit-distro.$d.new-private-pushers",
678 my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
681 $v =~ m/^[ty1]/ ? 0 : # force readonly, forpush = 0
682 $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
683 $v =~ m/^[a]/ ? '' : # auto, forpush = ''
684 badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
687 sub access_forpush () {
688 $access_forpush //= access_forpush_config();
689 return $access_forpush;
693 die "$access_forpush ?" if ($access_forpush // 1) ne 1;
694 badcfg "pushing but distro is configured readonly"
695 if access_forpush_config() eq '0';
697 $supplementary_message = <<'END' unless $we_are_responder;
698 Push failed, before we got started.
699 You can retry the push, after fixing the problem, if you like.
701 finalise_opts_opts();
705 finalise_opts_opts();
708 sub supplementary_message ($) {
710 if (!$we_are_responder) {
711 $supplementary_message = $msg;
713 } elsif ($protovsn >= 3) {
714 responder_send_command "supplementary-message ".length($msg)
716 print PO $msg or die $!;
720 sub access_distros () {
721 # Returns list of distros to try, in order
724 # 0. `instead of' distro name(s) we have been pointed to
725 # 1. the access_quirk distro, if any
726 # 2a. the user's specified distro, or failing that } basedistro
727 # 2b. the distro calculated from the suite }
728 my @l = access_basedistro();
730 my (undef,$quirkdistro) = access_quirk();
731 unshift @l, $quirkdistro;
732 unshift @l, $instead_distro;
733 @l = grep { defined } @l;
735 if (access_forpush()) {
736 @l = map { ("$_/push", $_) } @l;
741 sub access_cfg_cfgs (@) {
744 # The nesting of these loops determines the search order. We put
745 # the key loop on the outside so that we search all the distros
746 # for each key, before going on to the next key. That means that
747 # if access_cfg is called with a more specific, and then a less
748 # specific, key, an earlier distro can override the less specific
749 # without necessarily overriding any more specific keys. (If the
750 # distro wants to override the more specific keys it can simply do
751 # so; whereas if we did the loop the other way around, it would be
752 # impossible to for an earlier distro to override a less specific
753 # key but not the more specific ones without restating the unknown
754 # values of the more specific keys.
757 # We have to deal with RETURN-UNDEF specially, so that we don't
758 # terminate the search prematurely.
760 if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
763 foreach my $d (access_distros()) {
764 push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
766 push @cfgs, map { "dgit.default.$_" } @realkeys;
773 my (@cfgs) = access_cfg_cfgs(@keys);
774 my $value = cfg(@cfgs);
778 sub access_cfg_bool ($$) {
779 my ($def, @keys) = @_;
780 parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
783 sub string_to_ssh ($) {
785 if ($spec =~ m/\s/) {
786 return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
792 sub access_cfg_ssh () {
793 my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
794 if (!defined $gitssh) {
797 return string_to_ssh $gitssh;
801 sub access_runeinfo ($) {
803 return ": dgit ".access_basedistro()." $info ;";
806 sub access_someuserhost ($) {
808 my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
809 defined($user) && length($user) or
810 $user = access_cfg("$some-user",'username');
811 my $host = access_cfg("$some-host");
812 return length($user) ? "$user\@$host" : $host;
815 sub access_gituserhost () {
816 return access_someuserhost('git');
819 sub access_giturl (;$) {
821 my $url = access_cfg('git-url','RETURN-UNDEF');
824 my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
825 return undef unless defined $proto;
828 access_gituserhost().
829 access_cfg('git-path');
831 $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
834 return "$url/$package$suffix";
837 sub parsecontrolfh ($$;$) {
838 my ($fh, $desc, $allowsigned) = @_;
839 our $dpkgcontrolhash_noissigned;
842 my %opts = ('name' => $desc);
843 $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
844 $c = Dpkg::Control::Hash->new(%opts);
845 $c->parse($fh,$desc) or die "parsing of $desc failed";
846 last if $allowsigned;
847 last if $dpkgcontrolhash_noissigned;
848 my $issigned= $c->get_option('is_pgp_signed');
849 if (!defined $issigned) {
850 $dpkgcontrolhash_noissigned= 1;
851 seek $fh, 0,0 or die "seek $desc: $!";
852 } elsif ($issigned) {
853 fail "control file $desc is (already) PGP-signed. ".
854 " Note that dgit push needs to modify the .dsc and then".
855 " do the signature itself";
864 my ($file, $desc) = @_;
865 my $fh = new IO::Handle;
866 open $fh, '<', $file or die "$file: $!";
867 my $c = parsecontrolfh($fh,$desc);
868 $fh->error and die $!;
874 my ($dctrl,$field) = @_;
875 my $v = $dctrl->{$field};
876 return $v if defined $v;
877 fail "missing field $field in ".$dctrl->get_option('name');
881 my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
882 my $p = new IO::Handle;
883 my @cmd = (qw(dpkg-parsechangelog), @_);
884 open $p, '-|', @cmd or die $!;
886 $?=0; $!=0; close $p or failedcmd @cmd;
890 sub commit_getclogp ($) {
891 # Returns the parsed changelog hashref for a particular commit
893 our %commit_getclogp_memo;
894 my $memo = $commit_getclogp_memo{$objid};
895 return $memo if $memo;
897 my $mclog = ".git/dgit/clog-$objid";
898 runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
899 "$objid:debian/changelog";
900 $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
905 defined $d or fail "getcwd failed: $!";
911 sub archive_query ($) {
913 my $query = access_cfg('archive-query','RETURN-UNDEF');
914 $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
917 { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
920 sub pool_dsc_subpath ($$) {
921 my ($vsn,$component) = @_; # $package is implict arg
922 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
923 return "/pool/$component/$prefix/$package/".dscfn($vsn);
926 #---------- `ftpmasterapi' archive query method (nascent) ----------
928 sub archive_api_query_cmd ($) {
930 my @cmd = qw(curl -sS);
931 my $url = access_cfg('archive-query-url');
932 if ($url =~ m#^https://([-.0-9a-z]+)/#) {
934 my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
935 foreach my $key (split /\:/, $keys) {
936 $key =~ s/\%HOST\%/$host/g;
938 fail "for $url: stat $key: $!" unless $!==ENOENT;
941 fail "config requested specific TLS key but do not know".
942 " how to get curl to use exactly that EE key ($key)";
943 # push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
944 # # Sadly the above line does not work because of changes
945 # # to gnutls. The real fix for #790093 may involve
946 # # new curl options.
949 # Fixing #790093 properly will involve providing a value
950 # for this on clients.
951 my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
952 push @cmd, split / /, $kargs if defined $kargs;
954 push @cmd, $url.$subpath;
960 my ($data, $subpath) = @_;
961 badcfg "ftpmasterapi archive query method takes no data part"
963 my @cmd = archive_api_query_cmd($subpath);
964 my $json = cmdoutput @cmd;
965 return decode_json($json);
968 sub canonicalise_suite_ftpmasterapi () {
969 my ($proto,$data) = @_;
970 my $suites = api_query($data, 'suites');
972 foreach my $entry (@$suites) {
974 my $v = $entry->{$_};
975 defined $v && $v eq $isuite;
977 push @matched, $entry;
979 fail "unknown suite $isuite" unless @matched;
982 @matched==1 or die "multiple matches for suite $isuite\n";
983 $cn = "$matched[0]{codename}";
984 defined $cn or die "suite $isuite info has no codename\n";
985 $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
987 die "bad ftpmaster api response: $@\n".Dumper(\@matched)
992 sub archive_query_ftpmasterapi () {
993 my ($proto,$data) = @_;
994 my $info = api_query($data, "dsc_in_suite/$isuite/$package");
996 my $digester = Digest::SHA->new(256);
997 foreach my $entry (@$info) {
999 my $vsn = "$entry->{version}";
1000 my ($ok,$msg) = version_check $vsn;
1001 die "bad version: $msg\n" unless $ok;
1002 my $component = "$entry->{component}";
1003 $component =~ m/^$component_re$/ or die "bad component";
1004 my $filename = "$entry->{filename}";
1005 $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1006 or die "bad filename";
1007 my $sha256sum = "$entry->{sha256sum}";
1008 $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1009 push @rows, [ $vsn, "/pool/$component/$filename",
1010 $digester, $sha256sum ];
1012 die "bad ftpmaster api response: $@\n".Dumper($entry)
1015 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1019 #---------- `madison' archive query method ----------
1021 sub archive_query_madison {
1022 return map { [ @$_[0..1] ] } madison_get_parse(@_);
1025 sub madison_get_parse {
1026 my ($proto,$data) = @_;
1027 die unless $proto eq 'madison';
1028 if (!length $data) {
1029 $data= access_cfg('madison-distro','RETURN-UNDEF');
1030 $data //= access_basedistro();
1032 $rmad{$proto,$data,$package} ||= cmdoutput
1033 qw(rmadison -asource),"-s$isuite","-u$data",$package;
1034 my $rmad = $rmad{$proto,$data,$package};
1037 foreach my $l (split /\n/, $rmad) {
1038 $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1039 \s*( [^ \t|]+ )\s* \|
1040 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1041 \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1042 $1 eq $package or die "$rmad $package ?";
1049 $component = access_cfg('archive-query-default-component');
1051 $5 eq 'source' or die "$rmad ?";
1052 push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1054 return sort { -version_compare($a->[0],$b->[0]); } @out;
1057 sub canonicalise_suite_madison {
1058 # madison canonicalises for us
1059 my @r = madison_get_parse(@_);
1061 "unable to canonicalise suite using package $package".
1062 " which does not appear to exist in suite $isuite;".
1063 " --existing-package may help";
1067 #---------- `sshpsql' archive query method ----------
1070 my ($data,$runeinfo,$sql) = @_;
1071 if (!length $data) {
1072 $data= access_someuserhost('sshpsql').':'.
1073 access_cfg('sshpsql-dbname');
1075 $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1076 my ($userhost,$dbname) = ($`,$'); #';
1078 my @cmd = (access_cfg_ssh, $userhost,
1079 access_runeinfo("ssh-psql $runeinfo").
1080 " export LC_MESSAGES=C; export LC_CTYPE=C;".
1081 " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1083 open P, "-|", @cmd or die $!;
1086 printdebug(">|$_|\n");
1089 $!=0; $?=0; close P or failedcmd @cmd;
1091 my $nrows = pop @rows;
1092 $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1093 @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1094 @rows = map { [ split /\|/, $_ ] } @rows;
1095 my $ncols = scalar @{ shift @rows };
1096 die if grep { scalar @$_ != $ncols } @rows;
1100 sub sql_injection_check {
1101 foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1104 sub archive_query_sshpsql ($$) {
1105 my ($proto,$data) = @_;
1106 sql_injection_check $isuite, $package;
1107 my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1108 SELECT source.version, component.name, files.filename, files.sha256sum
1110 JOIN src_associations ON source.id = src_associations.source
1111 JOIN suite ON suite.id = src_associations.suite
1112 JOIN dsc_files ON dsc_files.source = source.id
1113 JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1114 JOIN component ON component.id = files_archive_map.component_id
1115 JOIN files ON files.id = dsc_files.file
1116 WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1117 AND source.source='$package'
1118 AND files.filename LIKE '%.dsc';
1120 @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1121 my $digester = Digest::SHA->new(256);
1123 my ($vsn,$component,$filename,$sha256sum) = @$_;
1124 [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1129 sub canonicalise_suite_sshpsql ($$) {
1130 my ($proto,$data) = @_;
1131 sql_injection_check $isuite;
1132 my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1133 SELECT suite.codename
1134 FROM suite where suite_name='$isuite' or codename='$isuite';
1136 @rows = map { $_->[0] } @rows;
1137 fail "unknown suite $isuite" unless @rows;
1138 die "ambiguous $isuite: @rows ?" if @rows>1;
1142 #---------- `dummycat' archive query method ----------
1144 sub canonicalise_suite_dummycat ($$) {
1145 my ($proto,$data) = @_;
1146 my $dpath = "$data/suite.$isuite";
1147 if (!open C, "<", $dpath) {
1148 $!==ENOENT or die "$dpath: $!";
1149 printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1153 chomp or die "$dpath: $!";
1155 printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1159 sub archive_query_dummycat ($$) {
1160 my ($proto,$data) = @_;
1161 canonicalise_suite();
1162 my $dpath = "$data/package.$csuite.$package";
1163 if (!open C, "<", $dpath) {
1164 $!==ENOENT or die "$dpath: $!";
1165 printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1173 printdebug "dummycat query $csuite $package $dpath | $_\n";
1174 my @row = split /\s+/, $_;
1175 @row==2 or die "$dpath: $_ ?";
1178 C->error and die "$dpath: $!";
1180 return sort { -version_compare($a->[0],$b->[0]); } @rows;
1183 #---------- tag format handling ----------
1185 sub access_cfg_tagformats () {
1186 split /\,/, access_cfg('dgit-tag-format');
1189 sub need_tagformat ($$) {
1190 my ($fmt, $why) = @_;
1191 fail "need to use tag format $fmt ($why) but also need".
1192 " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1193 " - no way to proceed"
1194 if $tagformat_want && $tagformat_want->[0] ne $fmt;
1195 $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1198 sub select_tagformat () {
1200 return if $tagformatfn && !$tagformat_want;
1201 die 'bug' if $tagformatfn && $tagformat_want;
1202 # ... $tagformat_want assigned after previous select_tagformat
1204 my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1205 printdebug "select_tagformat supported @supported\n";
1207 $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1208 printdebug "select_tagformat specified @$tagformat_want\n";
1210 my ($fmt,$why,$override) = @$tagformat_want;
1212 fail "target distro supports tag formats @supported".
1213 " but have to use $fmt ($why)"
1215 or grep { $_ eq $fmt } @supported;
1217 $tagformat_want = undef;
1219 $tagformatfn = ${*::}{"debiantag_$fmt"};
1221 fail "trying to use unknown tag format \`$fmt' ($why) !"
1222 unless $tagformatfn;
1225 #---------- archive query entrypoints and rest of program ----------
1227 sub canonicalise_suite () {
1228 return if defined $csuite;
1229 fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1230 $csuite = archive_query('canonicalise_suite');
1231 if ($isuite ne $csuite) {
1232 progress "canonical suite name for $isuite is $csuite";
1236 sub get_archive_dsc () {
1237 canonicalise_suite();
1238 my @vsns = archive_query('archive_query');
1239 foreach my $vinfo (@vsns) {
1240 my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1241 $dscurl = access_cfg('mirror').$subpath;
1242 $dscdata = url_get($dscurl);
1244 $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1249 $digester->add($dscdata);
1250 my $got = $digester->hexdigest();
1252 fail "$dscurl has hash $got but".
1253 " archive told us to expect $digest";
1255 my $dscfh = new IO::File \$dscdata, '<' or die $!;
1256 printdebug Dumper($dscdata) if $debuglevel>1;
1257 $dsc = parsecontrolfh($dscfh,$dscurl,1);
1258 printdebug Dumper($dsc) if $debuglevel>1;
1259 my $fmt = getfield $dsc, 'Format';
1260 fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1261 $dsc_checked = !!$digester;
1262 printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1266 printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1269 sub check_for_git ();
1270 sub check_for_git () {
1272 my $how = access_cfg('git-check');
1273 if ($how eq 'ssh-cmd') {
1275 (access_cfg_ssh, access_gituserhost(),
1276 access_runeinfo("git-check $package").
1277 " set -e; cd ".access_cfg('git-path').";".
1278 " if test -d $package.git; then echo 1; else echo 0; fi");
1279 my $r= cmdoutput @cmd;
1280 if (defined $r and $r =~ m/^divert (\w+)$/) {
1282 my ($usedistro,) = access_distros();
1283 # NB that if we are pushing, $usedistro will be $distro/push
1284 $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1285 $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1286 progress "diverting to $divert (using config for $instead_distro)";
1287 return check_for_git();
1289 failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1291 } elsif ($how eq 'url') {
1292 my $prefix = access_cfg('git-check-url','git-url');
1293 my $suffix = access_cfg('git-check-suffix','git-suffix',
1294 'RETURN-UNDEF') // '.git';
1295 my $url = "$prefix/$package$suffix";
1296 my @cmd = (qw(curl -sS -I), $url);
1297 my $result = cmdoutput @cmd;
1298 $result =~ s/^\S+ 200 .*\n\r?\n//;
1299 # curl -sS -I with https_proxy prints
1300 # HTTP/1.0 200 Connection established
1301 $result =~ m/^\S+ (404|200) /s or
1302 fail "unexpected results from git check query - ".
1303 Dumper($prefix, $result);
1305 if ($code eq '404') {
1307 } elsif ($code eq '200') {
1312 } elsif ($how eq 'true') {
1314 } elsif ($how eq 'false') {
1317 badcfg "unknown git-check \`$how'";
1321 sub create_remote_git_repo () {
1322 my $how = access_cfg('git-create');
1323 if ($how eq 'ssh-cmd') {
1325 (access_cfg_ssh, access_gituserhost(),
1326 access_runeinfo("git-create $package").
1327 "set -e; cd ".access_cfg('git-path').";".
1328 " cp -a _template $package.git");
1329 } elsif ($how eq 'true') {
1332 badcfg "unknown git-create \`$how'";
1336 our ($dsc_hash,$lastpush_mergeinput);
1338 our $ud = '.git/dgit/unpack';
1348 sub mktree_in_ud_here () {
1349 runcmd qw(git init -q);
1350 runcmd qw(git config gc.auto 0);
1351 rmtree('.git/objects');
1352 symlink '../../../../objects','.git/objects' or die $!;
1355 sub git_write_tree () {
1356 my $tree = cmdoutput @git, qw(write-tree);
1357 $tree =~ m/^\w+$/ or die "$tree ?";
1361 sub remove_stray_gits () {
1362 my @gitscmd = qw(find -name .git -prune -print0);
1363 debugcmd "|",@gitscmd;
1364 open GITS, "-|", @gitscmd or die $!;
1369 print STDERR "$us: warning: removing from source package: ",
1370 (messagequote $_), "\n";
1374 $!=0; $?=0; close GITS or failedcmd @gitscmd;
1377 sub mktree_in_ud_from_only_subdir (;$) {
1380 # changes into the subdir
1382 die "expected one subdir but found @dirs ?" unless @dirs==1;
1383 $dirs[0] =~ m#^([^/]+)/\.$# or die;
1387 remove_stray_gits();
1388 mktree_in_ud_here();
1390 my ($format, $fopts) = get_source_format();
1391 if (madformat($format)) {
1396 runcmd @git, qw(add -Af);
1397 my $tree=git_write_tree();
1398 return ($tree,$dir);
1401 sub dsc_files_info () {
1402 foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1403 ['Checksums-Sha1', 'Digest::SHA', 'new(1)'],
1404 ['Files', 'Digest::MD5', 'new()']) {
1405 my ($fname, $module, $method) = @$csumi;
1406 my $field = $dsc->{$fname};
1407 next unless defined $field;
1408 eval "use $module; 1;" or die $@;
1410 foreach (split /\n/, $field) {
1412 m/^(\w+) (\d+) (\S+)$/ or
1413 fail "could not parse .dsc $fname line \`$_'";
1414 my $digester = eval "$module"."->$method;" or die $@;
1419 Digester => $digester,
1424 fail "missing any supported Checksums-* or Files field in ".
1425 $dsc->get_option('name');
1429 map { $_->{Filename} } dsc_files_info();
1432 sub is_orig_file_in_dsc ($$) {
1433 my ($f, $dsc_files_info) = @_;
1434 return 0 if @$dsc_files_info <= 1;
1435 # One file means no origs, and the filename doesn't have a "what
1436 # part of dsc" component. (Consider versions ending `.orig'.)
1437 return 0 unless $f =~ m/\.orig(?:-\w+)?\.tar(?:\.\w+)?$/;
1441 sub is_orig_file_of_vsn ($$) {
1442 my ($f, $upstreamvsn) = @_;
1443 my $base = srcfn $upstreamvsn, '';
1444 return 0 unless $f =~ m/^\Q$base\E\.orig(?:-\w+)?\.tar(?:\.\w+)?$/;
1448 sub make_commit ($) {
1450 return cmdoutput @git, qw(hash-object -w -t commit), $file;
1453 sub make_commit_text ($) {
1456 my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1458 print Dumper($text) if $debuglevel > 1;
1459 my $child = open2($out, $in, @cmd) or die $!;
1462 print $in $text or die $!;
1463 close $in or die $!;
1465 $h =~ m/^\w+$/ or die;
1467 printdebug "=> $h\n";
1470 waitpid $child, 0 == $child or die "$child $!";
1471 $? and failedcmd @cmd;
1475 sub clogp_authline ($) {
1477 my $author = getfield $clogp, 'Maintainer';
1478 $author =~ s#,.*##ms;
1479 my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1480 my $authline = "$author $date";
1481 $authline =~ m/$git_authline_re/o or
1482 fail "unexpected commit author line format \`$authline'".
1483 " (was generated from changelog Maintainer field)";
1484 return ($1,$2,$3) if wantarray;
1488 sub vendor_patches_distro ($$) {
1489 my ($checkdistro, $what) = @_;
1490 return unless defined $checkdistro;
1492 my $series = "debian/patches/\L$checkdistro\E.series";
1493 printdebug "checking for vendor-specific $series ($what)\n";
1495 if (!open SERIES, "<", $series) {
1496 die "$series $!" unless $!==ENOENT;
1505 Unfortunately, this source package uses a feature of dpkg-source where
1506 the same source package unpacks to different source code on different
1507 distros. dgit cannot safely operate on such packages on affected
1508 distros, because the meaning of source packages is not stable.
1510 Please ask the distro/maintainer to remove the distro-specific series
1511 files and use a different technique (if necessary, uploading actually
1512 different packages, if different distros are supposed to have
1516 fail "Found active distro-specific series file for".
1517 " $checkdistro ($what): $series, cannot continue";
1519 die "$series $!" if SERIES->error;
1523 sub check_for_vendor_patches () {
1524 # This dpkg-source feature doesn't seem to be documented anywhere!
1525 # But it can be found in the changelog (reformatted):
1527 # commit 4fa01b70df1dc4458daee306cfa1f987b69da58c
1528 # Author: Raphael Hertzog <hertzog@debian.org>
1529 # Date: Sun Oct 3 09:36:48 2010 +0200
1531 # dpkg-source: correctly create .pc/.quilt_series with alternate
1534 # If you have debian/patches/ubuntu.series and you were
1535 # unpacking the source package on ubuntu, quilt was still
1536 # directed to debian/patches/series instead of
1537 # debian/patches/ubuntu.series.
1539 # debian/changelog | 3 +++
1540 # scripts/Dpkg/Source/Package/V3/quilt.pm | 4 +++-
1541 # 2 files changed, 6 insertions(+), 1 deletion(-)
1544 vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1545 vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1546 "Dpkg::Vendor \`current vendor'");
1547 vendor_patches_distro(access_basedistro(),
1548 "distro being accessed");
1551 sub generate_commits_from_dsc () {
1552 # See big comment in fetch_from_archive, below.
1556 my @dfi = dsc_files_info();
1557 foreach my $fi (@dfi) {
1558 my $f = $fi->{Filename};
1559 die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1561 link_ltarget "../../../$f", $f
1565 complete_file_from_dsc('.', $fi)
1568 if (is_orig_file_in_dsc($f, \@dfi)) {
1569 link $f, "../../../../$f"
1575 # We unpack and record the orig tarballs first, so that we only
1576 # need disk space for one private copy of the unpacked source.
1577 # But we can't make them into commits until we have the metadata
1578 # from the debian/changelog, so we record the tree objects now and
1579 # make them into commits later.
1581 my $upstreamv = $dsc->{version};
1582 $upstreamv =~ s/-[^-]+$//;
1583 my $orig_f_base = srcfn $upstreamv, '';
1585 foreach my $fi (@dfi) {
1586 # We actually import, and record as a commit, every tarball
1587 # (unless there is only one file, in which case there seems
1590 my $f = $fi->{Filename};
1591 printdebug "import considering $f ";
1592 (printdebug "only one dfi\n"), next if @dfi == 1;
1593 (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1597 $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1599 printdebug "Y ", (join ' ', map { $_//"(none)" }
1600 $compr_ext, $orig_f_part
1603 my $input = new IO::File $f, '<' or die "$f $!";
1607 if (defined $compr_ext) {
1609 Dpkg::Compression::compression_guess_from_filename $f;
1610 fail "Dpkg::Compression cannot handle file $f in source package"
1611 if defined $compr_ext && !defined $cname;
1613 new Dpkg::Compression::Process compression => $cname;
1614 my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1615 my $compr_fh = new IO::Handle;
1616 my $compr_pid = open $compr_fh, "-|" // die $!;
1618 open STDIN, "<&", $input or die $!;
1620 die "dgit (child): exec $compr_cmd[0]: $!\n";
1625 rmtree "../unpack-tar";
1626 mkdir "../unpack-tar" or die $!;
1627 my @tarcmd = qw(tar -x -f -
1628 --no-same-owner --no-same-permissions
1629 --no-acls --no-xattrs --no-selinux);
1630 my $tar_pid = fork // die $!;
1632 chdir "../unpack-tar" or die $!;
1633 open STDIN, "<&", $input or die $!;
1635 die "dgit (child): exec $tarcmd[0]: $!";
1637 $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1638 !$? or failedcmd @tarcmd;
1641 (@compr_cmd ? failedcmd @compr_cmd
1643 # finally, we have the results in "tarball", but maybe
1644 # with the wrong permissions
1646 runcmd qw(chmod -R +rwX ../unpack-tar);
1647 changedir "../unpack-tar";
1648 my ($tree) = mktree_in_ud_from_only_subdir(1);
1649 changedir "../../unpack";
1650 rmtree "../unpack-tar";
1652 my $ent = [ $f, $tree ];
1654 Orig => !!$orig_f_part,
1655 Sort => (!$orig_f_part ? 2 :
1656 $orig_f_part =~ m/-/g ? 1 :
1664 # put any without "_" first (spec is not clear whether files
1665 # are always in the usual order). Tarballs without "_" are
1666 # the main orig or the debian tarball.
1667 $a->{Sort} <=> $b->{Sort} or
1671 my $any_orig = grep { $_->{Orig} } @tartrees;
1673 my $dscfn = "$package.dsc";
1675 my $treeimporthow = 'package';
1677 open D, ">", $dscfn or die "$dscfn: $!";
1678 print D $dscdata or die "$dscfn: $!";
1679 close D or die "$dscfn: $!";
1680 my @cmd = qw(dpkg-source);
1681 push @cmd, '--no-check' if $dsc_checked;
1682 if (madformat $dsc->{format}) {
1683 push @cmd, '--skip-patches';
1684 $treeimporthow = 'unpatched';
1686 push @cmd, qw(-x --), $dscfn;
1689 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1690 if (madformat $dsc->{format}) {
1691 check_for_vendor_patches();
1695 if (madformat $dsc->{format}) {
1696 my @pcmd = qw(dpkg-source --before-build .);
1697 runcmd shell_cmd 'exec >/dev/null', @pcmd;
1699 runcmd @git, qw(add -Af);
1700 $dappliedtree = git_write_tree();
1703 my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1704 debugcmd "|",@clogcmd;
1705 open CLOGS, "-|", @clogcmd or die $!;
1711 my $stanzatext = do { local $/=""; <CLOGS>; };
1712 last if !defined $stanzatext;
1714 my $desc = "package changelog, entry no.$.";
1715 open my $stanzafh, "<", \$stanzatext or die;
1716 my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1717 $clogp //= $thisstanza;
1719 last if !$any_orig; # we don't need $r1clogp
1721 # We look for the first (most recent) changelog entry whose
1722 # version number is lower than the upstream version of this
1723 # package. Then the last (least recent) previous changelog
1724 # entry is treated as the one which introduced this upstream
1725 # version and used for the synthetic commits for the upstream
1728 # One might think that a more sophisticated algorithm would be
1729 # necessary. But: we do not want to scan the whole changelog
1730 # file. Stopping when we see an earlier version, which
1731 # necessarily then is an earlier upstream version, is the only
1732 # realistic way to do that. Then, either the earliest
1733 # changelog entry we have seen so far is indeed the earliest
1734 # upload of this upstream version; or there are only changelog
1735 # entries relating to later upstream versions (which is not
1736 # possible unless the changelog and .dsc disagree about the
1737 # version). Then it remains to choose between the physically
1738 # last entry in the file, and the one with the lowest version
1739 # number. If these are not the same, we guess that the
1740 # versions were created in a non-monotic order rather than
1741 # that the changelog entries have been misordered.
1743 last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1744 $r1clogp = $thisstanza;
1746 die $! if CLOGS->error;
1747 close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
1749 $clogp or fail "package changelog has no entries!";
1751 my $authline = clogp_authline $clogp;
1752 my $changes = getfield $clogp, 'Changes';
1753 my $cversion = getfield $clogp, 'Version';
1756 $r1clogp //= $clogp; # maybe there's only one entry;
1757 my $r1authline = clogp_authline $r1clogp;
1758 # Strictly, r1authline might now be wrong if it's going to be
1759 # unused because !$any_orig. Whatever.
1761 foreach my $tt (@tartrees) {
1762 $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1765 committer $r1authline
1769 [dgit import orig $tt->{F}]
1777 [dgit import tarball $package $cversion $tt->{F}]
1782 open C, ">../commit.tmp" or die $!;
1783 print C <<END or die $!;
1786 print C <<END or die $! foreach @tartrees;
1789 print C <<END or die $!;
1795 [dgit import $treeimporthow $package $cversion]
1799 my $rawimport_hash = make_commit qw(../commit.tmp);
1801 if (madformat $dsc->{format}) {
1802 # regularise the state of the working tree so that
1803 # the checkout of $rawimport_hash works nicely.
1804 my $dappliedcommit = make_commit_text(<<END);
1811 runcmd @git, qw(checkout -b dapplied), $dappliedcommit;
1813 runcmd @git, qw(checkout -b unpa), $rawimport_hash;
1814 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
1815 my $gapplied = git_rev_parse('HEAD');
1816 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1817 $gappliedtree eq $dappliedtree or
1819 gbp-pq import and dpkg-source disagree!
1820 gbp-pq import gave commit $gapplied
1821 gbp-pq import gave tree $gappliedtree
1822 dpkg-source --before-build gave tree $dappliedtree
1824 $rawimport_hash = $gapplied;
1827 progress "synthesised git commit from .dsc $cversion";
1829 my $rawimport_mergeinput = {
1830 Commit => $rawimport_hash,
1831 Info => "Import of source package",
1833 my @output = ($rawimport_mergeinput);
1835 if ($lastpush_mergeinput) {
1836 my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1837 my $oversion = getfield $oldclogp, 'Version';
1839 version_compare($oversion, $cversion);
1841 @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1842 { Message => <<END, ReverseParents => 1 });
1843 Record $package ($cversion) in archive suite $csuite
1845 } elsif ($vcmp > 0) {
1846 print STDERR <<END or die $!;
1848 Version actually in archive: $cversion (older)
1849 Last version pushed with dgit: $oversion (newer or same)
1852 @output = $lastpush_mergeinput;
1854 # Same version. Use what's in the server git branch,
1855 # discarding our own import. (This could happen if the
1856 # server automatically imports all packages into git.)
1857 @output = $lastpush_mergeinput;
1860 changedir '../../../..';
1865 sub complete_file_from_dsc ($$) {
1866 our ($dstdir, $fi) = @_;
1867 # Ensures that we have, in $dir, the file $fi, with the correct
1868 # contents. (Downloading it from alongside $dscurl if necessary.)
1870 my $f = $fi->{Filename};
1871 my $tf = "$dstdir/$f";
1874 if (stat_exists $tf) {
1875 progress "using existing $f";
1878 $furl =~ s{/[^/]+$}{};
1880 die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1881 die "$f ?" if $f =~ m#/#;
1882 runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1883 return 0 if !act_local();
1887 open F, "<", "$tf" or die "$tf: $!";
1888 $fi->{Digester}->reset();
1889 $fi->{Digester}->addfile(*F);
1890 F->error and die $!;
1891 my $got = $fi->{Digester}->hexdigest();
1892 $got eq $fi->{Hash} or
1893 fail "file $f has hash $got but .dsc".
1894 " demands hash $fi->{Hash} ".
1895 ($downloaded ? "(got wrong file from archive!)"
1896 : "(perhaps you should delete this file?)");
1901 sub ensure_we_have_orig () {
1902 my @dfi = dsc_files_info();
1903 foreach my $fi (@dfi) {
1904 my $f = $fi->{Filename};
1905 next unless is_orig_file_in_dsc($f, \@dfi);
1906 complete_file_from_dsc('..', $fi)
1911 sub git_fetch_us () {
1912 # Want to fetch only what we are going to use, unless
1913 # deliberately-not-ff, in which case we must fetch everything.
1915 my @specs = deliberately_not_fast_forward ? qw(tags/*) :
1917 (quiltmode_splitbrain
1918 ? (map { $_->('*',access_basedistro) }
1919 \&debiantag_new, \&debiantag_maintview)
1920 : debiantags('*',access_basedistro));
1921 push @specs, server_branch($csuite);
1922 push @specs, qw(heads/*) if deliberately_not_fast_forward;
1924 # This is rather miserable:
1925 # When git-fetch --prune is passed a fetchspec ending with a *,
1926 # it does a plausible thing. If there is no * then:
1927 # - it matches subpaths too, even if the supplied refspec
1928 # starts refs, and behaves completely madly if the source
1929 # has refs/refs/something. (See, for example, Debian #NNNN.)
1930 # - if there is no matching remote ref, it bombs out the whole
1932 # We want to fetch a fixed ref, and we don't know in advance
1933 # if it exists, so this is not suitable.
1935 # Our workaround is to use git-ls-remote. git-ls-remote has its
1936 # own qairks. Notably, it has the absurd multi-tail-matching
1937 # behaviour: git-ls-remote R refs/foo can report refs/foo AND
1938 # refs/refs/foo etc.
1940 # Also, we want an idempotent snapshot, but we have to make two
1941 # calls to the remote: one to git-ls-remote and to git-fetch. The
1942 # solution is use git-ls-remote to obtain a target state, and
1943 # git-fetch to try to generate it. If we don't manage to generate
1944 # the target state, we try again.
1946 my $specre = join '|', map {
1952 printdebug "git_fetch_us specre=$specre\n";
1953 my $wanted_rref = sub {
1955 return m/^(?:$specre)$/o;
1958 my $fetch_iteration = 0;
1961 if (++$fetch_iteration > 10) {
1962 fail "too many iterations trying to get sane fetch!";
1965 my @look = map { "refs/$_" } @specs;
1966 my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
1970 open GITLS, "-|", @lcmd or die $!;
1972 printdebug "=> ", $_;
1973 m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
1974 my ($objid,$rrefname) = ($1,$2);
1975 if (!$wanted_rref->($rrefname)) {
1977 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
1981 $wantr{$rrefname} = $objid;
1984 close GITLS or failedcmd @lcmd;
1986 # OK, now %want is exactly what we want for refs in @specs
1988 return () if !m/\*$/ && !exists $wantr{"refs/$_"};
1989 "+refs/$_:".lrfetchrefs."/$_";
1992 my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
1993 runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
1996 %lrfetchrefs_f = ();
1999 git_for_each_ref(lrfetchrefs, sub {
2000 my ($objid,$objtype,$lrefname,$reftail) = @_;
2001 $lrfetchrefs_f{$lrefname} = $objid;
2002 $objgot{$objid} = 1;
2005 foreach my $lrefname (sort keys %lrfetchrefs_f) {
2006 my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2007 if (!exists $wantr{$rrefname}) {
2008 if ($wanted_rref->($rrefname)) {
2010 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
2014 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
2017 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2018 delete $lrfetchrefs_f{$lrefname};
2022 foreach my $rrefname (sort keys %wantr) {
2023 my $lrefname = lrfetchrefs.substr($rrefname, 4);
2024 my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2025 my $want = $wantr{$rrefname};
2026 next if $got eq $want;
2027 if (!defined $objgot{$want}) {
2029 warning: git-ls-remote suggests we want $lrefname
2030 warning: and it should refer to $want
2031 warning: but git-fetch didn't fetch that object to any relevant ref.
2032 warning: This may be due to a race with someone updating the server.
2033 warning: Will try again...
2035 next FETCH_ITERATION;
2038 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
2040 runcmd_ordryrun_local @git, qw(update-ref -m),
2041 "dgit fetch git-fetch fixup", $lrefname, $want;
2042 $lrfetchrefs_f{$lrefname} = $want;
2046 printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
2047 Dumper(\%lrfetchrefs_f);
2050 my @tagpats = debiantags('*',access_basedistro);
2052 git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2053 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2054 printdebug "currently $fullrefname=$objid\n";
2055 $here{$fullrefname} = $objid;
2057 git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2058 my ($objid,$objtype,$fullrefname,$reftail) = @_;
2059 my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2060 printdebug "offered $lref=$objid\n";
2061 if (!defined $here{$lref}) {
2062 my @upd = (@git, qw(update-ref), $lref, $objid, '');
2063 runcmd_ordryrun_local @upd;
2064 lrfetchref_used $fullrefname;
2065 } elsif ($here{$lref} eq $objid) {
2066 lrfetchref_used $fullrefname;
2069 "Not updateting $lref from $here{$lref} to $objid.\n";
2074 sub mergeinfo_getclogp ($) {
2075 # Ensures thit $mi->{Clogp} exists and returns it
2077 $mi->{Clogp} = commit_getclogp($mi->{Commit});
2080 sub mergeinfo_version ($) {
2081 return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2084 sub fetch_from_archive () {
2085 # Ensures that lrref() is what is actually in the archive, one way
2086 # or another, according to us - ie this client's
2087 # appropritaely-updated archive view. Also returns the commit id.
2088 # If there is nothing in the archive, leaves lrref alone and
2089 # returns undef. git_fetch_us must have already been called.
2093 foreach my $field (@ourdscfield) {
2094 $dsc_hash = $dsc->{$field};
2095 last if defined $dsc_hash;
2097 if (defined $dsc_hash) {
2098 $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2100 progress "last upload to archive specified git hash";
2102 progress "last upload to archive has NO git hash";
2105 progress "no version available from the archive";
2108 # If the archive's .dsc has a Dgit field, there are three
2109 # relevant git commitids we need to choose between and/or merge
2111 # 1. $dsc_hash: the Dgit field from the archive
2112 # 2. $lastpush_hash: the suite branch on the dgit git server
2113 # 3. $lastfetch_hash: our local tracking brach for the suite
2115 # These may all be distinct and need not be in any fast forward
2118 # If the dsc was pushed to this suite, then the server suite
2119 # branch will have been updated; but it might have been pushed to
2120 # a different suite and copied by the archive. Conversely a more
2121 # recent version may have been pushed with dgit but not appeared
2122 # in the archive (yet).
2124 # $lastfetch_hash may be awkward because archive imports
2125 # (particularly, imports of Dgit-less .dscs) are performed only as
2126 # needed on individual clients, so different clients may perform a
2127 # different subset of them - and these imports are only made
2128 # public during push. So $lastfetch_hash may represent a set of
2129 # imports different to a subsequent upload by a different dgit
2132 # Our approach is as follows:
2134 # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2135 # descendant of $dsc_hash, then it was pushed by a dgit user who
2136 # had based their work on $dsc_hash, so we should prefer it.
2137 # Otherwise, $dsc_hash was installed into this suite in the
2138 # archive other than by a dgit push, and (necessarily) after the
2139 # last dgit push into that suite (since a dgit push would have
2140 # been descended from the dgit server git branch); thus, in that
2141 # case, we prefer the archive's version (and produce a
2142 # pseudo-merge to overwrite the dgit server git branch).
2144 # (If there is no Dgit field in the archive's .dsc then
2145 # generate_commit_from_dsc uses the version numbers to decide
2146 # whether the suite branch or the archive is newer. If the suite
2147 # branch is newer it ignores the archive's .dsc; otherwise it
2148 # generates an import of the .dsc, and produces a pseudo-merge to
2149 # overwrite the suite branch with the archive contents.)
2151 # The outcome of that part of the algorithm is the `public view',
2152 # and is same for all dgit clients: it does not depend on any
2153 # unpublished history in the local tracking branch.
2155 # As between the public view and the local tracking branch: The
2156 # local tracking branch is only updated by dgit fetch, and
2157 # whenever dgit fetch runs it includes the public view in the
2158 # local tracking branch. Therefore if the public view is not
2159 # descended from the local tracking branch, the local tracking
2160 # branch must contain history which was imported from the archive
2161 # but never pushed; and, its tip is now out of date. So, we make
2162 # a pseudo-merge to overwrite the old imports and stitch the old
2165 # Finally: we do not necessarily reify the public view (as
2166 # described above). This is so that we do not end up stacking two
2167 # pseudo-merges. So what we actually do is figure out the inputs
2168 # to any public view pseudo-merge and put them in @mergeinputs.
2171 # $mergeinputs[]{Commit}
2172 # $mergeinputs[]{Info}
2173 # $mergeinputs[0] is the one whose tree we use
2174 # @mergeinputs is in the order we use in the actual commit)
2177 # $mergeinputs[]{Message} is a commit message to use
2178 # $mergeinputs[]{ReverseParents} if def specifies that parent
2179 # list should be in opposite order
2180 # Such an entry has no Commit or Info. It applies only when found
2181 # in the last entry. (This ugliness is to support making
2182 # identical imports to previous dgit versions.)
2184 my $lastpush_hash = git_get_ref(lrfetchref());
2185 printdebug "previous reference hash=$lastpush_hash\n";
2186 $lastpush_mergeinput = $lastpush_hash && {
2187 Commit => $lastpush_hash,
2188 Info => "dgit suite branch on dgit git server",
2191 my $lastfetch_hash = git_get_ref(lrref());
2192 printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2193 my $lastfetch_mergeinput = $lastfetch_hash && {
2194 Commit => $lastfetch_hash,
2195 Info => "dgit client's archive history view",
2198 my $dsc_mergeinput = $dsc_hash && {
2199 Commit => $dsc_hash,
2200 Info => "Dgit field in .dsc from archive",
2204 my $del_lrfetchrefs = sub {
2207 printdebug "del_lrfetchrefs...\n";
2208 foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2209 my $objid = $lrfetchrefs_d{$fullrefname};
2210 printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2212 $gur ||= new IO::Handle;
2213 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2215 printf $gur "delete %s %s\n", $fullrefname, $objid;
2218 close $gur or failedcmd "git update-ref delete lrfetchrefs";
2222 if (defined $dsc_hash) {
2223 fail "missing remote git history even though dsc has hash -".
2224 " could not find ref ".rref()." at ".access_giturl()
2225 unless $lastpush_hash;
2226 ensure_we_have_orig();
2227 if ($dsc_hash eq $lastpush_hash) {
2228 @mergeinputs = $dsc_mergeinput
2229 } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2230 print STDERR <<END or die $!;
2232 Git commit in archive is behind the last version allegedly pushed/uploaded.
2233 Commit referred to by archive: $dsc_hash
2234 Last version pushed with dgit: $lastpush_hash
2237 @mergeinputs = ($lastpush_mergeinput);
2239 # Archive has .dsc which is not a descendant of the last dgit
2240 # push. This can happen if the archive moves .dscs about.
2241 # Just follow its lead.
2242 if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2243 progress "archive .dsc names newer git commit";
2244 @mergeinputs = ($dsc_mergeinput);
2246 progress "archive .dsc names other git commit, fixing up";
2247 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2251 @mergeinputs = generate_commits_from_dsc();
2252 # We have just done an import. Now, our import algorithm might
2253 # have been improved. But even so we do not want to generate
2254 # a new different import of the same package. So if the
2255 # version numbers are the same, just use our existing version.
2256 # If the version numbers are different, the archive has changed
2257 # (perhaps, rewound).
2258 if ($lastfetch_mergeinput &&
2259 !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2260 (mergeinfo_version $mergeinputs[0]) )) {
2261 @mergeinputs = ($lastfetch_mergeinput);
2263 } elsif ($lastpush_hash) {
2264 # only in git, not in the archive yet
2265 @mergeinputs = ($lastpush_mergeinput);
2266 print STDERR <<END or die $!;
2268 Package not found in the archive, but has allegedly been pushed using dgit.
2272 printdebug "nothing found!\n";
2273 if (defined $skew_warning_vsn) {
2274 print STDERR <<END or die $!;
2276 Warning: relevant archive skew detected.
2277 Archive allegedly contains $skew_warning_vsn
2278 But we were not able to obtain any version from the archive or git.
2282 unshift @end, $del_lrfetchrefs;
2286 if ($lastfetch_hash &&
2288 my $h = $_->{Commit};
2289 $h and is_fast_fwd($lastfetch_hash, $h);
2290 # If true, one of the existing parents of this commit
2291 # is a descendant of the $lastfetch_hash, so we'll
2292 # be ff from that automatically.
2296 push @mergeinputs, $lastfetch_mergeinput;
2299 printdebug "fetch mergeinfos:\n";
2300 foreach my $mi (@mergeinputs) {
2302 printdebug " commit $mi->{Commit} $mi->{Info}\n";
2304 printdebug sprintf " ReverseParents=%d Message=%s",
2305 $mi->{ReverseParents}, $mi->{Message};
2309 my $compat_info= pop @mergeinputs
2310 if $mergeinputs[$#mergeinputs]{Message};
2312 @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2315 if (@mergeinputs > 1) {
2317 my $tree_commit = $mergeinputs[0]{Commit};
2319 my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2320 $tree =~ m/\n\n/; $tree = $`;
2321 $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2324 # We use the changelog author of the package in question the
2325 # author of this pseudo-merge. This is (roughly) correct if
2326 # this commit is simply representing aa non-dgit upload.
2327 # (Roughly because it does not record sponsorship - but we
2328 # don't have sponsorship info because that's in the .changes,
2329 # which isn't in the archivw.)
2331 # But, it might be that we are representing archive history
2332 # updates (including in-archive copies). These are not really
2333 # the responsibility of the person who created the .dsc, but
2334 # there is no-one whose name we should better use. (The
2335 # author of the .dsc-named commit is clearly worse.)
2337 my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2338 my $author = clogp_authline $useclogp;
2339 my $cversion = getfield $useclogp, 'Version';
2341 my $mcf = ".git/dgit/mergecommit";
2342 open MC, ">", $mcf or die "$mcf $!";
2343 print MC <<END or die $!;
2347 my @parents = grep { $_->{Commit} } @mergeinputs;
2348 @parents = reverse @parents if $compat_info->{ReverseParents};
2349 print MC <<END or die $! foreach @parents;
2353 print MC <<END or die $!;
2359 if (defined $compat_info->{Message}) {
2360 print MC $compat_info->{Message} or die $!;
2362 print MC <<END or die $!;
2363 Record $package ($cversion) in archive suite $csuite
2367 my $message_add_info = sub {
2369 my $mversion = mergeinfo_version $mi;
2370 printf MC " %-20s %s\n", $mversion, $mi->{Info}
2374 $message_add_info->($mergeinputs[0]);
2375 print MC <<END or die $!;
2376 should be treated as descended from
2378 $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2382 $hash = make_commit $mcf;
2384 $hash = $mergeinputs[0]{Commit};
2386 progress "fetch hash=$hash\n";
2389 my ($lasth, $what) = @_;
2390 return unless $lasth;
2391 die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2394 $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2395 $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2397 runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2398 'DGIT_ARCHIVE', $hash;
2399 cmdoutput @git, qw(log -n2), $hash;
2400 # ... gives git a chance to complain if our commit is malformed
2402 if (defined $skew_warning_vsn) {
2404 printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2405 my $gotclogp = commit_getclogp($hash);
2406 my $got_vsn = getfield $gotclogp, 'Version';
2407 printdebug "SKEW CHECK GOT $got_vsn\n";
2408 if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2409 print STDERR <<END or die $!;
2411 Warning: archive skew detected. Using the available version:
2412 Archive allegedly contains $skew_warning_vsn
2413 We were able to obtain only $got_vsn
2419 if ($lastfetch_hash ne $hash) {
2420 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2424 dryrun_report @upd_cmd;
2428 lrfetchref_used lrfetchref();
2430 unshift @end, $del_lrfetchrefs;
2434 sub set_local_git_config ($$) {
2436 runcmd @git, qw(config), $k, $v;
2439 sub setup_mergechangelogs (;$) {
2441 return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2443 my $driver = 'dpkg-mergechangelogs';
2444 my $cb = "merge.$driver";
2445 my $attrs = '.git/info/attributes';
2446 ensuredir '.git/info';
2448 open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2449 if (!open ATTRS, "<", $attrs) {
2450 $!==ENOENT or die "$attrs: $!";
2454 next if m{^debian/changelog\s};
2455 print NATTRS $_, "\n" or die $!;
2457 ATTRS->error and die $!;
2460 print NATTRS "debian/changelog merge=$driver\n" or die $!;
2463 set_local_git_config "$cb.name", 'debian/changelog merge driver';
2464 set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2466 rename "$attrs.new", "$attrs" or die "$attrs: $!";
2469 sub setup_useremail (;$) {
2471 return unless $always || access_cfg_bool(1, 'setup-useremail');
2474 my ($k, $envvar) = @_;
2475 my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2476 return unless defined $v;
2477 set_local_git_config "user.$k", $v;
2480 $setup->('email', 'DEBEMAIL');
2481 $setup->('name', 'DEBFULLNAME');
2484 sub setup_new_tree () {
2485 setup_mergechangelogs();
2491 canonicalise_suite();
2492 badusage "dry run makes no sense with clone" unless act_local();
2493 my $hasgit = check_for_git();
2494 mkdir $dstdir or fail "create \`$dstdir': $!";
2496 runcmd @git, qw(init -q);
2497 my $giturl = access_giturl(1);
2498 if (defined $giturl) {
2499 open H, "> .git/HEAD" or die $!;
2500 print H "ref: ".lref()."\n" or die $!;
2502 runcmd @git, qw(remote add), 'origin', $giturl;
2505 progress "fetching existing git history";
2507 runcmd_ordryrun_local @git, qw(fetch origin);
2509 progress "starting new git history";
2511 fetch_from_archive() or no_such_package;
2512 my $vcsgiturl = $dsc->{'Vcs-Git'};
2513 if (length $vcsgiturl) {
2514 $vcsgiturl =~ s/\s+-b\s+\S+//g;
2515 runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2518 runcmd @git, qw(reset --hard), lrref();
2519 printdone "ready for work in $dstdir";
2523 if (check_for_git()) {
2526 fetch_from_archive() or no_such_package();
2527 printdone "fetched into ".lrref();
2532 runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2534 printdone "fetched to ".lrref()." and merged into HEAD";
2537 sub check_not_dirty () {
2538 foreach my $f (qw(local-options local-patch-header)) {
2539 if (stat_exists "debian/source/$f") {
2540 fail "git tree contains debian/source/$f";
2544 return if $ignoredirty;
2546 my @cmd = (@git, qw(diff --quiet HEAD));
2548 $!=0; $?=-1; system @cmd;
2551 fail "working tree is dirty (does not match HEAD)";
2557 sub commit_admin ($) {
2560 runcmd_ordryrun_local @git, qw(commit -m), $m;
2563 sub commit_quilty_patch () {
2564 my $output = cmdoutput @git, qw(status --porcelain);
2566 foreach my $l (split /\n/, $output) {
2567 next unless $l =~ m/\S/;
2568 if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2572 delete $adds{'.pc'}; # if there wasn't one before, don't add it
2574 progress "nothing quilty to commit, ok.";
2577 my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2578 runcmd_ordryrun_local @git, qw(add -f), @adds;
2579 commit_admin "Commit Debian 3.0 (quilt) metadata";
2582 sub get_source_format () {
2584 if (open F, "debian/source/options") {
2588 s/\s+$//; # ignore missing final newline
2590 my ($k, $v) = ($`, $'); #');
2591 $v =~ s/^"(.*)"$/$1/;
2597 F->error and die $!;
2600 die $! unless $!==&ENOENT;
2603 if (!open F, "debian/source/format") {
2604 die $! unless $!==&ENOENT;
2608 F->error and die $!;
2610 return ($_, \%options);
2613 sub madformat_wantfixup ($) {
2615 return 0 unless $format eq '3.0 (quilt)';
2616 our $quilt_mode_warned;
2617 if ($quilt_mode eq 'nocheck') {
2618 progress "Not doing any fixup of \`$format' due to".
2619 " ----no-quilt-fixup or --quilt=nocheck"
2620 unless $quilt_mode_warned++;
2623 progress "Format \`$format', need to check/update patch stack"
2624 unless $quilt_mode_warned++;
2628 # An "infopair" is a tuple [ $thing, $what ]
2629 # (often $thing is a commit hash; $what is a description)
2631 sub infopair_cond_equal ($$) {
2633 $x->[0] eq $y->[0] or fail <<END;
2634 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2638 sub infopair_lrf_tag_lookup ($$) {
2639 my ($tagnames, $what) = @_;
2640 # $tagname may be an array ref
2641 my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2642 printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2643 foreach my $tagname (@tagnames) {
2644 my $lrefname = lrfetchrefs."/tags/$tagname";
2645 my $tagobj = $lrfetchrefs_f{$lrefname};
2646 next unless defined $tagobj;
2647 printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2648 return [ git_rev_parse($tagobj), $what ];
2650 fail @tagnames==1 ? <<END : <<END;
2651 Wanted tag $what (@tagnames) on dgit server, but not found
2653 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2657 sub infopair_cond_ff ($$) {
2658 my ($anc,$desc) = @_;
2659 is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2660 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2664 sub pseudomerge_version_check ($$) {
2665 my ($clogp, $archive_hash) = @_;
2667 my $arch_clogp = commit_getclogp $archive_hash;
2668 my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2669 'version currently in archive' ];
2670 if (defined $overwrite_version) {
2671 if (length $overwrite_version) {
2672 infopair_cond_equal([ $overwrite_version,
2673 '--overwrite= version' ],
2676 my $v = $i_arch_v->[0];
2677 progress "Checking package changelog for archive version $v ...";
2679 my @xa = ("-f$v", "-t$v");
2680 my $vclogp = parsechangelog @xa;
2681 my $cv = [ (getfield $vclogp, 'Version'),
2682 "Version field from dpkg-parsechangelog @xa" ];
2683 infopair_cond_equal($i_arch_v, $cv);
2686 $@ =~ s/^dgit: //gm;
2688 "Perhaps debian/changelog does not mention $v ?";
2693 printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2697 sub pseudomerge_make_commit ($$$$ $$) {
2698 my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2699 $msg_cmd, $msg_msg) = @_;
2700 progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2702 my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2703 my $authline = clogp_authline $clogp;
2707 !defined $overwrite_version ? ""
2708 : !length $overwrite_version ? " --overwrite"
2709 : " --overwrite=".$overwrite_version;
2712 my $pmf = ".git/dgit/pseudomerge";
2713 open MC, ">", $pmf or die "$pmf $!";
2714 print MC <<END or die $!;
2717 parent $archive_hash
2727 return make_commit($pmf);
2730 sub splitbrain_pseudomerge ($$$$) {
2731 my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2732 # => $merged_dgitview
2733 printdebug "splitbrain_pseudomerge...\n";
2735 # We: debian/PREVIOUS HEAD($maintview)
2736 # expect: o ----------------- o
2739 # a/d/PREVIOUS $dgitview
2742 # we do: `------------------ o
2746 printdebug "splitbrain_pseudomerge...\n";
2748 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2750 return $dgitview unless defined $archive_hash;
2752 if (!defined $overwrite_version) {
2753 progress "Checking that HEAD inciudes all changes in archive...";
2756 return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2758 my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2759 my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2760 my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2761 my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2762 my $i_archive = [ $archive_hash, "current archive contents" ];
2764 printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2766 infopair_cond_equal($i_dgit, $i_archive);
2767 infopair_cond_ff($i_dep14, $i_dgit);
2768 $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2770 my $r = pseudomerge_make_commit
2771 $clogp, $dgitview, $archive_hash, $i_arch_v,
2772 "dgit --quilt=$quilt_mode",
2773 (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2774 Declare fast forward from $overwrite_version
2776 Make fast forward from $i_arch_v->[0]
2779 progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2783 sub plain_overwrite_pseudomerge ($$$) {
2784 my ($clogp, $head, $archive_hash) = @_;
2786 printdebug "plain_overwrite_pseudomerge...";
2788 my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2790 my @tagformats = access_cfg_tagformats();
2792 map { $_->($i_arch_v->[0], access_basedistro) }
2793 (grep { m/^(?:old|hist)$/ } @tagformats)
2794 ? \&debiantags : \&debiantag_new;
2795 my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2796 my $i_archive = [ $archive_hash, "current archive contents" ];
2798 infopair_cond_equal($i_overwr, $i_archive);
2800 return $head if is_fast_fwd $archive_hash, $head;
2802 my $m = "Declare fast forward from $i_arch_v->[0]";
2804 my $r = pseudomerge_make_commit
2805 $clogp, $head, $archive_hash, $i_arch_v,
2808 runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2810 progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2814 sub push_parse_changelog ($) {
2817 my $clogp = Dpkg::Control::Hash->new();
2818 $clogp->load($clogpfn) or die;
2820 $package = getfield $clogp, 'Source';
2821 my $cversion = getfield $clogp, 'Version';
2822 my $tag = debiantag($cversion, access_basedistro);
2823 runcmd @git, qw(check-ref-format), $tag;
2825 my $dscfn = dscfn($cversion);
2827 return ($clogp, $cversion, $dscfn);
2830 sub push_parse_dsc ($$$) {
2831 my ($dscfn,$dscfnwhat, $cversion) = @_;
2832 $dsc = parsecontrol($dscfn,$dscfnwhat);
2833 my $dversion = getfield $dsc, 'Version';
2834 my $dscpackage = getfield $dsc, 'Source';
2835 ($dscpackage eq $package && $dversion eq $cversion) or
2836 fail "$dscfn is for $dscpackage $dversion".
2837 " but debian/changelog is for $package $cversion";
2840 sub push_tagwants ($$$$) {
2841 my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2844 TagFn => \&debiantag,
2849 if (defined $maintviewhead) {
2851 TagFn => \&debiantag_maintview,
2852 Objid => $maintviewhead,
2853 TfSuffix => '-maintview',
2857 foreach my $tw (@tagwants) {
2858 $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2859 $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2861 printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2865 sub push_mktags ($$ $$ $) {
2867 $changesfile,$changesfilewhat,
2870 die unless $tagwants->[0]{View} eq 'dgit';
2872 $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2873 $dsc->save("$dscfn.tmp") or die $!;
2875 my $changes = parsecontrol($changesfile,$changesfilewhat);
2876 foreach my $field (qw(Source Distribution Version)) {
2877 $changes->{$field} eq $clogp->{$field} or
2878 fail "changes field $field \`$changes->{$field}'".
2879 " does not match changelog \`$clogp->{$field}'";
2882 my $cversion = getfield $clogp, 'Version';
2883 my $clogsuite = getfield $clogp, 'Distribution';
2885 # We make the git tag by hand because (a) that makes it easier
2886 # to control the "tagger" (b) we can do remote signing
2887 my $authline = clogp_authline $clogp;
2888 my $delibs = join(" ", "",@deliberatelies);
2889 my $declaredistro = access_basedistro();
2893 my $tfn = $tw->{Tfn};
2894 my $head = $tw->{Objid};
2895 my $tag = $tw->{Tag};
2897 open TO, '>', $tfn->('.tmp') or die $!;
2898 print TO <<END or die $!;
2905 if ($tw->{View} eq 'dgit') {
2906 print TO <<END or die $!;
2907 $package release $cversion for $clogsuite ($csuite) [dgit]
2908 [dgit distro=$declaredistro$delibs]
2910 foreach my $ref (sort keys %previously) {
2911 print TO <<END or die $!;
2912 [dgit previously:$ref=$previously{$ref}]
2915 } elsif ($tw->{View} eq 'maint') {
2916 print TO <<END or die $!;
2917 $package release $cversion for $clogsuite ($csuite)
2918 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2921 die Dumper($tw)."?";
2926 my $tagobjfn = $tfn->('.tmp');
2928 if (!defined $keyid) {
2929 $keyid = access_cfg('keyid','RETURN-UNDEF');
2931 if (!defined $keyid) {
2932 $keyid = getfield $clogp, 'Maintainer';
2934 unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2935 my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2936 push @sign_cmd, qw(-u),$keyid if defined $keyid;
2937 push @sign_cmd, $tfn->('.tmp');
2938 runcmd_ordryrun @sign_cmd;
2940 $tagobjfn = $tfn->('.signed.tmp');
2941 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2942 $tfn->('.tmp'), $tfn->('.tmp.asc');
2948 my @r = map { $mktag->($_); } @$tagwants;
2952 sub sign_changes ($) {
2953 my ($changesfile) = @_;
2955 my @debsign_cmd = @debsign;
2956 push @debsign_cmd, "-k$keyid" if defined $keyid;
2957 push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2958 push @debsign_cmd, $changesfile;
2959 runcmd_ordryrun @debsign_cmd;
2964 printdebug "actually entering push\n";
2966 supplementary_message(<<'END');
2967 Push failed, while checking state of the archive.
2968 You can retry the push, after fixing the problem, if you like.
2970 if (check_for_git()) {
2973 my $archive_hash = fetch_from_archive();
2974 if (!$archive_hash) {
2976 fail "package appears to be new in this suite;".
2977 " if this is intentional, use --new";
2980 supplementary_message(<<'END');
2981 Push failed, while preparing your push.
2982 You can retry the push, after fixing the problem, if you like.
2985 need_tagformat 'new', "quilt mode $quilt_mode"
2986 if quiltmode_splitbrain;
2990 access_giturl(); # check that success is vaguely likely
2993 my $clogpfn = ".git/dgit/changelog.822.tmp";
2994 runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2996 responder_send_file('parsed-changelog', $clogpfn);
2998 my ($clogp, $cversion, $dscfn) =
2999 push_parse_changelog("$clogpfn");
3001 my $dscpath = "$buildproductsdir/$dscfn";
3002 stat_exists $dscpath or
3003 fail "looked for .dsc $dscfn, but $!;".
3004 " maybe you forgot to build";
3006 responder_send_file('dsc', $dscpath);
3008 push_parse_dsc($dscpath, $dscfn, $cversion);
3010 my $format = getfield $dsc, 'Format';
3011 printdebug "format $format\n";
3013 my $actualhead = git_rev_parse('HEAD');
3014 my $dgithead = $actualhead;
3015 my $maintviewhead = undef;
3017 if (madformat_wantfixup($format)) {
3018 # user might have not used dgit build, so maybe do this now:
3019 if (quiltmode_splitbrain()) {
3020 my $upstreamversion = $clogp->{Version};
3021 $upstreamversion =~ s/-[^-]*$//;
3023 quilt_make_fake_dsc($upstreamversion);
3024 my ($dgitview, $cachekey) =
3025 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3027 "--quilt=$quilt_mode but no cached dgit view:
3028 perhaps tree changed since dgit build[-source] ?";
3030 $dgithead = splitbrain_pseudomerge($clogp,
3031 $actualhead, $dgitview,
3033 $maintviewhead = $actualhead;
3034 changedir '../../../..';
3035 prep_ud(); # so _only_subdir() works, below
3037 commit_quilty_patch();
3041 if (defined $overwrite_version && !defined $maintviewhead) {
3042 $dgithead = plain_overwrite_pseudomerge($clogp,
3050 if ($archive_hash) {
3051 if (is_fast_fwd($archive_hash, $dgithead)) {
3053 } elsif (deliberately_not_fast_forward) {
3056 fail "dgit push: HEAD is not a descendant".
3057 " of the archive's version.\n".
3058 "To overwrite the archive's contents,".
3059 " pass --overwrite[=VERSION].\n".
3060 "To rewind history, if permitted by the archive,".
3061 " use --deliberately-not-fast-forward.";
3066 progress "checking that $dscfn corresponds to HEAD";
3067 runcmd qw(dpkg-source -x --),
3068 $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3069 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3070 check_for_vendor_patches() if madformat($dsc->{format});
3071 changedir '../../../..';
3072 my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
3073 my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
3074 debugcmd "+",@diffcmd;
3076 my $r = system @diffcmd;
3079 fail "$dscfn specifies a different tree to your HEAD commit;".
3080 " perhaps you forgot to build".
3081 ($diffopt eq '--exit-code' ? "" :
3082 " (run with -D to see full diff output)");
3087 if (!$changesfile) {
3088 my $pat = changespat $cversion;
3089 my @cs = glob "$buildproductsdir/$pat";
3090 fail "failed to find unique changes file".
3091 " (looked for $pat in $buildproductsdir);".
3092 " perhaps you need to use dgit -C"
3094 ($changesfile) = @cs;
3096 $changesfile = "$buildproductsdir/$changesfile";
3099 # Checks complete, we're going to try and go ahead:
3101 responder_send_file('changes',$changesfile);
3102 responder_send_command("param head $dgithead");
3103 responder_send_command("param csuite $csuite");
3104 responder_send_command("param tagformat $tagformat");
3105 if (defined $maintviewhead) {
3106 die unless ($protovsn//4) >= 4;
3107 responder_send_command("param maint-view $maintviewhead");
3110 if (deliberately_not_fast_forward) {
3111 git_for_each_ref(lrfetchrefs, sub {
3112 my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3113 my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3114 responder_send_command("previously $rrefname=$objid");
3115 $previously{$rrefname} = $objid;
3119 my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3123 supplementary_message(<<'END');
3124 Push failed, while signing the tag.
3125 You can retry the push, after fixing the problem, if you like.
3127 # If we manage to sign but fail to record it anywhere, it's fine.
3128 if ($we_are_responder) {
3129 @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3130 responder_receive_files('signed-tag', @tagobjfns);
3132 @tagobjfns = push_mktags($clogp,$dscpath,
3133 $changesfile,$changesfile,
3136 supplementary_message(<<'END');
3137 Push failed, *after* signing the tag.
3138 If you want to try again, you should use a new version number.
3141 pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3143 foreach my $tw (@tagwants) {
3144 my $tag = $tw->{Tag};
3145 my $tagobjfn = $tw->{TagObjFn};
3147 cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3148 runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3149 runcmd_ordryrun_local
3150 @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3153 supplementary_message(<<'END');
3154 Push failed, while updating the remote git repository - see messages above.
3155 If you want to try again, you should use a new version number.
3157 if (!check_for_git()) {
3158 create_remote_git_repo();
3161 my @pushrefs = $forceflag.$dgithead.":".rrref();
3162 foreach my $tw (@tagwants) {
3163 push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3166 runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
3167 runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3169 supplementary_message(<<'END');
3170 Push failed, after updating the remote git repository.
3171 If you want to try again, you must use a new version number.
3173 if ($we_are_responder) {
3174 my $dryrunsuffix = act_local() ? "" : ".tmp";
3175 responder_receive_files('signed-dsc-changes',
3176 "$dscpath$dryrunsuffix",
3177 "$changesfile$dryrunsuffix");
3180 rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3182 progress "[new .dsc left in $dscpath.tmp]";
3184 sign_changes $changesfile;
3187 supplementary_message(<<END);
3188 Push failed, while uploading package(s) to the archive server.
3189 You can retry the upload of exactly these same files with dput of:
3191 If that .changes file is broken, you will need to use a new version
3192 number for your next attempt at the upload.
3194 my $host = access_cfg('upload-host','RETURN-UNDEF');
3195 my @hostarg = defined($host) ? ($host,) : ();
3196 runcmd_ordryrun @dput, @hostarg, $changesfile;
3197 printdone "pushed and uploaded $cversion";
3199 supplementary_message('');
3200 responder_send_command("complete");
3207 badusage "-p is not allowed with clone; specify as argument instead"
3208 if defined $package;
3211 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3212 ($package,$isuite) = @ARGV;
3213 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3214 ($package,$dstdir) = @ARGV;
3215 } elsif (@ARGV==3) {
3216 ($package,$isuite,$dstdir) = @ARGV;
3218 badusage "incorrect arguments to dgit clone";
3220 $dstdir ||= "$package";
3222 if (stat_exists $dstdir) {
3223 fail "$dstdir already exists";
3227 if ($rmonerror && !$dryrun_level) {
3228 $cwd_remove= getcwd();
3230 return unless defined $cwd_remove;
3231 if (!chdir "$cwd_remove") {
3232 return if $!==&ENOENT;
3233 die "chdir $cwd_remove: $!";
3236 rmtree($dstdir) or die "remove $dstdir: $!\n";
3237 } elsif (!grep { $! == $_ }
3238 (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3240 print STDERR "check whether to remove $dstdir: $!\n";
3246 $cwd_remove = undef;
3249 sub branchsuite () {
3250 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3251 if ($branch =~ m#$lbranch_re#o) {
3258 sub fetchpullargs () {
3260 if (!defined $package) {
3261 my $sourcep = parsecontrol('debian/control','debian/control');
3262 $package = getfield $sourcep, 'Source';
3265 # $isuite = branchsuite(); # this doesn't work because dak hates canons
3267 my $clogp = parsechangelog();
3268 $isuite = getfield $clogp, 'Distribution';
3270 canonicalise_suite();
3271 progress "fetching from suite $csuite";
3272 } elsif (@ARGV==1) {
3274 canonicalise_suite();
3276 badusage "incorrect arguments to dgit fetch or dgit pull";
3295 badusage "-p is not allowed with dgit push" if defined $package;
3297 my $clogp = parsechangelog();
3298 $package = getfield $clogp, 'Source';
3301 } elsif (@ARGV==1) {
3302 ($specsuite) = (@ARGV);
3304 badusage "incorrect arguments to dgit push";
3306 $isuite = getfield $clogp, 'Distribution';
3308 local ($package) = $existing_package; # this is a hack
3309 canonicalise_suite();
3311 canonicalise_suite();
3313 if (defined $specsuite &&
3314 $specsuite ne $isuite &&
3315 $specsuite ne $csuite) {
3316 fail "dgit push: changelog specifies $isuite ($csuite)".
3317 " but command line specifies $specsuite";
3322 #---------- remote commands' implementation ----------
3324 sub cmd_remote_push_build_host {
3325 my ($nrargs) = shift @ARGV;
3326 my (@rargs) = @ARGV[0..$nrargs-1];
3327 @ARGV = @ARGV[$nrargs..$#ARGV];
3329 my ($dir,$vsnwant) = @rargs;
3330 # vsnwant is a comma-separated list; we report which we have
3331 # chosen in our ready response (so other end can tell if they
3334 $we_are_responder = 1;
3335 $us .= " (build host)";
3339 open PI, "<&STDIN" or die $!;
3340 open STDIN, "/dev/null" or die $!;
3341 open PO, ">&STDOUT" or die $!;
3343 open STDOUT, ">&STDERR" or die $!;
3347 ($protovsn) = grep {
3348 $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3349 } @rpushprotovsn_support;
3351 fail "build host has dgit rpush protocol versions ".
3352 (join ",", @rpushprotovsn_support).
3353 " but invocation host has $vsnwant"
3354 unless defined $protovsn;
3356 responder_send_command("dgit-remote-push-ready $protovsn");
3357 rpush_handle_protovsn_bothends();
3362 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3363 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3364 # a good error message)
3366 sub rpush_handle_protovsn_bothends () {
3367 if ($protovsn < 4) {
3368 need_tagformat 'old', "rpush negotiated protocol $protovsn";
3377 my $report = i_child_report();
3378 if (defined $report) {
3379 printdebug "($report)\n";
3380 } elsif ($i_child_pid) {
3381 printdebug "(killing build host child $i_child_pid)\n";
3382 kill 15, $i_child_pid;
3384 if (defined $i_tmp && !defined $initiator_tempdir) {
3386 eval { rmtree $i_tmp; };
3390 END { i_cleanup(); }
3393 my ($base,$selector,@args) = @_;
3394 $selector =~ s/\-/_/g;
3395 { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3402 if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3410 push @rargs, join ",", @rpushprotovsn_support;
3413 push @rdgit, @ropts;
3414 push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3416 my @cmd = (@ssh, $host, shellquote @rdgit);
3419 if (defined $initiator_tempdir) {
3420 rmtree $initiator_tempdir;
3421 mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3422 $i_tmp = $initiator_tempdir;
3426 $i_child_pid = open2(\*RO, \*RI, @cmd);
3428 ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3429 die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3430 $supplementary_message = '' unless $protovsn >= 3;
3432 fail "rpush negotiated protocol version $protovsn".
3433 " which does not support quilt mode $quilt_mode"
3434 if quiltmode_splitbrain;
3436 rpush_handle_protovsn_bothends();
3438 my ($icmd,$iargs) = initiator_expect {
3439 m/^(\S+)(?: (.*))?$/;
3442 i_method "i_resp", $icmd, $iargs;
3446 sub i_resp_progress ($) {
3448 my $msg = protocol_read_bytes \*RO, $rhs;
3452 sub i_resp_supplementary_message ($) {
3454 $supplementary_message = protocol_read_bytes \*RO, $rhs;
3457 sub i_resp_complete {
3458 my $pid = $i_child_pid;
3459 $i_child_pid = undef; # prevents killing some other process with same pid
3460 printdebug "waiting for build host child $pid...\n";
3461 my $got = waitpid $pid, 0;
3462 die $! unless $got == $pid;
3463 die "build host child failed $?" if $?;
3466 printdebug "all done\n";
3470 sub i_resp_file ($) {
3472 my $localname = i_method "i_localname", $keyword;
3473 my $localpath = "$i_tmp/$localname";
3474 stat_exists $localpath and
3475 badproto \*RO, "file $keyword ($localpath) twice";
3476 protocol_receive_file \*RO, $localpath;
3477 i_method "i_file", $keyword;
3482 sub i_resp_param ($) {
3483 $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3487 sub i_resp_previously ($) {
3488 $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3489 or badproto \*RO, "bad previously spec";
3490 my $r = system qw(git check-ref-format), $1;
3491 die "bad previously ref spec ($r)" if $r;
3492 $previously{$1} = $2;
3497 sub i_resp_want ($) {
3499 die "$keyword ?" if $i_wanted{$keyword}++;
3500 my @localpaths = i_method "i_want", $keyword;
3501 printdebug "[[ $keyword @localpaths\n";
3502 foreach my $localpath (@localpaths) {
3503 protocol_send_file \*RI, $localpath;
3505 print RI "files-end\n" or die $!;
3508 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3510 sub i_localname_parsed_changelog {
3511 return "remote-changelog.822";
3513 sub i_file_parsed_changelog {
3514 ($i_clogp, $i_version, $i_dscfn) =
3515 push_parse_changelog "$i_tmp/remote-changelog.822";
3516 die if $i_dscfn =~ m#/|^\W#;
3519 sub i_localname_dsc {
3520 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3525 sub i_localname_changes {
3526 defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3527 $i_changesfn = $i_dscfn;
3528 $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3529 return $i_changesfn;
3531 sub i_file_changes { }
3533 sub i_want_signed_tag {
3534 printdebug Dumper(\%i_param, $i_dscfn);
3535 defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3536 && defined $i_param{'csuite'}
3537 or badproto \*RO, "premature desire for signed-tag";
3538 my $head = $i_param{'head'};
3539 die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3541 my $maintview = $i_param{'maint-view'};
3542 die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3545 if ($protovsn >= 4) {
3546 my $p = $i_param{'tagformat'} // '<undef>';
3548 or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3551 die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3553 push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3555 my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3558 push_mktags $i_clogp, $i_dscfn,
3559 $i_changesfn, 'remote changes',
3563 sub i_want_signed_dsc_changes {
3564 rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3565 sign_changes $i_changesfn;
3566 return ($i_dscfn, $i_changesfn);
3569 #---------- building etc. ----------
3575 #----- `3.0 (quilt)' handling -----
3577 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3579 sub quiltify_dpkg_commit ($$$;$) {
3580 my ($patchname,$author,$msg, $xinfo) = @_;
3584 my $descfn = ".git/dgit/quilt-description.tmp";
3585 open O, '>', $descfn or die "$descfn: $!";
3588 $msg =~ s/^\s+$/ ./mg;
3589 print O <<END or die $!;
3599 local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3600 local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3601 local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3602 runcmd @dpkgsource, qw(--commit .), $patchname;
3606 sub quiltify_trees_differ ($$;$$) {
3607 my ($x,$y,$finegrained,$ignorenamesr) = @_;
3608 # returns true iff the two tree objects differ other than in debian/
3609 # with $finegrained,
3610 # returns bitmask 01 - differ in upstream files except .gitignore
3611 # 02 - differ in .gitignore
3612 # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3613 # is set for each modified .gitignore filename $fn
3615 my @cmd = (@git, qw(diff-tree --name-only -z));
3616 push @cmd, qw(-r) if $finegrained;
3618 my $diffs= cmdoutput @cmd;
3620 foreach my $f (split /\0/, $diffs) {
3621 next if $f =~ m#^debian(?:/.*)?$#s;
3622 my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3623 $r |= $isignore ? 02 : 01;
3624 $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3626 printdebug "quiltify_trees_differ $x $y => $r\n";
3630 sub quiltify_tree_sentinelfiles ($) {
3631 # lists the `sentinel' files present in the tree
3633 my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3634 qw(-- debian/rules debian/control);
3639 sub quiltify_splitbrain_needed () {
3640 if (!$split_brain) {
3641 progress "dgit view: changes are required...";
3642 runcmd @git, qw(checkout -q -b dgit-view);
3647 sub quiltify_splitbrain ($$$$$$) {
3648 my ($clogp, $unapplied, $headref, $diffbits,
3649 $editedignores, $cachekey) = @_;
3650 if ($quilt_mode !~ m/gbp|dpm/) {
3651 # treat .gitignore just like any other upstream file
3652 $diffbits = { %$diffbits };
3653 $_ = !!$_ foreach values %$diffbits;
3655 # We would like any commits we generate to be reproducible
3656 my @authline = clogp_authline($clogp);
3657 local $ENV{GIT_COMMITTER_NAME} = $authline[0];
3658 local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3659 local $ENV{GIT_COMMITTER_DATE} = $authline[2];
3661 if ($quilt_mode =~ m/gbp|unapplied/ &&
3662 ($diffbits->{H2O} & 01)) {
3664 "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3665 " but git tree differs from orig in upstream files.";
3666 if (!stat_exists "debian/patches") {
3668 "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3672 if ($quilt_mode =~ m/dpm/ &&
3673 ($diffbits->{H2A} & 01)) {
3675 --quilt=$quilt_mode specified, implying patches-applied git tree
3676 but git tree differs from result of applying debian/patches to upstream
3679 if ($quilt_mode =~ m/gbp|unapplied/ &&
3680 ($diffbits->{O2A} & 01)) { # some patches
3681 quiltify_splitbrain_needed();
3682 progress "dgit view: creating patches-applied version using gbp pq";
3683 runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3684 # gbp pq import creates a fresh branch; push back to dgit-view
3685 runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3686 runcmd @git, qw(checkout -q dgit-view);
3688 if ($quilt_mode =~ m/gbp|dpm/ &&
3689 ($diffbits->{O2A} & 02)) {
3691 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3692 tool which does not create patches for changes to upstream
3693 .gitignores: but, such patches exist in debian/patches.
3696 if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3697 !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3698 quiltify_splitbrain_needed();
3699 progress "dgit view: creating patch to represent .gitignore changes";
3700 ensuredir "debian/patches";
3701 my $gipatch = "debian/patches/auto-gitignore";
3702 open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3703 stat GIPATCH or die "$gipatch: $!";
3704 fail "$gipatch already exists; but want to create it".
3705 " to record .gitignore changes" if (stat _)[7];
3706 print GIPATCH <<END or die "$gipatch: $!";
3707 Subject: Update .gitignore from Debian packaging branch
3709 The Debian packaging git branch contains these updates to the upstream
3710 .gitignore file(s). This patch is autogenerated, to provide these
3711 updates to users of the official Debian archive view of the package.
3713 [dgit version $our_version]
3716 close GIPATCH or die "$gipatch: $!";
3717 runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3718 $unapplied, $headref, "--", sort keys %$editedignores;
3719 open SERIES, "+>>", "debian/patches/series" or die $!;
3720 defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3722 defined read SERIES, $newline, 1 or die $!;
3723 print SERIES "\n" or die $! unless $newline eq "\n";
3724 print SERIES "auto-gitignore\n" or die $!;
3725 close SERIES or die $!;
3726 runcmd @git, qw(add -- debian/patches/series), $gipatch;
3727 commit_admin "Commit patch to update .gitignore";
3730 my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3732 changedir '../../../..';
3733 ensuredir ".git/logs/refs/dgit-intern";
3734 my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3736 runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3739 progress "dgit view: created (commit id $dgitview)";
3741 changedir '.git/dgit/unpack/work';
3744 sub quiltify ($$$$) {
3745 my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3747 # Quilt patchification algorithm
3749 # We search backwards through the history of the main tree's HEAD
3750 # (T) looking for a start commit S whose tree object is identical
3751 # to to the patch tip tree (ie the tree corresponding to the
3752 # current dpkg-committed patch series). For these purposes
3753 # `identical' disregards anything in debian/ - this wrinkle is
3754 # necessary because dpkg-source treates debian/ specially.
3756 # We can only traverse edges where at most one of the ancestors'
3757 # trees differs (in changes outside in debian/). And we cannot
3758 # handle edges which change .pc/ or debian/patches. To avoid
3759 # going down a rathole we avoid traversing edges which introduce
3760 # debian/rules or debian/control. And we set a limit on the
3761 # number of edges we are willing to look at.
3763 # If we succeed, we walk forwards again. For each traversed edge
3764 # PC (with P parent, C child) (starting with P=S and ending with
3765 # C=T) to we do this:
3767 # - dpkg-source --commit with a patch name and message derived from C
3768 # After traversing PT, we git commit the changes which
3769 # should be contained within debian/patches.
3771 # The search for the path S..T is breadth-first. We maintain a
3772 # todo list containing search nodes. A search node identifies a
3773 # commit, and looks something like this:
3775 # Commit => $git_commit_id,
3776 # Child => $c, # or undef if P=T
3777 # Whynot => $reason_edge_PC_unsuitable, # in @nots only
3778 # Nontrivial => true iff $p..$c has relevant changes
3785 my %considered; # saves being exponential on some weird graphs
3787 my $t_sentinels = quiltify_tree_sentinelfiles $target;
3790 my ($search,$whynot) = @_;
3791 printdebug " search NOT $search->{Commit} $whynot\n";
3792 $search->{Whynot} = $whynot;
3793 push @nots, $search;
3794 no warnings qw(exiting);
3803 my $c = shift @todo;
3804 next if $considered{$c->{Commit}}++;
3806 $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3808 printdebug "quiltify investigate $c->{Commit}\n";
3811 if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3812 printdebug " search finished hooray!\n";
3817 if ($quilt_mode eq 'nofix') {
3818 fail "quilt fixup required but quilt mode is \`nofix'\n".
3819 "HEAD commit $c->{Commit} differs from tree implied by ".
3820 " debian/patches (tree object $oldtiptree)";
3822 if ($quilt_mode eq 'smash') {
3823 printdebug " search quitting smash\n";
3827 my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3828 $not->($c, "has $c_sentinels not $t_sentinels")
3829 if $c_sentinels ne $t_sentinels;
3831 my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3832 $commitdata =~ m/\n\n/;
3834 my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3835 @parents = map { { Commit => $_, Child => $c } } @parents;
3837 $not->($c, "root commit") if !@parents;
3839 foreach my $p (@parents) {
3840 $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3842 my $ndiffers = grep { $_->{Nontrivial} } @parents;
3843 $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3845 foreach my $p (@parents) {
3846 printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3848 my @cmd= (@git, qw(diff-tree -r --name-only),
3849 $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3850 my $patchstackchange = cmdoutput @cmd;
3851 if (length $patchstackchange) {
3852 $patchstackchange =~ s/\n/,/g;
3853 $not->($p, "changed $patchstackchange");
3856 printdebug " search queue P=$p->{Commit} ",
3857 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3863 printdebug "quiltify want to smash\n";
3866 my $x = $_[0]{Commit};
3867 $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3870 my $reportnot = sub {
3872 my $s = $abbrev->($notp);
3873 my $c = $notp->{Child};
3874 $s .= "..".$abbrev->($c) if $c;
3875 $s .= ": ".$notp->{Whynot};
3878 if ($quilt_mode eq 'linear') {
3879 print STDERR "$us: quilt fixup cannot be linear. Stopped at:\n";
3880 foreach my $notp (@nots) {
3881 print STDERR "$us: ", $reportnot->($notp), "\n";
3883 print STDERR "$us: $_\n" foreach @$failsuggestion;
3884 fail "quilt fixup naive history linearisation failed.\n".
3885 "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3886 } elsif ($quilt_mode eq 'smash') {
3887 } elsif ($quilt_mode eq 'auto') {
3888 progress "quilt fixup cannot be linear, smashing...";
3890 die "$quilt_mode ?";
3893 my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3894 $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3896 my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3898 quiltify_dpkg_commit "auto-$version-$target-$time",
3899 (getfield $clogp, 'Maintainer'),
3900 "Automatically generated patch ($clogp->{Version})\n".
3901 "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3905 progress "quiltify linearisation planning successful, executing...";
3907 for (my $p = $sref_S;
3908 my $c = $p->{Child};
3910 printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3911 next unless $p->{Nontrivial};
3913 my $cc = $c->{Commit};
3915 my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3916 $commitdata =~ m/\n\n/ or die "$c ?";
3919 $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3922 $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3925 my $patchname = $title;
3926 $patchname =~ s/[.:]$//;
3927 $patchname =~ y/ A-Z/-a-z/;
3928 $patchname =~ y/-a-z0-9_.+=~//cd;
3929 $patchname =~ s/^\W/x-$&/;
3930 $patchname = substr($patchname,0,40);
3933 stat "debian/patches/$patchname$index";
3935 $!==ENOENT or die "$patchname$index $!";
3937 runcmd @git, qw(checkout -q), $cc;
3939 # We use the tip's changelog so that dpkg-source doesn't
3940 # produce complaining messages from dpkg-parsechangelog. None
3941 # of the information dpkg-source gets from the changelog is
3942 # actually relevant - it gets put into the original message
3943 # which dpkg-source provides our stunt editor, and then
3945 runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3947 quiltify_dpkg_commit "$patchname$index", $author, $msg,
3948 "X-Dgit-Generated: $clogp->{Version} $cc\n";
3950 runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3953 runcmd @git, qw(checkout -q master);
3956 sub build_maybe_quilt_fixup () {
3957 my ($format,$fopts) = get_source_format;
3958 return unless madformat_wantfixup $format;
3961 check_for_vendor_patches();
3963 if (quiltmode_splitbrain) {
3964 foreach my $needtf (qw(new maint)) {
3965 next if grep { $_ eq $needtf } access_cfg_tagformats;
3967 quilt mode $quilt_mode requires split view so server needs to support
3968 both "new" and "maint" tag formats, but config says it doesn't.
3973 my $clogp = parsechangelog();
3974 my $headref = git_rev_parse('HEAD');
3979 my $upstreamversion=$version;
3980 $upstreamversion =~ s/-[^-]*$//;
3982 if ($fopts->{'single-debian-patch'}) {
3983 quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3985 quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3988 die 'bug' if $split_brain && !$need_split_build_invocation;
3990 changedir '../../../..';
3991 runcmd_ordryrun_local
3992 @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3995 sub quilt_fixup_mkwork ($) {
3998 mkdir "work" or die $!;
4000 mktree_in_ud_here();
4001 runcmd @git, qw(reset -q --hard), $headref;
4004 sub quilt_fixup_linkorigs ($$) {
4005 my ($upstreamversion, $fn) = @_;
4006 # calls $fn->($leafname);
4008 foreach my $f (<../../../../*>) { #/){
4009 my $b=$f; $b =~ s{.*/}{};
4011 local ($debuglevel) = $debuglevel-1;
4012 printdebug "QF linkorigs $b, $f ?\n";
4014 next unless is_orig_file_of_vsn $b, $upstreamversion;
4015 printdebug "QF linkorigs $b, $f Y\n";
4016 link_ltarget $f, $b or die "$b $!";
4021 sub quilt_fixup_delete_pc () {
4022 runcmd @git, qw(rm -rqf .pc);
4023 commit_admin "Commit removal of .pc (quilt series tracking data)";
4026 sub quilt_fixup_singlepatch ($$$) {
4027 my ($clogp, $headref, $upstreamversion) = @_;
4029 progress "starting quiltify (single-debian-patch)";
4031 # dpkg-source --commit generates new patches even if
4032 # single-debian-patch is in debian/source/options. In order to
4033 # get it to generate debian/patches/debian-changes, it is
4034 # necessary to build the source package.
4036 quilt_fixup_linkorigs($upstreamversion, sub { });
4037 quilt_fixup_mkwork($headref);
4039 rmtree("debian/patches");
4041 runcmd @dpkgsource, qw(-b .);
4043 runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
4044 rename srcfn("$upstreamversion", "/debian/patches"),
4045 "work/debian/patches";
4048 commit_quilty_patch();
4051 sub quilt_make_fake_dsc ($) {
4052 my ($upstreamversion) = @_;
4054 my $fakeversion="$upstreamversion-~~DGITFAKE";
4056 my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
4057 print $fakedsc <<END or die $!;
4060 Version: $fakeversion
4064 my $dscaddfile=sub {
4067 my $md = new Digest::MD5;
4069 my $fh = new IO::File $b, '<' or die "$b $!";
4074 print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
4077 quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
4079 my @files=qw(debian/source/format debian/rules
4080 debian/control debian/changelog);
4081 foreach my $maybe (qw(debian/patches debian/source/options
4082 debian/tests/control)) {
4083 next unless stat_exists "../../../$maybe";
4084 push @files, $maybe;
4087 my $debtar= srcfn $fakeversion,'.debian.tar.gz';
4088 runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
4090 $dscaddfile->($debtar);
4091 close $fakedsc or die $!;
4094 sub quilt_check_splitbrain_cache ($$) {
4095 my ($headref, $upstreamversion) = @_;
4096 # Called only if we are in (potentially) split brain mode.
4098 # Computes the cache key and looks in the cache.
4099 # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
4101 my $splitbrain_cachekey;
4104 "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
4105 # we look in the reflog of dgit-intern/quilt-cache
4106 # we look for an entry whose message is the key for the cache lookup
4107 my @cachekey = (qw(dgit), $our_version);
4108 push @cachekey, $upstreamversion;
4109 push @cachekey, $quilt_mode;
4110 push @cachekey, $headref;
4112 push @cachekey, hashfile('fake.dsc');
4114 my $srcshash = Digest::SHA->new(256);
4115 my %sfs = ( %INC, '$0(dgit)' => $0 );
4116 foreach my $sfk (sort keys %sfs) {
4117 next unless m/^\$0\b/ || m{^Debian/Dgit\b};
4118 $srcshash->add($sfk," ");
4119 $srcshash->add(hashfile($sfs{$sfk}));
4120 $srcshash->add("\n");
4122 push @cachekey, $srcshash->hexdigest();
4123 $splitbrain_cachekey = "@cachekey";
4125 my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
4127 printdebug "splitbrain cachekey $splitbrain_cachekey\n";
4128 debugcmd "|(probably)",@cmd;
4129 my $child = open GC, "-|"; defined $child or die $!;
4131 chdir '../../..' or die $!;
4132 if (!stat ".git/logs/refs/$splitbraincache") {
4133 $! == ENOENT or die $!;
4134 printdebug ">(no reflog)\n";
4141 printdebug ">| ", $_, "\n" if $debuglevel > 1;
4142 next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
4145 quilt_fixup_mkwork($headref);
4146 if ($cachehit ne $headref) {
4147 progress "dgit view: found cached (commit id $cachehit)";
4148 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
4150 return ($cachehit, $splitbrain_cachekey);
4152 progress "dgit view: found cached, no changes required";
4153 return ($headref, $splitbrain_cachekey);
4155 die $! if GC->error;
4156 failedcmd unless close GC;
4158 printdebug "splitbrain cache miss\n";
4159 return (undef, $splitbrain_cachekey);
4162 sub quilt_fixup_multipatch ($$$) {
4163 my ($clogp, $headref, $upstreamversion) = @_;
4165 progress "examining quilt state (multiple patches, $quilt_mode mode)";
4168 # - honour any existing .pc in case it has any strangeness
4169 # - determine the git commit corresponding to the tip of
4170 # the patch stack (if there is one)
4171 # - if there is such a git commit, convert each subsequent
4172 # git commit into a quilt patch with dpkg-source --commit
4173 # - otherwise convert all the differences in the tree into
4174 # a single git commit
4178 # Our git tree doesn't necessarily contain .pc. (Some versions of
4179 # dgit would include the .pc in the git tree.) If there isn't
4180 # one, we need to generate one by unpacking the patches that we
4183 # We first look for a .pc in the git tree. If there is one, we
4184 # will use it. (This is not the normal case.)
4186 # Otherwise need to regenerate .pc so that dpkg-source --commit
4187 # can work. We do this as follows:
4188 # 1. Collect all relevant .orig from parent directory
4189 # 2. Generate a debian.tar.gz out of
4190 # debian/{patches,rules,source/format,source/options}
4191 # 3. Generate a fake .dsc containing just these fields:
4192 # Format Source Version Files
4193 # 4. Extract the fake .dsc
4194 # Now the fake .dsc has a .pc directory.
4195 # (In fact we do this in every case, because in future we will
4196 # want to search for a good base commit for generating patches.)
4198 # Then we can actually do the dpkg-source --commit
4199 # 1. Make a new working tree with the same object
4200 # store as our main tree and check out the main
4202 # 2. Copy .pc from the fake's extraction, if necessary
4203 # 3. Run dpkg-source --commit
4204 # 4. If the result has changes to debian/, then
4205 # - git-add them them
4206 # - git-add .pc if we had a .pc in-tree
4208 # 5. If we had a .pc in-tree, delete it, and git-commit
4209 # 6. Back in the main tree, fast forward to the new HEAD
4211 # Another situation we may have to cope with is gbp-style
4212 # patches-unapplied trees.
4214 # We would want to detect these, so we know to escape into
4215 # quilt_fixup_gbp. However, this is in general not possible.
4216 # Consider a package with a one patch which the dgit user reverts
4217 # (with git-revert or the moral equivalent).
4219 # That is indistinguishable in contents from a patches-unapplied
4220 # tree. And looking at the history to distinguish them is not
4221 # useful because the user might have made a confusing-looking git
4222 # history structure (which ought to produce an error if dgit can't
4223 # cope, not a silent reintroduction of an unwanted patch).
4225 # So gbp users will have to pass an option. But we can usually
4226 # detect their failure to do so: if the tree is not a clean
4227 # patches-applied tree, quilt linearisation fails, but the tree
4228 # _is_ a clean patches-unapplied tree, we can suggest that maybe
4229 # they want --quilt=unapplied.
4231 # To help detect this, when we are extracting the fake dsc, we
4232 # first extract it with --skip-patches, and then apply the patches
4233 # afterwards with dpkg-source --before-build. That lets us save a
4234 # tree object corresponding to .origs.
4236 my $splitbrain_cachekey;
4238 quilt_make_fake_dsc($upstreamversion);
4240 if (quiltmode_splitbrain()) {
4242 ($cachehit, $splitbrain_cachekey) =
4243 quilt_check_splitbrain_cache($headref, $upstreamversion);
4244 return if $cachehit;
4248 'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
4250 my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
4251 rename $fakexdir, "fake" or die "$fakexdir $!";
4255 remove_stray_gits();
4256 mktree_in_ud_here();
4260 runcmd @git, qw(add -Af .);
4261 my $unapplied=git_write_tree();
4262 printdebug "fake orig tree object $unapplied\n";
4267 'exec dpkg-source --before-build . >/dev/null';
4271 quilt_fixup_mkwork($headref);
4274 if (stat_exists ".pc") {
4276 progress "Tree already contains .pc - will use it then delete it.";
4279 rename '../fake/.pc','.pc' or die $!;
4282 changedir '../fake';
4284 runcmd @git, qw(add -Af .);
4285 my $oldtiptree=git_write_tree();
4286 printdebug "fake o+d/p tree object $unapplied\n";
4287 changedir '../work';
4290 # We calculate some guesswork now about what kind of tree this might
4291 # be. This is mostly for error reporting.
4296 # O = orig, without patches applied
4297 # A = "applied", ie orig with H's debian/patches applied
4298 H2O => quiltify_trees_differ($headref, $unapplied, 1,\%editedignores),
4299 H2A => quiltify_trees_differ($headref, $oldtiptree,1),
4300 O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
4304 foreach my $b (qw(01 02)) {
4305 foreach my $v (qw(H2O O2A H2A)) {
4306 push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
4309 printdebug "differences \@dl @dl.\n";
4312 "$us: quilt differences: src: %s orig %s gitignores: %s orig %s\n".
4313 "$us: quilt differences: HEAD %s o+d/p HEAD %s o+d/p",
4314 $dl[0], $dl[1], $dl[3], $dl[4],
4318 if (!($diffbits->{H2O} & $diffbits->{O2A})) {
4319 push @failsuggestion, "This might be a patches-unapplied branch.";
4320 } elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
4321 push @failsuggestion, "This might be a patches-applied branch.";
4323 push @failsuggestion, "Maybe you need to specify one of".
4324 " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
4326 if (quiltmode_splitbrain()) {
4327 quiltify_splitbrain($clogp, $unapplied, $headref,
4328 $diffbits, \%editedignores,
4329 $splitbrain_cachekey);
4333 progress "starting quiltify (multiple patches, $quilt_mode mode)";
4334 quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
4336 if (!open P, '>>', ".pc/applied-patches") {
4337 $!==&ENOENT or die $!;
4342 commit_quilty_patch();
4344 if ($mustdeletepc) {
4345 quilt_fixup_delete_pc();
4349 sub quilt_fixup_editor () {
4350 my $descfn = $ENV{$fakeeditorenv};
4351 my $editing = $ARGV[$#ARGV];
4352 open I1, '<', $descfn or die "$descfn: $!";
4353 open I2, '<', $editing or die "$editing: $!";
4354 unlink $editing or die "$editing: $!";
4355 open O, '>', $editing or die "$editing: $!";
4356 while (<I1>) { print O or die $!; } I1->error and die $!;
4359 $copying ||= m/^\-\-\- /;
4360 next unless $copying;
4363 I2->error and die $!;
4368 sub maybe_apply_patches_dirtily () {
4369 return unless $quilt_mode =~ m/gbp|unapplied/;
4370 print STDERR <<END or die $!;
4372 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
4373 dgit: Have to apply the patches - making the tree dirty.
4374 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
4377 $patches_applied_dirtily = 01;
4378 $patches_applied_dirtily |= 02 unless stat_exists '.pc';
4379 runcmd qw(dpkg-source --before-build .);
4382 sub maybe_unapply_patches_again () {
4383 progress "dgit: Unapplying patches again to tidy up the tree."
4384 if $patches_applied_dirtily;
4385 runcmd qw(dpkg-source --after-build .)
4386 if $patches_applied_dirtily & 01;
4388 if $patches_applied_dirtily & 02;
4389 $patches_applied_dirtily = 0;
4392 #----- other building -----
4394 our $clean_using_builder;
4395 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
4396 # clean the tree before building (perhaps invoked indirectly by
4397 # whatever we are using to run the build), rather than separately
4398 # and explicitly by us.
4401 return if $clean_using_builder;
4402 if ($cleanmode eq 'dpkg-source') {
4403 maybe_apply_patches_dirtily();
4404 runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
4405 } elsif ($cleanmode eq 'dpkg-source-d') {
4406 maybe_apply_patches_dirtily();
4407 runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
4408 } elsif ($cleanmode eq 'git') {
4409 runcmd_ordryrun_local @git, qw(clean -xdf);
4410 } elsif ($cleanmode eq 'git-ff') {
4411 runcmd_ordryrun_local @git, qw(clean -xdff);
4412 } elsif ($cleanmode eq 'check') {
4413 my $leftovers = cmdoutput @git, qw(clean -xdn);
4414 if (length $leftovers) {
4415 print STDERR $leftovers, "\n" or die $!;
4416 fail "tree contains uncommitted files and --clean=check specified";
4418 } elsif ($cleanmode eq 'none') {
4425 badusage "clean takes no additional arguments" if @ARGV;
4428 maybe_unapply_patches_again();
4433 badusage "-p is not allowed when building" if defined $package;
4436 my $clogp = parsechangelog();
4437 $isuite = getfield $clogp, 'Distribution';
4438 $package = getfield $clogp, 'Source';
4439 $version = getfield $clogp, 'Version';
4440 build_maybe_quilt_fixup();
4442 my $pat = changespat $version;
4443 foreach my $f (glob "$buildproductsdir/$pat") {
4445 unlink $f or fail "remove old changes file $f: $!";
4447 progress "would remove $f";
4453 sub changesopts_initial () {
4454 my @opts =@changesopts[1..$#changesopts];
4457 sub changesopts_version () {
4458 if (!defined $changes_since_version) {
4459 my @vsns = archive_query('archive_query');
4460 my @quirk = access_quirk();
4461 if ($quirk[0] eq 'backports') {
4462 local $isuite = $quirk[2];
4464 canonicalise_suite();
4465 push @vsns, archive_query('archive_query');
4468 @vsns = map { $_->[0] } @vsns;
4469 @vsns = sort { -version_compare($a, $b) } @vsns;
4470 $changes_since_version = $vsns[0];
4471 progress "changelog will contain changes since $vsns[0]";
4473 $changes_since_version = '_';
4474 progress "package seems new, not specifying -v<version>";
4477 if ($changes_since_version ne '_') {
4478 return ("-v$changes_since_version");
4484 sub changesopts () {
4485 return (changesopts_initial(), changesopts_version());
4488 sub massage_dbp_args ($;$) {
4489 my ($cmd,$xargs) = @_;
4492 # - if we're going to split the source build out so we can
4493 # do strange things to it, massage the arguments to dpkg-buildpackage
4494 # so that the main build doessn't build source (or add an argument
4495 # to stop it building source by default).
4497 # - add -nc to stop dpkg-source cleaning the source tree,
4498 # unless we're not doing a split build and want dpkg-source
4499 # as cleanmode, in which case we can do nothing
4502 # 0 - source will NOT need to be built separately by caller
4503 # +1 - source will need to be built separately by caller
4504 # +2 - source will need to be built separately by caller AND
4505 # dpkg-buildpackage should not in fact be run at all!
4506 debugcmd '#massaging#', @$cmd if $debuglevel>1;
4507 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
4508 if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
4509 $clean_using_builder = 1;
4512 # -nc has the side effect of specifying -b if nothing else specified
4513 # and some combinations of -S, -b, et al, are errors, rather than
4514 # later simply overriding earlie. So we need to:
4515 # - search the command line for these options
4516 # - pick the last one
4517 # - perhaps add our own as a default
4518 # - perhaps adjust it to the corresponding non-source-building version
4520 foreach my $l ($cmd, $xargs) {
4522 @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
4525 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
4527 if ($need_split_build_invocation) {
4528 printdebug "massage split $dmode.\n";
4529 $r = $dmode =~ m/[S]/ ? +2 :
4530 $dmode =~ y/gGF/ABb/ ? +1 :
4531 $dmode =~ m/[ABb]/ ? 0 :
4534 printdebug "massage done $r $dmode.\n";
4536 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
4541 my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
4542 my $wantsrc = massage_dbp_args \@dbp;
4549 push @dbp, changesopts_version();
4550 maybe_apply_patches_dirtily();
4551 runcmd_ordryrun_local @dbp;
4553 maybe_unapply_patches_again();
4554 printdone "build successful\n";
4558 my @dbp = @dpkgbuildpackage;
4560 my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
4563 if (length executable_on_path('git-buildpackage')) {
4564 @cmd = qw(git-buildpackage);
4566 @cmd = qw(gbp buildpackage);
4568 push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
4573 if (!$clean_using_builder) {
4574 push @cmd, '--git-cleaner=true';
4578 maybe_unapply_patches_again();
4580 unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
4581 canonicalise_suite();
4582 push @cmd, "--git-debian-branch=".lbranch();
4584 push @cmd, changesopts();
4585 runcmd_ordryrun_local @cmd, @ARGV;
4587 printdone "build successful\n";
4589 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
4592 my $our_cleanmode = $cleanmode;
4593 if ($need_split_build_invocation) {
4594 # Pretend that clean is being done some other way. This
4595 # forces us not to try to use dpkg-buildpackage to clean and
4596 # build source all in one go; and instead we run dpkg-source
4597 # (and build_prep() will do the clean since $clean_using_builder
4599 $our_cleanmode = 'ELSEWHERE';
4601 if ($our_cleanmode =~ m/^dpkg-source/) {
4602 # dpkg-source invocation (below) will clean, so build_prep shouldn't
4603 $clean_using_builder = 1;
4606 $sourcechanges = changespat $version,'source';
4608 unlink "../$sourcechanges" or $!==ENOENT
4609 or fail "remove $sourcechanges: $!";
4611 $dscfn = dscfn($version);
4612 if ($our_cleanmode eq 'dpkg-source') {
4613 maybe_apply_patches_dirtily();
4614 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
4616 } elsif ($our_cleanmode eq 'dpkg-source-d') {
4617 maybe_apply_patches_dirtily();
4618 runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
4621 my @cmd = (@dpkgsource, qw(-b --));
4624 runcmd_ordryrun_local @cmd, "work";
4625 my @udfiles = <${package}_*>;
4626 changedir "../../..";
4627 foreach my $f (@udfiles) {
4628 printdebug "source copy, found $f\n";
4631 ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
4632 $f eq srcfn($version, $&));
4633 printdebug "source copy, found $f - renaming\n";
4634 rename "$ud/$f", "../$f" or $!==ENOENT
4635 or fail "put in place new source file ($f): $!";
4638 my $pwd = must_getcwd();
4639 my $leafdir = basename $pwd;
4641 runcmd_ordryrun_local @cmd, $leafdir;
4644 runcmd_ordryrun_local qw(sh -ec),
4645 'exec >$1; shift; exec "$@"','x',
4646 "../$sourcechanges",
4647 @dpkggenchanges, qw(-S), changesopts();
4651 sub cmd_build_source {
4652 badusage "build-source takes no additional arguments" if @ARGV;
4654 maybe_unapply_patches_again();
4655 printdone "source built, results in $dscfn and $sourcechanges";
4660 my $pat = changespat $version;
4662 my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
4663 @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
4664 fail "changes files other than source matching $pat".
4665 " already present (@unwanted);".
4666 " building would result in ambiguity about the intended results"
4669 my $wasdir = must_getcwd();
4672 stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
4673 stat_exists $sourcechanges
4674 or fail "$sourcechanges (in parent directory): $!";
4676 runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
4677 my @changesfiles = glob $pat;
4678 @changesfiles = sort {
4679 ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
4682 fail "wrong number of different changes files (@changesfiles)"
4683 unless @changesfiles==2;
4684 my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
4685 foreach my $l (split /\n/, getfield $binchanges, 'Files') {
4686 fail "$l found in binaries changes file $binchanges"
4689 runcmd_ordryrun_local @mergechanges, @changesfiles;
4690 my $multichanges = changespat $version,'multi';
4692 stat_exists $multichanges or fail "$multichanges: $!";
4693 foreach my $cf (glob $pat) {
4694 next if $cf eq $multichanges;
4695 rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
4699 maybe_unapply_patches_again();
4700 printdone "build successful, results in $multichanges\n" or die $!;
4703 sub cmd_quilt_fixup {
4704 badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
4705 my $clogp = parsechangelog();
4706 $version = getfield $clogp, 'Version';
4707 $package = getfield $clogp, 'Source';
4710 build_maybe_quilt_fixup();
4713 sub cmd_archive_api_query {
4714 badusage "need only 1 subpath argument" unless @ARGV==1;
4715 my ($subpath) = @ARGV;
4716 my @cmd = archive_api_query_cmd($subpath);
4718 exec @cmd or fail "exec curl: $!\n";
4721 sub cmd_clone_dgit_repos_server {
4722 badusage "need destination argument" unless @ARGV==1;
4723 my ($destdir) = @ARGV;
4724 $package = '_dgit-repos-server';
4725 my @cmd = (@git, qw(clone), access_giturl(), $destdir);
4727 exec @cmd or fail "exec git clone: $!\n";
4730 sub cmd_setup_mergechangelogs {
4731 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4732 setup_mergechangelogs(1);
4735 sub cmd_setup_useremail {
4736 badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
4740 sub cmd_setup_new_tree {
4741 badusage "no arguments allowed to dgit setup-tree" if @ARGV;
4745 #---------- argument parsing and main program ----------
4748 print "dgit version $our_version\n" or die $!;
4752 our (%valopts_long, %valopts_short);
4755 sub defvalopt ($$$$) {
4756 my ($long,$short,$val_re,$how) = @_;
4757 my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
4758 $valopts_long{$long} = $oi;
4759 $valopts_short{$short} = $oi;
4760 # $how subref should:
4761 # do whatever assignemnt or thing it likes with $_[0]
4762 # if the option should not be passed on to remote, @rvalopts=()
4763 # or $how can be a scalar ref, meaning simply assign the value
4766 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
4767 defvalopt '--distro', '-d', '.+', \$idistro;
4768 defvalopt '', '-k', '.+', \$keyid;
4769 defvalopt '--existing-package','', '.*', \$existing_package;
4770 defvalopt '--build-products-dir','','.*', \$buildproductsdir;
4771 defvalopt '--clean', '', $cleanmode_re, \$cleanmode;
4772 defvalopt '--quilt', '', $quilt_modes_re, \$quilt_mode;
4774 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
4776 defvalopt '', '-C', '.+', sub {
4777 ($changesfile) = (@_);
4778 if ($changesfile =~ s#^(.*)/##) {
4779 $buildproductsdir = $1;
4783 defvalopt '--initiator-tempdir','','.*', sub {
4784 ($initiator_tempdir) = (@_);
4785 $initiator_tempdir =~ m#^/# or
4786 badusage "--initiator-tempdir must be used specify an".
4787 " absolute, not relative, directory."
4793 if (defined $ENV{'DGIT_SSH'}) {
4794 @ssh = string_to_ssh $ENV{'DGIT_SSH'};
4795 } elsif (defined $ENV{'GIT_SSH'}) {
4796 @ssh = ($ENV{'GIT_SSH'});
4804 if (!defined $val) {
4805 badusage "$what needs a value" unless @ARGV;
4807 push @rvalopts, $val;
4809 badusage "bad value \`$val' for $what" unless
4810 $val =~ m/^$oi->{Re}$(?!\n)/s;
4811 my $how = $oi->{How};
4812 if (ref($how) eq 'SCALAR') {
4817 push @ropts, @rvalopts;
4821 last unless $ARGV[0] =~ m/^-/;
4825 if (m/^--dry-run$/) {
4828 } elsif (m/^--damp-run$/) {
4831 } elsif (m/^--no-sign$/) {
4834 } elsif (m/^--help$/) {
4836 } elsif (m/^--version$/) {
4838 } elsif (m/^--new$/) {
4841 } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
4842 ($om = $opts_opt_map{$1}) &&
4846 } elsif (m/^--([-0-9a-z]+):(.*)/s &&
4847 !$opts_opt_cmdonly{$1} &&
4848 ($om = $opts_opt_map{$1})) {
4851 } elsif (m/^--ignore-dirty$/s) {
4854 } elsif (m/^--no-quilt-fixup$/s) {
4856 $quilt_mode = 'nocheck';
4857 } elsif (m/^--no-rm-on-error$/s) {
4860 } elsif (m/^--overwrite$/s) {
4862 $overwrite_version = '';
4863 } elsif (m/^--overwrite=(.+)$/s) {
4865 $overwrite_version = $1;
4866 } elsif (m/^--(no-)?rm-old-changes$/s) {
4869 } elsif (m/^--deliberately-($deliberately_re)$/s) {
4871 push @deliberatelies, $&;
4872 } elsif (m/^--dgit-tag-format=(old|new)$/s) {
4873 # undocumented, for testing
4875 $tagformat_want = [ $1, 'command line', 1 ];
4876 # 1 menas overrides distro configuration
4877 } elsif (m/^--always-split-source-build$/s) {
4878 # undocumented, for testing
4880 $need_split_build_invocation = 1;
4881 } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
4882 $val = $2 ? $' : undef; #';
4883 $valopt->($oi->{Long});
4885 badusage "unknown long option \`$_'";
4892 } elsif (s/^-L/-/) {
4895 } elsif (s/^-h/-/) {
4897 } elsif (s/^-D/-/) {
4901 } elsif (s/^-N/-/) {
4906 push @changesopts, $_;
4908 } elsif (s/^-wn$//s) {
4910 $cleanmode = 'none';
4911 } elsif (s/^-wg$//s) {
4914 } elsif (s/^-wgf$//s) {
4916 $cleanmode = 'git-ff';
4917 } elsif (s/^-wd$//s) {
4919 $cleanmode = 'dpkg-source';
4920 } elsif (s/^-wdd$//s) {
4922 $cleanmode = 'dpkg-source-d';
4923 } elsif (s/^-wc$//s) {
4925 $cleanmode = 'check';
4926 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
4928 $val = undef unless length $val;
4929 $valopt->($oi->{Short});
4932 badusage "unknown short option \`$_'";
4939 sub finalise_opts_opts () {
4940 foreach my $k (keys %opts_opt_map) {
4941 my $om = $opts_opt_map{$k};
4943 my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
4945 badcfg "cannot set command for $k"
4946 unless length $om->[0];
4950 foreach my $c (access_cfg_cfgs("opts-$k")) {
4951 my $vl = $gitcfg{$c};
4952 printdebug "CL $c ",
4953 ($vl ? join " ", map { shellquote } @$vl : ""),
4954 "\n" if $debuglevel >= 4;
4956 badcfg "cannot configure options for $k"
4957 if $opts_opt_cmdonly{$k};
4958 my $insertpos = $opts_cfg_insertpos{$k};
4959 @$om = ( @$om[0..$insertpos-1],
4961 @$om[$insertpos..$#$om] );
4966 if ($ENV{$fakeeditorenv}) {
4968 quilt_fixup_editor();
4974 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
4975 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
4976 if $dryrun_level == 1;
4978 print STDERR $helpmsg or die $!;
4981 my $cmd = shift @ARGV;
4984 if (!defined $rmchanges) {
4985 local $access_forpush;
4986 $rmchanges = access_cfg_bool(0, 'rm-old-changes');
4989 if (!defined $quilt_mode) {
4990 local $access_forpush;
4991 $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
4992 // access_cfg('quilt-mode', 'RETURN-UNDEF')
4994 $quilt_mode =~ m/^($quilt_modes_re)$/
4995 or badcfg "unknown quilt-mode \`$quilt_mode'";
4999 $need_split_build_invocation ||= quiltmode_splitbrain();
5001 if (!defined $cleanmode) {
5002 local $access_forpush;
5003 $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
5004 $cleanmode //= 'dpkg-source';
5006 badcfg "unknown clean-mode \`$cleanmode'" unless
5007 $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
5010 my $fn = ${*::}{"cmd_$cmd"};
5011 $fn or badusage "unknown operation $cmd";