X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=b7e7f7eb6e49ff2585ce465753dea3ae0e8c12f6;hp=f1a30c3a989a46748b770c070a040df654d9d94c;hb=6f4ecf492c297aa6a1f0c2b2652225cd40ce72be;hpb=d422e614352724c8cd511c8d1ae8a6d9a1ba5265

diff --git a/dgit b/dgit
index f1a30c3a..b7e7f7eb 100755
--- a/dgit
+++ b/dgit
@@ -1010,6 +1010,8 @@ our %rmad;
 
 sub archive_query ($;@) {
     my ($method) = shift @_;
+    fail "this operation does not support multiple comma-separated suites"
+	if $isuite =~ m/,/;
     my $query = access_cfg('archive-query','RETURN-UNDEF');
     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
     my $proto = $1;
@@ -1162,7 +1164,7 @@ sub aptget_aptcache () { return @aptcache, qw(-c), $aptget_configpath; }
 
 sub aptget_cache_clean {
     runcmd_ordryrun_local qw(sh -ec),
-	'cd "$1"; pwd; find -atime +30 -type f -print0 | xargs -0r echo rm --',
+	'cd "$1"; find -atime +30 -type f -print0 | xargs -0r rm --',
 	'x', $aptget_base;
 }
 
@@ -3072,6 +3074,167 @@ sub setup_new_tree () {
     setup_useremail();
 }
 
+sub multisuite_suite_child ($$$) {
+    my ($tsuite, $merginputs, $fn) = @_;
+    # in child, sets things up, calls $fn->(), and returns undef
+    # in parent, returns canonical suite name for $tsuite
+    my $canonsuitefh = IO::File::new_tmpfile;
+    my $pid = fork // die $!;
+    if (!$pid) {
+	$isuite = $tsuite;
+	$us .= " [$isuite]";
+	$debugprefix .= " ";
+	progress "fetching $tsuite...";
+	canonicalise_suite();
+	print $canonsuitefh $csuite, "\n" or die $!;
+	close $canonsuitefh or die $!;
+	$fn->();
+	return undef;
+    }
+    waitpid $pid,0 == $pid or die $!;
+    fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
+    seek $canonsuitefh,0,0 or die $!;
+    local $csuite = <$canonsuitefh>;
+    die $! unless defined $csuite && chomp $csuite;
+    if ($? == 256*4) {
+	printdebug "multisuite $tsuite missing\n";
+	return $csuite;
+    }
+    printdebug "multisuite $tsuite ok (canon=$csuite)\n";
+    push @$merginputs, {
+        Ref => lrref,
+        Info => $csuite,
+    };
+    return $csuite;
+}
+
+sub fork_for_multisuite ($) {
+    my ($before_fetch_merge) = @_;
+    # if nothing unusual, just returns ''
+    #
+    # if multisuite:
+    # returns 0 to caller in child, to do first of the specified suites
+    # in child, $csuite is not yet set
+    #
+    # returns 1 to caller in parent, to finish up anything needed after
+    # in parent, $csuite is set to canonicalised portmanteau
+
+    my $org_isuite = $isuite;
+    my @suites = split /\,/, $isuite;
+    return '' unless @suites > 1;
+    printdebug "fork_for_multisuite: @suites\n";
+
+    my @mergeinputs;
+
+    my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
+					    sub { });
+    return 0 unless defined $cbasesuite;
+
+    fail "package $package missing in (base suite) $cbasesuite"
+	unless @mergeinputs;
+
+    my @csuites = ($cbasesuite);
+
+    $before_fetch_merge->();
+
+    foreach my $tsuite (@suites[1..$#suites]) {
+	my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
+					       sub {
+            @end = ();
+            fetch();
+	    exit 0;
+	});
+	# xxx collecte the ref here
+
+	$csubsuite =~ s/^\Q$cbasesuite\E-/-/;
+	push @csuites, $csubsuite;
+    }
+
+    foreach my $mi (@mergeinputs) {
+	my $ref = git_get_ref $mi->{Ref};
+	die "$mi->{Ref} ?" unless length $ref;
+	$mi->{Commit} = $ref;
+    }
+
+    $csuite = join ",", @csuites;
+
+    my $previous = git_get_ref lrref;
+    if ($previous) {
+	unshift @mergeinputs, {
+            Commit => $previous,
+            Info => "local combined tracking branch",
+            Warning =>
+ "archive seems to have rewound: local tracking branch is ahead!",
+        };
+    }
+
+    foreach my $ix (0..$#mergeinputs) {
+	$mergeinputs[$ix]{Index} = $ix;
+    }
+
+    @mergeinputs = sort {
+	-version_compare(mergeinfo_version $a,
+			 mergeinfo_version $b) # highest version first
+	    or
+	$a->{Index} <=> $b->{Index}; # earliest in spec first
+    } @mergeinputs;
+
+    my @needed;
+
+  NEEDED:
+    foreach my $mi (@mergeinputs) {
+	printdebug "multisuite merge check $mi->{Info}\n";
+	foreach my $previous (@needed) {
+	    next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
+	    printdebug "multisuite merge un-needed $previous->{Info}\n";
+	    next NEEDED;
+	}
+	push @needed, $mi;
+	printdebug "multisuite merge this-needed\n";
+	$mi->{Character} = '+';
+    }
+
+    $needed[0]{Character} = '*';
+
+    my $output = $needed[0]{Commit};
+
+    if (@needed > 1) {
+	printdebug "multisuite merge nontrivial\n";
+	my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
+
+	my $commit = "tree $tree\n";
+	my $msg = "Combine archive branches $csuite [dgit]\n\n".
+	    "Input branches:\n";
+
+	foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
+	    printdebug "multisuite merge include $mi->{Info}\n";
+	    $mi->{Character} //= ' ';
+	    $commit .= "parent $mi->{Commit}\n";
+	    $msg .= sprintf " %s  %-25s %s\n",
+		$mi->{Character},
+		(mergeinfo_version $mi),
+		$mi->{Info};
+	}
+	my $authline = clogp_authline mergeinfo_getclogp $needed[0];
+	$msg .= "\nKey\n".
+	    " * marks the highest version branch, which choose to use\n".
+	    " + marks each branch which was not already an ancestor\n\n".
+	    "[dgit multi-suite $csuite]\n";
+	$commit .=
+	    "author $authline\n".
+	    "committer $authline\n\n";
+	$output = make_commit_text $commit.$msg;
+	printdebug "multisuite merge generated $output\n";
+    }
+
+    fetch_from_archive_record_1($output);
+    fetch_from_archive_record_2($output);
+
+    progress "calculated combined tracking suite $csuite";
+
+    return 1;
+}
+
 sub clone_set_head () {
     open H, "> .git/HEAD" or die $!;
     print H "ref: ".lref()."\n" or die $!;
@@ -3090,8 +3253,21 @@ END
 
 sub clone ($) {
     my ($dstdir) = @_;
-    canonicalise_suite();
     badusage "dry run makes no sense with clone" unless act_local();
+
+    my $multi_fetched = fork_for_multisuite(sub {
+        printdebug "multi clone before fetch merge\n";
+        changedir $dstdir;
+    });
+    if ($multi_fetched) {
+        printdebug "multi clone after fetch merge\n";
+	clone_set_head();
+	clone_finish($dstdir);
+	exit 0;
+    }
+    printdebug "clone main body\n";
+
+    canonicalise_suite();
     my $hasgit = check_for_git();
     mkdir $dstdir or fail "create \`$dstdir': $!";
     changedir $dstdir;
@@ -3119,6 +3295,7 @@ sub clone ($) {
 }
 
 sub fetch () {
+    canonicalise_suite();
     if (check_for_git()) {
 	git_fetch_us();
     }
@@ -3127,7 +3304,9 @@ sub fetch () {
 }
 
 sub pull () {
-    fetch();
+    my $multi_fetched = fork_for_multisuite(sub { });
+    fetch() unless $multi_fetched; # parent
+    return if $multi_fetched eq '0'; # child
     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
         lrref();
     printdone "fetched to ".lrref()." and merged into HEAD";
@@ -3867,6 +4046,7 @@ sub cmd_clone {
 		return if $!==&ENOENT;
 		die "chdir $cwd_remove: $!";
 	    }
+	    printdebug "clone rmonerror removing $dstdir\n";
 	    if (stat $dstdir) {
 		rmtree($dstdir) or die "remove $dstdir: $!\n";
 	    } elsif (grep { $! == $_ }
@@ -3897,16 +4077,13 @@ sub fetchpullargs () {
 	$package = getfield $sourcep, 'Source';
     }
     if (@ARGV==0) {
-#	$isuite = branchsuite();  # this doesn't work because dak hates canons
+	$isuite = branchsuite();
 	if (!$isuite) {
 	    my $clogp = parsechangelog();
 	    $isuite = getfield $clogp, 'Distribution';
 	}
-	canonicalise_suite();
-	progress "fetching from suite $csuite";
     } elsif (@ARGV==1) {
 	($isuite) = @ARGV;
-	canonicalise_suite();
     } else {
 	badusage "incorrect arguments to dgit fetch or dgit pull";
     }
@@ -3915,6 +4092,8 @@ sub fetchpullargs () {
 sub cmd_fetch {
     parseopts();
     fetchpullargs();
+    my $multi_fetched = fork_for_multisuite(sub { });
+    exit 0 if $multi_fetched;
     fetch();
 }