Compare commits

..

No commits in common. "08d7a9f7aff5d0dbd0fa72709d9f1b82bf3323e8" and "51e303a7980ee863cd2e2bb169fd8cfbc1903571" have entirely different histories.

36 changed files with 9984 additions and 3207 deletions

View file

@ -1 +0,0 @@
repo_token: xl1m2EiKjG4YlJQ0KjTTBNDRcAFD0lCVt

View file

@ -1,6 +0,0 @@
((cperl-mode . ((dumb-jump-force-searcher . rg)
(cperl-indent-level . 4)
(cperl-close-paren-offset . -4)
(cperl-indent-subs-specially . nil)
(indent-tabs-mode . nil)
(eval . (auto-fill-mode -1)))))

View file

@ -1,2 +0,0 @@
+bin/*.in
+lib/*.pm.in

View file

@ -1,80 +0,0 @@
# 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/.
name: Test suite
on:
push:
branches: [master]
pull_request:
branches: [master]
types: [opened, synchronize, reopened, ready_for_review]
jobs:
# call-simple-perl-test:
# uses: perl-actions/github-workflows/.github/workflows/simple-perltester-workflow.yml@main
# with:
# since-perl: 5.14
test:
name: Perl ${{ matrix.perl-version }}
runs-on: ubuntu-latest
strategy:
matrix:
perl-version:
- '5.38'
- '5.36'
- '5.34'
- '5.32'
- '5.30'
container:
# This Docker image should avoid the need to run:
#
# cpanm -n Devel::Cover::Report::Coveralls
image: perldocker/perl-tester:${{ matrix.perl-version }}
steps:
- run: apt-get update && apt-get install -y sudo texinfo texlive
- name: Checkout code
uses: actions/checkout@v2
# - uses: awalsh128/cache-apt-pkgs-action@latest
# with:
# debug: true
# packages: texinfo texlive
# version: 1.0
- run: autoreconf --install
- name: ./configure && make
run: |
eval `perl -V:siteprefix`
# Note: this will complain Test::Output isn't yet installed:
./configure --prefix=$siteprefix && make
# but that's OK because we install it here:
make cpanm
#- name: Run tests
# run: make test
- run: make distcheck
- run: perl Build.PL
- run: ./Build build
- run: cover -test -report coveralls
- run: ./Build distcheck

3
.gitignore vendored
View file

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

View file

@ -1,7 +1,3 @@
This file documents the high-level history of Stow, and some of its
major contributors. See also the THANKS file for a more complete list
of contributors.
Stow was originally written by Bob Glickstein <bobg+stow@zanshin.com>, Stow was originally written by Bob Glickstein <bobg+stow@zanshin.com>,
Zanshin Software, Inc. Zanshin Software, Inc.

View file

@ -1,123 +0,0 @@
Contributing to GNU Stow
========================
Development of Stow, and GNU in general, is a volunteer effort, and
you can contribute. If you'd like to get involved, it's a good idea to join
the [stow-devel](https://lists.gnu.org/mailman/listinfo/stow-devel)
mailing list.
Bug reporting
-------------
Please follow the procedure described in [the "Reporting Bugs"
section](https://www.gnu.org/software/stow/manual/html_node/Reporting-Bugs.html#Reporting-Bugs)
of [the manual](README.md#documentation).
Development
-----------
For [development sources](https://savannah.gnu.org/git/?group=stow)
and other information, please see the [Stow project
page](http://savannah.gnu.org/projects/stow/) at
[savannah.gnu.org](http://savannah.gnu.org).
There is also a
[stow-devel](https://lists.gnu.org/mailman/listinfo/stow-devel)
mailing list (see [Mailing lists](README.md#mailing-lists)).
Please be aware that all program source files (excluding the test
suite) end in `.in`, and are pre-processed by `Makefile` into
corresponding files with that prefix stripped before execution. So if
you want to test any modifications to the source, make sure that you
change the `.in` files and then run `make` to regenerate the
pre-processed versions before doing any testing. To avoid forgetting
(which can potentially waste a lot of time debugging the wrong code),
you can automatically run `make` in an infinite loop every second via:
make watch
(You could even use fancier approaches like
[`inotifywait(1)`](https://www.man7.org/linux/man-pages/man1/inotifywait.1.html)
or [Guard](https://guardgem.org/). But those are probably overkill in
this case where the simple `while` loop is plenty good enough.)
Testing
~~~~~~~
The test suite can be found in the [`t/`](t/) subdirectory. You can
run the test suite via:
make check
Tests can be run individually as follows. First you have to ensure
that the `t/`, `bin/`, and `lib/` directories are on Perl's search path.
Assuming that you run all tests from the root of the repository tree,
this will do the job:
export PERL5LIB=t:bin:lib
(Not all tests require all of these, but it's safer to include all of
them.)
Secondly, be aware that if you want to test modifications to the
source files, you will need to run `make watch`, or `make` before each
test run as explained above.
Now running an individual test is as simple as:
perl t/chkstow.t
or with a given debugging verbosity corresponding to the `-v` / `--verbose`
command-line option:
TEST_VERBOSE=4 perl t/chkstow.t
The [`prove(1)` test runner](https://perldoc.perl.org/prove) is another
good alternative which provides several handy extra features. Invocation
is very similar, e.g.:
prove t/stow.t
or to run the whole suite:
prove
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.
Test coverage
~~~~~~~~~~~~~
To view test coverage reports, first ensure that
[`Devel::Cover`](https://metacpan.org/dist/Devel-Cover) is installed.
Then type `make coverage`. The last lines of the output should
include something like:
HTML output written to /home/user/path/to/stow/cover_db/coverage.html
which you can open in a web browser to view the report.
Translating Stow
----------------
Stow is not currently multi-lingual, but patches would be very
gratefully accepted. Please e-mail
[stow-devel](https://lists.gnu.org/mailman/listinfo/stow-devel) if you
intend to work on this.
Maintainers
-----------
Stow is currently being maintained by Adam Spiers. Please use [the
mailing lists](README.md#mailing-lists).
Helping the GNU project
-----------------------
For more general information, please read [How to help
GNU](https://www.gnu.org/help/).

View file

@ -3,7 +3,6 @@ aclocal.m4
automake/install-sh automake/install-sh
automake/mdate-sh automake/mdate-sh
automake/missing automake/missing
automake/texinfo.tex
bin/chkstow bin/chkstow
bin/chkstow.in bin/chkstow.in
bin/stow bin/stow
@ -12,7 +11,6 @@ Build.PL
ChangeLog ChangeLog
configure configure
configure.ac configure.ac
CONTRIBUTING.md
COPYING COPYING
default-ignore-list default-ignore-list
doc/ChangeLog.OLD doc/ChangeLog.OLD
@ -21,6 +19,7 @@ doc/manual.pdf
doc/stow.8 doc/stow.8
doc/stow.info doc/stow.info
doc/stow.texi doc/stow.texi
doc/texinfo.tex
doc/version.texi doc/version.texi
INSTALL.md INSTALL.md
lib/Stow.pm lib/Stow.pm
@ -44,12 +43,12 @@ t/find_stowed_path.t
t/foldable.t t/foldable.t
t/ignore.t t/ignore.t
t/join_paths.t t/join_paths.t
t/link_dest_within_stow_dir.t
t/parent.t t/parent.t
t/stow.t t/stow.t
t/rc_options.t t/rc_options.t
t/testutil.pm t/testutil.pm
t/unstow.t t/unstow.t
t/unstow_orig.t
tools/get-version tools/get-version
THANKS THANKS
TODO TODO

View file

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

View file

@ -4,7 +4,7 @@
"unknown" "unknown"
], ],
"dynamic_config" : 1, "dynamic_config" : 1,
"generated_by" : "Module::Build version 0.4234", "generated_by" : "Module::Build version 0.4224",
"license" : [ "license" : [
"gpl_1" "gpl_1"
], ],
@ -37,11 +37,11 @@
"provides" : { "provides" : {
"Stow" : { "Stow" : {
"file" : "lib/Stow.pm", "file" : "lib/Stow.pm",
"version" : "v2.4.0" "version" : "v2.3.2-fixbug56727"
}, },
"Stow::Util" : { "Stow::Util" : {
"file" : "lib/Stow/Util.pm", "file" : "lib/Stow/Util.pm",
"version" : "v2.4.0" "version" : "v2.3.2-fixbug56727"
} }
}, },
"release_status" : "stable", "release_status" : "stable",
@ -55,6 +55,6 @@
"url" : "git://git.savannah.gnu.org/stow.git" "url" : "git://git.savannah.gnu.org/stow.git"
} }
}, },
"version" : "v2.4.0", "version" : "v2.3.2-fixbug56727",
"x_serialization_backend" : "JSON::PP version 4.16" "x_serialization_backend" : "JSON::PP version 4.00"
} }

View file

@ -9,7 +9,7 @@ build_requires:
configure_requires: configure_requires:
Module::Build: '0' Module::Build: '0'
dynamic_config: 1 dynamic_config: 1
generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010'
license: gpl license: gpl
meta-spec: meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html url: http://module-build.sourceforge.net/META-spec-v1.4.html
@ -18,10 +18,10 @@ name: Stow
provides: provides:
Stow: Stow:
file: lib/Stow.pm file: lib/Stow.pm
version: v2.4.0 version: v2.3.2-fixbug56727
Stow::Util: Stow::Util:
file: lib/Stow/Util.pm file: lib/Stow/Util.pm
version: v2.4.0 version: v2.3.2-fixbug56727
requires: requires:
Carp: '0' Carp: '0'
IO::File: '0' IO::File: '0'
@ -30,5 +30,5 @@ resources:
homepage: https://savannah.gnu.org/projects/stow homepage: https://savannah.gnu.org/projects/stow
license: http://www.gnu.org/licenses/gpl-2.0.html license: http://www.gnu.org/licenses/gpl-2.0.html
repository: git://git.savannah.gnu.org/stow.git repository: git://git.savannah.gnu.org/stow.git
version: v2.4.0 version: v2.3.2-fixbug56727
x_serialization_backend: 'CPAN::Meta::YAML version 0.018' x_serialization_backend: 'CPAN::Meta::YAML version 0.018'

View file

@ -32,26 +32,26 @@ pmstowdir = $(pmdir)/Stow
pm_DATA = lib/Stow.pm pm_DATA = lib/Stow.pm
pmstow_DATA = lib/Stow/Util.pm pmstow_DATA = lib/Stow/Util.pm
TEXINFO_TEX = doc/texinfo.tex
export TEXI2DVI_BUILD_MODE = clean export TEXI2DVI_BUILD_MODE = clean
AM_MAKEINFOFLAGS = -I $(srcdir) AM_MAKEINFOFLAGS = -I $(srcdir)
# We require this -I parameter to ensure that the include of the # We require this -I parameter to ensure that the include of the
# default ignore list in the manual works correctly, even when the # default ignore list in the manual works. Unfortunately this is
# manual is being built via make distcheck from a different directory. # the only way to do it:
# Unfortunately this is the only way to do it:
# #
# https://lists.gnu.org/archive/html/bug-automake/2008-09/msg00040.html # http://article.gmane.org/gmane.comp.sysutils.automake.bugs/4334/match=passing+parameters
# #
# even though it annoyingly produces a warning with the -Wall option # even though it annoyingly produces a warning with the -Wall option
# to AM_INIT_AUTOMAKE which has to be silenced via -Wno-override. # to AM_INIT_AUTOMAKE which has to be silenced via -Wno-override.
TEXI2DVI = texi2dvi $(AM_MAKEINFOFLAGS) TEXI2DVI = texi2dvi $(AM_MAKEINFOFLAGS)
doc_deps = $(info_TEXINFOS) doc/version.texi
DEFAULT_IGNORE_LIST = $(srcdir)/default-ignore-list DEFAULT_IGNORE_LIST = $(srcdir)/default-ignore-list
doc_deps = $(info_TEXINFOS) doc/version.texi $(DEFAULT_IGNORE_LIST)
TESTS_DIR = $(srcdir)/t TESTS_DIR = $(srcdir)/t
TESTS_OUT = tmp-testing-trees tmp-testing-trees-compat TESTS_OUT = tmp-testing-trees
TESTS_ENVIRONMENT = $(PERL) -Ibin -Ilib -I$(TESTS_DIR) TESTS_ENVIRONMENT = $(PERL) -Ibin -Ilib -I$(TESTS_DIR)
# This is a kind of hack; TESTS needs to be set to ensure that the # This is a kind of hack; TESTS needs to be set to ensure that the
@ -77,7 +77,7 @@ check_DATA = $(TESTS_OUT)
# Note that automake's `check' rule cannot be overridden # Note that automake's `check' rule cannot be overridden
# for some weird reason: # for some weird reason:
# #
# https://lists.gnu.org/archive/html/automake/2011-09/msg00029.html # http://thread.gmane.org/gmane.comp.sysutils.automake.general/13040/focus=13041
# #
# so we override check-TESTS instead which is where the real work is # so we override check-TESTS instead which is where the real work is
# done anyway. Unfortunately this produces a warning with the -Wall # done anyway. Unfortunately this produces a warning with the -Wall
@ -87,10 +87,6 @@ check-TESTS:
dir=$(TESTS_DIR); \ dir=$(TESTS_DIR); \
$(TESTS_ENVIRONMENT) -MTest::Harness -e 'runtests(@ARGV)' "$${dir#./}"/*.t $(TESTS_ENVIRONMENT) -MTest::Harness -e 'runtests(@ARGV)' "$${dir#./}"/*.t
coverage:
PERL5OPT=-MDevel::Cover $(MAKE) check-TESTS
cover
$(TESTS_OUT): $(TESTS_OUT):
mkdir -p $@ mkdir -p $@
@ -99,6 +95,7 @@ EXTRA_DIST = \
bin/stow.in bin/chkstow.in lib/Stow.pm.in lib/Stow/Util.pm.in \ bin/stow.in bin/chkstow.in lib/Stow.pm.in lib/Stow/Util.pm.in \
doc/manual-split \ doc/manual-split \
$(TESTS) t/testutil.pm \ $(TESTS) t/testutil.pm \
$(TEXINFO_TEX) \
$(DEFAULT_IGNORE_LIST) \ $(DEFAULT_IGNORE_LIST) \
$(CPAN_FILES) $(CPAN_FILES)
CLEANFILES = $(bin_SCRIPTS) $(pm_DATA) $(pmstow_DATA) CLEANFILES = $(bin_SCRIPTS) $(pm_DATA) $(pmstow_DATA)
@ -196,7 +193,7 @@ doc/stow.8: bin/stow.in Makefile.am
# #
# If it were not for a troublesome dependency on doc/$(am__dirstamp): # If it were not for a troublesome dependency on doc/$(am__dirstamp):
# #
# https://lists.gnu.org/archive/html/automake/2011-11/msg00107.html # http://article.gmane.org/gmane.comp.sysutils.automake.general/13192
# #
# we could have achieved this using the built-in rules combined with # we could have achieved this using the built-in rules combined with
# install-data-hook to rename from stow.pdf to manual.pdf etc. on # install-data-hook to rename from stow.pdf to manual.pdf etc. on
@ -305,28 +302,3 @@ ChangeLog: doc/ChangeLog.OLD
else \ else \
echo "Not in a git repository; can't update ChangeLog."; \ echo "Not in a git repository; can't update ChangeLog."; \
fi fi
# Watch for changes, and if any rebuilds are required, also do a
# make install.
#
# If we solved https://github.com/aspiers/stow/issues/84, we could
# probably ditch this:
watch:
@echo "Watching for changes to program source files ..."
@while true; do \
if $(MAKE) 2>&1 | \
grep -vE 'make\[[1-9]\]: (Entering|Leaving) directory ' | \
grep -v 'Nothing to be done'; \
then \
echo; \
echo "-----------------------------------------------------"; \
echo "make found things to rebuild; doing $(MAKE) install ..."; \
echo; \
$(MAKE) install; \
echo; \
echo ">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"; \
echo; \
fi; \
sleep 1; \
done 2>&1 | \
grep -vE 'make\[[1-9]\]: (Entering|Leaving) directory '

82
NEWS
View file

@ -1,81 +1,5 @@
News file for Stow. News file for Stow.
* Changes in version 2.4.0
*** --dotfiles now works with directories
A long-standing bug preventing the --dotfiles option from working
correctly with directories has been fixed.
It should also works in combination with the --compat option.
*** Eliminated a spurious warning on unstowing
2.3.1 introduced a benign but annoying warning when unstowing
in certain circumstances. It looked like:
BUG in find_stowed_path? Absolute/relative mismatch between Stow dir X and path Y
This was caused by erroneous logic, and has now been fixed.
*** Unstowing logic has been improved in other cases
Several other improvements have been made internally to the
unstowing logic. These changes should all be either invisible
(except for changes to debug output) or improvements, but if you
encounter any unexpected behaviour, please report it as directed
in the manual.
*** Improved debug output
Extra output resulting from use of the -v / --verbose flag
now appears in a more logical and understandable way.
*** Janitorial tasks
Users are not substantially affected by these changes.
***** Added some more information from the web page to the README
***** Made some improvements to the documentation
***** Improve readability of source code
Quite a few extra details have been added in comments to clarify
how the code works. Many variable names have also been
improved. The comments of many Stow class methods have been
converted into Perl POD format.
***** Added a =CONTRIBUTING.md= file
***** Add a =watch= target to =Makefile=
=make watch= provides easy continual pre-processing during
development, which reduces the risk of debugging the wrong code.
***** Removed texinfo.tex from the distribution
This eliminates existing and future bit-rot.
***** Updated aclocal.m4 from 1.15.1 to 1.16.5
This mostly just updates copyright notices to 2021, and URLs to https.
***** Replace broken gmane links with links to lists.gnu.org
[[https://lars.ingebrigtsen.no/2020/01/06/whatever-happened-to-news-gmane-org/][gmane has been dead for quite a while.]]
***** Improve support for navigating / editing source via emacs
******* Support source navigation in emacs via [[https://github.com/jacktasia/dumb-jump][dumb-jump]].
******* Configure cperl-mode to match existing coding style.
*** Various maintainer tweaks
Further improved the release process and its documentation in
various minor ways.
* Changes in version 2.3.1 * Changes in version 2.3.1
*** Remove dependencies on Hash::Merge and Clone::Choose *** Remove dependencies on Hash::Merge and Clone::Choose
@ -214,7 +138,6 @@ News file for Stow.
consistency. consistency.
- INSTALL.md now also documents how to build directly from git. - INSTALL.md now also documents how to build directly from git.
*** Fixes for bugs, tests, and other technical debt *** Fixes for bugs, tests, and other technical debt
***** Add Docker files for convenient testing across multiple Perl versions ***** Add Docker files for convenient testing across multiple Perl versions
@ -312,7 +235,7 @@ due to Stow::Util missing $VERSION.
stow directory path being calculated as stow directory path being calculated as
../../../usr/home/user/local/stow relative to the target. ../../../usr/home/user/local/stow relative to the target.
See https://lists.gnu.org/archive/html/bug-stow/2013-04/msg00000.html for details. See http://article.gmane.org/gmane.comp.gnu.stow.bugs/8820 for details.
*** Fix stowing of relative links when --no-folding is used. *** Fix stowing of relative links when --no-folding is used.
@ -353,7 +276,7 @@ due to Stow::Util missing $VERSION.
Thanks to Gabriele Balducci for reporting this problem: Thanks to Gabriele Balducci for reporting this problem:
https://lists.gnu.org/archive/html/help-stow/2014-09/msg00000.html http://thread.gmane.org/gmane.comp.gnu.stow.general/6676
*** Internal code cleanups *** Internal code cleanups
@ -663,5 +586,4 @@ due to Stow::Util missing $VERSION.
org-export-with-toc: nil org-export-with-toc: nil
org-export-with-author: nil org-export-with-author: nil
org-toc-odd-levels-only: t org-toc-odd-levels-only: t
org-blank-before-new-entry: ((heading . auto) (plain-list-item . auto))
End: End:

View file

@ -60,56 +60,6 @@ You can get the latest information about Stow from the home page:
http://www.gnu.org/software/stow/ http://www.gnu.org/software/stow/
Installation
------------
See [`INSTALL.md`](INSTALL.md) for installation instructions.
Documentation
-------------
Documentation for Stow is available
[online](https://www.gnu.org/software/stow/manual/), as is
[documentation for most GNU
software](https://www.gnu.org/software/manual/). Once you have Stow
installed, you may also find more information about Stow by running
`info stow` or `man stow`, or by looking at `/usr/share/doc/stow/`,
`/usr/local/doc/stow/`, or similar directories on your system. A
brief summary is available by running `stow --help`.
Mailing lists
-------------
Stow has the following mailing lists:
- [help-stow](https://lists.gnu.org/mailman/listinfo/help-stow) is for
general user help and discussion.
- [stow-devel](https://lists.gnu.org/mailman/listinfo/stow-devel) is
used to discuss most aspects of Stow, including development and
enhancement requests.
- [bug-stow](https://lists.gnu.org/mailman/listinfo/bug-stow) is for
bug reports.
Announcements about Stow are posted to
[info-stow](http://lists.gnu.org/mailman/listinfo/info-stow) and also,
as with most other GNU software, to
[info-gnu](http://lists.gnu.org/mailman/listinfo/info-gnu)
([archive](http://lists.gnu.org/archive/html/info-gnu/)).
Security reports that should not be made immediately public can be
sent directly to the maintainer. If there is no response to an urgent
issue, you can escalate to the general
[security](http://lists.gnu.org/mailman/listinfo/security) mailing
list for advice.
The Savannah project also has a [mailing
lists](https://savannah.gnu.org/mail/?group=stow) page.
Getting involved
----------------
Please see the [`CONTRIBUTING.md` file](CONTRIBUTING.md).
License License
------- -------
@ -121,6 +71,18 @@ are permitted in any medium without royalty provided the copyright
notice and this notice are preserved. This file is offered as-is, notice and this notice are preserved. This file is offered as-is,
without any warranty. without any warranty.
Installation
------------
See [`INSTALL.md`](INSTALL.md) for installation instructions.
Feedback
--------
Please do send comments, questions, and constructive criticism. The
mailing lists and any other communication channels are detailed on the
above home page.
Brief history and authorship Brief history and authorship
---------------------------- ----------------------------

2
TODO
View file

@ -4,7 +4,7 @@
install-info, amongst other things: install-info, amongst other things:
*** http://unix.stackexchange.com/questions/73426/dealing-with-gnu-stow-conflicts *** http://unix.stackexchange.com/questions/73426/dealing-with-gnu-stow-conflicts
*** https://lists.gnu.org/archive/html/help-stow/2013-04/msg00016.html *** http://article.gmane.org/gmane.comp.gnu.stow.general/6661
* Get permission for next documentation release to be under FDL 1.3 * Get permission for next documentation release to be under FDL 1.3

4
aclocal.m4 vendored
View file

@ -14,8 +14,8 @@
m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])])
m4_ifndef([AC_AUTOCONF_VERSION], m4_ifndef([AC_AUTOCONF_VERSION],
[m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl
m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.72],, m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.71],,
[m4_warning([this file was generated for autoconf 2.72. [m4_warning([this file was generated for autoconf 2.71.
You have another version of autoconf. It may work, but is not guaranteed to. You have another version of autoconf. It may work, but is not guaranteed to.
If you have problems, you may need to regenerate the build system entirely. If you have problems, you may need to regenerate the build system entirely.
To do so, use the procedure documented by the package, typically 'autoreconf'.])]) To do so, use the procedure documented by the package, typically 'autoreconf'.])])

1
automake/.gitignore vendored
View file

@ -2,4 +2,3 @@ install-sh
missing missing
mdate-sh mdate-sh
test-driver test-driver
texinfo.tex

View file

@ -123,5 +123,6 @@ sub list {
# Local variables: # Local variables:
# mode: perl # mode: perl
# cperl-indent-level: 4
# End: # End:
# vim: ft=perl # vim: ft=perl

View file

@ -474,6 +474,7 @@ sub main {
my ($options, $pkgs_to_unstow, $pkgs_to_stow) = process_options(); my ($options, $pkgs_to_unstow, $pkgs_to_stow) = process_options();
my $stow = new Stow(%$options); my $stow = new Stow(%$options);
# current dir is now the target directory
$stow->plan_unstow(@$pkgs_to_unstow); $stow->plan_unstow(@$pkgs_to_unstow);
$stow->plan_stow (@$pkgs_to_stow); $stow->plan_stow (@$pkgs_to_stow);
@ -848,5 +849,6 @@ sub version {
# Local variables: # Local variables:
# mode: perl # mode: perl
# cperl-indent-level: 4
# end: # end:
# vim: ft=perl # vim: ft=perl

View file

@ -15,11 +15,11 @@ dnl along with this program. If not, see https://www.gnu.org/licenses/.
dnl Process this file with Autoconf to produce configure dnl dnl Process this file with Autoconf to produce configure dnl
AC_INIT([stow], [2.4.0], [bug-stow@gnu.org]) AC_INIT([stow], [2.3.2-fixbug56727], [bug-stow@gnu.org])
AC_PREREQ([2.61]) AC_PREREQ([2.61])
AC_CONFIG_AUX_DIR([automake]) AC_CONFIG_AUX_DIR([automake])
# Unfortunately we have to disable warnings for overrides, because we # Unfortunately we have to disable warnings for overrides, because we
# need to override the built-in `check-TESTS' rule and also the TEXI2DVI # need to override the built-in `check' rule and also the TEXI2DVI
# variable. # variable.
AM_INIT_AUTOMAKE([-Wall -Werror -Wno-override dist-bzip2 foreign]) AM_INIT_AUTOMAKE([-Wall -Werror -Wno-override dist-bzip2 foreign])
AC_PROG_INSTALL AC_PROG_INSTALL

View file

@ -13,7 +13,6 @@ _darcs
\.git \.git
\.gitignore \.gitignore
\.gitmodules
.+~ # emacs backup files .+~ # emacs backup files
\#.*\# # emacs autosave files \#.*\# # emacs autosave files

View file

@ -21,16 +21,17 @@ Release procedure
version=$( tools/get-version ) && echo $version version=$( tools/get-version ) && echo $version
- Ensure NEWS contains the latest changes. If necessary, commit - Ensure NEWS contains the latest changes, and that any new
contributors have been added to THANKS. If necessary, commit
any additions: any additions:
git commit -m "Prepare NEWS for $version release" git commit -m "Prepare NEWS and THANKS for $version release"
- Check CPAN distribution will work via Module::Build: - Check CPAN distribution will work via Module::Build:
- Start from a clean slate: - Start from a clean slate:
make maintainer-clean make distclean
autoreconf -iv autoreconf -iv
- Generate stow, chkstow, and lib/Stow.pm via: - Generate stow, chkstow, and lib/Stow.pm via:

View file

@ -19,13 +19,13 @@ This manual describes GNU Stow version @value{VERSION}
Software and documentation is copyrighted by the following: Software and documentation is copyrighted by the following:
@copyright{} 1993, 1994, 1995, 1996 Bob Glickstein @email{bobg+stow@@zanshin.com} @copyright{} 1993, 1994, 1995, 1996 Bob Glickstein <bobg+stow@@zanshin.com>
@* @*
@copyright{} 2000, 2001 Guillaume Morin @email{gmorin@@gnu.org} @copyright{} 2000, 2001 Guillaume Morin <gmorin@@gnu.org>
@* @*
@copyright{} 2007 Kahlil (Kal) Hodgson @email{kahlil@@internode.on.net} @copyright{} 2007 Kahlil (Kal) Hodgson <kahlil@@internode.on.net>
@* @*
@copyright{} 2011 Adam Spiers @email{stow@@adamspiers.org} @copyright{} 2011 Adam Spiers <stow@@adamspiers.org>
@quotation @quotation
Permission is granted to make and distribute verbatim copies of this Permission is granted to make and distribute verbatim copies of this
@ -99,7 +99,7 @@ appear to be installed in a single directory tree.
* Multiple Stow Directories:: Further segregating software. * Multiple Stow Directories:: Further segregating software.
* Target Maintenance:: Cleaning up mistakes. * Target Maintenance:: Cleaning up mistakes.
* Resource Files:: Setting default command line options. * Resource Files:: Setting default command line options.
* Compile-time vs. Install-time:: Faking out `make install'. * Compile-time vs Install-time:: Faking out `make install'.
* Bootstrapping:: When stow and perl are not yet stowed. * Bootstrapping:: When stow and perl are not yet stowed.
* Reporting Bugs:: How, what, where, and when to report. * Reporting Bugs:: How, what, where, and when to report.
* Known Bugs:: Don't report any of these. * Known Bugs:: Don't report any of these.
@ -220,12 +220,9 @@ to be installed in a particular directory structure --- e.g., with
@cindex target directory @cindex target directory
A @dfn{target directory} is the root of a tree in which one or more A @dfn{target directory} is the root of a tree in which one or more
packages wish to @emph{appear} to be installed. @file{/usr/local} is a packages wish to @emph{appear} to be installed. A common, but by no
common choice for this, but by no means the only such location. Another means the only such location is @file{/usr/local}. The examples in this
common choice is @file{~} (i.e.@: the user's @code{$HOME} directory) in manual will use @file{/usr/local} as the target directory.
the case where Stow is being used to manage the user's configuration
(``dotfiles'') and other files in their @code{$HOME}. The examples in
this manual will use @file{/usr/local} as the target directory.
@cindex stow directory @cindex stow directory
A @dfn{stow directory} is the root of a tree containing separate A @dfn{stow directory} is the root of a tree containing separate
@ -243,11 +240,6 @@ installation image for Perl includes: a @file{bin} directory containing
containing Texinfo documentation; a @file{lib/perl} directory containing containing Texinfo documentation; a @file{lib/perl} directory containing
Perl libraries; and a @file{man/man1} directory containing man pages. Perl libraries; and a @file{man/man1} directory containing man pages.
@quotation Note
This is a @emph{pre-}installation image which exists even before Stow
has installed any symlinks into the target directory which point to it.
@end quotation
@cindex package directory @cindex package directory
@cindex package name @cindex package name
A @dfn{package directory} is the root of a tree containing the A @dfn{package directory} is the root of a tree containing the
@ -263,68 +255,15 @@ target directory, @file{/usr/local/stow} is the stow directory,
@file{/usr/local/stow/perl} is the package directory, and @file{/usr/local/stow/perl} is the package directory, and
@file{bin/perl} within is part of the installation image. @file{bin/perl} within is part of the installation image.
@anchor{symlink}
@cindex symlink @cindex symlink
@cindex symlink source
@cindex symlink destination
@cindex relative symlink @cindex relative symlink
@cindex absolute symlink @cindex absolute symlink
A @dfn{symlink} is a symbolic link, i.e.@: an entry on the filesystem A @dfn{symlink} is a symbolic link. A symlink can be @dfn{relative} or
whose path is sometimes called the @dfn{symlink source}, which points to @dfn{absolute}. An absolute symlink names a full path; that is, one
another location on the filesystem called the @dfn{symlink destination}. starting from @file{/}. A relative symlink names a relative path; that
There is no guarantee that the destination actually exists. is, one not starting from @file{/}. The target of a relative symlink is
computed starting from the symlink's own directory. Stow only
In general, symlinks can be @dfn{relative} or @dfn{absolute}. A symlink creates relative symlinks.
is absolute when the destination names a full path; that is, one
starting from @file{/}. A symlink is relative when the destination
names a relative path; that is, one not starting from @file{/}. The
destination of a relative symlink is computed starting from the
symlink's own directory, i.e.@: the directory containing the symlink
source.
@quotation Note
Stow only creates symlinks within the target directory which point to
locations @emph{outside} the target directory and inside the stow
directory.
Consequently, we avoid referring to symlink destinations as symlink
@emph{targets}, since this would result in the word ``target'' having
two different meanings:
@enumerate
@item
the target directory, i.e.@: the directory into which Stow targets
installation, where symlinks are managed by Stow, and
@item
the destinations of those symlinks.
@end enumerate
If we did not avoid the second meaning of ``target'', then it would lead
to confusing language, such as describing Stow as installing symlinks
into the target directory which point to targets @emph{outside} the
target directory.
Similarly, the word ``source'' can have two different meanings in this
context:
@enumerate
@item
the installation image, or some of its contents, and
@item
the location of symlinks (the ``source'' of the link, vs.@: its
destination).
@end enumerate
Therefore it should also be avoided, or at least care taken to ensure
that the meaning is not ambiguous.
@end quotation
@c =========================================================================== @c ===========================================================================
@node Invoking Stow, Ignore Lists, Terminology, Top @node Invoking Stow, Ignore Lists, Terminology, Top
@ -444,7 +383,7 @@ refolding (@pxref{tree refolding}). If a new subdirectory is
encountered whilst stowing a new package, the subdirectory is created encountered whilst stowing a new package, the subdirectory is created
within the target, and its contents are symlinked, rather than just within the target, and its contents are symlinked, rather than just
creating a symlink for the directory. If removal of symlinks whilst creating a symlink for the directory. If removal of symlinks whilst
unstowing a package causes a subtree to be foldable (i.e.@: only unstowing a package causes a subtree to be foldable (i.e. only
containing symlinks to a single package), that subtree will not be containing symlinks to a single package), that subtree will not be
removed and replaced with a symlink. removed and replaced with a symlink.
@ -489,15 +428,13 @@ doing. Verbosity levels are from 0 to 5; 0 is the default. Using
@item -p @item -p
@itemx --compat @itemx --compat
Scan the whole target tree when unstowing. By default, only directories Scan the whole target tree when unstowing. By default, only
specified in the @dfn{installation image} are scanned during an unstow directories specified in the @dfn{installation image} are scanned
operation. Previously Stow scanned the whole tree, which can be during an unstow operation. Scanning the whole tree can be
prohibitive if your target tree is very large, but on the other hand has prohibitive if your target tree is very large. This option restores
the advantage of unstowing previously stowed links which are no longer the legacy behaviour; however, the @option{--badlinks} option to the
present in the installation image and therefore orphaned. This option @command{chkstow} utility may be a better way of ensuring that your
restores the legacy behaviour; however, the @option{--badlinks} option installation does not have any dangling symlinks (@pxref{Target
to the @command{chkstow} utility may be a better way of ensuring that
your installation does not have any dangling symlinks (@pxref{Target
Maintenance}). Maintenance}).
@item -V @item -V
@ -876,7 +813,7 @@ This is much faster and cleaner than performing two separate
invocations of stow, because redundant folding/unfolding operations invocations of stow, because redundant folding/unfolding operations
can be factored out. In addition, all the operations are calculated can be factored out. In addition, all the operations are calculated
and merged before being executed (@pxref{Deferred Operation}), so the and merged before being executed (@pxref{Deferred Operation}), so the
amount of time in which GNU Emacs is unavailable is minimised. amount of of time in which GNU Emacs is unavailable is minimised.
You can mix and match any number of actions, for example, You can mix and match any number of actions, for example,
@ -956,7 +893,7 @@ directory.
@end table @end table
@c =========================================================================== @c ===========================================================================
@node Resource Files, Compile-time vs. Install-time, Target Maintenance, Top @node Resource Files, Compile-time vs Install-time, Target Maintenance, Top
@chapter Resource Files @chapter Resource Files
@cindex resource files @cindex resource files
@cindex configuration files @cindex configuration files
@ -1023,8 +960,8 @@ resource files. This is also true of any package names given in the
resource file. resource file.
@c =========================================================================== @c ===========================================================================
@node Compile-time vs. Install-time, Bootstrapping, Resource Files, Top @node Compile-time vs Install-time, Bootstrapping, Resource Files, Top
@chapter Compile-time vs. Install-time @chapter Compile-time vs Install-time
Software whose installation is managed with Stow needs to be installed Software whose installation is managed with Stow needs to be installed
in one place (the package directory, e.g. @file{/usr/local/stow/perl}) in one place (the package directory, e.g. @file{/usr/local/stow/perl})
@ -1106,7 +1043,7 @@ following sections.
@end menu @end menu
@c --------------------------------------------------------------------------- @c ---------------------------------------------------------------------------
@node GNU Emacs, Other FSF Software, Compile-time vs. Install-time, Compile-time vs. Install-time @node GNU Emacs, Other FSF Software, Compile-time vs Install-time, Compile-time vs Install-time
@section GNU Emacs @section GNU Emacs
Although the Free Software Foundation has many enlightened practices Although the Free Software Foundation has many enlightened practices
@ -1139,7 +1076,7 @@ make do-install prefix=/usr/local/stow/emacs
@end example @end example
@c --------------------------------------------------------------------------- @c ---------------------------------------------------------------------------
@node Other FSF Software, Cygnus Software, GNU Emacs, Compile-time vs. Install-time @node Other FSF Software, Cygnus Software, GNU Emacs, Compile-time vs Install-time
@section Other FSF Software @section Other FSF Software
The Free Software Foundation, the organization behind the GNU project, The Free Software Foundation, the organization behind the GNU project,
@ -1160,7 +1097,7 @@ and @samp{make install} steps to work correctly without needing to
``fool'' the build process. ``fool'' the build process.
@c --------------------------------------------------------------------------- @c ---------------------------------------------------------------------------
@node Cygnus Software, Perl and Perl 5 Modules, Other FSF Software, Compile-time vs. Install-time @node Cygnus Software, Perl and Perl 5 Modules, Other FSF Software, Compile-time vs Install-time
@section Cygnus Software @section Cygnus Software
Cygnus is a commercial supplier and supporter of GNU software. It has Cygnus is a commercial supplier and supporter of GNU software. It has
@ -1189,7 +1126,7 @@ is recompiling files. Usually it will work just fine; otherwise,
install manually. install manually.
@c --------------------------------------------------------------------------- @c ---------------------------------------------------------------------------
@node Perl and Perl 5 Modules, , Cygnus Software, Compile-time vs. Install-time @node Perl and Perl 5 Modules, , Cygnus Software, Compile-time vs Install-time
@section Perl and Perl 5 Modules @section Perl and Perl 5 Modules
Perl 4.036 allows you to specify different locations for installation Perl 4.036 allows you to specify different locations for installation
@ -1292,7 +1229,7 @@ find cpan.* \( -name .exists -o -name perllocal.pod \) -print | \
@c --------------------------------------------------------------------------- @c ---------------------------------------------------------------------------
@node Bootstrapping, Reporting Bugs, Compile-time vs. Install-time, Top @node Bootstrapping, Reporting Bugs, Compile-time vs Install-time, Top
@chapter Bootstrapping @chapter Bootstrapping
Suppose you have a stow directory all set up and ready to go: Suppose you have a stow directory all set up and ready to go:
@ -1327,32 +1264,9 @@ perl/bin/perl stow/bin/stow -vv *
@node Reporting Bugs, Known Bugs, Bootstrapping, Top @node Reporting Bugs, Known Bugs, Bootstrapping, Top
@chapter Reporting Bugs @chapter Reporting Bugs
You can report bugs to the current maintainers in one of three ways: Please send bug reports to the current maintainers by electronic
mail. The address to use is @samp{<bug-stow@@gnu.org>}. Please
@enumerate include:
@item
Send e-mail to @email{bug-stow@@gnu.org}.
@item
File an issue in @uref{https://savannah.gnu.org/bugs/?group=stow,
the Savannah bug tracker}.
@item
File an issue in
@uref{https://github.com/aspiers/stow/issues/, the GitHub project}.
@end enumerate
While GitHub is arguably the most convenient of these three options, it
@uref{https://www.gnu.org/software/repo-criteria-evaluation.html#GitHub,
is not the most ethical or freedom-preserving way to host software
projects}. Therefore the GitHub project may be
@uref{https://github.com/aspiers/stow/issues/43, moved to a more ethical
hosting service} in the future.
Before reporting a bug, it is recommended to check whether it is already
known, so please first @pxref{Known Bugs}.
When reporting a new bug, please include:
@itemize @bullet @itemize @bullet
@item @item
@ -1373,13 +1287,12 @@ the precise command you gave;
@item @item
the output from the command (preferably verbose output, obtained by the output from the command (preferably verbose output, obtained by
adding @samp{--verbose=5} to the Stow command line). adding @samp{--verbose=3} to the Stow command line).
@end itemize @end itemize
If you are really keen, consider developing a minimal test case and If you are really keen, consider developing a minimal test case and
creating a new test. See the @file{t/} directory in the source for lots creating a new test. See the @file{t/} directory in the source for
of examples, and the @file{CONTRIBUTING.md} file for a guide on how to lots of examples.
contribute.
Before reporting a bug, please read the manual carefully, especially Before reporting a bug, please read the manual carefully, especially
@ref{Known Bugs}, to see whether you're encountering @ref{Known Bugs}, to see whether you're encountering
@ -1390,22 +1303,13 @@ something that doesn't need reporting.
@node Known Bugs, GNU General Public License, Reporting Bugs, Top @node Known Bugs, GNU General Public License, Reporting Bugs, Top
@chapter Known Bugs @chapter Known Bugs
Known bugs can be found in the following locations: There are no known bugs in Stow version @value{VERSION}!
If you think you have found one, please @pxref{Reporting Bugs}.
@itemize @c @itemize @bullet
@item @c @item
@uref{https://github.com/aspiers/stow/issues/, the GitHub issue tracker} @c Put known bugs here
@c @end itemize
@item
@uref{https://savannah.gnu.org/bugs/?group=stow, the Savannah bug
tracker}
@item
the @uref{https://lists.gnu.org/archive/html/bug-stow/, bug-stow list
archives}
@end itemize
If you think you have found a new bug, please @pxref{Reporting Bugs}.
@c =========================================================================== @c ===========================================================================
@node GNU General Public License, Index, Known Bugs, Top @node GNU General Public License, Index, Known Bugs, Top

7482
doc/texinfo.tex Normal file

File diff suppressed because it is too large Load diff

View file

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

File diff suppressed because it is too large Load diff

View file

@ -32,14 +32,12 @@ Supporting utility routines for L<Stow>.
use strict; use strict;
use warnings; use warnings;
use File::Spec;
use POSIX qw(getcwd); use POSIX qw(getcwd);
use base qw(Exporter); use base qw(Exporter);
our @EXPORT_OK = qw( our @EXPORT_OK = qw(
error debug set_debug_level set_test_mode error debug set_debug_level set_test_mode
join_paths parent canon_path restore_cwd join_paths parent canon_path restore_cwd adjust_dotfile
adjust_dotfile unadjust_dotfile
); );
our $ProgramName = 'stow'; our $ProgramName = 'stow';
@ -95,7 +93,7 @@ sub set_test_mode {
} }
} }
=head2 debug($level[, $indent_level], $msg) =head2 debug($level, $msg)
Logs to STDERR based on C<$debug_level> setting. C<$level> is the Logs to STDERR based on C<$debug_level> setting. C<$level> is the
minimum verbosity level required to output C<$msg>. All output is to minimum verbosity level required to output C<$msg>. All output is to
@ -127,18 +125,13 @@ overriding, fixing invalid links
=cut =cut
sub debug { sub debug {
my $level = shift; my ($level, $msg) = @_;
my $indent_level;
# Maintain backwards-compatibility in case anyone's relying on this.
$indent_level = $_[0] =~ /^\d+$/ ? shift : 0;
my $msg = shift;
if ($debug_level >= $level) { if ($debug_level >= $level) {
my $indent = ' ' x $indent_level;
if ($test_mode) { if ($test_mode) {
print "# $indent$msg\n"; print "# $msg\n";
} }
else { else {
warn "$indent$msg\n"; warn "$msg\n";
} }
} }
} }
@ -149,53 +142,29 @@ sub debug {
# Parameters: path1, path2, ... => paths # Parameters: path1, path2, ... => paths
# Returns : concatenation of given paths # Returns : concatenation of given paths
# Throws : n/a # Throws : n/a
# Comments : Factors out some redundant path elements: # Comments : factors out redundant path elements:
# : '//' => '/', and 'a/b/../c' => 'a/c'. We need this function # : '//' => '/' and 'a/b/../c' => 'a/c'
# : with this behaviour, even though b could be a symlink to
# : elsewhere, as noted in the perldoc for File::Spec->canonpath().
# : This behaviour is deliberately different to
# : Stow::Util::canon_path(), because the way join_paths() is used
# : relies on this. Firstly, there is no guarantee that the paths
# : exist, so a filesystem check is inappropriate.
# :
# : For example, it's used to determine the path from the target
# : directory to a symlink destination. So if a symlink
# : path/to/target/a/b/c points to ../../../stow/pkg/a/b/c,
# : then joining path/to/target/a/b with ../../../stow/pkg/a/b/c
# : yields path/to/stow/pkg/a/b/c, and it's crucial that the
# : path/to/stow prefix matches a recognisable stow directory.
#============================================================================ #============================================================================
sub join_paths { sub join_paths {
my @paths = @_; my @paths = @_;
debug(5, 5, "| Joining: @paths"); # weed out empty components and concatenate
my $result = ''; my $result = join '/', grep {! /\A\z/} @paths;
for my $part (@paths) {
next if ! length $part; # probably shouldn't happen?
$part = File::Spec->canonpath($part);
if (substr($part, 0, 1) eq '/') { # factor out back references and remove redundant /'s)
$result = $part; # absolute path, so ignore all previous parts my @result = ();
PART:
for my $part (split m{/+}, $result) {
next PART if $part eq '.';
if (@result && $part eq '..' && $result[-1] ne '..') {
pop @result;
} }
else { else {
$result .= '/' if length $result && $result ne '/'; push @result, $part;
$result .= $part;
} }
debug(7, 6, "| Join now: $result");
} }
debug(6, 5, "| Joined: $result");
# Need this to remove any initial ./ return join '/', @result;
$result = File::Spec->canonpath($result);
# remove foo/..
1 while $result =~ s,(^|/)(?!\.\.)[^/]+/\.\.(/|$),$1,;
debug(6, 5, "| After .. removal: $result");
$result = File::Spec->canonpath($result);
debug(5, 5, "| Final join: $result");
return $result;
} }
#===== METHOD =============================================================== #===== METHOD ===============================================================
@ -212,7 +181,7 @@ sub parent {
my $path = join '/', @_; my $path = join '/', @_;
my @elts = split m{/+}, $path; my @elts = split m{/+}, $path;
pop @elts; pop @elts;
return join '/', @elts; return join '/', @elts;
} }
#===== METHOD =============================================================== #===== METHOD ===============================================================
@ -240,17 +209,17 @@ sub restore_cwd {
} }
sub adjust_dotfile { sub adjust_dotfile {
my ($pkg_node) = @_; my ($target) = @_;
(my $adjusted = $pkg_node) =~ s/^dot-([^.])/.$1/;
return $adjusted;
}
# Needed when unstowing with --compat and --dotfiles my @result = ();
sub unadjust_dotfile { for my $part (split m{/+}, $target) {
my ($target_node) = @_; if (($part ne "dot-") && ($part ne "dot-.")) {
return $target_node if $target_node =~ /^\.\.?$/; $part =~ s/^dot-/./;
(my $adjusted = $target_node) =~ s/^\./dot-/; }
return $adjusted; push @result, $part;
}
return join '/', @result;
} }
=head1 BUGS =head1 BUGS
@ -263,5 +232,6 @@ sub unadjust_dotfile {
# Local variables: # Local variables:
# mode: perl # mode: perl
# cperl-indent-level: 4
# end: # end:
# vim: ft=perl # vim: ft=perl

View file

@ -22,11 +22,10 @@
use strict; use strict;
use warnings; use warnings;
use Test::More tests => 4; use Test::More tests => 6;
use English qw(-no_match_vars); use English qw(-no_match_vars);
use testutil; use testutil;
use Stow::Util;
init_test_dirs(); init_test_dirs();
cd("$TEST_DIR/target"); cd("$TEST_DIR/target");
@ -35,64 +34,48 @@ my $stow;
# Note that each of the following tests use a distinct set of files # Note that each of the following tests use a distinct set of files
subtest('nothing to clean in a simple tree' => sub { #
plan tests => 1; # nothing to clean in a simple tree
#
make_path('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1');
make_link('bin1', '../stow/pkg1/bin1');
$stow = new_Stow(); make_path('../stow/pkg1/bin1');
$stow->cleanup_invalid_links('./'); make_file('../stow/pkg1/bin1/file1');
is( make_link('bin1', '../stow/pkg1/bin1');
scalar($stow->get_tasks), 0
=> 'nothing to clean'
);
});
subtest('cleanup an orphaned owned link in a simple tree' => sub { $stow = new_Stow();
plan tests => 3; $stow->cleanup_invalid_links('./');
is(
scalar($stow->get_tasks), 0
=> 'nothing to clean'
);
make_path('bin2'); #
make_path('../stow/pkg2/bin2'); # cleanup a bad link in a simple tree
make_file('../stow/pkg2/bin2/file2a'); #
make_link('bin2/file2a', '../../stow/pkg2/bin2/file2a'); make_path('bin2');
make_invalid_link('bin2/file2b', '../../stow/pkg2/bin2/file2b'); make_path('../stow/pkg2/bin2');
make_file('../stow/pkg2/bin2/file2a');
make_link('bin2/file2a', '../../stow/pkg2/bin2/file2a');
make_invalid_link('bin2/file2b', '../../stow/pkg2/bin2/file2b');
$stow = new_Stow(); $stow = new_Stow();
$stow->cleanup_invalid_links('bin2'); $stow->cleanup_invalid_links('bin2');
is($stow->get_conflict_count, 0, 'no conflicts cleaning up bad link'); is($stow->get_conflict_count, 0, 'no conflicts cleaning up bad link');
is(scalar($stow->get_tasks), 1, 'one task cleaning up bad link'); is(scalar($stow->get_tasks), 1, 'one task cleaning up bad link');
is($stow->link_task_action('bin2/file2b'), 'remove', 'removal task for bad link'); is($stow->link_task_action('bin2/file2b'), 'remove', 'removal task for bad link');
});
subtest("don't cleanup a bad link not owned by stow" => sub { #
plan tests => 2; # dont cleanup a bad link not owned by stow
#
make_path('bin3'); make_path('bin3');
make_path('../stow/pkg3/bin3'); make_path('../stow/pkg3/bin3');
make_file('../stow/pkg3/bin3/file3a'); make_file('../stow/pkg3/bin3/file3a');
make_link('bin3/file3a', '../../stow/pkg3/bin3/file3a'); make_link('bin3/file3a', '../../stow/pkg3/bin3/file3a');
make_invalid_link('bin3/file3b', '../../empty'); make_invalid_link('bin3/file3b', '../../empty');
$stow = new_Stow(); $stow = new_Stow();
$stow->cleanup_invalid_links('bin3'); $stow->cleanup_invalid_links('bin3');
is($stow->get_conflict_count, 0, 'no conflicts cleaning up bad link not owned by stow'); is($stow->get_conflict_count, 0, 'no conflicts cleaning up bad link not owned by stow');
is(scalar($stow->get_tasks), 0, 'no tasks cleaning up bad link not owned by stow'); is(scalar($stow->get_tasks), 0, 'no tasks cleaning up bad link not owned by stow');
});
subtest("don't cleanup a valid link in the target not owned by stow" => sub {
plan tests => 2;
make_path('bin4');
make_path('../stow/pkg4/bin4');
make_file('../stow/pkg4/bin4/file3a');
make_link('bin4/file3a', '../../stow/pkg4/bin4/file3a');
make_file("unowned");
make_link('bin4/file3b', '../unowned');
$stow = new_Stow();
$stow->cleanup_invalid_links('bin4');
is($stow->get_conflict_count, 0, 'no conflicts cleaning up bad link not owned by stow');
is(scalar($stow->get_tasks), 0, 'no tasks cleaning up bad link not owned by stow');
});

View file

@ -22,214 +22,190 @@
use strict; use strict;
use warnings; use warnings;
use Test::More tests => 12; use testutil;
use Test::More tests => 10;
use English qw(-no_match_vars); use English qw(-no_match_vars);
use Stow::Util qw(adjust_dotfile unadjust_dotfile);
use testutil; use testutil;
init_test_dirs(); init_test_dirs();
cd("$TEST_DIR/target"); cd("$TEST_DIR/target");
subtest('adjust_dotfile()', sub {
plan tests => 4;
my @TESTS = (
['file'],
['dot-'],
['dot-.'],
['dot-file', '.file'],
);
for my $test (@TESTS) {
my ($input, $expected) = @$test;
$expected ||= $input;
is(adjust_dotfile($input), $expected);
}
});
subtest('unadjust_dotfile()', sub {
plan tests => 4;
my @TESTS = (
['file'],
['.'],
['..'],
['.file', 'dot-file'],
);
for my $test (@TESTS) {
my ($input, $expected) = @$test;
$expected ||= $input;
is(unadjust_dotfile($input), $expected);
}
});
my $stow; my $stow;
subtest("stow dot-foo as .foo", sub { #
plan tests => 1; # process a dotfile marked with 'dot' prefix
$stow = new_Stow(dir => '../stow', dotfiles => 1); #
make_path('../stow/dotfiles');
make_file('../stow/dotfiles/dot-foo');
$stow->plan_stow('dotfiles'); $stow = new_Stow(dir => '../stow', dotfiles => 1);
$stow->process_tasks();
is(
readlink('.foo'),
'../stow/dotfiles/dot-foo',
=> 'processed dotfile'
);
});
subtest("stow dot-foo as dot-foo without --dotfile enabled", sub { make_path('../stow/dotfiles');
plan tests => 1; make_file('../stow/dotfiles/dot-foo');
$stow = new_Stow(dir => '../stow', dotfiles => 0);
make_path('../stow/dotfiles');
make_file('../stow/dotfiles/dot-foo');
$stow->plan_stow('dotfiles'); $stow->plan_stow('dotfiles');
$stow->process_tasks(); $stow->process_tasks();
is( is(
readlink('dot-foo'), readlink('.foo'),
'../stow/dotfiles/dot-foo', '../stow/dotfiles/dot-foo',
=> 'unprocessed dotfile' => 'processed dotfile'
); );
});
subtest("stow dot-emacs dir as .emacs", sub { #
plan tests => 1; # ensure that turning off dotfile processing links files as usual
$stow = new_Stow(dir => '../stow', dotfiles => 1); #
make_path('../stow/dotfiles/dot-emacs'); $stow = new_Stow(dir => '../stow', dotfiles => 0);
make_file('../stow/dotfiles/dot-emacs/init.el');
$stow->plan_stow('dotfiles'); make_path('../stow/dotfiles');
$stow->process_tasks(); make_file('../stow/dotfiles/dot-foo');
is(
readlink('.emacs'),
'../stow/dotfiles/dot-emacs',
=> 'processed dotfile dir'
);
});
subtest("stow dir marked with 'dot' prefix when directory exists in target", sub { $stow->plan_stow('dotfiles');
plan tests => 1; $stow->process_tasks();
$stow = new_Stow(dir => '../stow', dotfiles => 1); is(
readlink('dot-foo'),
'../stow/dotfiles/dot-foo',
=> 'unprocessed dotfile'
);
make_path('../stow/dotfiles/dot-emacs.d');
make_file('../stow/dotfiles/dot-emacs.d/init.el');
make_path('.emacs.d');
$stow->plan_stow('dotfiles'); #
$stow->process_tasks(); # process folder marked with 'dot' prefix
is( #
readlink('.emacs.d/init.el'),
'../../stow/dotfiles/dot-emacs.d/init.el',
=> 'processed dotfile dir when dir exists (1 level)'
);
});
subtest("stow dir marked with 'dot' prefix when directory exists in target (2 levels)", sub { $stow = new_Stow(dir => '../stow', dotfiles => 1);
plan tests => 1;
$stow = new_Stow(dir => '../stow', dotfiles => 1);
make_path('../stow/dotfiles/dot-emacs.d/dot-emacs.d'); make_path('../stow/dotfiles/dot-emacs');
make_file('../stow/dotfiles/dot-emacs.d/dot-emacs.d/init.el'); make_file('../stow/dotfiles/dot-emacs/init.el');
make_path('.emacs.d');
$stow->plan_stow('dotfiles'); $stow->plan_stow('dotfiles');
$stow->process_tasks(); $stow->process_tasks();
is( is(
readlink('.emacs.d/.emacs.d'), readlink('.emacs'),
'../../stow/dotfiles/dot-emacs.d/dot-emacs.d', '../stow/dotfiles/dot-emacs',
=> 'processed dotfile dir exists (2 levels)' => 'processed dotfile folder'
); );
});
subtest("stow dir marked with 'dot' prefix when directory exists in target", sub { #
plan tests => 1; # process folder marked with 'dot' prefix
$stow = new_Stow(dir => '../stow', dotfiles => 1); # when directory exists is target
#
make_path('../stow/dotfiles/dot-one/dot-two'); $stow = new_Stow(dir => '../stow', dotfiles => 1);
make_file('../stow/dotfiles/dot-one/dot-two/three');
make_path('.one/.two');
$stow->plan_stow('dotfiles'); make_path('../stow/dotfiles/dot-emacs.d');
$stow->process_tasks(); make_file('../stow/dotfiles/dot-emacs.d/init.el');
is( make_path('.emacs.d');
readlink('./.one/.two/three'),
'../../../stow/dotfiles/dot-one/dot-two/three',
=> 'processed dotfile 2 dir exists (2 levels)'
);
}); $stow->plan_stow('dotfiles');
$stow->process_tasks();
is(
readlink('.emacs.d/init.el'),
'../../stow/dotfiles/dot-emacs.d/init.el',
=> 'processed dotfile folder when folder exists (1 level)'
);
subtest("dot-. should not have that part expanded.", sub { #
plan tests => 2; # process folder marked with 'dot' prefix
$stow = new_Stow(dir => '../stow', dotfiles => 1); # when directory exists is target (2 levels)
#
make_path('../stow/dotfiles'); $stow = new_Stow(dir => '../stow', dotfiles => 1);
make_file('../stow/dotfiles/dot-');
make_path('../stow/dotfiles/dot-.'); make_path('../stow/dotfiles/dot-emacs.d/dot-emacs.d');
make_file('../stow/dotfiles/dot-./foo'); make_file('../stow/dotfiles/dot-emacs.d/dot-emacs.d/init.el');
make_path('.emacs.d');
$stow->plan_stow('dotfiles'); $stow->plan_stow('dotfiles');
$stow->process_tasks(); $stow->process_tasks();
is( is(
readlink('dot-'), readlink('.emacs.d/.emacs.d'),
'../stow/dotfiles/dot-', '../../stow/dotfiles/dot-emacs.d/dot-emacs.d',
=> 'processed dotfile' => 'processed dotfile folder exists (2 levels)'
); );
is(
readlink('dot-.'),
'../stow/dotfiles/dot-.',
=> 'unprocessed dotfile'
);
});
subtest("unstow .bar from dot-bar", sub { #
plan tests => 3; # process folder marked with 'dot' prefix
$stow = new_Stow(dir => '../stow', dotfiles => 1); # when directory exists is target
#
make_path('../stow/dotfiles'); $stow = new_Stow(dir => '../stow', dotfiles => 1);
make_file('../stow/dotfiles/dot-bar');
make_link('.bar', '../stow/dotfiles/dot-bar');
$stow->plan_unstow('dotfiles'); make_path('../stow/dotfiles/dot-one/dot-two');
$stow->process_tasks(); make_file('../stow/dotfiles/dot-one/dot-two/three');
is($stow->get_conflict_count, 0); make_path('.one/.two');
ok(-f '../stow/dotfiles/dot-bar', 'package file untouched');
ok(! -e '.bar' => '.bar was unstowed');
});
subtest("unstow dot-emacs.d/init.el when .emacs.d/init.el in target", sub { $stow->plan_stow('dotfiles');
plan tests => 4; $stow->process_tasks();
$stow = new_Stow(dir => '../stow', dotfiles => 1); is(
readlink('./.one/.two/three'),
'../../../stow/dotfiles/dot-one/dot-two/three',
=> 'processed dotfile 2 folder exists (2 levels)'
);
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(); # corner case: paths that have a part in them that's just "$DOT_PREFIX" or
is($stow->get_conflict_count, 0); # "$DOT_PREFIX." should not have that part expanded.
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');
});
subtest("unstow dot-emacs.d/init.el in --compat mode", sub { $stow = new_Stow(dir => '../stow', dotfiles => 1);
plan tests => 4;
$stow = new_compat_Stow(dir => '../stow', dotfiles => 1);
make_path('../stow/dotfiles/dot-emacs.d'); make_path('../stow/dotfiles');
make_file('../stow/dotfiles/dot-emacs.d/init.el'); make_file('../stow/dotfiles/dot-');
make_path('.emacs.d');
make_link('.emacs.d/init.el', '../../stow/dotfiles/dot-emacs.d/init.el');
$stow->plan_unstow('dotfiles'); make_path('../stow/dotfiles/dot-.');
$stow->process_tasks(); make_file('../stow/dotfiles/dot-./foo');
is($stow->get_conflict_count, 0);
ok(-f '../stow/dotfiles/dot-emacs.d/init.el'); $stow->plan_stow('dotfiles');
ok(! -e '.emacs.d/init.el', '.emacs.d/init.el unstowed'); $stow->process_tasks();
ok(-d '.emacs.d/' => '.emacs.d left behind'); is(
}); readlink('dot-'),
'../stow/dotfiles/dot-',
=> 'processed dotfile'
);
is(
readlink('dot-.'),
'../stow/dotfiles/dot-.',
=> 'unprocessed dotfile'
);
#
# simple unstow scenario
#
$stow = new_Stow(dir => '../stow', dotfiles => 1);
make_path('../stow/dotfiles');
make_file('../stow/dotfiles/dot-bar');
make_link('.bar', '../stow/dotfiles/dot-bar');
$stow->plan_unstow('dotfiles');
$stow->process_tasks();
ok(
$stow->get_conflict_count == 0 &&
-f '../stow/dotfiles/dot-bar' && ! -e '.bar'
=> 'unstow a simple dotfile'
);
#
# unstow process folder marked with 'dot' prefix
# when directory exists is target
#
$stow = new_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();
ok(
$stow->get_conflict_count == 0 &&
-f '../stow/dotfiles/dot-emacs.d/init.el' &&
! -e '.emacs.d/init.el' &&
-d '.emacs.d/'
=> 'unstow dotfile folder when folder already exists'
);

View file

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

View file

@ -22,40 +22,91 @@
use strict; use strict;
use warnings; use warnings;
use Stow::Util qw(join_paths set_debug_level); use Stow::Util qw(join_paths);
#set_debug_level(4); use Test::More tests => 14;
use Test::More tests => 22; is(
join_paths('a/b/c', 'd/e/f'),
my @TESTS = ( 'a/b/c/d/e/f'
[['a/b/c', 'd/e/f'], 'a/b/c/d/e/f' => 'simple'], => 'simple'
[['a/b/c', '/d/e/f'], '/d/e/f' => 'relative then absolute'],
[['/a/b/c', 'd/e/f'], '/a/b/c/d/e/f' => 'absolute then relative'],
[['/a/b/c', '/d/e/f'], '/d/e/f' => 'two absolutes'],
[['/a/b/c/', '/d/e/f/'], '/d/e/f' => 'two absolutes with trailing /'],
[['///a/b///c//', '/d///////e/f'], '/d/e/f' => "multiple /'s, absolute"],
[['///a/b///c//', 'd///////e/f'], '/a/b/c/d/e/f' => "multiple /'s, relative"],
[['', 'a/b/c'], 'a/b/c' => 'first empty'],
[['a/b/c', ''], 'a/b/c' => 'second empty'],
[['/', 'a/b/c'], '/a/b/c' => 'first is /'],
[['a/b/c', '/'], '/' => 'second is /'],
[['../a1/b1/../c1/', 'a2/../b2/e2'], '../a1/c1/b2/e2' => 'relative with ../'],
[['../a1/b1/../c1/', '/a2/../b2/e2'], '/b2/e2' => 'absolute with ../'],
[['../a1/../../c1', 'a2/../../'], '../..' => 'lots of ../'],
[['./', '../a2'], '../a2' => 'drop any "./"'],
[['./a1', '../../a2'], '../a2' => 'drop any "./foo"'],
[['a/b/c', '.'], 'a/b/c' => '. on RHS'],
[['a/b/c', '.', 'd/e'], 'a/b/c/d/e' => '. in middle'],
[['0', 'a/b'], '0/a/b' => '0 at start'],
[['/0', 'a/b'], '/0/a/b' => '/0 at start'],
[['a/b/c', '0', 'd/e'], 'a/b/c/0/d/e' => '0 in middle'],
[['a/b', '0'], 'a/b/0' => '0 at end'],
); );
for my $test (@TESTS) { is(
my ($inputs, $expected, $scenario) = @$test; join_paths('/a/b/c', '/d/e/f'),
my $got = join_paths(@$inputs); '/a/b/c/d/e/f'
my $descr = "$scenario: in=[" . join(', ', map "'$_'", @$inputs) . "] exp=[$expected] got=[$got]"; => 'leading /'
is($got, $expected, $descr); );
}
is(
join_paths('/a/b/c/', '/d/e/f/'),
'/a/b/c/d/e/f'
=> 'trailing /'
);
is(
join_paths('///a/b///c//', '/d///////e/f'),
'/a/b/c/d/e/f'
=> 'mltiple /\'s'
);
is(
join_paths('', 'a/b/c'),
'a/b/c'
=> 'first empty'
);
is(
join_paths('a/b/c', ''),
'a/b/c'
=> 'second empty'
);
is(
join_paths('/', 'a/b/c'),
'/a/b/c'
=> 'first is /'
);
is(
join_paths('a/b/c', '/'),
'a/b/c'
=> 'second is /'
);
is(
join_paths('///a/b///c//', '/d///////e/f'),
'/a/b/c/d/e/f'
=> 'multiple /\'s'
);
is(
join_paths('../a1/b1/../c1/', '/a2/../b2/e2'),
'../a1/c1/b2/e2'
=> 'simple deref ".."'
);
is(
join_paths('../a1/b1/../c1/d1/e1', '../a2/../b2/c2/d2/../e2'),
'../a1/c1/d1/b2/c2/e2'
=> 'complex deref ".."'
);
is(
join_paths('../a1/../../c1', 'a2/../../'),
'../..'
=> 'too many ".."'
);
is(
join_paths('./a1', '../../a2'),
'../a2'
=> 'drop any "./"'
);
is(
join_paths('a/b/c', '.'),
'a/b/c'
=> '. on RHS'
);

View file

@ -1,88 +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/.
#
# Testing Stow::link_dest_within_stow_dir()
#
use strict;
use warnings;
use Test::More tests => 6;
use testutil;
use Stow::Util;
init_test_dirs();
# This is a relative path, unlike $ABS_TEST_DIR below.
my $stow = new_Stow(dir => "$TEST_DIR/stow",
target => "$TEST_DIR/target");
subtest("relative stow dir, link to top-level package file" => sub {
plan tests => 2;
my ($package, $path) =
$stow->link_dest_within_stow_dir("../stow/pkg/dir/file");
is($package, "pkg", "package");
is($path, "dir/file", "path");
});
subtest("relative stow dir, link to second-level package file" => sub {
plan tests => 2;
my ($package, $path) =
$stow->link_dest_within_stow_dir("../stow/pkg/dir/subdir/file");
is($package, "pkg", "package");
is($path, "dir/subdir/file", "path");
});
# This is an absolute path, unlike $TEST_DIR above.
$stow = new_Stow(dir => "$ABS_TEST_DIR/stow",
target => "$ABS_TEST_DIR/target");
subtest("relative stow dir, link to second-level package file" => sub {
plan tests => 2;
my ($package, $path) =
$stow->link_dest_within_stow_dir("../stow/pkg/dir/file");
is($package, "pkg", "package");
is($path, "dir/file", "path");
});
subtest("absolute stow dir, link to top-level package file" => sub {
plan tests => 2;
my ($package, $path) =
$stow->link_dest_within_stow_dir("../stow/pkg/dir/subdir/file");
is($package, "pkg", "package");
is($path, "dir/subdir/file", "path");
});
# Links with destination in the target are not pointing within
# the stow dir, so they're not owned by stow.
subtest("link to path in target" => sub {
plan tests => 2;
my ($package, $path) =
$stow->link_dest_within_stow_dir("./alien");
is($path, "", "alien is in target, so path is empty");
is($package, "", "alien is in target, so package is empty");
});
subtest("link to path outside target and stow dir" => sub {
plan tests => 2;
my ($package, $path) =
$stow->link_dest_within_stow_dir("../alien");
is($path, "", "alien is outside, so path is empty");
is($package, "", "alien is outside, so package is empty");
});

895
t/stow.t
View file

@ -22,7 +22,7 @@
use strict; use strict;
use warnings; use warnings;
use Test::More tests => 22; use Test::More tests => 118;
use Test::Output; use Test::Output;
use English qw(-no_match_vars); use English qw(-no_match_vars);
@ -37,535 +37,520 @@ my %conflicts;
# Note that each of the following tests use a distinct set of files # Note that each of the following tests use a distinct set of files
subtest('stow a simple tree minimally', sub { #
plan tests => 2; # stow a simple tree minimally
my $stow = new_Stow(dir => '../stow'); #
$stow = new_Stow(dir => '../stow');
make_path('../stow/pkg1/bin1'); make_path('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1'); make_file('../stow/pkg1/bin1/file1');
$stow->plan_stow('pkg1'); $stow->plan_stow('pkg1');
$stow->process_tasks(); $stow->process_tasks();
is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow'); is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow');
is( is(
readlink('bin1'), readlink('bin1'),
'../stow/pkg1/bin1', '../stow/pkg1/bin1',
=> 'minimal stow of a simple tree' => 'minimal stow of a simple tree'
); );
});
subtest('stow a simple tree into an existing directory', sub { #
plan tests => 1; # stow a simple tree into an existing directory
my $stow = new_Stow(); #
$stow = new_Stow();
make_path('../stow/pkg2/lib2'); make_path('../stow/pkg2/lib2');
make_file('../stow/pkg2/lib2/file2'); make_file('../stow/pkg2/lib2/file2');
make_path('lib2'); make_path('lib2');
$stow->plan_stow('pkg2'); $stow->plan_stow('pkg2');
$stow->process_tasks(); $stow->process_tasks();
is( is(
readlink('lib2/file2'), readlink('lib2/file2'),
'../../stow/pkg2/lib2/file2', '../../stow/pkg2/lib2/file2',
=> 'stow simple tree to existing directory' => 'stow simple tree to existing directory'
); );
});
subtest('unfold existing tree', sub { #
plan tests => 3; # unfold existing tree
my $stow = new_Stow(); #
$stow = new_Stow();
make_path('../stow/pkg3a/bin3'); make_path('../stow/pkg3a/bin3');
make_file('../stow/pkg3a/bin3/file3a'); make_file('../stow/pkg3a/bin3/file3a');
make_link('bin3' => '../stow/pkg3a/bin3'); # emulate stow make_link('bin3' => '../stow/pkg3a/bin3'); # emulate stow
make_path('../stow/pkg3b/bin3'); make_path('../stow/pkg3b/bin3');
make_file('../stow/pkg3b/bin3/file3b'); make_file('../stow/pkg3b/bin3/file3b');
$stow->plan_stow('pkg3b'); $stow->plan_stow('pkg3b');
$stow->process_tasks(); $stow->process_tasks();
ok(-d 'bin3'); ok(
is(readlink('bin3/file3a'), '../../stow/pkg3a/bin3/file3a'); -d 'bin3' &&
is(readlink('bin3/file3b'), '../../stow/pkg3b/bin3/file3b' readlink('bin3/file3a') eq '../../stow/pkg3a/bin3/file3a' &&
=> 'target already has 1 stowed package'); readlink('bin3/file3b') eq '../../stow/pkg3b/bin3/file3b'
}); => 'target already has 1 stowed package'
);
subtest("Package dir 'bin4' conflicts with existing non-dir so can't unfold", sub { #
plan tests => 2; # Link to a new dir 'bin4' conflicts with existing non-dir so can't
my $stow = new_Stow(); # unfold
#
$stow = new_Stow();
make_file('bin4'); # this is a file but named like a directory make_file('bin4'); # this is a file but named like a directory
make_path('../stow/pkg4/bin4'); make_path('../stow/pkg4/bin4');
make_file('../stow/pkg4/bin4/file4'); make_file('../stow/pkg4/bin4/file4');
$stow->plan_stow('pkg4'); $stow->plan_stow('pkg4');
%conflicts = $stow->get_conflicts(); %conflicts = $stow->get_conflicts();
is($stow->get_conflict_count, 1); ok(
$stow->get_conflict_count == 1 &&
$conflicts{stow}{pkg4}[0] =~
qr/existing target is neither a link nor a directory/
=> 'link to new dir bin4 conflicts with existing non-directory'
);
#
# Link to a new dir 'bin4a' conflicts with existing non-dir so can't
# unfold even with --adopt
#
#$stow = new_Stow(adopt => 1);
$stow = new_Stow();
make_file('bin4a'); # this is a file but named like a directory
make_path('../stow/pkg4a/bin4a');
make_file('../stow/pkg4a/bin4a/file4a');
$stow->plan_stow('pkg4a');
%conflicts = $stow->get_conflicts();
ok(
$stow->get_conflict_count == 1 &&
$conflicts{stow}{pkg4a}[0] =~
qr/existing target is neither a link nor a directory/
=> 'link to new dir bin4a conflicts with existing non-directory'
);
#
# Link to files 'file4b' and 'bin4b' conflict with existing files
# without --adopt
#
$stow = new_Stow();
# Populate target
make_file('file4b', 'file4b - version originally in target');
make_path ('bin4b');
make_file('bin4b/file4b', 'bin4b/file4b - version originally in target');
# Populate
make_path ('../stow/pkg4b/bin4b');
make_file('../stow/pkg4b/file4b', 'file4b - version originally in stow package');
make_file('../stow/pkg4b/bin4b/file4b', 'bin4b/file4b - version originally in stow package');
$stow->plan_stow('pkg4b');
%conflicts = $stow->get_conflicts();
is($stow->get_conflict_count, 2 => 'conflict per file');
for my $i (0, 1) {
like( like(
$conflicts{stow}{pkg4}[0], $conflicts{stow}{pkg4b}[$i],
qr!cannot stow ../stow/pkg4/bin4 over existing target bin4 since neither a link nor a directory and --adopt not specified! qr/existing target is neither a link nor a directory/
=> 'link to new dir bin4 conflicts with existing non-directory' => 'link to file4b conflicts with existing non-directory'
); );
}); }
subtest("Package dir 'bin4a' conflicts with existing non-dir " . #
"so can't unfold even with --adopt", sub { # Link to files 'file4b' and 'bin4b' do not conflict with existing
plan tests => 2; # files when --adopt is given
my $stow = new_Stow(adopt => 1); #
$stow = new_Stow(adopt => 1);
make_file('bin4a'); # this is a file but named like a directory # Populate target
make_path('../stow/pkg4a/bin4a'); make_file('file4c', "file4c - version originally in target\n");
make_file('../stow/pkg4a/bin4a/file4a'); make_path ('bin4c');
make_file('bin4c/file4c', "bin4c/file4c - version originally in target\n");
$stow->plan_stow('pkg4a'); # Populate
%conflicts = $stow->get_conflicts(); make_path ('../stow/pkg4c/bin4c');
is($stow->get_conflict_count, 1); make_file('../stow/pkg4c/file4c', "file4c - version originally in stow package\n");
like( make_file('../stow/pkg4c/bin4c/file4c', "bin4c/file4c - version originally in stow package\n");
$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'
);
});
subtest("Package files 'file4b' and 'bin4b' conflict with existing files", sub { $stow->plan_stow('pkg4c');
plan tests => 3; is($stow->get_conflict_count, 0 => 'no conflicts with --adopt');
my $stow = new_Stow(); is($stow->get_tasks, 4 => 'two tasks per file');
$stow->process_tasks();
# Populate target for my $file ('file4c', 'bin4c/file4c') {
make_file('file4b', 'file4b - version originally in target'); ok(-l $file, "$file turned into a symlink");
make_path('bin4b');
make_file('bin4b/file4b', 'bin4b/file4b - version originally in target');
# Populate stow package
make_path('../stow/pkg4b');
make_file('../stow/pkg4b/file4b', 'file4b - version originally in stow package');
make_path('../stow/pkg4b/bin4b');
make_file('../stow/pkg4b/bin4b/file4b', 'bin4b/file4b - version originally in stow package');
$stow->plan_stow('pkg4b');
%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,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);
# Populate target
make_file('file4c', "file4c - version originally in target\n");
make_path ('bin4c');
make_file('bin4c/file4c', "bin4c/file4c - version originally in target\n");
# Populate stow package
make_path('../stow/pkg4c');
make_file('../stow/pkg4c/file4c', "file4c - version originally in stow package\n");
make_path ('../stow/pkg4c/bin4c');
make_file('../stow/pkg4c/bin4c/file4c', "bin4c/file4c - version originally in stow package\n");
$stow->plan_stow('pkg4c');
is($stow->get_conflict_count, 0 => 'no conflicts with --adopt');
is($stow->get_tasks, 4 => 'two tasks per file');
$stow->process_tasks();
for my $file ('file4c', 'bin4c/file4c') {
ok(-l $file, "$file turned into a symlink");
is(
readlink $file,
(index($file, '/') == -1 ? '' : '../' )
. "../stow/pkg4c/$file" => "$file points to right place"
);
is(cat_file($file), "$file - version originally in target\n" => "$file has right contents");
}
});
subtest("Target already exists but is not owned by stow", sub {
plan tests => 1;
my $stow = new_Stow();
make_path('bin5');
make_invalid_link('bin5/file5','../../empty');
make_path('../stow/pkg5/bin5/file5');
$stow->plan_stow('pkg5');
%conflicts = $stow->get_conflicts();
like(
$conflicts{stow}{pkg5}[-1],
qr/not owned by stow/
=> 'target already exists but is not owned by stow'
);
});
subtest("Replace existing but invalid target", sub {
plan tests => 1;
my $stow = new_Stow();
make_invalid_link('file6','../stow/path-does-not-exist');
make_path('../stow/pkg6');
make_file('../stow/pkg6/file6');
$stow->plan_stow('pkg6');
$stow->process_tasks();
is( is(
readlink('file6'), readlink $file,
'../stow/pkg6/file6' (index($file, '/') == -1 ? '' : '../' )
=> 'replace existing but invalid target' . "../stow/pkg4c/$file" => "$file points to right place"
); );
}); is(cat_file($file), "$file - version originally in target\n" => "$file has right contents");
}
subtest("Target already exists, is owned by stow, but points to a non-directory", sub {
plan tests => 1;
my $stow = new_Stow();
#set_debug_level(4);
make_path('bin7'); #
make_path('../stow/pkg7a/bin7'); # Target already exists but is not owned by stow
make_file('../stow/pkg7a/bin7/node7'); #
make_link('bin7/node7','../../stow/pkg7a/bin7/node7'); $stow = new_Stow();
make_path('../stow/pkg7b/bin7/node7');
make_file('../stow/pkg7b/bin7/node7/file7');
$stow->plan_stow('pkg7b'); make_path('bin5');
%conflicts = $stow->get_conflicts(); make_invalid_link('bin5/file5','../../empty');
like( make_path('../stow/pkg5/bin5/file5');
$conflicts{stow}{pkg7b}[-1],
qr/existing target is stowed to a different package/
=> 'link to new dir conflicts with existing stowed non-directory'
);
});
subtest("stowing directories named 0", sub { $stow->plan_stow('pkg5');
plan tests => 4; %conflicts = $stow->get_conflicts();
my $stow = new_Stow(); like(
$conflicts{stow}{pkg5}[-1],
qr/not owned by stow/
=> 'target already exists but is not owned by stow'
);
make_path('../stow/pkg8a/0'); #
make_file('../stow/pkg8a/0/file8a'); # Replace existing but invalid target
make_link('0' => '../stow/pkg8a/0'); # emulate stow #
$stow = new_Stow();
make_path('../stow/pkg8b/0'); make_invalid_link('file6','../stow/path-does-not-exist');
make_file('../stow/pkg8b/0/file8b'); make_path('../stow/pkg6');
make_file('../stow/pkg6/file6');
$stow->plan_stow('pkg8b'); $stow->plan_stow('pkg6');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); is(
ok(-d '0'); readlink('file6'),
is(readlink('0/file8a'), '../../stow/pkg8a/0/file8a'); '../stow/pkg6/file6'
is(readlink('0/file8b'), '../../stow/pkg8b/0/file8b' => 'replace existing but invalid target'
=> 'stowing directories named 0' );
);
});
subtest("overriding already stowed documentation", sub { #
plan tests => 2; # Target already exists, is owned by stow, but points to a non-directory
my $stow = new_Stow(override => ['man9', 'info9']); # (can't unfold)
#
$stow = new_Stow();
#set_debug_level(4);
make_path('../stow/pkg9a/man9/man1'); make_path('bin7');
make_file('../stow/pkg9a/man9/man1/file9.1'); make_path('../stow/pkg7a/bin7');
make_path('man9/man1'); make_file('../stow/pkg7a/bin7/node7');
make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow make_link('bin7/node7','../../stow/pkg7a/bin7/node7');
make_path('../stow/pkg7b/bin7/node7');
make_file('../stow/pkg7b/bin7/node7/file7');
make_path('../stow/pkg9b/man9/man1'); $stow->plan_stow('pkg7b');
make_file('../stow/pkg9b/man9/man1/file9.1'); %conflicts = $stow->get_conflicts();
like(
$conflicts{stow}{pkg7b}[-1],
qr/existing target is stowed to a different package/
=> 'link to new dir conflicts with existing stowed non-directory'
);
$stow->plan_stow('pkg9b'); #
$stow->process_tasks(); # stowing directories named 0
is($stow->get_conflict_count, 0); #
is(readlink('man9/man1/file9.1'), '../../../stow/pkg9b/man9/man1/file9.1' $stow = new_Stow();
=> 'overriding existing documentation files'
);
});
subtest("deferring to already stowed documentation", sub { make_path('../stow/pkg8a/0');
plan tests => 3; make_file('../stow/pkg8a/0/file8a');
my $stow = new_Stow(defer => ['man10', 'info10']); make_link('0' => '../stow/pkg8a/0'); # emulate stow
make_path('../stow/pkg10a/man10/man1'); make_path('../stow/pkg8b/0');
make_file('../stow/pkg10a/man10/man1/file10.1'); make_file('../stow/pkg8b/0/file8b');
make_path('man10/man1');
make_link('man10/man1/file10.1' => '../../../stow/pkg10a/man10/man1/file10.1'); # emulate stow
make_path('../stow/pkg10b/man10/man1'); $stow->plan_stow('pkg8b');
make_file('../stow/pkg10b/man10/man1/file10.1'); $stow->process_tasks();
ok(
$stow->get_conflict_count == 0 &&
-d '0' &&
readlink('0/file8a') eq '../../stow/pkg8a/0/file8a' &&
readlink('0/file8b') eq '../../stow/pkg8b/0/file8b'
=> 'stowing directories named 0'
);
$stow->plan_stow('pkg10b'); #
is($stow->get_tasks, 0, 'no tasks to process'); # overriding already stowed documentation
is($stow->get_conflict_count, 0); #
is(readlink('man10/man1/file10.1'), '../../../stow/pkg10a/man10/man1/file10.1' $stow = new_Stow(override => ['man9', 'info9']);
=> 'defer to existing documentation files'
);
});
subtest("Ignore temp files", sub { make_path('../stow/pkg9a/man9/man1');
plan tests => 4; make_file('../stow/pkg9a/man9/man1/file9.1');
my $stow = new_Stow(ignore => ['~', '\.#.*']); make_path('man9/man1');
make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow
make_path('../stow/pkg11/man11/man1'); make_path('../stow/pkg9b/man9/man1');
make_file('../stow/pkg11/man11/man1/file11.1'); make_file('../stow/pkg9b/man9/man1/file9.1');
make_file('../stow/pkg11/man11/man1/file11.1~');
make_file('../stow/pkg11/man11/man1/.#file11.1');
make_path('man11/man1');
$stow->plan_stow('pkg11'); $stow->plan_stow('pkg9b');
$stow->process_tasks(); $stow->process_tasks();
is($stow->get_conflict_count, 0); ok(
is(readlink('man11/man1/file11.1'), '../../../stow/pkg11/man11/man1/file11.1'); $stow->get_conflict_count == 0 &&
ok(!-e 'man11/man1/file11.1~'); readlink('man9/man1/file9.1') eq '../../../stow/pkg9b/man9/man1/file9.1'
ok(!-e 'man11/man1/.#file11.1' => 'overriding existing documentation files'
=> 'ignore temp files' );
);
});
subtest("stowing links library files", sub { #
plan tests => 3; # deferring to already stowed documentation
my $stow = new_Stow(); #
$stow = new_Stow(defer => ['man10', 'info10']);
make_path('../stow/pkg12/lib12/'); make_path('../stow/pkg10a/man10/man1');
make_file('../stow/pkg12/lib12/lib.so.1'); make_file('../stow/pkg10a/man10/man1/file10.1');
make_link('../stow/pkg12/lib12/lib.so', 'lib.so.1'); make_path('man10/man1');
make_link('man10/man1/file10.1' => '../../../stow/pkg10a/man10/man1/file10.1'); # emulate stow
make_path('lib12/'); make_path('../stow/pkg10b/man10/man1');
make_file('../stow/pkg10b/man10/man1/file10.1');
$stow->plan_stow('pkg12'); $stow->plan_stow('pkg10b');
$stow->process_tasks(); is($stow->get_tasks, 0, 'no tasks to process');
is($stow->get_conflict_count, 0); ok(
is(readlink('lib12/lib.so.1'), '../../stow/pkg12/lib12/lib.so.1'); $stow->get_conflict_count == 0 &&
is(readlink('lib12/lib.so'), '../../stow/pkg12/lib12/lib.so' readlink('man10/man1/file10.1') eq '../../../stow/pkg10a/man10/man1/file10.1'
=> 'stow links to libraries' => 'defer to existing documentation files'
); );
});
subtest("unfolding to stow links to library files", sub { #
plan tests => 5; # Ignore temp files
my $stow = new_Stow(); #
$stow = new_Stow(ignore => ['~', '\.#.*']);
make_path('../stow/pkg13a/lib13/'); make_path('../stow/pkg11/man11/man1');
make_file('../stow/pkg13a/lib13/liba.so.1'); make_file('../stow/pkg11/man11/man1/file11.1');
make_link('../stow/pkg13a/lib13/liba.so', 'liba.so.1'); make_file('../stow/pkg11/man11/man1/file11.1~');
make_link('lib13','../stow/pkg13a/lib13'); make_file('../stow/pkg11/man11/man1/.#file11.1');
make_path('man11/man1');
make_path('../stow/pkg13b/lib13/'); $stow->plan_stow('pkg11');
make_file('../stow/pkg13b/lib13/libb.so.1'); $stow->process_tasks();
make_link('../stow/pkg13b/lib13/libb.so', 'libb.so.1'); ok(
$stow->get_conflict_count == 0 &&
readlink('man11/man1/file11.1') eq '../../../stow/pkg11/man11/man1/file11.1' &&
!-e 'man11/man1/file11.1~' &&
!-e 'man11/man1/.#file11.1'
=> 'ignore temp files'
);
$stow->plan_stow('pkg13b'); #
$stow->process_tasks(); # stowing links library files
is($stow->get_conflict_count, 0); #
is(readlink('lib13/liba.so.1'), '../../stow/pkg13a/lib13/liba.so.1'); $stow = new_Stow();
is(readlink('lib13/liba.so' ), '../../stow/pkg13a/lib13/liba.so');
is(readlink('lib13/libb.so.1'), '../../stow/pkg13b/lib13/libb.so.1');
is(readlink('lib13/libb.so' ), '../../stow/pkg13b/lib13/libb.so'
=> 'unfolding to stow links to libraries'
);
});
subtest("stowing to stow dir should fail", sub { make_path('../stow/pkg12/lib12/');
plan tests => 4; make_file('../stow/pkg12/lib12/lib.so.1');
make_path('stow'); make_link('../stow/pkg12/lib12/lib.so', 'lib.so.1');
$stow = new_Stow(dir => 'stow');
make_path('stow/pkg14/stow/pkg15'); make_path('lib12/');
make_file('stow/pkg14/stow/pkg15/node15');
stderr_like( $stow->plan_stow('pkg12');
sub { $stow->plan_stow('pkg14'); }, $stow->process_tasks();
qr/WARNING: skipping target which was current stow directory stow/, ok(
"stowing to stow dir should give warning" $stow->get_conflict_count == 0 &&
); readlink('lib12/lib.so.1') eq '../../stow/pkg12/lib12/lib.so.1' &&
readlink('lib12/lib.so' ) eq '../../stow/pkg12/lib12/lib.so'
=> 'stow links to libraries'
);
is($stow->get_tasks, 0, 'no tasks to process'); #
is($stow->get_conflict_count, 0); # unfolding to stow links to library files
ok( #
! -l 'stow/pkg15' $stow = new_Stow();
=> "stowing to stow dir should fail"
);
});
subtest("stow a simple tree minimally when cwd isn't target", sub { make_path('../stow/pkg13a/lib13/');
plan tests => 2; make_file('../stow/pkg13a/lib13/liba.so.1');
cd('../..'); make_link('../stow/pkg13a/lib13/liba.so', 'liba.so.1');
$stow = new_Stow(dir => "$TEST_DIR/stow", target => "$TEST_DIR/target"); make_link('lib13','../stow/pkg13a/lib13');
make_path("$TEST_DIR/stow/pkg16/bin16"); make_path('../stow/pkg13b/lib13/');
make_file("$TEST_DIR/stow/pkg16/bin16/file16"); make_file('../stow/pkg13b/lib13/libb.so.1');
make_link('../stow/pkg13b/lib13/libb.so', 'libb.so.1');
$stow->plan_stow('pkg16'); $stow->plan_stow('pkg13b');
$stow->process_tasks(); $stow->process_tasks();
is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow'); ok(
is( $stow->get_conflict_count == 0 &&
readlink("$TEST_DIR/target/bin16"), readlink('lib13/liba.so.1') eq '../../stow/pkg13a/lib13/liba.so.1' &&
'../stow/pkg16/bin16', readlink('lib13/liba.so' ) eq '../../stow/pkg13a/lib13/liba.so' &&
=> "minimal stow of a simple tree when cwd isn't target" readlink('lib13/libb.so.1') eq '../../stow/pkg13b/lib13/libb.so.1' &&
); readlink('lib13/libb.so' ) eq '../../stow/pkg13b/lib13/libb.so'
}); => 'unfolding to stow links to libraries'
);
subtest("stow a simple tree minimally to absolute stow dir when cwd isn't", sub { #
plan tests => 2; # stowing to stow dir should fail
my $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"), #
target => "$TEST_DIR/target"); make_path('stow');
$stow = new_Stow(dir => 'stow');
make_path("$TEST_DIR/stow/pkg17/bin17"); make_path('stow/pkg14/stow/pkg15');
make_file("$TEST_DIR/stow/pkg17/bin17/file17"); make_file('stow/pkg14/stow/pkg15/node15');
$stow->plan_stow('pkg17'); capture_stderr();
$stow->process_tasks(); $stow->plan_stow('pkg14');
is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow'); is($stow->get_tasks, 0, 'no tasks to process');
is( ok(
readlink("$TEST_DIR/target/bin17"), $stow->get_conflict_count == 0 &&
'../stow/pkg17/bin17', ! -l 'stow/pkg15'
=> "minimal stow of a simple tree with absolute stow dir" => "stowing to stow dir should fail"
); );
}); like($stderr,
qr/WARNING: skipping target which was current stow directory stow/
=> "stowing to stow dir should give warning");
uncapture_stderr();
subtest("stow a simple tree minimally with absolute stow AND target dirs when", sub { #
plan tests => 2; # stow a simple tree minimally when cwd isn't target
my $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"), #
target => canon_path("$TEST_DIR/target")); cd('../..');
$stow = new_Stow(dir => "$TEST_DIR/stow", target => "$TEST_DIR/target");
make_path("$TEST_DIR/stow/pkg18/bin18"); make_path("$TEST_DIR/stow/pkg16/bin16");
make_file("$TEST_DIR/stow/pkg18/bin18/file18"); make_file("$TEST_DIR/stow/pkg16/bin16/file16");
$stow->plan_stow('pkg18'); $stow->plan_stow('pkg16');
$stow->process_tasks(); $stow->process_tasks();
is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow'); is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow');
is( is(
readlink("$TEST_DIR/target/bin18"), readlink("$TEST_DIR/target/bin16"),
'../stow/pkg18/bin18', '../stow/pkg16/bin16',
=> "minimal stow of a simple tree with absolute stow and target dirs" => "minimal stow of a simple tree when cwd isn't target"
); );
});
subtest("stow a tree with no-folding enabled", sub { #
plan tests => 82; # stow a simple tree minimally to absolute stow dir when cwd isn't
# folded directories should be split open (unfolded) where # target
# (and only where) necessary #
# $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"),
cd("$TEST_DIR/target"); target => "$TEST_DIR/target");
sub create_pkg { make_path("$TEST_DIR/stow/pkg17/bin17");
my ($id, $pkg) = @_; make_file("$TEST_DIR/stow/pkg17/bin17/file17");
my $stow_pkg = "../stow/$id-$pkg"; $stow->plan_stow('pkg17');
make_path ($stow_pkg); $stow->process_tasks();
make_file("$stow_pkg/$id-file-$pkg"); is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow');
is(
readlink("$TEST_DIR/target/bin17"),
'../stow/pkg17/bin17',
=> "minimal stow of a simple tree with absolute stow dir"
);
# create a shallow hierarchy specific to this package which isn't #
# yet stowed # stow a simple tree minimally with absolute stow AND target dirs when
make_path ("$stow_pkg/$id-$pkg-only-new"); # cwd isn't target
make_file("$stow_pkg/$id-$pkg-only-new/$id-file-$pkg"); #
$stow = new_Stow(dir => canon_path("$TEST_DIR/stow"),
target => canon_path("$TEST_DIR/target"));
# create a deeper hierarchy specific to this package which isn't make_path("$TEST_DIR/stow/pkg18/bin18");
# yet stowed make_file("$TEST_DIR/stow/pkg18/bin18/file18");
make_path ("$stow_pkg/$id-$pkg-only-new2/subdir");
make_file("$stow_pkg/$id-$pkg-only-new2/subdir/$id-file-$pkg");
make_link("$stow_pkg/$id-$pkg-only-new2/current", "subdir");
# create a hierarchy specific to this package which is already $stow->plan_stow('pkg18');
# stowed via a folded tree $stow->process_tasks();
make_path ("$stow_pkg/$id-$pkg-only-old"); is_deeply([ $stow->get_conflicts ], [], 'no conflicts with minimal stow');
make_link("$id-$pkg-only-old", "$stow_pkg/$id-$pkg-only-old"); is(
make_file("$stow_pkg/$id-$pkg-only-old/$id-file-$pkg"); readlink("$TEST_DIR/target/bin18"),
'../stow/pkg18/bin18',
=> "minimal stow of a simple tree with absolute stow and target dirs"
);
# create a shared hierarchy which this package uses #
make_path ("$stow_pkg/$id-shared"); # stow a tree with no-folding enabled -
make_file("$stow_pkg/$id-shared/$id-file-$pkg"); # no new folded directories should be created, and existing
# folded directories should be split open (unfolded) where
# (and only where) necessary
#
cd("$TEST_DIR/target");
# create a partially shared hierarchy which this package uses sub create_pkg {
make_path ("$stow_pkg/$id-shared2/subdir-$pkg"); my ($id, $pkg) = @_;
make_file("$stow_pkg/$id-shared2/$id-file-$pkg");
make_file("$stow_pkg/$id-shared2/subdir-$pkg/$id-file-$pkg");
}
foreach my $pkg (qw{a b}) { my $stow_pkg = "../stow/$id-$pkg";
create_pkg('no-folding', $pkg); make_path ($stow_pkg);
} make_file("$stow_pkg/$id-file-$pkg");
$stow = new_Stow('no-folding' => 1); # create a shallow hierarchy specific to this package which isn't
$stow->plan_stow('no-folding-a'); # yet stowed
is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding'); make_path ("$stow_pkg/$id-$pkg-only-new");
my @tasks = $stow->get_tasks; make_file("$stow_pkg/$id-$pkg-only-new/$id-file-$pkg");
use Data::Dumper;
is(scalar(@tasks), 13 => "6 dirs, 7 links") || warn Dumper(\@tasks);
$stow->process_tasks();
sub check_no_folding { # create a deeper hierarchy specific to this package which isn't
my ($pkg) = @_; # yet stowed
my $stow_pkg = "../stow/no-folding-$pkg"; make_path ("$stow_pkg/$id-$pkg-only-new2/subdir");
is_link("no-folding-file-$pkg", "$stow_pkg/no-folding-file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-new2/subdir/$id-file-$pkg");
make_link("$stow_pkg/$id-$pkg-only-new2/current", "subdir");
# check existing folded tree is untouched # create a hierarchy specific to this package which is already
is_link("no-folding-$pkg-only-old", "$stow_pkg/no-folding-$pkg-only-old"); # stowed via a folded tree
make_path ("$stow_pkg/$id-$pkg-only-old");
make_link("$id-$pkg-only-old", "$stow_pkg/$id-$pkg-only-old");
make_file("$stow_pkg/$id-$pkg-only-old/$id-file-$pkg");
# check newly stowed shallow tree is not folded # create a shared hierarchy which this package uses
is_dir_not_symlink("no-folding-$pkg-only-new"); make_path ("$stow_pkg/$id-shared");
is_link("no-folding-$pkg-only-new/no-folding-file-$pkg", make_file("$stow_pkg/$id-shared/$id-file-$pkg");
"../$stow_pkg/no-folding-$pkg-only-new/no-folding-file-$pkg");
# check newly stowed deeper tree is not folded # create a partially shared hierarchy which this package uses
is_dir_not_symlink("no-folding-$pkg-only-new2"); make_path ("$stow_pkg/$id-shared2/subdir-$pkg");
is_dir_not_symlink("no-folding-$pkg-only-new2/subdir"); make_file("$stow_pkg/$id-shared2/$id-file-$pkg");
is_link("no-folding-$pkg-only-new2/subdir/no-folding-file-$pkg", make_file("$stow_pkg/$id-shared2/subdir-$pkg/$id-file-$pkg");
"../../$stow_pkg/no-folding-$pkg-only-new2/subdir/no-folding-file-$pkg"); }
is_link("no-folding-$pkg-only-new2/current",
"../$stow_pkg/no-folding-$pkg-only-new2/current");
# check shared tree is not folded. first time round this will be foreach my $pkg (qw{a b}) {
# newly stowed. create_pkg('no-folding', $pkg);
is_dir_not_symlink('no-folding-shared'); }
is_link("no-folding-shared/no-folding-file-$pkg",
"../$stow_pkg/no-folding-shared/no-folding-file-$pkg");
# check partially shared tree is not folded. first time round this $stow = new_Stow('no-folding' => 1);
# will be newly stowed. $stow->plan_stow('no-folding-a');
is_dir_not_symlink('no-folding-shared2'); is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding');
is_link("no-folding-shared2/no-folding-file-$pkg", my @tasks = $stow->get_tasks;
"../$stow_pkg/no-folding-shared2/no-folding-file-$pkg"); use Data::Dumper;
is_link("no-folding-shared2/no-folding-file-$pkg", is(scalar(@tasks), 13 => "6 dirs, 7 links") || warn Dumper(\@tasks);
"../$stow_pkg/no-folding-shared2/no-folding-file-$pkg"); $stow->process_tasks();
}
check_no_folding('a'); sub check_no_folding {
my ($pkg) = @_;
my $stow_pkg = "../stow/no-folding-$pkg";
is_link("no-folding-file-$pkg", "$stow_pkg/no-folding-file-$pkg");
$stow = new_Stow('no-folding' => 1); # check existing folded tree is untouched
$stow->plan_stow('no-folding-b'); is_link("no-folding-$pkg-only-old", "$stow_pkg/no-folding-$pkg-only-old");
is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding');
@tasks = $stow->get_tasks;
is(scalar(@tasks), 11 => '4 dirs, 7 links') || warn Dumper(\@tasks);
$stow->process_tasks();
check_no_folding('a'); # check newly stowed shallow tree is not folded
check_no_folding('b'); is_dir_not_symlink("no-folding-$pkg-only-new");
}); is_link("no-folding-$pkg-only-new/no-folding-file-$pkg",
"../$stow_pkg/no-folding-$pkg-only-new/no-folding-file-$pkg");
# check newly stowed deeper tree is not folded
is_dir_not_symlink("no-folding-$pkg-only-new2");
is_dir_not_symlink("no-folding-$pkg-only-new2/subdir");
is_link("no-folding-$pkg-only-new2/subdir/no-folding-file-$pkg",
"../../$stow_pkg/no-folding-$pkg-only-new2/subdir/no-folding-file-$pkg");
is_link("no-folding-$pkg-only-new2/current",
"../$stow_pkg/no-folding-$pkg-only-new2/current");
# check shared tree is not folded. first time round this will be
# newly stowed.
is_dir_not_symlink('no-folding-shared');
is_link("no-folding-shared/no-folding-file-$pkg",
"../$stow_pkg/no-folding-shared/no-folding-file-$pkg");
# check partially shared tree is not folded. first time round this
# will be newly stowed.
is_dir_not_symlink('no-folding-shared2');
is_link("no-folding-shared2/no-folding-file-$pkg",
"../$stow_pkg/no-folding-shared2/no-folding-file-$pkg");
is_link("no-folding-shared2/no-folding-file-$pkg",
"../$stow_pkg/no-folding-shared2/no-folding-file-$pkg");
}
check_no_folding('a');
$stow = new_Stow('no-folding' => 1);
$stow->plan_stow('no-folding-b');
is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding');
@tasks = $stow->get_tasks;
is(scalar(@tasks), 11 => '4 dirs, 7 links') || warn Dumper(\@tasks);
$stow->process_tasks();
check_no_folding('a');
check_no_folding('b');

View file

@ -24,10 +24,11 @@ package testutil;
use strict; use strict;
use warnings; use warnings;
use Carp qw(confess croak); use Carp qw(croak);
use File::Basename; use File::Basename;
use File::Path qw(make_path remove_tree); use File::Path qw(make_path remove_tree);
use File::Spec; use File::Spec;
use IO::Scalar;
use Test::More; use Test::More;
use Stow; use Stow;
@ -37,6 +38,7 @@ use base qw(Exporter);
our @EXPORT = qw( our @EXPORT = qw(
$ABS_TEST_DIR $ABS_TEST_DIR
$TEST_DIR $TEST_DIR
$stderr
init_test_dirs init_test_dirs
cd cd
new_Stow new_compat_Stow new_Stow new_compat_Stow
@ -44,41 +46,45 @@ our @EXPORT = qw(
remove_dir remove_file remove_link remove_dir remove_file remove_link
cat_file cat_file
is_link is_dir_not_symlink is_nonexistent_path is_link is_dir_not_symlink is_nonexistent_path
capture_stderr uncapture_stderr
); );
our $TEST_DIR = 'tmp-testing-trees'; our $TEST_DIR = 'tmp-testing-trees';
our $ABS_TEST_DIR = File::Spec->rel2abs('tmp-testing-trees'); our $ABS_TEST_DIR = File::Spec->rel2abs('tmp-testing-trees');
sub init_test_dirs { our $stderr;
my $test_dir = shift || $TEST_DIR; my $tied_err;
my $abs_test_dir = File::Spec->rel2abs($test_dir);
sub capture_stderr {
undef $stderr;
$tied_err = tie *STDERR, 'IO::Scalar', \$stderr;
}
sub uncapture_stderr {
undef $tied_err;
untie *STDERR;
}
sub init_test_dirs {
# Create a run_from/ subdirectory for tests which want to run # Create a run_from/ subdirectory for tests which want to run
# from a separate directory outside the Stow directory or # from a separate directory outside the Stow directory or
# target directory. # target directory.
for my $dir ("target", "stow", "run_from") { for my $dir ("target", "stow", "run_from") {
my $path = "$test_dir/$dir"; my $path = "$TEST_DIR/$dir";
-d $path and remove_tree($path); -d $path and remove_tree($path);
make_path($path); make_path($path);
} }
# Don't let user's ~/.stow-global-ignore affect test results # Don't let user's ~/.stow-global-ignore affect test results
$ENV{HOME} = $abs_test_dir; $ENV{HOME} = $ABS_TEST_DIR;
return $abs_test_dir;
} }
sub new_Stow { sub new_Stow {
my %opts = @_; my %opts = @_;
# These default paths assume that execution will be triggered from
# within the target directory.
$opts{dir} ||= '../stow'; $opts{dir} ||= '../stow';
$opts{target} ||= '.'; $opts{target} ||= '.';
$opts{test_mode} = 1; $opts{test_mode} = 1;
my $stow = eval { new Stow(%opts) }; return new Stow(%opts);
if ($@) {
confess "Error while trying to instantiate new Stow(%opts): $@";
}
return $stow;
} }
sub new_compat_Stow { sub new_compat_Stow {
@ -90,28 +96,28 @@ sub new_compat_Stow {
#===== SUBROUTINE =========================================================== #===== SUBROUTINE ===========================================================
# Name : make_link() # Name : make_link()
# Purpose : safely create a link # Purpose : safely create a link
# Parameters: $link_src => path to the link # Parameters: $target => path to the link
# : $link_dest => where the new link should point # : $source => where the new link should point
# : $invalid => true iff $link_dest refers to non-existent file # : $invalid => true iff $source refers to non-existent file
# Returns : n/a # Returns : n/a
# Throws : fatal error if the link can not be safely created # Throws : fatal error if the link can not be safely created
# Comments : checks for existing nodes # Comments : checks for existing nodes
#============================================================================ #============================================================================
sub make_link { sub make_link {
my ($link_src, $link_dest, $invalid) = @_; my ($target, $source, $invalid) = @_;
if (-l $link_src) { if (-l $target) {
my $old_source = readlink join('/', parent($link_src), $link_dest) my $old_source = readlink join('/', parent($target), $source)
or croak "$link_src is already a link but could not read link $link_src/$link_dest"; or die "$target is already a link but could not read link $target/$source";
if ($old_source ne $link_dest) { if ($old_source ne $source) {
croak "$link_src already exists but points elsewhere\n"; die "$target already exists but points elsewhere\n";
} }
} }
croak "$link_src already exists and is not a link\n" if -e $link_src; die "$target already exists and is not a link\n" if -e $target;
my $abs_target = File::Spec->rel2abs($link_src); my $abs_target = File::Spec->rel2abs($target);
my $link_src_container = dirname($abs_target); my $target_container = dirname($abs_target);
my $abs_source = File::Spec->rel2abs($link_dest, $link_src_container); my $abs_source = File::Spec->rel2abs($source, $target_container);
#warn "t $link_src c $link_src_container as $abs_source"; #warn "t $target c $target_container as $abs_source";
if (-e $abs_source) { if (-e $abs_source) {
croak "Won't make invalid link pointing to existing $abs_target" croak "Won't make invalid link pointing to existing $abs_target"
if $invalid; if $invalid;
@ -120,8 +126,8 @@ sub make_link {
croak "Won't make link pointing to non-existent $abs_target" croak "Won't make link pointing to non-existent $abs_target"
unless $invalid; unless $invalid;
} }
symlink $link_dest, $link_src symlink $source, $target
or croak "could not create link $link_src => $link_dest ($!)\n"; or die "could not create link $target => $source ($!)\n";
} }
#===== SUBROUTINE =========================================================== #===== SUBROUTINE ===========================================================
@ -151,11 +157,11 @@ sub make_file {
my ($path, $contents) = @_; my ($path, $contents) = @_;
if (-e $path and ! -f $path) { if (-e $path and ! -f $path) {
croak "a non-file already exists at $path\n"; die "a non-file already exists at $path\n";
} }
open my $FILE ,'>', $path open my $FILE ,'>', $path
or croak "could not create file: $path ($!)\n"; or die "could not create file: $path ($!)\n";
print $FILE $contents if defined $contents; print $FILE $contents if defined $contents;
close $FILE; close $FILE;
} }
@ -172,9 +178,9 @@ sub make_file {
sub remove_link { sub remove_link {
my ($path) = @_; my ($path) = @_;
if (not -l $path) { if (not -l $path) {
croak qq(remove_link() called with a non-link: $path); die qq(remove_link() called with a non-link: $path);
} }
unlink $path or croak "could not remove link: $path ($!)\n"; unlink $path or die "could not remove link: $path ($!)\n";
return; return;
} }
@ -189,9 +195,9 @@ sub remove_link {
sub remove_file { sub remove_file {
my ($path) = @_; my ($path) = @_;
if (-z $path) { if (-z $path) {
croak "file at $path is non-empty\n"; die "file at $path is non-empty\n";
} }
unlink $path or croak "could not remove empty file: $path ($!)\n"; unlink $path or die "could not remove empty file: $path ($!)\n";
return; return;
} }
@ -207,10 +213,10 @@ sub remove_dir {
my ($dir) = @_; my ($dir) = @_;
if (not -d $dir) { if (not -d $dir) {
croak "$dir is not a directory"; die "$dir is not a directory";
} }
opendir my $DIR, $dir or croak "cannot read directory: $dir ($!)\n"; opendir my $DIR, $dir or die "cannot read directory: $dir ($!)\n";
my @listing = readdir $DIR; my @listing = readdir $DIR;
closedir $DIR; closedir $DIR;
@ -221,16 +227,16 @@ sub remove_dir {
my $path = "$dir/$node"; my $path = "$dir/$node";
if (-l $path or (-f $path and -z $path) or $node eq $Stow::LOCAL_IGNORE_FILE) { if (-l $path or (-f $path and -z $path) or $node eq $Stow::LOCAL_IGNORE_FILE) {
unlink $path or croak "cannot unlink $path ($!)\n"; unlink $path or die "cannot unlink $path ($!)\n";
} }
elsif (-d "$path") { elsif (-d "$path") {
remove_dir($path); remove_dir($path);
} }
else { else {
croak "$path is not a link, directory, or empty file\n"; die "$path is not a link, directory, or empty file\n";
} }
} }
rmdir $dir or croak "cannot rmdir $dir ($!)\n"; rmdir $dir or die "cannot rmdir $dir ($!)\n";
return; return;
} }
@ -245,7 +251,7 @@ sub remove_dir {
#============================================================================ #============================================================================
sub cd { sub cd {
my ($dir) = @_; my ($dir) = @_;
chdir $dir or croak "Failed to chdir($dir): $!\n"; chdir $dir or die "Failed to chdir($dir): $!\n";
} }
#===== SUBROUTINE =========================================================== #===== SUBROUTINE ===========================================================
@ -258,7 +264,7 @@ sub cd {
#============================================================================ #============================================================================
sub cat_file { sub cat_file {
my ($file) = @_; my ($file) = @_;
open F, $file or croak "Failed to open($file): $!\n"; open F, $file or die "Failed to open($file): $!\n";
my $contents = join '', <F>; my $contents = join '', <F>;
close(F); close(F);
return $contents; return $contents;
@ -303,5 +309,6 @@ sub is_nonexistent_path {
# Local variables: # Local variables:
# mode: perl # mode: perl
# cperl-indent-level: 4
# end: # end:
# vim: ft=perl # vim: ft=perl

View file

@ -22,528 +22,429 @@
use strict; use strict;
use warnings; use warnings;
use File::Spec qw(make_path); use Test::More tests => 39;
use POSIX qw(getcwd);
use Test::More tests => 35;
use Test::Output; use Test::Output;
use English qw(-no_match_vars); use English qw(-no_match_vars);
use testutil; use testutil;
use Stow::Util qw(canon_path); use Stow::Util qw(canon_path);
my $repo = getcwd(); init_test_dirs();
cd("$TEST_DIR/target");
init_test_dirs($TEST_DIR); # Note that each of the following tests use a distinct set of files
our $COMPAT_TEST_DIR = "${TEST_DIR}-compat"; my $stow;
our $COMPAT_ABS_TEST_DIR = init_test_dirs($COMPAT_TEST_DIR); my %conflicts;
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 # unstow a simple tree minimally
#
$stow = new_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();
ok(
$stow->get_conflict_count == 0 &&
-f '../stow/pkg1/bin1/file1' && ! -e 'bin1'
=> 'unstow a simple tree'
);
# #
# $setup is an optional ref to an options hash to pass into the new # unstow a simple tree from an existing directory
# Stow() constructor, or a ref to a sub which performs setup before #
# the constructor gets called and then returns that options hash. $stow = new_Stow();
sub subtests {
my $name = shift;
my $setup = @_ == 2 ? shift : {};
my $code = shift;
$ENV{HOME} = $ABS_TEST_DIR; make_path('lib2');
cd($repo); make_path('../stow/pkg2/lib2');
cd("$TEST_DIR/target"); make_file('../stow/pkg2/lib2/file2');
create_unowned_files(); make_link('lib2/file2', '../../stow/pkg2/lib2/file2');
# cd first to allow setup to cd somewhere else. $stow->plan_unstow('pkg2');
my $opts = ref($setup) eq 'HASH' ? $setup : $setup->($TEST_DIR); $stow->process_tasks();
subtest($name, sub { ok(
make_path($opts->{dir}) if $opts->{dir}; $stow->get_conflict_count == 0 &&
my $stow = new_Stow(%$opts); -f '../stow/pkg2/lib2/file2' && -d 'lib2'
$code->($stow, $TEST_DIR); => 'unstow simple tree from a pre-existing directory'
}); );
$ENV{HOME} = $COMPAT_ABS_TEST_DIR; #
cd($repo); # fold tree after unstowing
cd("$COMPAT_TEST_DIR/target"); #
create_unowned_files(); $stow = new_Stow();
# 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 { make_path('bin3');
my ($stow, $count) = @_;
plan tests => $stow->{compat} ? $count + 2 : $count;
}
subtests("unstow a simple tree minimally", sub { make_path('../stow/pkg3a/bin3');
my ($stow) = @_; make_file('../stow/pkg3a/bin3/file3a');
plan tests => 3; make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow
make_path('../stow/pkg1/bin1'); make_path('../stow/pkg3b/bin3');
make_file('../stow/pkg1/bin1/file1'); make_file('../stow/pkg3b/bin3/file3b');
make_link('bin1', '../stow/pkg1/bin1'); make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow
$stow->plan_unstow('pkg3b');
$stow->process_tasks();
ok(
$stow->get_conflict_count == 0 &&
-l 'bin3' &&
readlink('bin3') eq '../stow/pkg3a/bin3'
=> 'fold tree after unstowing'
);
$stow->plan_unstow('pkg1'); #
$stow->process_tasks(); # existing link is owned by stow but is invalid so it gets removed anyway
is($stow->get_conflict_count, 0, 'conflict count'); #
ok(-f '../stow/pkg1/bin1/file1'); $stow = new_Stow();
ok(! -e 'bin1' => 'unstow a simple tree');
});
subtests("unstow a simple tree from an existing directory", sub { make_path('bin4');
my ($stow) = @_; make_path('../stow/pkg4/bin4');
plan tests => 3; make_file('../stow/pkg4/bin4/file4');
make_invalid_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist');
make_path('lib2'); $stow->plan_unstow('pkg4');
make_path('../stow/pkg2/lib2'); $stow->process_tasks();
make_file('../stow/pkg2/lib2/file2'); ok(
make_link('lib2/file2', '../../stow/pkg2/lib2/file2'); $stow->get_conflict_count == 0 &&
$stow->plan_unstow('pkg2'); ! -e 'bin4/file4'
$stow->process_tasks(); => q(remove invalid link owned by stow)
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'
);
});
subtests("fold tree after unstowing", sub { #
my ($stow) = @_; # Existing link is not owned by stow
plan tests => 3; #
$stow = new_Stow();
make_path('bin3'); make_path('../stow/pkg5/bin5');
make_invalid_link('bin5', '../not-stow');
make_path('../stow/pkg3a/bin3'); $stow->plan_unstow('pkg5');
make_file('../stow/pkg3a/bin3/file3a'); %conflicts = $stow->get_conflicts;
make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow like(
$conflicts{unstow}{pkg5}[-1],
qr(existing target is not owned by stow)
=> q(existing link not owned by stow)
);
make_path('../stow/pkg3b/bin3'); #
make_file('../stow/pkg3b/bin3/file3b'); # Target already exists, is owned by stow, but points to a different package
make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow #
$stow->plan_unstow('pkg3b'); $stow = new_Stow();
$stow->process_tasks();
is($stow->get_conflict_count, 0, 'conflict count');
ok(-l 'bin3');
is(readlink('bin3'), '../stow/pkg3a/bin3'
=> 'fold tree after unstowing'
);
});
subtests("existing link is owned by stow but is invalid so it gets removed anyway", sub { make_path('bin6');
my ($stow) = @_; make_path('../stow/pkg6a/bin6');
plan tests => 2; make_file('../stow/pkg6a/bin6/file6');
make_link('bin6/file6', '../../stow/pkg6a/bin6/file6');
make_path('bin4'); make_path('../stow/pkg6b/bin6');
make_path('../stow/pkg4/bin4'); make_file('../stow/pkg6b/bin6/file6');
make_file('../stow/pkg4/bin4/file4');
make_invalid_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist');
$stow->plan_unstow('pkg4'); $stow->plan_unstow('pkg6b');
$stow->process_tasks(); ok(
is($stow->get_conflict_count, 0, 'conflict count'); $stow->get_conflict_count == 0 &&
ok(! -e 'bin4/file4' -l 'bin6/file6' &&
=> q(remove invalid link owned by stow) readlink('bin6/file6') eq '../../stow/pkg6a/bin6/file6'
); => q(ignore existing link that points to a different package)
}); );
subtests("Existing invalid link is not owned by stow", sub { #
my ($stow) = @_; # Don't unlink anything under the stow directory
plan tests => 3; #
make_path('stow'); # make out stow dir a subdir of target
$stow = new_Stow(dir => 'stow');
make_path('../stow/pkg5/bin5'); # emulate stowing into ourself (bizarre corner case or accident)
make_invalid_link('bin5', '../not-stow'); make_path('stow/pkg7a/stow/pkg7b');
make_file('stow/pkg7a/stow/pkg7b/file7b');
make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b');
$stow->plan_unstow('pkg5'); $stow->plan_unstow('pkg7b');
is($stow->get_conflict_count, 0, 'conflict count'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg7b');
ok(-l 'bin5', 'invalid link not removed'); ok(
is(readlink('bin5'), '../not-stow' => "invalid link not changed"); $stow->get_conflict_count == 0 &&
}); -l 'stow/pkg7b' &&
readlink('stow/pkg7b') eq '../stow/pkg7a/stow/pkg7b'
=> q(don't unlink any nodes under the stow directory)
);
subtests("Target already exists, is owned by stow, but points to a different package", sub {
my ($stow) = @_;
plan tests => 3;
make_path('bin6'); #
make_path('../stow/pkg6a/bin6'); # Don't unlink any nodes under another stow directory
make_file('../stow/pkg6a/bin6/file6'); #
make_link('bin6/file6', '../../stow/pkg6a/bin6/file6'); $stow = new_Stow(dir => 'stow');
make_path('../stow/pkg6b/bin6'); make_path('stow2'); # make our alternate stow dir a subdir of target
make_file('../stow/pkg6b/bin6/file6'); make_file('stow2/.stow');
$stow->plan_unstow('pkg6b'); # emulate stowing into ourself (bizarre corner case or accident)
is($stow->get_conflict_count, 0, 'conflict count'); make_path('stow/pkg8a/stow2/pkg8b');
ok(-l 'bin6/file6'); make_file('stow/pkg8a/stow2/pkg8b/file8b');
is( make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b');
readlink('bin6/file6'),
'../../stow/pkg6a/bin6/file6'
=> q(ignore existing link that points to a different package)
);
});
subtests("Don't unlink anything under the stow directory", capture_stderr();
sub { $stow->plan_unstow('pkg8a');
make_path('stow'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg8a');
return { dir => 'stow' }; ok(
# target dir defaults to parent of stow, which is target directory $stow->get_conflict_count == 0 &&
}, -l 'stow2/pkg8b' &&
sub { readlink('stow2/pkg8b') eq '../stow/pkg8a/stow2/pkg8b'
plan tests => 5; => q(don't unlink any nodes under another stow directory)
my ($stow) = @_; );
like($stderr,
qr/WARNING: skipping protected directory stow2/
=> "unstowing from ourself should skip stow");
uncapture_stderr();
# Emulate stowing into ourself (bizarre corner case or accident): #
make_path('stow/pkg7a/stow/pkg7b'); # overriding already stowed documentation
make_file('stow/pkg7a/stow/pkg7b/file7b'); #
# Make a package be a link to a package of the same name inside another package. $stow = new_Stow(override => ['man9', 'info9']);
make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b'); make_file('stow/.stow');
stderr_like( make_path('../stow/pkg9a/man9/man1');
sub { $stow->plan_unstow('pkg7b'); }, make_file('../stow/pkg9a/man9/man1/file9.1');
$stow->{compat} ? qr/WARNING: skipping target which was current stow directory stow/ : qr// make_path('man9/man1');
=> "warn when unstowing from ourself" make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg7b');
is($stow->get_conflict_count, 0, 'conflict count');
ok(-l 'stow/pkg7b');
is(
readlink('stow/pkg7b'),
'../stow/pkg7a/stow/pkg7b'
=> q(don't unlink any nodes under the stow directory)
);
});
subtests("Don't unlink any nodes under another stow directory", make_path('../stow/pkg9b/man9/man1');
sub { make_file('../stow/pkg9b/man9/man1/file9.1');
make_path('stow'); $stow->plan_unstow('pkg9b');
return { dir => 'stow' }; $stow->process_tasks();
}, ok(
sub { $stow->get_conflict_count == 0 &&
my ($stow) = @_; !-l 'man9/man1/file9.1'
plan tests => 5; => 'overriding existing documentation files'
);
init_stow2(); #
# emulate stowing into ourself (bizarre corner case or accident) # deferring to already stowed documentation
make_path('stow/pkg8a/stow2/pkg8b'); #
make_file('stow/pkg8a/stow2/pkg8b/file8b'); $stow = new_Stow(defer => ['man10', 'info10']);
make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b');
stderr_like( make_path('../stow/pkg10a/man10/man1');
sub { $stow->plan_unstow('pkg8a'); }, make_file('../stow/pkg10a/man10/man1/file10a.1');
qr/WARNING: skipping marked Stow directory stow2/ make_path('man10/man1');
=> "warn when skipping unstowing" make_link('man10/man1/file10a.1' => '../../../stow/pkg10a/man10/man1/file10a.1');
);
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg8a');
is($stow->get_conflict_count, 0, 'conflict count');
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 # need this to block folding
sub check_protected_dirs_skipped { make_path('../stow/pkg10b/man10/man1');
my ($stderr) = @_; make_file('../stow/pkg10b/man10/man1/file10b.1');
for my $dir (qw{stow stow2}) { make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1');
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'); make_path('../stow/pkg10c/man10/man1');
init_stow2(); make_file('../stow/pkg10c/man10/man1/file10a.1');
make_path('../stow/pkg9a/man9/man1'); $stow->plan_unstow('pkg10c');
make_file('../stow/pkg9a/man9/man1/file9.1'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg10c');
make_path('man9/man1'); ok(
make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow $stow->get_conflict_count == 0 &&
readlink('man10/man1/file10a.1') eq '../../../stow/pkg10a/man10/man1/file10a.1'
=> 'defer to existing documentation files'
);
make_path('../stow/pkg9b/man9/man1'); #
make_file('../stow/pkg9b/man9/man1/file9.1'); # Ignore temp files
my $stderr = stderr_from { $stow->plan_unstow('pkg9b') }; #
check_protected_dirs_skipped($stderr) if $stow->{compat}; $stow = new_Stow(ignore => ['~', '\.#.*']);
$stow->process_tasks();
is($stow->get_conflict_count, 0, 'conflict count');
ok(!-l 'man9/man1/file9.1'
=> 'overriding existing documentation files'
);
});
subtests("deferring to already stowed documentation", make_path('../stow/pkg12/man12/man1');
{defer => ['man10', 'info10']}, make_file('../stow/pkg12/man12/man1/file12.1');
sub { make_file('../stow/pkg12/man12/man1/file12.1~');
my ($stow) = @_; make_file('../stow/pkg12/man12/man1/.#file12.1');
plan_tests($stow, 3); make_path('man12/man1');
make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1');
init_stow2(); $stow->plan_unstow('pkg12');
make_path('../stow/pkg10a/man10/man1'); $stow->process_tasks();
make_file('../stow/pkg10a/man10/man1/file10a.1'); ok(
make_path('man10/man1'); $stow->get_conflict_count == 0 &&
make_link('man10/man1/file10a.1' => '../../../stow/pkg10a/man10/man1/file10a.1'); !-e 'man12/man1/file12.1'
=> 'ignore temp files'
);
# need this to block folding #
make_path('../stow/pkg10b/man10/man1'); # Unstow an already unstowed package
make_file('../stow/pkg10b/man10/man1/file10b.1'); #
make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1'); $stow = new_Stow();
$stow->plan_unstow('pkg12');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12');
ok(
$stow->get_conflict_count == 0
=> 'unstow already unstowed package pkg12'
);
make_path('../stow/pkg10c/man10/man1'); #
make_file('../stow/pkg10c/man10/man1/file10a.1'); # Unstow a never stowed package
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, 'conflict count');
is(
readlink('man10/man1/file10a.1'),
'../../../stow/pkg10a/man10/man1/file10a.1'
=> 'defer to existing documentation files'
);
});
subtests("Ignore temp files", eval { remove_dir("$TEST_DIR/target"); };
{ignore => ['~', '\.#.*']}, mkdir("$TEST_DIR/target");
sub {
my ($stow) = @_;
plan_tests($stow, 2);
init_stow2(); $stow = new_Stow();
make_path('../stow/pkg12/man12/man1'); $stow->plan_unstow('pkg12');
make_file('../stow/pkg12/man12/man1/file12.1'); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 which was never stowed');
make_file('../stow/pkg12/man12/man1/file12.1~'); ok(
make_file('../stow/pkg12/man12/man1/.#file12.1'); $stow->get_conflict_count == 0
make_path('man12/man1'); => 'unstow never stowed package pkg12'
make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1'); );
my $stderr = stderr_from { $stow->plan_unstow('pkg12') }; #
check_protected_dirs_skipped($stderr) if $stow->{compat}; # Unstowing when target contains a real file shouldn't be an issue.
$stow->process_tasks(); #
is($stow->get_conflict_count, 0, 'conflict count'); make_file('man12/man1/file12.1');
ok(! -e 'man12/man1/file12.1' => 'man12/man1/file12.1 was unstowed');
});
subtests("Unstow an already unstowed package", sub { $stow = new_Stow();
my ($stow) = @_; $stow->plan_unstow('pkg12');
plan_tests($stow, 2); is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 for third time');
%conflicts = $stow->get_conflicts;
ok(
$stow->get_conflict_count == 1 &&
$conflicts{unstow}{pkg12}[0]
=~ m!existing target is neither a link nor a directory: man12/man1/file12\.1!
=> 'unstow pkg12 for third time'
);
my $stderr = stderr_from { $stow->plan_unstow('pkg12') }; #
check_protected_dirs_skipped($stderr) if $stow->{compat}; # unstow a simple tree minimally when cwd isn't target
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12'); #
is($stow->get_conflict_count, 0, 'conflict count'); cd('../..');
}); $stow = new_Stow(dir => "$TEST_DIR/stow", target => "$TEST_DIR/target");
subtests("Unstow a never stowed package", sub { make_path("$TEST_DIR/stow/pkg13/bin13");
my ($stow) = @_; make_file("$TEST_DIR/stow/pkg13/bin13/file13");
plan tests => 2; make_link("$TEST_DIR/target/bin13", '../stow/pkg13/bin13');
eval { remove_dir($stow->{target}); }; $stow->plan_unstow('pkg13');
mkdir($stow->{target}); $stow->process_tasks();
ok(
$stow->get_conflict_count == 0 &&
-f "$TEST_DIR/stow/pkg13/bin13/file13" && ! -e "$TEST_DIR/target/bin13"
=> 'unstow a simple tree'
);
$stow->plan_unstow('pkg12'); #
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 which was never stowed'); # unstow a simple tree minimally with absolute stow dir when cwd isn't
is($stow->get_conflict_count, 0, 'conflict count'); # target
}); #
$stow = new_Stow(dir => canon_path("$TEST_DIR/stow"),
target => "$TEST_DIR/target");
subtests("Unstowing when target contains real files shouldn't be an issue", sub { make_path("$TEST_DIR/stow/pkg14/bin14");
my ($stow) = @_; make_file("$TEST_DIR/stow/pkg14/bin14/file14");
plan tests => 4; make_link("$TEST_DIR/target/bin14", '../stow/pkg14/bin14');
# Test both a file which do / don't overlap with the package $stow->plan_unstow('pkg14');
make_path('man12/man1'); $stow->process_tasks();
make_file('man12/man1/alien'); ok(
make_file('man12/man1/file12.1'); $stow->get_conflict_count == 0 &&
-f "$TEST_DIR/stow/pkg14/bin14/file14" && ! -e "$TEST_DIR/target/bin14"
=> 'unstow a simple tree with absolute stow dir'
);
$stow->plan_unstow('pkg12'); #
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 for third time'); # unstow a simple tree minimally with absolute stow AND target dirs
is($stow->get_conflict_count, 0, 'conflict count'); # when cwd isn't target
ok(-f 'man12/man1/alien', 'alien untouched'); #
ok(-f 'man12/man1/file12.1', 'file overlapping with pkg untouched'); $stow = new_Stow(dir => canon_path("$TEST_DIR/stow"),
}); target => canon_path("$TEST_DIR/target"));
subtests("unstow a simple tree minimally when cwd isn't target", make_path("$TEST_DIR/stow/pkg15/bin15");
sub { make_file("$TEST_DIR/stow/pkg15/bin15/file15");
my $test_dir = shift; make_link("$TEST_DIR/target/bin15", '../stow/pkg15/bin15');
cd($repo);
return {
dir => "$test_dir/stow",
target => "$test_dir/target"
}
},
sub {
my ($stow, $test_dir) = @_;
plan tests => 3;
make_path("$test_dir/stow/pkg13/bin13"); $stow->plan_unstow('pkg15');
make_file("$test_dir/stow/pkg13/bin13/file13"); $stow->process_tasks();
make_link("$test_dir/target/bin13", '../stow/pkg13/bin13'); ok(
$stow->get_conflict_count == 0 &&
-f "$TEST_DIR/stow/pkg15/bin15/file15" && ! -e "$TEST_DIR/target/bin15"
=> 'unstow a simple tree with absolute stow and target dirs'
);
$stow->plan_unstow('pkg13'); #
$stow->process_tasks(); # unstow a tree with no-folding enabled -
is($stow->get_conflict_count, 0, 'conflict count'); # no refolding should take place
ok(-f "$test_dir/stow/pkg13/bin13/file13", 'package file untouched'); #
ok(! -e "$test_dir/target/bin13" => 'bin13/ unstowed'); cd("$TEST_DIR/target");
});
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, $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');
$stow->plan_unstow('pkg14');
$stow->process_tasks();
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'
);
});
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;
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, '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'
);
});
sub create_and_stow_pkg { sub create_and_stow_pkg {
my ($id, $pkg) = @_; my ($id, $pkg) = @_;
my $stow_pkg = "../stow/$id-$pkg"; my $stow_pkg = "../stow/$id-$pkg";
make_path($stow_pkg); make_path ($stow_pkg);
make_file("$stow_pkg/$id-file-$pkg"); make_file("$stow_pkg/$id-file-$pkg");
# create a shallow hierarchy specific to this package and stow # create a shallow hierarchy specific to this package and stow
# via folding # via folding
make_path("$stow_pkg/$id-$pkg-only-folded"); make_path ("$stow_pkg/$id-$pkg-only-folded");
make_file("$stow_pkg/$id-$pkg-only-folded/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-folded/file-$pkg");
make_link("$id-$pkg-only-folded", "$stow_pkg/$id-$pkg-only-folded"); make_link("$id-$pkg-only-folded", "$stow_pkg/$id-$pkg-only-folded");
# create a deeper hierarchy specific to this package and stow # create a deeper hierarchy specific to this package and stow
# via folding # via folding
make_path("$stow_pkg/$id-$pkg-only-folded2/subdir"); make_path ("$stow_pkg/$id-$pkg-only-folded2/subdir");
make_file("$stow_pkg/$id-$pkg-only-folded2/subdir/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-folded2/subdir/file-$pkg");
make_link("$id-$pkg-only-folded2", make_link("$id-$pkg-only-folded2",
"$stow_pkg/$id-$pkg-only-folded2"); "$stow_pkg/$id-$pkg-only-folded2");
# create a shallow hierarchy specific to this package and stow # create a shallow hierarchy specific to this package and stow
# without folding # without folding
make_path("$stow_pkg/$id-$pkg-only-unfolded"); make_path ("$stow_pkg/$id-$pkg-only-unfolded");
make_file("$stow_pkg/$id-$pkg-only-unfolded/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-unfolded/file-$pkg");
make_path("$id-$pkg-only-unfolded"); make_path ("$id-$pkg-only-unfolded");
make_link("$id-$pkg-only-unfolded/file-$pkg", make_link("$id-$pkg-only-unfolded/file-$pkg",
"../$stow_pkg/$id-$pkg-only-unfolded/file-$pkg"); "../$stow_pkg/$id-$pkg-only-unfolded/file-$pkg");
# create a deeper hierarchy specific to this package and stow # create a deeper hierarchy specific to this package and stow
# without folding # without folding
make_path("$stow_pkg/$id-$pkg-only-unfolded2/subdir"); make_path ("$stow_pkg/$id-$pkg-only-unfolded2/subdir");
make_file("$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg"); make_file("$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg");
make_path("$id-$pkg-only-unfolded2/subdir"); make_path ("$id-$pkg-only-unfolded2/subdir");
make_link("$id-$pkg-only-unfolded2/subdir/file-$pkg", make_link("$id-$pkg-only-unfolded2/subdir/file-$pkg",
"../../$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg"); "../../$stow_pkg/$id-$pkg-only-unfolded2/subdir/file-$pkg");
# create a shallow shared hierarchy which this package uses, and stow # create a shallow shared hierarchy which this package uses, and stow
# its contents without folding # its contents without folding
make_path("$stow_pkg/$id-shared"); make_path ("$stow_pkg/$id-shared");
make_file("$stow_pkg/$id-shared/file-$pkg"); make_file("$stow_pkg/$id-shared/file-$pkg");
make_path("$id-shared"); make_path ("$id-shared");
make_link("$id-shared/file-$pkg", make_link("$id-shared/file-$pkg",
"../$stow_pkg/$id-shared/file-$pkg"); "../$stow_pkg/$id-shared/file-$pkg");
# create a deeper shared hierarchy which this package uses, and stow # create a deeper shared hierarchy which this package uses, and stow
# its contents without folding # its contents without folding
make_path("$stow_pkg/$id-shared2/subdir"); make_path ("$stow_pkg/$id-shared2/subdir");
make_file("$stow_pkg/$id-shared2/file-$pkg"); make_file("$stow_pkg/$id-shared2/file-$pkg");
make_file("$stow_pkg/$id-shared2/subdir/file-$pkg"); make_file("$stow_pkg/$id-shared2/subdir/file-$pkg");
make_path("$id-shared2/subdir"); make_path ("$id-shared2/subdir");
make_link("$id-shared2/file-$pkg", make_link("$id-shared2/file-$pkg",
"../$stow_pkg/$id-shared2/file-$pkg"); "../$stow_pkg/$id-shared2/file-$pkg");
make_link("$id-shared2/subdir/file-$pkg", make_link("$id-shared2/subdir/file-$pkg",
"../../$stow_pkg/$id-shared2/subdir/file-$pkg"); "../../$stow_pkg/$id-shared2/subdir/file-$pkg");
} }
subtest("unstow a tree with no-folding enabled - no refolding should take place", sub { foreach my $pkg (qw{a b}) {
cd("$TEST_DIR/target"); create_and_stow_pkg('no-folding', $pkg);
plan tests => 15; }
foreach my $pkg (qw{a b}) { $stow = new_Stow('no-folding' => 1);
create_and_stow_pkg('no-folding', $pkg); $stow->plan_unstow('no-folding-b');
} is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding');
use Data::Dumper;
#warn Dumper($stow->get_tasks);
my $stow = new_Stow('no-folding' => 1); $stow->process_tasks();
$stow->plan_unstow('no-folding-b');
is_deeply([ $stow->get_conflicts ], [] => 'no conflicts with --no-folding');
$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');
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
# TODO #
# }); # Test cleaning up subdirs with --paranoid option

403
t/unstow_orig.t Executable file
View file

@ -0,0 +1,403 @@
#!/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 => 37;
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;
#
# unstow a simple tree minimally
#
$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();
ok(
$stow->get_conflict_count == 0 &&
-f '../stow/pkg1/bin1/file1' && ! -e 'bin1'
=> 'unstow a simple tree'
);
#
# unstow a simple tree from an existing directory
#
$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();
ok(
$stow->get_conflict_count == 0 &&
-f '../stow/pkg2/lib2/file2' && -d 'lib2'
=> 'unstow simple tree from a pre-existing directory'
);
#
# fold tree after unstowing
#
$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();
ok(
$stow->get_conflict_count == 0 &&
-l 'bin3' &&
readlink('bin3') eq '../stow/pkg3a/bin3'
=> 'fold tree after unstowing'
);
#
# existing link is owned by stow but is invalid so it gets removed anyway
#
$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();
ok(
$stow->get_conflict_count == 0 &&
! -e 'bin4/file4'
=> q(remove invalid link owned by stow)
);
#
# Existing link is not owned by stow
#
$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' && readlink('bin5') eq '../not-stow'
=> q(existing link not owned by stow)
);
#
# Target already exists, is owned by stow, but points to a different package
#
$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');
ok(
$stow->get_conflict_count == 0 &&
-l 'bin6/file6' &&
readlink('bin6/file6') eq '../../stow/pkg6a/bin6/file6'
=> q(ignore existing link that points to a different package)
);
#
# Don't unlink anything under the stow directory
#
make_path('stow'); # make out stow dir a subdir of target
$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');
capture_stderr();
$stow->plan_unstow('pkg7b');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg7b');
ok(
$stow->get_conflict_count == 0 &&
-l 'stow/pkg7b' &&
readlink('stow/pkg7b') eq '../stow/pkg7a/stow/pkg7b'
=> q(don't unlink any nodes under the stow directory)
);
like($stderr,
qr/WARNING: skipping target which was current stow directory stow/
=> "warn when unstowing from ourself");
uncapture_stderr();
#
# Don't unlink any nodes under another stow directory
#
$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');
capture_stderr();
$stow->plan_unstow('pkg8a');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg8a');
ok(
$stow->get_conflict_count == 0 &&
-l 'stow2/pkg8b' &&
readlink('stow2/pkg8b') eq '../stow/pkg8a/stow2/pkg8b'
=> q(don't unlink any nodes under another stow directory)
);
like($stderr,
qr/WARNING: skipping target which was current stow directory stow/
=> "warn when skipping unstowing");
uncapture_stderr();
#
# overriding already stowed documentation
#
# This will be used by this and subsequent tests
sub check_protected_dirs_skipped {
for my $dir (qw{stow stow2}) {
like($stderr,
qr/WARNING: skipping protected directory $dir/
=> "warn when skipping protected directory $dir");
}
uncapture_stderr();
}
$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');
capture_stderr();
$stow->plan_unstow('pkg9b');
$stow->process_tasks();
ok(
$stow->get_conflict_count == 0 &&
!-l 'man9/man1/file9.1'
=> 'overriding existing documentation files'
);
check_protected_dirs_skipped();
#
# deferring to already stowed documentation
#
$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');
capture_stderr();
$stow->plan_unstow('pkg10c');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg10c');
ok(
$stow->get_conflict_count == 0 &&
readlink('man10/man1/file10a.1') eq '../../../stow/pkg10a/man10/man1/file10a.1'
=> 'defer to existing documentation files'
);
check_protected_dirs_skipped();
#
# Ignore temp files
#
$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');
capture_stderr();
$stow->plan_unstow('pkg12');
$stow->process_tasks();
ok(
$stow->get_conflict_count == 0 &&
!-e 'man12/man1/file12.1'
=> 'ignore temp files'
);
check_protected_dirs_skipped();
#
# Unstow an already unstowed package
#
$stow = new_compat_Stow();
capture_stderr();
$stow->plan_unstow('pkg12');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12');
ok(
$stow->get_conflict_count == 0
=> 'unstow already unstowed package pkg12'
);
check_protected_dirs_skipped();
#
# Unstow a never stowed package
#
eval { remove_dir("$TEST_DIR/target"); };
mkdir("$TEST_DIR/target");
$stow = new_compat_Stow();
capture_stderr();
$stow->plan_unstow('pkg12');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 which was never stowed');
ok(
$stow->get_conflict_count == 0
=> 'unstow never stowed package pkg12'
);
check_protected_dirs_skipped();
#
# Unstowing when target contains a real file shouldn't be an issue.
#
make_file('man12/man1/file12.1');
$stow = new_compat_Stow();
capture_stderr();
$stow->plan_unstow('pkg12');
is($stow->get_tasks, 0, 'no tasks to process when unstowing pkg12 for third time');
%conflicts = $stow->get_conflicts;
ok(
$stow->get_conflict_count == 1 &&
$conflicts{unstow}{pkg12}[0]
=~ m!existing target is neither a link nor a directory: man12/man1/file12\.1!
=> 'unstow pkg12 for third time'
);
check_protected_dirs_skipped();
#
# unstow a simple tree minimally when cwd isn't target
#
cd('../..');
$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();
ok(
$stow->get_conflict_count == 0 &&
-f "$TEST_DIR/stow/pkg13/bin13/file13" && ! -e "$TEST_DIR/target/bin13"
=> 'unstow a simple tree'
);
#
# unstow a simple tree minimally with absolute stow dir when cwd isn't
# target
#
$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();
ok(
$stow->get_conflict_count == 0 &&
-f "$TEST_DIR/stow/pkg14/bin14/file14" && ! -e "$TEST_DIR/target/bin14"
=> 'unstow a simple tree with absolute stow dir'
);
#
# unstow a simple tree minimally with absolute stow AND target dirs
# when cwd isn't target
#
$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();
ok(
$stow->get_conflict_count == 0 &&
-f "$TEST_DIR/stow/pkg15/bin15/file15" && ! -e "$TEST_DIR/target/bin15"
=> 'unstow a simple tree with absolute stow and target dirs'
);
# Todo
#
# Test cleaning up subdirs with --paranoid option