our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
our $protovsn;
-our $isuite = 'unstable';
+our $isuite;
our $idistro;
our $package;
our @ropts;
our $overwrite_version; # undef: not specified; '': check changelog
our $quilt_mode;
our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
+our $dodep14tag;
our $split_brain_save;
our $we_are_responder;
+our $we_are_initiator;
our $initiator_tempdir;
our $patches_applied_dirtily = 00;
our $tagformat_want;
our $tagformat;
our $tagformatfn;
+our $chase_dsc_distro=1;
our %forceopts = map { $_=>0 }
qw(unrepresentable unsupported-source-format
our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
our $splitbraincache = 'dgit-intern/quilt-cache';
+our $rewritemap = 'dgit-rewrite/map';
our (@git) = qw(git);
our (@dget) = qw(dget);
scalar @{ $opts_opt_map{$_} }
} keys %opts_opt_map;
-sub finalise_opts_opts();
+sub parseopts_late_defaults();
our $keyid;
END {
local ($@, $?);
+ return unless forkcheck_mainprocess();
print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
}
sub debiantag_maintview ($$) {
my ($v,$distro) = @_;
- $v =~ y/~:/_%/;
- return "$distro/$v";
+ return "$distro/".dep14_version_mangle $v;
}
sub madformat ($) { $_[0] eq '3.0 (quilt)' }
sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
sub rrref () { return server_ref($csuite); }
-sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
-sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
-
-# We fetch some parts of lrfetchrefs/*. Ideally we delete these
-# locally fetched refs because they have unhelpful names and clutter
-# up gitk etc. So we track whether we have "used up" head ref (ie,
-# whether we have made another local ref which refers to this object).
-#
-# (If we deleted them unconditionally, then we might end up
-# re-fetching the same git objects each time dgit fetch was run.)
-#
-# So, leach use of lrfetchrefs needs to be accompanied by arrangements
-# in git_fetch_us to fetch the refs in question, and possibly a call
-# to lrfetchref_used.
-
-our (%lrfetchrefs_f, %lrfetchrefs_d);
-# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
-
-sub lrfetchref_used ($) {
- my ($fullrefname) = @_;
- my $objid = $lrfetchrefs_f{$fullrefname};
- $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
-}
-
sub stripepoch ($) {
my ($vsn) = @_;
$vsn =~ s/^\d+\://;
our @end;
END {
local ($?);
+ return unless forkcheck_mainprocess();
foreach my $f (@end) {
eval { $f->(); };
print STDERR "$us: cleanup: $@" if length $@;
our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
our %defcfg = ('dgit.default.distro' => 'debian',
+ 'dgit.default.default-suite' => 'unstable',
+ 'dgit.default.old-dsc-distro' => 'debian',
'dgit-suite.*-security.distro' => 'debian-security',
'dgit.default.username' => '',
'dgit.default.archive-query-default-component' => 'main',
'dgit.default.sshpsql-dbname' => 'service=projectb',
'dgit.default.aptget-components' => 'main',
'dgit.default.dgit-tag-format' => 'new,old,maint',
+ 'dgit.dsc-url-proto-ok.http' => 'true',
+ 'dgit.dsc-url-proto-ok.https' => 'true',
+ 'dgit.dsc-url-proto-ok.git' => 'true',
+ 'dgit.default.dsc-url-proto-ok' => 'false',
# old means "repo server accepts pushes with old dgit tags"
# new means "repo server accepts pushes with new dgit tags"
# maint means "repo server accepts split brain pushes"
my ($c) = @_;
foreach my $src (@gitcfgsources) {
my $l = $gitcfgs{$src}{$c};
- printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
+ croak "$l $c" if $l && !ref $l;
+ printdebug"C $c ".(defined $l ?
+ join " ", map { messagequote "'$_'" } @$l :
+ "undef")."\n"
if $debuglevel >= 4;
$l or next;
@$l==1 or badcfg "multiple values for $c".
sub cfg {
foreach my $c (@_) {
return undef if $c =~ /RETURN-UNDEF/;
+ printdebug "C? $c\n" if $debuglevel >= 5;
my $v = git_get_config($c);
return $v if defined $v;
my $dv = $defcfg{$c};
- return $dv if defined $dv;
+ if (defined $dv) {
+ printdebug "CD $c $dv\n" if $debuglevel >= 4;
+ return $dv;
+ }
}
badcfg "need value for one of: @_\n".
"$us: distro or suite appears not to be (properly) supported";
}
-sub access_basedistro () {
+sub access_basedistro__noalias () {
if (defined $idistro) {
return $idistro;
} else {
}
}
+sub access_basedistro () {
+ my $noalias = access_basedistro__noalias();
+ my $canon = cfg("dgit-distro.$noalias.alias-canon",'RETURN-UNDEF');
+ return $canon // $noalias;
+}
+
sub access_nomdistro () {
my $base = access_basedistro();
- return cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
+ my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
+ $r =~ m/^$distro_re$/ or badcfg
+ "bad syntax for (nominal) distro \`$r' (does not match /^$distro_re$/)";
+ return $r;
}
sub access_quirk () {
Push failed, before we got started.
You can retry the push, after fixing the problem, if you like.
END
- finalise_opts_opts();
+ parseopts_late_defaults();
}
sub notpushing () {
- finalise_opts_opts();
+ parseopts_late_defaults();
}
sub supplementary_message ($) {
split /\,/, access_cfg('dgit-tag-format');
}
+sub access_cfg_tagformats_can_splitbrain () {
+ my %y = map { $_ => 1 } access_cfg_tagformats;
+ foreach my $needtf (qw(new maint)) {
+ next if $y{$needtf};
+ return 0;
+ }
+ return 1;
+}
+
sub need_tagformat ($$) {
my ($fmt, $why) = @_;
fail "need to use tag format $fmt ($why) but also need".
}
our ($dsc_hash,$lastpush_mergeinput);
+our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
our $ud = '.git/dgit/unpack';
return git_write_tree();
}
-sub remove_stray_gits () {
+sub remove_stray_gits ($) {
+ my ($what) = @_;
my @gitscmd = qw(find -name .git -prune -print0);
debugcmd "|",@gitscmd;
open GITS, "-|", @gitscmd or die $!;
local $/="\0";
while (<GITS>) {
chomp or die;
- print STDERR "$us: warning: removing from source package: ",
+ print STDERR "$us: warning: removing from $what: ",
(messagequote $_), "\n";
rmtree $_;
}
$!=0; $?=0; close GITS or failedcmd @gitscmd;
}
-sub mktree_in_ud_from_only_subdir (;$) {
- my ($raw) = @_;
+sub mktree_in_ud_from_only_subdir ($;$) {
+ my ($what,$raw) = @_;
# changes into the subdir
my (@dirs) = <*/.>;
my $dir = $1;
changedir $dir;
- remove_stray_gits();
+ remove_stray_gits($what);
mktree_in_ud_here();
if (!$raw) {
my ($format, $fopts) = get_source_format();
}
}
- runcmd @git, qw(add -Af);
- my $tree=git_write_tree();
+ my $tree=git_add_write_tree();
return ($tree,$dir);
}
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
+ my $upper_f = "../../../../$f";
+
+ printdebug "considering reusing $f: ";
+
+ if (link_ltarget "$upper_f,fetch", $f) {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail "accessing ../$f,fetch: $!";
+ } elsif (link_ltarget $upper_f, $f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($!) "),
+ $! != ENOENT) {
+ fail "accessing ../$f: $!";
+ } else {
+ printdebug "absent.\n";
+ }
- printdebug "considering linking $f: ";
-
- link_ltarget "../../../../$f", $f
- or ((printdebug "($!) "), 0)
- or $!==&ENOENT
- or die "$f $!";
-
- printdebug "linked.\n";
-
- complete_file_from_dsc('.', $fi)
+ my $refetched;
+ complete_file_from_dsc('.', $fi, \$refetched)
or next;
- if (is_orig_file_in_dsc($f, \@dfi)) {
- link $f, "../../../../$f"
- or $!==&EEXIST
- or die "$f $!";
+ printdebug "considering saving $f: ";
+
+ if (link $f, $upper_f) {
+ printdebug "linked.\n";
+ } elsif ((printdebug "($!) "),
+ $! != EEXIST) {
+ fail "saving ../$f: $!";
+ } elsif (!$refetched) {
+ printdebug "no need.\n";
+ } elsif (link $f, "$upper_f,fetch") {
+ printdebug "linked (using ...,fetch).\n";
+ } elsif ((printdebug "($!) "),
+ $! != EEXIST) {
+ fail "saving ../$f,fetch: $!";
+ } else {
+ printdebug "cannot.\n";
}
}
runcmd qw(chmod -R +rwX _unpack-tar);
changedir "_unpack-tar";
- remove_stray_gits();
+ remove_stray_gits($f);
mktree_in_ud_here();
my ($tree) = git_add_write_tree();
push @cmd, qw(-x --), $dscfn;
runcmd @cmd;
- my ($tree,$dir) = mktree_in_ud_from_only_subdir();
+ my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
if (madformat $dsc->{format}) {
check_for_vendor_patches();
}
my @pcmd = qw(dpkg-source --before-build .);
runcmd shell_cmd 'exec >/dev/null', @pcmd;
rmtree '.pc';
- runcmd @git, qw(add -Af);
- $dappliedtree = git_write_tree();
+ $dappliedtree = git_add_write_tree();
}
my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
my $path = $ENV{PATH} or die;
foreach my $use_absurd (qw(0 1)) {
+ runcmd @git, qw(checkout -q unpa);
+ runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
local $ENV{PATH} = $path;
if ($use_absurd) {
chomp $@;
die "only absurd git-apply!\n" if !$use_absurd
&& forceing [qw(import-gitapply-absurd)];
- local $ENV{PATH} = $path if $use_absurd;
+ local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
+ local $ENV{PATH} = $path if $use_absurd;
my @showcmd = (gbp_pq, qw(import));
my @realcmd = shell_cmd
- 'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
+ 'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
debugcmd "+",@realcmd;
if (system @realcmd) {
die +(shellquote @showcmd).
return @output;
}
-sub complete_file_from_dsc ($$) {
- our ($dstdir, $fi) = @_;
- # Ensures that we have, in $dir, the file $fi, with the correct
+sub complete_file_from_dsc ($$;$) {
+ our ($dstdir, $fi, $refetched) = @_;
+ # Ensures that we have, in $dstdir, the file $fi, with the correct
# contents. (Downloading it from alongside $dscurl if necessary.)
+ # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
+ # and will set $$refetched=1 if it did so (or tried to).
my $f = $fi->{Filename};
my $tf = "$dstdir/$f";
my $downloaded = 0;
+ my $got;
+ my $checkhash = sub {
+ open F, "<", "$tf" or die "$tf: $!";
+ $fi->{Digester}->reset();
+ $fi->{Digester}->addfile(*F);
+ F->error and die $!;
+ my $got = $fi->{Digester}->hexdigest();
+ return $got eq $fi->{Hash};
+ };
+
if (stat_exists $tf) {
- progress "using existing $f";
+ if ($checkhash->()) {
+ progress "using existing $f";
+ return 1;
+ }
+ if (!$refetched) {
+ fail "file $f has hash $got but .dsc".
+ " demands hash $fi->{Hash} ".
+ "(perhaps you should delete this file?)";
+ }
+ progress "need to fetch correct version of $f";
+ unlink $tf or die "$tf $!";
+ $$refetched = 1;
} else {
printdebug "$tf does not exist, need to fetch\n";
- my $furl = $dscurl;
- $furl =~ s{/[^/]+$}{};
- $furl .= "/$f";
- die "$f ?" unless $f =~ m/^\Q${package}\E_/;
- die "$f ?" if $f =~ m#/#;
- runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
- return 0 if !act_local();
- $downloaded = 1;
- }
-
- open F, "<", "$tf" or die "$tf: $!";
- $fi->{Digester}->reset();
- $fi->{Digester}->addfile(*F);
- F->error and die $!;
- my $got = $fi->{Digester}->hexdigest();
- $got eq $fi->{Hash} or
+ }
+
+ my $furl = $dscurl;
+ $furl =~ s{/[^/]+$}{};
+ $furl .= "/$f";
+ die "$f ?" unless $f =~ m/^\Q${package}\E_/;
+ die "$f ?" if $f =~ m#/#;
+ runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
+ return 0 if !act_local();
+
+ $checkhash->() or
fail "file $f has hash $got but .dsc".
" demands hash $fi->{Hash} ".
- ($downloaded ? "(got wrong file from archive!)"
- : "(perhaps you should delete this file?)");
+ "(got wrong file from archive!)";
return 1;
}
}
}
-sub git_fetch_us () {
- # Want to fetch only what we are going to use, unless
- # deliberately-not-ff, in which case we must fetch everything.
+#---------- git fetch ----------
- my @specs = deliberately_not_fast_forward ? qw(tags/*) :
- map { "tags/$_" }
- (quiltmode_splitbrain
- ? (map { $_->('*',access_nomdistro) }
- \&debiantag_new, \&debiantag_maintview)
- : debiantags('*',access_nomdistro));
- push @specs, server_branch($csuite);
- push @specs, qw(heads/*) if deliberately_not_fast_forward;
+sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
+sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
+
+# We fetch some parts of lrfetchrefs/*. Ideally we delete these
+# locally fetched refs because they have unhelpful names and clutter
+# up gitk etc. So we track whether we have "used up" head ref (ie,
+# whether we have made another local ref which refers to this object).
+#
+# (If we deleted them unconditionally, then we might end up
+# re-fetching the same git objects each time dgit fetch was run.)
+#
+# So, each use of lrfetchrefs needs to be accompanied by arrangements
+# in git_fetch_us to fetch the refs in question, and possibly a call
+# to lrfetchref_used.
+
+our (%lrfetchrefs_f, %lrfetchrefs_d);
+# $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
+
+sub lrfetchref_used ($) {
+ my ($fullrefname) = @_;
+ my $objid = $lrfetchrefs_f{$fullrefname};
+ $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
+}
+
+sub git_lrfetch_sane {
+ my ($supplementary, @specs) = @_;
+ # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
+ # at least as regards @specs. Also leave the results in
+ # %lrfetchrefs_f, and arrange for lrfetchref_used to be
+ # able to clean these up.
+ #
+ # With $supplementary==1, @specs must not contain wildcards
+ # and we add to our previous fetches (non-atomically).
# This is rather miserable:
# When git fetch --prune is passed a fetchspec ending with a *,
# git fetch to try to generate it. If we don't manage to generate
# the target state, we try again.
- printdebug "git_fetch_us specs @specs\n";
+ my $url = access_giturl();
+
+ printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
my $specre = join '|', map {
my $x = $_;
$x =~ s/\W/\\$&/g;
- $x =~ s/\\\*$/.*/;
+ my $wildcard = $x =~ s/\\\*$/.*/;
+ die if $wildcard && $supplementary;
"(?:refs/$x)";
} @specs;
- printdebug "git_fetch_us specre=$specre\n";
+ printdebug "git_lrfetch_sane specre=$specre\n";
my $wanted_rref = sub {
local ($_) = @_;
- return m/^(?:$specre)$/o;
+ return m/^(?:$specre)$/;
};
my $fetch_iteration = 0;
FETCH_ITERATION:
for (;;) {
- printdebug "git_fetch_us iteration $fetch_iteration\n";
+ printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
if (++$fetch_iteration > 10) {
fail "too many iterations trying to get sane fetch!";
}
my @look = map { "refs/$_" } @specs;
- my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
+ my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
debugcmd "|",@lcmd;
my %wantr;
"+refs/$_:".lrfetchrefs."/$_";
} @specs;
- printdebug "git_fetch_us fspecs @fspecs\n";
+ printdebug "git_lrfetch_sane fspecs @fspecs\n";
- my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
- runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
- @fspecs;
+ my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
+ runcmd_ordryrun_local @fcmd if @fspecs;
- %lrfetchrefs_f = ();
+ if (!$supplementary) {
+ %lrfetchrefs_f = ();
+ }
my %objgot;
git_for_each_ref(lrfetchrefs, sub {
$objgot{$objid} = 1;
});
+ if ($supplementary) {
+ last;
+ }
+
foreach my $lrefname (sort keys %lrfetchrefs_f) {
my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
if (!exists $wantr{$rrefname}) {
}
last;
}
- printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
+
+ if (defined $csuite) {
+ printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
+ git_for_each_ref("refs/dgit-fetch/$csuite", sub {
+ my ($objid,$objtype,$lrefname,$reftail) = @_;
+ next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
+ runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
+ });
+ }
+
+ printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
Dumper(\%lrfetchrefs_f);
+}
+
+sub git_fetch_us () {
+ # Want to fetch only what we are going to use, unless
+ # deliberately-not-ff, in which case we must fetch everything.
+
+ my @specs = deliberately_not_fast_forward ? qw(tags/*) :
+ map { "tags/$_" }
+ (quiltmode_splitbrain
+ ? (map { $_->('*',access_nomdistro) }
+ \&debiantag_new, \&debiantag_maintview)
+ : debiantags('*',access_nomdistro));
+ push @specs, server_branch($csuite);
+ push @specs, $rewritemap;
+ push @specs, qw(heads/*) if deliberately_not_fast_forward;
+
+ git_lrfetch_sane 0, @specs;
my %here;
my @tagpats = debiantags('*',access_nomdistro);
} elsif ($here{$lref} eq $objid) {
lrfetchref_used $fullrefname;
} else {
- print STDERR \
- "Not updateting $lref from $here{$lref} to $objid.\n";
+ print STDERR
+ "Not updating $lref from $here{$lref} to $objid.\n";
}
});
}
+#---------- dsc and archive handling ----------
+
sub mergeinfo_getclogp ($) {
# Ensures thit $mi->{Clogp} exists and returns it
my ($mi) = @_;
}
}
+sub parse_dsc_field_def_dsc_distro () {
+ $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
+ dgit.default.distro);
+}
+
+sub parse_dsc_field ($$) {
+ my ($dsc, $what) = @_;
+ my $f;
+ foreach my $field (@ourdscfield) {
+ $f = $dsc->{$field};
+ last if defined $f;
+ }
+
+ if (!defined $f) {
+ progress "$what: NO git hash";
+ parse_dsc_field_def_dsc_distro();
+ } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
+ = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
+ progress "$what: specified git info ($dsc_distro)";
+ $dsc_hint_tag = [ $dsc_hint_tag ];
+ } elsif ($f =~ m/^\w+\s*$/) {
+ $dsc_hash = $&;
+ parse_dsc_field_def_dsc_distro();
+ $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
+ $dsc_distro ];
+ progress "$what: specified git hash";
+ } else {
+ fail "$what: invalid Dgit info";
+ }
+}
+
+sub resolve_dsc_field_commit ($$) {
+ my ($already_distro, $already_mapref) = @_;
+
+ return unless defined $dsc_hash;
+
+ my $mapref =
+ defined $already_mapref &&
+ ($already_distro eq $dsc_distro || !$chase_dsc_distro)
+ ? $already_mapref : undef;
+
+ my $do_fetch;
+ $do_fetch = sub {
+ my ($what, @fetch) = @_;
+
+ local $idistro = $dsc_distro;
+ my $lrf = lrfetchrefs;
+
+ if (!$chase_dsc_distro) {
+ progress
+ "not chasing .dsc distro $dsc_distro: not fetching $what";
+ return 0;
+ }
+
+ progress
+ ".dsc names distro $dsc_distro: fetching $what";
+
+ my $url = access_giturl();
+ if (!defined $url) {
+ defined $dsc_hint_url or fail <<END;
+.dsc Dgit metadata is in context of distro $dsc_distro
+for which we have no configured url and .dsc provides no hint
+END
+ my $proto =
+ $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
+ $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
+ parse_cfg_bool "dsc-url-proto-ok", 'false',
+ cfg("dgit.dsc-url-proto-ok.$proto",
+ "dgit.default.dsc-url-proto-ok")
+ or fail <<END;
+.dsc Dgit metadata is in context of distro $dsc_distro
+for which we have no configured url;
+.dsc provices hinted url with protocol $proto which is unsafe.
+(can be overridden by config - consult documentation)
+END
+ $url = $dsc_hint_url;
+ }
+
+ git_lrfetch_sane 1, @fetch;
+
+ return $lrf;
+ };
+
+ my $rewrite_enable = do {
+ local $idistro = $dsc_distro;
+ access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
+ };
+
+ if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
+ if (!defined $mapref) {
+ my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
+ $mapref = $lrf.'/'.$rewritemap;
+ }
+ my $rewritemapdata = git_cat_file $mapref.':map';
+ if (defined $rewritemapdata
+ && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
+ progress
+ "server's git history rewrite map contains a relevant entry!";
+
+ $dsc_hash = $1;
+ if (defined $dsc_hash) {
+ progress "using rewritten git hash in place of .dsc value";
+ } else {
+ progress "server data says .dsc hash is to be disregarded";
+ }
+ }
+ }
+
+ if (!defined git_cat_file $dsc_hash) {
+ my @tags = map { "tags/".$_ } @$dsc_hint_tag;
+ my $lrf = $do_fetch->("additional commits", @tags) &&
+ defined git_cat_file $dsc_hash
+ or fail <<END;
+.dsc Dgit metadata requires commit $dsc_hash
+but we could not obtain that object anywhere.
+END
+ foreach my $t (@tags) {
+ my $fullrefname = $lrf.'/'.$t;
+# print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
+ next unless $lrfetchrefs_f{$fullrefname};
+ next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
+ lrfetchref_used $fullrefname;
+ }
+ }
+}
+
sub fetch_from_archive () {
ensure_setup_existing_tree();
get_archive_dsc();
if ($dsc) {
- foreach my $field (@ourdscfield) {
- $dsc_hash = $dsc->{$field};
- last if defined $dsc_hash;
- }
- if (defined $dsc_hash) {
- $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
- $dsc_hash = $&;
- progress "last upload to archive specified git hash";
- } else {
- progress "last upload to archive has NO git hash";
- }
+ parse_dsc_field($dsc, 'last upload to archive');
+ resolve_dsc_field_commit access_basedistro,
+ lrfetchrefs."/".$rewritemap
} else {
progress "no version available from the archive";
}
my $canonsuitefh = IO::File::new_tmpfile;
my $pid = fork // die $!;
if (!$pid) {
+ forkcheck_setup();
$isuite = $tsuite;
$us .= " [$isuite]";
$debugprefix .= " ";
runcmd qw(bash -ec), <<'END';
set -o pipefail
git ls-tree -r --name-only -z HEAD | \
- xargs -0r touch -r . --
+ xargs -0r touch -h -r . --
END
printdone "ready for work in $dstdir";
}
parent $dgitview
parent $archive_hash
author $authline
-commiter $authline
+committer $authline
$msg_msg
fail "-p specified $package but changelog specified $clogpackage"
unless $package eq $clogpackage;
my $cversion = getfield $clogp, 'Version';
- my $tag = debiantag($cversion, access_nomdistro);
- runcmd @git, qw(check-ref-format), $tag;
+
+ if (!$we_are_initiator) {
+ # rpush initiator can't do this because it doesn't have $isuite yet
+ my $tag = debiantag($cversion, access_nomdistro);
+ runcmd @git, qw(check-ref-format), $tag;
+ }
my $dscfn = dscfn($cversion);
TfSuffix => '-maintview',
View => 'maint',
};
- }
+ } elsif ($dodep14tag eq 'no' ? 0
+ : $dodep14tag eq 'want' ? access_cfg_tagformats_can_splitbrain
+ : $dodep14tag eq 'always'
+ ? (access_cfg_tagformats_can_splitbrain or fail <<END)
+--dep14tag-always (or equivalent in config) means server must support
+ both "new" and "maint" tag formats, but config says it doesn't.
+END
+ : die "$dodep14tag ?") {
+ push @tagwants, {
+ TagFn => \&debiantag_maintview,
+ Objid => $dgithead,
+ TfSuffix => '-dgit',
+ View => 'dgit',
+ };
+ };
foreach my $tw (@tagwants) {
$tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
$tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
die unless $tagwants->[0]{View} eq 'dgit';
- $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
+ my $declaredistro = access_nomdistro();
+ my $reader_giturl = do { local $access_forpush=0; access_giturl(); };
+ $dsc->{$ourdscfield[0]} = join " ",
+ $tagwants->[0]{Objid}, $declaredistro, $tagwants->[0]{Tag},
+ $reader_giturl;
$dsc->save("$dscfn.tmp") or die $!;
my $changes = parsecontrol($changesfile,$changesfilewhat);
# to control the "tagger" (b) we can do remote signing
my $authline = clogp_authline $clogp;
my $delibs = join(" ", "",@deliberatelies);
- my $declaredistro = access_nomdistro();
my $mktag = sub {
my ($tw) = @_;
prep_ud();
access_giturl(); # check that success is vaguely likely
+ rpush_handle_protovsn_bothends() if $we_are_initiator;
select_tagformat();
my $clogpfn = ".git/dgit/changelog.822.tmp";
my $dscpath = "$buildproductsdir/$dscfn";
stat_exists $dscpath or
- fail "looked for .dsc $dscfn, but $!;".
+ fail "looked for .dsc $dscpath, but $!;".
" maybe you forgot to build";
responder_send_file('dsc', $dscpath);
progress "checking that $dscfn corresponds to HEAD";
runcmd qw(dpkg-source -x --),
$dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
- my ($tree,$dir) = mktree_in_ud_from_only_subdir();
+ my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
check_for_vendor_patches() if madformat($dsc->{format});
changedir '../../../..';
my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
responder_send_file('changes',$changesfile);
responder_send_command("param head $dgithead");
responder_send_command("param csuite $csuite");
+ responder_send_command("param isuite $isuite");
responder_send_command("param tagformat $tagformat");
if (defined $maintviewhead) {
die unless ($protovsn//4) >= 4;
runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
supplementary_message(<<'END');
-Push failed, after updating the remote git repository.
-If you want to try again, you must use a new version number.
+Push failed, while obtaining signatures on the .changes and .dsc.
+If it was just that the signature failed, you may try again by using
+debsign by hand to sign the changes
+ $changesfile
+and then dput to complete the upload.
+If you need to change the package, you must use a new version number.
END
if ($we_are_responder) {
my $dryrunsuffix = act_local() ? "" : ".tmp";
sub cmd_clone {
parseopts();
- notpushing();
my $dstdir;
badusage "-p is not allowed with clone; specify as argument instead"
if defined $package;
} else {
badusage "incorrect arguments to dgit clone";
}
- $dstdir ||= "$package";
+ notpushing();
+ $dstdir ||= "$package";
if (stat_exists $dstdir) {
fail "$dstdir already exists";
}
}
sub fetchpullargs () {
- notpushing();
if (!defined $package) {
my $sourcep = parsecontrol('debian/control','debian/control');
$package = getfield $sourcep, 'Source';
$isuite = branchsuite();
if (!$isuite) {
my $clogp = parsechangelog();
- $isuite = getfield $clogp, 'Distribution';
+ my $clogsuite = getfield $clogp, 'Distribution';
+ $isuite= $clogsuite if $clogsuite ne 'UNRELEASED';
}
} elsif (@ARGV==1) {
($isuite) = @ARGV;
} else {
badusage "incorrect arguments to dgit fetch or dgit pull";
}
+ notpushing();
}
sub cmd_fetch {
sub cmd_push {
parseopts();
- pushing();
badusage "-p is not allowed with dgit push" if defined $package;
check_not_dirty();
my $clogp = parsechangelog();
badusage "incorrect arguments to dgit push";
}
$isuite = getfield $clogp, 'Distribution';
+ pushing();
if ($new_package) {
local ($package) = $existing_package; # this is a hack
canonicalise_suite();
$we_are_responder = 1;
$us .= " (build host)";
- pushing();
-
open PI, "<&STDIN" or die $!;
open STDIN, "/dev/null" or die $!;
open PO, ">&STDOUT" or die $!;
unless defined $protovsn;
responder_send_command("dgit-remote-push-ready $protovsn");
- rpush_handle_protovsn_bothends();
changedir $dir;
&cmd_push;
}
}
}
-END { i_cleanup(); }
+END {
+ return unless forkcheck_mainprocess();
+ i_cleanup();
+}
sub i_method {
my ($base,$selector,@args) = @_;
}
sub cmd_rpush {
- pushing();
my $host = nextarg;
my $dir;
if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
my @cmd = (@ssh, $host, shellquote @rdgit);
debugcmd "+",@cmd;
+ $we_are_initiator=1;
+
if (defined $initiator_tempdir) {
rmtree $initiator_tempdir;
mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
$supplementary_message = '' unless $protovsn >= 3;
- fail "rpush negotiated protocol version $protovsn".
- " which does not support quilt mode $quilt_mode"
- if quiltmode_splitbrain;
-
- rpush_handle_protovsn_bothends();
for (;;) {
my ($icmd,$iargs) = initiator_expect {
m/^(\S+)(?: (.*))?$/;
sub i_resp_want ($) {
my ($keyword) = @_;
die "$keyword ?" if $i_wanted{$keyword}++;
+
+ defined $i_param{'csuite'} or badproto \*RO, "premature desire, no csuite";
+ $isuite = $i_param{'isuite'} // $i_param{'csuite'};
+ die unless $isuite =~ m/^$suite_re$/;
+
+ pushing();
+ rpush_handle_protovsn_bothends();
+
+ fail "rpush negotiated protocol version $protovsn".
+ " which does not support quilt mode $quilt_mode"
+ if quiltmode_splitbrain;
+
my @localpaths = i_method "i_want", $keyword;
printdebug "[[ $keyword @localpaths\n";
foreach my $localpath (@localpaths) {
local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
local $ENV{'VISUAL'} = $ENV{'EDITOR'};
local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
- runcmd @dpkgsource, qw(--commit .), $patchname;
+ runcmd @dpkgsource, qw(--commit --include-removal .), $patchname;
}
}
if ($unrepres) {
eval {
- die "deleted\n" unless $newmode =~ m/[^0]/;
- die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
- if ($oldmode =~ m/[^0]/) {
+ die "not a plain file\n"
+ unless $newmode =~ m/^10\d{4}$/ ||
+ $oldmode =~ m/^10\d{4}$/;
+ if ($oldmode =~ m/[^0]/ &&
+ $newmode =~ m/[^0]/) {
die "mode changed\n" if $oldmode ne $newmode;
} else {
- die "non-default mode\n" unless $newmode =~ m/^100644$/;
+ die "non-default mode\n"
+ unless $newmode =~ m/^100644$/ ||
+ $oldmode =~ m/^100644$/;
}
};
if ($@) {
local $/="\n"; chomp $@;
- push @$unrepres, [ $f, $@ ];
+ push @$unrepres, [ $f, "$@ ($oldmode->$newmode)" ];
}
}
check_for_vendor_patches();
if (quiltmode_splitbrain) {
- foreach my $needtf (qw(new maint)) {
- next if grep { $_ eq $needtf } access_cfg_tagformats;
- fail <<END
+ fail <<END unless access_cfg_tagformats_can_splitbrain;
quilt mode $quilt_mode requires split view so server needs to support
both "new" and "maint" tag formats, but config says it doesn't.
END
- }
}
my $clogp = parsechangelog();
changedir 'fake';
- remove_stray_gits();
+ remove_stray_gits("source package");
mktree_in_ud_here();
rmtree '.pc';
+ runcmd @git, qw(checkout -f), $headref, qw(-- debian);
my $unapplied=git_add_write_tree();
printdebug "fake orig tree object $unapplied\n";
sub build_prep_early () {
our $build_prep_early_done //= 0;
return if $build_prep_early_done++;
- notpushing();
badusage "-p is not allowed when building" if defined $package;
my $clogp = parsechangelog();
$isuite = getfield $clogp, 'Distribution';
$package = getfield $clogp, 'Source';
$version = getfield $clogp, 'Version';
+ notpushing();
check_not_dirty();
}
}
sub cmd_build {
+ build_prep_early();
my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
my $wantsrc = massage_dbp_args \@dbp;
if ($wantsrc > 0) {
sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
sub build_source {
+ build_prep_early();
my $our_cleanmode = $cleanmode;
if ($need_split_build_invocation) {
# Pretend that clean is being done some other way. This
}
sub cmd_build_source {
+ build_prep_early();
badusage "build-source takes no additional arguments" if @ARGV;
build_source();
maybe_unapply_patches_again();
sub cmd_quilt_fixup {
badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
- my $clogp = parsechangelog();
- $version = getfield $clogp, 'Version';
- $package = getfield $clogp, 'Source';
- check_not_dirty();
+ build_prep_early();
clean_tree();
build_maybe_quilt_fixup();
}
parse_dscdata();
- my $dgit_commit = $dsc->{$ourdscfield[0]};
- if (defined $dgit_commit &&
- !forceing [qw(import-dsc-with-dgit-field)]) {
- $dgit_commit =~ m/\w+/ or fail "invalid hash in .dsc";
+ $package = getfield $dsc, 'Source';
+
+ parse_dsc_field($dsc, "Dgit metadata in .dsc")
+ unless forceing [qw(import-dsc-with-dgit-field)];
+
+ if (defined $dsc_hash) {
progress "dgit: import-dsc of .dsc with Dgit field, using git hash";
+ resolve_dsc_field_commit undef, undef;
+ }
+ if (defined $dsc_hash) {
my @cmd = (qw(sh -ec),
- "echo $dgit_commit | git cat-file --batch-check");
+ "echo $dsc_hash | git cat-file --batch-check");
my $objgot = cmdoutput @cmd;
if ($objgot =~ m#^\w+ missing\b#) {
fail <<END
-.dsc contains Dgit field referring to object $dgit_commit
+.dsc contains Dgit field referring to object $dsc_hash
Your git tree does not have that object. Try `git fetch' from a
plausible server (browse.dgit.d.o? alioth?), and try the import-dsc again.
END
}
- if ($oldhash && !is_fast_fwd $oldhash, $dgit_commit) {
+ if ($oldhash && !is_fast_fwd $oldhash, $dsc_hash) {
if ($force > 0) {
progress "Not fast forward, forced update.";
} else {
- fail "Not fast forward to $dgit_commit";
+ fail "Not fast forward to $dsc_hash";
}
}
@cmd = (@git, qw(update-ref -m), "dgit import-dsc (Dgit): $info",
- $dstbranch, $dgit_commit);
+ $dstbranch, $dsc_hash);
runcmd @cmd;
progress "dgit: import-dsc updated git ref $dstbranch";
return 0;
END
if $oldhash && !$force;
- $package = getfield $dsc, 'Source';
+ notpushing();
+
my @dfi = dsc_files_info();
foreach my $fi (@dfi) {
my $f = $fi->{Filename};
$there .= "/$f";
symlink $there, $here or fail "symlink $there to $here: $!";
progress "made symlink $here -> $there";
- print STDERR Dumper($fi);
+# print STDERR Dumper($fi);
}
my @mergeinputs = generate_commits_from_dsc();
die unless @mergeinputs == 1;
progress "Import, merging.";
my $tree = cmdoutput @git, qw(rev-parse), "$newhash:";
my $version = getfield $dsc, 'Version';
+ my $clogp = commit_getclogp $newhash;
+ my $authline = clogp_authline $clogp;
$newhash = make_commit_text <<END;
tree $tree
parent $newhash
parent $oldhash
+author $authline
+committer $authline
Merge $package ($version) import into $dstbranch
END
badusage "need destination argument" unless @ARGV==1;
my ($destdir) = @ARGV;
$package = '_dgit-repos-server';
+ local $access_forpush = 0;
my @cmd = (@git, qw(clone), access_giturl(), $destdir);
debugcmd ">",@cmd;
exec @cmd or fail "exec git clone: $!\n";
}
+sub cmd_print_dgit_repos_server_source_url {
+ badusage "no arguments allowed to dgit print-dgit-repos-server-source-url"
+ if @ARGV;
+ $package = '_dgit-repos-server';
+ local $access_forpush = 0;
+ my $url = access_giturl();
+ print $url, "\n" or die $!;
+}
+
sub cmd_setup_mergechangelogs {
badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
setup_mergechangelogs(1);
}
sub cmd_setup_useremail {
- badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
+ badusage "no arguments allowed to dgit setup-useremail" if @ARGV;
setup_useremail(1);
}
}
our (%valopts_long, %valopts_short);
+our (%funcopts_long);
our @rvalopts;
+our (@modeopt_cfgs);
sub defvalopt ($$$$) {
my ($long,$short,$val_re,$how) = @_;
" absolute, not relative, directory."
};
+sub defoptmodes ($@) {
+ my ($varref, $cfgkey, $default, %optmap) = @_;
+ my %permit;
+ while (my ($opt,$val) = each %optmap) {
+ $funcopts_long{$opt} = sub { $$varref = $val; };
+ $permit{$val} = $val;
+ }
+ push @modeopt_cfgs, {
+ Var => $varref,
+ Key => $cfgkey,
+ Default => $default,
+ Vals => \%permit
+ };
+}
+
+defoptmodes \$dodep14tag, qw( dep14tag want
+ --dep14tag want
+ --no-dep14tag no
+ --always-dep14tag always );
+
sub parseopts () {
my $om;
} elsif (m/^--no-rm-on-error$/s) {
push @ropts, $_;
$rmonerror = 0;
+ } elsif (m/^--no-chase-dsc-distro$/s) {
+ push @ropts, $_;
+ $chase_dsc_distro = 0;
} elsif (m/^--overwrite$/s) {
push @ropts, $_;
$overwrite_version = '';
# undocumented, for testing
push @ropts, $_;
$need_split_build_invocation = 1;
+ } elsif (m/^--config-lookup-explode=(.+)$/s) {
+ # undocumented, for testing
+ push @ropts, $_;
+ $gitcfgs{cmdline}{$1} = 'CONFIG-LOOKUP-EXPLODE';
+ # ^ it's supposed to be an array ref
} elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
$val = $2 ? $' : undef; #';
$valopt->($oi->{Long});
+ } elsif ($funcopts_long{$_}) {
+ push @ropts, $_;
+ $funcopts_long{$_}();
} else {
badusage "unknown long option \`$_'";
}
}
-sub finalise_opts_opts () {
+sub parseopts_late_defaults () {
+ $isuite //= cfg("dgit-distro.$idistro.default-suite", 'RETURN-UNDEF')
+ if defined $idistro;
+ $isuite //= cfg('dgit.default.default-suite');
+
foreach my $k (keys %opts_opt_map) {
my $om = $opts_opt_map{$k};
@$om[$insertpos..$#$om] );
}
}
+
+ if (!defined $rmchanges) {
+ local $access_forpush;
+ $rmchanges = access_cfg_bool(0, 'rm-old-changes');
+ }
+
+ if (!defined $quilt_mode) {
+ local $access_forpush;
+ $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
+ // access_cfg('quilt-mode', 'RETURN-UNDEF')
+ // 'linear';
+ $quilt_mode =~ m/^($quilt_modes_re)$/
+ or badcfg "unknown quilt-mode \`$quilt_mode'";
+ $quilt_mode = $1;
+ }
+
+ foreach my $moc (@modeopt_cfgs) {
+ local $access_forpush;
+ my $vr = $moc->{Var};
+ next if defined $$vr;
+ $$vr = access_cfg($moc->{Key}, 'RETURN-UNDEF') // $moc->{Default};
+ my $v = $moc->{Vals}{$$vr};
+ badcfg "unknown $moc->{Key} setting \`$$vr'" unless defined $v;
+ $$vr = $v;
+ }
+
+ $need_split_build_invocation ||= quiltmode_splitbrain();
+
+ if (!defined $cleanmode) {
+ local $access_forpush;
+ $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
+ $cleanmode //= 'dpkg-source';
+
+ badcfg "unknown clean-mode \`$cleanmode'" unless
+ $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
+ }
}
if ($ENV{$fakeeditorenv}) {
my $pre_fn = ${*::}{"pre_$cmd"};
$pre_fn->() if $pre_fn;
-if (!defined $rmchanges) {
- local $access_forpush;
- $rmchanges = access_cfg_bool(0, 'rm-old-changes');
-}
-
-if (!defined $quilt_mode) {
- local $access_forpush;
- $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
- // access_cfg('quilt-mode', 'RETURN-UNDEF')
- // 'linear';
- $quilt_mode =~ m/^($quilt_modes_re)$/
- or badcfg "unknown quilt-mode \`$quilt_mode'";
- $quilt_mode = $1;
-}
-
-$need_split_build_invocation ||= quiltmode_splitbrain();
-
-if (!defined $cleanmode) {
- local $access_forpush;
- $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
- $cleanmode //= 'dpkg-source';
-
- badcfg "unknown clean-mode \`$cleanmode'" unless
- $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
-}
-
my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage "unknown operation $cmd";
$fn->();
~ianmdlvl / dgit.git / blobdiff