Add support for ignore lists.
This commit is contained in:
parent
7777e181a8
commit
ea82ef5b8b
18 changed files with 881 additions and 167 deletions
4
AUTHORS
4
AUTHORS
|
@ -34,7 +34,7 @@ version 2 and created the texi2man script.
|
||||||
|
|
||||||
Adam Spiers <stow@adamspiers.org> refactored the backend code into new
|
Adam Spiers <stow@adamspiers.org> refactored the backend code into new
|
||||||
Stow.pm and Stow/Util.pm modules providing an OO interface, tightened
|
Stow.pm and Stow/Util.pm modules providing an OO interface, tightened
|
||||||
up the test suite, added support for `make test' and distribution via
|
up the test suite, added support for ignore lists, `make test', and
|
||||||
CPAN, and cleaned up numerous other minor issues.
|
distribution via CPAN, and cleaned up numerous other minor issues.
|
||||||
|
|
||||||
Stow is currently maintained by Troy Mill.
|
Stow is currently maintained by Troy Mill.
|
||||||
|
|
|
@ -10,6 +10,8 @@ dist_pm_DATA = lib/Stow.pm
|
||||||
pmstowdir = $(pmdir)/Stow
|
pmstowdir = $(pmdir)/Stow
|
||||||
dist_pmstow_DATA = lib/Stow/Util.pm
|
dist_pmstow_DATA = lib/Stow/Util.pm
|
||||||
|
|
||||||
|
DEFAULT_IGNORE_LIST = default-ignore-list
|
||||||
|
|
||||||
TESTS_ENVIRONMENT=$(PERL) -I $(top_srcdir)
|
TESTS_ENVIRONMENT=$(PERL) -I $(top_srcdir)
|
||||||
TESTS = \
|
TESTS = \
|
||||||
t/cleanup_invalid_links.t \
|
t/cleanup_invalid_links.t \
|
||||||
|
@ -17,7 +19,7 @@ TESTS = \
|
||||||
t/examples.t \
|
t/examples.t \
|
||||||
t/find_stowed_path.t \
|
t/find_stowed_path.t \
|
||||||
t/foldable.t \
|
t/foldable.t \
|
||||||
t/join_paths.t \
|
t/ignore.t \
|
||||||
t/parent.t \
|
t/parent.t \
|
||||||
t/stow_contents.t \
|
t/stow_contents.t \
|
||||||
t/stow.t \
|
t/stow.t \
|
||||||
|
@ -31,6 +33,7 @@ EXTRA_DIST = \
|
||||||
bin/stow.in bin/chkstow.in lib/Stow.pm.in \
|
bin/stow.in bin/chkstow.in lib/Stow.pm.in \
|
||||||
$(TESTS) t/testutil.pm \
|
$(TESTS) t/testutil.pm \
|
||||||
$(TEXINFO_TEX) \
|
$(TEXINFO_TEX) \
|
||||||
|
default-ignore-list \
|
||||||
$(CPAN_FILES)
|
$(CPAN_FILES)
|
||||||
CLEANFILES = $(bin_SCRIPTS) $(dist_pm_DATA)
|
CLEANFILES = $(bin_SCRIPTS) $(dist_pm_DATA)
|
||||||
|
|
||||||
|
@ -50,8 +53,8 @@ bin/chkstow: bin/chkstow.in Makefile
|
||||||
$(edit) < $< > $@
|
$(edit) < $< > $@
|
||||||
chmod +x $@
|
chmod +x $@
|
||||||
|
|
||||||
lib/Stow.pm: lib/Stow.pm.in Makefile
|
lib/Stow.pm: lib/Stow.pm.in Makefile $(DEFAULT_IGNORE_LIST)
|
||||||
$(edit) < $< > $@
|
( $(edit) < $<; cat $(DEFAULT_IGNORE_LIST) ) > $@
|
||||||
|
|
||||||
# The rules for manual.html and manual.texi are only used by
|
# The rules for manual.html and manual.texi are only used by
|
||||||
# the developer
|
# the developer
|
||||||
|
|
21
TODO
21
TODO
|
@ -1,24 +1,5 @@
|
||||||
|
* Prevent folding of directories which contain ignored files
|
||||||
* Honour .no-stow-folding and --no-folding
|
* 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
|
* Add semi-automatic conflict resolution
|
||||||
*** STOW_RESOLVE_CONFLICTS="non_stow_symlinks=t stow_symlinks=r"
|
*** STOW_RESOLVE_CONFLICTS="non_stow_symlinks=t stow_symlinks=r"
|
||||||
*** Add documentation about conflict resolution
|
*** Add documentation about conflict resolution
|
||||||
|
|
18
default-ignore-list
Normal file
18
default-ignore-list
Normal 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
|
171
doc/stow.texi
171
doc/stow.texi
|
@ -82,6 +82,7 @@ approved by the Free Software Foundation.
|
||||||
|
|
||||||
@c ==========================================================================
|
@c ==========================================================================
|
||||||
@node Top, Introduction, (dir), (dir)
|
@node Top, Introduction, (dir), (dir)
|
||||||
|
@top
|
||||||
|
|
||||||
@ifinfo
|
@ifinfo
|
||||||
This manual describes GNU Stow @value{VERSION}, a program for managing
|
This manual describes GNU Stow @value{VERSION}, a program for managing
|
||||||
|
@ -92,6 +93,7 @@ the installation of software packages.
|
||||||
* Introduction:: Description of Stow.
|
* Introduction:: Description of Stow.
|
||||||
* Terminology:: Terms used by this manual.
|
* Terminology:: Terms used by this manual.
|
||||||
* Invoking Stow:: Option summary.
|
* Invoking Stow:: Option summary.
|
||||||
|
* Ignore Lists:: Controlling what gets stowed.
|
||||||
* Installing Packages:: Using Stow to install.
|
* Installing Packages:: Using Stow to install.
|
||||||
* Deleting Packages:: Using Stow to uninstall.
|
* Deleting Packages:: Using Stow to uninstall.
|
||||||
* Conflicts:: When Stow can't stow.
|
* Conflicts:: When Stow can't stow.
|
||||||
|
@ -107,16 +109,24 @@ the installation of software packages.
|
||||||
* GNU General Public License:: Copying terms.
|
* GNU General Public License:: Copying terms.
|
||||||
* Index:: Index of concepts.
|
* Index:: Index of concepts.
|
||||||
|
|
||||||
|
@detailmenu
|
||||||
--- The Detailed Node Listing ---
|
--- The Detailed Node Listing ---
|
||||||
|
|
||||||
Compile-time and install-time
|
Ignore Lists
|
||||||
|
|
||||||
|
* 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::
|
* GNU Emacs::
|
||||||
* Other FSF Software::
|
* Other FSF Software::
|
||||||
* Cygnus Software::
|
* Cygnus Software::
|
||||||
* Perl and Perl 5 Modules::
|
* Perl and Perl 5 Modules::
|
||||||
@end menu
|
|
||||||
|
|
||||||
|
@end detailmenu
|
||||||
|
@end menu
|
||||||
|
|
||||||
@c ===========================================================================
|
@c ===========================================================================
|
||||||
@node Introduction, Terminology, Top, Top
|
@node Introduction, Terminology, Top, Top
|
||||||
|
@ -229,7 +239,7 @@ computed starting from the symlink's own directory. Stow only
|
||||||
creates relative symlinks.
|
creates relative symlinks.
|
||||||
|
|
||||||
@c ===========================================================================
|
@c ===========================================================================
|
||||||
@node Invoking Stow, Installing Packages, Terminology, Top
|
@node Invoking Stow, Ignore Lists, Terminology, Top
|
||||||
@chapter Invoking Stow
|
@chapter Invoking Stow
|
||||||
|
|
||||||
The syntax of the @code{stow} command is:
|
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
|
given perl regular expression. For example, using the options
|
||||||
|
|
||||||
@example
|
@example
|
||||||
--ignore='~' --ignore='\.#.*'
|
--ignore='*.orig' --ignore='*.dist'
|
||||||
@end example
|
@end example
|
||||||
|
|
||||||
@noindent
|
@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,
|
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.
|
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>'
|
@item --defer='<regex>'
|
||||||
This (repeatable) option avoids stowing a file matching the given
|
This (repeatable) option avoids stowing a file matching the given
|
||||||
regular expression, if that file is already stowed by another package.
|
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
|
@ref{Resource Files} for a way to set default values for any of these
|
||||||
options.
|
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 ===========================================================================
|
@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
|
@chapter Installing Packages
|
||||||
|
|
||||||
@cindex installation
|
@cindex installation
|
||||||
|
@ -532,7 +689,7 @@ package.
|
||||||
|
|
||||||
@c ===========================================================================
|
@c ===========================================================================
|
||||||
@node Conflicts, Deferred Operation, Deleting Packages, Top
|
@node Conflicts, Deferred Operation, Deleting Packages, Top
|
||||||
@section Conflicts
|
@chapter Conflicts
|
||||||
|
|
||||||
If, during installation, a file or symlink exists in the target tree and
|
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
|
has the same name as something Stow needs to create, and if the
|
||||||
|
|
399
lib/Stow.pm.in
399
lib/Stow.pm.in
|
@ -45,6 +45,12 @@ use Stow::Util qw(set_debug_level debug error set_test_mode
|
||||||
our $ProgramName = 'stow';
|
our $ProgramName = 'stow';
|
||||||
our $VERSION = '@VERSION@';
|
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.
|
# These are the default options for each Stow instance.
|
||||||
our %DEFAULT_OPTIONS = (
|
our %DEFAULT_OPTIONS = (
|
||||||
conflicts => 0,
|
conflicts => 0,
|
||||||
|
@ -235,14 +241,16 @@ sub plan_unstow {
|
||||||
debug(2, "Planning unstow of package $package...");
|
debug(2, "Planning unstow of package $package...");
|
||||||
if ($self->{'compat'}) {
|
if ($self->{'compat'}) {
|
||||||
$self->unstow_contents_orig(
|
$self->unstow_contents_orig(
|
||||||
join_paths($self->{stow_path}, $package), # path to package
|
$self->{stow_path},
|
||||||
'.', # target is current_dir
|
$package,
|
||||||
|
'.',
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
$self->unstow_contents(
|
$self->unstow_contents(
|
||||||
join_paths($self->{stow_path}, $package), # path to package
|
$self->{stow_path},
|
||||||
'.', # target is current_dir
|
$package,
|
||||||
|
'.',
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
debug(2, "Planning unstow of package $package... done");
|
debug(2, "Planning unstow of package $package... done");
|
||||||
|
@ -269,8 +277,9 @@ sub plan_stow {
|
||||||
}
|
}
|
||||||
debug(2, "Planning stow of package $package...");
|
debug(2, "Planning stow of package $package...");
|
||||||
$self->stow_contents(
|
$self->stow_contents(
|
||||||
join_paths($self->{stow_path}, $package), # path package
|
$self->{stow_path},
|
||||||
'.', # target is current dir
|
$package,
|
||||||
|
'.',
|
||||||
join_paths($self->{stow_path}, $package), # source from target
|
join_paths($self->{stow_path}, $package), # source from target
|
||||||
);
|
);
|
||||||
debug(2, "Planning stow of package $package... done");
|
debug(2, "Planning stow of package $package... done");
|
||||||
|
@ -306,23 +315,29 @@ sub within_target_do {
|
||||||
#===== METHOD ===============================================================
|
#===== METHOD ===============================================================
|
||||||
# Name : stow_contents()
|
# Name : stow_contents()
|
||||||
# Purpose : stow the contents of the given directory
|
# Purpose : stow 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
|
||||||
# : $target => relative path to symlink target from the current directory
|
# : to the stow dir containing the package to be stowed
|
||||||
# : $source => relative path to symlink source from the dir of target
|
# : $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
|
# Returns : n/a
|
||||||
# Throws : a fatal error if directory cannot be read
|
# 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
|
# : $source and $target are used for creating the symlink
|
||||||
# : $path is used for folding/unfolding trees as necessary
|
# : $path is used for folding/unfolding trees as necessary
|
||||||
#============================================================================
|
#============================================================================
|
||||||
sub stow_contents {
|
sub stow_contents {
|
||||||
my $self = shift;
|
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);
|
return if $self->should_skip_target_which_is_stow_dir($target);
|
||||||
|
|
||||||
my $cwd = getcwd();
|
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;
|
$msg =~ s!$ENV{HOME}/!~/!g;
|
||||||
debug(2, $msg);
|
debug(2, $msg);
|
||||||
debug(3, "--- $target => $source");
|
debug(3, "--- $target => $source");
|
||||||
|
@ -341,10 +356,12 @@ sub stow_contents {
|
||||||
for my $node (@listing) {
|
for my $node (@listing) {
|
||||||
next NODE if $node eq '.';
|
next NODE if $node eq '.';
|
||||||
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(
|
$self->stow_node(
|
||||||
join_paths($path, $node), # path
|
$stow_path,
|
||||||
join_paths($target, $node), # target
|
$package,
|
||||||
|
$node_target, # target
|
||||||
join_paths($source, $node), # source
|
join_paths($source, $node), # source
|
||||||
);
|
);
|
||||||
}
|
}
|
||||||
|
@ -353,8 +370,10 @@ sub stow_contents {
|
||||||
#===== METHOD ===============================================================
|
#===== METHOD ===============================================================
|
||||||
# Name : stow_node()
|
# Name : stow_node()
|
||||||
# Purpose : stow the given node
|
# Purpose : stow 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
|
||||||
# : $target => relative path to symlink target from the current 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
|
# : $source => relative path to symlink source from the dir of target
|
||||||
# Returns : n/a
|
# Returns : n/a
|
||||||
# Throws : fatal exception if a conflict arises
|
# Throws : fatal exception if a conflict arises
|
||||||
|
@ -364,7 +383,9 @@ sub stow_contents {
|
||||||
#============================================================================
|
#============================================================================
|
||||||
sub stow_node {
|
sub stow_node {
|
||||||
my $self = shift;
|
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(2, "Stowing from $path");
|
||||||
debug(3, "--- $target => $source");
|
debug(3, "--- $target => $source");
|
||||||
|
@ -381,7 +402,6 @@ sub stow_node {
|
||||||
|
|
||||||
# Does the target already exist?
|
# Does the target already exist?
|
||||||
if ($self->is_a_link($target)) {
|
if ($self->is_a_link($target)) {
|
||||||
|
|
||||||
# Where is the link pointing?
|
# Where is the link pointing?
|
||||||
my $existing_source = $self->read_a_link($target);
|
my $existing_source = $self->read_a_link($target);
|
||||||
if (not $existing_source) {
|
if (not $existing_source) {
|
||||||
|
@ -390,7 +410,8 @@ sub stow_node {
|
||||||
debug(3, "--- Evaluate existing link: $target => $existing_source");
|
debug(3, "--- Evaluate existing link: $target => $existing_source");
|
||||||
|
|
||||||
# Does it point to a node under our stow directory?
|
# 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) {
|
if (not $existing_path) {
|
||||||
$self->conflict("existing target is not owned by stow: $target");
|
$self->conflict("existing target is not owned by stow: $target");
|
||||||
return; # XXX #
|
return; # XXX #
|
||||||
|
@ -416,11 +437,21 @@ sub stow_node {
|
||||||
# and the proposed new link points to a directory,
|
# and the proposed new link points to a directory,
|
||||||
# then we can unfold (split open) the tree at that point
|
# 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_unlink($target);
|
||||||
$self->do_mkdir($target);
|
$self->do_mkdir($target);
|
||||||
$self->stow_contents($existing_path, $target, join_paths('..', $existing_source));
|
$self->stow_contents(
|
||||||
$self->stow_contents($path, $target, join_paths('..', $source));
|
$existing_stow_path,
|
||||||
|
$existing_package,
|
||||||
|
$target,
|
||||||
|
join_paths('..', $existing_source),
|
||||||
|
);
|
||||||
|
$self->stow_contents(
|
||||||
|
$self->{stow_path},
|
||||||
|
$package,
|
||||||
|
$target,
|
||||||
|
join_paths('..', $source),
|
||||||
|
);
|
||||||
}
|
}
|
||||||
else {
|
else {
|
||||||
$self->conflict(
|
$self->conflict(
|
||||||
|
@ -440,7 +471,12 @@ sub stow_node {
|
||||||
elsif ($self->is_a_node($target)) {
|
elsif ($self->is_a_node($target)) {
|
||||||
debug(3, "--- Evaluate existing node: $target");
|
debug(3, "--- Evaluate existing node: $target");
|
||||||
if ($self->is_a_dir($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 {
|
else {
|
||||||
$self->conflict(
|
$self->conflict(
|
||||||
|
@ -497,7 +533,9 @@ sub marked_stow_dir {
|
||||||
#===== METHOD ===============================================================
|
#===== METHOD ===============================================================
|
||||||
# Name : unstow_contents_orig()
|
# Name : unstow_contents_orig()
|
||||||
# Purpose : unstow the contents of the given directory
|
# 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
|
# : $target => relative path to symlink target from the current directory
|
||||||
# Returns : n/a
|
# Returns : n/a
|
||||||
# Throws : a fatal error if directory cannot be read
|
# Throws : a fatal error if directory cannot be read
|
||||||
|
@ -506,7 +544,9 @@ sub marked_stow_dir {
|
||||||
#============================================================================
|
#============================================================================
|
||||||
sub unstow_contents_orig {
|
sub unstow_contents_orig {
|
||||||
my $self = shift;
|
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);
|
return if $self->should_skip_target_which_is_stow_dir($target);
|
||||||
|
|
||||||
|
@ -530,18 +570,18 @@ sub unstow_contents_orig {
|
||||||
for my $node (@listing) {
|
for my $node (@listing) {
|
||||||
next NODE if $node eq '.';
|
next NODE if $node eq '.';
|
||||||
next NODE if $node eq '..';
|
next NODE if $node eq '..';
|
||||||
next NODE if $self->ignore($node);
|
my $node_target = join_paths($target, $node);
|
||||||
$self->unstow_node_orig(
|
next NODE if $self->ignore($stow_path, $package, $node_target);
|
||||||
join_paths($path, $node), # path
|
$self->unstow_node_orig($stow_path, $package, $node_target);
|
||||||
join_paths($target, $node), # target
|
|
||||||
);
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
#===== METHOD ===============================================================
|
#===== METHOD ===============================================================
|
||||||
# Name : unstow_node_orig()
|
# Name : unstow_node_orig()
|
||||||
# Purpose : unstow the given 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 stowed
|
||||||
# : $target => relative path to symlink target from the current directory
|
# : $target => relative path to symlink target from the current directory
|
||||||
# Returns : n/a
|
# Returns : n/a
|
||||||
# Throws : fatal error if a conflict arises
|
# Throws : fatal error if a conflict arises
|
||||||
|
@ -549,7 +589,9 @@ sub unstow_contents_orig {
|
||||||
#============================================================================
|
#============================================================================
|
||||||
sub unstow_node_orig {
|
sub unstow_node_orig {
|
||||||
my $self = shift;
|
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(2, "Unstowing $target (compat mode)");
|
||||||
debug(3, "--- source path is $path");
|
debug(3, "--- source path is $path");
|
||||||
|
@ -565,7 +607,8 @@ sub unstow_node_orig {
|
||||||
}
|
}
|
||||||
|
|
||||||
# Does it point to a node under our stow directory?
|
# 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) {
|
if (not $existing_path) {
|
||||||
# We're traversing the target tree not the package tree,
|
# We're traversing the target tree not the package tree,
|
||||||
# so we definitely expect to find stuff not owned by stow.
|
# so we definitely expect to find stuff not owned by stow.
|
||||||
|
@ -591,7 +634,7 @@ sub unstow_node_orig {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
elsif (-d $target) {
|
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
|
# This action may have made the parent directory foldable
|
||||||
if (my $parent = $self->foldable($target)) {
|
if (my $parent = $self->foldable($target)) {
|
||||||
|
@ -612,7 +655,9 @@ sub unstow_node_orig {
|
||||||
#===== METHOD ===============================================================
|
#===== METHOD ===============================================================
|
||||||
# Name : unstow_contents()
|
# Name : unstow_contents()
|
||||||
# Purpose : unstow the contents of the given directory
|
# 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
|
# : $target => relative path to symlink target from the current directory
|
||||||
# Returns : n/a
|
# Returns : n/a
|
||||||
# Throws : a fatal error if directory cannot be read
|
# Throws : a fatal error if directory cannot be read
|
||||||
|
@ -621,7 +666,9 @@ sub unstow_node_orig {
|
||||||
#============================================================================
|
#============================================================================
|
||||||
sub unstow_contents {
|
sub unstow_contents {
|
||||||
my $self = shift;
|
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);
|
return if $self->should_skip_target_which_is_stow_dir($target);
|
||||||
|
|
||||||
|
@ -648,11 +695,9 @@ sub unstow_contents {
|
||||||
for my $node (@listing) {
|
for my $node (@listing) {
|
||||||
next NODE if $node eq '.';
|
next NODE if $node eq '.';
|
||||||
next NODE if $node eq '..';
|
next NODE if $node eq '..';
|
||||||
next NODE if $self->ignore($node);
|
my $node_target = join_paths($target, $node);
|
||||||
$self->unstow_node(
|
next NODE if $self->ignore($stow_path, $package, $node_target);
|
||||||
join_paths($path, $node), # path
|
$self->unstow_node($stow_path, $package, $node_target);
|
||||||
join_paths($target, $node), # target
|
|
||||||
);
|
|
||||||
}
|
}
|
||||||
if (-d $target) {
|
if (-d $target) {
|
||||||
$self->cleanup_invalid_links($target);
|
$self->cleanup_invalid_links($target);
|
||||||
|
@ -662,7 +707,9 @@ sub unstow_contents {
|
||||||
#===== METHOD ===============================================================
|
#===== METHOD ===============================================================
|
||||||
# Name : unstow_node()
|
# Name : unstow_node()
|
||||||
# Purpose : unstow the given 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
|
# : $target => relative path to symlink target from the current directory
|
||||||
# Returns : n/a
|
# Returns : n/a
|
||||||
# Throws : fatal error if a conflict arises
|
# Throws : fatal error if a conflict arises
|
||||||
|
@ -670,7 +717,9 @@ sub unstow_contents {
|
||||||
#============================================================================
|
#============================================================================
|
||||||
sub unstow_node {
|
sub unstow_node {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
my ($path, $target) = @_;
|
my ($stow_path, $package, $target) = @_;
|
||||||
|
|
||||||
|
my $path = join_paths($stow_path, $package, $target);
|
||||||
|
|
||||||
debug(2, "Unstowing $path");
|
debug(2, "Unstowing $path");
|
||||||
debug(3, "--- target is $target");
|
debug(3, "--- target is $target");
|
||||||
|
@ -686,12 +735,13 @@ sub unstow_node {
|
||||||
}
|
}
|
||||||
|
|
||||||
if ($existing_source =~ m{\A/}) {
|
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 #
|
return; # XXX #
|
||||||
}
|
}
|
||||||
|
|
||||||
# Does it point to a node under our stow directory?
|
# 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) {
|
if (not $existing_path) {
|
||||||
$self->conflict(
|
$self->conflict(
|
||||||
qq{existing target is not owned by stow: $target => $existing_source}
|
qq{existing target is not owned by stow: $target => $existing_source}
|
||||||
|
@ -732,7 +782,7 @@ sub unstow_node {
|
||||||
elsif (-e $target) {
|
elsif (-e $target) {
|
||||||
debug(3, "Evaluate existing node: $target");
|
debug(3, "Evaluate existing node: $target");
|
||||||
if (-d $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
|
# This action may have made the parent directory foldable
|
||||||
if (my $parent = $self->foldable($target)) {
|
if (my $parent = $self->foldable($target)) {
|
||||||
|
@ -752,16 +802,39 @@ sub unstow_node {
|
||||||
}
|
}
|
||||||
|
|
||||||
#===== METHOD ===============================================================
|
#===== METHOD ===============================================================
|
||||||
# Name : find_stowed_path()
|
# Name : path_owned_by_package()
|
||||||
# Purpose : determine if the given link points to a member of a
|
# Purpose : determine if the given link points to a member of a
|
||||||
# : stowed package
|
# : stowed package
|
||||||
# Parameters: $target => path to a symbolic link under current directory
|
# Parameters: $target => path to a symbolic link under current directory
|
||||||
# : $source => where that link points to
|
# : $source => where that link points to
|
||||||
# Returns : relative path to stowed node (from the current directory)
|
# Returns : the package iff link is owned by stow, otherwise ''
|
||||||
# : or '' if link is not owned by stow
|
# Throws : n/a
|
||||||
# Throws : fatal exception if link is unreadable
|
# Comments : lossy wrapper around find_stowed_path()
|
||||||
# Comments : allow for stow dir not being under target dir
|
#============================================================================
|
||||||
# : we could put more logic under here for multiple stow dirs
|
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 {
|
sub find_stowed_path {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
|
@ -769,34 +842,48 @@ sub find_stowed_path {
|
||||||
|
|
||||||
# Evaluate softlink relative to its target
|
# Evaluate softlink relative to its target
|
||||||
my $path = join_paths(parent($target), $source);
|
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 = '';
|
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);
|
$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}
|
# If no .stow file was found, we need to find out whether it's
|
||||||
my @path = split m{/+}, $path;
|
# 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};
|
my @stow_path = split m{/+}, $self->{stow_path};
|
||||||
|
|
||||||
# Strip off common prefixes until one is empty
|
# Strip off common prefixes until one is empty
|
||||||
while (@path && @stow_path) {
|
while (@path && @stow_path) {
|
||||||
if ((shift @path) ne (shift @stow_path)) {
|
if ((shift @path) ne (shift @stow_path)) {
|
||||||
debug(4, " no - either $path not under $self->{stow_path} or vice-versa");
|
debug(4, " no - either $path not under $self->{stow_path} or vice-versa");
|
||||||
return '';
|
return ('', '', '');
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
if (@stow_path) { # @path must be empty
|
if (@stow_path) { # @path must be empty
|
||||||
debug(4, " no - $path is not under $self->{stow_path}");
|
debug(4, " no - $path is not under $self->{stow_path}");
|
||||||
return '';
|
return ('', '', '');
|
||||||
}
|
}
|
||||||
|
|
||||||
debug(4, " yes - in " . join_paths(@path));
|
my $package = shift @path;
|
||||||
return $path;
|
|
||||||
|
debug(4, " yes - by $package in " . join_paths(@path));
|
||||||
|
return ($path, $self->{stow_path}, $package);
|
||||||
}
|
}
|
||||||
|
|
||||||
#===== METHOD ================================================================
|
#===== METHOD ================================================================
|
||||||
|
@ -841,7 +928,7 @@ sub cleanup_invalid_links {
|
||||||
|
|
||||||
if (
|
if (
|
||||||
not -e join_paths($dir, $source) and # bad link
|
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 => " .
|
debug(3, "--- removing stale link: $node_path => " .
|
||||||
join_paths($dir, $source));
|
join_paths($dir, $source));
|
||||||
|
@ -910,7 +997,7 @@ sub foldable {
|
||||||
$parent =~ s{\A\.\./}{};
|
$parent =~ s{\A\.\./}{};
|
||||||
|
|
||||||
# If the resulting path is owned by stow, we can fold it
|
# 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");
|
debug(3, "--- $target is foldable");
|
||||||
return $parent;
|
return $parent;
|
||||||
}
|
}
|
||||||
|
@ -997,21 +1084,189 @@ sub get_tasks {
|
||||||
#===== METHOD ================================================================
|
#===== METHOD ================================================================
|
||||||
# Name : ignore
|
# Name : ignore
|
||||||
# Purpose : determine if the given path matches a regex in our ignore list
|
# Purpose : determine if the given path matches a regex in our ignore list
|
||||||
# Parameters: $path
|
# Parameters: $stow_path => the stow directory containing the package
|
||||||
# Returns : Boolean
|
# : $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
|
# Throws : no exceptions
|
||||||
# Comments : none
|
# Comments : none
|
||||||
#=============================================================================
|
#=============================================================================
|
||||||
sub ignore {
|
sub ignore {
|
||||||
my $self = shift;
|
my $self = shift;
|
||||||
my ($path) = @_;
|
my ($stow_path, $package, $target) = @_;
|
||||||
|
|
||||||
|
internal_error(__PACKAGE__ . "::ignore() called with empty target")
|
||||||
|
unless length $target;
|
||||||
|
|
||||||
for my $suffix (@{ $self->{'ignore'} }) {
|
for my $suffix (@{ $self->{'ignore'} }) {
|
||||||
return 1 if $path =~ m/$suffix/;
|
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;
|
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 ================================================================
|
#===== METHOD ================================================================
|
||||||
# Name : defer
|
# Name : defer
|
||||||
# Purpose : determine if the given path matches a regex in our defer list
|
# Purpose : determine if the given path matches a regex in our defer list
|
||||||
|
@ -1675,3 +1930,9 @@ sub internal_error {
|
||||||
# cperl-indent-level: 4
|
# cperl-indent-level: 4
|
||||||
# end:
|
# end:
|
||||||
# vim: ft=perl
|
# vim: ft=perl
|
||||||
|
|
||||||
|
#############################################################################
|
||||||
|
# Default global list of ignore regexps follows
|
||||||
|
# (automatically appended by the Makefile)
|
||||||
|
|
||||||
|
__DATA__
|
||||||
|
|
|
@ -14,7 +14,7 @@ use Test::More tests => 7;
|
||||||
use Test::Output;
|
use Test::Output;
|
||||||
use English qw(-no_match_vars);
|
use English qw(-no_match_vars);
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
|
|
||||||
# setup stow directory
|
# setup stow directory
|
||||||
|
|
|
@ -12,7 +12,7 @@ use English qw(-no_match_vars);
|
||||||
|
|
||||||
use testutil;
|
use testutil;
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
|
|
||||||
my $stow;
|
my $stow;
|
||||||
|
|
|
@ -12,7 +12,7 @@ use testutil;
|
||||||
use Test::More tests => 10;
|
use Test::More tests => 10;
|
||||||
use English qw(-no_match_vars);
|
use English qw(-no_match_vars);
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
|
|
||||||
my $stow;
|
my $stow;
|
||||||
|
|
|
@ -11,21 +11,21 @@ use testutil;
|
||||||
|
|
||||||
use Test::More tests => 6;
|
use Test::More tests => 6;
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
|
|
||||||
my $stow = new_Stow(dir => 't/stow');
|
my $stow = new_Stow(dir => 't/stow');
|
||||||
|
|
||||||
is(
|
is_deeply(
|
||||||
$stow->find_stowed_path('t/target/a/b/c', '../../../stow/a/b/c'),
|
[ $stow->find_stowed_path('t/target/a/b/c', '../../../stow/a/b/c') ],
|
||||||
't/stow/a/b/c'
|
[ 't/stow/a/b/c', 't/stow', 'a' ]
|
||||||
=> 'from root'
|
=> 'from root'
|
||||||
);
|
);
|
||||||
|
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
$stow->set_stow_dir('../stow');
|
$stow->set_stow_dir('../stow');
|
||||||
is(
|
is_deeply(
|
||||||
$stow->find_stowed_path('a/b/c','../../../stow/a/b/c'),
|
[ $stow->find_stowed_path('a/b/c','../../../stow/a/b/c') ],
|
||||||
'../stow/a/b/c'
|
[ '../stow/a/b/c', '../stow', 'a' ]
|
||||||
=> 'from target directory'
|
=> 'from target directory'
|
||||||
);
|
);
|
||||||
|
|
||||||
|
@ -33,31 +33,31 @@ make_dir('stow');
|
||||||
cd('../..');
|
cd('../..');
|
||||||
$stow->set_stow_dir('t/target/stow');
|
$stow->set_stow_dir('t/target/stow');
|
||||||
|
|
||||||
is(
|
is_deeply(
|
||||||
$stow->find_stowed_path('t/target/a/b/c', '../../stow/a/b/c'),
|
[ $stow->find_stowed_path('t/target/a/b/c', '../../stow/a/b/c') ],
|
||||||
't/target/stow/a/b/c'
|
[ 't/target/stow/a/b/c', 't/target/stow', 'a' ]
|
||||||
=> 'stow is subdir of target directory'
|
=> 'stow is subdir of target directory'
|
||||||
);
|
);
|
||||||
|
|
||||||
is(
|
is_deeply(
|
||||||
$stow->find_stowed_path('t/target/a/b/c','../../empty'),
|
[ $stow->find_stowed_path('t/target/a/b/c','../../empty') ],
|
||||||
''
|
[ '', '', '' ]
|
||||||
=> 'target is not stowed'
|
=> 'target is not stowed'
|
||||||
);
|
);
|
||||||
|
|
||||||
make_dir('t/target/stow2');
|
make_dir('t/target/stow2');
|
||||||
make_file('t/target/stow2/.stow');
|
make_file('t/target/stow2/.stow');
|
||||||
|
|
||||||
is(
|
is_deeply(
|
||||||
$stow->find_stowed_path('t/target/a/b/c','../../stow2/a/b/c'),
|
[ $stow->find_stowed_path('t/target/a/b/c','../../stow2/a/b/c') ],
|
||||||
't/target/stow2/a/b/c'
|
[ 't/target/stow2/a/b/c', 't/target/stow2', 'a' ]
|
||||||
=> q(detect alternate stow directory)
|
=> q(detect alternate stow directory)
|
||||||
);
|
);
|
||||||
|
|
||||||
# Possible corner case with rogue symlink pointing to ancestor of
|
# Possible corner case with rogue symlink pointing to ancestor of
|
||||||
# stow dir.
|
# stow dir.
|
||||||
is(
|
is_deeply(
|
||||||
$stow->find_stowed_path('t/target/a/b/c','../../..'),
|
[ $stow->find_stowed_path('t/target/a/b/c','../../..') ],
|
||||||
''
|
[ '', '', '' ]
|
||||||
=> q(corner case - link points to ancestor of stow dir)
|
=> q(corner case - link points to ancestor of stow dir)
|
||||||
);
|
);
|
||||||
|
|
|
@ -12,7 +12,7 @@ use testutil;
|
||||||
use Test::More tests => 4;
|
use Test::More tests => 4;
|
||||||
use English qw(-no_match_vars);
|
use English qw(-no_match_vars);
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
|
|
||||||
my $stow = new_Stow(dir => '../stow');
|
my $stow = new_Stow(dir => '../stow');
|
||||||
|
|
291
t/ignore.t
Executable file
291
t/ignore.t
Executable 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
2
t/stow.t
|
@ -13,7 +13,7 @@ use testutil;
|
||||||
|
|
||||||
require 'stow';
|
require 'stow';
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
|
|
||||||
local @ARGV = (
|
local @ARGV = (
|
||||||
'-v',
|
'-v',
|
||||||
|
|
|
@ -14,7 +14,7 @@ use English qw(-no_match_vars);
|
||||||
use Stow::Util qw(canon_path);
|
use Stow::Util qw(canon_path);
|
||||||
use testutil;
|
use testutil;
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
|
|
||||||
my $stow;
|
my $stow;
|
||||||
|
|
|
@ -10,14 +10,17 @@ use warnings;
|
||||||
use Stow;
|
use Stow;
|
||||||
use Stow::Util qw(parent);
|
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"
|
die "t/ didn't exist; are you running the tests from the root of the tree?\n"
|
||||||
unless -d 't';
|
unless -d 't';
|
||||||
|
|
||||||
for my $dir ('t/target', 't/stow') {
|
for my $dir ('t/target', 't/stow') {
|
||||||
eval { remove_dir($dir); };
|
-d $dir and remove_dir($dir);
|
||||||
make_dir($dir);
|
make_dir($dir);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Don't let user's ~/.stow-global-ignore affect test results
|
||||||
|
$ENV{HOME} = '/tmp/fake/home';
|
||||||
}
|
}
|
||||||
|
|
||||||
sub new_Stow {
|
sub new_Stow {
|
||||||
|
@ -90,22 +93,22 @@ sub make_dir {
|
||||||
# Name : create_file()
|
# Name : create_file()
|
||||||
# Purpose : create an empty file
|
# Purpose : create an empty file
|
||||||
# Parameters: $path => proposed path to the file
|
# Parameters: $path => proposed path to the file
|
||||||
|
# : $contents => (optional) contents to write to file
|
||||||
# Returns : n/a
|
# Returns : n/a
|
||||||
# Throws : fatal error if the file could not be created
|
# Throws : fatal error if the file could not be created
|
||||||
# Comments : detects clash with an existing non-file
|
# Comments : detects clash with an existing non-file
|
||||||
#============================================================================
|
#============================================================================
|
||||||
sub make_file {
|
sub make_file {
|
||||||
my ($path) =@_;
|
my ($path, $contents) =@_;
|
||||||
|
|
||||||
if (not -e $path) {
|
if (-e $path and ! -f $path) {
|
||||||
open my $FILE ,'>', $path
|
|
||||||
or die "could not create file: $path ($!)\n";
|
|
||||||
close $FILE;
|
|
||||||
}
|
|
||||||
elsif (not -f $path) {
|
|
||||||
die "a non-file already exists at $path\n";
|
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 ===========================================================
|
#===== SUBROUTINE ===========================================================
|
||||||
|
@ -168,7 +171,7 @@ sub remove_dir {
|
||||||
next NODE if $node eq '..';
|
next NODE if $node eq '..';
|
||||||
|
|
||||||
my $path = "$dir/$node";
|
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";
|
unlink $path or die "cannot unlink $path ($!)\n";
|
||||||
}
|
}
|
||||||
elsif (-d "$path") {
|
elsif (-d "$path") {
|
||||||
|
|
|
@ -14,7 +14,7 @@ use English qw(-no_match_vars);
|
||||||
use testutil;
|
use testutil;
|
||||||
use Stow::Util qw(canon_path);
|
use Stow::Util qw(canon_path);
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
|
|
||||||
# Note that each of the following tests use a distinct set of files
|
# Note that each of the following tests use a distinct set of files
|
||||||
|
|
|
@ -14,7 +14,7 @@ use English qw(-no_match_vars);
|
||||||
use testutil;
|
use testutil;
|
||||||
use Stow::Util qw(canon_path);
|
use Stow::Util qw(canon_path);
|
||||||
|
|
||||||
make_fresh_stow_and_target_dirs();
|
init_test_dirs();
|
||||||
cd('t/target');
|
cd('t/target');
|
||||||
|
|
||||||
# Note that each of the following tests use a distinct set of files
|
# Note that each of the following tests use a distinct set of files
|
||||||
|
|
Loading…
Reference in a new issue