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
This commit is contained in:
Adam Spiers 2020-11-11 19:43:25 +00:00
parent 877fc0ce7e
commit 8436768144
4 changed files with 331 additions and 114 deletions

9
NEWS
View file

@ -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

View file

@ -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.
# : Must share a common prefix with $self->{stow_path}
# : $source => where that link points to (needed because link
# Parameters: $target => path to a symbolic link somewhere under
# : the target directory, relative to the
# : 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
# : expressed relative to (the directory containing)
# : $target.
# Returns : ($path, $stow_path, $package) where $path and $stow_path are
# : relative from the current (i.e. target) directory. $path
# : is the full relative path, $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
# : so we can't just call readlink()). If this is
# : owned by Stow, it will be expressed relative to
# : (the directory containing) $target. However if
# : it's not, it could of course be relative or absolute,
# : point absolutely anywhere, and could even be
# : dangling.
# Returns : ($path, $stow_path, $package) where $path and $stow_path
# : 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.
# : We could put more logic under here for multiple stow dirs.
# Comments : cwd must be the top-level target directory, otherwise
# : 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
my $path = join_paths(parent($target), $source);
debug(4, 2, "is path $path owned by stow?");
# 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);
}
}
# 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
# a prefix of $self->{stow_path}.
if (substr($path, 0, 1) eq '/' xor substr($self->{stow_path}, 0, 1) eq '/')
{
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 ('', '', '');
}
}
if (@stow_path) { # @path must be empty
debug(4, 3, "no - $path is not under $self->{stow_path}");
if (substr($ldest, 0, 1) eq '/') {
# Symlink points to an absolute path, therefore it cannot be
# owned by Stow.
return ('', '', '');
}
my $package = shift @path;
# 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?");
debug(4, 3, "yes - by $package in " . join_paths(@path));
return ($path, $self->{stow_path}, $package);
# 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
my ($stow_path, $ext_package) = $self->find_containing_marked_stow_dir($dest);
if (length $stow_path) {
debug(5, 5, "yes - $stow_path in $dest was marked as a stow dir; package=$ext_package");
return ($dest, $stow_path, $ext_package);
}
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 ('', '');
}
debug(4, 4, "remaining after removing $self->{stow_path}: $ldest");
my @dirs = File::Spec->splitdir($ldest);
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 = $segments[$last_segment + 1];
return ($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);
if (not $source) {
my $ldest = readlink($node_path);
if (not $ldest) {
error("Could not read link $node_path");
}
if (-e join_paths($dir, $source)) {
debug(4, 2, "Link target $source exists; skipping clean up");
my $target = join_paths($dir, $ldest);
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 => " .
join_paths($dir, $source));
debug(2, 0, "--- removing link owned by $owner: $node_path => " .
join_paths($dir, $ldest));
$self->do_unlink($node_path);
}
}

View file

@ -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");
#set_debug_level(4);
subtest("find link to a stowed path with relative target" => sub {
plan tests => 3;
my ($path, $stow_path, $package) =
$stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../../stow/a/b/c");
is($path, "$TEST_DIR/stow/a/b/c", "path");
is($stow_path, "$TEST_DIR/stow", "stow path");
is($package, "a", "package");
# This is a relative path, unlike $ABS_TEST_DIR below.
my $target = "$TEST_DIR/target";
cd("$TEST_DIR/target");
$stow->set_stow_dir("../stow");
($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($stow_path, "../stow", "stow path from target directory");
is($package, "a", "from target directory");
my $stow = new_Stow(dir => "$TEST_DIR/stow", target => $target);
my ($path, $stow_path, $package) =
$stow->find_stowed_path("a/b/c", "../../../stow/a/b/c");
is($path, "../stow/a/b/c", "path");
is($stow_path, "../stow", "stow path");
is($package, "a", "package");
});
make_path("stow");
cd("../..");
$stow->set_stow_dir("$TEST_DIR/target/stow");
my $stow = new_Stow(dir => "$ABS_TEST_DIR/stow", target => "$ABS_TEST_DIR/target");
($path, $stow_path, $package) =
$stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../stow/a/b/c");
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");
# Required by creation of stow2 and stow2/.stow below
cd("$ABS_TEST_DIR/target");
($path, $stow_path, $package) =
$stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../empty");
is($path, "", "empty path");
is($stow_path, "", "empty stow path");
is($package, "", "target is not stowed");
subtest("find link to a stowed path" => sub {
plan tests => 3;
my ($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($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
# directory are detected correctly.
make_path("$TEST_DIR/target/stow2");
make_file("$TEST_DIR/target/stow2/.stow");
# can check that links to package files within that stow directory are
# detected correctly.
make_path("stow2");
($path, $stow_path, $package) =
$stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../stow2/a/b/c");
is($path, "$TEST_DIR/target/stow2/a/b/c", "path");
is($stow_path, "$TEST_DIR/target/stow2", "stow path");
is($package, "a", "detect alternate stow directory");
# However this second stow directory is still "alien" to stow until we
# put a .stow file in it. So first test a symlink pointing to a path
# within this second stow directory
subtest("second stow dir still alien without .stow" => sub {
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
# stow dir.
($path, $stow_path, $package) =
$stow->find_stowed_path("$TEST_DIR/target/a/b/c", "../../..");
is($path, "", "path");
is($stow_path, "", "stow path");
is($package, "", "corner case - link points to ancestor of stow dir");
# Now make stow2 a secondary stow directory and test that
make_file("stow2/.stow");
subtest(".stow makes second stow dir owned by Stow" => 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");
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");
});

88
t/link_dest_within_stow_dir.t Executable file
View file

@ -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");
});