X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=dgit;h=a0d2e0a0f86034b6accf6fe81fb4f8556c65d9b3;hp=b25d344f46a496516735dd9cb088cd76008c7341;hb=3193ca2bad512d2563797eca11ceb9d707a65004;hpb=07a861b637e45f33cfbb9031e6fe4061f31e929c

diff --git a/dgit b/dgit
index b25d344f..a0d2e0a0 100755
--- a/dgit
+++ b/dgit
@@ -32,6 +32,7 @@ use Data::Dumper;
 use LWP::UserAgent;
 use Dpkg::Control::Hash;
 use File::Path;
+use File::Spec;
 use File::Temp qw(tempdir);
 use File::Basename;
 use Dpkg::Version;
@@ -102,7 +103,7 @@ our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
 
 our $suite_re = '[-+.0-9a-z]+';
 our $cleanmode_re = qr{(?: dpkg-source (?: -d )? (?: ,no-check | ,all-check )?
-                         | git | git-ff
+                     | (?: git | git-ff ) (?: ,always )?
                          | check (?: ,ignores )?
                          | none
                          )}x;
@@ -164,6 +165,7 @@ our %opts_cfg_insertpos = map {
 } keys %opts_opt_map;
 
 sub parseopts_late_defaults();
+sub quiltify_trees_differ ($$;$$$);
 sub setup_gitattrs(;$);
 sub check_gitattrs($$);
 
@@ -257,7 +259,7 @@ sub forceing ($) {
 }
 
 sub no_such_package () {
-    print STDERR f_ "%s: package %s does not exist in suite %s\n",
+    print STDERR f_ "%s: source package %s does not exist in suite %s\n",
 	$us, $package, $isuite;
     finish 4;
 }
@@ -396,7 +398,9 @@ sub branch_is_gdr ($) {
 	    return 0;
 	}
 	if ($tip_patches eq '' and
-	    !defined git_cat_file "$walk:debian") {
+	    !defined git_cat_file "$walk~:debian" and
+	    !quiltify_trees_differ "$walk~", $walk
+	   ) {
 	    # (gdr classification of parent: BreakwaterStart
 	    printdebug "branch_is_gdr  $walk unmarked BreakwaterStart YES\n";
 	    return 1;
@@ -2197,17 +2201,89 @@ sub check_for_vendor_patches () {
 			  __ "(nominal) distro being accessed");
 }
 
+sub check_bpd_exists () {
+    stat $buildproductsdir
+	or fail f_ "build-products-dir %s is not accessible: %s\n",
+	$buildproductsdir, $!;
+}
+
+sub dotdot_bpd_transfer_origs ($$$) {
+    my ($bpd_abs, $upstreamversion, $wanted) = @_;
+    # checks is_orig_file_of_vsn and if
+    # calls $wanted->{$leaf} and expects boolish
+
+    return if $buildproductsdir eq '..';
+
+    my $warned;
+    my $dotdot = $maindir;
+    $dotdot =~ s{/[^/]+$}{};
+    opendir DD, $dotdot or fail "opendir .. ($dotdot): $!";
+    while ($!=0, defined(my $leaf = readdir DD)) {
+	{
+	    local ($debuglevel) = $debuglevel-1;
+	    printdebug "DD_BPD $leaf ?\n";
+	}
+	next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+	next unless $wanted->($leaf);
+	next if lstat "$bpd_abs/$leaf";
+
+	print STDERR f_
+ "%s: found orig(s) in .. missing from build-products-dir, transferring:\n",
+	    $us
+	    unless $warned++;
+	$! == &ENOENT or fail f_
+	    "check orig file %s in bpd %s: %s", $leaf, $bpd_abs, $!;
+	lstat "$dotdot/$leaf" or fail f_
+	    "check orig file %s in ..: %s", $leaf, $!;
+	if (-l _) {
+	    stat "$dotdot/$leaf" or fail f_
+		"check target of orig symlink %s in ..: %s", $leaf, $!;
+	    my $ltarget = readlink "$dotdot/$leaf" or
+		die "readlink $dotdot/$leaf: $!";
+	    if ($ltarget !~ m{^/}) {
+		$ltarget = "$dotdot/$ltarget";
+	    }
+	    symlink $ltarget, "$bpd_abs/$leaf"
+		or die "$ltarget $bpd_abs $leaf: $!";
+	    print STDERR f_
+ "%s: cloned orig symlink from ..: %s\n",
+		$us, $leaf;
+	} elsif (link "$dotdot/$leaf", "$bpd_abs/$leaf") {
+	    print STDERR f_
+ "%s: hardlinked orig from ..: %s\n",
+		$us, $leaf;
+	} elsif ($! != EXDEV) {
+	    fail f_ "failed to make %s a hardlink to %s: %s",
+		"$bpd_abs/$leaf", "$dotdot/$leaf", $!;
+	} else {
+	    symlink "$bpd_abs/$leaf", "$dotdot/$leaf"
+		or die "$bpd_abs $dotdot $leaf $!";
+	    print STDERR f_
+ "%s: symmlinked orig from .. on other filesystem: %s\n",
+		$us, $leaf;
+	}
+    }
+    die "$dotdot; $!" if $!;
+    closedir DD;
+}
+
 sub generate_commits_from_dsc () {
     # See big comment in fetch_from_archive, below.
     # See also README.dsc-import.
     prep_ud();
     changedir $playground;
 
+    my $bpd_abs = bpd_abs();
+    my $upstreamv = upstreamversion $dsc->{version};
     my @dfi = dsc_files_info();
+
+    dotdot_bpd_transfer_origs $bpd_abs, $upstreamv,
+	sub { grep { $_->{Filename} eq $_[0] } @dfi };
+
     foreach my $fi (@dfi) {
 	my $f = $fi->{Filename};
 	die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
-	my $upper_f = (bpd_abs()."/$f");
+	my $upper_f = "$bpd_abs/$f";
 
 	printdebug "considering reusing $f: ";
 
@@ -2254,7 +2330,6 @@ sub generate_commits_from_dsc () {
     # from the debian/changelog, so we record the tree objects now and
     # make them into commits later.
     my @tartrees;
-    my $upstreamv = upstreamversion $dsc->{version};
     my $orig_f_base = srcfn $upstreamv, '';
 
     foreach my $fi (@dfi) {
@@ -3062,6 +3137,7 @@ END
 }
 
 sub fetch_from_archive () {
+    check_bpd_exists();
     ensure_setup_existing_tree();
 
     # Ensures that lrref() is what is actually in the archive, one way
@@ -3760,6 +3836,7 @@ sub clone ($) {
 
     mkdir $dstdir or fail f_ "create \`%s': %s", $dstdir, $!;
     changedir $dstdir;
+    check_bpd_exists();
 
     canonicalise_suite();
     my $hasgit = check_for_git();
@@ -5782,17 +5859,20 @@ sub unpack_playtree_linkorigs ($$) {
     # calls $fn->($leafname);
 
     my $bpd_abs = bpd_abs();
+
+    dotdot_bpd_transfer_origs $bpd_abs, $upstreamversion, sub { 1 };
+
     opendir QFD, $bpd_abs or fail "buildproductsdir: $bpd_abs: $!";
-    while ($!=0, defined(my $b = readdir QFD)) {
-	my $f = bpd_abs()."/".$b;
+    while ($!=0, defined(my $leaf = readdir QFD)) {
+	my $f = bpd_abs()."/".$leaf;
 	{
 	    local ($debuglevel) = $debuglevel-1;
-	    printdebug "QF linkorigs $b, $f ?\n";
+	    printdebug "QF linkorigs bpd $leaf, $f ?\n";
 	}
-	next unless is_orig_file_of_vsn $b, $upstreamversion;
-	printdebug "QF linkorigs $b, $f Y\n";
-	link_ltarget $f, $b or die "$b $!";
-        $fn->($b);
+	next unless is_orig_file_of_vsn $leaf, $upstreamversion;
+	printdebug "QF linkorigs $leaf, $f Y\n";
+	link_ltarget $f, $leaf or die "$leaf $!";
+        $fn->($leaf);
     }
     die "$buildproductsdir: $!" if $!;
     closedir QFD;
@@ -5849,16 +5929,16 @@ Files:
 END
 
     my $dscaddfile=sub {
-        my ($b) = @_;
+        my ($leaf) = @_;
         
 	my $md = new Digest::MD5;
 
-	my $fh = new IO::File $b, '<' or die "$b $!";
+	my $fh = new IO::File $leaf, '<' or die "$leaf $!";
 	stat $fh or confess $!;
 	my $size = -s _;
 
 	$md->addfile($fh);
-	print $fakedsc " ".$md->hexdigest." $size $b\n" or confess $!;
+	print $fakedsc " ".$md->hexdigest." $size $leaf\n" or confess $!;
     };
 
     unpack_playtree_linkorigs($upstreamversion, $dscaddfile);
@@ -6094,9 +6174,9 @@ END
     };
 
     my @dl;
-    foreach my $b (qw(01 02)) {
+    foreach my $bits (qw(01 02)) {
         foreach my $v (qw(O2H O2A H2A)) {
-            push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
+            push @dl, ($diffbits->{$v} & $bits) ? '##' : '==';
         }
     }
     printdebug "differences \@dl @dl.\n";
@@ -6205,13 +6285,14 @@ sub maybe_unapply_patches_again () {
 
 #----- other building -----
 
-sub clean_tree_check_git ($$) {
-    my ($honour_ignores, $message) = @_;
+sub clean_tree_check_git ($$$) {
+    my ($honour_ignores, $message, $ignmessage) = @_;
     my @cmd = (@git, qw(clean -dn));
     push @cmd, qw(-x) unless $honour_ignores;
     my $leftovers = cmdoutput @cmd;
     if (length $leftovers) {
 	print STDERR $leftovers, "\n" or confess $!;
+	$message .= $ignmessage if $honour_ignores;
 	fail $message;
     }
 }
@@ -6221,8 +6302,7 @@ sub clean_tree_check_git_wd ($) {
     return if $cleanmode =~ m{no-check};
     return if $patches_applied_dirtily; # yuk
     clean_tree_check_git +($cleanmode !~ m{all-check}),
-	                  (f_ <<END, $message);
-%s
+	$message, "\n".__ <<END;
 If this is just missing .gitignore entries, use a different clean
 mode, eg --clean=dpkg-source,no-check (-wdn/-wddn) to ignore them
 or --clean=git (-wg/-wgf) to use \`git clean' instead.
@@ -6230,20 +6310,19 @@ END
 }
 
 sub clean_tree_check () {
-    # Not yet fully implemented.
     # This function needs to not care about modified but tracked files.
     # That was done by check_not_dirty, and by now we may have run
     # the rules clean target which might modify tracked files (!)
     if ($cleanmode =~ m{^check}) {
 	clean_tree_check_git +($cleanmode =~ m{ignores}), __
- "tree contains uncommitted files and --clean=check specified";
+ "tree contains uncommitted files and --clean=check specified", '';
     } elsif ($cleanmode =~ m{^dpkg-source}) {
 	clean_tree_check_git_wd __
  "tree contains uncommitted files (NB dgit didn't run rules clean)";
     } elsif ($cleanmode =~ m{^git}) {
-	# If we were actually cleaning these files would be summarily
-	# deleted.  Since we're not, and not using the working tree
-	# anyway, we can just ignore them - nothing will use them.
+	clean_tree_check_git 1, __
+ "tree contains uncommited, untracked, unignored files\n".
+ "You can use --clean=git[-ff],always (-wga/-wgfa) to delete them.", '';
     } elsif ($cleanmode eq 'none') {
     } else {
 	confess "$cleanmode ?";
@@ -6261,9 +6340,9 @@ sub clean_tree () {
 	runcmd_ordryrun_local @cmd;
 	clean_tree_check_git_wd __
  "tree contains uncommitted files (after running rules clean)";
-    } elsif ($cleanmode eq 'git') {
+    } elsif ($cleanmode =~ m{^git(?!-)}) {
 	runcmd_ordryrun_local @git, qw(clean -xdf);
-    } elsif ($cleanmode eq 'git-ff') {
+    } elsif ($cleanmode =~ m{^git-ff}) {
 	runcmd_ordryrun_local @git, qw(clean -xdff);
     } elsif ($cleanmode =~ m{^check}) {
 	clean_tree_check();
@@ -6305,10 +6384,13 @@ sub build_prep_early () {
 sub build_prep ($) {
     my ($wantsrc) = @_;
     build_prep_early();
-    if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)) {
+    check_bpd_exists();
+    if (!building_source_in_playtree() || ($wantsrc & WANTSRC_BUILDER)
 	# Clean the tree because we're going to use the contents of
 	# $maindir.  (We trying to include dirty changes in the source
 	# package, or we are running the builder in $maindir.)
+	|| $cleanmode =~ m{always}) {
+	# Or because the user asked us to.
 	clean_tree();
     } else {
 	# We don't actually need to do anything in $maindir, but we
@@ -6925,29 +7007,49 @@ END
     my @dfi = dsc_files_info();
     foreach my $fi (@dfi) {
 	my $f = $fi->{Filename};
+	# We transfer all the pieces of the dsc to the bpd, not just
+	# origs.  This is by analogy with dgit fetch, which wants to
+	# keep them somewhere to avoid downloading them again.
+	# We make symlinks, though.  If the user wants copies, then
+	# they can copy the parts of the dsc to the bpd using dcmd,
+	# or something.
 	my $here = "$buildproductsdir/$f";
 	if (lstat $here) {
-	    next if stat $here;
+	    if (stat $here) {
+		next;
+	    }
 	    fail f_ "lstat %s works but stat gives %s !", $here, $!;
 	}
 	fail f_ "stat %s: %s", $here, $! unless $! == ENOENT;
+	printdebug "not in bpd, $f ...\n";
+	# $f does not exist in bpd, we need to transfer it
 	my $there = $dscfn;
-	if ($dscfn =~ m#^(?:\./+)?\.\./+#) {
-	    $there = $';
-	} elsif ($dscfn =~ m#^/#) {
-	    $there = $dscfn;
+	$there =~ s{[^/]+$}{$f} or confess "$there ?";
+	# $there is file we want, relative to user's cwd, or abs
+	printdebug "not in bpd, $f, test $there ...\n";
+	stat $there or fail f_
+	    "import %s requires %s, but: %s", $dscfn, $there, $!;
+	if ($there =~ m#^(?:\./+)?\.\./+#) {
+	    # $there is relative to user's cwd
+	    my $there_from_parent = $';
+	    if ($buildproductsdir !~ m{^/}) {
+		# abs2rel, despite its name, can take two relative paths
+		$there = File::Spec->abs2rel($there,$buildproductsdir);
+		# now $there is relative to bpd, great
+		printdebug "not in bpd, $f, abs2rel, $there ...\n";
+	    } else {
+		$there = (dirname $maindir)."/$there_from_parent";
+		# now $there is absoute
+		printdebug "not in bpd, $f, rel2rel, $there ...\n";
+	    }
+	} elsif ($there =~ m#^/#) {
+	    # $there is absolute already
+	    printdebug "not in bpd, $f, abs, $there ...\n";
 	} else {
 	    fail f_
 		"cannot import %s which seems to be inside working tree!",
 		$dscfn;
 	}
-	$there =~ s#/+[^/]+$## or fail f_
-	    "import %s requires .../%s, but it does not exist",
-	    $dscfn, $f;
-	$there .= "/$f";
-	my $test = $there =~ m{^/} ? $there : "../$there";
-	stat $test or fail f_
-	    "import %s requires %s, but: %s", $dscfn, $test, $!;
 	symlink $there, $here or fail f_
 	    "symlink %s to %s: %s", $there, $here, $!;
 	progress f_ "made symlink %s -> %s", $here, $there;
@@ -7289,12 +7391,11 @@ sub parseopts () {
 		} elsif (s/^-wn$//s) {
 		    push @ropts, $&;
 		    $cleanmode = 'none';
-		} elsif (s/^-wg$//s) {
+		} elsif (s/^-wg(f?)(a?)$//s) {
 		    push @ropts, $&;
 		    $cleanmode = 'git';
-		} elsif (s/^-wgf$//s) {
-		    push @ropts, $&;
-		    $cleanmode = 'git-ff';
+		    $cleanmode .= '-ff' if $1;
+		    $cleanmode .= ',always' if $2;
 		} elsif (s/^-wd(d?)([na]?)$//s) {
 		    push @ropts, $&;
 		    $cleanmode = 'dpkg-source';