diff --git a/.gitignore b/.gitignore index dcb7f4d..caf4ba3 100644 --- a/.gitignore +++ b/.gitignore @@ -9,7 +9,8 @@ /bin/stow /doc/stow.info /doc/version.texi -tmp-testing-trees/ +/playground/ +tmp-testing-trees*/ _build/ autom4te.cache/ blib/ diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 1bcd0f4..6f6399c 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -85,6 +85,11 @@ or to run the whole suite: However currently there is an issue where this interferes with `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 ---------------- diff --git a/MANIFEST b/MANIFEST index 8f7a812..09cb2bf 100644 --- a/MANIFEST +++ b/MANIFEST @@ -50,7 +50,6 @@ t/stow.t t/rc_options.t t/testutil.pm t/unstow.t -t/unstow_orig.t tools/get-version THANKS TODO diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 4fd408e..522b3fd 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -83,16 +83,14 @@ ^doc/HOWTO-RELEASE$ # Avoid test files -tmp-testing-trees -.coveralls.yml -.github/workflows/ -.travis.yml +tmp-testing-trees* +^.coveralls.yml +^.github/workflows/ +^.travis.yml ^docker/ ^[a-zA-Z]*-docker.sh +^playground/ # Avoid development config -.dir-locals.el -.dumbjump - -# Avoid CI -.github/ \ No newline at end of file +^.dir-locals.el +^.dumbjump diff --git a/Makefile.am b/Makefile.am index 7bd43bd..56abbef 100644 --- a/Makefile.am +++ b/Makefile.am @@ -51,7 +51,7 @@ DEFAULT_IGNORE_LIST = $(srcdir)/default-ignore-list doc_deps = $(info_TEXINFOS) doc/version.texi $(DEFAULT_IGNORE_LIST) 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) # This is a kind of hack; TESTS needs to be set to ensure that the diff --git a/docker/Dockerfile b/docker/Dockerfile index ec8f089..80ed7f3 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -16,10 +16,9 @@ # Build docker image: `docker build -t stowtest` # Run tests: (from stow src directory) # `docker run --rm -it -v $(pwd):$(pwd) -w $(pwd) stowtest` -FROM debian:jessie -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 +FROM debian:bookworm +RUN DEBIAN_FRONTEND=noninteractive apt-get update -qq RUN DEBIAN_FRONTEND=noninteractive \ -apt-get update -qq && \ apt-get install -y -q \ autoconf \ bzip2 \ diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index b402d9a..b9b3b30 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -56,7 +56,8 @@ use File::Spec; use POSIX qw(getcwd); 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 $VERSION = '@VERSION@'; @@ -284,7 +285,7 @@ sub plan_unstow { $self->unstow_contents( $package, '.', - $pkg_path, + '.', ); debug(2, 0, "Planning unstow of package $package... done"); $self->{action_count}++; @@ -319,8 +320,7 @@ sub plan_stow { $self->{stow_path}, $package, '.', - $pkg_path, # source from target - 0, + '.', ); debug(2, 0, "Planning stow of package $package... done"); $self->{action_count}++; @@ -361,7 +361,7 @@ sub within_target_do { 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. @@ -379,55 +379,48 @@ Stow Directories" section of the manual). 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 -Subpath relative to package directory which needs stowing as a symlink -at subpath relative to target directory. - -=item $source - -Relative path from the (sub)dir of target to symlink source. +Subdirectory of the target directory which either needs 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 folded or recursed into. =back C and C are mutually recursive. -C<$source> and C<$target_subdir> are used for creating the symlink. =cut sub stow_contents { 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 # whose contents need to be stowed, 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. - # - # 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. + my $pkg_path_from_cwd = join_paths($stow_path, $package, $pkg_subdir); - # 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") unless $self->is_a_node($target_subdir); - opendir my $DIR, $path - or error("cannot read directory: $path ($!)"); + opendir my $DIR, $pkg_path_from_cwd + or error("cannot read directory: $pkg_path_from_cwd ($!)"); my @listing = readdir $DIR; closedir $DIR; @@ -435,26 +428,31 @@ sub stow_contents { for my $node (sort @listing) { 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}) { - my $adj_node_target = adjust_dotfile($node_target); - debug(4, 1, "Adjusting: $node_target => $adj_node_target"); - $node_target = $adj_node_target; + my $adjusted = adjust_dotfile($node); + if ($adjusted ne $node) { + 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( $stow_path, $package, - $node_target, # target, potentially adjusted for dot- prefix - join_paths($source, $node), # source - $level + $package_node_path, + $target_node_path ); } } -=head2 stow_node($stow_path, $package, $target_subpath, $source) +=head2 stow_node($stow_path, $package, $pkg_subpath, $target_subpath) Stow the given node @@ -470,16 +468,20 @@ Stow Directories" section of the manual). =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 -Subpath relative to package directory of node which needs stowing as a -symlink at subpath relative to target directory. - -=item $source - -Relative path to symlink source from the dir of target. +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 @@ -489,27 +491,42 @@ C and C are mutually recursive. sub stow_node { 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 / $target_subpath"); - debug(4, 1, "=> $source"); + debug(3, 0, "Stowing entry $stow_path / $package / $pkg_subpath"); + # Calculate the path to the package directory or sub-directory + # whose contents need to be stowed, 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($stow_path, $package, $pkg_subpath); # Don't try to stow absolute symlinks (they can't be unstowed) - if (-l $source) { - my $link_dest = $self->read_a_link($source); + if (-l $pkg_path_from_cwd) { + my $link_dest = $self->read_a_link($pkg_path_from_cwd); if ($link_dest =~ m{\A/}) { $self->conflict( 'stow', $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"); 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? if ($self->is_a_link($target_subpath)) { # Where is the link pointing? @@ -533,8 +550,8 @@ sub stow_node { # Does the existing $target_subpath actually point to anything? if ($self->is_a_node($existing_pkg_path_from_cwd)) { - if ($existing_link_dest eq $source) { - debug(2, 0, "--- Skipping $target_subpath as it already points to $source"); + if ($existing_link_dest eq $link_dest) { + debug(2, 0, "--- Skipping $target_subpath as it already points to $link_dest"); } elsif ($self->defer($target_subpath)) { debug(2, 0, "--- Deferring installation of: $target_subpath"); @@ -542,10 +559,10 @@ sub stow_node { elsif ($self->override($target_subpath)) { debug(2, 0, "--- Overriding installation of: $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)) && - $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, @@ -558,16 +575,14 @@ sub stow_node { $self->stow_contents( $existing_stow_path, $existing_package, + $pkg_subpath, $target_subpath, - join_paths('..', $existing_link_dest), - $level + 1, ); $self->stow_contents( $self->{stow_path}, $package, + $pkg_subpath, $target_subpath, - join_paths('..', $source), - $level + 1, ); } else { @@ -581,48 +596,68 @@ sub stow_node { } else { # 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_link($source, $target_subpath); + $self->do_link($link_dest, $target_subpath); } } elsif ($self->is_a_node($target_subpath)) { debug(4, 1, "Evaluate existing node: $target_subpath"); if ($self->is_a_dir($target_subpath)) { - $self->stow_contents( - $self->{stow_path}, - $package, - $target_subpath, - join_paths('..', $source), - $level + 1, - ); + if (! -d $pkg_path_from_cwd) { + # FIXME: why wasn't this ever needed before? + $self->conflict( + 'stow', + $package, + "cannot stow non-directory $pkg_path_from_cwd over existing directory target $target_subpath" + ); + } + 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}) { - $self->do_mv($target_subpath, $path); - $self->do_link($source, $target_subpath); + if (-d $pkg_path_from_cwd) { + $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 { $self->conflict( 'stow', $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->stow_contents( $self->{stow_path}, $package, + $pkg_subpath, $target_subpath, - join_paths('..', $source), - $level + 1, ); } else { - $self->do_link($source, $target_subpath); + $self->do_link($link_dest, $target_subpath); } return; } @@ -684,7 +719,7 @@ sub marked_stow_dir { return 0; } -=head2 unstow_contents($package, $target) +=head2 unstow_contents($package, $pkg_subdir, $target_subdir) 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. -=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 @@ -707,15 +751,21 @@ Here we traverse the package tree, rather than the target tree. sub unstow_contents { my $self = shift; - my ($package, $target_subdir, $path) = @_; + my ($package, $pkg_subdir, $target_subdir) = @_; return if $self->should_skip_target($target_subdir); 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; 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}) { # In compat mode we traverse the target tree not the source tree, @@ -725,9 +775,10 @@ sub unstow_contents { unless -d $target_subdir; } else { - # We traverse the source tree not the target tree, so $path must exist. - error("unstow_contents() called with non-directory path: $path") - unless -d $path; + # We traverse the package installation image tree not the + # target tree, so $pkg_path_from_cwd must exist. + 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 # unstow_node() should only call this via mutual recursion if @@ -736,7 +787,7 @@ sub unstow_contents { 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 or error("cannot read directory: $dir ($!)"); my @listing = readdir $DIR; @@ -746,16 +797,41 @@ sub unstow_contents { for my $node (sort @listing) { 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}) { - my $adj_node_target = adjust_dotfile($node_target); - debug(4, 1, "Adjusting: $node_target => $adj_node_target"); - $node_target = $adj_node_target; + if ($self->{compat}) { + # $node is in the target tree, so we need to reverse + # 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) { @@ -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. @@ -773,9 +849,18 @@ Unstow the given node. 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 -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 @@ -785,19 +870,19 @@ C and C are mutually recursive. sub unstow_node { my $self = shift; - my ($package, $target_subpath, $source) = @_; - - 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"); + my ($package, $pkg_subpath, $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? 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) { - $self->unstow_contents($package, $target_subpath, $pkg_path_from_cwd); + elsif (-d $target_subpath) { + $self->unstow_contents($package, $pkg_subpath, $target_subpath); # This action may have made the parent directory foldable if (my $parent_in_pkg = $self->foldable($target_subpath)) { @@ -805,16 +890,7 @@ sub unstow_node { } } elsif (-e $target_subpath) { - if ($self->{compat}) { - $self->conflict( - 'unstow', - $package, - "existing target is neither a link nor a directory: $target_subpath", - ); - } - else { - $self->unstow_existing_node($package, $target_subpath, $source); - } + debug(2, 1, "$target_subpath doesn't need to be unstowed"); } else { debug(2, 1, "$target_subpath did not exist to be unstowed"); @@ -823,7 +899,7 @@ sub unstow_node { sub unstow_link_node { 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"); # Where is the link pointing? @@ -841,25 +917,24 @@ sub unstow_link_node { my ($existing_pkg_path_from_cwd, $existing_stow_path, $existing_package) = $self->find_stowed_path($target_subpath, $link_dest); if (not $existing_pkg_path_from_cwd) { - if ($self->{compat}) { - # We're traversing the target tree not the package tree, - # so we definitely expect to find stuff not owned by stow. - # Therefore we can't flag a conflict. - return; - } - else { - $self->conflict( - 'unstow', - $package, - "existing target is not owned by stow: $target_subpath => $link_dest" - ); - } + # The user is unstowing the package, so they don't want links to it. + # Therefore we should allow them to have a link pointing elsewhere + # which would conflict with the package if they were stowing it. + debug(5, 3, "Ignoring unowned link $target_subpath => $link_dest"); return; } + my $pkg_path_from_cwd = join_paths($self->{stow_path}, $package, $pkg_subpath); + # Does the existing $target_subpath actually point to anything? 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 { 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) Determine whether the given link points to a member of a stowed @@ -2078,7 +2098,7 @@ sub read_a_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 ($!)"); return $link_dest; } diff --git a/lib/Stow/Util.pm.in b/lib/Stow/Util.pm.in index 3b7dc3e..b33fb5a 100644 --- a/lib/Stow/Util.pm.in +++ b/lib/Stow/Util.pm.in @@ -38,7 +38,8 @@ use POSIX qw(getcwd); use base qw(Exporter); our @EXPORT_OK = qw( 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'; @@ -239,17 +240,17 @@ sub restore_cwd { } sub adjust_dotfile { - my ($link_dest) = @_; + my ($pkg_node) = @_; + (my $adjusted = $pkg_node) =~ s/^dot-([^.])/.$1/; + return $adjusted; +} - my @result = (); - for my $part (split m{/+}, $link_dest) { - if (($part ne "dot-") && ($part ne "dot-.")) { - $part =~ s/^dot-/./; - } - push @result, $part; - } - - return join '/', @result; +# Needed when unstowing with --compat and --dotfiles +sub unadjust_dotfile { + my ($target_node) = @_; + return $target_node if $target_node =~ /^\.\.?$/; + (my $adjusted = $target_node) =~ s/^\./dot-/; + return $adjusted; } =head1 BUGS diff --git a/t/dotfiles.t b/t/dotfiles.t index 83874ca..643b873 100755 --- a/t/dotfiles.t +++ b/t/dotfiles.t @@ -22,27 +22,22 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 12; use English qw(-no_match_vars); -use Stow::Util qw(adjust_dotfile); +use Stow::Util qw(adjust_dotfile unadjust_dotfile); use testutil; init_test_dirs(); cd("$TEST_DIR/target"); subtest('adjust_dotfile()', sub { - plan tests => 9; + plan tests => 4; my @TESTS = ( ['file'], + ['dot-'], + ['dot-.'], ['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) { 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; -subtest("stow a dotfile marked with 'dot' prefix", sub { +subtest("stow dot-foo as .foo", sub { plan tests => 1; $stow = new_Stow(dir => '../stow', dotfiles => 1); 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; $stow = new_Stow(dir => '../stow', dotfiles => 0); make_path('../stow/dotfiles'); @@ -81,10 +91,9 @@ subtest("ensure that turning off dotfile processing links files as usual", sub { '../stow/dotfiles/dot-foo', => 'unprocessed dotfile' ); - }); -subtest("stow folder marked with 'dot' prefix", sub { +subtest("stow dot-emacs dir as .emacs", sub { plan tests => 1; $stow = new_Stow(dir => '../stow', dotfiles => 1); @@ -96,11 +105,11 @@ subtest("stow folder marked with 'dot' prefix", sub { is( readlink('.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; $stow = new_Stow(dir => '../stow', dotfiles => 1); @@ -113,11 +122,11 @@ subtest("process folder marked with 'dot' prefix when directory exists is target is( readlink('.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; $stow = new_Stow(dir => '../stow', dotfiles => 1); @@ -130,11 +139,11 @@ subtest("process folder marked with 'dot' prefix when directory exists is target is( readlink('.emacs.d/.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; $stow = new_Stow(dir => '../stow', dotfiles => 1); @@ -147,7 +156,7 @@ subtest("process folder marked with 'dot' prefix when directory exists is target is( readlink('./.one/.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; $stow = new_Stow(dir => '../stow', dotfiles => 1); @@ -187,11 +196,11 @@ subtest("simple unstow scenario", sub { $stow->plan_unstow('dotfiles'); $stow->process_tasks(); is($stow->get_conflict_count, 0); - ok(-f '../stow/dotfiles/dot-bar'); - ok(! -e '.bar' => 'unstow a simple dotfile'); + ok(-f '../stow/dotfiles/dot-bar', 'package file untouched'); + 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; $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(); is($stow->get_conflict_count, 0); ok(-f '../stow/dotfiles/dot-emacs.d/init.el'); - ok(! -e '.emacs.d/init.el'); - ok(-d '.emacs.d/' => 'unstow dotfile folder when folder already exists'); + ok(! -e '.emacs.d/init.el', '.emacs.d/init.el unstowed'); + 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'); }); diff --git a/t/stow.t b/t/stow.t index 318eb6d..d23e8d6 100755 --- a/t/stow.t +++ b/t/stow.t @@ -22,7 +22,7 @@ use strict; use warnings; -use Test::More tests => 21; +use Test::More tests => 22; use Test::Output; 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); like( $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' ); }); @@ -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 " . "so can't unfold even with --adopt", sub { plan tests => 2; - #my $stow = new_Stow(adopt => 1); - my $stow = new_Stow(); + my $stow = new_Stow(adopt => 1); make_file('bin4a'); # this is a file but named like a directory make_path('../stow/pkg4a/bin4a'); @@ -121,8 +120,9 @@ subtest("Package dir 'bin4a' conflicts with existing non-dir " . $stow->plan_stow('pkg4a'); %conflicts = $stow->get_conflicts(); is($stow->get_conflict_count, 1); - like($conflicts{stow}{pkg4a}[0], - qr/existing target is neither a link nor a directory/ + like( + $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' ); }); @@ -146,14 +146,42 @@ subtest("Package files 'file4b' and 'bin4b' conflict with existing files", sub { %conflicts = $stow->get_conflicts(); is($stow->get_conflict_count, 2 => 'conflict per file'); for my $i (0, 1) { + my $target = $i ? 'file4b' : 'bin4b/file4b'; like( $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' ); } }); +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 { plan tests => 8; my $stow = new_Stow(adopt => 1); diff --git a/t/testutil.pm b/t/testutil.pm index b7c1549..2b4e097 100755 --- a/t/testutil.pm +++ b/t/testutil.pm @@ -24,7 +24,7 @@ package testutil; use strict; use warnings; -use Carp qw(croak); +use Carp qw(confess croak); use File::Basename; use File::Path qw(make_path remove_tree); use File::Spec; @@ -50,17 +50,21 @@ our $TEST_DIR = 'tmp-testing-trees'; our $ABS_TEST_DIR = File::Spec->rel2abs('tmp-testing-trees'); 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 # from a separate directory outside the Stow directory or # target directory. for my $dir ("target", "stow", "run_from") { - my $path = "$TEST_DIR/$dir"; + my $path = "$test_dir/$dir"; -d $path and remove_tree($path); make_path($path); } # 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 { @@ -70,7 +74,11 @@ sub new_Stow { $opts{dir} ||= '../stow'; $opts{target} ||= '.'; $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 { diff --git a/t/unstow.t b/t/unstow.t index 15288c9..4252694 100755 --- a/t/unstow.t +++ b/t/unstow.t @@ -22,21 +22,86 @@ use strict; 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 English qw(-no_match_vars); use testutil; use Stow::Util qw(canon_path); -init_test_dirs(); -cd("$TEST_DIR/target"); +my $repo = getcwd(); -# 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; - my $stow = new_Stow(); make_path('../stow/pkg1/bin1'); make_file('../stow/pkg1/bin1/file1'); @@ -44,14 +109,14 @@ subtest("unstow a simple tree minimally", sub { $stow->plan_unstow('pkg1'); $stow->process_tasks(); - is($stow->get_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); ok(-f '../stow/pkg1/bin1/file1'); 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; - my $stow = new_Stow(); make_path('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'); $stow->plan_unstow('pkg2'); $stow->process_tasks(); - is($stow->get_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); ok(-f '../stow/pkg2/lib2/file2'); ok(-d 'lib2' => '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; - my $stow = new_Stow(); make_path('bin3'); @@ -81,16 +146,16 @@ subtest("fold tree after unstowing", sub { make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow $stow->plan_unstow('pkg3b'); $stow->process_tasks(); - is($stow->get_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); 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 { +subtests("existing link is owned by stow but is invalid so it gets removed anyway", sub { + my ($stow) = @_; plan tests => 2; - my $stow = new_Stow(); make_path('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->process_tasks(); - is($stow->get_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); ok(! -e 'bin4/file4' => q(remove invalid link owned by stow) ); }); -subtest("Existing link is not owned by stow", sub { - plan tests => 1; - my $stow = new_Stow(); +subtests("Existing invalid link is not owned by stow", sub { + my ($stow) = @_; + plan tests => 3; make_path('../stow/pkg5/bin5'); make_invalid_link('bin5', '../not-stow'); $stow->plan_unstow('pkg5'); - my %conflicts = $stow->get_conflicts; - like( - $conflicts{unstow}{pkg5}[-1], - qr(existing target is not owned by stow) - => q(existing link not owned by stow) - ); + is($stow->get_conflict_count, 0, 'conflict count'); + ok(-l 'bin5', 'invalid link not removed'); + is(readlink('bin5'), '../not-stow' => "invalid link not changed"); }); -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; - my $stow = new_Stow(); make_path('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'); $stow->plan_unstow('pkg6b'); - is($stow->get_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); ok(-l 'bin6/file6'); is( 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 { - plan tests => 4; - make_path('stow'); # make out stow dir a subdir of target - my $stow = new_Stow(dir => 'stow'); +subtests("Don't unlink anything under the stow directory", + sub { + make_path('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_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'); - $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_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); ok(-l 'stow/pkg7b'); is( 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; - 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) make_path('stow/pkg8a/stow2/pkg8b'); make_file('stow/pkg8a/stow2/pkg8b/file8b'); @@ -179,10 +254,10 @@ subtest("Don't unlink any nodes under another stow directory", sub { stderr_like( sub { $stow->plan_unstow('pkg8a'); }, 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_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); ok(-l 'stow2/pkg8b'); is( readlink('stow2/pkg8b'), @@ -191,11 +266,24 @@ subtest("Don't unlink any nodes under another stow directory", sub { ); }); -subtest("overriding already stowed documentation", sub { - plan tests => 2; - my $stow = new_Stow(override => ['man9', 'info9']); - make_file('stow/.stow'); +# This will be used by subsequent tests +sub check_protected_dirs_skipped { + my ($stderr) = @_; + 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_file('../stow/pkg9a/man9/man1/file9.1'); make_path('man9/man1'); @@ -203,18 +291,22 @@ subtest("overriding already stowed documentation", sub { make_path('../stow/pkg9b/man9/man1'); 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(); - is($stow->get_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); ok(!-l 'man9/man1/file9.1' => 'overriding existing documentation files' ); }); -subtest("deferring to already stowed documentation", sub { - plan tests => 3; - my $stow = new_Stow(defer => ['man10', 'info10']); +subtests("deferring to already stowed documentation", + {defer => ['man10', 'info10']}, + sub { + my ($stow) = @_; + plan_tests($stow, 3); + init_stow2(); make_path('../stow/pkg10a/man10/man1'); make_file('../stow/pkg10a/man10/man1/file10a.1'); make_path('man10/man1'); @@ -225,12 +317,12 @@ subtest("deferring to already stowed documentation", sub { 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'); - $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_conflict_count, 0); + is($stow->get_conflict_count, 0, 'conflict count'); is( readlink('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 { - plan tests => 2; - my $stow = new_Stow(ignore => ['~', '\.#.*']); +subtests("Ignore temp files", + {ignore => ['~', '\.#.*']}, + sub { + my ($stow) = @_; + plan_tests($stow, 2); + init_stow2(); make_path('../stow/pkg12/man12/man1'); 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_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(); - is($stow->get_conflict_count, 0); - ok(!-e 'man12/man1/file12.1' => 'ignore temp files'); + is($stow->get_conflict_count, 0, 'conflict count'); + ok(! -e 'man12/man1/file12.1' => 'man12/man1/file12.1 was unstowed'); }); -subtest("Unstow an already unstowed package", sub { - plan tests => 2; - my $stow = new_Stow(); - $stow->plan_unstow('pkg12'); +subtests("Unstow an already unstowed package", sub { + my ($stow) = @_; + plan_tests($stow, 2); + + 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_conflict_count, 0 - => 'unstow already unstowed package pkg12' - ); + is($stow->get_conflict_count, 0, 'conflict count'); }); -subtest("Unstow a never stowed package", sub { +subtests("Unstow a never stowed package", sub { + my ($stow) = @_; plan tests => 2; - eval { remove_dir("$TEST_DIR/target"); }; - mkdir("$TEST_DIR/target"); + eval { remove_dir($stow->{target}); }; + mkdir($stow->{target}); - my $stow = new_Stow(); $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' - ); + is($stow->get_conflict_count, 0, 'conflict count'); }); -subtest("Unstowing when target contains a real file shouldn't be an issue", sub { - plan tests => 3; +subtests("Unstowing when target contains real files shouldn't be an issue", sub { + 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'); - my $stow = new_Stow(); $stow->plan_unstow('pkg12'); 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, 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' - ); + is($stow->get_conflict_count, 0, 'conflict count'); + ok(-f 'man12/man1/alien', 'alien untouched'); + ok(-f 'man12/man1/file12.1', 'file overlapping with pkg untouched'); }); -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; - 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'); + 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'); + is($stow->get_conflict_count, 0, 'conflict count'); + ok(-f "$test_dir/stow/pkg13/bin13/file13", 'package file untouched'); + 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; - my $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"), - target => "$TEST_DIR/target"); + my ($stow, $test_dir) = @_; - make_path("$TEST_DIR/stow/pkg14/bin14"); - make_file("$TEST_DIR/stow/pkg14/bin14/file14"); - make_link("$TEST_DIR/target/bin14", '../stow/pkg14/bin14'); + 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" + is($stow->get_conflict_count, 0, 'conflict count'); + 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 { +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; - 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'); + 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" + is($stow->get_conflict_count, 0, 'conflict count'); + ok(-f "$test_dir/stow/pkg15/bin15/file15"); + ok(! -e "$test_dir/target/bin15" => '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 { my ($id, $pkg) = @_; my $stow_pkg = "../stow/$id-$pkg"; - make_path ($stow_pkg); + make_path($stow_pkg); make_file("$stow_pkg/$id-file-$pkg"); # create a shallow hierarchy specific to this package and stow # 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_link("$id-$pkg-only-folded", "$stow_pkg/$id-$pkg-only-folded"); # create a deeper hierarchy specific to this package and stow # 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_link("$id-$pkg-only-folded2", "$stow_pkg/$id-$pkg-only-folded2"); # create a shallow hierarchy specific to this package and stow # 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_path ("$id-$pkg-only-unfolded"); + make_path("$id-$pkg-only-unfolded"); make_link("$id-$pkg-only-unfolded/file-$pkg", "../$stow_pkg/$id-$pkg-only-unfolded/file-$pkg"); # create a deeper hierarchy specific to this package and stow # 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_path ("$id-$pkg-only-unfolded2/subdir"); + make_path("$id-$pkg-only-unfolded2/subdir"); make_link("$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 # 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_path ("$id-shared"); + make_path("$id-shared"); make_link("$id-shared/file-$pkg", "../$stow_pkg/$id-shared/file-$pkg"); # create a deeper shared hierarchy which this package uses, and stow # 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/subdir/file-$pkg"); - make_path ("$id-shared2/subdir"); + make_path("$id-shared2/subdir"); make_link("$id-shared2/file-$pkg", "../$stow_pkg/$id-shared2/file-$pkg"); make_link("$id-shared2/subdir/file-$pkg", "../../$stow_pkg/$id-shared2/subdir/file-$pkg"); } -foreach my $pkg (qw{a b}) { - create_and_stow_pkg('no-folding', $pkg); -} +subtest("unstow a tree with no-folding enabled - no refolding should take place", sub { + cd("$TEST_DIR/target"); + plan tests => 15; -my $stow = new_Stow('no-folding' => 1); -$stow->plan_unstow('no-folding-b'); -is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding'); -use Data::Dumper; -#warn Dumper($stow->get_tasks); + foreach my $pkg (qw{a b}) { + create_and_stow_pkg('no-folding', $pkg); + } -$stow->process_tasks(); + my $stow = new_Stow('no-folding' => 1); + $stow->plan_unstow('no-folding-b'); + is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding'); -is_nonexistent_path('no-folding-b-only-folded'); -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-unfolded2/subdir/file-b'); -is_dir_not_symlink('no-folding-shared'); -is_dir_not_symlink('no-folding-shared2'); -is_dir_not_symlink('no-folding-shared2/subdir'); + $stow->process_tasks(); + is_nonexistent_path('no-folding-b-only-folded'); + 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-unfolded2/subdir/file-b'); + is_dir_not_symlink('no-folding-shared'); + is_dir_not_symlink('no-folding-shared2'); + is_dir_not_symlink('no-folding-shared2/subdir'); +}); -# Todo -# -# Test cleaning up subdirs with --paranoid option +# subtests("Test cleaning up subdirs with --paranoid option", sub { +# TODO +# }); diff --git a/t/unstow_orig.t b/t/unstow_orig.t deleted file mode 100755 index 9d62bd9..0000000 --- a/t/unstow_orig.t +++ /dev/null @@ -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 -# });