X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=bd9dd3967945f290c6f92eaed60c3dc02f0f7448;hp=da62de1f39f57708a7874b7f33cfebac2d84730d;hb=57c7a33b3b21cd1840e33be2f159c4b7cd5ccf39;hpb=eed6fc8ddef77d691bfb4cd1e02a53045b25814d

diff --git a/dgit b/dgit
index da62de1f..bd9dd396 100755
--- a/dgit
+++ b/dgit
@@ -516,7 +516,7 @@ sub act_scary () { return !$dryrun_level; }
 
 sub printdone {
     if (!$dryrun_level) {
-	progress "dgit ok: @_";
+	progress "$us ok: @_";
     } else {
 	progress "would be ok: @_ (but dry run only)";
     }
@@ -1562,6 +1562,8 @@ sub canonicalise_suite () {
     $csuite = archive_query('canonicalise_suite');
     if ($isuite ne $csuite) {
 	progress "canonical suite name for $isuite is $csuite";
+    } else {
+	progress "canonical suite name is $csuite";
     }
 }
 
@@ -2648,6 +2650,24 @@ sub mergeinfo_version ($) {
     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
 }
 
+sub fetch_from_archive_record_1 ($) {
+    my ($hash) = @_;
+    runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
+	    'DGIT_ARCHIVE', $hash;
+    cmdoutput @git, qw(log -n2), $hash;
+    # ... gives git a chance to complain if our commit is malformed
+}
+
+sub fetch_from_archive_record_2 ($) {
+    my ($hash) = @_;
+    my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
+    if (act_local()) {
+	cmdoutput @upd_cmd;
+    } else {
+	dryrun_report @upd_cmd;
+    }
+}
+
 sub fetch_from_archive () {
     ensure_setup_existing_tree();
 
@@ -2961,10 +2981,7 @@ END
 	if $lastpush_hash;
     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
 
-    runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
-	    'DGIT_ARCHIVE', $hash;
-    cmdoutput @git, qw(log -n2), $hash;
-    # ... gives git a chance to complain if our commit is malformed
+    fetch_from_archive_record_1($hash);
 
     if (defined $skew_warning_vsn) {
 	mkpath '.git/dgit';
@@ -2984,12 +3001,7 @@ END
     }
 
     if ($lastfetch_hash ne $hash) {
-	my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
-	if (act_local()) {
-	    cmdoutput @upd_cmd;
-	} else {
-	    dryrun_report @upd_cmd;
-	}
+	fetch_from_archive_record_2($hash);
     }
 
     lrfetchref_used lrfetchref();
@@ -3060,19 +3072,207 @@ 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 $!;
+    close H or die $!;
+}
+sub clone_finish ($) {
+    my ($dstdir) = @_;
+    runcmd @git, qw(reset --hard), lrref();
+    runcmd qw(bash -ec), <<'END';
+        set -o pipefail
+        git ls-tree -r --name-only -z HEAD | \
+        xargs -0r touch -r . --
+END
+    printdone "ready for work in $dstdir";
+}
+
 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;
     runcmd @git, qw(init -q);
+    clone_set_head();
     my $giturl = access_giturl(1);
     if (defined $giturl) {
-	open H, "> .git/HEAD" or die $!;
-	print H "ref: ".lref()."\n" or die $!;
-	close H or die $!;
 	runcmd @git, qw(remote add), 'origin', $giturl;
     }
     if ($hasgit) {
@@ -3089,16 +3289,11 @@ sub clone ($) {
 	runcmd @git, qw(remote add vcs-git), $vcsgiturl;
     }
     setup_new_tree();
-    runcmd @git, qw(reset --hard), lrref();
-    runcmd qw(bash -ec), <<'END';
-        set -o pipefail
-        git ls-tree -r --name-only -z HEAD | \
-        xargs -0r touch -r . --
-END
-    printdone "ready for work in $dstdir";
+    clone_finish($dstdir);
 }
 
 sub fetch () {
+    canonicalise_suite();
     if (check_for_git()) {
 	git_fetch_us();
     }
@@ -3107,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";
@@ -3847,6 +4044,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 { $! == $_ }
@@ -3877,16 +4075,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";
     }
@@ -3895,6 +4090,8 @@ sub fetchpullargs () {
 sub cmd_fetch {
     parseopts();
     fetchpullargs();
+    my $multi_fetched = fork_for_multisuite(sub { });
+    exit 0 if $multi_fetched;
     fetch();
 }