dgit: Implement multi-suites

Signed-off-by: Ian Jackson <ijackson@chiark.greenend.org.uk>

1 files changed, 179 insertions, 1 deletions

diff --git a/dgit b/dgit
index aa5da93..bd9dd39 100755
--- a/dgit
+++ b/dgit
@@ -3072,6 +3072,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 $!;
@@ -3091,6 +3252,19 @@ END
 sub clone ($) {
     my ($dstdir) = @_;
     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': $!";
@@ -3128,7 +3302,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";
@@ -3914,6 +4090,8 @@ sub fetchpullargs () {
 sub cmd_fetch {
     parseopts();
     fetchpullargs();
+    my $multi_fetched = fork_for_multisuite(sub { });
+    exit 0 if $multi_fetched;
     fetch();
 }