Eliminate erroneous warning when unstowing (#65)

When unstowing a package, cleanup_invalid_links() is invoked to remove
any invalid links owned by Stow.  It was invoking link_owned_by_package()
to check whether each existing link is owned by Stow.  This in turn
called find_stowed_path() which since 40a0807185 was not allowing for
the possibility that it could be passed a symlink *not* owned by Stow
with an absolute target and consequently emitting an erroneous warning.

So remove this erroneous warning, and refactor find_stowed_path()
to use two new helper functions for detecting stow directories:
link_dest_within_stow_dir() and find_containing_marked_stow_dir().
Also refactor the logic within each to be simpler and more accurate,
and add more test cases to the corresponding parts of the test suite.

Fixes #65.
Closes #103.

https://github.com/aspiers/stow/issues/65

NEWS

@@ -2,6 +2,15 @@ News file for Stow.
 
 * Changes in version 2.3.2
 
+*** Eliminated a spurious warning on unstowing
+
+    2.3.1 introduced a benign but annoying warning when unstowing
+    in certain circumstances.  It looked like:
+
+      BUG in find_stowed_path? Absolute/relative mismatch between Stow dir X and path Y
+
+    This was caused by erroneous logic, and has now been fixed.
+
 *** Improved debug output
 
     Extra output resulting from use of the -v / --verbose flag

lib/Stow.pm.in

@@ -936,80 +936,129 @@ sub link_owned_by_package {
 
 #===== METHOD ===============================================================
 # Name      : find_stowed_path()
-# Purpose   : determine whether the given link within the target directory
+# Purpose   : determine whether the given symlink within the target directory
 #           : is a stowed path pointing to a member of a package under the
 #           : stow dir, and if so, obtain a breakdown of information about
 #           : this stowed path.
-# Parameters: $target => path to a symbolic link under current directory.
+# Parameters: $target => path to a symbolic link somewhere under
-#           :            Must share a common prefix with $self->{stow_path}
+#           :            the target directory, relative to the
-#           : $source => where that link points to (needed because link
+#           :            top-level target directory (which is also
+#           :            expected to be the current directory).
+#           : $ldest =>  where that link points to (needed because link
 #           :            might not exist yet due to two-phase approach,
-#           :            so we can't just call readlink()).  This must be
+#           :            so we can't just call readlink()).  If this is
-#           :            expressed relative to (the directory containing)
+#           :            owned by Stow, it will be expressed relative to
-#           :            $target.
+#           :            (the directory containing) $target.  However if
-# Returns   : ($path, $stow_path, $package) where $path and $stow_path are
+#           :            it's not, it could of course be relative or absolute,
-#           : relative from the current (i.e. target) directory.  $path
+#           :            point absolutely anywhere, and could even be
-#           : is the full relative path, $stow_path is the relative path
+#           :            dangling.
-#           : to the stow directory, and $package is the name of the package.
+# Returns   : ($path, $stow_path, $package) where $path and $stow_path
-#           : or ('', '', '') if link is not owned by stow
+#           : are relative from the top-level target directory.  $path
+#           : is the full relative path to the member of the package
+#           : pointed to by $ldest; $stow_path is the relative path
+#           : to the stow directory; and $package is the name of the
+#           : package; or ('', '', '') if link is not owned by stow.
 # Throws    : n/a
-# Comments  : Allow for stow dir not being under target dir.
+# Comments  : cwd must be the top-level target directory, otherwise
-#           : We could put more logic under here for multiple stow dirs.
+#           : find_containing_marked_stow_dir() won't work.
+#           : Allow for stow dir not being under target dir.
 #============================================================================
 sub find_stowed_path {
     my $self = shift;
-    my ($target, $source) = @_;
+    my ($target, $ldest) = @_;
 
-    # Evaluate softlink relative to its target
+    if (substr($ldest, 0, 1) eq '/') {
-    my $path = join_paths(parent($target), $source);
+        # Symlink points to an absolute path, therefore it cannot be
-    debug(4, 2, "is path $path owned by stow?");
+        # owned by Stow.
-
+        return ('', '', '');
-    # Search for .stow files - this allows us to detect links
-    # owned by stow directories other than the current one.
-    my $dir = '';
-    my @path = split m{/+}, $path;
-    for my $i (0 .. $#path) {
-        my $part = $path[$i];
-        $dir = join_paths($dir, $part);
-        if ($self->marked_stow_dir($dir)) {
-            # FIXME - not sure if this can ever happen
-            internal_error("find_stowed_path() called directly on stow dir")
-                if $i == $#path;
-
-            debug(4, 3, "yes - $dir was marked as a stow dir");
-            my $package = $path[$i + 1];
-            return ($path, $dir, $package);
     }
+
+    # Evaluate softlink relative to its target, without relying on
+    # what's actually on the filesystem, since the link might not
+    # exist yet.
+    debug(4, 2, "find_stowed_path(target=$target; source=$ldest)");
+    my $dest = join_paths(parent($target), $ldest);
+    debug(4, 3, "is symlink destination $dest owned by stow?");
+
+    # First check whether the link is owned by the current stow
+    # directory, in which case $dest will be a prefix of
+    # $self->{stow_path}.
+    my ($package, $path) = $self->link_dest_within_stow_dir($dest);
+    if (length $package) {
+        debug(4, 3, "yes - package $package in $self->{stow_path} may contain $path");
+        return ($dest, $self->{stow_path}, $package);
     }
 
     # If no .stow file was found, we need to find out whether it's
-    # owned by the current stow directory, in which case $path will be
+    my ($stow_path, $ext_package) = $self->find_containing_marked_stow_dir($dest);
-    # a prefix of $self->{stow_path}.
+    if (length $stow_path) {
-    if (substr($path, 0, 1) eq '/' xor substr($self->{stow_path}, 0, 1) eq '/')
+        debug(5, 5, "yes - $stow_path in $dest was marked as a stow dir; package=$ext_package");
-    {
+        return ($dest, $stow_path, $ext_package);
-        warn "BUG in find_stowed_path? Absolute/relative mismatch between " .
-             "Stow dir $self->{stow_path} and path $path";
     }
 
-    my @stow_path = split m{/+}, $self->{stow_path};
-
-    # Strip off common prefixes until one is empty
-    while (@path && @stow_path) {
-        if ((shift @path) ne (shift @stow_path)) {
-            debug(4, 3, "no - either $path not under $self->{stow_path} or vice-versa");
     return ('', '', '');
-        }
+}
+
+#===== METHOD ================================================================
+# Name      : link_dest_within_stow_dir
+# Purpose   : detect whether symlink destination is within current stow dir
+# Parameters: $ldest - destination of the symlink relative
+# Returns   : ($package, $path) - package within the current stow dir
+#           : and subpath within that package which the symlink points to
+#=============================================================================
+sub link_dest_within_stow_dir {
+    my $self = shift;
+    my ($ldest) = @_;
+
+    debug(4, 4, "common prefix? ldest=$ldest; stow_path=$self->{stow_path}");
+
+    my $removed = $ldest =~ s,^\Q$self->{stow_path}/,,;
+    if (! $removed) {
+        debug(4, 3, "no - $ldest not under $self->{stow_path}");
+        return ('', '');
     }
 
-    if (@stow_path) { # @path must be empty
+    debug(4, 4, "remaining after removing $self->{stow_path}: $ldest");
-        debug(4, 3, "no - $path is not under $self->{stow_path}");
+    my @dirs = File::Spec->splitdir($ldest);
-        return ('', '', '');
+    my $package = shift @dirs;
+    my $path = File::Spec->catdir(@dirs);
+    return ($package, $path);
+}
+
+#===== METHOD ================================================================
+# Name      : find_containing_marked_stow_dir
+# Purpose   : detect whether path is within a marked stow directory
+# Parameters: $path => path to directory to check
+# Returns   : ($stow_path, $package) where $stow_path is the highest directory
+#           : (relative from the top-level target directory) which is marked
+#           : as a Stow directory, and $package is the containing package;
+#           : or ('', '') if no containing directory is marked as a stow
+#           : directory.
+# Comments  : cwd must be the top-level target directory, otherwise
+#           : marked_stow_dir() won't work.
+#=============================================================================
+sub find_containing_marked_stow_dir {
+    my $self = shift;
+    my ($path) = @_;
+
+    # Search for .stow files - this allows us to detect links
+    # owned by stow directories other than the current one.
+    my @segments = File::Spec->splitdir($path);
+    for my $last_segment (0 .. $#segments) {
+        my $path = join_paths(@segments[0 .. $last_segment]);
+        debug(5, 5, "is $path marked stow dir?");
+        if ($self->marked_stow_dir($path)) {
+            if ($last_segment == $#segments) {
+                # This should probably never happen.  Even if it did,
+                # there would be no way of calculating $package.
+                internal_error("find_stowed_path() called directly on stow dir");
             }
 
-    my $package = shift @path;
+            my $package = $segments[$last_segment + 1];
-
+            return ($path, $package);
-    debug(4, 3, "yes - by $package in " . join_paths(@path));
+        }
-    return ($path, $self->{stow_path}, $package);
+    }
+    return ('', '');
 }
 
 #===== METHOD ================================================================
@@ -1066,24 +1115,30 @@ sub cleanup_invalid_links {
 
         # Where is the link pointing?
         # (don't use read_a_link() here)
-        my $source = readlink($node_path);
+        my $ldest = readlink($node_path);
-        if (not $source) {
+        if (not $ldest) {
             error("Could not read link $node_path");
         }
 
-        if (-e join_paths($dir, $source)) {
+        my $target = join_paths($dir, $ldest);
-            debug(4, 2, "Link target $source exists; skipping clean up");
+        debug(4, 2, "join $dir $ldest");
+        if (-e $target) {
+            debug(4, 2, "Link target $ldest exists at $target; skipping clean up");
             next;
         }
+        else {
+            debug(4, 2, "Link target $ldest doesn't exist at $target");
+        }
 
         debug(3, 1,
-              "Checking whether valid link $node_path -> $source is " .
+              "Checking whether valid link $node_path -> $ldest is " .
               "owned by stow");
 
-        if ($self->link_owned_by_package($node_path, $source)) {
+        my $owner = $self->link_owned_by_package($node_path, $ldest);
+        if ($owner) {
             # owned by stow
-            debug(2, 0, "--- removing stale link: $node_path => " .
+            debug(2, 0, "--- removing link owned by $owner: $node_path => " .
-                  join_paths($dir, $source));
+                  join_paths($dir, $ldest));
             $self->do_unlink($node_path);
         }
     }

t/find_stowed_path.t

@@ -16,68 +16,133 @@
 # along with this program. If not, see https://www.gnu.org/licenses/.
 
 #
-# Testing find_stowed_path()
+# Testing Stow:: find_stowed_path()
 #
 
 use strict;
 use warnings;
 
-use Test::More tests => 18;
+use Test::More tests => 10;
 
 use testutil;
 use Stow::Util qw(set_debug_level);
 
 init_test_dirs();
 
-my $stow = new_Stow(dir => "$TEST_DIR/stow");
+subtest("find link to a stowed path with relative target" => sub {
-#set_debug_level(4);
+    plan tests => 3;
 
-my ($path, $stow_path, $package) =
+    # This is a relative path, unlike $ABS_TEST_DIR below.
-    $stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../../stow/a/b/c");
+    my $target = "$TEST_DIR/target";
-is($path, "$TEST_DIR/stow/a/b/c", "path");
-is($stow_path, "$TEST_DIR/stow", "stow path");
-is($package, "a", "package");
 
-cd("$TEST_DIR/target");
+    my $stow = new_Stow(dir => "$TEST_DIR/stow", target => $target);
-$stow->set_stow_dir("../stow");
+    my ($path, $stow_path, $package) =
-($path, $stow_path, $package) =
         $stow->find_stowed_path("a/b/c", "../../../stow/a/b/c");
-is($path, "../stow/a/b/c", "path from target directory");
+    is($path, "../stow/a/b/c", "path");
-is($stow_path, "../stow", "stow path from target directory");
+    is($stow_path, "../stow", "stow path");
-is($package, "a", "from target directory");
+    is($package, "a", "package");
+});
 
-make_path("stow");
+my $stow = new_Stow(dir => "$ABS_TEST_DIR/stow", target => "$ABS_TEST_DIR/target");
-cd("../..");
-$stow->set_stow_dir("$TEST_DIR/target/stow");
 
-($path, $stow_path, $package) =
+# Required by creation of stow2 and stow2/.stow below
-    $stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../stow/a/b/c");
+cd("$ABS_TEST_DIR/target");
-is($path, "$TEST_DIR/target/stow/a/b/c", "path");
-is($stow_path, "$TEST_DIR/target/stow", "stow path");
-is($package, "a", "stow is subdir of target directory");
 
-($path, $stow_path, $package) =
+subtest("find link to a stowed path" => sub {
-    $stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../empty");
+    plan tests => 3;
-is($path, "", "empty path");
+    my ($path, $stow_path, $package) =
-is($stow_path, "", "empty stow path");
+        $stow->find_stowed_path("a/b/c", "../../../stow/a/b/c");
-is($package, "", "target is not stowed");
+    is($path, "../stow/a/b/c", "path from target directory");
+    is($stow_path, "../stow", "stow path from target directory");
+    is($package, "a", "from target directory");
+});
+
+subtest("find link to alien path not owned by Stow" => sub {
+    plan tests => 3;
+    my ($path, $stow_path, $package) =
+        $stow->find_stowed_path("a/b/c", "../../alien");
+    is($path, "", "alien is not stowed, so path is empty");
+    is($stow_path, "", "alien, so stow path is empty");
+    is($package, "", "alien is not stowed in any package");
+});
 
 # Make a second stow directory within the target directory, so that we
-# can check that links to package files within that second stow
+# can check that links to package files within that stow directory are
-# directory are detected correctly.
+# detected correctly.
-make_path("$TEST_DIR/target/stow2");
+make_path("stow2");
-make_file("$TEST_DIR/target/stow2/.stow");
 
-($path, $stow_path, $package) =
+# However this second stow directory is still "alien" to stow until we
-    $stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../stow2/a/b/c");
+# put a .stow file in it.  So first test a symlink pointing to a path
-is($path, "$TEST_DIR/target/stow2/a/b/c", "path");
+# within this second stow directory
-is($stow_path, "$TEST_DIR/target/stow2", "stow path");
+subtest("second stow dir still alien without .stow" => sub {
-is($package, "a", "detect alternate stow directory");
+    plan tests => 3;
+    my ($path, $stow_path, $package) =
+        $stow->find_stowed_path("a/b/c", "../../stow2/a/b/c");
+    is($path, "", "stow2 not a stow dir yet, so path is empty");
+    is($stow_path, "", "stow2 not a stow dir yet so stow path is empty");
+    is($package, "", "not stowed in any recognised package yet");
+});
 
-# Possible corner case with rogue symlink pointing to ancestor of
+# Now make stow2 a secondary stow directory and test that
-# stow dir.
+make_file("stow2/.stow");
-($path, $stow_path, $package) =
+
-    $stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../..");
+subtest(".stow makes second stow dir owned by Stow" => sub {
-is($path, "", "path");
+    plan tests => 3;
-is($stow_path, "", "stow path");
+    my ($path, $stow_path, $package) =
-is($package, "", "corner case - link points to ancestor of stow dir");
+        $stow->find_stowed_path("a/b/c", "../../stow2/a/b/c");
+    is($path, "stow2/a/b/c", "path");
+    is($stow_path, "stow2", "stow path");
+    is($package, "a", "detect alternate stow directory");
+});
+
+subtest("relative symlink pointing to target dir" => sub {
+    plan tests => 3;
+    my ($path, $stow_path, $package) =
+        $stow->find_stowed_path("a/b/c", "../../..");
+    # Technically the target dir is not owned by Stow, since
+    # Stow won't touch the target dir itself, only its contents.
+    is($path, "", "path");
+    is($stow_path, "", "stow path");
+    is($package, "", "corner case - link points to target dir");
+});
+
+subtest("relative symlink pointing to parent of target dir" => sub {
+    plan tests => 3;
+    my ($path, $stow_path, $package) =
+        $stow->find_stowed_path("a/b/c", "../../../..");
+    is($path, "", "path");
+    is($stow_path, "", "stow path");
+    is($package, "", "corner case - link points to parent of target dir");
+});
+
+subtest("unowned symlink pointing to absolute path inside target" => sub {
+    plan tests => 3;
+    my ($path, $stow_path, $package) =
+        $stow->find_stowed_path("a/b/c", "$ABS_TEST_DIR/target/d");
+    is($path, "", "path");
+    is($stow_path, "", "stow path");
+    is($package, "", "symlink unowned by Stow points to absolute path outside target directory");
+});
+
+subtest("unowned symlink pointing to absolute path outside target" => sub {
+    plan tests => 3;
+    my ($path, $stow_path, $package) =
+        $stow->find_stowed_path("a/b/c", "/dev/null");
+    is($path, "", "path");
+    is($stow_path, "", "stow path");
+    is($package, "", "symlink unowned by Stow points to absolute path outside target directory");
+});
+
+# Now make stow2 the primary stow directory and test that it still
+# works when the stow directory is under the target directory
+$stow->set_stow_dir("$ABS_TEST_DIR/target/stow2");
+
+subtest("stow2 becomes the primary stow directory" => sub {
+    plan tests => 3;
+
+    my ($path, $stow_path, $package) =
+        $stow->find_stowed_path("a/b/c", "../../stow2/a/b/c");
+    is($path, "stow2/a/b/c", "path in stow2");
+    is($stow_path, "stow2", "stow path for stow2");
+    is($package, "a", "stow2 is subdir of target directory");
+});

t/link_dest_within_stow_dir.t

@@ -0,0 +1,88 @@
+#!/usr/bin/perl
+#
+# This file is part of GNU Stow.
+#
+# GNU Stow is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# GNU Stow is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see https://www.gnu.org/licenses/.
+
+#
+# Testing Stow::link_dest_within_stow_dir()
+#
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+use testutil;
+use Stow::Util;
+
+init_test_dirs();
+
+# This is a relative path, unlike $ABS_TEST_DIR below.
+my $stow = new_Stow(dir => "$TEST_DIR/stow",
+                    target => "$TEST_DIR/target");
+
+subtest("relative stow dir, link to top-level package file" => sub {
+    plan tests => 2;
+    my ($package, $path) =
+        $stow->link_dest_within_stow_dir("../stow/pkg/dir/file");
+    is($package, "pkg", "package");
+    is($path, "dir/file", "path");
+});
+
+subtest("relative stow dir, link to second-level package file" => sub {
+    plan tests => 2;
+    my ($package, $path) =
+        $stow->link_dest_within_stow_dir("../stow/pkg/dir/subdir/file");
+    is($package, "pkg", "package");
+    is($path, "dir/subdir/file", "path");
+});
+
+# This is an absolute path, unlike $TEST_DIR above.
+$stow = new_Stow(dir => "$ABS_TEST_DIR/stow",
+                    target => "$ABS_TEST_DIR/target");
+
+subtest("relative stow dir, link to second-level package file" => sub {
+    plan tests => 2;
+    my ($package, $path) =
+        $stow->link_dest_within_stow_dir("../stow/pkg/dir/file");
+    is($package, "pkg", "package");
+    is($path, "dir/file", "path");
+});
+
+subtest("absolute stow dir, link to top-level package file" => sub {
+    plan tests => 2;
+    my ($package, $path) =
+        $stow->link_dest_within_stow_dir("../stow/pkg/dir/subdir/file");
+    is($package, "pkg", "package");
+    is($path, "dir/subdir/file", "path");
+});
+
+# Links with destination in the target are not pointing within
+# the stow dir, so they're not owned by stow.
+subtest("link to path in target" => sub {
+    plan tests => 2;
+    my ($package, $path) =
+        $stow->link_dest_within_stow_dir("./alien");
+    is($path, "", "alien is in target, so path is empty");
+    is($package, "", "alien is in target, so package is empty");
+});
+
+subtest("link to path outside target and stow dir" => sub {
+    plan tests => 2;
+    my ($package, $path) =
+        $stow->link_dest_within_stow_dir("../alien");
+    is($path, "", "alien is outside, so path is empty");
+    is($package, "", "alien is outside, so package is empty");
+});