00dani/stow
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Add support for ignore lists.

Browse source
This commit is contained in:
Adam Spiers 2011-11-23 23:45:48 +00:00
parent 7777e181a8
commit ea82ef5b8b
18 changed files with 881 additions and 167 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
AUTHORS
View file

@ -34,7 +34,7 @@ version 2 and created the texi2man script.
Adam Spiers <stow@adamspiers.org> refactored the backend code into new
Stow.pm and Stow/Util.pm modules providing an OO interface, tightened
up the test suite, added support for `make test' and distribution via
CPAN, and cleaned up numerous other minor issues.
up the test suite, added support for ignore lists, `make test', and
distribution via CPAN, and cleaned up numerous other minor issues.
Stow is currently maintained by Troy Mill.

9
Makefile.am
View file

@ -10,6 +10,8 @@ dist_pm_DATA = lib/Stow.pm
pmstowdir = $(pmdir)/Stow
dist_pmstow_DATA = lib/Stow/Util.pm
DEFAULT_IGNORE_LIST = default-ignore-list
TESTS_ENVIRONMENT=$(PERL) -I $(top_srcdir)
TESTS = \
t/cleanup_invalid_links.t \
@ -17,7 +19,7 @@ TESTS = \
t/examples.t \
t/find_stowed_path.t \
t/foldable.t \
t/join_paths.t \
t/ignore.t \
t/parent.t \
t/stow_contents.t \
t/stow.t \
@ -31,6 +33,7 @@ EXTRA_DIST = \
bin/stow.in bin/chkstow.in lib/Stow.pm.in \
$(TESTS) t/testutil.pm \
$(TEXINFO_TEX) \
default-ignore-list \
$(CPAN_FILES)
CLEANFILES = $(bin_SCRIPTS) $(dist_pm_DATA)
@ -50,8 +53,8 @@ bin/chkstow: bin/chkstow.in Makefile
$(edit) < $< > $@
chmod +x $@
lib/Stow.pm: lib/Stow.pm.in Makefile
$(edit) < $< > $@
lib/Stow.pm: lib/Stow.pm.in Makefile $(DEFAULT_IGNORE_LIST)
( $(edit) < $<; cat $(DEFAULT_IGNORE_LIST) ) > $@
# The rules for manual.html and manual.texi are only used by
# the developer

21
TODO
View file

@ -1,24 +1,5 @@
* Prevent folding of directories which contain ignored files
* Honour .no-stow-folding and --no-folding
* Support ignore lists in files
*** Implement.
*** Add documentation about ignore lists.
***** Justification for having stow ignore lists independently of VCS ignore lists
******* If a file is in the VCS ignore list for its containing repo
********* generated during development
probably shouldn't be stowed
********* generated during compilation / install
*********** could be an intermediary file
again, probably shouldn't be stowed
*********** but most likely a file to install
e.g. compiled binary/library/docs - should be stowed
******* If a file is not in the VCS ignore list for its containing repo
********* it's probably tracked by the VCS - part of the repo
********* could intended for end use
*********** e.g. script/config file requiring no modifications, docs
should be stowed
********* or intended only to be used during compilation / build phase
shouldn't be stowed
*** (Eventually) rsync-like include/exclude lists instead of ignore lists
* Add semi-automatic conflict resolution
*** STOW_RESOLVE_CONFLICTS="non_stow_symlinks=t stow_symlinks=r"
*** Add documentation about conflict resolution

18
default-ignore-list Normal file
View file

@ -0,0 +1,18 @@
# Comments and blank lines are allowed.
RCS
.+,v
CVS
\.\#.+ # CVS conflict files / emacs lock files
\.cvsignore
\.svn
_darcs
\.hg
\.git
\.gitignore
.+~ # emacs backup files
\#.*\# # emacs autosave files

219
doc/stow.texi
View file

@ -82,6 +82,7 @@ approved by the Free Software Foundation.
@c ==========================================================================
@node Top, Introduction, (dir), (dir)
@top
@ifinfo
This manual describes GNU Stow @value{VERSION}, a program for managing
@ -89,35 +90,44 @@ the installation of software packages.
@end ifinfo
@menu
* Introduction:: Description of Stow.
* Terminology:: Terms used by this manual.
* Invoking Stow:: Option summary.
* Installing Packages:: Using Stow to install.
* Deleting Packages:: Using Stow to uninstall.
* Conflicts:: When Stow can't stow.
* Deferred Operation:: Using two passes to stow.
* Mixing Operations:: Multiple actions per invocation.
* Multiple Stow Directories:: Further segregating software.
* Target Maintenance:: Cleaning up mistakes.
* Resource Files:: Setting default command line options.
* Introduction:: Description of Stow.
* Terminology:: Terms used by this manual.
* Invoking Stow:: Option summary.
* Ignore Lists:: Controlling what gets stowed.
* Installing Packages:: Using Stow to install.
* Deleting Packages:: Using Stow to uninstall.
* Conflicts:: When Stow can't stow.
* Deferred Operation:: Using two passes to stow.
* Mixing Operations:: Multiple actions per invocation.
* Multiple Stow Directories:: Further segregating software.
* Target Maintenance:: Cleaning up mistakes.
* Resource Files:: Setting default command line options.
* Compile-time vs Install-time:: Faking out `make install'.
* Bootstrapping:: When stow and perl are not yet stowed.
* Reporting Bugs:: How, what, where, and when to report.
* Known Bugs:: Don't report any of these.
* GNU General Public License:: Copying terms.
* Index:: Index of concepts.
* Bootstrapping:: When stow and perl are not yet stowed.
* Reporting Bugs:: How, what, where, and when to report.
* Known Bugs:: Don't report any of these.
* GNU General Public License:: Copying terms.
* Index:: Index of concepts.
@detailmenu
--- The Detailed Node Listing ---
Compile-time and install-time
Ignore Lists
* GNU Emacs::
* Other FSF Software::
* Cygnus Software::
* Perl and Perl 5 Modules::
* Motivation For Ignore Lists::
* Types And Syntax Of Ignore Lists::
* Justification For Yet Another Set Of Ignore Files::
Compile-time vs Install-time
* GNU Emacs::
* Other FSF Software::
* Cygnus Software::
* Perl and Perl 5 Modules::
@end detailmenu
@end menu
@c ===========================================================================
@node Introduction, Terminology, Top, Top
@chapter Introduction
@ -229,7 +239,7 @@ computed starting from the symlink's own directory. Stow only
creates relative symlinks.
@c ===========================================================================
@node Invoking Stow, Installing Packages, Terminology, Top
@node Invoking Stow, Ignore Lists, Terminology, Top
@chapter Invoking Stow
The syntax of the @code{stow} command is:
@ -265,15 +275,19 @@ This (repeatable) option lets you suppress acting on files that match the
given perl regular expression. For example, using the options
@example
--ignore='~' --ignore='\.#.*'
--ignore='*.orig' --ignore='*.dist'
@end example
@noindent
will cause stow to ignore emacs and CVS backup files.
will cause stow to ignore files ending in @file{.orig} or @file{.dist}.
Note that the regular expression is anchored to the end of the filename,
because this is what you will want to do most of the time.
Also note that by default Stow automatically ignores a ``sensible''
built-in list of files and directories such as @file{CVS}, editor
backup files, and so on. @xref{Ignore Lists}, for more details.
@item --defer='<regex>'
This (repeatable) option avoids stowing a file matching the given
regular expression, if that file is already stowed by another package.
@ -407,9 +421,152 @@ operations will be performed if any conflicts are detected.
@ref{Resource Files} for a way to set default values for any of these
options.
@c ===========================================================================
@node Ignore Lists, Installing Packages, Invoking Stow, Top
@chapter Ignore Lists
@cindex ignore lists
@cindex ignoring files and directories
@menu
* Motivation For Ignore Lists::
* Types And Syntax Of Ignore Lists::
* Justification For Yet Another Set Of Ignore Files::
@end menu
@c ===========================================================================
@node Installing Packages, Deleting Packages, Invoking Stow, Top
@node Motivation For Ignore Lists, Types And Syntax Of Ignore Lists, Ignore Lists, Ignore Lists
@section Motivation For Ignore Lists
In many situations, there will exist files under the package
directories which it would be undesirable to stow into the target
directory. For example, files related version control such as
@file{.gitignore}, @file{CVS}, @file{*,v} (RCS files) should typically
not have symlinks from the target tree pointing to them. Also there
may be files or directories relating to the build of the package which
are not needed at run-time.
In these cases, it can be rather cumbersome to specify a
@samp{--ignore} parameter for each file or directory to be ignored.
This could be worked around by ensuring the existence of
@file{~/.stowrc} containing multiple @samp{--ignore} lines, or if a
different set of files/directories should be ignored depending on
which stow package is involved, a @file{.stowrc} file for each stow
package, but this would require the user to ensure that they were in
the correct directory before invoking stow, which would be tedious and
error-prone. Furthermore, since Stow shifts parameters from
@file{.stowrc} onto ARGV at run-time, it could clutter up the process
table with excessively long parameter lists, or even worse, exceed the
operating system's limit for process arguments.
@cindex ignore lists
Therefore in addition to @samp{--ignore} parameters, Stow provides a
way to specify lists of files and directories to ignore.
@c ===========================================================================
@node Types And Syntax Of Ignore Lists, Justification For Yet Another Set Of Ignore Files, Motivation For Ignore Lists, Ignore Lists
@section Types And Syntax Of Ignore Lists
If you put Perl regular expressions, one per line, in a
@file{.stow-local-ignore} file within any top level package directory,
in which case any file or directory within that package matching any
of these regular expressions will be ignored. In the absence of this
package-specific ignore list, Stow will instead use the contents of
@file{~/.stow-global-ignore}, if it exists. If neither the
package-local or global ignore list exist, Stow will use its own
built-in default ignore list, which serves as a useful example of the
format of these ignore list files:
@example
@verbatiminclude default-ignore-list
@end example
Stow first iterates through the chosen ignore list (built-in, global,
or package-local) as per above, stripping out comments (if you want to
include the @samp{#} symbol in a regular expression, escape it with a
blackslash) and blank lines, placing each regular expressions into one
of two sets depending on whether it contains the @samp{/} forward
slash symbol.
Then in order to determine whether a file or directory should be
ignored:
@enumerate
@item
Stow calculates its path relative to the top-level package directory,
prefixing that with @samp{/}. If any of the regular expressions
containing a @samp{/} @emph{exactly}@footnote{Exact matching means the
regular expression is anchored at the beginning and end, in contrast
to unanchored regular expressions which will match a substring.} match
a subpath@footnote{In this context, ``subpath'' means a contiguous
subset of path segments; e.g for the relative path
@file{one/two/three/four}, the following are examples of valid
subpaths: @file{one}, @file{two}, @file{two/three},
@file{two/three/four}.} of this relative path, then the file or
directory will be ignored.
@item
If none of the regular expressions containing a @samp{/} match in the
manner described above, Stow checks whether the
@emph{basename}@footnote{The ``basename'' is the name of the file or
directory itself, excluding any directory path prefix - as returned by
the @command{basename} command.} of the file or directory matches
@emph{exactly} against the remaining regular expressions which do not
contain a @samp{/}, and if so, ignores the file or directory.
@item
Otherwise, the file or directory is not ignored.
@end enumerate
For example, if a file @file{bazqux} is in the @file{foo/bar}
subdirectory of the package directory, Stow would use
@code{/foo/bar/bazqux} as the text for matching against regular
expressions which contain @samp{/}, and @code{bazqux} as the text for
matching against regular expressions which don't contain @samp{/}.
Then regular expressions @code{bazqux}, @code{baz.*}, @code{.*qux},
@code{bar/.*x}, and @code{^/foo/.*qux} would all match (causing the
file to be ignored), whereas @code{bar}, @code{baz}, and @code{qux}
would not (although @code{bar} would cause its parent directory to be
ignored and prevent Stow from recursing into that anyway, in which
case the file @file{bazqux} would not even be considered for
stowing).
As a special exception to the above algorithm, any
@file{.stow-local-ignore} present in the top-level package directory
is @emph{always} ignored, regardless of the contents of any ignore
list, because this file serves no purpose outside the stow directory.
@c ===========================================================================
@node Justification For Yet Another Set Of Ignore Files, , Types And Syntax Of Ignore Lists, Ignore Lists
@section Justification For Yet Another Set Of Ignore Files
The reader may note that this format is very similar to existing
ignore list file formats, such as those for @code{CVS}, @code{git},
@code{rsync} etc., and wonder if another set of ignore lists is
justified. However there are good reasons why Stow does not simply
check for the presence of say, @code{.cvsignore}, and use that if it
exists. Firstly, there is no guarantee that a stow package would
contain any version control meta-data, or permit introducing this if
it didn't already exist.
Secondly even if it did, version control system ignore lists generally
reflect @emph{build-time} ignores rather than @emph{install-time}, and
there may be some intermediate or temporary files on those ignore
lists generated during development or at build-time which it would be
inappropriate to stow, even though many files generated at build-time
(binaries, libraries, documentation etc.) certainly do need to be
stowed. Similarly, if a file is @emph{not} in the version control
system's ignore list, there is no way of knowing whether the file is
intended for end use, let alone whether the version control system is
tracking it or not.
Therefore it seems clear that ignore lists provided by version control
systems do not provide sufficient information for Stow to determine
which files and directories to stow, and so it makes sense for Stow to
support independent ignore lists.
@c ===========================================================================
@node Installing Packages, Deleting Packages, Ignore Lists, Top
@chapter Installing Packages
@cindex installation
@ -532,7 +689,7 @@ package.
@c ===========================================================================
@node Conflicts, Deferred Operation, Deleting Packages, Top
@section Conflicts
@chapter Conflicts
If, during installation, a file or symlink exists in the target tree and
has the same name as something Stow needs to create, and if the
@ -766,10 +923,10 @@ The details of stowing some specific packages are described in the
following sections.
@menu
* GNU Emacs::
* Other FSF Software::
* Cygnus Software::
* Perl and Perl 5 Modules::
* GNU Emacs::
* Other FSF Software::
* Cygnus Software::
* Perl and Perl 5 Modules::
@end menu
@c ---------------------------------------------------------------------------

405
lib/Stow.pm.in
View file

@ -45,6 +45,12 @@ use Stow::Util qw(set_debug_level debug error set_test_mode
our $ProgramName = 'stow';
our $VERSION = '@VERSION@';
our $LOCAL_IGNORE_FILE = '.stow-local-ignore';
our $GLOBAL_IGNORE_FILE = '.stow-global-ignore';
our @default_global_ignore_regexps =
__PACKAGE__->get_default_global_ignore_regexps();
# These are the default options for each Stow instance.
our %DEFAULT_OPTIONS = (
conflicts => 0,
@ -235,14 +241,16 @@ sub plan_unstow {
debug(2, "Planning unstow of package $package...");
if ($self->{'compat'}) {
$self->unstow_contents_orig(
join_paths($self->{stow_path}, $package), # path to package
'.', # target is current_dir
$self->{stow_path},
$package,
'.',
);
}
else {
$self->unstow_contents(
join_paths($self->{stow_path}, $package), # path to package
'.', # target is current_dir
$self->{stow_path},
$package,
'.',
);
}
debug(2, "Planning unstow of package $package... done");
@ -269,8 +277,9 @@ sub plan_stow {
}
debug(2, "Planning stow of package $package...");
$self->stow_contents(
join_paths($self->{stow_path}, $package), # path package
'.', # target is current dir
$self->{stow_path},
$package,
'.',
join_paths($self->{stow_path}, $package), # source from target
);
debug(2, "Planning stow of package $package... done");
@ -306,23 +315,29 @@ sub within_target_do {
#===== METHOD ===============================================================
# Name : stow_contents()
# Purpose : stow the contents of the given directory
# Parameters: $path => relative path to source dir from current directory
# : $target => relative path to symlink target from the current directory
# : $source => relative path to symlink source from the dir of target
# Parameters: $stow_path => relative path from current (i.e. target) directory
# : to the stow dir containing the package to be stowed
# : $package => the package whose contents are being stowed
# : $target => subpath relative to package and target directories
# : $source => relative path from the (sub)dir of target
# : to symlink source
# Returns : n/a
# Throws : a fatal error if directory cannot be read
# Comments : stow_node() and stow_contents() are mutually recursive
# Comments : stow_node() and stow_contents() are mutually recursive.
# : $source and $target are used for creating the symlink
# : $path is used for folding/unfolding trees as necessary
#============================================================================
sub stow_contents {
my $self = shift;
my ($path, $target, $source) = @_;
my ($stow_path, $package, $target, $source) = @_;
my $path = join_paths($stow_path, $package, $target);
return if $self->should_skip_target_which_is_stow_dir($target);
my $cwd = getcwd();
my $msg = "Stowing contents of $path (cwd=$cwd, stow dir=$self->{stow_path})";
my $msg = "Stowing contents of $path in package $package "
. "(cwd=$cwd, stow dir=$self->{stow_path})";
$msg =~ s!$ENV{HOME}/!~/!g;
debug(2, $msg);
debug(3, "--- $target => $source");
@ -341,10 +356,12 @@ sub stow_contents {
for my $node (@listing) {
next NODE if $node eq '.';
next NODE if $node eq '..';
next NODE if $self->ignore($node);
my $node_target = join_paths($target, $node);
next NODE if $self->ignore($stow_path, $package, $node_target);
$self->stow_node(
join_paths($path, $node), # path
join_paths($target, $node), # target
$stow_path,
$package,
$node_target, # target
join_paths($source, $node), # source
);
}
@ -353,8 +370,10 @@ sub stow_contents {
#===== METHOD ===============================================================
# Name : stow_node()
# Purpose : stow the given node
# Parameters: $path => relative path to source node from the current directory
# : $target => relative path to symlink target from the current directory
# Parameters: $stow_path => relative path from current (i.e. target) directory
# : to the stow dir containing the node to be stowed
# : $package => the package containing the node being stowed
# : $target => subpath relative to package and target directories
# : $source => relative path to symlink source from the dir of target
# Returns : n/a
# Throws : fatal exception if a conflict arises
@ -364,7 +383,9 @@ sub stow_contents {
#============================================================================
sub stow_node {
my $self = shift;
my ($path, $target, $source) = @_;
my ($stow_path, $package, $target, $source) = @_;
my $path = join_paths($stow_path, $package, $target);
debug(2, "Stowing from $path");
debug(3, "--- $target => $source");
@ -381,7 +402,6 @@ sub stow_node {
# Does the target already exist?
if ($self->is_a_link($target)) {
# Where is the link pointing?
my $existing_source = $self->read_a_link($target);
if (not $existing_source) {
@ -390,7 +410,8 @@ sub stow_node {
debug(3, "--- Evaluate existing link: $target => $existing_source");
# Does it point to a node under our stow directory?
my $existing_path = $self->find_stowed_path($target, $existing_source);
my ($existing_path, $existing_stow_path, $existing_package) =
$self->find_stowed_path($target, $existing_source);
if (not $existing_path) {
$self->conflict("existing target is not owned by stow: $target");
return; # XXX #
@ -416,11 +437,21 @@ sub stow_node {
# and the proposed new link points to a directory,
# then we can unfold (split open) the tree at that point
debug(3, "--- Unfolding $target");
debug(3, "--- Unfolding $target which was already owned by $existing_package");
$self->do_unlink($target);
$self->do_mkdir($target);
$self->stow_contents($existing_path, $target, join_paths('..', $existing_source));
$self->stow_contents($path, $target, join_paths('..', $source));
$self->stow_contents(
$existing_stow_path,
$existing_package,
$target,
join_paths('..', $existing_source),
);
$self->stow_contents(
$self->{stow_path},
$package,
$target,
join_paths('..', $source),
);
}
else {
$self->conflict(
@ -440,7 +471,12 @@ sub stow_node {
elsif ($self->is_a_node($target)) {
debug(3, "--- Evaluate existing node: $target");
if ($self->is_a_dir($target)) {
$self->stow_contents($path, $target, join_paths('..', $source));
$self->stow_contents(
$self->{stow_path},
$package,
$target,
join_paths('..', $source),
);
}
else {
$self->conflict(
@ -497,7 +533,9 @@ sub marked_stow_dir {
#===== METHOD ===============================================================
# Name : unstow_contents_orig()
# Purpose : unstow the contents of the given directory
# Parameters: $path => relative path to source dir from current directory
# Parameters: $stow_path => relative path from current (i.e. target) directory
# : to the stow dir containing the package to be unstowed
# : $package => the package whose contents are being unstowed
# : $target => relative path to symlink target from the current directory
# Returns : n/a
# Throws : a fatal error if directory cannot be read
@ -506,7 +544,9 @@ sub marked_stow_dir {
#============================================================================
sub unstow_contents_orig {
my $self = shift;
my ($path, $target) = @_;
my ($stow_path, $package, $target) = @_;
my $path = join_paths($stow_path, $package, $target);
return if $self->should_skip_target_which_is_stow_dir($target);
@ -530,18 +570,18 @@ sub unstow_contents_orig {
for my $node (@listing) {
next NODE if $node eq '.';
next NODE if $node eq '..';
next NODE if $self->ignore($node);
$self->unstow_node_orig(
join_paths($path, $node), # path
join_paths($target, $node), # target
);
my $node_target = join_paths($target, $node);
next NODE if $self->ignore($stow_path, $package, $node_target);
$self->unstow_node_orig($stow_path, $package, $node_target);
}
}
#===== METHOD ===============================================================
# Name : unstow_node_orig()
# Purpose : unstow the given node
# Parameters: $path => relative path to source node from the current directory
# Parameters: $stow_path => relative path from current (i.e. target) directory
# : to the stow dir containing the node to be stowed
# : $package => the package containing the node being stowed
# : $target => relative path to symlink target from the current directory
# Returns : n/a
# Throws : fatal error if a conflict arises
@ -549,7 +589,9 @@ sub unstow_contents_orig {
#============================================================================
sub unstow_node_orig {
my $self = shift;
my ($path, $target) = @_;
my ($stow_path, $package, $target) = @_;
my $path = join_paths($stow_path, $package, $target);
debug(2, "Unstowing $target (compat mode)");
debug(3, "--- source path is $path");
@ -565,7 +607,8 @@ sub unstow_node_orig {
}
# Does it point to a node under our stow directory?
my $existing_path = $self->find_stowed_path($target, $existing_source);
my ($existing_path, $existing_stow_path, $existing_package) =
$self->find_stowed_path($target, $existing_source);
if (not $existing_path) {
# We're traversing the target tree not the package tree,
# so we definitely expect to find stuff not owned by stow.
@ -591,7 +634,7 @@ sub unstow_node_orig {
}
}
elsif (-d $target) {
$self->unstow_contents_orig($path, $target);
$self->unstow_contents_orig($stow_path, $package, $target);
# This action may have made the parent directory foldable
if (my $parent = $self->foldable($target)) {
@ -612,7 +655,9 @@ sub unstow_node_orig {
#===== METHOD ===============================================================
# Name : unstow_contents()
# Purpose : unstow the contents of the given directory
# Parameters: $path => relative path to source dir from current directory
# Parameters: $stow_path => relative path from current (i.e. target) directory
# : to the stow dir containing the package to be unstowed
# : $package => the package whose contents are being unstowed
# : $target => relative path to symlink target from the current directory
# Returns : n/a
# Throws : a fatal error if directory cannot be read
@ -621,7 +666,9 @@ sub unstow_node_orig {
#============================================================================
sub unstow_contents {
my $self = shift;
my ($path, $target) = @_;
my ($stow_path, $package, $target) = @_;
my $path = join_paths($stow_path, $package, $target);
return if $self->should_skip_target_which_is_stow_dir($target);
@ -648,11 +695,9 @@ sub unstow_contents {
for my $node (@listing) {
next NODE if $node eq '.';
next NODE if $node eq '..';
next NODE if $self->ignore($node);
$self->unstow_node(
join_paths($path, $node), # path
join_paths($target, $node), # target
);
my $node_target = join_paths($target, $node);
next NODE if $self->ignore($stow_path, $package, $node_target);
$self->unstow_node($stow_path, $package, $node_target);
}
if (-d $target) {
$self->cleanup_invalid_links($target);
@ -662,7 +707,9 @@ sub unstow_contents {
#===== METHOD ===============================================================
# Name : unstow_node()
# Purpose : unstow the given node
# Parameters: $path => relative path to source node from the current directory
# Parameters: $stow_path => relative path from current (i.e. target) directory
# : to the stow dir containing the node to be stowed
# : $package => the package containing the node being unstowed
# : $target => relative path to symlink target from the current directory
# Returns : n/a
# Throws : fatal error if a conflict arises
@ -670,7 +717,9 @@ sub unstow_contents {
#============================================================================
sub unstow_node {
my $self = shift;
my ($path, $target) = @_;
my ($stow_path, $package, $target) = @_;
my $path = join_paths($stow_path, $package, $target);
debug(2, "Unstowing $path");
debug(3, "--- target is $target");
@ -686,12 +735,13 @@ sub unstow_node {
}
if ($existing_source =~ m{\A/}) {
warn "ignoring an absolute symlink: $target => $existing_source\n";
warn "Ignoring an absolute symlink: $target => $existing_source\n";
return; # XXX #
}
# Does it point to a node under our stow directory?
my $existing_path = $self->find_stowed_path($target, $existing_source);
my ($existing_path, $existing_stow_path, $existing_package) =
$self->find_stowed_path($target, $existing_source);
if (not $existing_path) {
$self->conflict(
qq{existing target is not owned by stow: $target => $existing_source}
@ -732,7 +782,7 @@ sub unstow_node {
elsif (-e $target) {
debug(3, "Evaluate existing node: $target");
if (-d $target) {
$self->unstow_contents($path, $target);
$self->unstow_contents($stow_path, $package, $target);
# This action may have made the parent directory foldable
if (my $parent = $self->foldable($target)) {
@ -752,16 +802,39 @@ sub unstow_node {
}
#===== METHOD ===============================================================
# Name : find_stowed_path()
# Name : path_owned_by_package()
# Purpose : determine if the given link points to a member of a
# : stowed package
# Parameters: $target => path to a symbolic link under current directory
# : $source => where that link points to
# Returns : relative path to stowed node (from the current directory)
# : or '' if link is not owned by stow
# Throws : fatal exception if link is unreadable
# Comments : allow for stow dir not being under target dir
# : we could put more logic under here for multiple stow dirs
# Returns : the package iff link is owned by stow, otherwise ''
# Throws : n/a
# Comments : lossy wrapper around find_stowed_path()
#============================================================================
sub path_owned_by_package {
my $self = shift;
my ($target, $source) = @_;
my ($path, $stow_path, $package) =
$self->find_stowed_path($target, $source);
return $package;
}
#===== METHOD ===============================================================
# Name : find_stowed_path()
# Purpose : determine if the given link points to a member of a
# : stowed package
# Parameters: $target => path to a symbolic link under current directory
# : $source => where that link points to (needed because link
# : might not exist yet due to two-phase approach,
# : so we can't just call readlink())
# Returns : ($path, $stow_path, $package) where $path and $stow_path are
# : relative from the current (i.e. target) directory
# : or ('', '', '') if link is not owned by stow
# Throws : n/a
# Comments : Needs
# : Allow for stow dir not being under target dir.
# : We could put more logic under here for multiple stow dirs.
#============================================================================
sub find_stowed_path {
my $self = shift;
@ -769,34 +842,48 @@ sub find_stowed_path {
# Evaluate softlink relative to its target
my $path = join_paths(parent($target), $source);
debug(4, " is path $path under $self->{stow_path} ?");
debug(4, " is path $path owned by stow?");
# Search for .stow files
# Search for .stow files - this allows us to detect links
# owned by stow directories other than the current one.
my $dir = '';
for my $part (split m{/+}, $path) {
my @path = split m{/+}, $path;
for my $i (0 .. $#path) {
my $part = $path[$i];
$dir = join_paths($dir, $part);
return $path if $self->marked_stow_dir($dir);
if ($self->marked_stow_dir($dir)) {
# FIXME - not sure if this can ever happen
internal_error("find_stowed_path() called directly on stow dir")
if $i == $#path;
debug(4, " yes - $dir was marked as a stow dir");
my $package = $path[$i + 1];
return ($path, $dir, $package);
}
}
# Compare with $self->{stow_path}
my @path = split m{/+}, $path;
# If no .stow file was found, we need to find out whether it's
# owned by the current stow directory, in which case $path will be
# a prefix of $self->{stow_path}.
my @stow_path = split m{/+}, $self->{stow_path};
# Strip off common prefixes until one is empty
while (@path && @stow_path) {
if ((shift @path) ne (shift @stow_path)) {
debug(4, " no - either $path not under $self->{stow_path} or vice-versa");
return '';
return ('', '', '');
}
}
if (@stow_path) { # @path must be empty
debug(4, " no - $path is not under $self->{stow_path}");
return '';
return ('', '', '');
}
debug(4, " yes - in " . join_paths(@path));
return $path;
my $package = shift @path;
debug(4, " yes - by $package in " . join_paths(@path));
return ($path, $self->{stow_path}, $package);
}
#===== METHOD ================================================================
@ -841,7 +928,7 @@ sub cleanup_invalid_links {
if (
not -e join_paths($dir, $source) and # bad link
$self->find_stowed_path($node_path, $source) # owned by stow
$self->path_owned_by_package($node_path, $source) # owned by stow
){
debug(3, "--- removing stale link: $node_path => " .
join_paths($dir, $source));
@ -910,7 +997,7 @@ sub foldable {
$parent =~ s{\A\.\./}{};
# If the resulting path is owned by stow, we can fold it
if ($self->find_stowed_path($target, $parent)) {
if ($self->path_owned_by_package($target, $parent)) {
debug(3, "--- $target is foldable");
return $parent;
}
@ -997,21 +1084,189 @@ sub get_tasks {
#===== METHOD ================================================================
# Name : ignore
# Purpose : determine if the given path matches a regex in our ignore list
# Parameters: $path
# Returns : Boolean
# Parameters: $stow_path => the stow directory containing the package
# : $package => the package containing the path
# : $target => the path to check against the ignore list
# : relative to its package directory
# Returns : true iff the path should be ignored
# Throws : no exceptions
# Comments : none
#=============================================================================
sub ignore {
my $self = shift;
my ($path) = @_;
my ($stow_path, $package, $target) = @_;
for my $suffix (@{$self->{'ignore'}}) {
return 1 if $path =~ m/$suffix/;
internal_error(__PACKAGE__ . "::ignore() called with empty target")
unless length $target;
for my $suffix (@{ $self->{'ignore'} }) {
if ($target =~ m/$suffix/) {
debug(4, " Ignoring path $target due to --ignore=$suffix");
return 1;
}
}
my $package_dir = join_paths($stow_path, $package);
my ($path_regexp, $segment_regexp) =
$self->get_ignore_regexps($package_dir);
debug(3, " Ignore list regexp for paths: " .
(defined $path_regexp ? "/$path_regexp/" : "none"));
debug(3, " Ignore list regexp for segments: " .
(defined $segment_regexp ? "/$segment_regexp/" : "none"));
if (defined $path_regexp and "/$target" =~ $path_regexp) {
debug(4, " Ignoring path /$target");
return 1;
}
(my $basename = $target) =~ s!.+/!!;
if (defined $segment_regexp and $basename =~ $segment_regexp) {
debug(4, " Ignoring path segment $basename");
return 1;
}
debug(5, " Not ignoring $target");
return 0;
}
sub get_ignore_regexps {
my $self = shift;
my ($dir) = @_;
# N.B. the local and global stow ignore files have to have different
# names so that:
# 1. the global one can be a symlink to within a stow
# package, managed by stow itself, and
# 2. the local ones can be ignored via hardcoded logic in
# GlobsToRegexp(), so that they always stay within their stow packages.
my $local_stow_ignore = join_paths($dir, $LOCAL_IGNORE_FILE);
my $global_stow_ignore = join_paths($ENV{HOME}, $GLOBAL_IGNORE_FILE);
for my $file ($local_stow_ignore, $global_stow_ignore) {
if (-e $file) {
debug(3, " Using ignore file: $file");
return $self->get_ignore_regexps_from_file($file);
}
else {
debug(4, " $file didn't exist");
}
}
debug(4, " Using built-in ignore list");
return @default_global_ignore_regexps;
}
my %ignore_file_regexps;
sub get_ignore_regexps_from_file {
my $self = shift;
my ($file) = @_;
if (exists $ignore_file_regexps{$file}) {
debug(4, " Using memoized regexps from $file");
return @{ $ignore_file_regexps{$file} };
}
if (! open(REGEXPS, $file)) {
debug(4, " Failed to open $file: $!");
return undef;
}
my @regexps = $self->get_ignore_regexps_from_fh(\*REGEXPS);
close(REGEXPS);
$ignore_file_regexps{$file} = [ @regexps ];
return @regexps;
}
=head2 invalidate_memoized_regexp($file)
For efficiency of performance, regular expressions are compiled from
each ignore list file the first time it is used by the Stow process,
and then memoized for future use. If you expect the contents of these
files to change during a single run, you will need to invalidate the
memoized value from this cache. This method allows you to do that.
=cut
sub invalidate_memoized_regexp {
my $self = shift;
my ($file) = @_;
if (exists $ignore_file_regexps{$file}) {
debug(4, " Invalidated memoized regexp for $file");
delete $ignore_file_regexps{$file};
}
else {
debug(2, " WARNING: no memoized regexp for $file to invalidate");
}
}
sub get_ignore_regexps_from_fh {
my $self = shift;
my ($fh) = @_;
my %regexps;
while (<$fh>) {
chomp;
s/^\s+//;
s/\s+$//;
next if /^#/ or length($_) == 0;
s/\s+#.+//; # strip comments to right of pattern
s/\\#/#/g;
$regexps{$_}++;
}
# Local ignore lists should *always* stay within the stow directory,
# because this is the only place stow looks for them.
$regexps{"^/\Q$LOCAL_IGNORE_FILE\E\$"}++;
return $self->compile_ignore_regexps(%regexps);
}
sub compile_ignore_regexps {
my $self = shift;
my (%regexps) = @_;
my @segment_regexps;
my @path_regexps;
for my $regexp (keys %regexps) {
if (index($regexp, '/') < 0) {
# No / found in regexp, so use it for matching against basename
push @segment_regexps, $regexp;
}
else {
# / found in regexp, so use it for matching against full path
push @path_regexps, $regexp;
}
}
my $segment_regexp = join '|', @segment_regexps;
my $path_regexp = join '|', @path_regexps;
$segment_regexp = @segment_regexps ?
$self->compile_regexp("^($segment_regexp)\$") : undef;
$path_regexp = @path_regexps ?
$self->compile_regexp("(^|/)($path_regexp)(/|\$)") : undef;
return ($path_regexp, $segment_regexp);
}
sub compile_regexp {
my $self = shift;
my ($regexp) = @_;
my $compiled = eval { qr/$regexp/ };
die "Failed to compile regexp: $@\n" if $@;
return $compiled;
}
sub get_default_global_ignore_regexps {
my $class = shift;
# Bootstrap issue - first time we stow, we will be stowing
# .cvsignore so it might not exist in ~ yet, or if it does, it could
# be an old version missing the entries we need. So we make sure
# they are there by hardcoding some crucial entries.
return $class->get_ignore_regexps_from_fh(\*DATA);
}
#===== METHOD ================================================================
# Name : defer
# Purpose : determine if the given path matches a regex in our defer list
@ -1024,7 +1279,7 @@ sub defer {
my $self = shift;
my ($path) = @_;
for my $prefix (@{$self->{'defer'}}) {
for my $prefix (@{ $self->{'defer'} }) {
return 1 if $path =~ m/$prefix/;
}
return 0;
@ -1042,7 +1297,7 @@ sub override {
my $self = shift;
my ($path) = @_;
for my $regex (@{$self->{'override'}}) {
for my $regex (@{ $self->{'override'} }) {
return 1 if $path =~ m/$regex/;
}
return 0;
@ -1675,3 +1930,9 @@ sub internal_error {
# cperl-indent-level: 4
# end:
# vim: ft=perl
#############################################################################
# Default global list of ignore regexps follows
# (automatically appended by the Makefile)
__DATA__

2
lib/Stow/Util.pm
View file

@ -128,7 +128,7 @@ sub join_paths {
my @paths = @_;
# weed out empty components and concatenate
my $result = join '/', grep {!/\A\z/} @paths;
my $result = join '/', grep {! /\A\z/} @paths;
# factor out back references and remove redundant /'s)
my @result = ();

2
t/chkstow.t
View file

@ -14,7 +14,7 @@ use Test::More tests => 7;
use Test::Output;
use English qw(-no_match_vars);
make_fresh_stow_and_target_dirs();
init_test_dirs();
cd('t/target');
# setup stow directory

2
t/cleanup_invalid_links.t
View file

@ -12,7 +12,7 @@ use English qw(-no_match_vars);
use testutil;
make_fresh_stow_and_target_dirs();
init_test_dirs();
cd('t/target');
my $stow;

2
t/examples.t
View file

@ -12,7 +12,7 @@ use testutil;
use Test::More tests => 10;
use English qw(-no_match_vars);
make_fresh_stow_and_target_dirs();
init_test_dirs();
cd('t/target');
my $stow;

38
t/find_stowed_path.t
View file

@ -11,21 +11,21 @@ use testutil;
use Test::More tests => 6;
make_fresh_stow_and_target_dirs();
init_test_dirs();
my $stow = new_Stow(dir => 't/stow');
is(
$stow->find_stowed_path('t/target/a/b/c', '../../../stow/a/b/c'),
't/stow/a/b/c'
is_deeply(
[ $stow->find_stowed_path('t/target/a/b/c', '../../../stow/a/b/c') ],
[ 't/stow/a/b/c', 't/stow', 'a' ]
=> 'from root'
);
cd('t/target');
$stow->set_stow_dir('../stow');
is(
$stow->find_stowed_path('a/b/c','../../../stow/a/b/c'),
'../stow/a/b/c'
is_deeply(
[ $stow->find_stowed_path('a/b/c','../../../stow/a/b/c') ],
[ '../stow/a/b/c', '../stow', 'a' ]
=> 'from target directory'
);
@ -33,31 +33,31 @@ make_dir('stow');
cd('../..');
$stow->set_stow_dir('t/target/stow');
is(
$stow->find_stowed_path('t/target/a/b/c', '../../stow/a/b/c'),
't/target/stow/a/b/c'
is_deeply(
[ $stow->find_stowed_path('t/target/a/b/c', '../../stow/a/b/c') ],
[ 't/target/stow/a/b/c', 't/target/stow', 'a' ]
=> 'stow is subdir of target directory'
);
is(
$stow->find_stowed_path('t/target/a/b/c','../../empty'),
''
is_deeply(
[ $stow->find_stowed_path('t/target/a/b/c','../../empty') ],
[ '', '', '' ]
=> 'target is not stowed'
);
make_dir('t/target/stow2');
make_file('t/target/stow2/.stow');
is(
$stow->find_stowed_path('t/target/a/b/c','../../stow2/a/b/c'),
't/target/stow2/a/b/c'
is_deeply(
[ $stow->find_stowed_path('t/target/a/b/c','../../stow2/a/b/c') ],
[ 't/target/stow2/a/b/c', 't/target/stow2', 'a' ]
=> q(detect alternate stow directory)
);
# Possible corner case with rogue symlink pointing to ancestor of
# stow dir.
is(
$stow->find_stowed_path('t/target/a/b/c','../../..'),
''
is_deeply(
[ $stow->find_stowed_path('t/target/a/b/c','../../..') ],
[ '', '', '' ]
=> q(corner case - link points to ancestor of stow dir)
);

2
t/foldable.t
View file

@ -12,7 +12,7 @@ use testutil;
use Test::More tests => 4;
use English qw(-no_match_vars);
make_fresh_stow_and_target_dirs();
init_test_dirs();
cd('t/target');
my $stow = new_Stow(dir => '../stow');

291
t/ignore.t Executable file
View file

@ -0,0 +1,291 @@
#!/usr/local/bin/perl
#
# Testing ignore lists.
#
use strict;
use warnings;
use File::Temp qw(tempdir);
use Test::More tests => 286;
use testutil;
use Stow::Util qw(join_paths);
init_test_dirs();
cd('t/target');
my $stow = new_Stow();
sub test_ignores {
my ($stow_path, $package, $context, @tests) = @_;
$context ||= '';
while (@tests) {
my $path = shift @tests;
my $should_ignore = shift @tests;
my $not = $should_ignore ? '' : ' not';
my $was_ignored = $stow->ignore($stow_path, $package, $path);
is(
$was_ignored, $should_ignore,
"Should$not ignore $path $context"
);
}
}
sub test_local_ignore_list_always_ignored_at_top_level {
my ($stow_path, $package, $context) = @_;
test_ignores(
$stow_path, $package, $context,
$Stow::LOCAL_IGNORE_FILE => 1,
"subdir/" . $Stow::LOCAL_IGNORE_FILE => 0,
);
}
sub test_built_in_list {
my ($stow_path, $package, $context, $expect_ignores) = @_;
for my $ignored ('CVS', '.cvsignore', '#autosave#') {
for my $path ($ignored, "foo/bar/$ignored") {
my $suffix = "$path.suffix";
(my $prefix = $path) =~ s!([^/]+)$!prefix.$1!;
test_ignores(
$stow_path, $package, $context,
$path => $expect_ignores,
$prefix => 0,
$suffix => 0,
);
}
}
# The pattern catching lock files allows suffixes but not prefixes
for my $ignored ('.#lock-file') {
for my $path ($ignored, "foo/bar/$ignored") {
my $suffix = "$path.suffix";
(my $prefix = $path) =~ s!([^/]+)$!prefix.$1!;
test_ignores(
$stow_path, $package, $context,
$path => $expect_ignores,
$prefix => 0,
$suffix => $expect_ignores,
);
}
}
}
sub test_user_global_list {
my ($stow_path, $package, $context, $expect_ignores) = @_;
for my $path ('', 'foo/bar/') {
test_ignores(
$stow_path, $package, $context,
$path . 'exact' => $expect_ignores,
$path . '0exact' => 0,
$path . 'exact1' => 0,
$path . '0exact1' => 0,
$path . 'substring' => 0,
$path . '0substring' => 0,
$path . 'substring1' => 0,
$path . '0substring1' => $expect_ignores,
);
}
}
sub setup_user_global_list {
# Now test with global ignore list in home directory
$ENV{HOME} = tempdir();
make_file(join_paths($ENV{HOME}, $Stow::GLOBAL_IGNORE_FILE), <<EOF);
exact
.+substring.+ # here's a comment
.+\.extension
myprefix.+ #hi mum
EOF
}
sub setup_package_local_list {
my ($stow_path, $package, $list) = @_;
my $package_path = join_paths($stow_path, $package);
make_dir($package_path);
my $local_ignore = join_paths($package_path, $Stow::LOCAL_IGNORE_FILE);
make_file($local_ignore, $list);
$stow->invalidate_memoized_regexp($local_ignore);
return $local_ignore;
}
sub main {
my $stow_path = '../stow';
my $package;
my $context;
# Test built-in list first. init_test_dirs() already set
# $ENV{HOME} to ensure that we're not using the user's global
# ignore list.
$package = 'non-existent-package';
$context = "when using built-in list";
test_local_ignore_list_always_ignored_at_top_level($stow_path, $package, $context);
test_built_in_list($stow_path, $package, $context, 1);
# Test ~/.stow-global-ignore
setup_user_global_list();
$context = "when using ~/$Stow::GLOBAL_IGNORE_FILE";
test_local_ignore_list_always_ignored_at_top_level($stow_path, $package, $context);
test_built_in_list($stow_path, $package, $context, 0);
test_user_global_list($stow_path, $package, $context, 1);
# Test empty package-local .stow-local-ignore
$package = 'ignorepkg';
my $local_ignore = setup_package_local_list($stow_path, $package, "");
$context = "when using empty $local_ignore";
test_local_ignore_list_always_ignored_at_top_level($stow_path, $package, $context);
test_built_in_list($stow_path, $package, $context, 0);
test_user_global_list($stow_path, $package, $context, 0);
test_ignores(
$stow_path, $package, $context,
'random' => 0,
'foo2/bar' => 0,
'foo2/bars' => 0,
'foo2/bar/random' => 0,
'foo2/bazqux' => 0,
'xfoo2/bazqux' => 0,
);
# Test package-local .stow-local-ignore with only path segment regexps
$local_ignore = setup_package_local_list($stow_path, $package, <<EOF);
random
EOF
$context = "when using $local_ignore with only path segment regexps";
test_local_ignore_list_always_ignored_at_top_level($stow_path, $package, $context);
test_built_in_list($stow_path, $package, $context, 0);
test_user_global_list($stow_path, $package, $context, 0);
test_ignores(
$stow_path, $package, $context,
'random' => 1,
'foo2/bar' => 0,
'foo2/bars' => 0,
'foo2/bar/random' => 1,
'foo2/bazqux' => 0,
'xfoo2/bazqux' => 0,
);
# Test package-local .stow-local-ignore with only full path regexps
$local_ignore = setup_package_local_list($stow_path, $package, <<EOF);
foo2/bar
EOF
$context = "when using $local_ignore with only full path regexps";
test_local_ignore_list_always_ignored_at_top_level($stow_path, $package, $context);
test_built_in_list($stow_path, $package, $context, 0);
test_user_global_list($stow_path, $package, $context, 0);
test_ignores(
$stow_path, $package, $context,
'random' => 0,
'foo2/bar' => 1,
'foo2/bars' => 0,
'foo2/bar/random' => 1,
'foo2/bazqux' => 0,
'xfoo2/bazqux' => 0,
);
# Test package-local .stow-local-ignore with a mixture of regexps
$local_ignore = setup_package_local_list($stow_path, $package, <<EOF);
foo2/bar
random
foo2/baz.+
EOF
$context = "when using $local_ignore with mixture of regexps";
test_local_ignore_list_always_ignored_at_top_level($stow_path, $package, $context);
test_built_in_list($stow_path, $package, $context, 0);
test_user_global_list($stow_path, $package, $context, 0);
test_ignores(
$stow_path, $package, $context,
'random' => 1,
'foo2/bar' => 1,
'foo2/bars' => 0,
'foo2/bar/random' => 1,
'foo2/bazqux' => 1,
'xfoo2/bazqux' => 0,
);
test_examples_in_manual($stow_path);
test_invalid_regexp($stow_path, "Invalid segment regexp in list", <<EOF);
this one's ok
this one isn't|*!
but this one is
EOF
test_invalid_regexp($stow_path, "Invalid full path regexp in list", <<EOF);
this one's ok
this/one isn't|*!
but this one is
EOF
test_ignore_via_stow($stow_path);
}
sub test_examples_in_manual {
my ($stow_path) = @_;
my $package = 'ignorepkg';
my $context = "(example from manual)";
for my $re ('bazqux', 'baz.*', '.*qux', 'bar/.*x', '^/foo/.*qux') {
my $local_ignore = setup_package_local_list($stow_path, $package, "$re\n");
test_ignores(
$stow_path, $package, $context,
"foo/bar/bazqux" => 1,
);
}
for my $re ('bar', 'baz', 'qux') {
my $local_ignore = setup_package_local_list($stow_path, $package, "$re\n");
test_ignores(
$stow_path, $package, $context,
"foo/bar/bazqux" => 0,
);
}
}
sub test_invalid_regexp {
my ($stow_path, $context, $list) = @_;
my $package = 'ignorepkg';
my $local_ignore = setup_package_local_list($stow_path, $package, $list);
eval {
test_ignores(
$stow_path, $package, $context,
"foo/bar/bazqux" => 1,
);
};
like($@, qr/^Failed to compile regexp: Quantifier follows nothing in regex;/,
$context);
}
sub test_ignore_via_stow {
my ($stow_path) = @_;
my $package = 'pkg1';
make_dir("$stow_path/$package/foo/bar");
make_file("$stow_path/$package/foo/bar/baz");
setup_package_local_list($stow_path, $package, 'foo');
$stow->plan_stow($package);
is($stow->get_tasks(), 0, 'top dir ignored');
is($stow->get_conflicts(), 0, 'top dir ignored, no conflicts');
make_dir("foo");
for my $ignore ('bar', 'foo/bar', '/foo/bar', '^/foo/bar', '^/fo.+ar') {
setup_package_local_list($stow_path, $package, $ignore);
$stow->plan_stow($package);
is($stow->get_tasks(), 0, "bar ignored via $ignore");
is($stow->get_conflicts(), 0, 'bar ignored, no conflicts');
}
make_file("$stow_path/$package/foo/qux");
$stow->plan_stow($package);
$stow->process_tasks();
is($stow->get_conflicts(), 0, 'no conflicts stowing qux');
ok(! -e "foo/bar", "bar ignore prevented stow");
ok(-l "foo/qux", "qux not ignored and stowed");
is(readlink("foo/qux"), "../$stow_path/$package/foo/qux", "qux stowed correctly");
}
main();

2
t/stow.t
View file

@ -13,7 +13,7 @@ use testutil;
require 'stow';
make_fresh_stow_and_target_dirs();
init_test_dirs();
local @ARGV = (
'-v',

2
t/stow_contents.t
View file

@ -14,7 +14,7 @@ use English qw(-no_match_vars);
use Stow::Util qw(canon_path);
use testutil;
make_fresh_stow_and_target_dirs();
init_test_dirs();
cd('t/target');
my $stow;

25
t/testutil.pm
View file

@ -10,14 +10,17 @@ use warnings;
use Stow;
use Stow::Util qw(parent);
sub make_fresh_stow_and_target_dirs {
sub init_test_dirs {
die "t/ didn't exist; are you running the tests from the root of the tree?\n"
unless -d 't';
for my $dir ('t/target', 't/stow') {
eval { remove_dir($dir); };
-d $dir and remove_dir($dir);
make_dir($dir);
}
# Don't let user's ~/.stow-global-ignore affect test results
$ENV{HOME} = '/tmp/fake/home';
}
sub new_Stow {
@ -90,22 +93,22 @@ sub make_dir {
# Name : create_file()
# Purpose : create an empty file
# Parameters: $path => proposed path to the file
# : $contents => (optional) contents to write to file
# Returns : n/a
# Throws : fatal error if the file could not be created
# Comments : detects clash with an existing non-file
#============================================================================
sub make_file {
my ($path) =@_;
my ($path, $contents) =@_;
if (not -e $path) {
open my $FILE ,'>', $path
or die "could not create file: $path ($!)\n";
close $FILE;
}
elsif (not -f $path) {
if (-e $path and ! -f $path) {
die "a non-file already exists at $path\n";
}
return;
open my $FILE ,'>', $path
or die "could not create file: $path ($!)\n";
print $FILE $contents if defined $contents;
close $FILE;
}
#===== SUBROUTINE ===========================================================
@ -168,7 +171,7 @@ sub remove_dir {
next NODE if $node eq '..';
my $path = "$dir/$node";
if (-l $path or -z $path) {
if (-l $path or -z $path or $node eq $Stow::LOCAL_IGNORE_FILE) {
unlink $path or die "cannot unlink $path ($!)\n";
}
elsif (-d "$path") {

2
t/unstow_contents.t
View file

@ -14,7 +14,7 @@ use English qw(-no_match_vars);
use testutil;
use Stow::Util qw(canon_path);
make_fresh_stow_and_target_dirs();
init_test_dirs();
cd('t/target');
# Note that each of the following tests use a distinct set of files

2
t/unstow_contents_orig.t
View file

@ -14,7 +14,7 @@ use English qw(-no_match_vars);
use testutil;
use Stow::Util qw(canon_path);
make_fresh_stow_and_target_dirs();
init_test_dirs();
cd('t/target');
# Note that each of the following tests use a distinct set of files