Merge pull request #107 from aspiers/improve-dotfiles-fix

This commit is contained in:
Adam Spiers 2024-04-07 17:56:54 +01:00 committed by GitHub
commit 143dbf83e2
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
13 changed files with 600 additions and 797 deletions

3
.gitignore vendored
View file

@ -9,7 +9,8 @@
/bin/stow /bin/stow
/doc/stow.info /doc/stow.info
/doc/version.texi /doc/version.texi
tmp-testing-trees/ /playground/
tmp-testing-trees*/
_build/ _build/
autom4te.cache/ autom4te.cache/
blib/ blib/

View file

@ -85,6 +85,11 @@ or to run the whole suite:
However currently there is an issue where this interferes with However currently there is an issue where this interferes with
`TEST_VERBOSE`. `TEST_VERBOSE`.
If you want to create test files for experimentation, it is
recommended to put them in a subdirectory called `playground/` since
this will be automatically ignored by git and the build process,
avoiding any undesirable complications.
Translating Stow Translating Stow
---------------- ----------------

View file

@ -50,7 +50,6 @@ t/stow.t
t/rc_options.t t/rc_options.t
t/testutil.pm t/testutil.pm
t/unstow.t t/unstow.t
t/unstow_orig.t
tools/get-version tools/get-version
THANKS THANKS
TODO TODO

View file

@ -83,16 +83,14 @@
^doc/HOWTO-RELEASE$ ^doc/HOWTO-RELEASE$
# Avoid test files # Avoid test files
tmp-testing-trees tmp-testing-trees*
.coveralls.yml ^.coveralls.yml
.github/workflows/ ^.github/workflows/
.travis.yml ^.travis.yml
^docker/ ^docker/
^[a-zA-Z]*-docker.sh ^[a-zA-Z]*-docker.sh
^playground/
# Avoid development config # Avoid development config
.dir-locals.el ^.dir-locals.el
.dumbjump ^.dumbjump
# Avoid CI
.github/

View file

@ -51,7 +51,7 @@ DEFAULT_IGNORE_LIST = $(srcdir)/default-ignore-list
doc_deps = $(info_TEXINFOS) doc/version.texi $(DEFAULT_IGNORE_LIST) doc_deps = $(info_TEXINFOS) doc/version.texi $(DEFAULT_IGNORE_LIST)
TESTS_DIR = $(srcdir)/t TESTS_DIR = $(srcdir)/t
TESTS_OUT = tmp-testing-trees TESTS_OUT = tmp-testing-trees tmp-testing-trees-compat
TESTS_ENVIRONMENT = $(PERL) -Ibin -Ilib -I$(TESTS_DIR) TESTS_ENVIRONMENT = $(PERL) -Ibin -Ilib -I$(TESTS_DIR)
# This is a kind of hack; TESTS needs to be set to ensure that the # This is a kind of hack; TESTS needs to be set to ensure that the

View file

@ -16,10 +16,9 @@
# Build docker image: `docker build -t stowtest` # Build docker image: `docker build -t stowtest`
# Run tests: (from stow src directory) # Run tests: (from stow src directory)
# `docker run --rm -it -v $(pwd):$(pwd) -w $(pwd) stowtest` # `docker run --rm -it -v $(pwd):$(pwd) -w $(pwd) stowtest`
FROM debian:jessie FROM debian:bookworm
RUN printf "deb http://archive.debian.org/debian/ jessie main\ndeb-src http://archive.debian.org/debian/ jessie main\ndeb http://security.debian.org jessie/updates main\ndeb-src http://security.debian.org jessie/updates main" > /etc/apt/sources.list RUN DEBIAN_FRONTEND=noninteractive apt-get update -qq
RUN DEBIAN_FRONTEND=noninteractive \ RUN DEBIAN_FRONTEND=noninteractive \
apt-get update -qq && \
apt-get install -y -q \ apt-get install -y -q \
autoconf \ autoconf \
bzip2 \ bzip2 \

View file

@ -56,7 +56,8 @@ use File::Spec;
use POSIX qw(getcwd); use POSIX qw(getcwd);
use Stow::Util qw(set_debug_level debug error set_test_mode use Stow::Util qw(set_debug_level debug error set_test_mode
join_paths restore_cwd canon_path parent adjust_dotfile); join_paths restore_cwd canon_path parent
adjust_dotfile unadjust_dotfile);
our $ProgramName = 'stow'; our $ProgramName = 'stow';
our $VERSION = '@VERSION@'; our $VERSION = '@VERSION@';
@ -284,7 +285,7 @@ sub plan_unstow {
$self->unstow_contents( $self->unstow_contents(
$package, $package,
'.', '.',
$pkg_path, '.',
); );
debug(2, 0, "Planning unstow of package $package... done"); debug(2, 0, "Planning unstow of package $package... done");
$self->{action_count}++; $self->{action_count}++;
@ -319,8 +320,7 @@ sub plan_stow {
$self->{stow_path}, $self->{stow_path},
$package, $package,
'.', '.',
$pkg_path, # source from target '.',
0,
); );
debug(2, 0, "Planning stow of package $package... done"); debug(2, 0, "Planning stow of package $package... done");
$self->{action_count}++; $self->{action_count}++;
@ -361,7 +361,7 @@ sub within_target_do {
debug(3, 0, "cwd restored to $cwd"); debug(3, 0, "cwd restored to $cwd");
} }
=head2 stow_contents($stow_path, $package, $target_subdir, $source) =head2 stow_contents($stow_path, $package, $pkg_subdir, $target_subdir)
Stow the contents of the given directory. Stow the contents of the given directory.
@ -379,55 +379,48 @@ Stow Directories" section of the manual).
The package whose contents are being stowed. The package whose contents are being stowed.
=item $pkg_subdir
Subdirectory of the installation image in the package directory which
needs stowing as a symlink which points to it. This is relative to
the top-level package directory.
=item $target_subdir =item $target_subdir
Subpath relative to package directory which needs stowing as a symlink Subdirectory of the target directory which either needs a symlink to the
at subpath relative to target directory. corresponding package subdirectory in the installation image, or if
it's an existing directory, it's an unfolded tree which may need to
=item $source be folded or recursed into.
Relative path from the (sub)dir of target to symlink source.
=back =back
C<stow_node()> and C<stow_contents()> are mutually recursive. C<stow_node()> and C<stow_contents()> are mutually recursive.
C<$source> and C<$target_subdir> are used for creating the symlink.
=cut =cut
sub stow_contents { sub stow_contents {
my $self = shift; my $self = shift;
my ($stow_path, $package, $target_subdir, $source, $level) = @_; my ($stow_path, $package, $pkg_subdir, $target_subdir) = @_;
return if $self->should_skip_target($pkg_subdir);
my $cwd = getcwd();
my $msg = "Stowing contents of $stow_path / $package / $pkg_subdir (cwd=$cwd)";
$msg =~ s!$ENV{HOME}(/|$)!~$1!g;
debug(3, 0, $msg);
debug(4, 1, "target subdir is $target_subdir");
# Calculate the path to the package directory or sub-directory # Calculate the path to the package directory or sub-directory
# whose contents need to be stowed, relative to the current # whose contents need to be stowed, relative to the current
# (target directory). This is needed so that we can check it's a # (target directory). This is needed so that we can check it's a
# valid directory, and can read its contents to iterate over them. # valid directory, and can read its contents to iterate over them.
# my $pkg_path_from_cwd = join_paths($stow_path, $package, $pkg_subdir);
# Note that $source refers to the same package (sub-)directory,
# but instead it's relative to the target directory or
# sub-directory where the symlink will be installed when the plans
# are executed.
# Remove leading $level times .. from $source
my $n = 0;
my $path = join '/', map { (++$n <= $level) ? ( ) : $_ } (split m{/+}, $source);
return if $self->should_skip_target($target_subdir);
my $cwd = getcwd();
my $msg = "Stowing contents of $path (cwd=$cwd)";
$msg =~ s!$ENV{HOME}(/|$)!~$1!g;
debug(3, 0, $msg);
debug(4, 1, "=> $source");
error("stow_contents() called with non-directory package path: $path")
unless -d $path;
error("stow_contents() called with non-directory target: $target_subdir") error("stow_contents() called with non-directory target: $target_subdir")
unless $self->is_a_node($target_subdir); unless $self->is_a_node($target_subdir);
opendir my $DIR, $path opendir my $DIR, $pkg_path_from_cwd
or error("cannot read directory: $path ($!)"); or error("cannot read directory: $pkg_path_from_cwd ($!)");
my @listing = readdir $DIR; my @listing = readdir $DIR;
closedir $DIR; closedir $DIR;
@ -435,26 +428,31 @@ sub stow_contents {
for my $node (sort @listing) { for my $node (sort @listing) {
next NODE if $node eq '.'; next NODE if $node eq '.';
next NODE if $node eq '..'; next NODE if $node eq '..';
my $node_target = join_paths($target_subdir, $node);
next NODE if $self->ignore($stow_path, $package, $node_target); my $package_node_path = join_paths($pkg_subdir, $node);
my $target_node = $node;
if ($self->{dotfiles}) { if ($self->{dotfiles}) {
my $adj_node_target = adjust_dotfile($node_target); my $adjusted = adjust_dotfile($node);
debug(4, 1, "Adjusting: $node_target => $adj_node_target"); if ($adjusted ne $node) {
$node_target = $adj_node_target; debug(4, 1, "Adjusting: $node => $adjusted");
$target_node = $adjusted;
} }
}
my $target_node_path = join_paths($target_subdir, $target_node);
next NODE if $self->ignore($stow_path, $package, $target_node_path);
$self->stow_node( $self->stow_node(
$stow_path, $stow_path,
$package, $package,
$node_target, # target, potentially adjusted for dot- prefix $package_node_path,
join_paths($source, $node), # source $target_node_path
$level
); );
} }
} }
=head2 stow_node($stow_path, $package, $target_subpath, $source) =head2 stow_node($stow_path, $package, $pkg_subpath, $target_subpath)
Stow the given node Stow the given node
@ -470,16 +468,20 @@ Stow Directories" section of the manual).
=item $package =item $package
The package containing the node being stowed The package containing the node being stowed.
=item $pkg_subpath
Subpath of the installation image in the package directory which needs
stowing as a symlink which points to it. This is relative to the
top-level package directory.
=item $target_subpath =item $target_subpath
Subpath relative to package directory of node which needs stowing as a Subpath of the target directory which either needs a symlink to the
symlink at subpath relative to target directory. corresponding package subpathectory in the installation image, or if
it's an existing directory, it's an unfolded tree which may need to
=item $source be folded or recursed into.
Relative path to symlink source from the dir of target.
=back =back
@ -489,27 +491,42 @@ C<stow_node()> and C<stow_contents()> are mutually recursive.
sub stow_node { sub stow_node {
my $self = shift; my $self = shift;
my ($stow_path, $package, $target_subpath, $source, $level) = @_; my ($stow_path, $package, $pkg_subpath, $target_subpath) = @_;
my $path = join_paths($stow_path, $package, $target_subpath); debug(3, 0, "Stowing entry $stow_path / $package / $pkg_subpath");
# Calculate the path to the package directory or sub-directory
debug(3, 0, "Stowing entry $stow_path / $package / $target_subpath"); # whose contents need to be stowed, relative to the current
debug(4, 1, "=> $source"); # (target directory). This is needed so that we can check it's a
# valid directory, and can read its contents to iterate over them.
my $pkg_path_from_cwd = join_paths($stow_path, $package, $pkg_subpath);
# Don't try to stow absolute symlinks (they can't be unstowed) # Don't try to stow absolute symlinks (they can't be unstowed)
if (-l $source) { if (-l $pkg_path_from_cwd) {
my $link_dest = $self->read_a_link($source); my $link_dest = $self->read_a_link($pkg_path_from_cwd);
if ($link_dest =~ m{\A/}) { if ($link_dest =~ m{\A/}) {
$self->conflict( $self->conflict(
'stow', 'stow',
$package, $package,
"source is an absolute symlink $source => $link_dest" "source is an absolute symlink $pkg_path_from_cwd => $link_dest"
); );
debug(3, 0, "Absolute symlinks cannot be unstowed"); debug(3, 0, "Absolute symlinks cannot be unstowed");
return; return;
} }
} }
# How many directories deep are we?
my $level = ($pkg_subpath =~ tr,/,,);
debug(2, 1, "level of $pkg_subpath is $level");
# Calculate the destination of the symlink which would need to be
# installed within this directory in the absence of folding. This
# is relative to the target (sub-)directory where the symlink will
# be installed when the plans are executed, so as we descend down
# into the package hierarchy, it will have extra "../" segments
# prefixed to it.
my $link_dest = join_paths('../' x $level, $pkg_path_from_cwd);
debug(4, 1, "link destination $link_dest");
# Does the target already exist? # Does the target already exist?
if ($self->is_a_link($target_subpath)) { if ($self->is_a_link($target_subpath)) {
# Where is the link pointing? # Where is the link pointing?
@ -533,8 +550,8 @@ sub stow_node {
# Does the existing $target_subpath actually point to anything? # Does the existing $target_subpath actually point to anything?
if ($self->is_a_node($existing_pkg_path_from_cwd)) { if ($self->is_a_node($existing_pkg_path_from_cwd)) {
if ($existing_link_dest eq $source) { if ($existing_link_dest eq $link_dest) {
debug(2, 0, "--- Skipping $target_subpath as it already points to $source"); debug(2, 0, "--- Skipping $target_subpath as it already points to $link_dest");
} }
elsif ($self->defer($target_subpath)) { elsif ($self->defer($target_subpath)) {
debug(2, 0, "--- Deferring installation of: $target_subpath"); debug(2, 0, "--- Deferring installation of: $target_subpath");
@ -542,10 +559,10 @@ sub stow_node {
elsif ($self->override($target_subpath)) { elsif ($self->override($target_subpath)) {
debug(2, 0, "--- Overriding installation of: $target_subpath"); debug(2, 0, "--- Overriding installation of: $target_subpath");
$self->do_unlink($target_subpath); $self->do_unlink($target_subpath);
$self->do_link($source, $target_subpath); $self->do_link($link_dest, $target_subpath);
} }
elsif ($self->is_a_dir(join_paths(parent($target_subpath), $existing_link_dest)) && elsif ($self->is_a_dir(join_paths(parent($target_subpath), $existing_link_dest)) &&
$self->is_a_dir(join_paths(parent($target_subpath), $source))) $self->is_a_dir(join_paths(parent($target_subpath), $link_dest)))
{ {
# If the existing link points to a directory, # If the existing link points to a directory,
@ -558,16 +575,14 @@ sub stow_node {
$self->stow_contents( $self->stow_contents(
$existing_stow_path, $existing_stow_path,
$existing_package, $existing_package,
$pkg_subpath,
$target_subpath, $target_subpath,
join_paths('..', $existing_link_dest),
$level + 1,
); );
$self->stow_contents( $self->stow_contents(
$self->{stow_path}, $self->{stow_path},
$package, $package,
$pkg_subpath,
$target_subpath, $target_subpath,
join_paths('..', $source),
$level + 1,
); );
} }
else { else {
@ -581,48 +596,68 @@ sub stow_node {
} }
else { else {
# The existing link is invalid, so replace it with a good link # The existing link is invalid, so replace it with a good link
debug(2, 0, "--- replacing invalid link: $path"); debug(2, 0, "--- replacing invalid link: $target_subpath");
$self->do_unlink($target_subpath); $self->do_unlink($target_subpath);
$self->do_link($source, $target_subpath); $self->do_link($link_dest, $target_subpath);
} }
} }
elsif ($self->is_a_node($target_subpath)) { elsif ($self->is_a_node($target_subpath)) {
debug(4, 1, "Evaluate existing node: $target_subpath"); debug(4, 1, "Evaluate existing node: $target_subpath");
if ($self->is_a_dir($target_subpath)) { if ($self->is_a_dir($target_subpath)) {
$self->stow_contents( if (! -d $pkg_path_from_cwd) {
$self->{stow_path}, # FIXME: why wasn't this ever needed before?
$self->conflict(
'stow',
$package, $package,
$target_subpath, "cannot stow non-directory $pkg_path_from_cwd over existing directory target $target_subpath"
join_paths('..', $source),
$level + 1,
); );
} }
else { else {
$self->stow_contents(
$self->{stow_path},
$package,
$pkg_subpath,
$target_subpath,
);
}
}
else {
# If we're here, $target_subpath is not a current or
# planned directory.
if ($self->{adopt}) { if ($self->{adopt}) {
$self->do_mv($target_subpath, $path); if (-d $pkg_path_from_cwd) {
$self->do_link($source, $target_subpath); $self->conflict(
'stow',
$package,
"cannot stow directory $pkg_path_from_cwd over existing non-directory target $target_subpath"
);
}
else {
$self->do_mv($target_subpath, $pkg_path_from_cwd);
$self->do_link($link_dest, $target_subpath);
}
} }
else { else {
$self->conflict( $self->conflict(
'stow', 'stow',
$package, $package,
"existing target is neither a link nor a directory: $target_subpath" "cannot stow $pkg_path_from_cwd over existing target $target_subpath since neither a link nor a directory and --adopt not specified"
); );
} }
} }
} }
elsif ($self->{'no-folding'} && -d $path && ! -l $path) { elsif ($self->{'no-folding'} && -d $pkg_path_from_cwd && ! -l $pkg_path_from_cwd) {
$self->do_mkdir($target_subpath); $self->do_mkdir($target_subpath);
$self->stow_contents( $self->stow_contents(
$self->{stow_path}, $self->{stow_path},
$package, $package,
$pkg_subpath,
$target_subpath, $target_subpath,
join_paths('..', $source),
$level + 1,
); );
} }
else { else {
$self->do_link($source, $target_subpath); $self->do_link($link_dest, $target_subpath);
} }
return; return;
} }
@ -684,7 +719,7 @@ sub marked_stow_dir {
return 0; return 0;
} }
=head2 unstow_contents($package, $target) =head2 unstow_contents($package, $pkg_subdir, $target_subdir)
Unstow the contents of the given directory Unstow the contents of the given directory
@ -694,9 +729,18 @@ Unstow the contents of the given directory
The package whose contents are being unstowed. The package whose contents are being unstowed.
=item $target =item $pkg_subdir
Relative path to symlink target from the current directory. Subdirectory of the installation image in the package directory which
may need a symlink pointing to it to be unstowed. This is relative to
the top-level package directory.
=item $target_subdir
Subdirectory of the target directory which either needs unstowing of a
symlink to the corresponding package subdirectory in the installation
image, or if it's an existing directory, it's an unfolded tree which
may need to be recursed into.
=back =back
@ -707,15 +751,21 @@ Here we traverse the package tree, rather than the target tree.
sub unstow_contents { sub unstow_contents {
my $self = shift; my $self = shift;
my ($package, $target_subdir, $path) = @_; my ($package, $pkg_subdir, $target_subdir) = @_;
return if $self->should_skip_target($target_subdir); return if $self->should_skip_target($target_subdir);
my $cwd = getcwd(); my $cwd = getcwd();
my $msg = "Unstowing from $target_subdir (cwd=$cwd, stow dir=$self->{stow_path})"; my $msg = "Unstowing contents of $self->{stow_path} / $package / $pkg_subdir (cwd=$cwd" . ($self->{compat} ? ', compat' : '') . ")";
$msg =~ s!$ENV{HOME}/!~/!g; $msg =~ s!$ENV{HOME}/!~/!g;
debug(3, 0, $msg); debug(3, 0, $msg);
debug(4, 1, "source path is $path"); debug(4, 1, "target subdir is $target_subdir");
# Calculate the path to the package directory or sub-directory
# whose contents need to be unstowed, relative to the current
# (target directory). This is needed so that we can check it's a
# valid directory, and can read its contents to iterate over them.
my $pkg_path_from_cwd = join_paths($self->{stow_path}, $package, $pkg_subdir);
if ($self->{compat}) { if ($self->{compat}) {
# In compat mode we traverse the target tree not the source tree, # In compat mode we traverse the target tree not the source tree,
@ -725,9 +775,10 @@ sub unstow_contents {
unless -d $target_subdir; unless -d $target_subdir;
} }
else { else {
# We traverse the source tree not the target tree, so $path must exist. # We traverse the package installation image tree not the
error("unstow_contents() called with non-directory path: $path") # target tree, so $pkg_path_from_cwd must exist.
unless -d $path; error("unstow_contents() called with non-directory path: $pkg_path_from_cwd")
unless -d $pkg_path_from_cwd;
# When called at the top level, $target_subdir should exist. And # When called at the top level, $target_subdir should exist. And
# unstow_node() should only call this via mutual recursion if # unstow_node() should only call this via mutual recursion if
@ -736,7 +787,7 @@ sub unstow_contents {
unless $self->is_a_node($target_subdir); unless $self->is_a_node($target_subdir);
} }
my $dir = $self->{compat} ? $target_subdir : $path; my $dir = $self->{compat} ? $target_subdir : $pkg_path_from_cwd;
opendir my $DIR, $dir opendir my $DIR, $dir
or error("cannot read directory: $dir ($!)"); or error("cannot read directory: $dir ($!)");
my @listing = readdir $DIR; my @listing = readdir $DIR;
@ -746,16 +797,41 @@ sub unstow_contents {
for my $node (sort @listing) { for my $node (sort @listing) {
next NODE if $node eq '.'; next NODE if $node eq '.';
next NODE if $node eq '..'; next NODE if $node eq '..';
my $node_target = join_paths($target_subdir, $node);
next NODE if $self->ignore($self->{stow_path}, $package, $node_target); my $package_node = $node;
my $target_node = $node;
if ($self->{dotfiles}) { if ($self->{dotfiles}) {
my $adj_node_target = adjust_dotfile($node_target); if ($self->{compat}) {
debug(4, 1, "Adjusting: $node_target => $adj_node_target"); # $node is in the target tree, so we need to reverse
$node_target = $adj_node_target; # adjust any .* files in case they came from a dot-*
# file.
my $adjusted = unadjust_dotfile($node);
if ($adjusted ne $node) {
debug(4, 1, "Reverse adjusting: $node => $adjusted");
$package_node = $adjusted;
} }
}
else {
# $node is in the package tree, so adjust any dot-*
# files for the target.
my $adjusted = adjust_dotfile($node);
if ($adjusted ne $node) {
debug(4, 1, "Adjusting: $node => $adjusted");
$target_node = $adjusted;
}
}
}
my $package_node_path = join_paths($pkg_subdir, $package_node);
my $target_node_path = join_paths($target_subdir, $target_node);
$self->unstow_node($package, $node_target, join_paths($path, $node)); next NODE if $self->ignore($self->{stow_path}, $package, $target_node_path);
$self->unstow_node(
$package,
$package_node_path,
$target_node_path
);
} }
if (! $self->{compat} && -d $target_subdir) { if (! $self->{compat} && -d $target_subdir) {
@ -763,7 +839,7 @@ sub unstow_contents {
} }
} }
=head2 unstow_node($package, $target_subpath) =head2 unstow_node($package, $pkg_subpath, $target_subpath)
Unstow the given node. Unstow the given node.
@ -773,9 +849,18 @@ Unstow the given node.
The package containing the node being unstowed. The package containing the node being unstowed.
=item $pkg_subpath
Subpath of the installation image in the package directory which needs
stowing as a symlink which points to it. This is relative to the
top-level package directory.
=item $target_subpath =item $target_subpath
Relative path to symlink target from the current directory. Subpath of the target directory which either needs a symlink to the
corresponding package subpathectory in the installation image, or if
it's an existing directory, it's an unfolded tree which may need to
be folded or recursed into.
=back =back
@ -785,19 +870,19 @@ C<unstow_node()> and C<unstow_contents()> are mutually recursive.
sub unstow_node { sub unstow_node {
my $self = shift; my $self = shift;
my ($package, $target_subpath, $source) = @_; my ($package, $pkg_subpath, $target_subpath) = @_;
my $pkg_path_from_cwd = join_paths($self->{stow_path}, $package, $target_subpath);
debug(3, 1, "Unstowing $pkg_path_from_cwd");
debug(4, 2, "target is $target_subpath");
debug(3, 0, "Unstowing entry from target: $target_subpath");
debug(4, 1, "Package entry: $self->{stow_path} / $package / $pkg_subpath");
# Calculate the path to the package directory or sub-directory
# whose contents need to be unstowed, relative to the current
# (target directory).
# Does the target exist? # Does the target exist?
if ($self->is_a_link($target_subpath)) { if ($self->is_a_link($target_subpath)) {
$self->unstow_link_node($package, $target_subpath, $pkg_path_from_cwd); $self->unstow_link_node($package, $pkg_subpath, $target_subpath);
} }
elsif ($self->{compat} && -d $target_subpath) { elsif (-d $target_subpath) {
$self->unstow_contents($package, $target_subpath, $pkg_path_from_cwd); $self->unstow_contents($package, $pkg_subpath, $target_subpath);
# This action may have made the parent directory foldable # This action may have made the parent directory foldable
if (my $parent_in_pkg = $self->foldable($target_subpath)) { if (my $parent_in_pkg = $self->foldable($target_subpath)) {
@ -805,16 +890,7 @@ sub unstow_node {
} }
} }
elsif (-e $target_subpath) { elsif (-e $target_subpath) {
if ($self->{compat}) { debug(2, 1, "$target_subpath doesn't need to be unstowed");
$self->conflict(
'unstow',
$package,
"existing target is neither a link nor a directory: $target_subpath",
);
}
else {
$self->unstow_existing_node($package, $target_subpath, $source);
}
} }
else { else {
debug(2, 1, "$target_subpath did not exist to be unstowed"); debug(2, 1, "$target_subpath did not exist to be unstowed");
@ -823,7 +899,7 @@ sub unstow_node {
sub unstow_link_node { sub unstow_link_node {
my $self = shift; my $self = shift;
my ($package, $target_subpath, $pkg_path_from_cwd) = @_; my ($package, $pkg_subpath, $target_subpath) = @_;
debug(4, 2, "Evaluate existing link: $target_subpath"); debug(4, 2, "Evaluate existing link: $target_subpath");
# Where is the link pointing? # Where is the link pointing?
@ -841,25 +917,24 @@ sub unstow_link_node {
my ($existing_pkg_path_from_cwd, $existing_stow_path, $existing_package) = my ($existing_pkg_path_from_cwd, $existing_stow_path, $existing_package) =
$self->find_stowed_path($target_subpath, $link_dest); $self->find_stowed_path($target_subpath, $link_dest);
if (not $existing_pkg_path_from_cwd) { if (not $existing_pkg_path_from_cwd) {
if ($self->{compat}) { # The user is unstowing the package, so they don't want links to it.
# We're traversing the target tree not the package tree, # Therefore we should allow them to have a link pointing elsewhere
# so we definitely expect to find stuff not owned by stow. # which would conflict with the package if they were stowing it.
# Therefore we can't flag a conflict. debug(5, 3, "Ignoring unowned link $target_subpath => $link_dest");
return;
}
else {
$self->conflict(
'unstow',
$package,
"existing target is not owned by stow: $target_subpath => $link_dest"
);
}
return; return;
} }
my $pkg_path_from_cwd = join_paths($self->{stow_path}, $package, $pkg_subpath);
# Does the existing $target_subpath actually point to anything? # Does the existing $target_subpath actually point to anything?
if (-e $existing_pkg_path_from_cwd) { if (-e $existing_pkg_path_from_cwd) {
$self->unstow_valid_link($pkg_path_from_cwd, $target_subpath, $existing_pkg_path_from_cwd); if ($existing_pkg_path_from_cwd eq $pkg_path_from_cwd) {
# It points to the package we're unstowing, so unstow the link.
$self->do_unlink($target_subpath);
}
else {
debug(5, 3, "Ignoring link $target_subpath => $link_dest");
}
} }
else { else {
debug(2, 0, "--- removing invalid link into a stow directory: $pkg_path_from_cwd"); debug(2, 0, "--- removing invalid link into a stow directory: $pkg_path_from_cwd");
@ -867,61 +942,6 @@ sub unstow_link_node {
} }
} }
sub unstow_valid_link {
my $self = shift;
my ($pkg_path_from_cwd, $target_subpath, $existing_pkg_path_from_cwd) = @_;
# Does link points to the right place?
# Adjust for dotfile if necessary.
if ($self->{dotfiles}) {
$existing_pkg_path_from_cwd = adjust_dotfile($existing_pkg_path_from_cwd);
}
if ($existing_pkg_path_from_cwd eq $pkg_path_from_cwd) {
$self->do_unlink($target_subpath);
}
# FIXME: we quietly ignore links that are stowed to a different
# package.
#elsif (defer($target_subpath)) {
# debug(2, 0, "--- deferring to installation of: $target_subpath");
#}
#elsif ($self->override($target_subpath)) {
# debug(2, 0, "--- overriding installation of: $target_subpath");
# $self->do_unlink($target_subpath);
#}
#else {
# $self->conflict(
# 'unstow',
# $package,
# "existing target is stowed to a different package: "
# . "$target_subpath => $existing_source"
# );
#}
}
sub unstow_existing_node {
my $self = shift;
my ($package, $target_subpath, $source) = @_;
debug(4, 2, "Evaluate existing node: $target_subpath");
if (-d $target_subpath) {
$self->unstow_contents($package, $target_subpath, $source);
# This action may have made the parent directory foldable
if (my $parent_in_pkg = $self->foldable($target_subpath)) {
$self->fold_tree($target_subpath, $parent_in_pkg);
}
}
else {
$self->conflict(
'unstow',
$package,
"existing target is neither a link nor a directory: $target_subpath",
);
}
}
=head2 link_owned_by_package($target_subpath, $link_dest) =head2 link_owned_by_package($target_subpath, $link_dest)
Determine whether the given link points to a member of a stowed Determine whether the given link points to a member of a stowed
@ -2078,7 +2098,7 @@ sub read_a_link {
} }
} }
elsif (-l $link) { elsif (-l $link) {
debug(4, 2, "read_a_link($link): real link"); debug(4, 2, "read_a_link($link): is a real link");
my $link_dest = readlink $link or error("Could not read link: $link ($!)"); my $link_dest = readlink $link or error("Could not read link: $link ($!)");
return $link_dest; return $link_dest;
} }

View file

@ -38,7 +38,8 @@ use POSIX qw(getcwd);
use base qw(Exporter); use base qw(Exporter);
our @EXPORT_OK = qw( our @EXPORT_OK = qw(
error debug set_debug_level set_test_mode error debug set_debug_level set_test_mode
join_paths parent canon_path restore_cwd adjust_dotfile join_paths parent canon_path restore_cwd
adjust_dotfile unadjust_dotfile
); );
our $ProgramName = 'stow'; our $ProgramName = 'stow';
@ -239,17 +240,17 @@ sub restore_cwd {
} }
sub adjust_dotfile { sub adjust_dotfile {
my ($link_dest) = @_; my ($pkg_node) = @_;
(my $adjusted = $pkg_node) =~ s/^dot-([^.])/.$1/;
return $adjusted;
}
my @result = (); # Needed when unstowing with --compat and --dotfiles
for my $part (split m{/+}, $link_dest) { sub unadjust_dotfile {
if (($part ne "dot-") && ($part ne "dot-.")) { my ($target_node) = @_;
$part =~ s/^dot-/./; return $target_node if $target_node =~ /^\.\.?$/;
} (my $adjusted = $target_node) =~ s/^\./dot-/;
push @result, $part; return $adjusted;
}
return join '/', @result;
} }
=head1 BUGS =head1 BUGS

View file

@ -22,27 +22,22 @@
use strict; use strict;
use warnings; use warnings;
use Test::More tests => 10; use Test::More tests => 12;
use English qw(-no_match_vars); use English qw(-no_match_vars);
use Stow::Util qw(adjust_dotfile); use Stow::Util qw(adjust_dotfile unadjust_dotfile);
use testutil; use testutil;
init_test_dirs(); init_test_dirs();
cd("$TEST_DIR/target"); cd("$TEST_DIR/target");
subtest('adjust_dotfile()', sub { subtest('adjust_dotfile()', sub {
plan tests => 9; plan tests => 4;
my @TESTS = ( my @TESTS = (
['file'], ['file'],
['dot-'],
['dot-.'],
['dot-file', '.file'], ['dot-file', '.file'],
['dir1/file'],
['dir1/dir2/file'],
['dir1/dir2/dot-file', 'dir1/dir2/.file'],
['dir1/dot-dir2/file', 'dir1/.dir2/file'],
['dir1/dot-dir2/dot-file', 'dir1/.dir2/.file'],
['dot-dir1/dot-dir2/dot-file', '.dir1/.dir2/.file'],
['dot-dir1/dot-dir2/file', '.dir1/.dir2/file'],
); );
for my $test (@TESTS) { for my $test (@TESTS) {
my ($input, $expected) = @$test; my ($input, $expected) = @$test;
@ -51,9 +46,24 @@ subtest('adjust_dotfile()', sub {
} }
}); });
subtest('unadjust_dotfile()', sub {
plan tests => 4;
my @TESTS = (
['file'],
['.'],
['..'],
['.file', 'dot-file'],
);
for my $test (@TESTS) {
my ($input, $expected) = @$test;
$expected ||= $input;
is(unadjust_dotfile($input), $expected);
}
});
my $stow; my $stow;
subtest("stow a dotfile marked with 'dot' prefix", sub { subtest("stow dot-foo as .foo", sub {
plan tests => 1; plan tests => 1;
$stow = new_Stow(dir => '../stow', dotfiles => 1); $stow = new_Stow(dir => '../stow', dotfiles => 1);
make_path('../stow/dotfiles'); make_path('../stow/dotfiles');
@ -68,7 +78,7 @@ subtest("stow a dotfile marked with 'dot' prefix", sub {
); );
}); });
subtest("ensure that turning off dotfile processing links files as usual", sub { subtest("stow dot-foo as dot-foo without --dotfile enabled", sub {
plan tests => 1; plan tests => 1;
$stow = new_Stow(dir => '../stow', dotfiles => 0); $stow = new_Stow(dir => '../stow', dotfiles => 0);
make_path('../stow/dotfiles'); make_path('../stow/dotfiles');
@ -81,10 +91,9 @@ subtest("ensure that turning off dotfile processing links files as usual", sub {
'../stow/dotfiles/dot-foo', '../stow/dotfiles/dot-foo',
=> 'unprocessed dotfile' => 'unprocessed dotfile'
); );
}); });
subtest("stow folder marked with 'dot' prefix", sub { subtest("stow dot-emacs dir as .emacs", sub {
plan tests => 1; plan tests => 1;
$stow = new_Stow(dir => '../stow', dotfiles => 1); $stow = new_Stow(dir => '../stow', dotfiles => 1);
@ -96,11 +105,11 @@ subtest("stow folder marked with 'dot' prefix", sub {
is( is(
readlink('.emacs'), readlink('.emacs'),
'../stow/dotfiles/dot-emacs', '../stow/dotfiles/dot-emacs',
=> 'processed dotfile folder' => 'processed dotfile dir'
); );
}); });
subtest("process folder marked with 'dot' prefix when directory exists is target", sub { subtest("stow dir marked with 'dot' prefix when directory exists in target", sub {
plan tests => 1; plan tests => 1;
$stow = new_Stow(dir => '../stow', dotfiles => 1); $stow = new_Stow(dir => '../stow', dotfiles => 1);
@ -113,11 +122,11 @@ subtest("process folder marked with 'dot' prefix when directory exists is target
is( is(
readlink('.emacs.d/init.el'), readlink('.emacs.d/init.el'),
'../../stow/dotfiles/dot-emacs.d/init.el', '../../stow/dotfiles/dot-emacs.d/init.el',
=> 'processed dotfile folder when folder exists (1 level)' => 'processed dotfile dir when dir exists (1 level)'
); );
}); });
subtest("process folder marked with 'dot' prefix when directory exists is target (2 levels)", sub { subtest("stow dir marked with 'dot' prefix when directory exists in target (2 levels)", sub {
plan tests => 1; plan tests => 1;
$stow = new_Stow(dir => '../stow', dotfiles => 1); $stow = new_Stow(dir => '../stow', dotfiles => 1);
@ -130,11 +139,11 @@ subtest("process folder marked with 'dot' prefix when directory exists is target
is( is(
readlink('.emacs.d/.emacs.d'), readlink('.emacs.d/.emacs.d'),
'../../stow/dotfiles/dot-emacs.d/dot-emacs.d', '../../stow/dotfiles/dot-emacs.d/dot-emacs.d',
=> 'processed dotfile folder exists (2 levels)' => 'processed dotfile dir exists (2 levels)'
); );
}); });
subtest("process folder marked with 'dot' prefix when directory exists is target", sub { subtest("stow dir marked with 'dot' prefix when directory exists in target", sub {
plan tests => 1; plan tests => 1;
$stow = new_Stow(dir => '../stow', dotfiles => 1); $stow = new_Stow(dir => '../stow', dotfiles => 1);
@ -147,7 +156,7 @@ subtest("process folder marked with 'dot' prefix when directory exists is target
is( is(
readlink('./.one/.two/three'), readlink('./.one/.two/three'),
'../../../stow/dotfiles/dot-one/dot-two/three', '../../../stow/dotfiles/dot-one/dot-two/three',
=> 'processed dotfile 2 folder exists (2 levels)' => 'processed dotfile 2 dir exists (2 levels)'
); );
}); });
@ -176,7 +185,7 @@ subtest("dot-. should not have that part expanded.", sub {
); );
}); });
subtest("simple unstow scenario", sub { subtest("unstow .bar from dot-bar", sub {
plan tests => 3; plan tests => 3;
$stow = new_Stow(dir => '../stow', dotfiles => 1); $stow = new_Stow(dir => '../stow', dotfiles => 1);
@ -187,11 +196,11 @@ subtest("simple unstow scenario", sub {
$stow->plan_unstow('dotfiles'); $stow->plan_unstow('dotfiles');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0);
ok(-f '../stow/dotfiles/dot-bar'); ok(-f '../stow/dotfiles/dot-bar', 'package file untouched');
ok(! -e '.bar' => 'unstow a simple dotfile'); ok(! -e '.bar' => '.bar was unstowed');
}); });
subtest("unstow process folder marked with 'dot' prefix when directory exists is target", sub { subtest("unstow dot-emacs.d/init.el when .emacs.d/init.el in target", sub {
plan tests => 4; plan tests => 4;
$stow = new_Stow(dir => '../stow', dotfiles => 1); $stow = new_Stow(dir => '../stow', dotfiles => 1);
@ -204,6 +213,23 @@ subtest("unstow process folder marked with 'dot' prefix when directory exists is
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0);
ok(-f '../stow/dotfiles/dot-emacs.d/init.el'); ok(-f '../stow/dotfiles/dot-emacs.d/init.el');
ok(! -e '.emacs.d/init.el'); ok(! -e '.emacs.d/init.el', '.emacs.d/init.el unstowed');
ok(-d '.emacs.d/' => 'unstow dotfile folder when folder already exists'); ok(-d '.emacs.d/' => '.emacs.d left behind');
});
subtest("unstow dot-emacs.d/init.el in --compat mode", sub {
plan tests => 4;
$stow = new_compat_Stow(dir => '../stow', dotfiles => 1);
make_path('../stow/dotfiles/dot-emacs.d');
make_file('../stow/dotfiles/dot-emacs.d/init.el');
make_path('.emacs.d');
make_link('.emacs.d/init.el', '../../stow/dotfiles/dot-emacs.d/init.el');
$stow->plan_unstow('dotfiles');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(-f '../stow/dotfiles/dot-emacs.d/init.el');
ok(! -e '.emacs.d/init.el', '.emacs.d/init.el unstowed');
ok(-d '.emacs.d/' => '.emacs.d left behind');
}); });

View file

@ -22,7 +22,7 @@
use strict; use strict;
use warnings; use warnings;
use Test::More tests => 21; use Test::More tests => 22;
use Test::Output; use Test::Output;
use English qw(-no_match_vars); use English qw(-no_match_vars);
@ -103,7 +103,7 @@ subtest("Package dir 'bin4' conflicts with existing non-dir so can't unfold", su
is($stow->get_conflict_count, 1); is($stow->get_conflict_count, 1);
like( like(
$conflicts{stow}{pkg4}[0], $conflicts{stow}{pkg4}[0],
qr/existing target is neither a link nor a directory/ qr!cannot stow ../stow/pkg4/bin4 over existing target bin4 since neither a link nor a directory and --adopt not specified!
=> 'link to new dir bin4 conflicts with existing non-directory' => 'link to new dir bin4 conflicts with existing non-directory'
); );
}); });
@ -111,8 +111,7 @@ subtest("Package dir 'bin4' conflicts with existing non-dir so can't unfold", su
subtest("Package dir 'bin4a' conflicts with existing non-dir " . subtest("Package dir 'bin4a' conflicts with existing non-dir " .
"so can't unfold even with --adopt", sub { "so can't unfold even with --adopt", sub {
plan tests => 2; plan tests => 2;
#my $stow = new_Stow(adopt => 1); my $stow = new_Stow(adopt => 1);
my $stow = new_Stow();
make_file('bin4a'); # this is a file but named like a directory make_file('bin4a'); # this is a file but named like a directory
make_path('../stow/pkg4a/bin4a'); make_path('../stow/pkg4a/bin4a');
@ -121,8 +120,9 @@ subtest("Package dir 'bin4a' conflicts with existing non-dir " .
$stow->plan_stow('pkg4a'); $stow->plan_stow('pkg4a');
%conflicts = $stow->get_conflicts(); %conflicts = $stow->get_conflicts();
is($stow->get_conflict_count, 1); is($stow->get_conflict_count, 1);
like($conflicts{stow}{pkg4a}[0], like(
qr/existing target is neither a link nor a directory/ $conflicts{stow}{pkg4a}[0],
qr!cannot stow directory ../stow/pkg4a/bin4a over existing non-directory target bin4a!
=> 'link to new dir bin4a conflicts with existing non-directory' => 'link to new dir bin4a conflicts with existing non-directory'
); );
}); });
@ -146,14 +146,42 @@ subtest("Package files 'file4b' and 'bin4b' conflict with existing files", sub {
%conflicts = $stow->get_conflicts(); %conflicts = $stow->get_conflicts();
is($stow->get_conflict_count, 2 => 'conflict per file'); is($stow->get_conflict_count, 2 => 'conflict per file');
for my $i (0, 1) { for my $i (0, 1) {
my $target = $i ? 'file4b' : 'bin4b/file4b';
like( like(
$conflicts{stow}{pkg4b}[$i], $conflicts{stow}{pkg4b}[$i],
qr/existing target is neither a link nor a directory/ qr,cannot stow ../stow/pkg4b/$target over existing target $target since neither a link nor a directory and --adopt not specified,
=> 'link to file4b conflicts with existing non-directory' => 'link to file4b conflicts with existing non-directory'
); );
} }
}); });
subtest("Package files 'file4d' conflicts with existing directories", sub {
plan tests => 3;
my $stow = new_Stow();
# Populate target
make_path('file4d'); # this is a directory but named like a file to create the conflict
make_path('bin4d/file4d'); # same here
# Populate stow package
make_path('../stow/pkg4d');
make_file('../stow/pkg4d/file4d', 'file4d - version originally in stow package');
make_path('../stow/pkg4d/bin4d');
make_file('../stow/pkg4d/bin4d/file4d', 'bin4d/file4d - version originally in stow package');
$stow->plan_stow('pkg4d');
%conflicts = $stow->get_conflicts();
is($stow->get_conflict_count, 2 => 'conflict per file');
for my $i (0, 1) {
my $target = $i ? 'file4d' : 'bin4d/file4d';
like(
$conflicts{stow}{pkg4d}[$i],
qr!cannot stow non-directory ../stow/pkg4d/$target over existing directory target $target!
=> 'link to file4d conflicts with existing non-directory'
);
}
});
subtest("Package files 'file4c' and 'bin4c' can adopt existing versions", sub { subtest("Package files 'file4c' and 'bin4c' can adopt existing versions", sub {
plan tests => 8; plan tests => 8;
my $stow = new_Stow(adopt => 1); my $stow = new_Stow(adopt => 1);

View file

@ -24,7 +24,7 @@ package testutil;
use strict; use strict;
use warnings; use warnings;
use Carp qw(croak); use Carp qw(confess croak);
use File::Basename; use File::Basename;
use File::Path qw(make_path remove_tree); use File::Path qw(make_path remove_tree);
use File::Spec; use File::Spec;
@ -50,17 +50,21 @@ our $TEST_DIR = 'tmp-testing-trees';
our $ABS_TEST_DIR = File::Spec->rel2abs('tmp-testing-trees'); our $ABS_TEST_DIR = File::Spec->rel2abs('tmp-testing-trees');
sub init_test_dirs { sub init_test_dirs {
my $test_dir = shift || $TEST_DIR;
my $abs_test_dir = File::Spec->rel2abs($test_dir);
# Create a run_from/ subdirectory for tests which want to run # Create a run_from/ subdirectory for tests which want to run
# from a separate directory outside the Stow directory or # from a separate directory outside the Stow directory or
# target directory. # target directory.
for my $dir ("target", "stow", "run_from") { for my $dir ("target", "stow", "run_from") {
my $path = "$TEST_DIR/$dir"; my $path = "$test_dir/$dir";
-d $path and remove_tree($path); -d $path and remove_tree($path);
make_path($path); make_path($path);
} }
# Don't let user's ~/.stow-global-ignore affect test results # Don't let user's ~/.stow-global-ignore affect test results
$ENV{HOME} = $ABS_TEST_DIR; $ENV{HOME} = $abs_test_dir;
return $abs_test_dir;
} }
sub new_Stow { sub new_Stow {
@ -70,7 +74,11 @@ sub new_Stow {
$opts{dir} ||= '../stow'; $opts{dir} ||= '../stow';
$opts{target} ||= '.'; $opts{target} ||= '.';
$opts{test_mode} = 1; $opts{test_mode} = 1;
return new Stow(%opts); my $stow = eval { new Stow(%opts) };
if ($@) {
confess "Error while trying to instantiate new Stow(%opts): $@";
}
return $stow;
} }
sub new_compat_Stow { sub new_compat_Stow {

View file

@ -22,21 +22,86 @@
use strict; use strict;
use warnings; use warnings;
use Test::More tests => 32; use File::Spec qw(make_path);
use POSIX qw(getcwd);
use Test::More tests => 35;
use Test::Output; use Test::Output;
use English qw(-no_match_vars); use English qw(-no_match_vars);
use testutil; use testutil;
use Stow::Util qw(canon_path); use Stow::Util qw(canon_path);
init_test_dirs(); my $repo = getcwd();
cd("$TEST_DIR/target");
# Note that each of the following tests use a distinct set of files init_test_dirs($TEST_DIR);
subtest("unstow a simple tree minimally", sub { our $COMPAT_TEST_DIR = "${TEST_DIR}-compat";
our $COMPAT_ABS_TEST_DIR = init_test_dirs($COMPAT_TEST_DIR);
sub init_stow2 {
make_path('stow2'); # make our alternate stow dir a subdir of target
make_file('stow2/.stow');
}
sub create_unowned_files {
# Make things harder for Stow to figure out, by adding
# a bunch of alien files unrelated to Stow.
my @UNOWNED_DIRS = ('unowned-dir', '.unowned-dir', 'dot-unowned-dir');
for my $dir ('.', @UNOWNED_DIRS) {
for my $subdir ('.', @UNOWNED_DIRS) {
make_path("$dir/$subdir");
make_file("$dir/$subdir/unowned");
make_file("$dir/$subdir/.unowned");
make_file("$dir/$subdir/dot-unowned");
}
}
}
# Run a subtest twice, with compat off then on, in parallel test trees.
#
# Params: $name[, $setup], $test_code
#
# $setup is an optional ref to an options hash to pass into the new
# Stow() constructor, or a ref to a sub which performs setup before
# the constructor gets called and then returns that options hash.
sub subtests {
my $name = shift;
my $setup = @_ == 2 ? shift : {};
my $code = shift;
$ENV{HOME} = $ABS_TEST_DIR;
cd($repo);
cd("$TEST_DIR/target");
create_unowned_files();
# cd first to allow setup to cd somewhere else.
my $opts = ref($setup) eq 'HASH' ? $setup : $setup->($TEST_DIR);
subtest($name, sub {
make_path($opts->{dir}) if $opts->{dir};
my $stow = new_Stow(%$opts);
$code->($stow, $TEST_DIR);
});
$ENV{HOME} = $COMPAT_ABS_TEST_DIR;
cd($repo);
cd("$COMPAT_TEST_DIR/target");
create_unowned_files();
# cd first to allow setup to cd somewhere else.
$opts = ref $setup eq 'HASH' ? $setup : $setup->($COMPAT_TEST_DIR);
subtest("$name (compat mode)", sub {
make_path($opts->{dir}) if $opts->{dir};
my $stow = new_compat_Stow(%$opts);
$code->($stow, $COMPAT_TEST_DIR);
});
}
sub plan_tests {
my ($stow, $count) = @_;
plan tests => $stow->{compat} ? $count + 2 : $count;
}
subtests("unstow a simple tree minimally", sub {
my ($stow) = @_;
plan tests => 3; plan tests => 3;
my $stow = new_Stow();
make_path('../stow/pkg1/bin1'); make_path('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1'); make_file('../stow/pkg1/bin1/file1');
@ -44,14 +109,14 @@ subtest("unstow a simple tree minimally", sub {
$stow->plan_unstow('pkg1'); $stow->plan_unstow('pkg1');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-f '../stow/pkg1/bin1/file1'); ok(-f '../stow/pkg1/bin1/file1');
ok(! -e 'bin1' => 'unstow a simple tree'); ok(! -e 'bin1' => 'unstow a simple tree');
}); });
subtest("unstow a simple tree from an existing directory", sub { subtests("unstow a simple tree from an existing directory", sub {
my ($stow) = @_;
plan tests => 3; plan tests => 3;
my $stow = new_Stow();
make_path('lib2'); make_path('lib2');
make_path('../stow/pkg2/lib2'); make_path('../stow/pkg2/lib2');
@ -59,16 +124,16 @@ subtest("unstow a simple tree from an existing directory", sub {
make_link('lib2/file2', '../../stow/pkg2/lib2/file2'); make_link('lib2/file2', '../../stow/pkg2/lib2/file2');
$stow->plan_unstow('pkg2'); $stow->plan_unstow('pkg2');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-f '../stow/pkg2/lib2/file2'); ok(-f '../stow/pkg2/lib2/file2');
ok(-d 'lib2' ok(-d 'lib2'
=> 'unstow simple tree from a pre-existing directory' => 'unstow simple tree from a pre-existing directory'
); );
}); });
subtest("fold tree after unstowing", sub { subtests("fold tree after unstowing", sub {
my ($stow) = @_;
plan tests => 3; plan tests => 3;
my $stow = new_Stow();
make_path('bin3'); make_path('bin3');
@ -81,16 +146,16 @@ subtest("fold tree after unstowing", sub {
make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow
$stow->plan_unstow('pkg3b'); $stow->plan_unstow('pkg3b');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-l 'bin3'); ok(-l 'bin3');
is(readlink('bin3'), '../stow/pkg3a/bin3' is(readlink('bin3'), '../stow/pkg3a/bin3'
=> 'fold tree after unstowing' => 'fold tree after unstowing'
); );
}); });
subtest("existing link is owned by stow but is invalid so it gets removed anyway", sub { subtests("existing link is owned by stow but is invalid so it gets removed anyway", sub {
my ($stow) = @_;
plan tests => 2; plan tests => 2;
my $stow = new_Stow();
make_path('bin4'); make_path('bin4');
make_path('../stow/pkg4/bin4'); make_path('../stow/pkg4/bin4');
@ -99,31 +164,28 @@ subtest("existing link is owned by stow but is invalid so it gets removed anyway
$stow->plan_unstow('pkg4'); $stow->plan_unstow('pkg4');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(! -e 'bin4/file4' ok(! -e 'bin4/file4'
=> q(remove invalid link owned by stow) => q(remove invalid link owned by stow)
); );
}); });
subtest("Existing link is not owned by stow", sub { subtests("Existing invalid link is not owned by stow", sub {
plan tests => 1; my ($stow) = @_;
my $stow = new_Stow(); plan tests => 3;
make_path('../stow/pkg5/bin5'); make_path('../stow/pkg5/bin5');
make_invalid_link('bin5', '../not-stow'); make_invalid_link('bin5', '../not-stow');
$stow->plan_unstow('pkg5'); $stow->plan_unstow('pkg5');
my %conflicts = $stow->get_conflicts; is($stow->get_conflict_count, 0, 'conflict count');
like( ok(-l 'bin5', 'invalid link not removed');
$conflicts{unstow}{pkg5}[-1], is(readlink('bin5'), '../not-stow' => "invalid link not changed");
qr(existing target is not owned by stow)
=> q(existing link not owned by stow)
);
}); });
subtest("Target already exists, is owned by stow, but points to a different package", sub { subtests("Target already exists, is owned by stow, but points to a different package", sub {
my ($stow) = @_;
plan tests => 3; plan tests => 3;
my $stow = new_Stow();
make_path('bin6'); make_path('bin6');
make_path('../stow/pkg6a/bin6'); make_path('../stow/pkg6a/bin6');
@ -134,7 +196,7 @@ subtest("Target already exists, is owned by stow, but points to a different pack
make_file('../stow/pkg6b/bin6/file6'); make_file('../stow/pkg6b/bin6/file6');
$stow->plan_unstow('pkg6b'); $stow->plan_unstow('pkg6b');
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-l 'bin6/file6'); ok(-l 'bin6/file6');
is( is(
readlink('bin6/file6'), readlink('bin6/file6'),
@ -143,19 +205,29 @@ subtest("Target already exists, is owned by stow, but points to a different pack
); );
}); });
subtest("Don't unlink anything under the stow directory", sub { subtests("Don't unlink anything under the stow directory",
plan tests => 4; sub {
make_path('stow'); # make out stow dir a subdir of target make_path('stow');
my $stow = new_Stow(dir => 'stow'); return { dir => 'stow' };
# target dir defaults to parent of stow, which is target directory
},
sub {
plan tests => 5;
my ($stow) = @_;
# emulate stowing into ourself (bizarre corner case or accident) # Emulate stowing into ourself (bizarre corner case or accident):
make_path('stow/pkg7a/stow/pkg7b'); make_path('stow/pkg7a/stow/pkg7b');
make_file('stow/pkg7a/stow/pkg7b/file7b'); make_file('stow/pkg7a/stow/pkg7b/file7b');
# Make a package be a link to a package of the same name inside another package.
make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b'); make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b');
$stow->plan_unstow('pkg7b'); stderr_like(
sub { $stow->plan_unstow('pkg7b'); },
$stow->{compat} ? qr/WARNING: skipping target which was current stow directory stow/ : qr//
=> "warn when unstowing from ourself"
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg7b'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg7b');
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-l 'stow/pkg7b'); ok(-l 'stow/pkg7b');
is( is(
readlink('stow/pkg7b'), readlink('stow/pkg7b'),
@ -164,13 +236,16 @@ subtest("Don't unlink anything under the stow directory", sub {
); );
}); });
subtest("Don't unlink any nodes under another stow directory", sub { subtests("Don't unlink any nodes under another stow directory",
sub {
make_path('stow');
return { dir => 'stow' };
},
sub {
my ($stow) = @_;
plan tests => 5; plan tests => 5;
my $stow = new_Stow(dir => 'stow');
make_path('stow2'); # make our alternate stow dir a subdir of target
make_file('stow2/.stow');
init_stow2();
# emulate stowing into ourself (bizarre corner case or accident) # emulate stowing into ourself (bizarre corner case or accident)
make_path('stow/pkg8a/stow2/pkg8b'); make_path('stow/pkg8a/stow2/pkg8b');
make_file('stow/pkg8a/stow2/pkg8b/file8b'); make_file('stow/pkg8a/stow2/pkg8b/file8b');
@ -179,10 +254,10 @@ subtest("Don't unlink any nodes under another stow directory", sub {
stderr_like( stderr_like(
sub { $stow->plan_unstow('pkg8a'); }, sub { $stow->plan_unstow('pkg8a'); },
qr/WARNING: skipping marked Stow directory stow2/ qr/WARNING: skipping marked Stow directory stow2/
=> "unstowing from ourself should skip stow" => "warn when skipping unstowing"
); );
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg8a'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg8a');
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-l 'stow2/pkg8b'); ok(-l 'stow2/pkg8b');
is( is(
readlink('stow2/pkg8b'), readlink('stow2/pkg8b'),
@ -191,11 +266,24 @@ subtest("Don't unlink any nodes under another stow directory", sub {
); );
}); });
subtest("overriding already stowed documentation", sub { # This will be used by subsequent tests
plan tests => 2; sub check_protected_dirs_skipped {
my $stow = new_Stow(override => ['man9', 'info9']); my ($stderr) = @_;
make_file('stow/.stow'); for my $dir (qw{stow stow2}) {
like($stderr,
qr/WARNING: skipping marked Stow directory $dir/
=> "warn when skipping marked directory $dir");
}
}
subtests("overriding already stowed documentation",
{override => ['man9', 'info9']},
sub {
my ($stow) = @_;
plan_tests($stow, 2);
make_file('stow/.stow');
init_stow2();
make_path('../stow/pkg9a/man9/man1'); make_path('../stow/pkg9a/man9/man1');
make_file('../stow/pkg9a/man9/man1/file9.1'); make_file('../stow/pkg9a/man9/man1/file9.1');
make_path('man9/man1'); make_path('man9/man1');
@ -203,18 +291,22 @@ subtest("overriding already stowed documentation", sub {
make_path('../stow/pkg9b/man9/man1'); make_path('../stow/pkg9b/man9/man1');
make_file('../stow/pkg9b/man9/man1/file9.1'); make_file('../stow/pkg9b/man9/man1/file9.1');
$stow->plan_unstow('pkg9b'); my $stderr = stderr_from { $stow->plan_unstow('pkg9b') };
check_protected_dirs_skipped($stderr) if $stow->{compat};
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(!-l 'man9/man1/file9.1' ok(!-l 'man9/man1/file9.1'
=> 'overriding existing documentation files' => 'overriding existing documentation files'
); );
}); });
subtest("deferring to already stowed documentation", sub { subtests("deferring to already stowed documentation",
plan tests => 3; {defer => ['man10', 'info10']},
my $stow = new_Stow(defer => ['man10', 'info10']); sub {
my ($stow) = @_;
plan_tests($stow, 3);
init_stow2();
make_path('../stow/pkg10a/man10/man1'); make_path('../stow/pkg10a/man10/man1');
make_file('../stow/pkg10a/man10/man1/file10a.1'); make_file('../stow/pkg10a/man10/man1/file10a.1');
make_path('man10/man1'); make_path('man10/man1');
@ -225,12 +317,12 @@ subtest("deferring to already stowed documentation", sub {
make_file('../stow/pkg10b/man10/man1/file10b.1'); make_file('../stow/pkg10b/man10/man1/file10b.1');
make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1'); make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1');
make_path('../stow/pkg10c/man10/man1'); make_path('../stow/pkg10c/man10/man1');
make_file('../stow/pkg10c/man10/man1/file10a.1'); make_file('../stow/pkg10c/man10/man1/file10a.1');
$stow->plan_unstow('pkg10c'); my $stderr = stderr_from { $stow->plan_unstow('pkg10c') };
check_protected_dirs_skipped($stderr) if $stow->{compat};
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg10c'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg10c');
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
is( is(
readlink('man10/man1/file10a.1'), readlink('man10/man1/file10a.1'),
'../../../stow/pkg10a/man10/man1/file10a.1' '../../../stow/pkg10a/man10/man1/file10a.1'
@ -238,10 +330,13 @@ subtest("deferring to already stowed documentation", sub {
); );
}); });
subtest("Ignore temp files", sub { subtests("Ignore temp files",
plan tests => 2; {ignore => ['~', '\.#.*']},
my $stow = new_Stow(ignore => ['~', '\.#.*']); sub {
my ($stow) = @_;
plan_tests($stow, 2);
init_stow2();
make_path('../stow/pkg12/man12/man1'); make_path('../stow/pkg12/man12/man1');
make_file('../stow/pkg12/man12/man1/file12.1'); make_file('../stow/pkg12/man12/man1/file12.1');
make_file('../stow/pkg12/man12/man1/file12.1~'); make_file('../stow/pkg12/man12/man1/file12.1~');
@ -249,190 +344,206 @@ subtest("Ignore temp files", sub {
make_path('man12/man1'); make_path('man12/man1');
make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1'); make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1');
$stow->plan_unstow('pkg12'); my $stderr = stderr_from { $stow->plan_unstow('pkg12') };
check_protected_dirs_skipped($stderr) if $stow->{compat};
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(!-e 'man12/man1/file12.1' => 'ignore temp files'); ok(! -e 'man12/man1/file12.1' => 'man12/man1/file12.1 was unstowed');
}); });
subtest("Unstow an already unstowed package", sub { subtests("Unstow an already unstowed package", sub {
plan tests => 2; my ($stow) = @_;
my $stow = new_Stow(); plan_tests($stow, 2);
$stow->plan_unstow('pkg12');
my $stderr = stderr_from { $stow->plan_unstow('pkg12') };
check_protected_dirs_skipped($stderr) if $stow->{compat};
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12');
is( is($stow->get_conflict_count, 0, 'conflict count');
$stow->get_conflict_count, 0
=> 'unstow already unstowed package pkg12'
);
}); });
subtest("Unstow a never stowed package", sub { subtests("Unstow a never stowed package", sub {
my ($stow) = @_;
plan tests => 2; plan tests => 2;
eval { remove_dir("$TEST_DIR/target"); }; eval { remove_dir($stow->{target}); };
mkdir("$TEST_DIR/target"); mkdir($stow->{target});
my $stow = new_Stow();
$stow->plan_unstow('pkg12'); $stow->plan_unstow('pkg12');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 which was never stowed'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 which was never stowed');
is( is($stow->get_conflict_count, 0, 'conflict count');
$stow->get_conflict_count,
0
=> 'unstow never stowed package pkg12'
);
}); });
subtest("Unstowing when target contains a real file shouldn't be an issue", sub { subtests("Unstowing when target contains real files shouldn't be an issue", sub {
plan tests => 3; my ($stow) = @_;
plan tests => 4;
# Test both a file which do / don't overlap with the package
make_path('man12/man1');
make_file('man12/man1/alien');
make_file('man12/man1/file12.1'); make_file('man12/man1/file12.1');
my $stow = new_Stow();
$stow->plan_unstow('pkg12'); $stow->plan_unstow('pkg12');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 for third time'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 for third time');
my %conflicts = $stow->get_conflicts; is($stow->get_conflict_count, 0, 'conflict count');
is($stow->get_conflict_count, 1); ok(-f 'man12/man1/alien', 'alien untouched');
like( ok(-f 'man12/man1/file12.1', 'file overlapping with pkg untouched');
$conflicts{unstow}{pkg12}[0],
qr!existing target is neither a link nor a directory: man12/man1/file12\.1!
=> 'unstow pkg12 for third time'
);
}); });
subtest("unstow a simple tree minimally when cwd isn't target", sub { subtests("unstow a simple tree minimally when cwd isn't target",
sub {
my $test_dir = shift;
cd($repo);
return {
dir => "$test_dir/stow",
target => "$test_dir/target"
}
},
sub {
my ($stow, $test_dir) = @_;
plan tests => 3; plan tests => 3;
cd('../..');
my $stow = new_Stow(dir => "$TEST_DIR/stow", target => "$TEST_DIR/target");
make_path("$TEST_DIR/stow/pkg13/bin13"); make_path("$test_dir/stow/pkg13/bin13");
make_file("$TEST_DIR/stow/pkg13/bin13/file13"); make_file("$test_dir/stow/pkg13/bin13/file13");
make_link("$TEST_DIR/target/bin13", '../stow/pkg13/bin13'); make_link("$test_dir/target/bin13", '../stow/pkg13/bin13');
$stow->plan_unstow('pkg13'); $stow->plan_unstow('pkg13');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-f "$TEST_DIR/stow/pkg13/bin13/file13"); ok(-f "$test_dir/stow/pkg13/bin13/file13", 'package file untouched');
ok(! -e "$TEST_DIR/target/bin13" => 'unstow a simple tree'); ok(! -e "$test_dir/target/bin13" => 'bin13/ unstowed');
}); });
subtest("unstow a simple tree minimally with absolute stow dir when cwd isn't target", sub { subtests("unstow a simple tree minimally with absolute stow dir when cwd isn't target",
sub {
my $test_dir = shift;
cd($repo);
return {
dir => canon_path("$test_dir/stow"),
target => "$test_dir/target"
};
},
sub {
plan tests => 3; plan tests => 3;
my $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"), my ($stow, $test_dir) = @_;
target => "$TEST_DIR/target");
make_path("$TEST_DIR/stow/pkg14/bin14"); make_path("$test_dir/stow/pkg14/bin14");
make_file("$TEST_DIR/stow/pkg14/bin14/file14"); make_file("$test_dir/stow/pkg14/bin14/file14");
make_link("$TEST_DIR/target/bin14", '../stow/pkg14/bin14'); make_link("$test_dir/target/bin14", '../stow/pkg14/bin14');
$stow->plan_unstow('pkg14'); $stow->plan_unstow('pkg14');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-f "$TEST_DIR/stow/pkg14/bin14/file14"); ok(-f "$test_dir/stow/pkg14/bin14/file14");
ok(! -e "$TEST_DIR/target/bin14" ok(! -e "$test_dir/target/bin14"
=> 'unstow a simple tree with absolute stow dir' => 'unstow a simple tree with absolute stow dir'
); );
}); });
subtest("unstow a simple tree minimally with absolute stow AND target dirs when cwd isn't target", sub { subtests("unstow a simple tree minimally with absolute stow AND target dirs when cwd isn't target",
sub {
my $test_dir = shift;
cd($repo);
return {
dir => canon_path("$test_dir/stow"),
target => canon_path("$test_dir/target")
};
},
sub {
my ($stow, $test_dir) = @_;
plan tests => 3; plan tests => 3;
my $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"),
target => canon_path("$TEST_DIR/target"));
make_path("$TEST_DIR/stow/pkg15/bin15"); make_path("$test_dir/stow/pkg15/bin15");
make_file("$TEST_DIR/stow/pkg15/bin15/file15"); make_file("$test_dir/stow/pkg15/bin15/file15");
make_link("$TEST_DIR/target/bin15", '../stow/pkg15/bin15'); make_link("$test_dir/target/bin15", '../stow/pkg15/bin15');
$stow->plan_unstow('pkg15'); $stow->plan_unstow('pkg15');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is($stow->get_conflict_count, 0, 'conflict count');
ok(-f "$TEST_DIR/stow/pkg15/bin15/file15"); ok(-f "$test_dir/stow/pkg15/bin15/file15");
ok(! -e "$TEST_DIR/target/bin15" ok(! -e "$test_dir/target/bin15"
=> 'unstow a simple tree with absolute stow and target dirs' => 'unstow a simple tree with absolute stow and target dirs'
); );
}); });
#
# unstow a tree with no-folding enabled -
# no refolding should take place
#
cd("$TEST_DIR/target");
sub create_and_stow_pkg { sub create_and_stow_pkg {
my ($id, $pkg) = @_; my ($id, $pkg) = @_;
my $stow_pkg = "../stow/$id-$pkg"; my $stow_pkg = "../stow/$id-$pkg";
make_path ($stow_pkg); make_path($stow_pkg);
make_file("$stow_pkg/$id-file-$pkg"); make_file("$stow_pkg/$id-file-$pkg");
# create a shallow hierarchy specific to this package and stow # create a shallow hierarchy specific to this package and stow
# via folding # via folding
make_path ("$stow_pkg/$id-$pkg-only-folded"); make_path("$stow_pkg/$id-$pkg-only-folded");
make_file("$stow_pkg/$id-$pkg-only-folded/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-folded/file-$pkg");
make_link("$id-$pkg-only-folded", "$stow_pkg/$id-$pkg-only-folded"); make_link("$id-$pkg-only-folded", "$stow_pkg/$id-$pkg-only-folded");
# create a deeper hierarchy specific to this package and stow # create a deeper hierarchy specific to this package and stow
# via folding # via folding
make_path ("$stow_pkg/$id-$pkg-only-folded2/subdir"); make_path("$stow_pkg/$id-$pkg-only-folded2/subdir");
make_file("$stow_pkg/$id-$pkg-only-folded2/subdir/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-folded2/subdir/file-$pkg");
make_link("$id-$pkg-only-folded2", make_link("$id-$pkg-only-folded2",
"$stow_pkg/$id-$pkg-only-folded2"); "$stow_pkg/$id-$pkg-only-folded2");
# create a shallow hierarchy specific to this package and stow # create a shallow hierarchy specific to this package and stow
# without folding # without folding
make_path ("$stow_pkg/$id-$pkg-only-unfolded"); make_path("$stow_pkg/$id-$pkg-only-unfolded");
make_file("$stow_pkg/$id-$pkg-only-unfolded/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-unfolded/file-$pkg");
make_path ("$id-$pkg-only-unfolded"); make_path("$id-$pkg-only-unfolded");
make_link("$id-$pkg-only-unfolded/file-$pkg", make_link("$id-$pkg-only-unfolded/file-$pkg",
"../$stow_pkg/$id-$pkg-only-unfolded/file-$pkg"); "../$stow_pkg/$id-$pkg-only-unfolded/file-$pkg");
# create a deeper hierarchy specific to this package and stow # create a deeper hierarchy specific to this package and stow
# without folding # without folding
make_path ("$stow_pkg/$id-$pkg-only-unfolded2/subdir"); make_path("$stow_pkg/$id-$pkg-only-unfolded2/subdir");
make_file("$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg");
make_path ("$id-$pkg-only-unfolded2/subdir"); make_path("$id-$pkg-only-unfolded2/subdir");
make_link("$id-$pkg-only-unfolded2/subdir/file-$pkg", make_link("$id-$pkg-only-unfolded2/subdir/file-$pkg",
"../../$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg"); "../../$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg");
# create a shallow shared hierarchy which this package uses, and stow # create a shallow shared hierarchy which this package uses, and stow
# its contents without folding # its contents without folding
make_path ("$stow_pkg/$id-shared"); make_path("$stow_pkg/$id-shared");
make_file("$stow_pkg/$id-shared/file-$pkg"); make_file("$stow_pkg/$id-shared/file-$pkg");
make_path ("$id-shared"); make_path("$id-shared");
make_link("$id-shared/file-$pkg", make_link("$id-shared/file-$pkg",
"../$stow_pkg/$id-shared/file-$pkg"); "../$stow_pkg/$id-shared/file-$pkg");
# create a deeper shared hierarchy which this package uses, and stow # create a deeper shared hierarchy which this package uses, and stow
# its contents without folding # its contents without folding
make_path ("$stow_pkg/$id-shared2/subdir"); make_path("$stow_pkg/$id-shared2/subdir");
make_file("$stow_pkg/$id-shared2/file-$pkg"); make_file("$stow_pkg/$id-shared2/file-$pkg");
make_file("$stow_pkg/$id-shared2/subdir/file-$pkg"); make_file("$stow_pkg/$id-shared2/subdir/file-$pkg");
make_path ("$id-shared2/subdir"); make_path("$id-shared2/subdir");
make_link("$id-shared2/file-$pkg", make_link("$id-shared2/file-$pkg",
"../$stow_pkg/$id-shared2/file-$pkg"); "../$stow_pkg/$id-shared2/file-$pkg");
make_link("$id-shared2/subdir/file-$pkg", make_link("$id-shared2/subdir/file-$pkg",
"../../$stow_pkg/$id-shared2/subdir/file-$pkg"); "../../$stow_pkg/$id-shared2/subdir/file-$pkg");
} }
foreach my $pkg (qw{a b}) { subtest("unstow a tree with no-folding enabled - no refolding should take place", sub {
cd("$TEST_DIR/target");
plan tests => 15;
foreach my $pkg (qw{a b}) {
create_and_stow_pkg('no-folding', $pkg); create_and_stow_pkg('no-folding', $pkg);
} }
my $stow = new_Stow('no-folding' => 1); my $stow = new_Stow('no-folding' => 1);
$stow->plan_unstow('no-folding-b'); $stow->plan_unstow('no-folding-b');
is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding'); is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding');
use Data::Dumper;
#warn Dumper($stow->get_tasks);
$stow->process_tasks(); $stow->process_tasks();
is_nonexistent_path('no-folding-b-only-folded'); is_nonexistent_path('no-folding-b-only-folded');
is_nonexistent_path('no-folding-b-only-folded2'); is_nonexistent_path('no-folding-b-only-folded2');
is_nonexistent_path('no-folding-b-only-unfolded/file-b'); is_nonexistent_path('no-folding-b-only-unfolded/file-b');
is_nonexistent_path('no-folding-b-only-unfolded2/subdir/file-b'); is_nonexistent_path('no-folding-b-only-unfolded2/subdir/file-b');
is_dir_not_symlink('no-folding-shared'); is_dir_not_symlink('no-folding-shared');
is_dir_not_symlink('no-folding-shared2'); is_dir_not_symlink('no-folding-shared2');
is_dir_not_symlink('no-folding-shared2/subdir'); is_dir_not_symlink('no-folding-shared2/subdir');
});
# subtests("Test cleaning up subdirs with --paranoid option", sub {
# Todo # TODO
# # });
# Test cleaning up subdirs with --paranoid option

View file

@ -1,393 +0,0 @@
#!/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/.
#
# Test unstowing packages in compat mode
#
use strict;
use warnings;
use File::Spec qw(make_path);
use Test::More tests => 17;
use Test::Output;
use English qw(-no_match_vars);
use testutil;
use Stow::Util qw(canon_path);
init_test_dirs();
cd("$TEST_DIR/target");
# Note that each of the following tests use a distinct set of files
my $stow;
my %conflicts;
subtest("unstow a simple tree minimally", sub {
plan tests => 3;
my $stow = new_compat_Stow();
make_path('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1');
make_link('bin1', '../stow/pkg1/bin1');
$stow->plan_unstow('pkg1');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(-f '../stow/pkg1/bin1/file1');
ok(! -e 'bin1' => 'unstow a simple tree');
});
subtest("unstow a simple tree from an existing directory", sub {
plan tests => 3;
my $stow = new_compat_Stow();
make_path('lib2');
make_path('../stow/pkg2/lib2');
make_file('../stow/pkg2/lib2/file2');
make_link('lib2/file2', '../../stow/pkg2/lib2/file2');
$stow->plan_unstow('pkg2');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(-f '../stow/pkg2/lib2/file2');
ok(-d 'lib2'
=> 'unstow simple tree from a pre-existing directory'
);
});
subtest("fold tree after unstowing", sub {
plan tests => 3;
my $stow = new_compat_Stow();
make_path('bin3');
make_path('../stow/pkg3a/bin3');
make_file('../stow/pkg3a/bin3/file3a');
make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow
make_path('../stow/pkg3b/bin3');
make_file('../stow/pkg3b/bin3/file3b');
make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow
$stow->plan_unstow('pkg3b');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(-l 'bin3');
is(readlink('bin3'), '../stow/pkg3a/bin3'
=> 'fold tree after unstowing'
);
});
subtest("existing link is owned by stow but is invalid so it gets removed anyway", sub {
plan tests => 2;
my $stow = new_compat_Stow();
make_path('bin4');
make_path('../stow/pkg4/bin4');
make_file('../stow/pkg4/bin4/file4');
make_invalid_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist');
$stow->plan_unstow('pkg4');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(! -e 'bin4/file4'
=> q(remove invalid link owned by stow)
);
});
subtest("Existing link is not owned by stow", sub {
plan tests => 2;
my $stow = new_compat_Stow();
make_path('../stow/pkg5/bin5');
make_invalid_link('bin5', '../not-stow');
$stow->plan_unstow('pkg5');
# Unlike the corresponding stow_contents.t test, this doesn't
# cause any conflicts.
#
#like(
# $Conflicts[-1], qr(can't unlink.*not owned by stow)
# => q(existing link not owned by stow)
#);
ok(-l 'bin5');
is(
readlink('bin5'),
'../not-stow'
=> q(existing link not owned by stow)
);
});
subtest("Target already exists, is owned by stow, but points to a different package", sub {
plan tests => 3;
my $stow = new_compat_Stow();
make_path('bin6');
make_path('../stow/pkg6a/bin6');
make_file('../stow/pkg6a/bin6/file6');
make_link('bin6/file6', '../../stow/pkg6a/bin6/file6');
make_path('../stow/pkg6b/bin6');
make_file('../stow/pkg6b/bin6/file6');
$stow->plan_unstow('pkg6b');
is($stow->get_conflict_count, 0);
ok(-l 'bin6/file6');
is(
readlink('bin6/file6'),
'../../stow/pkg6a/bin6/file6'
=> q(ignore existing link that points to a different package)
);
});
subtest("Don't unlink anything under the stow directory", sub {
plan tests => 5;
make_path('stow'); # make stow dir a subdir of target
my $stow = new_compat_Stow(dir => 'stow');
# emulate stowing into ourself (bizarre corner case or accident)
make_path('stow/pkg7a/stow/pkg7b');
make_file('stow/pkg7a/stow/pkg7b/file7b');
make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b');
stderr_like(
sub { $stow->plan_unstow('pkg7b'); },
qr/WARNING: skipping target which was current stow directory stow/
=> "warn when unstowing from ourself"
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg7b');
is($stow->get_conflict_count, 0);
ok(-l 'stow/pkg7b');
is(
readlink('stow/pkg7b'),
'../stow/pkg7a/stow/pkg7b'
=> q(don't unlink any nodes under the stow directory)
);
});
subtest("Don't unlink any nodes under another stow directory", sub {
plan tests => 5;
my $stow = new_compat_Stow(dir => 'stow');
make_path('stow2'); # make our alternate stow dir a subdir of target
make_file('stow2/.stow');
# emulate stowing into ourself (bizarre corner case or accident)
make_path('stow/pkg8a/stow2/pkg8b');
make_file('stow/pkg8a/stow2/pkg8b/file8b');
make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b');
stderr_like(
sub { $stow->plan_unstow('pkg8a'); },
qr/WARNING: skipping target which was current stow directory stow/
=> "warn when skipping unstowing"
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg8a');
is($stow->get_conflict_count, 0);
ok(-l 'stow2/pkg8b');
is(
readlink('stow2/pkg8b'),
'../stow/pkg8a/stow2/pkg8b'
=> q(don't unlink any nodes under another stow directory)
);
});
# This will be used by subsequent tests
sub check_protected_dirs_skipped {
my $coderef = shift;
my $stderr = stderr_from { $coderef->(); };
for my $dir (qw{stow stow2}) {
like($stderr,
qr/WARNING: skipping marked Stow directory $dir/
=> "warn when skipping marked directory $dir");
}
}
subtest("overriding already stowed documentation", sub {
plan tests => 4;
my $stow = new_compat_Stow(override => ['man9', 'info9']);
make_file('stow/.stow');
make_path('../stow/pkg9a/man9/man1');
make_file('../stow/pkg9a/man9/man1/file9.1');
make_path('man9/man1');
make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow
make_path('../stow/pkg9b/man9/man1');
make_file('../stow/pkg9b/man9/man1/file9.1');
check_protected_dirs_skipped(
sub { $stow->plan_unstow('pkg9b'); }
);
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(!-l 'man9/man1/file9.1'
=> 'overriding existing documentation files'
);
});
subtest("deferring to already stowed documentation", sub {
plan tests => 5;
my $stow = new_compat_Stow(defer => ['man10', 'info10']);
make_path('../stow/pkg10a/man10/man1');
make_file('../stow/pkg10a/man10/man1/file10a.1');
make_path('man10/man1');
make_link('man10/man1/file10a.1' => '../../../stow/pkg10a/man10/man1/file10a.1');
# need this to block folding
make_path('../stow/pkg10b/man10/man1');
make_file('../stow/pkg10b/man10/man1/file10b.1');
make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1');
make_path('../stow/pkg10c/man10/man1');
make_file('../stow/pkg10c/man10/man1/file10a.1');
check_protected_dirs_skipped(
sub { $stow->plan_unstow('pkg10c'); }
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg10c');
is($stow->get_conflict_count, 0);
is(
readlink('man10/man1/file10a.1'),
'../../../stow/pkg10a/man10/man1/file10a.1'
=> 'defer to existing documentation files'
);
});
subtest("Ignore temp files", sub {
plan tests => 4;
my $stow = new_compat_Stow(ignore => ['~', '\.#.*']);
make_path('../stow/pkg12/man12/man1');
make_file('../stow/pkg12/man12/man1/file12.1');
make_file('../stow/pkg12/man12/man1/file12.1~');
make_file('../stow/pkg12/man12/man1/.#file12.1');
make_path('man12/man1');
make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1');
check_protected_dirs_skipped(
sub { $stow->plan_unstow('pkg12'); }
);
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(!-e 'man12/man1/file12.1' => 'ignore temp files');
});
subtest("Unstow an already unstowed package", sub {
plan tests => 4;
my $stow = new_compat_Stow();
check_protected_dirs_skipped(
sub { $stow->plan_unstow('pkg12'); }
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12');
is(
$stow->get_conflict_count,
0
=> 'unstow already unstowed package pkg12'
);
});
subtest("Unstow a never stowed package", sub {
plan tests => 4;
eval { remove_dir("$TEST_DIR/target"); };
mkdir("$TEST_DIR/target");
my $stow = new_compat_Stow();
check_protected_dirs_skipped(
sub { $stow->plan_unstow('pkg12'); }
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 which was never stowed');
is(
$stow->get_conflict_count,
0
=> 'unstow never stowed package pkg12'
);
});
subtest("Unstowing when target contains a real file shouldn't be an issue", sub {
plan tests => 5;
make_file('man12/man1/file12.1');
my $stow = new_compat_Stow();
check_protected_dirs_skipped(
sub { $stow->plan_unstow('pkg12'); }
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 for third time');
%conflicts = $stow->get_conflicts;
is($stow->get_conflict_count, 1);
like(
$conflicts{unstow}{pkg12}[0],
qr!existing target is neither a link nor a directory: man12/man1/file12\.1!
=> 'unstow pkg12 for third time'
);
});
subtest("unstow a simple tree minimally when cwd isn't target", sub {
plan tests => 3;
cd('../..');
my $stow = new_Stow(dir => "$TEST_DIR/stow", target => "$TEST_DIR/target");
make_path("$TEST_DIR/stow/pkg13/bin13");
make_file("$TEST_DIR/stow/pkg13/bin13/file13");
make_link("$TEST_DIR/target/bin13", '../stow/pkg13/bin13');
$stow->plan_unstow('pkg13');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(-f "$TEST_DIR/stow/pkg13/bin13/file13");
ok(! -e "$TEST_DIR/target/bin13" => 'unstow a simple tree');
});
subtest("unstow a simple tree minimally with absolute stow dir when cwd isn't target", sub {
plan tests => 3;
my $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"),
target => "$TEST_DIR/target");
make_path("$TEST_DIR/stow/pkg14/bin14");
make_file("$TEST_DIR/stow/pkg14/bin14/file14");
make_link("$TEST_DIR/target/bin14", '../stow/pkg14/bin14');
$stow->plan_unstow('pkg14');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(-f "$TEST_DIR/stow/pkg14/bin14/file14");
ok(! -e "$TEST_DIR/target/bin14"
=> 'unstow a simple tree with absolute stow dir'
);
});
subtest("unstow a simple tree minimally with absolute stow AND target dirs when cwd isn't target", sub {
plan tests => 3;
my $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"),
target => canon_path("$TEST_DIR/target"));
make_path("$TEST_DIR/stow/pkg15/bin15");
make_file("$TEST_DIR/stow/pkg15/bin15/file15");
make_link("$TEST_DIR/target/bin15", '../stow/pkg15/bin15');
$stow->plan_unstow('pkg15');
$stow->process_tasks();
is($stow->get_conflict_count, 0);
ok(-f "$TEST_DIR/stow/pkg15/bin15/file15");
ok(! -e "$TEST_DIR/target/bin15"
=> 'unstow a simple tree with absolute stow and target dirs'
);
});
# subtest("Test cleaning up subdirs with --paranoid option", sub {
# TODO
# });