From a070116621ffb135ff77e32689976129aa3805ca Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 12:51:21 +0100 Subject: [PATCH 01/13] Fix Dockerfile by updating from jessie to bookworm --- docker/Dockerfile | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) 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 \ From 5e21f47879f9546f905005ca4082af8075ea7e77 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 13:08:27 +0100 Subject: [PATCH 02/13] read_a_link(): clarify debug message when it's a real link --- lib/Stow.pm.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index b402d9a..e844253 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -2078,7 +2078,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; } From a7c251c316c83d34d51ac0aa2e154cac4ea578f9 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 14:08:59 +0100 Subject: [PATCH 03/13] tidy up MANIFEST.SKIP --- MANIFEST.SKIP | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index 4fd408e..a771f30 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -84,15 +84,12 @@ # Avoid test files tmp-testing-trees -.coveralls.yml -.github/workflows/ -.travis.yml +^.coveralls.yml +^.github/workflows/ +^.travis.yml ^docker/ ^[a-zA-Z]*-docker.sh # Avoid development config -.dir-locals.el -.dumbjump - -# Avoid CI -.github/ \ No newline at end of file +^.dir-locals.el +^.dumbjump From 001b287b1be5f391189023469db25c832bbf9b4e Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 14:09:15 +0100 Subject: [PATCH 04/13] allow playground/ directory for testing stuff --- .gitignore | 1 + CONTRIBUTING.md | 5 +++++ MANIFEST.SKIP | 1 + 3 files changed, 7 insertions(+) diff --git a/.gitignore b/.gitignore index dcb7f4d..81f5836 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,7 @@ /bin/stow /doc/stow.info /doc/version.texi +/playground/ tmp-testing-trees/ _build/ autom4te.cache/ 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.SKIP b/MANIFEST.SKIP index a771f30..033f12a 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -89,6 +89,7 @@ tmp-testing-trees ^.travis.yml ^docker/ ^[a-zA-Z]*-docker.sh +^playground/ # Avoid development config ^.dir-locals.el From 06fdfc185f1e4c27c01347021fd258dd6466a03c Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Tue, 2 Apr 2024 00:36:51 +0100 Subject: [PATCH 05/13] merge unstow_orig.t into unstow.t and fix unstowing logic There was a ton of duplication which is not maintainable, so refactor everything into a single test which still covers the differences. This in turn revealed some issues in the unstowing logic: - We shouldn't conflict if we find a file which isn't a link or a directory; we can just skip over it. - Unstowing with `--dotfiles` was using the wrong variable to obtain the package path, and as a result having to perform an unnecessary call to `adjust_dotfile()`. So fix those at the same time. --- .gitignore | 2 +- MANIFEST | 1 - MANIFEST.SKIP | 2 +- Makefile.am | 2 +- lib/Stow.pm.in | 83 ++-------- t/dotfiles.t | 2 +- t/testutil.pm | 16 +- t/unstow.t | 357 +++++++++++++++++++++++++++++-------------- t/unstow_orig.t | 393 ------------------------------------------------ 9 files changed, 269 insertions(+), 589 deletions(-) delete mode 100755 t/unstow_orig.t diff --git a/.gitignore b/.gitignore index 81f5836..caf4ba3 100644 --- a/.gitignore +++ b/.gitignore @@ -10,7 +10,7 @@ /doc/stow.info /doc/version.texi /playground/ -tmp-testing-trees/ +tmp-testing-trees*/ _build/ autom4te.cache/ blib/ 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 033f12a..522b3fd 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -83,7 +83,7 @@ ^doc/HOWTO-RELEASE$ # Avoid test files -tmp-testing-trees +tmp-testing-trees* ^.coveralls.yml ^.github/workflows/ ^.travis.yml 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/lib/Stow.pm.in b/lib/Stow.pm.in index e844253..40351bb 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -787,17 +787,15 @@ 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(3, 1, "Unstowing $source"); debug(4, 2, "target is $target_subpath"); # 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, $target_subpath, $source); } - elsif ($self->{compat} && -d $target_subpath) { - $self->unstow_contents($package, $target_subpath, $pkg_path_from_cwd); + elsif (-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)) { @@ -805,16 +803,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"); @@ -859,7 +848,12 @@ sub unstow_link_node { # 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) { + $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 +861,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 diff --git a/t/dotfiles.t b/t/dotfiles.t index 83874ca..5719eaa 100755 --- a/t/dotfiles.t +++ b/t/dotfiles.t @@ -187,7 +187,7 @@ 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(-f '../stow/dotfiles/dot-bar', 'package file untouched'); ok(! -e '.bar' => 'unstow a simple dotfile'); }); 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..9fd7852 100755 --- a/t/unstow.t +++ b/t/unstow.t @@ -22,21 +22,70 @@ use strict; use warnings; -use Test::More tests => 32; +use File::Spec qw(make_path); +use POSIX qw(getcwd); +use Test::More tests => 49; 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'); +} + +# 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"); + # 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"); + # 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 +93,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 +108,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 +130,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 +148,57 @@ 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; + plan tests => 2; + $ENV{HOME} = $ABS_TEST_DIR; + cd($repo); + cd("$TEST_DIR/target"); my $stow = new_Stow(); 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, 1, 'conflict count'); + my %conflicts = $stow->get_conflicts(); + is_deeply( + \%conflicts, + { + 'unstow' => { + 'pkg5' => [ + 'existing target is not owned by stow: bin5 => ../not-stow' + ] + } + } + => "existing link not owned by stow" ); }); -subtest("Target already exists, is owned by stow, but points to a different package", sub { +subtest("Existing link is not owned by stow (compat mode)", sub { + plan tests => 2; + $ENV{HOME} = $COMPAT_ABS_TEST_DIR; + cd($repo); + cd("$COMPAT_TEST_DIR/target"); + my $stow = new_compat_Stow(); + + make_path('../stow/pkg5/bin5'); + make_invalid_link('bin5', '../not-stow'); + + $stow->plan_unstow('pkg5'); + # Unlike the non-compat test above, this doesn't cause any conflicts. + ok(-l 'bin5'); + is(readlink('bin5'), '../not-stow' => "existing link not owned by stow"); +}); + +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 +209,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 +218,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 +249,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 +267,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 +279,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 +304,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 +330,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 +343,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,103 +357,123 @@ 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' ); }); @@ -432,7 +560,6 @@ 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 -# }); From 744ba651f50341a998c97341809eeda4f8e181e0 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 13:08:56 +0100 Subject: [PATCH 06/13] unstow_link_node(): don't register conflicts when unstowing unowned links --- lib/Stow.pm.in | 17 ++++------------- t/unstow.t | 41 ++++++----------------------------------- 2 files changed, 10 insertions(+), 48 deletions(-) diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index 40351bb..7647a42 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -830,19 +830,10 @@ 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; } diff --git a/t/unstow.t b/t/unstow.t index 9fd7852..1c7f967 100755 --- a/t/unstow.t +++ b/t/unstow.t @@ -154,46 +154,17 @@ subtests("existing link is owned by stow but is invalid so it gets removed anywa ); }); -subtest("Existing link is not owned by stow", sub { - plan tests => 2; - $ENV{HOME} = $ABS_TEST_DIR; - cd($repo); - cd("$TEST_DIR/target"); - 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'); - is($stow->get_conflict_count, 1, 'conflict count'); - my %conflicts = $stow->get_conflicts(); - is_deeply( - \%conflicts, - { - 'unstow' => { - 'pkg5' => [ - 'existing target is not owned by stow: bin5 => ../not-stow' - ] - } - } - => "existing link not owned by stow" - ); -}); - -subtest("Existing link is not owned by stow (compat mode)", sub { - plan tests => 2; - $ENV{HOME} = $COMPAT_ABS_TEST_DIR; - cd($repo); - cd("$COMPAT_TEST_DIR/target"); - my $stow = new_compat_Stow(); - - make_path('../stow/pkg5/bin5'); - make_invalid_link('bin5', '../not-stow'); - - $stow->plan_unstow('pkg5'); - # Unlike the non-compat test above, this doesn't cause any conflicts. - ok(-l 'bin5'); - is(readlink('bin5'), '../not-stow' => "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"); }); subtests("Target already exists, is owned by stow, but points to a different package", sub { From afa50077c98b6fc0b13530912b2c1ea35603ee32 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Mon, 1 Apr 2024 22:50:58 +0100 Subject: [PATCH 07/13] dotfiles: switch {un,}stow_{contents,node}() recursion parameters Stow walks the package and target tree hierarchies by using mutually recursive pairs of functions: - `stow_contents()` and `stow_node()` - `unstow_contents()` and `unstow_node()` As Stow runs its planning from the target directory (`plan_*()` both call `within_target_do()`), previously the parameters for these included: - `$target_subpath` (or `$target_subdir` in the `*_node()` functions): the relative path from the target top-level directory to the target subdirectory (initially `.` at the beginning of recursion). For example, this could be `dir1/subdir1/file1`. - `$source`: the relative path from the target _subdirectory_ (N.B. _not_ top-level directory) to the package subdirectory. For example, if the relative path to the Stow directory is `../stow`, this could be `../../../stow/pkg1/dir1/subdir1/file1`. This is used when stowing to construct a new link, or when unstowing to detect whether the link can be unstowed. Each time it descends into a further subdirectory of the target and package, it appends the new path segment onto both of these, and also prefixes `$source` with another `..`. When the `--dotfiles` parameter is enabled, it adjusts `$target_subdir`, performing the `dot-foo` => `.foo` adjustment on all segments of the path in one go. In this case, `$target_subpath` could be something like `.dir1/subdir1/file1`, and the corresponding `$source` could be something like `../../../stow/pkg1/dot-dir1/subdir1/file1`. However this doesn't leave an easy way to obtain the relative path from the target _top-level_ directory to the package subdirectory (i.e. `../stow/pkg1/dot-dir1/subdir1/file1`), which is needed for checking its existence and if necessary iterating over its contents. The current implementation solves this by including an extra `$level` parameter which tracks the recursion depth, and uses that to strip the right number of leading path segments off the front of `$source`. (In the above example, it would remove `../..`.) This implementation isn't the most elegant because: - It involves adding things to `$source` and then removing them again. - It performs the `dot-` => `.` adjustment on every path segment at each level, which is overkill, since when recursing down a level, only adjustment on the final subdirectory is required since the higher segments have already had any required adjustment. This in turn requires `adjust_dotfile` to be more complex than it needs to be. It also prevents a potential future where we might want Stow to optionally start iterating from within a subdirectory of the whole package install image / target tree, avoiding adjustment at higher levels and only doing it at the levels below the starting point. - It requires passing an extra `$level` parameter which can be automatically calculated simply by counting the number of slashes in `$target_subpath`. So change the `$source` recursion parameter to instead track the relative path from the top-level package directory to the package subdirectory or file being considered for (un)stowing, and rename it to avoid the ambiguity caused by the word "source". Also automatically calculate the depth simply by counting the number of slashes, and reconstruct `$source` when needed by combining the relative path to the Stow directory with the package name and `$target_subpath`. Closes #33. --- lib/Stow.pm.in | 255 +++++++++++++++++++++++++++----------------- lib/Stow/Util.pm.in | 14 +-- t/dotfiles.t | 13 +-- 3 files changed, 162 insertions(+), 120 deletions(-) diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index 7647a42..2c94622 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -284,7 +284,7 @@ sub plan_unstow { $self->unstow_contents( $package, '.', - $pkg_path, + '.', ); debug(2, 0, "Planning unstow of package $package... done"); $self->{action_count}++; @@ -319,8 +319,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 +360,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 +378,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 +427,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 +467,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 +490,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 +549,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 +558,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 +574,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,9 +595,9 @@ 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)) { @@ -592,15 +606,14 @@ sub stow_node { $self->stow_contents( $self->{stow_path}, $package, + $pkg_subpath, $target_subpath, - join_paths('..', $source), - $level + 1, ); } else { if ($self->{adopt}) { - $self->do_mv($target_subpath, $path); - $self->do_link($source, $target_subpath); + $self->do_mv($target_subpath, $pkg_path_from_cwd); + $self->do_link($link_dest, $target_subpath); } else { $self->conflict( @@ -611,18 +624,17 @@ sub stow_node { } } } - 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 +696,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 +706,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 +728,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 +752,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 +764,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 +774,29 @@ 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; + # $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 +804,7 @@ sub unstow_contents { } } -=head2 unstow_node($package, $target_subpath) +=head2 unstow_node($package, $pkg_subpath, $target_subpath) Unstow the given node. @@ -773,9 +814,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,17 +835,19 @@ C and C are mutually recursive. sub unstow_node { my $self = shift; - my ($package, $target_subpath, $source) = @_; - - debug(3, 1, "Unstowing $source"); - 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, $source); + $self->unstow_link_node($package, $pkg_subpath, $target_subpath); } elsif (-d $target_subpath) { - $self->unstow_contents($package, $target_subpath, $source); + $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)) { @@ -812,7 +864,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? @@ -837,9 +889,12 @@ sub unstow_link_node { 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) { 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 { diff --git a/lib/Stow/Util.pm.in b/lib/Stow/Util.pm.in index 3b7dc3e..8ee42f9 100644 --- a/lib/Stow/Util.pm.in +++ b/lib/Stow/Util.pm.in @@ -239,17 +239,9 @@ sub restore_cwd { } sub adjust_dotfile { - my ($link_dest) = @_; - - 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; + my ($pkg_node) = @_; + (my $adjusted = $pkg_node) =~ s/^dot-([^.])/.$1/; + return $adjusted; } =head1 BUGS diff --git a/t/dotfiles.t b/t/dotfiles.t index 5719eaa..e954076 100755 --- a/t/dotfiles.t +++ b/t/dotfiles.t @@ -22,7 +22,7 @@ use strict; use warnings; -use Test::More tests => 10; +use Test::More tests => 11; use English qw(-no_match_vars); use Stow::Util qw(adjust_dotfile); @@ -32,17 +32,12 @@ 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; From 8ed799a3a38f9478bd49b134be05787cb9068232 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 15:42:06 +0100 Subject: [PATCH 08/13] t/unstow.t: create a bunch of unowned files to make tests more robust This should make it harder for Stow to do the right thing. --- t/unstow.t | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/t/unstow.t b/t/unstow.t index 1c7f967..7eab2d0 100755 --- a/t/unstow.t +++ b/t/unstow.t @@ -43,6 +43,20 @@ sub init_stow2 { 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 @@ -58,6 +72,7 @@ sub subtests { $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 { @@ -69,6 +84,7 @@ sub subtests { $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 { From 34421ba5cf34df7265017e6564fa4d7922e37182 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Tue, 2 Apr 2024 00:06:38 +0100 Subject: [PATCH 09/13] stow_contents: fix bugs and corner cases with type mismatch conflicts If the target directory as a file named X and a package has a directory named X, or vice-versa, then it is impossible for Stow to stow that entry X from the package, even if --adopt is supplied. However we were previously only handling the former case, and not the latter, and the test for the former was actually broken. So fix stow_contents() to handle both cases correctly, fix the broken test, and add a new test for the latter case. --- lib/Stow.pm.in | 40 +++++++++++++++++++++++++++++++--------- t/stow.t | 42 +++++++++++++++++++++++++++++++++++------- 2 files changed, 66 insertions(+), 16 deletions(-) diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index 2c94622..5a81855 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -603,23 +603,45 @@ sub stow_node { 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, - $pkg_subpath, - $target_subpath, - ); + 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, $pkg_path_from_cwd); - $self->do_link($link_dest, $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" ); } } 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); From 723ddcf3a4dcc0480585e2c831363652c5bbe5aa Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 15:57:03 +0100 Subject: [PATCH 10/13] t/dotfiles.t: improve language in test names and assertion messages We use the term "directory" (or "dir" for short) rather than "folder". Also explicitly say whether a test is stowing or unstowing, and fix the odd typo. --- t/dotfiles.t | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/t/dotfiles.t b/t/dotfiles.t index e954076..1c16522 100755 --- a/t/dotfiles.t +++ b/t/dotfiles.t @@ -48,7 +48,7 @@ subtest('adjust_dotfile()', sub { 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'); @@ -63,7 +63,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'); @@ -76,10 +76,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); @@ -91,11 +90,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); @@ -108,11 +107,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); @@ -125,11 +124,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); @@ -142,7 +141,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)' ); }); @@ -171,7 +170,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); @@ -186,7 +185,7 @@ subtest("simple unstow scenario", sub { ok(! -e '.bar' => 'unstow a simple dotfile'); }); -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); @@ -200,5 +199,5 @@ subtest("unstow process folder marked with 'dot' prefix when directory exists is 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(-d '.emacs.d/' => 'unstow dotfile dir when dir already exists'); }); From 93fc195ddb5588a3ebeb4d353909b8e58e45bf0b Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 17:19:37 +0100 Subject: [PATCH 11/13] Fix unstowing with `--compat --dotfiles` Unstowing with `--dotfiles` didn't work with `--compat`, because when traversing the target tree rather than the package tree, there was no mechanism for mapping a `.foo` file or directory back to its original `dot-foo` and determine whether it should be unstowed. So add a reverse `unadjust_dotfile()` mapping mechanism to support this. --- lib/Stow.pm.in | 27 ++++++++++++++++++++------- lib/Stow/Util.pm.in | 11 ++++++++++- t/dotfiles.t | 42 +++++++++++++++++++++++++++++++++++++----- 3 files changed, 67 insertions(+), 13 deletions(-) diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index 5a81855..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@'; @@ -801,12 +802,24 @@ sub unstow_contents { my $target_node = $node; if ($self->{dotfiles}) { - # $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; + 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); diff --git a/lib/Stow/Util.pm.in b/lib/Stow/Util.pm.in index 8ee42f9..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'; @@ -244,6 +245,14 @@ sub adjust_dotfile { return $adjusted; } +# 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 =head1 SEE ALSO diff --git a/t/dotfiles.t b/t/dotfiles.t index 1c16522..643b873 100755 --- a/t/dotfiles.t +++ b/t/dotfiles.t @@ -22,10 +22,10 @@ use strict; use warnings; -use Test::More tests => 11; +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(); @@ -46,6 +46,21 @@ 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 dot-foo as .foo", sub { @@ -182,7 +197,7 @@ subtest("unstow .bar from dot-bar", sub { $stow->process_tasks(); is($stow->get_conflict_count, 0); ok(-f '../stow/dotfiles/dot-bar', 'package file untouched'); - ok(! -e '.bar' => 'unstow a simple dotfile'); + ok(! -e '.bar' => '.bar was unstowed'); }); subtest("unstow dot-emacs.d/init.el when .emacs.d/init.el in target", sub { @@ -198,6 +213,23 @@ subtest("unstow dot-emacs.d/init.el when .emacs.d/init.el in target", sub { $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 dir when dir 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'); }); From c0b8890b144bfc0f6e77270452324c643cb750e8 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 17:24:13 +0100 Subject: [PATCH 12/13] t/unstow.t: remove superfluous spaces --- t/unstow.t | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/t/unstow.t b/t/unstow.t index 7eab2d0..c0e7639 100755 --- a/t/unstow.t +++ b/t/unstow.t @@ -475,52 +475,52 @@ 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", From 94ed91646620dbcc71cca1fa1fd20be65ec21d4a Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Sun, 7 Apr 2024 17:44:44 +0100 Subject: [PATCH 13/13] t/unstow.t: move final set of tests into a subtest --- t/unstow.t | 43 ++++++++++++++++++++----------------------- 1 file changed, 20 insertions(+), 23 deletions(-) diff --git a/t/unstow.t b/t/unstow.t index c0e7639..4252694 100755 --- a/t/unstow.t +++ b/t/unstow.t @@ -24,7 +24,7 @@ use warnings; use File::Spec qw(make_path); use POSIX qw(getcwd); -use Test::More tests => 49; +use Test::More tests => 35; use Test::Output; use English qw(-no_match_vars); @@ -465,12 +465,6 @@ subtests("unstow a simple tree minimally with absolute stow AND target dirs when ); }); -# -# unstow a tree with no-folding enabled - -# no refolding should take place -# -cd("$TEST_DIR/target"); - sub create_and_stow_pkg { my ($id, $pkg) = @_; @@ -527,25 +521,28 @@ sub create_and_stow_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'); +}); # subtests("Test cleaning up subdirs with --paranoid option", sub { # TODO