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

diff --git a/dgit b/dgit
index da62de1f..983f97c5 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)";
     }
@@ -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;
 }
 
@@ -1562,6 +1564,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";
     }
 }
 
@@ -1689,7 +1693,13 @@ sub git_write_tree () {
     return $tree;
 }
 
-sub remove_stray_gits () {
+sub git_add_write_tree () {
+    runcmd @git, qw(add -Af .);
+    return git_write_tree();
+}
+
+sub remove_stray_gits ($) {
+    my ($what) = @_;
     my @gitscmd = qw(find -name .git -prune -print0);
     debugcmd "|",@gitscmd;
     open GITS, "-|", @gitscmd or die $!;
@@ -1697,7 +1707,7 @@ sub remove_stray_gits () {
 	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 $_;
 	}
@@ -1705,8 +1715,8 @@ sub remove_stray_gits () {
     $!=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) = <*/.>;
@@ -1715,7 +1725,7 @@ sub mktree_in_ud_from_only_subdir (;$) {
     my $dir = $1;
     changedir $dir;
 
-    remove_stray_gits();
+    remove_stray_gits($what);
     mktree_in_ud_here();
     if (!$raw) {
 	my ($format, $fopts) = get_source_format();
@@ -1724,8 +1734,7 @@ sub mktree_in_ud_from_only_subdir (;$) {
 	}
     }
 
-    runcmd @git, qw(add -Af);
-    my $tree=git_write_tree();
+    my $tree=git_add_write_tree();
     return ($tree,$dir);
 }
 
@@ -1887,7 +1896,8 @@ END
 	    push @found_differ, "archive $h->{filename}: ".join "; ", @differ
 		if @differ;
 	}
-	print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
+	printdebug "origs $file f.same=$found_same".
+	    " #f._differ=$#found_differ\n";
 	if (@found_differ && !$found_same) {
 	    fail join "\n",
 		"archive contains $file with different checksum",
@@ -2118,14 +2128,14 @@ sub generate_commits_from_dsc () {
 	    $input = $compr_fh;
 	}
 
-	rmtree "../unpack-tar";
-	mkdir "../unpack-tar" or die $!;
+	rmtree "_unpack-tar";
+	mkdir "_unpack-tar" or die $!;
 	my @tarcmd = qw(tar -x -f -
 			--no-same-owner --no-same-permissions
 			--no-acls --no-xattrs --no-selinux);
 	my $tar_pid = fork // die $!;
 	if (!$tar_pid) {
-	    chdir "../unpack-tar" or die $!;
+	    chdir "_unpack-tar" or die $!;
 	    open STDIN, "<&", $input or die $!;
 	    exec @tarcmd;
 	    die "dgit (child): exec $tarcmd[0]: $!";
@@ -2139,11 +2149,21 @@ sub generate_commits_from_dsc () {
 	# finally, we have the results in "tarball", but maybe
 	# with the wrong permissions
 
-	runcmd qw(chmod -R +rwX ../unpack-tar);
-	changedir "../unpack-tar";
-	my ($tree) = mktree_in_ud_from_only_subdir(1);
-	changedir "../../unpack";
-	rmtree "../unpack-tar";
+	runcmd qw(chmod -R +rwX _unpack-tar);
+	changedir "_unpack-tar";
+	remove_stray_gits($f);
+	mktree_in_ud_here();
+	
+	my ($tree) = git_add_write_tree();
+	my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
+	if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
+	    $tree = $1;
+	    printdebug "one subtree $1\n";
+	} else {
+	    printdebug "multiple subtrees\n";
+	}
+	changedir "..";
+	rmtree "_unpack-tar";
 
 	my $ent = [ $f, $tree ];
 	push @tartrees, {
@@ -2182,7 +2202,7 @@ sub generate_commits_from_dsc () {
     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();
     }
@@ -2192,8 +2212,7 @@ sub generate_commits_from_dsc () {
 	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);
@@ -2648,6 +2667,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 +2998,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 +3018,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 +3089,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 +3306,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 +3319,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";
@@ -3666,7 +3880,7 @@ END
     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);
@@ -3847,6 +4061,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 +4092,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 +4107,8 @@ sub fetchpullargs () {
 sub cmd_fetch {
     parseopts();
     fetchpullargs();
+    my $multi_fetched = fork_for_multisuite(sub { });
+    exit 0 if $multi_fetched;
     fetch();
 }
 
@@ -4990,13 +5204,12 @@ sub quilt_fixup_multipatch ($$$) {
 
     changedir 'fake';
 
-    remove_stray_gits();
+    remove_stray_gits("source package");
     mktree_in_ud_here();
 
     rmtree '.pc';
 
-    runcmd @git, qw(add -Af .);
-    my $unapplied=git_write_tree();
+    my $unapplied=git_add_write_tree();
     printdebug "fake orig tree object $unapplied\n";
 
     ensuredir '.pc';
@@ -5028,8 +5241,7 @@ END
 
     changedir '../fake';
     rmtree '.pc';
-    runcmd @git, qw(add -Af .);
-    my $oldtiptree=git_write_tree();
+    my $oldtiptree=git_add_write_tree();
     printdebug "fake o+d/p tree object $unapplied\n";
     changedir '../work';