diff --git a/AUTHORS b/AUTHORS index b2ca1ed..5694873 100644 --- a/AUTHORS +++ b/AUTHORS @@ -34,7 +34,7 @@ version 2 and created the texi2man script. Adam Spiers 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. diff --git a/Makefile.am b/Makefile.am index 07e8a69..40dcba3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 diff --git a/TODO b/TODO index 92ca05b..01d6fda 100644 --- a/TODO +++ b/TODO @@ -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 diff --git a/default-ignore-list b/default-ignore-list new file mode 100644 index 0000000..351480f --- /dev/null +++ b/default-ignore-list @@ -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 diff --git a/doc/stow.texi b/doc/stow.texi index 79cc3d3..06a6bd4 100644 --- a/doc/stow.texi +++ b/doc/stow.texi @@ -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='' 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 --------------------------------------------------------------------------- diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in index b76e187..21832cd 100755 --- a/lib/Stow.pm.in +++ b/lib/Stow.pm.in @@ -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__ diff --git a/lib/Stow/Util.pm b/lib/Stow/Util.pm index 0effc35..885269b 100644 --- a/lib/Stow/Util.pm +++ b/lib/Stow/Util.pm @@ -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 = (); diff --git a/t/chkstow.t b/t/chkstow.t index 711c33b..0b8027f 100755 --- a/t/chkstow.t +++ b/t/chkstow.t @@ -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 diff --git a/t/cleanup_invalid_links.t b/t/cleanup_invalid_links.t index 9882487..99bfdf3 100755 --- a/t/cleanup_invalid_links.t +++ b/t/cleanup_invalid_links.t @@ -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; diff --git a/t/examples.t b/t/examples.t index 381f9ad..67d72aa 100755 --- a/t/examples.t +++ b/t/examples.t @@ -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; diff --git a/t/find_stowed_path.t b/t/find_stowed_path.t index 7fac9f0..c632d5d 100755 --- a/t/find_stowed_path.t +++ b/t/find_stowed_path.t @@ -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) ); diff --git a/t/foldable.t b/t/foldable.t index 6815ec7..1d0446f 100755 --- a/t/foldable.t +++ b/t/foldable.t @@ -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'); diff --git a/t/ignore.t b/t/ignore.t new file mode 100755 index 0000000..5d23bba --- /dev/null +++ b/t/ignore.t @@ -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), <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, < 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, < 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, < 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", < 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(); diff --git a/t/stow.t b/t/stow.t index 2ad0fc8..902bb50 100755 --- a/t/stow.t +++ b/t/stow.t @@ -13,7 +13,7 @@ use testutil; require 'stow'; -make_fresh_stow_and_target_dirs(); +init_test_dirs(); local @ARGV = ( '-v', diff --git a/t/stow_contents.t b/t/stow_contents.t index b8a0eff..30cfa64 100755 --- a/t/stow_contents.t +++ b/t/stow_contents.t @@ -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; diff --git a/t/testutil.pm b/t/testutil.pm index 5c71a20..2efe72e 100755 --- a/t/testutil.pm +++ b/t/testutil.pm @@ -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") { diff --git a/t/unstow_contents.t b/t/unstow_contents.t index cb9707d..45ad7d6 100755 --- a/t/unstow_contents.t +++ b/t/unstow_contents.t @@ -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 diff --git a/t/unstow_contents_orig.t b/t/unstow_contents_orig.t index 85214c5..61b1a45 100755 --- a/t/unstow_contents_orig.t +++ b/t/unstow_contents_orig.t @@ -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