X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=02d0b9298e3c8d9d7f5acae491f39b6099d8fbc4;hp=845edd3aa22878a3571116c59d37a743fba4ea8f;hb=1af545d050a9f129e7e42ec6fd2763fd8a3514aa;hpb=8e176e95b2137b2103bba97c8cd6af09a3fdc4a7

diff --git a/dgit b/dgit
index 845edd3a..02d0b929 100755
--- a/dgit
+++ b/dgit
@@ -78,6 +78,7 @@ our $patches_applied_dirtily = 00;
 our $tagformat_want;
 our $tagformat;
 our $tagformatfn;
+our $chase_dsc_distro=1; #xxx configurable
 
 our %forceopts = map { $_=>0 }
     qw(unrepresentable unsupported-source-format
@@ -572,6 +573,10 @@ our %defcfg = ('dgit.default.distro' => 'debian',
 	       '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"
@@ -686,7 +691,7 @@ sub cfg {
 	"$us: distro or suite appears not to be (properly) supported";
 }
 
-sub access_basedistro () {
+sub access_basedistro__noalias () {
     if (defined $idistro) {
 	return $idistro;
     } else {	
@@ -706,6 +711,12 @@ sub access_basedistro () {
     }
 }
 
+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();
     my $r = cfg("dgit-distro.$base.nominal-distro",'RETURN-UNDEF') // $base;
@@ -2515,7 +2526,14 @@ sub lrfetchref_used ($) {
 }
 
 sub git_lrfetch_sane {
-    my (@specs) = @_;
+    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 *,
@@ -2539,18 +2557,21 @@ sub git_lrfetch_sane {
     # git fetch to try to generate it.  If we don't manage to generate
     # the target state, we try again.
 
-    printdebug "git_lrfetch_sane 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_lrfetch_sane specre=$specre\n";
     my $wanted_rref = sub {
 	local ($_) = @_;
-	return m/^(?:$specre)$/o;
+	return m/^(?:$specre)$/;
     };
 
     my $fetch_iteration = 0;
@@ -2562,7 +2583,7 @@ sub git_lrfetch_sane {
 	}
 
 	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;
@@ -2590,10 +2611,12 @@ END
 
 	printdebug "git_lrfetch_sane fspecs @fspecs\n";
 
-	my @fcmd = (@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 {
@@ -2602,6 +2625,10 @@ END
 	    $objgot{$objid} = 1;
 	});
 
+	if ($supplementary) {
+	    last;
+	}
+
 	foreach my $lrefname (sort keys %lrfetchrefs_f) {
 	    my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
 	    if (!exists $wantr{$rrefname}) {
@@ -2661,7 +2688,7 @@ sub git_fetch_us () {
     push @specs, $rewritemap;
     push @specs, qw(heads/*) if deliberately_not_fast_forward;
 
-    git_lrfetch_sane @specs;
+    git_lrfetch_sane 0, @specs;
 
     my %here;
     my @tagpats = debiantags('*',access_nomdistro);
@@ -2747,16 +2774,86 @@ sub resolve_dsc_field_commit ($$) {
 
     return unless defined $dsc_hash;
 
-    my $rewritemapdata = git_cat_file $already_mapref.':map';
-    if (defined $rewritemapdata
-	&& $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
-	progress "server's git history rewrite map contains a relevant entry!";
+    my $mapref =
+	defined $already_mapref &&
+	($already_distro eq $dsc_distro || !$chase_dsc_distro)
+	? $already_mapref : undef;
 
-	$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";
+    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;
+    };
+
+    if (parse_cfg_bool 'rewrite-map-enable', 'true',
+	    access_cfg('rewrite-map-enable', 'RETURN-UNDEF')) {
+	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;
 	}
     }
 }
@@ -5932,11 +6029,16 @@ sub cmd_import_dsc {
 
     parse_dscdata();
 
-    parse_dsc_field($dsc, "Dgit metadata 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
-	&& !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 $dsc_hash | git cat-file --batch-check");
 	my $objgot = cmdoutput @cmd;
@@ -5968,7 +6070,6 @@ Specify  +$specbranch to overwrite, discarding existing history
 END
 	if $oldhash && !$force;
 
-    $package = getfield $dsc, 'Source';
     my @dfi = dsc_files_info();
     foreach my $fi (@dfi) {
 	my $f = $fi->{Filename};