diff --git a/.gitignore b/.gitignore index cee7979..fffadc6 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,4 @@ stamp-vti stow.info t/target/ version.texi +lib/Stow.pm diff --git a/Makefile.am b/Makefile.am index 61afb72..e72767e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -4,6 +4,8 @@ bin_SCRIPTS = stow chkstow info_TEXINFOS = stow.texi dist_man_MANS = stow.8 dist_doc_DATA = README +pmdir = $(libdir)/perl5 +pm_DATA = lib/Stow.pm lib/Stow/Util.pm TESTS_ENVIRONMENT=$(PERL) -I $(top_srcdir) TESTS = \ @@ -21,7 +23,7 @@ TESTS = \ t/chkstow.t AUTOMAKE_OPTIONS = dist-shar -EXTRA_DIST = $(TESTS) t/util.pm stow.in +EXTRA_DIST = $(TESTS) t/testutil.pm CLEANFILES = $(bin_SCRIPTS) # clean up files left behind by test suite @@ -30,7 +32,6 @@ clean-local: # this is more explicit and reliable than the config file trick edit = sed -e 's|[@]PERL[@]|$(PERL)|g' \ - -e 's|[@]PACKAGE[@]|$(PACKAGE)|g' \ -e 's|[@]VERSION[@]|$(VERSION)|g' stow: stow.in Makefile @@ -41,6 +42,9 @@ chkstow: chkstow.in Makefile $(edit) < $< > $@ chmod +x $@ +lib/Stow.pm: lib/Stow.pm.in + $(edit) < $< > $@ + # The rules for manual.html and manual.texi are only used by # the developer manual.html: manual.texi @@ -51,5 +55,7 @@ manual.texi: stow.texi -rm -f $@ cp $< $@ -test: stow chkstow - perl -MTest::Harness -e 'runtests(@ARGV)' t/*.t +MODULES = lib/Stow.pm lib/Stow/Util.pm + +test: stow chkstow $(MODULES) + perl -MTest::Harness -Ilib -It -Ibin -e 'runtests(@ARGV)' t/*.t diff --git a/TODO b/TODO index 0e2e614..b873238 100644 --- a/TODO +++ b/TODO @@ -1,5 +1,3 @@ -* Split core code into Stow.pm -* Add use strict / warnings to tests * Honour .no-stow-folding and --no-folding * Support ignore lists in files *** Implement. diff --git a/configure.ac b/configure.ac index 09bac98..063733e 100644 --- a/configure.ac +++ b/configure.ac @@ -15,5 +15,11 @@ then AC_MSG_WARN([WARNING: Perl not found; you must edit line 1 of 'stow']) fi +AC_ARG_WITH( + pmdir, + [ --with-pmdir=DIR perl modules are in DIR [[LIBDIR/perl5]]], + [PMDIR=${withval}], [PMDIR=${libdir}/perl5] +) + AC_CONFIG_FILES([Makefile]) AC_OUTPUT diff --git a/lib/Stow.pm.in b/lib/Stow.pm.in new file mode 100755 index 0000000..ecc4087 --- /dev/null +++ b/lib/Stow.pm.in @@ -0,0 +1,1675 @@ +#!/usr/bin/perl + +package Stow; + +=head1 NAME + +Stow - manage the installation of multiple software packages + +=head1 SYNOPSIS + + my $stow = new Stow(%$options); + + $stow->plan_unstow(@pkgs_to_unstow); + $stow->plan_stow (@pkgs_to_stow); + + my @conflicts = $stow->get_conflicts; + $stow->process_tasks() unless @conflicts; + +=head1 DESCRIPTION + +This is the backend Perl module for GNU Stow, a program for managing +the installation of software packages, keeping them separate +(C vs. C, for example) +while making them appear to be installed in the same place +(C). + +Stow doesn't store an extra state between runs, so there's no danger +of mangling directories when file hierarchies don't match the +database. Also, stow will never delete any files, directories, or +links that appear in a stow directory, so it is always possible to +rebuild the target tree. + +=cut + +use strict; +use warnings; + +use Carp qw(carp cluck croak confess); +use File::Spec; +use POSIX qw(getcwd); + +use Stow::Util qw(set_debug_level debug error set_test_mode + join_paths restore_cwd canon_path parent); + +our $ProgramName = 'stow'; +our $VERSION = '@VERSION@'; + +# These are the default options for each Stow instance. +our %DEFAULT_OPTIONS = ( + conflicts => 0, + simulate => 0, + verbose => 0, + paranoid => 0, + compat => 0, + test_mode => 0, + ignore => [], + override => [], + defer => [], +); + +=head1 CONSTRUCTORS + +=head2 new(%options) + +=head3 Required options + +=over 4 + +=item * dir - the stow directory + +=item * target - the target directory + +=back + +=head3 Non-mandatory options + +=over 4 + +=item * conflicts + +=item * simulate + +=item * verbose + +=item * paranoid + +=item * ignore + +=item * override + +=item * defer + +=back + +N.B. This sets the current working directory to the target directory. + +=cut + +sub new { + my $self = shift; + my $class = ref($self) || $self; + my %opts = @_; + + my $new = bless { }, $class; + + for my $required_arg (qw(dir target)) { + croak "$class->new() called without '$required_arg' parameter\n" + unless exists $opts{$required_arg}; + $new->{$required_arg} = delete $opts{$required_arg}; + } + + for my $opt (keys %DEFAULT_OPTIONS) { + $new->{$opt} = exists $opts{$opt} ? delete $opts{$opt} + : $DEFAULT_OPTIONS{$opt}; + } + + if (%opts) { + croak "$class->new() called with unrecognised parameter(s): ", + join(", ", keys %opts), "\n"; + } + + $opts{'simulate'} = 1 if $opts{'conflicts'}; + + set_debug_level($new->get_verbosity()); + set_test_mode($new->{test_mode}); + $new->set_stow_dir(); + $new->init_state(); + + return $new; +} + +sub get_verbosity { + my $self = shift; + + return $self->{verbose} unless $self->{test_mode}; + + return 0 unless length $ENV{TEST_VERBOSE}; + + # Convert TEST_VERBOSE=y into numeric value + $ENV{TEST_VERBOSE} = 3 if $ENV{TEST_VERBOSE} !~ /^\d+$/; + + return $ENV{TEST_VERBOSE}; +} + +=head2 set_stow_dir([$dir]) + +Sets a new stow directory. This allows the use of multiple stow +directories within one Stow instance, e.g. + + $stow->plan_stow('foo'); + $stow->set_stow_dir('/different/stow/dir'); + $stow->plan_stow('bar'); + $stow->process_tasks; + +If C<$dir> is omitted, uses the value of the C parameter passed +to the L constructor. + +=cut + +sub set_stow_dir { + my $self = shift; + my ($dir) = @_; + if (defined $dir) { + $self->{dir} = $dir; + } + + my $stow_dir = canon_path($self->{dir}); + + $self->{stow_path} = File::Spec->abs2rel($stow_dir, $self->{target}); + + debug(2, "stow dir is $stow_dir"); + debug(2, "stow dir path relative to target $self->{target} is $self->{stow_path}"); +} + +sub init_state { + my $self = shift; + + # Store conflicts during pre-processing + $self->{conflicts} = []; + + # Store command line packages to stow (-S and -R) + $self->{pkgs_to_stow} = []; + + # Store command line packages to unstow (-D and -R) + $self->{pkgs_to_delete} = []; + + # The following structures are used by the abstractions that allow us to + # defer operating on the filesystem until after all potential conflicts have + # been assessed. + + # $self->{tasks}: list of operations to be performed (in order) + # each element is a hash ref of the form + # { + # action => ... + # type => ... + # path => ... (unique) + # source => ... (only for links) + # } + $self->{tasks} = []; + + # $self->{dir_task_for}: map a path to the corresponding directory task reference + # This structure allows us to quickly determine if a path has an existing + # directory task associated with it. + $self->{dir_task_for} = {}; + + # $self->{link_task_for}: map a path to the corresponding directory task reference + # This structure allows us to quickly determine if a path has an existing + # directory task associated with it. + $self->{link_task_for} = {}; + + # N.B.: directory tasks and link tasks are NOT mutually exclusive due + # to tree splitting (which involves a remove link task followed by + # a create directory task). +} + +=head1 METHODS + +=head2 plan_unstow(@packages) + +Plan which symlink/directory creation/removal tasks need to be executed +in order to unstow the given packages. Any potential conflicts are then +accessible via L. + +=cut + +sub plan_unstow { + my $self = shift; + my @packages = @_; + + $self->within_target_do(sub { + for my $package (@packages) { + if (not -d join_paths($self->{stow_path}, $package)) { + error("The given package name ($package) is not in your stow path $self->{stow_path}"); + } + debug(2, "Unstowing package $package..."); + if ($self->{'compat'}) { + $self->unstow_contents_orig( + join_paths($self->{stow_path}, $package), # path to package + '.', # target is current_dir + ); + } + else { + $self->unstow_contents( + join_paths($self->{stow_path}, $package), # path to package + '.', # target is current_dir + ); + } + debug(2, "Unstowing package $package... done"); + } + }); +} + +=head2 plan_stow(@packages) + +Plan which symlink/directory creation/removal tasks need to be executed +in order to stow the given packages. Any potential conflicts are then +accessible via L. + +=cut + +sub plan_stow { + my $self = shift; + my @packages = @_; + + $self->within_target_do(sub { + for my $package (@packages) { + if (not -d join_paths($self->{stow_path}, $package)) { + error("The given package name ($package) is not in your stow path $self->{stow_path}"); + } + debug(2, "Stowing package $package..."); + $self->stow_contents( + join_paths($self->{stow_path}, $package), # path package + '.', # target is current dir + join_paths($self->{stow_path}, $package), # source from target + ); + debug(2, "Stowing package $package... done"); + } + }); +} + +#===== METHOD =============================================================== +# Name : within_target_do() +# Purpose : execute code within target directory, preserving cwd +# Parameters: $code => anonymous subroutine to execute within target dir +# Returns : n/a +# Throws : n/a +# Comments : This is done to ensure that the consumer of the Stow interface +# : doesn't have to worry about (a) what their cwd is, and +# : (b) that their cwd might change. +#============================================================================ +sub within_target_do { + my $self = shift; + my ($code) = @_; + + my $cwd = getcwd(); + chdir($self->{'target'}) + or error("Cannot chdir to target tree: $self->{'target'}"); + debug(3, "cwd now $self->{target}"); + + $self->$code(); + + restore_cwd($cwd); + debug(3, "cwd restored to $cwd"); +} + +#===== 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 +# Returns : n/a +# Throws : a fatal error if directory cannot be read +# 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) = @_; + + return if $self->should_skip_stow_dir_target($target); + + my $cwd = getcwd(); + my $msg = "Stowing contents of $path (cwd=$cwd, stow dir=$self->{stow_path})"; + $msg =~ s!$ENV{HOME}/!~/!g; + debug(2, $msg); + debug(3, "--- $target => $source"); + + error("stow_contents() called with non-directory path: $path") + unless -d $path; + error("stow_contents() called with non-directory target: $target") + unless $self->is_a_node($target); + + opendir my $DIR, $path + or error("cannot read directory: $path"); + my @listing = readdir $DIR; + closedir $DIR; + + NODE: + for my $node (@listing) { + next NODE if $node eq '.'; + next NODE if $node eq '..'; + next NODE if $self->ignore($node); + $self->stow_node( + join_paths($path, $node), # path + join_paths($target, $node), # target + join_paths($source, $node), # source + ); + } +} + +#===== 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 +# : $source => relative path to symlink source from the dir of target +# Returns : n/a +# Throws : fatal exception if a conflict arises +# 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_node { + my $self = shift; + my ($path, $target, $source) = @_; + + debug(2, "Stowing from $path"); + debug(3, "--- $target => $source"); + + # don't try to stow absolute symlinks (they can't be unstowed) + if (-l $source) { + my $second_source = $self->read_a_link($source); + if ($second_source =~ m{\A/}) { + $self->conflict("source is an absolute symlink $source => $second_source"); + debug(3, "absolute symlinks cannot be unstowed"); + return; + } + } + + # does the target already exist? + if ($self->is_a_link($target)) { + + # where is the link pointing? + my $old_source = $self->read_a_link($target); + if (not $old_source) { + error("Could not read link: $target"); + } + debug(3, "--- Evaluate existing link: $target => $old_source"); + + # does it point to a node under our stow directory? + my $old_path = $self->find_stowed_path($target, $old_source); + if (not $old_path) { + $self->conflict("existing target is not owned by stow: $target"); + return; # XXX # + } + + # does the existing $target actually point to anything? + if ($self->is_a_node($old_path)) { + if ($old_source eq $source) { + debug(3, "--- Skipping $target as it already points to $source"); + } + elsif ($self->defer($target)) { + debug(3, "--- deferring installation of: $target"); + } + elsif ($self->override($target)) { + debug(3, "--- overriding installation of: $target"); + $self->do_unlink($target); + $self->do_link($source, $target); + } + elsif ($self->is_a_dir(join_paths(parent($target), $old_source)) && + $self->is_a_dir(join_paths(parent($target), $source)) ) { + + # if the existing 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 + + debug(3, "--- Unfolding $target"); + $self->do_unlink($target); + $self->do_mkdir($target); + $self->stow_contents($old_path, $target, join_paths('..', $old_source)); + $self->stow_contents($path, $target, join_paths('..', $source)); + } + else { + $self->conflict( + q{existing target is stowed to a different package: %s => %s}, + $target, + $old_source, + ); + } + } + else { + # the existing link is invalid, so replace it with a good link + debug(3, "--- replacing invalid link: $path"); + $self->do_unlink($target); + $self->do_link($source, $target); + } + } + 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)); + } + else { + $self->conflict( + qq{existing target is neither a link nor a directory: $target} + ); + } + } + else { + $self->do_link($source, $target); + } + return; +} + +#===== METHOD =============================================================== +# Name : should_skip_stow_dir_target() +# Purpose : determine whether target is a stow directory and should be skipped +# Parameters: $target => relative path to symlink target from the current directory +# Returns : true iff target is a stow directory +# Throws : n/a +# Comments : none +#============================================================================ +sub should_skip_stow_dir_target { + my $self = shift; + my ($target) = @_; + + # don't try to remove anything under a stow directory + if ($target eq $self->{stow_path}) { + debug(2, "Skipping target which was current stow directory $target"); + return 1; + } + + if ($self->protected_dir($target)) { + debug(2, "Skipping protected directory $target"); + return 1; + } + + debug (4, "$target not protected"); + return 0; +} + +sub protected_dir { + my $self = shift; + my ($target) = @_; + for my $f (".stow", ".nonstow") { + if (-e join_paths($target, $f)) { + debug(4, "$target contained $f"); + return 1; + } + } + return 0; +} + +#===== METHOD =============================================================== +# Name : unstow_contents_orig() +# Purpose : unstow 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 +# Returns : n/a +# Throws : a fatal error if directory cannot be read +# Comments : unstow_node_orig() and unstow_contents_orig() are mutually recursive +# : Here we traverse the target tree, rather than the source tree. +#============================================================================ +sub unstow_contents_orig { + my $self = shift; + my ($path, $target) = @_; + + return if $self->should_skip_stow_dir_target($target); + + my $cwd = getcwd(); + my $msg = "Unstowing from $target (compat mode, cwd=$cwd, stow dir=$self->{stow_path})"; + $msg =~ s!$ENV{HOME}/!~/!g; + debug(2, $msg); + debug(3, "--- source path is $path"); + # In compat mode we traverse the target tree not the source tree, + # so we're unstowing the contents of /target/foo, there's no + # guarantee that the corresponding /stow/mypkg/foo exists. + error("unstow_contents_orig() called with non-directory target: $target") + unless -d $target; + + opendir my $DIR, $target + or error("cannot read directory: $target"); + my @listing = readdir $DIR; + closedir $DIR; + + NODE: + 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 + ); + } +} + +#===== METHOD =============================================================== +# Name : unstow_node_orig() +# Purpose : unstow the given node +# Parameters: $path => relative path to source node from the current directory +# : $target => relative path to symlink target from the current directory +# Returns : n/a +# Throws : fatal error if a conflict arises +# Comments : unstow_node() and unstow_contents() are mutually recursive +#============================================================================ +sub unstow_node_orig { + my $self = shift; + my ($path, $target) = @_; + + debug(2, "Unstowing $target (compat mode)"); + debug(3, "--- source path is $path"); + + # does the target exist + if ($self->is_a_link($target)) { + debug(3, "Evaluate existing link: $target"); + + # where is the link pointing? + my $old_source = $self->read_a_link($target); + if (not $old_source) { + error("Could not read link: $target"); + } + + # does it point to a node under our stow directory? + my $old_path = $self->find_stowed_path($target, $old_source); + if (not $old_path) { + # skip links not owned by stow + return; # XXX # + } + + # does the existing $target actually point to anything? + if (-e $old_path) { + # does link point to the right place? + if ($old_path eq $path) { + $self->do_unlink($target); + } + elsif ($self->override($target)) { + debug(3, "--- overriding installation of: $target"); + $self->do_unlink($target); + } + # else leave it alone + } + else { + debug(3, "--- removing invalid link into a stow directory: $path"); + $self->do_unlink($target); + } + } + elsif (-d $target) { + $self->unstow_contents_orig($path, $target); + + # this action may have made the parent directory foldable + if (my $parent = $self->foldable($target)) { + $self->fold_tree($target, $parent); + } + } + elsif (-e $target) { + $self->conflict( + qq{existing target is neither a link nor a directory: $target}, + ); + } + else { + debug(3, "$target did not exist to be unstowed"); + } + return; +} + +#===== METHOD =============================================================== +# Name : unstow_contents() +# Purpose : unstow 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 +# Returns : n/a +# Throws : a fatal error if directory cannot be read +# Comments : unstow_node() and unstow_contents() are mutually recursive +# : Here we traverse the source tree, rather than the target tree. +#============================================================================ +sub unstow_contents { + my $self = shift; + my ($path, $target) = @_; + + return if $self->should_skip_stow_dir_target($target); + + my $cwd = getcwd(); + my $msg = "Unstowing from $target (cwd=$cwd, stow dir=$self->{stow_path})"; + $msg =~ s!$ENV{HOME}/!~/!g; + debug(2, $msg); + debug(3, "--- source path is $path"); + # We traverse the source tree not the target tree, so $path must exist. + error("unstow_contents() called with non-directory path: $path") + unless -d $path; + # When called at the top level, $target should exist. And + # unstow_node() should only call this via mutual recursion if + # $target exists. + error("unstow_contents() called with invalid target: $target") + unless $self->is_a_node($target); + + opendir my $DIR, $path + or error("cannot read directory: $path"); + my @listing = readdir $DIR; + closedir $DIR; + + NODE: + 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 + ); + } + if (-d $target) { + $self->cleanup_invalid_links($target); + } +} + +#===== METHOD =============================================================== +# Name : unstow_node() +# Purpose : unstow the given node +# Parameters: $path => relative path to source node from the current directory +# : $target => relative path to symlink target from the current directory +# Returns : n/a +# Throws : fatal error if a conflict arises +# Comments : unstow_node() and unstow_contents() are mutually recursive +#============================================================================ +sub unstow_node { + my $self = shift; + my ($path, $target) = @_; + + debug(2, "Unstowing $path"); + debug(3, "--- target is $target"); + + # does the target exist + if ($self->is_a_link($target)) { + debug(3, "Evaluate existing link: $target"); + + # where is the link pointing? + my $old_source = $self->read_a_link($target); + if (not $old_source) { + error("Could not read link: $target"); + } + + if ($old_source =~ m{\A/}) { + warn "ignoring a absolute symlink: $target => $old_source\n"; + return; # XXX # + } + + # does it point to a node under our stow directory? + my $old_path = $self->find_stowed_path($target, $old_source); + if (not $old_path) { + $self->conflict( + qq{existing target is not owned by stow: $target => $old_source} + ); + return; # XXX # + } + + # does the existing $target actually point to anything + if (-e $old_path) { + # does link points to the right place + if ($old_path eq $path) { + $self->do_unlink($target); + } + + # XXX we quietly ignore links that are stowed to a different + # package. + + #elsif (defer($target)) { + # debug(3, "--- deferring to installation of: $target"); + #} + #elsif ($self->override($target)) { + # debug(3, "--- overriding installation of: $target"); + # $self->do_unlink($target); + #} + #else { + # $self->conflict( + # q{existing target is stowed to a different package: %s => %s}, + # $target, + # $old_source + # ); + #} + } + else { + debug(3, "--- removing invalid link into a stow directory: $path"); + $self->do_unlink($target); + } + } + elsif (-e $target) { + debug(3, "Evaluate existing node: $target"); + if (-d $target) { + $self->unstow_contents($path, $target); + + # this action may have made the parent directory foldable + if (my $parent = $self->foldable($target)) { + $self->fold_tree($target, $parent); + } + } + else { + $self->conflict( + qq{existing target is neither a link nor a directory: $target}, + ); + } + } + else { + debug(3, "$target did not exist to be unstowed"); + } + return; +} + +#===== 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 +# 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 +#============================================================================ +sub find_stowed_path { + my $self = shift; + my ($target, $source) = @_; + + # evaluate softlink relative to its target + my $path = join_paths(parent($target), $source); + debug(4, " is path $path under $self->{stow_path} ?"); + + # search for .stow files + my $dir = ''; + for my $part (split m{/+}, $path) { + $dir = join_paths($dir, $part); + return $path if $self->protected_dir($dir); + } + + # compare with $self->{stow_path} + my @path = split m{/+}, $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 ''; + } + } + + if (@stow_path) { # @path must be empty + debug(4, " no - $path is not under $self->{stow_path}"); + return ''; + } + + debug(4, " yes - in " . join_paths(@path)); + return $path; +} + +#===== METHOD ================================================================ +# Name : cleanup_invalid_links() +# Purpose : clean up invalid links that may block folding +# Parameters: $dir => path to directory to check +# Returns : n/a +# Throws : no exceptions +# Comments : removing files from a stowed package is probably a bad practice +# : so this kind of clean up is not _really_ stow's responsibility; +# : however, failing to clean up can block tree folding, so we'll do +# : it anyway +#============================================================================= +sub cleanup_invalid_links { + my $self = shift; + my ($dir) = @_; + + if (not -d $dir) { + error("cleanup_invalid_links() called with a non-directory: $dir"); + } + + opendir my $DIR, $dir + or error("cannot read directory: $dir"); + my @listing = readdir $DIR; + closedir $DIR; + + NODE: + for my $node (@listing) { + next NODE if $node eq '.'; + next NODE if $node eq '..'; + + my $node_path = join_paths($dir, $node); + + if (-l $node_path and not exists $self->{link_task_for}{$node_path}) { + + # where is the link pointing? + # (dont use read_a_link here) + my $source = readlink($node_path); + if (not $source) { + error("Could not read link $node_path"); + } + + if ( + not -e join_paths($dir, $source) and # bad link + $self->find_stowed_path($node_path, $source) # owned by stow + ){ + debug(3, "--- removing stale link: $node_path => " . + join_paths($dir, $source)); + $self->do_unlink($node_path); + } + } + } + return; +} + + +#===== METHOD =============================================================== +# Name : foldable() +# Purpose : determine if a tree can be folded +# Parameters: $target => path to a directory +# Returns : path to the parent dir iff the tree can be safely folded +# Throws : n/a +# Comments : the path returned is relative to the parent of $target, +# : that is, it can be used as the source for a replacement symlink +#============================================================================ +sub foldable { + my $self = shift; + my ($target) = @_; + + debug(3, "--- Is $target foldable?"); + + opendir my $DIR, $target + or error(qq{Cannot read directory "$target" ($!)\n}); + my @listing = readdir $DIR; + closedir $DIR; + + my $parent = ''; + NODE: + for my $node (@listing) { + + next NODE if $node eq '.'; + next NODE if $node eq '..'; + + my $path = join_paths($target, $node); + + # skip nodes scheduled for removal + next NODE if not $self->is_a_node($path); + + # if its not a link then we can't fold its parent + return '' if not $self->is_a_link($path); + + # where is the link pointing? + my $source = $self->read_a_link($path); + if (not $source) { + error("Could not read link $path"); + } + if ($parent eq '') { + $parent = parent($source) + } + elsif ($parent ne parent($source)) { + return ''; + } + } + return '' if not $parent; + + # if we get here then all nodes inside $target are links, and those links + # point to nodes inside the same directory. + + # chop of leading '..' to get the path to the common parent directory + # relative to the parent of our $target + $parent =~ s{\A\.\./}{}; + + # if the resulting path is owned by stow, we can fold it + if ($self->find_stowed_path($target, $parent)) { + debug(3, "--- $target is foldable"); + return $parent; + } + else { + return ''; + } +} + +#===== METHOD =============================================================== +# Name : fold_tree() +# Purpose : fold the given tree +# Parameters: $source => link to the folded tree source +# : $target => directory that we will replace with a link to $source +# Returns : n/a +# Throws : none +# Comments : only called iff foldable() is true so we can remove some checks +#============================================================================ +sub fold_tree { + my $self = shift; + my ($target, $source) = @_; + + debug(3, "--- Folding tree: $target => $source"); + + opendir my $DIR, $target + or error(qq{Cannot read directory "$target" ($!)\n}); + my @listing = readdir $DIR; + closedir $DIR; + + NODE: + for my $node (@listing) { + next NODE if $node eq '.'; + next NODE if $node eq '..'; + next NODE if not $self->is_a_node(join_paths($target, $node)); + $self->do_unlink(join_paths($target, $node)); + } + $self->do_rmdir($target); + $self->do_link($source, $target); + return; +} + + +#===== METHOD =============================================================== +# Name : conflict() +# Purpose : handle conflicts in stow operations +# Parameters: $format => message printf format +# : @args => paths that conflict +# Returns : n/a +# Throws : fatal exception unless 'conflicts' option is set +# Comments : indicates what type of conflict it is +#============================================================================ +sub conflict { + my $self = shift; + my ($format, @args) = @_; + + my $message = sprintf($format, @args); + + debug(1, "CONFLICT: $message"); + push @{ $self->{conflicts} }, "CONFLICT: $message\n"; + return; +} + +=head2 get_conflicts() + +Returns a list of all potential conflicts discovered. + +=cut + +sub get_conflicts { + my $self = shift; + return @{ $self->{conflicts} }; +} + +=head2 get_tasks() + +Returns a list of all symlink/directory creation/removal tasks. + +=cut + +sub get_tasks { + my $self = shift; + return @{ $self->{tasks} }; +} + +#===== METHOD ================================================================ +# Name : ignore +# Purpose : determine if the given path matches a regex in our ignore list +# Parameters: $path +# Returns : Boolean +# Throws : no exceptions +# Comments : none +#============================================================================= +sub ignore { + my $self = shift; + my ($path) = @_; + + for my $suffix (@{$self->{'ignore'}}) { + return 1 if $path =~ m/$suffix/; + } + return 0; +} + +#===== METHOD ================================================================ +# Name : defer +# Purpose : determine if the given path matches a regex in our defer list +# Parameters: $path +# Returns : Boolean +# Throws : no exceptions +# Comments : none +#============================================================================= +sub defer { + my $self = shift; + my ($path) = @_; + + for my $prefix (@{$self->{'defer'}}) { + return 1 if $path =~ m/$prefix/; + } + return 0; +} + +#===== METHOD ================================================================ +# Name : overide +# Purpose : determine if the given path matches a regex in our override list +# Parameters: $path +# Returns : Boolean +# Throws : no exceptions +# Comments : none +#============================================================================= +sub override { + my $self = shift; + my ($path) = @_; + + for my $regex (@{$self->{'override'}}) { + return 1 if $path =~ m/$regex/; + } + return 0; +} + +############################################################################## +# +# The following code provides the abstractions that allow us to defer operating +# on the filesystem until after all potential conflcits have been assessed. +# +############################################################################## + +#===== METHOD =============================================================== +# Name : process_tasks() +# Purpose : process each task in the tasks list +# Parameters: none +# Returns : n/a +# Throws : fatal error if tasks list is corrupted or a task fails +# Comments : none +#============================================================================ +sub process_tasks { + my $self = shift; + + debug(2, "Processing tasks..."); + + if ($self->{'simulate'}) { + warn "WARNING: simulating so all operations are deferred.\n"; + return; + } + + # strip out all tasks with a skip action + $self->{tasks} = [ grep { $_->{'action'} ne 'skip' } @{ $self->{tasks} } ]; + + if (not @{ $self->{tasks} }) { + warn "There are no outstanding operations to perform.\n"; + return; + } + + $self->within_target_do(sub { + for my $task (@{ $self->{tasks} }) { + $self->process_task($task); + } + }); + + debug(2, "Processing tasks... done"); +} + +#===== METHOD =============================================================== +# Name : process_task() +# Purpose : process a single task +# Parameters: $task => the task to process +# Returns : n/a +# Throws : fatal error if task fails +# Comments : Must run from within target directory. +# : Task involve either creating or deleting dirs and symlinks +# : an action is set to 'skip' if it is found to be redundant +#============================================================================ +sub process_task { + my $self = shift; + my ($task) = @_; + + if ($task->{'action'} eq 'create') { + if ($task->{'type'} eq 'dir') { + mkdir($task->{'path'}, 0777) + or error(qq(Could not create directory: $task->{'path'})); + } + elsif ($task->{'type'} eq 'link') { + symlink $task->{'source'}, $task->{'path'} + or error( + q(Could not create symlink: %s => %s), + $task->{'path'}, + $task->{'source'} + ); + } + else { + internal_error(qq(bad task type: $task->{'type'})); + } + } + elsif ($task->{'action'} eq 'remove') { + if ($task->{'type'} eq 'dir') { + rmdir $task->{'path'} + or error(qq(Could not remove directory: $task->{'path'})); + } + elsif ($task->{'type'} eq 'link') { + unlink $task->{'path'} + or error(qq(Could not remove link: $task->{'path'})); + } + else { + internal_error(qq(bad task type: $task->{'type'})); + } + } + else { + internal_error(qq(bad task action: $task->{'action'})); + } +} + +#===== METHOD =============================================================== +# Name : link_task_action() +# Purpose : finds the link task action for the given path, if there is one +# Parameters: $path +# Returns : 'remove', 'create', or '' if there is no action +# Throws : a fatal exception if an invalid action is found +# Comments : none +#============================================================================ +sub link_task_action { + my $self = shift; + my ($path) = @_; + + if (! exists $self->{link_task_for}{$path}) { + debug(4, " link_task_action($path): no task"); + return ''; + } + + my $action = $self->{link_task_for}{$path}->{'action'}; + internal_error("bad task action: $action") + unless $action eq 'remove' or $action eq 'create'; + + debug(4, " link_task_action($path): link task exists with action $action"); + return $action; +} + +#===== METHOD =============================================================== +# Name : dir_task_action() +# Purpose : finds the dir task action for the given path, if there is one +# Parameters: $path +# Returns : 'remove', 'create', or '' if there is no action +# Throws : a fatal exception if an invalid action is found +# Comments : none +#============================================================================ +sub dir_task_action { + my $self = shift; + my ($path) = @_; + + if (! exists $self->{dir_task_for}{$path}) { + debug(4, " dir_task_action($path): no task"); + return ''; + } + + my $action = $self->{dir_task_for}{$path}->{'action'}; + internal_error("bad task action: $action") + unless $action eq 'remove' or $action eq 'create'; + + debug(4, " dir_task_action($path): dir task exists with action $action"); + return $action; +} + +#===== METHOD =============================================================== +# Name : parent_link_scheduled_for_removal() +# Purpose : determines whether the given path or any parent thereof +# : is a link scheduled for removal +# Parameters: $path +# Returns : Boolean +# Throws : none +# Comments : none +#============================================================================ +sub parent_link_scheduled_for_removal { + my $self = shift; + my ($path) = @_; + + my $prefix = ''; + for my $part (split m{/+}, $path) { + $prefix = join_paths($prefix, $part); + debug(4, " parent_link_scheduled_for_removal($path): prefix $prefix"); + if (exists $self->{link_task_for}{$prefix} and + $self->{link_task_for}{$prefix}->{'action'} eq 'remove') { + debug(4, " parent_link_scheduled_for_removal($path): link scheduled for removal"); + return 1; + } + } + + debug(4, " parent_link_scheduled_for_removal($path): returning false"); + return 0; +} + +#===== METHOD =============================================================== +# Name : is_a_link() +# Purpose : is the given path a current or planned link +# Parameters: $path +# Returns : Boolean +# Throws : none +# Comments : returns false if an existing link is scheduled for removal +# : and true if a non-existent link is scheduled for creation +#============================================================================ +sub is_a_link { + my $self = shift; + my ($path) = @_; + debug(4, " is_a_link($path)"); + + if (my $action = $self->link_task_action($path)) { + if ($action eq 'remove') { + return 0; + } + elsif ($action eq 'create') { + return 1; + } + } + + if (-l $path) { + # check if any of its parent are links scheduled for removal + # (need this for edge case during unfolding) + debug(4, " is_a_link($path): is a real link"); + return $self->parent_link_scheduled_for_removal($path) ? 0 : 1; + } + + debug(4, " is_a_link($path): returning false"); + return 0; +} + +#===== METHOD =============================================================== +# Name : is_a_dir() +# Purpose : is the given path a current or planned directory +# Parameters: $path +# Returns : Boolean +# Throws : none +# Comments : returns false if an existing directory is scheduled for removal +# : and true if a non-existent directory is scheduled for creation +# : we also need to be sure we are not just following a link +#============================================================================ +sub is_a_dir { + my $self = shift; + my ($path) = @_; + debug(4, " is_a_dir($path)"); + + if (my $action = $self->dir_task_action($path)) { + if ($action eq 'remove') { + return 0; + } + elsif ($action eq 'create') { + return 1; + } + } + + return 0 if $self->parent_link_scheduled_for_removal($path); + + if (-d $path) { + debug(4, " is_a_dir($path): real dir"); + return 1; + } + + debug(4, " is_a_dir($path): returning false"); + return 0; +} + +#===== METHOD =============================================================== +# Name : is_a_node() +# Purpose : is the given path a current or planned node +# Parameters: $path +# Returns : Boolean +# Throws : none +# Comments : returns false if an existing node is scheduled for removal +# : true if a non-existent node is scheduled for creation +# : we also need to be sure we are not just following a link +#============================================================================ +sub is_a_node { + my $self = shift; + my ($path) = @_; + debug(4, " is_a_node($path)"); + + my $laction = $self->link_task_action($path); + my $daction = $self->dir_task_action($path); + + if ($laction eq 'remove') { + if ($daction eq 'remove') { + internal_error("removing link and dir: $path"); + return 0; + } + elsif ($daction eq 'create') { + # Assume that we're unfolding $path, and that the link + # removal action is earlier than the dir creation action + # in the task queue. FIXME: is this a safe assumption? + return 1; + } + else { # no dir action + return 0; + } + } + elsif ($laction eq 'create') { + if ($daction eq 'remove') { + # Assume that we're folding $path, and that the dir + # removal action is earlier than the link creation action + # in the task queue. FIXME: is this a safe assumption? + return 1; + } + elsif ($daction eq 'create') { + internal_error("creating link and dir: $path"); + return 1; + } + else { # no dir action + return 1; + } + } + else { + # No link action + if ($daction eq 'remove') { + return 0; + } + elsif ($daction eq 'create') { + return 1; + } + else { # no dir action + # fall through to below + } + } + + return 0 if $self->parent_link_scheduled_for_removal($path); + + if (-e $path) { + debug(4, " is_a_node($path): really exists"); + return 1; + } + + debug(4, " is_a_node($path): returning false"); + return 0; +} + +#===== METHOD =============================================================== +# Name : read_a_link() +# Purpose : return the source of a current or planned link +# Parameters: $path => path to the link target +# Returns : a string +# Throws : fatal exception if the given path is not a current or planned +# : link +# Comments : none +#============================================================================ +sub read_a_link { + my $self = shift; + my ($path) = @_; + + if (my $action = $self->link_task_action($path)) { + debug(4, " read_a_link($path): task exists with action $action"); + + if ($action eq 'create') { + return $self->{link_task_for}{$path}->{'source'}; + } + elsif ($action eq 'remove') { + internal_error( + "read_a_link() passed a path that is scheduled for removal: $path" + ); + } + } + elsif (-l $path) { + debug(4, " read_a_link($path): real link"); + return readlink $path + or error("Could not read link: $path"); + } + internal_error("read_a_link() passed a non link path: $path\n"); +} + +#===== METHOD =============================================================== +# Name : do_link() +# Purpose : wrap 'link' operation for later processing +# Parameters: $oldfile => the existing file to link to +# : $newfile => the file to link +# Returns : n/a +# Throws : error if this clashes with an existing planned operation +# Comments : cleans up operations that undo previous operations +#============================================================================ +sub do_link { + my $self = shift; + my ($oldfile, $newfile) = @_; + + if (exists $self->{dir_task_for}{$newfile}) { + my $task_ref = $self->{dir_task_for}{$newfile}; + + if ($task_ref->{'action'} eq 'create') { + if ($task_ref->{'type'} eq 'dir') { + internal_error( + "new link (%s => %s) clashes with planned new directory", + $newfile, + $oldfile, + ); + } + } + elsif ($task_ref->{'action'} eq 'remove') { + # we may need to remove a directory before creating a link so continue; + } + else { + internal_error("bad task action: $task_ref->{'action'}"); + } + } + + if (exists $self->{link_task_for}{$newfile}) { + my $task_ref = $self->{link_task_for}{$newfile}; + + if ($task_ref->{'action'} eq 'create') { + if ($task_ref->{'source'} ne $oldfile) { + internal_error( + "new link clashes with planned new link: %s => %s", + $task_ref->{'path'}, + $task_ref->{'source'}, + ) + } + else { + debug(1, "LINK: $newfile => $oldfile (duplicates previous action)"); + return; + } + } + elsif ($task_ref->{'action'} eq 'remove') { + if ($task_ref->{'source'} eq $oldfile) { + # no need to remove a link we are going to recreate + debug(1, "LINK: $newfile => $oldfile (reverts previous action)"); + $self->{link_task_for}{$newfile}->{'action'} = 'skip'; + delete $self->{link_task_for}{$newfile}; + return; + } + # we may need to remove a link to replace it so continue + } + else { + internal_error("bad task action: $task_ref->{'action'}"); + } + } + + # creating a new link + debug(1, "LINK: $newfile => $oldfile"); + my $task = { + action => 'create', + type => 'link', + path => $newfile, + source => $oldfile, + }; + push @{ $self->{tasks} }, $task; + $self->{link_task_for}{$newfile} = $task; + + return; +} + +#===== METHOD =============================================================== +# Name : do_unlink() +# Purpose : wrap 'unlink' operation for later processing +# Parameters: $file => the file to unlink +# Returns : n/a +# Throws : error if this clashes with an existing planned operation +# Comments : will remove an existing planned link +#============================================================================ +sub do_unlink { + my $self = shift; + my ($file) = @_; + + if (exists $self->{link_task_for}{$file}) { + my $task_ref = $self->{link_task_for}{$file}; + if ($task_ref->{'action'} eq 'remove') { + debug(1, "UNLINK: $file (duplicates previous action)"); + return; + } + elsif ($task_ref->{'action'} eq 'create') { + # do need to create a link then remove it + debug(1, "UNLINK: $file (reverts previous action)"); + $self->{link_task_for}{$file}->{'action'} = 'skip'; + delete $self->{link_task_for}{$file}; + return; + } + else { + internal_error("bad task action: $task_ref->{'action'}"); + } + } + + if (exists $self->{dir_task_for}{$file} and $self->{dir_task_for}{$file} eq 'create') { + internal_error( + "new unlink operation clashes with planned operation: %s dir %s", + $self->{dir_task_for}{$file}->{'action'}, + $file + ); + } + + # remove the link + #debug(1, "UNLINK: $file (" . (caller())[2] . ")"); + debug(1, "UNLINK: $file"); + + my $source = readlink $file or error("could not readlink $file"); + + my $task = { + action => 'remove', + type => 'link', + path => $file, + source => $source, + }; + push @{ $self->{tasks} }, $task; + $self->{link_task_for}{$file} = $task; + + return; +} + +#===== METHOD =============================================================== +# Name : do_mkdir() +# Purpose : wrap 'mkdir' operation +# Parameters: $dir => the directory to remove +# Returns : n/a +# Throws : fatal exception if operation fails +# Comments : outputs a message if 'verbose' option is set +# : does not perform operation if 'simulate' option is set +# Comments : cleans up operations that undo previous operations +#============================================================================ +sub do_mkdir { + my $self = shift; + my ($dir) = @_; + + if (exists $self->{link_task_for}{$dir}) { + my $task_ref = $self->{link_task_for}{$dir}; + + if ($task_ref->{'action'} eq 'create') { + internal_error( + "new dir clashes with planned new link (%s => %s)", + $task_ref->{'path'}, + $task_ref->{'source'}, + ); + } + elsif ($task_ref->{'action'} eq 'remove') { + # may need to remove a link before creating a directory so continue + } + else { + internal_error("bad task action: $task_ref->{'action'}"); + } + } + + if (exists $self->{dir_task_for}{$dir}) { + my $task_ref = $self->{dir_task_for}{$dir}; + + if ($task_ref->{'action'} eq 'create') { + debug(1, "MKDIR: $dir (duplicates previous action)"); + return; + } + elsif ($task_ref->{'action'} eq 'remove') { + debug(1, "MKDIR: $dir (reverts previous action)"); + $self->{dir_task_for}{$dir}->{'action'} = 'skip'; + delete $self->{dir_task_for}{$dir}; + return; + } + else { + internal_error("bad task action: $task_ref->{'action'}"); + } + } + + debug(1, "MKDIR: $dir"); + my $task = { + action => 'create', + type => 'dir', + path => $dir, + source => undef, + }; + push @{ $self->{tasks} }, $task; + $self->{dir_task_for}{$dir} = $task; + + return; +} + +#===== METHOD =============================================================== +# Name : do_rmdir() +# Purpose : wrap 'rmdir' operation +# Parameters: $dir => the directory to remove +# Returns : n/a +# Throws : fatal exception if operation fails +# Comments : outputs a message if 'verbose' option is set +# : does not perform operation if 'simulate' option is set +#============================================================================ +sub do_rmdir { + my $self = shift; + my ($dir) = @_; + + if (exists $self->{link_task_for}{$dir}) { + my $task_ref = $self->{link_task_for}{$dir}; + internal_error( + "rmdir clashes with planned operation: %s link %s => %s", + $task_ref->{'action'}, + $task_ref->{'path'}, + $task_ref->{'source'} + ); + } + + if (exists $self->{dir_task_for}{$dir}) { + my $task_ref = $self->{link_task_for}{$dir}; + + if ($task_ref->{'action'} eq 'remove') { + debug(1, "RMDIR $dir (duplicates previous action)"); + return; + } + elsif ($task_ref->{'action'} eq 'create') { + debug(1, "MKDIR $dir (reverts previous action)"); + $self->{link_task_for}{$dir}->{'action'} = 'skip'; + delete $self->{link_task_for}{$dir}; + return; + } + else { + internal_error("bad task action: $task_ref->{'action'}"); + } + } + + debug(1, "RMDIR $dir"); + my $task = { + action => 'remove', + type => 'dir', + path => $dir, + source => '', + }; + push @{ $self->{tasks} }, $task; + $self->{dir_task_for}{$dir} = $task; + + return; +} + + +############################################################################# +# +# End of methods; subroutines follow. +# FIXME: Ideally these should be in a separate module. + + +#===== PRIVATE SUBROUTINE =================================================== +# Name : internal_error() +# Purpose : output internal error message in a consistent form and die +# Parameters: $message => error message to output +# Returns : n/a +# Throws : n/a +# Comments : none +#============================================================================ +sub internal_error { + my ($format, @args) = @_; + die "$ProgramName: INTERNAL ERROR: " . sprintf($format, @args) . "\n", + "This _is_ a bug. Please submit a bug report so we can fix it:-)\n"; +} + +=head1 BUGS + +=head1 SEE ALSO + +=cut + +1; + +# Local variables: +# mode: perl +# cperl-indent-level: 4 +# end: +# vim: ft=perl diff --git a/lib/Stow/Util.pm b/lib/Stow/Util.pm new file mode 100644 index 0000000..0effc35 --- /dev/null +++ b/lib/Stow/Util.pm @@ -0,0 +1,202 @@ +package Stow::Util; + +=head1 NAME + +Stow::Util - general utilities + +=head1 SYNOPSIS + + use Stow::Util qw(debug set_debug_level error ...); + +=head1 DESCRIPTION + +Supporting utility routines for L. + +=cut + +use strict; +use warnings; + +use POSIX qw(getcwd); + +use base qw(Exporter); +our @EXPORT_OK = qw( + error debug set_debug_level set_test_mode + join_paths parent canon_path restore_cwd +); + +our $ProgramName = 'stow'; + +############################################################################# +# +# General Utilities: nothing stow specific here. +# +############################################################################# + +=head1 IMPORTABLE SUBROUTINES + +=head2 error($format, @args) + +Outputs an error message in a consistent form and then dies. + +=cut + +sub error { + my ($format, @args) = @_; + die "$ProgramName: ERROR: " . sprintf($format, @args) . " ($!)\n"; +} + +=head2 set_debug_level($level) + +Sets verbosity level for C. + +=cut + +our $debug_level = 0; + +sub set_debug_level { + my ($level) = @_; + $debug_level = $level; +} + +=head2 set_test_mode($on_or_off) + +Sets testmode on or off. + +=cut + +our $test_mode = 0; + +sub set_test_mode { + my ($on_or_off) = @_; + if ($on_or_off) { + $test_mode = 1; + } + else { + $test_mode = 0; + } +} + +=head2 debug($level, $msg) + +Logs to STDERR based on C<$debug_level> setting. C<$level> is the +minimum verbosity level required to output C<$msg>. All output is to +STDERR to preserve backward compatibility, except for in test mode, +when STDOUT is used instead. In test mode, the verbosity can be +overridden via the C environment variable. + +Verbosity rules: + +=over 4 + +=item 0: errors only + +=item >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR + +=item >= 2: print trace: stow/unstow package/contents/node + +=item >= 3: print trace detail: "_this_ already points to _that_" + +=item >= 4: debug helper routines + +=back + +=cut + +sub debug { + my ($level, $msg) = @_; + if ($debug_level >= $level) { + if ($test_mode) { + print "# $msg\n"; + } + else { + warn "$msg\n"; + } + } +} + +#===== METHOD =============================================================== +# Name : join_paths() +# Purpose : concatenates given paths +# Parameters: path1, path2, ... => paths +# Returns : concatenation of given paths +# Throws : n/a +# Comments : factors out redundant path elements: +# : '//' => '/' and 'a/b/../c' => 'a/c' +#============================================================================ +sub join_paths { + my @paths = @_; + + # weed out empty components and concatenate + my $result = join '/', grep {!/\A\z/} @paths; + + # factor out back references and remove redundant /'s) + my @result = (); + PART: + for my $part (split m{/+}, $result) { + next PART if $part eq '.'; + if (@result && $part eq '..' && $result[-1] ne '..') { + pop @result; + } + else { + push @result, $part; + } + } + + return join '/', @result; +} + +#===== METHOD =============================================================== +# Name : parent +# Purpose : find the parent of the given path +# Parameters: @path => components of the path +# Returns : returns a path string +# Throws : n/a +# Comments : allows you to send multiple chunks of the path +# : (this feature is currently not used) +#============================================================================ +sub parent { + my @path = @_; + my $path = join '/', @_; + my @elts = split m{/+}, $path; + pop @elts; + return join '/', @elts; +} + +#===== METHOD =============================================================== +# Name : canon_path +# Purpose : find absolute canonical path of given path +# Parameters: $path +# Returns : absolute canonical path +# Throws : n/a +# Comments : is this significantly different from File::Spec->rel2abs? +#============================================================================ +sub canon_path { + my ($path) = @_; + + my $cwd = getcwd(); + chdir($path) or error("canon_path: cannot chdir to $path from $cwd"); + my $canon_path = getcwd(); + restore_cwd($cwd); + + return $canon_path; +} + +sub restore_cwd { + my ($prev) = @_; + chdir($prev) or error("Your current directory $prev seems to have vanished"); +} + +=head1 BUGS + +=head1 SEE ALSO + +=cut + +1; + +# Local variables: +# mode: perl +# cperl-indent-level: 4 +# end: +# vim: ft=perl diff --git a/stow.in b/stow.in index df58cc8..34cb13a 100755 --- a/stow.in +++ b/stow.in @@ -24,272 +24,170 @@ use warnings; require 5.6.1; -use File::Spec; use POSIX qw(getcwd); use Getopt::Long; -my $Version = '@VERSION@'; +use Stow; +use Stow::Util qw(parent); + my $ProgramName = $0; $ProgramName =~ s{.*/}{}; -# Verbosity rules: -# -# 0: errors only -# >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR -# >= 2: print trace: stow/unstow package/contents/node -# >= 3: print trace detail: "_this_ already points to _that_" -# >= 4: debug helper routines -# -# All output (except for version() and usage()) is to stderr to preserve -# backward compatibility. +main() unless caller(); -# These are the defaults for command line options -our %Option = ( - help => 0, - conflicts => 0, - action => 'stow', - simulate => 0, - verbose => 0, - paranoid => 0, - dir => undef, - target => undef, - ignore => [], - override => [], - defer => [], -); +sub main { + my ($options, $pkgs_to_unstow, $pkgs_to_stow) = process_options(); -# This becomes static after option processing -our $Stow_Path; # only use in main loop and find_stowed_path() - -# Store conflicts during pre-processing -our @Conflicts = (); - -# Store command line packages to stow (-S and -R) -our @Pkgs_To_Stow = (); - -# Store command line packages to unstow (-D and -R) -our @Pkgs_To_Delete = (); - -# The following structures are used by the abstractions that allow us to -# defer operating on the filesystem until after all potential conflicts have -# been assessed. - -# our @Tasks: list of operations to be performed (in order) -# each element is a hash ref of the form -# { -# action => ... -# type => ... -# path => ... (unique) -# source => ... (only for links) -# } -our @Tasks = (); - -# my %Dir_Task_For: map a path to the corresponding directory task reference -# This structure allows us to quickly determine if a path has an existing -# directory task associated with it. -our %Dir_Task_For = (); - -# my %Link_Task_For: map a path to the corresponding directory task reference -# This structure allows us to quickly determine if a path has an existing -# directory task associated with it. -our %Link_Task_For = (); - -# N.B.: directory tasks and link tasks are NOT mutually exclusive due -# to tree splitting (which involves a remove link task followed by -# a create directory task). - -# put the main loop in this block so we can load the -# rest of the code as a module for testing -if (not caller()) { - - process_options(); - set_stow_path(); - + my $stow = new Stow(%$options); # current dir is now the target directory - - for my $package (@Pkgs_To_Delete) { - if (not -d join_paths($Stow_Path, $package)) { - error("The given package name ($package) is not in your stow path"); - } - debug(2, "Unstowing package $package..."); - if ($Option{'compat'}) { - unstow_contents_orig( - join_paths($Stow_Path, $package), # path to package - '.', # target is current_dir - ); - } - else { - unstow_contents( - join_paths($Stow_Path, $package), # path to package - '.', # target is current_dir - ); - } - debug(2, "Unstowing package $package... done"); - } - for my $package (@Pkgs_To_Stow) { - if (not -d join_paths($Stow_Path, $package)) { - error("The given package name ($package) is not in your stow path"); - } - debug(2, "Stowing package $package..."); - stow_contents( - join_paths($Stow_Path, $package), # path package - '.', # target is current dir - join_paths($Stow_Path, $package), # source from target - ); - debug(2, "Stowing package $package... done"); - } + $stow->plan_unstow(@$pkgs_to_unstow); + $stow->plan_stow (@$pkgs_to_stow); + + my @conflicts = $stow->get_conflicts; # --verbose: tell me what you are planning to do # --simulate: don't execute planned operations # --conflicts: just list any detected conflicts - if (scalar @Conflicts) { + if (scalar @conflicts) { warn "WARNING: conflicts detected.\n"; - if ($Option{'conflicts'}) { - map { warn $_ } @Conflicts; + if ($options->{'conflicts'}) { + map { warn $_ } @conflicts; } warn "WARNING: all operations aborted.\n"; } else { - process_tasks(); + $stow->process_tasks(); } } #===== SUBROUTINE =========================================================== # Name : process_options() -# Purpose : parse command line options and update the %Option hash +# Purpose : parse command line options # Parameters: none -# Returns : n/a +# Returns : (\%options, \@pkgs_to_unstow, \@pkgs_to_stow) # Throws : a fatal error if a bad command line option is given # Comments : checks @ARGV for valid package names #============================================================================ sub process_options { - get_defaults(); + my %options = (); + my @pkgs_to_unstow = (); + my @pkgs_to_stow = (); + my $action = 'stow'; + + unshift @ARGV, get_config_file_options(); #$,="\n"; print @ARGV,"\n"; # for debugging rc file Getopt::Long::config('no_ignore_case', 'bundling', 'permute'); GetOptions( - \%Option, + \%options, 'verbose|v:+', 'help|h', 'simulate|n|no', 'conflicts|c', 'version|V', 'compat|p', 'dir|d=s', 'target|t=s', # clean and pre-compile any regex's at parse time 'ignore=s' => - sub { + sub { + # FIXME: do we really need strip_quotes here? my $regex = strip_quotes($_[1]); - push @{$Option{'ignore'}}, qr($regex\z) + push @{$options{'ignore'}}, qr($regex\z); }, 'override=s' => sub { my $regex = strip_quotes($_[1]); - push @{$Option{'override'}}, qr(\A$regex) + push @{$options{'override'}}, qr(\A$regex); }, 'defer=s' => sub { my $regex = strip_quotes($_[1]); - push @{$Option{'defer'}}, qr(\A$regex) ; + push @{$options{'defer'}}, qr(\A$regex); }, # a little craziness so we can do different actions on the same line: # a -D, -S, or -R changes the action that will be performed on the # package arguments that follow it. - 'D|delete' => sub { $Option{'action'} = 'delete' }, - 'S|stow' => sub { $Option{'action'} = 'stow' }, - 'R|restow' => sub { $Option{'action'} = 'restow' }, + 'D|delete' => sub { $action = 'unstow' }, + 'S|stow' => sub { $action = 'stow' }, + 'R|restow' => sub { $action = 'restow' }, + + # Handler for non-option arguments '<>' => sub { - if ($Option{'action'} eq 'restow') { - push @Pkgs_To_Delete, $_[0]; - push @Pkgs_To_Stow, $_[0]; + if ($action eq 'restow') { + push @pkgs_to_unstow, $_[0]; + push @pkgs_to_stow, $_[0]; } - elsif ($Option{'action'} eq 'delete') { - push @Pkgs_To_Delete, $_[0]; + elsif ($action eq 'unstow') { + push @pkgs_to_unstow, $_[0]; } else { - push @Pkgs_To_Stow, $_[0]; + push @pkgs_to_stow, $_[0]; } }, ) or usage(); - #print "$Option{'dir'}\n"; print "$Option{'target'}\n"; exit; + usage() if $options{'help'}; + version() if $options{'version'}; - # clean any leading and trailing whitespace in paths - if ($Option{'dir'}) { - $Option{'dir'} =~ s/\A +//; - $Option{'dir'} =~ s/ +\z//; + sanitize_path_options(\%options); + check_packages(\@pkgs_to_unstow, \@pkgs_to_stow); + + return (\%options, \@pkgs_to_unstow, \@pkgs_to_stow); +} + +sub sanitize_path_options { + my ($options) = @_; + + if (exists $options->{'dir'}) { + $options->{'dir'} =~ s/\A +//; + $options->{'dir'} =~ s/ +\z//; } - if ($Option{'target'}) { - $Option{'target'} =~ s/\A +//; - $Option{'target'} =~ s/ +\z//; + else { + $options->{'dir'} = exists $ENV{STOW_DIR} ? $ENV{STOW_DIR} : getcwd(); } - if ($Option{'help'}) { - usage(); - } - if ($Option{'version'}) { - version(); + if (exists $options->{'target'}) { + $options->{'target'} =~ s/\A +//; + $options->{'target'} =~ s/ +\z//; } - if ($Option{'conflicts'}) { - $Option{'simulate'} = 1; + else { + $options->{'target'} = parent($options->{'dir'}); } +} - if (not scalar @Pkgs_To_Stow and not scalar @Pkgs_To_Delete) { - usage("No packages named"); +sub check_packages { + my ($pkgs_to_stow, $pkgs_to_unstow) = @_; + + if (not @$pkgs_to_stow and not @$pkgs_to_unstow) { + usage("No packages to stow or unstow"); } # check package arguments - for my $package ((@Pkgs_To_Stow, @Pkgs_To_Delete)) { + for my $package (@$pkgs_to_stow, @$pkgs_to_unstow) { $package =~ s{/+$}{}; # delete trailing slashes if ($package =~ m{/}) { error("Slashes are not permitted in package names"); } } - - return; } -#===== SUBROUTINE ============================================================ -# Name : debug() -# Purpose : log to STDERR based on verbosity setting -# Parameters: $level => minimum verbosity level required to output this message -# : $msg => the message -# Returns : n/a -# Throws : no exceptions -# Comments : none -#============================================================================= -sub debug { - my ($level, $msg) = @_; - if ($Option{'testmode'}) { - # Convert TEST_VERBOSE=y into numeric value - $ENV{TEST_VERBOSE} = 3 - if $ENV{TEST_VERBOSE} && $ENV{TEST_VERBOSE} !~ /^\d+$/; - - my $verbose = exists $Option{'verbose'} ? $Option{'verbose'} : - length $ENV{TEST_VERBOSE} ? $ENV{TEST_VERBOSE} : 0; - print "# $msg\n" if $verbose >= $level; - } - elsif ($Option{'verbose'} >= $level) { - warn "$msg\n"; - } -} #===== SUBROUTINE ============================================================ -# Name : get_defaults() -# Purpose : search for default settings in any .stow files +# Name : get_config_file_options() +# Purpose : search for default settings in any .stowrc files # Parameters: none -# Returns : n/a +# Returns : a list of default options # Throws : no exceptions -# Comments : prepends the contents '~/.stowrc' and '.stowrc' to the command +# Comments : prepends the contents of '~/.stowrc' and '.stowrc' to the command # : line so they get parsed just like normal arguments. (This was # : hacked in so that Emil and I could set different preferences). #============================================================================= -sub get_defaults { +sub get_config_file_options { my @defaults = (); - for my $file ($ENV{'HOME'}.'/.stowrc', '.stowrc') { + for my $file ("$ENV{'HOME'}/.stowrc", '.stowrc') { if (-r $file) { warn "Loading defaults from $file\n"; open my $FILE, '<', $file @@ -301,9 +199,7 @@ sub get_defaults { close $FILE or die "Could not close open file: $file\n"; } } - # doing this inline does not seem to work - unshift @ARGV, @defaults; - return; + return @defaults; } #===== SUBROUTINE =========================================================== @@ -322,7 +218,7 @@ sub usage { } print <<"EOT"; -$ProgramName (GNU Stow) version $Version +$ProgramName (GNU Stow) version $Stow::VERSION SYNOPSIS: @@ -350,1317 +246,15 @@ OPTIONS: -V, --version Show stow version number -h, --help Show this help EOT - exit $msg ? 1 : 0; + exit defined $msg ? 1 : 0; } -#===== SUBROUTINE =========================================================== -# Name : set_stow_path() -# Purpose : find the relative path to the stow directory -# Parameters: none -# Returns : a relative path -# Throws : fatal error if either default directories or those set by the -# : the command line flags are not valid. -# Comments : This sets the current working directory to $Option{target} -#============================================================================ -sub set_stow_path { - # Changing dirs helps a lot when soft links are used - # Also prevents problems when 'stow_dir' or 'target' are - # supplied as relative paths (FIXME: examples?) - - my $current_dir = getcwd(); - - # default stow dir is $STOW_DIR if set, otherwise the current - # directory - if (not $Option{'dir'}) { - $Option{'dir'} = exists $ENV{STOW_DIR} ? $ENV{STOW_DIR} : getcwd(); - } - if (not chdir($Option{'dir'})) { - error("Cannot chdir to target tree: '$Option{'dir'}'"); - } - my $stow_dir = getcwd(); - - # back to start in case target is relative - if (not chdir($current_dir)) { - error("Your directory does not seem to exist anymore"); - } - - # default target is the parent of the stow directory - if (not $Option{'target'}) { - $Option{'target'} = parent($Option{'dir'}); - } - if (not chdir($Option{'target'})) { - error("Cannot chdir to target tree: $Option{'target'}"); - } - - # set our one global - $Stow_Path = File::Spec->abs2rel($stow_dir); - - debug(2, "current dir is " . getcwd()); - debug(2, "stow dir path relative to cwd is $Stow_Path"); +sub version { + print "$ProgramName (GNU Stow) version $Stow::VERSION\n"; + exit 0; } -#===== SUBROUTINE =========================================================== -# 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 -# Returns : n/a -# Throws : a fatal error if directory cannot be read -# 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 ($path, $target, $source) = @_; - - return if should_skip_stow_dir_target($target); - - my $cwd = getcwd(); - my $msg = "Stowing contents of $path (cwd=$cwd, stow dir=$Stow_Path)"; - $msg =~ s!$ENV{HOME}/!~/!g; - debug(2, $msg); - debug(3, "--- $target => $source"); - - error("stow_contents() called with non-directory path: $path") - unless -d $path; - error("stow_contents() called with non-directory target: $target") - unless is_a_node($target); - - opendir my $DIR, $path - or error("cannot read directory: $path"); - my @listing = readdir $DIR; - closedir $DIR; - - NODE: - for my $node (@listing) { - next NODE if $node eq '.'; - next NODE if $node eq '..'; - next NODE if ignore($node); - stow_node( - join_paths($path, $node), # path - join_paths($target, $node), # target - join_paths($source, $node), # source - ); - } -} - -#===== SUBROUTINE =========================================================== -# 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 -# : $source => relative path to symlink source from the dir of target -# Returns : n/a -# Throws : fatal exception if a conflict arises -# 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_node { - my ($path, $target, $source) = @_; - - debug(2, "Stowing from $path"); - debug(3, "--- $target => $source"); - - # don't try to stow absolute symlinks (they can't be unstowed) - if (-l $source) { - my $second_source = read_a_link($source); - if ($second_source =~ m{\A/}) { - conflict("source is an absolute symlink $source => $second_source"); - debug(3, "absolute symlinks cannot be unstowed"); - return; - } - } - - # does the target already exist? - if (is_a_link($target)) { - - # where is the link pointing? - my $old_source = read_a_link($target); - if (not $old_source) { - error("Could not read link: $target"); - } - debug(3, "--- Evaluate existing link: $target => $old_source"); - - # does it point to a node under our stow directory? - my $old_path = find_stowed_path($target, $old_source); - if (not $old_path) { - conflict("existing target is not owned by stow: $target"); - return; # XXX # - } - - # does the existing $target actually point to anything? - if (is_a_node($old_path)) { - if ($old_source eq $source) { - debug(3, "--- Skipping $target as it already points to $source"); - } - elsif (defer($target)) { - debug(3, "--- deferring installation of: $target"); - } - elsif (override($target)) { - debug(3, "--- overriding installation of: $target"); - do_unlink($target); - do_link($source, $target); - } - elsif (is_a_dir(join_paths(parent($target), $old_source)) && - is_a_dir(join_paths(parent($target), $source)) ) { - - # if the existing 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 - - debug(3, "--- Unfolding $target"); - do_unlink($target); - do_mkdir($target); - stow_contents($old_path, $target, join_paths('..', $old_source)); - stow_contents($path, $target, join_paths('..', $source)); - } - else { - conflict( - q{existing target is stowed to a different package: %s => %s}, - $target, - $old_source, - ); - } - } - else { - # the existing link is invalid, so replace it with a good link - debug(3, "--- replacing invalid link: $path"); - do_unlink($target); - do_link($source, $target); - } - } - elsif (is_a_node($target)) { - debug(3, "--- Evaluate existing node: $target"); - if (is_a_dir($target)) { - stow_contents($path, $target, join_paths('..', $source)); - } - else { - conflict( - qq{existing target is neither a link nor a directory: $target} - ); - } - } - else { - do_link($source, $target); - } - return; -} - -#===== SUBROUTINE =========================================================== -# Name : should_skip_stow_dir_target() -# Purpose : determine whether target is a stow directory and should be skipped -# Parameters: $target => relative path to symlink target from the current directory -# Returns : true iff target is a stow directory -# Throws : n/a -# Comments : none -#============================================================================ -sub should_skip_stow_dir_target { - my ($target) = @_; - - # don't try to remove anything under a stow directory - if ($target eq $Stow_Path) { - debug(2, "Skipping target which was current stow directory $target"); - return 1; - } - for my $f (".stow", ".nonstow") { - if (-e join_paths($target, $f)) { - debug(2, "Skipping $target which contained $f"); - return 1; - } - } - - debug (4, "$target not protected"); - return 0; -} - -#===== SUBROUTINE =========================================================== -# Name : unstow_contents_orig() -# Purpose : unstow 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 -# Returns : n/a -# Throws : a fatal error if directory cannot be read -# Comments : unstow_node_orig() and unstow_contents_orig() are mutually recursive -# : Here we traverse the target tree, rather than the source tree. -#============================================================================ -sub unstow_contents_orig { - my ($path, $target) = @_; - - return if should_skip_stow_dir_target($target); - - my $cwd = getcwd(); - my $msg = "Unstowing from $target (compat mode, cwd=$cwd, stow dir=$Stow_Path)"; - $msg =~ s!$ENV{HOME}/!~/!g; - debug(2, $msg); - debug(3, "--- source path is $path"); - # In compat mode we traverse the target tree not the source tree, - # so we're unstowing the contents of /target/foo, there's no - # guarantee that the corresponding /stow/mypkg/foo exists. - error("unstow_contents_orig() called with non-directory target: $target") - unless -d $target; - - opendir my $DIR, $target - or error("cannot read directory: $target"); - my @listing = readdir $DIR; - closedir $DIR; - - NODE: - for my $node (@listing) { - next NODE if $node eq '.'; - next NODE if $node eq '..'; - next NODE if ignore($node); - unstow_node_orig( - join_paths($path, $node), # path - join_paths($target, $node), # target - ); - } -} - -#===== SUBROUTINE =========================================================== -# Name : unstow_node_orig() -# Purpose : unstow the given node -# Parameters: $path => relative path to source node from the current directory -# : $target => relative path to symlink target from the current directory -# Returns : n/a -# Throws : fatal error if a conflict arises -# Comments : unstow_node() and unstow_contents() are mutually recursive -#============================================================================ -sub unstow_node_orig { - my ($path, $target) = @_; - - debug(2, "Unstowing $target (compat mode)"); - debug(3, "--- source path is $path"); - - # does the target exist - if (is_a_link($target)) { - debug(3, "Evaluate existing link: $target"); - - # where is the link pointing? - my $old_source = read_a_link($target); - if (not $old_source) { - error("Could not read link: $target"); - } - - # does it point to a node under our stow directory? - my $old_path = find_stowed_path($target, $old_source); - if (not $old_path) { - # skip links not owned by stow - return; # XXX # - } - - # does the existing $target actually point to anything? - if (-e $old_path) { - # does link point to the right place? - if ($old_path eq $path) { - do_unlink($target); - } - elsif (override($target)) { - debug(3, "--- overriding installation of: $target"); - do_unlink($target); - } - # else leave it alone - } - else { - debug(3, "--- removing invalid link into a stow directory: $path"); - do_unlink($target); - } - } - elsif (-d $target) { - unstow_contents_orig($path, $target); - - # this action may have made the parent directory foldable - if (my $parent = foldable($target)) { - fold_tree($target, $parent); - } - } - elsif (-e $target) { - conflict( - qq{existing target is neither a link nor a directory: $target}, - ); - } - else { - debug(3, "$target did not exist to be unstowed"); - } - return; -} - -#===== SUBROUTINE =========================================================== -# Name : unstow_contents() -# Purpose : unstow 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 -# Returns : n/a -# Throws : a fatal error if directory cannot be read -# Comments : unstow_node() and unstow_contents() are mutually recursive -# : Here we traverse the source tree, rather than the target tree. -#============================================================================ -sub unstow_contents { - my ($path, $target) = @_; - - return if should_skip_stow_dir_target($target); - - my $cwd = getcwd(); - my $msg = "Unstowing from $target (cwd=$cwd, stow dir=$Stow_Path)"; - $msg =~ s!$ENV{HOME}/!~/!g; - debug(2, $msg); - debug(3, "--- source path is $path"); - # We traverse the source tree not the target tree, so $path must exist. - error("unstow_contents() called with non-directory path: $path") - unless -d $path; - # When called at the top level, $target should exist. And - # unstow_node() should only call this via mutual recursion if - # $target exists. - error("unstow_contents() called with invalid target: $target") - unless is_a_node($target); - - opendir my $DIR, $path - or error("cannot read directory: $path"); - my @listing = readdir $DIR; - closedir $DIR; - - NODE: - for my $node (@listing) { - next NODE if $node eq '.'; - next NODE if $node eq '..'; - next NODE if ignore($node); - unstow_node( - join_paths($path, $node), # path - join_paths($target, $node), # target - ); - } - if (-d $target) { - cleanup_invalid_links($target); - } -} - -#===== SUBROUTINE =========================================================== -# Name : unstow_node() -# Purpose : unstow the given node -# Parameters: $path => relative path to source node from the current directory -# : $target => relative path to symlink target from the current directory -# Returns : n/a -# Throws : fatal error if a conflict arises -# Comments : unstow_node() and unstow_contents() are mutually recursive -#============================================================================ -sub unstow_node { - my ($path, $target) = @_; - - debug(2, "Unstowing $path"); - debug(3, "--- target is $target"); - - # does the target exist - if (is_a_link($target)) { - debug(3, "Evaluate existing link: $target"); - - # where is the link pointing? - my $old_source = read_a_link($target); - if (not $old_source) { - error("Could not read link: $target"); - } - - if ($old_source =~ m{\A/}) { - warn "ignoring a absolute symlink: $target => $old_source\n"; - return; # XXX # - } - - # does it point to a node under our stow directory? - my $old_path = find_stowed_path($target, $old_source); - if (not $old_path) { - conflict( - qq{existing target is not owned by stow: $target => $old_source} - ); - return; # XXX # - } - - # does the existing $target actually point to anything - if (-e $old_path) { - # does link points to the right place - if ($old_path eq $path) { - do_unlink($target); - } - - # XXX we quietly ignore links that are stowed to a different - # package. - - #elsif (defer($target)) { - # debug(3, "--- deferring to installation of: $target"); - #} - #elsif (override($target)) { - # debug(3, "--- overriding installation of: $target"); - # do_unlink($target); - #} - #else { - # conflict( - # q{existing target is stowed to a different package: %s => %s}, - # $target, - # $old_source - # ); - #} - } - else { - debug(3, "--- removing invalid link into a stow directory: $path"); - do_unlink($target); - } - } - elsif (-e $target) { - debug(3, "Evaluate existing node: $target"); - if (-d $target) { - unstow_contents($path, $target); - - # this action may have made the parent directory foldable - if (my $parent = foldable($target)) { - fold_tree($target, $parent); - } - } - else { - conflict( - qq{existing target is neither a link nor a directory: $target}, - ); - } - } - else { - debug(3, "$target did not exist to be unstowed"); - } - return; -} - -#===== SUBROUTINE =========================================================== -# 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 -# 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 -#============================================================================ -sub find_stowed_path { - my ($target, $source) = @_; - - # evaluate softlink relative to its target - my $path = join_paths(parent($target), $source); - - # search for .stow files - my $dir = ''; - for my $part (split m{/+}, $path) { - $dir = join_paths($dir, $part); - if (-f "$dir/.stow") { - return $path; - } - } - - # compare with $Stow_Path - my @path = split m{/+}, $path; - my @stow_path = split m{/+}, $Stow_Path; - - # strip off common prefixes - while (@path && @stow_path) { - if ((shift @path) ne (shift @stow_path)) { - return ''; - } - } - if (@stow_path) { - # @path is not under @stow_dir - return ''; - } - - return $path -} - -#===== SUBROUTINE ============================================================ -# Name : cleanup_invalid_links() -# Purpose : clean up invalid links that may block folding -# Parameters: $dir => path to directory to check -# Returns : n/a -# Throws : no exceptions -# Comments : removing files from a stowed package is probably a bad practice -# : so this kind of clean up is not _really_ stow's responsibility; -# : however, failing to clean up can block tree folding, so we'll do -# : it anyway -#============================================================================= -sub cleanup_invalid_links { - my ($dir) = @_; - - if (not -d $dir) { - error("cleanup_invalid_links() called with a non-directory: $dir"); - } - - opendir my $DIR, $dir - or error("cannot read directory: $dir"); - my @listing = readdir $DIR; - closedir $DIR; - - NODE: - for my $node (@listing) { - next NODE if $node eq '.'; - next NODE if $node eq '..'; - - my $node_path = join_paths($dir, $node); - - if (-l $node_path and not exists $Link_Task_For{$node_path}) { - - # where is the link pointing? - # (dont use read_a_link here) - my $source = readlink($node_path); - if (not $source) { - error("Could not read link $node_path"); - } - - if ( - not -e join_paths($dir, $source) and # bad link - find_stowed_path($node_path, $source) # owned by stow - ){ - debug(3, "--- removing stale link: $node_path => " . - join_paths($dir, $source)); - do_unlink($node_path); - } - } - } - return; -} - - -#===== SUBROUTINE =========================================================== -# Name : foldable() -# Purpose : determine if a tree can be folded -# Parameters: $target => path to a directory -# Returns : path to the parent dir iff the tree can be safely folded -# Throws : n/a -# Comments : the path returned is relative to the parent of $target, -# : that is, it can be used as the source for a replacement symlink -#============================================================================ -sub foldable { - my ($target) = @_; - - debug(3, "--- Is $target foldable?"); - - opendir my $DIR, $target - or error(qq{Cannot read directory "$target" ($!)\n}); - my @listing = readdir $DIR; - closedir $DIR; - - my $parent = ''; - NODE: - for my $node (@listing) { - - next NODE if $node eq '.'; - next NODE if $node eq '..'; - - my $path = join_paths($target, $node); - - # skip nodes scheduled for removal - next NODE if not is_a_node($path); - - # if its not a link then we can't fold its parent - return '' if not is_a_link($path); - - # where is the link pointing? - my $source = read_a_link($path); - if (not $source) { - error("Could not read link $path"); - } - if ($parent eq '') { - $parent = parent($source) - } - elsif ($parent ne parent($source)) { - return ''; - } - } - return '' if not $parent; - - # if we get here then all nodes inside $target are links, and those links - # point to nodes inside the same directory. - - # chop of leading '..' to get the path to the common parent directory - # relative to the parent of our $target - $parent =~ s{\A\.\./}{}; - - # if the resulting path is owned by stow, we can fold it - if (find_stowed_path($target, $parent)) { - debug(3, "--- $target is foldable"); - return $parent; - } - else { - return ''; - } -} - -#===== SUBROUTINE =========================================================== -# Name : fold_tree() -# Purpose : fold the given tree -# Parameters: $source => link to the folded tree source -# : $target => directory that we will replace with a link to $source -# Returns : n/a -# Throws : none -# Comments : only called iff foldable() is true so we can remove some checks -#============================================================================ -sub fold_tree { - my ($target, $source) = @_; - - debug(3, "--- Folding tree: $target => $source"); - - opendir my $DIR, $target - or error(qq{Cannot read directory "$target" ($!)\n}); - my @listing = readdir $DIR; - closedir $DIR; - - NODE: - for my $node (@listing) { - next NODE if $node eq '.'; - next NODE if $node eq '..'; - next NODE if not is_a_node(join_paths($target, $node)); - do_unlink(join_paths($target, $node)); - } - do_rmdir($target); - do_link($source, $target); - return; -} - - -#===== SUBROUTINE =========================================================== -# Name : conflict() -# Purpose : handle conflicts in stow operations -# Parameters: $format => message printf format -# : @args => paths that conflict -# Returns : n/a -# Throws : fatal exception unless 'conflicts' option is set -# Comments : indicates what type of conflict it is -#============================================================================ -sub conflict { - my ($format, @args) = @_; - - my $message = sprintf($format, @args); - - debug(1, "CONFLICT: $message"); - push @Conflicts, "CONFLICT: $message\n"; - return; -} - -#===== SUBROUTINE ============================================================ -# Name : ignore -# Purpose : determine if the given path matches a regex in our ignore list -# Parameters: $path -# Returns : Boolean -# Throws : no exceptions -# Comments : none -#============================================================================= -sub ignore { - my ($path) = @_; - - for my $suffix (@{$Option{'ignore'}}) { - return 1 if $path =~ m/$suffix/; - } - return 0; -} - -#===== SUBROUTINE ============================================================ -# Name : defer -# Purpose : determine if the given path matches a regex in our defer list -# Parameters: $path -# Returns : Boolean -# Throws : no exceptions -# Comments : none -#============================================================================= -sub defer { - my ($path) = @_; - - for my $prefix (@{$Option{'defer'}}) { - return 1 if $path =~ m/$prefix/; - } - return 0; -} - -#===== SUBROUTINE ============================================================ -# Name : overide -# Purpose : determine if the given path matches a regex in our override list -# Parameters: $path -# Returns : Boolean -# Throws : no exceptions -# Comments : none -#============================================================================= -sub override { - my ($path) = @_; - - for my $regex (@{$Option{'override'}}) { - return 1 if $path =~ m/$regex/; - } - return 0; -} - -############################################################################## -# -# The following code provides the abstractions that allow us to defer operating -# on the filesystem until after all potential conflcits have been assessed. -# -############################################################################## - -#===== SUBROUTINE =========================================================== -# Name : process_tasks() -# Purpose : process each task in the @Tasks list -# Parameters: none -# Returns : n/a -# Throws : fatal error if @Tasks is corrupted or a task fails -# Comments : task involve either creating or deleting dirs and symlinks -# : an action is set to 'skip' if it is found to be redundant -#============================================================================ -sub process_tasks { - debug(2, "Processing tasks..."); - - # strip out all tasks with a skip action - @Tasks = grep { $_->{'action'} ne 'skip' } @Tasks; - - if (not scalar @Tasks) { - warn "There are no outstanding operations to perform.\n"; - return; - } - if ($Option{'simulate'}) { - warn "WARNING: simulating so all operations are deferred.\n"; - return; - } - - for my $task (@Tasks) { - - if ($task->{'action'} eq 'create') { - if ($task->{'type'} eq 'dir') { - mkdir($task->{'path'}, 0777) - or error(qq(Could not create directory: $task->{'path'})); - } - elsif ($task->{'type'} eq 'link') { - symlink $task->{'source'}, $task->{'path'} - or error( - q(Could not create symlink: %s => %s), - $task->{'path'}, - $task->{'source'} - ); - } - else { - internal_error(qq(bad task type: $task->{'type'})); - } - } - elsif ($task->{'action'} eq 'remove') { - if ($task->{'type'} eq 'dir') { - rmdir $task->{'path'} - or error(qq(Could not remove directory: $task->{'path'})); - } - elsif ($task->{'type'} eq 'link') { - unlink $task->{'path'} - or error(qq(Could not remove link: $task->{'path'})); - } - else { - internal_error(qq(bad task type: $task->{'type'})); - } - } - else { - internal_error(qq(bad task action: $task->{'action'})); - } - } - debug(2, "Processing tasks... done"); - return; -} - -#===== SUBROUTINE =========================================================== -# Name : link_task_action() -# Purpose : finds the link task action for the given path, if there is one -# Parameters: $path -# Returns : 'remove', 'create', or '' if there is no action -# Throws : a fatal exception if an invalid action is found -# Comments : none -#============================================================================ -sub link_task_action { - my ($path) = @_; - - if (! exists $Link_Task_For{$path}) { - debug(4, " link_task_action($path): no task"); - return ''; - } - - my $action = $Link_Task_For{$path}->{'action'}; - internal_error("bad task action: $action") - unless $action eq 'remove' or $action eq 'create'; - - debug(4, " link_task_action($path): link task exists with action $action"); - return $action; -} - -#===== SUBROUTINE =========================================================== -# Name : dir_task_action() -# Purpose : finds the dir task action for the given path, if there is one -# Parameters: $path -# Returns : 'remove', 'create', or '' if there is no action -# Throws : a fatal exception if an invalid action is found -# Comments : none -#============================================================================ -sub dir_task_action { - my ($path) = @_; - - if (! exists $Dir_Task_For{$path}) { - debug(4, " dir_task_action($path): no task"); - return ''; - } - - my $action = $Dir_Task_For{$path}->{'action'}; - internal_error("bad task action: $action") - unless $action eq 'remove' or $action eq 'create'; - - debug(4, " dir_task_action($path): dir task exists with action $action"); - return $action; -} - -#===== SUBROUTINE =========================================================== -# Name : parent_link_scheduled_for_removal() -# Purpose : determines whether the given path or any parent thereof -# : is a link scheduled for removal -# Parameters: $path -# Returns : Boolean -# Throws : none -# Comments : none -#============================================================================ -sub parent_link_scheduled_for_removal { - my ($path) = @_; - - my $prefix = ''; - for my $part (split m{/+}, $path) { - $prefix = join_paths($prefix, $part); - debug(4, " parent_link_scheduled_for_removal($path): prefix $prefix"); - if (exists $Link_Task_For{$prefix} and - $Link_Task_For{$prefix}->{'action'} eq 'remove') { - debug(4, " parent_link_scheduled_for_removal($path): link scheduled for removal"); - return 1; - } - } - - debug(4, " parent_link_scheduled_for_removal($path): returning false"); - return 0; -} - -#===== SUBROUTINE =========================================================== -# Name : is_a_link() -# Purpose : is the given path a current or planned link -# Parameters: $path -# Returns : Boolean -# Throws : none -# Comments : returns false if an existing link is scheduled for removal -# : and true if a non-existent link is scheduled for creation -#============================================================================ -sub is_a_link { - my ($path) = @_; - debug(4, " is_a_link($path)"); - - if (my $action = link_task_action($path)) { - if ($action eq 'remove') { - return 0; - } - elsif ($action eq 'create') { - return 1; - } - } - - if (-l $path) { - # check if any of its parent are links scheduled for removal - # (need this for edge case during unfolding) - debug(4, " is_a_link($path): is a real link"); - return parent_link_scheduled_for_removal($path) ? 0 : 1; - } - - debug(4, " is_a_link($path): returning false"); - return 0; -} - -#===== SUBROUTINE =========================================================== -# Name : is_a_dir() -# Purpose : is the given path a current or planned directory -# Parameters: $path -# Returns : Boolean -# Throws : none -# Comments : returns false if an existing directory is scheduled for removal -# : and true if a non-existent directory is scheduled for creation -# : we also need to be sure we are not just following a link -#============================================================================ -sub is_a_dir { - my ($path) = @_; - debug(4, " is_a_dir($path)"); - - if (my $action = dir_task_action($path)) { - if ($action eq 'remove') { - return 0; - } - elsif ($action eq 'create') { - return 1; - } - } - - return 0 if parent_link_scheduled_for_removal($path); - - if (-d $path) { - debug(4, " is_a_dir($path): real dir"); - return 1; - } - - debug(4, " is_a_dir($path): returning false"); - return 0; -} - -#===== SUBROUTINE =========================================================== -# Name : is_a_node() -# Purpose : is the given path a current or planned node -# Parameters: $path -# Returns : Boolean -# Throws : none -# Comments : returns false if an existing node is scheduled for removal -# : true if a non-existent node is scheduled for creation -# : we also need to be sure we are not just following a link -#============================================================================ -sub is_a_node { - my ($path) = @_; - debug(4, " is_a_node($path)"); - - my $laction = link_task_action($path); - my $daction = dir_task_action($path); - - if ($laction eq 'remove') { - if ($daction eq 'remove') { - internal_error("removing link and dir: $path"); - return 0; - } - elsif ($daction eq 'create') { - # Assume that we're unfolding $path, and that the link - # removal action is earlier than the dir creation action - # in the task queue. FIXME: is this a safe assumption? - return 1; - } - else { # no dir action - return 0; - } - } - elsif ($laction eq 'create') { - if ($daction eq 'remove') { - # Assume that we're folding $path, and that the dir - # removal action is earlier than the link creation action - # in the task queue. FIXME: is this a safe assumption? - return 1; - } - elsif ($daction eq 'create') { - internal_error("creating link and dir: $path"); - return 1; - } - else { # no dir action - return 1; - } - } - else { - # No link action - if ($daction eq 'remove') { - return 0; - } - elsif ($daction eq 'create') { - return 1; - } - else { # no dir action - # fall through to below - } - } - - return 0 if parent_link_scheduled_for_removal($path); - - if (-e $path) { - debug(4, " is_a_node($path): really exists"); - return 1; - } - - debug(4, " is_a_node($path): returning false"); - return 0; -} - -#===== SUBROUTINE =========================================================== -# Name : read_a_link() -# Purpose : return the source of a current or planned link -# Parameters: $path => path to the link target -# Returns : a string -# Throws : fatal exception if the given path is not a current or planned -# : link -# Comments : none -#============================================================================ -sub read_a_link { - my ($path) = @_; - - if (my $action = link_task_action($path)) { - debug(4, " read_a_link($path): task exists with action $action"); - - if ($action eq 'create') { - return $Link_Task_For{$path}->{'source'}; - } - elsif ($action eq 'remove') { - internal_error( - "read_a_link() passed a path that is scheduled for removal: $path" - ); - } - } - elsif (-l $path) { - debug(4, " read_a_link($path): real link"); - return readlink $path - or error("Could not read link: $path"); - } - internal_error("read_a_link() passed a non link path: $path\n"); -} - -#===== SUBROUTINE =========================================================== -# Name : do_link() -# Purpose : wrap 'link' operation for later processing -# Parameters: $oldfile => the existing file to link to -# : $newfile => the file to link -# Returns : n/a -# Throws : error if this clashes with an existing planned operation -# Comments : cleans up operations that undo previous operations -#============================================================================ -sub do_link { - my ($oldfile, $newfile) = @_; - - if (exists $Dir_Task_For{$newfile}) { - my $task_ref = $Dir_Task_For{$newfile}; - - if ($task_ref->{'action'} eq 'create') { - if ($task_ref->{'type'} eq 'dir') { - internal_error( - "new link (%s => %s) clashes with planned new directory", - $newfile, - $oldfile, - ); - } - } - elsif ($task_ref->{'action'} eq 'remove') { - # we may need to remove a directory before creating a link so continue; - } - else { - internal_error("bad task action: $task_ref->{'action'}"); - } - } - - if (exists $Link_Task_For{$newfile}) { - my $task_ref = $Link_Task_For{$newfile}; - - if ($task_ref->{'action'} eq 'create') { - if ($task_ref->{'source'} ne $oldfile) { - internal_error( - "new link clashes with planned new link: %s => %s", - $task_ref->{'path'}, - $task_ref->{'source'}, - ) - } - else { - debug(1, "LINK: $newfile => $oldfile (duplicates previous action)"); - return; - } - } - elsif ($task_ref->{'action'} eq 'remove') { - if ($task_ref->{'source'} eq $oldfile) { - # no need to remove a link we are going to recreate - debug(1, "LINK: $newfile => $oldfile (reverts previous action)"); - $Link_Task_For{$newfile}->{'action'} = 'skip'; - delete $Link_Task_For{$newfile}; - return; - } - # we may need to remove a link to replace it so continue - } - else { - internal_error("bad task action: $task_ref->{'action'}"); - } - } - - # creating a new link - debug(1, "LINK: $newfile => $oldfile"); - my $task = { - action => 'create', - type => 'link', - path => $newfile, - source => $oldfile, - }; - push @Tasks, $task; - $Link_Task_For{$newfile} = $task; - - return; -} - -#===== SUBROUTINE =========================================================== -# Name : do_unlink() -# Purpose : wrap 'unlink' operation for later processing -# Parameters: $file => the file to unlink -# Returns : n/a -# Throws : error if this clashes with an existing planned operation -# Comments : will remove an existing planned link -#============================================================================ -sub do_unlink { - my ($file) = @_; - - if (exists $Link_Task_For{$file}) { - my $task_ref = $Link_Task_For{$file}; - if ($task_ref->{'action'} eq 'remove') { - debug(1, "UNLINK: $file (duplicates previous action)"); - return; - } - elsif ($task_ref->{'action'} eq 'create') { - # do need to create a link then remove it - debug(1, "UNLINK: $file (reverts previous action)"); - $Link_Task_For{$file}->{'action'} = 'skip'; - delete $Link_Task_For{$file}; - return; - } - else { - internal_error("bad task action: $task_ref->{'action'}"); - } - } - - if (exists $Dir_Task_For{$file} and $Dir_Task_For{$file} eq 'create') { - internal_error( - "new unlink operation clashes with planned operation: %s dir %s", - $Dir_Task_For{$file}->{'action'}, - $file - ); - } - - # remove the link - #debug(1, "UNLINK: $file (" . (caller())[2] . ")"); - debug(1, "UNLINK: $file"); - - my $source = readlink $file or error("could not readlink $file"); - - my $task = { - action => 'remove', - type => 'link', - path => $file, - source => $source, - }; - push @Tasks, $task; - $Link_Task_For{$file} = $task; - - return; -} - -#===== SUBROUTINE =========================================================== -# Name : do_mkdir() -# Purpose : wrap 'mkdir' operation -# Parameters: $dir => the directory to remove -# Returns : n/a -# Throws : fatal exception if operation fails -# Comments : outputs a message if 'verbose' option is set -# : does not perform operation if 'simulate' option is set -# Comments : cleans up operations that undo previous operations -#============================================================================ -sub do_mkdir { - my ($dir) = @_; - - if (exists $Link_Task_For{$dir}) { - my $task_ref = $Link_Task_For{$dir}; - - if ($task_ref->{'action'} eq 'create') { - internal_error( - "new dir clashes with planned new link (%s => %s)", - $task_ref->{'path'}, - $task_ref->{'source'}, - ); - } - elsif ($task_ref->{'action'} eq 'remove') { - # may need to remove a link before creating a directory so continue - } - else { - internal_error("bad task action: $task_ref->{'action'}"); - } - } - - if (exists $Dir_Task_For{$dir}) { - my $task_ref = $Dir_Task_For{$dir}; - - if ($task_ref->{'action'} eq 'create') { - debug(1, "MKDIR: $dir (duplicates previous action)"); - return; - } - elsif ($task_ref->{'action'} eq 'remove') { - debug(1, "MKDIR: $dir (reverts previous action)"); - $Dir_Task_For{$dir}->{'action'} = 'skip'; - delete $Dir_Task_For{$dir}; - return; - } - else { - internal_error("bad task action: $task_ref->{'action'}"); - } - } - - debug(1, "MKDIR: $dir"); - my $task = { - action => 'create', - type => 'dir', - path => $dir, - source => undef, - }; - push @Tasks, $task; - $Dir_Task_For{$dir} = $task; - - return; -} - -#===== SUBROUTINE =========================================================== -# Name : do_rmdir() -# Purpose : wrap 'rmdir' operation -# Parameters: $dir => the directory to remove -# Returns : n/a -# Throws : fatal exception if operation fails -# Comments : outputs a message if 'verbose' option is set -# : does not perform operation if 'simulate' option is set -#============================================================================ -sub do_rmdir { - my ($dir) = @_; - - if (exists $Link_Task_For{$dir}) { - my $task_ref = $Link_Task_For{$dir}; - internal_error( - "rmdir clashes with planned operation: %s link %s => %s", - $task_ref->{'action'}, - $task_ref->{'path'}, - $task_ref->{'source'} - ); - } - - if (exists $Dir_Task_For{$dir}) { - my $task_ref = $Link_Task_For{$dir}; - - if ($task_ref->{'action'} eq 'remove') { - debug(1, "RMDIR $dir (duplicates previous action)"); - return; - } - elsif ($task_ref->{'action'} eq 'create') { - debug(1, "MKDIR $dir (reverts previous action)"); - $Link_Task_For{$dir}->{'action'} = 'skip'; - delete $Link_Task_For{$dir}; - return; - } - else { - internal_error("bad task action: $task_ref->{'action'}"); - } - } - - debug(1, "RMDIR $dir"); - my $task = { - action => 'remove', - type => 'dir', - path => $dir, - source => '', - }; - push @Tasks, $task; - $Dir_Task_For{$dir} = $task; - - return; -} - -############################################################################# -# -# General Utilities: nothing stow specific here. -# -############################################################################# - -#===== SUBROUTINE ============================================================ +#===== METHOD ================================================================ # Name : strip_quotes # Purpose : remove matching outer quotes from the given string # Parameters: none @@ -1680,95 +274,6 @@ sub strip_quotes { return $string; } -#===== SUBROUTINE =========================================================== -# Name : join_paths() -# Purpose : concatenates given paths -# Parameters: path1, path2, ... => paths -# Returns : concatenation of given paths -# Throws : n/a -# Comments : factors out redundant path elements: -# : '//' => '/' and 'a/b/../c' => 'a/c' -#============================================================================ -sub join_paths { - my @paths = @_; - - # weed out empty components and concatenate - my $result = join '/', grep {!/\A\z/} @paths; - - # factor out back references and remove redundant /'s) - my @result = (); - PART: - for my $part (split m{/+}, $result) { - next PART if $part eq '.'; - if (@result && $part eq '..' && $result[-1] ne '..') { - pop @result; - } - else { - push @result, $part; - } - } - - return join '/', @result; -} - -#===== SUBROUTINE =========================================================== -# Name : parent -# Purpose : find the parent of the given path -# Parameters: @path => components of the path -# Returns : returns a path string -# Throws : n/a -# Comments : allows you to send multiple chunks of the path -# : (this feature is currently not used) -#============================================================================ -sub parent { - my @path = @_; - my $path = join '/', @_; - my @elts = split m{/+}, $path; - pop @elts; - return join '/', @elts; -} - -#===== SUBROUTINE =========================================================== -# Name : internal_error() -# Purpose : output internal error message in a consistent form and die -# Parameters: $message => error message to output -# Returns : n/a -# Throws : n/a -# Comments : none -#============================================================================ -sub internal_error { - my ($format, @args) = @_; - die "$ProgramName: INTERNAL ERROR: " . sprintf($format, @args) . "\n", - "This _is_ a bug. Please submit a bug report so we can fix it:-)\n"; -} - -#===== SUBROUTINE =========================================================== -# Name : error() -# Purpose : output error message in a consistent form and die -# Parameters: $message => error message to output -# Returns : n/a -# Throws : n/a -# Comments : none -#============================================================================ -sub error { - my ($format, @args) = @_; - die "$ProgramName: ERROR: " . sprintf($format, @args) . " ($!)\n"; -} - -#===== SUBROUTINE =========================================================== -# Name : version() -# Purpose : print this programs verison and exit -# Parameters: none -# Returns : n/a -# Throws : n/a -# Comments : none -#============================================================================ -sub version { - print "$ProgramName (GNU Stow) version $Version\n"; - exit 0; -} - -1; # return true so we can load this script as a module during unit testing # Local variables: # mode: perl diff --git a/t/chkstow.t b/t/chkstow.t index f38de57..b182fd9 100755 --- a/t/chkstow.t +++ b/t/chkstow.t @@ -4,22 +4,18 @@ # Testing cleanup_invalid_links() # -# load as a library -BEGIN { - use lib qw(.); - require "t/util.pm"; - require "chkstow"; -} +use strict; +use warnings; + +use testutil; +require "chkstow"; use Test::More tests => 7; use Test::Output; use English qw(-no_match_vars); -### setup -eval { remove_dir('t/target'); }; -make_dir('t/target'); - -chdir 't/target'; +make_fresh_stow_and_target_dirs(); +cd('t/target'); # setup stow directory make_dir('stow'); @@ -111,5 +107,6 @@ stdout_like( @ARGV = ('-b',); process_options(); -ok($::Target == q{/usr/local}, +our $Target; +ok($Target == q{/usr/local}, "Default target is /usr/local/"); diff --git a/t/cleanup_invalid_links.t b/t/cleanup_invalid_links.t index 69efbe8..f5802dd 100755 --- a/t/cleanup_invalid_links.t +++ b/t/cleanup_invalid_links.t @@ -4,64 +4,55 @@ # Testing cleanup_invalid_links() # -# load as a library -BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; } +use strict; +use warnings; -use Test::More tests => 3; +use Test::More tests => 6; use English qw(-no_match_vars); -### setup -eval { remove_dir('t/target'); }; -eval { remove_dir('t/stow'); }; -make_dir('t/target'); -make_dir('t/stow'); +use testutil; -chdir 't/target'; -$Stow_Path= '../stow'; +make_fresh_stow_and_target_dirs(); +cd('t/target'); + +my $stow; # Note that each of the following tests use a distinct set of files # # nothing to clean in a simple tree # -reset_state(); + make_dir('../stow/pkg1/bin1'); make_file('../stow/pkg1/bin1/file1'); make_link('bin1','../stow/pkg1/bin1'); -cleanup_invalid_links('./'); +$stow = new_Stow(); +$stow->cleanup_invalid_links('./'); is( - scalar @Tasks, 0 + scalar($stow->get_tasks), 0 => 'nothing to clean' ); # # cleanup a bad link in a simple tree # -reset_state(); - make_dir('bin2'); make_dir('../stow/pkg2/bin2'); make_file('../stow/pkg2/bin2/file2a'); make_link('bin2/file2a','../../stow/pkg2/bin2/file2a'); make_link('bin2/file2b','../../stow/pkg2/bin2/file2b'); -cleanup_invalid_links('bin2'); -ok( - scalar(@Conflicts) == 0 && - scalar @Tasks == 1 && - $Link_Task_For{'bin2/file2b'}->{'action'} eq 'remove' - => 'cleanup a bad link' -); - -#use Data::Dumper; -#print Dumper(\@Tasks,\%Link_Task_For,\%Dir_Task_For); +$stow = new_Stow(); +$stow->cleanup_invalid_links('bin2'); +is(scalar($stow->get_conflicts), 0, 'no conflicts cleaning up bad link'); +is(scalar($stow->get_tasks), 1, 'one task cleaning up bad link'); +is($stow->link_task_action('bin2/file2b'), 'remove', 'removal task for bad link'); # # dont cleanup a bad link not owned by stow # -reset_state(); make_dir('bin3'); make_dir('../stow/pkg3/bin3'); @@ -69,11 +60,7 @@ make_file('../stow/pkg3/bin3/file3a'); make_link('bin3/file3a','../../stow/pkg3/bin3/file3a'); make_link('bin3/file3b','../../empty'); -cleanup_invalid_links('bin3'); -ok( - scalar(@Conflicts) == 0 && - scalar @Tasks == 0 - => 'dont cleanup a bad link not owned by stow' -); - - +$stow = new_Stow(); +$stow->cleanup_invalid_links('bin3'); +is(scalar($stow->get_conflicts), 0, 'no conflicts cleaning up bad link not owned by stow'); +is(scalar($stow->get_tasks), 0, 'no tasks cleaning up bad link not owned by stow'); diff --git a/t/defer.t b/t/defer.t old mode 100644 new mode 100755 index a4f8cf7..24d4d5f --- a/t/defer.t +++ b/t/defer.t @@ -4,19 +4,23 @@ # Testing defer(). # -# load as a library -BEGIN { use lib qw(. ..); require "stow"; } +use strict; +use warnings; + +use testutil; use Test::More tests => 4; -$Option{'defer'} = [ 'man' ]; -ok(defer('man/man1/file.1') => 'simple success'); +my $stow; -$Option{'defer'} = [ 'lib' ]; -ok(!defer('man/man1/file.1') => 'simple failure'); +$stow = new_Stow(defer => [ 'man' ]); +ok($stow->defer('man/man1/file.1') => 'simple success'); -$Option{'defer'} = [ 'lib', 'man', 'share' ]; -ok(defer('man/man1/file.1') => 'complex success'); +$stow = new_Stow(defer => [ 'lib' ]); +ok(! $stow->defer('man/man1/file.1') => 'simple failure'); -$Option{'defer'} = [ 'lib', 'man', 'share' ]; -ok(!defer('bin/file') => 'complex failure'); +$stow = new_Stow(defer => [ 'lib', 'man', 'share' ]); +ok($stow->defer('man/man1/file.1') => 'complex success'); + +$stow = new_Stow(defer => [ 'lib', 'man', 'share' ]); +ok(! $stow->defer('bin/file') => 'complex failure'); diff --git a/t/examples.t b/t/examples.t index adcaa97..381f9ad 100755 --- a/t/examples.t +++ b/t/examples.t @@ -4,18 +4,18 @@ # Testing examples from the documentation # -# load as a library -BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; } +use strict; +use warnings; -use Test::More tests => 4; +use testutil; + +use Test::More tests => 10; use English qw(-no_match_vars); -### setup -eval { remove_dir('t/target'); }; -make_dir('t/target/stow'); +make_fresh_stow_and_target_dirs(); +cd('t/target'); -chdir 't/target'; -$Stow_Path= 'stow'; +my $stow; ## set up some fake packages to stow @@ -42,8 +42,6 @@ make_file('stow/emacs/man/man1/emacs.1'); # # stow perl into an empty target # -reset_state(); - make_dir('stow/perl/bin'); make_file('stow/perl/bin/perl'); make_file('stow/perl/bin/a2p'); @@ -52,10 +50,11 @@ make_dir('stow/perl/lib/perl'); make_dir('stow/perl/man/man1'); make_file('stow/perl/man/man1/perl.1'); -stow_contents('stow/perl','./','stow/perl'); -process_tasks(); +$stow = new_Stow(dir => 'stow'); +$stow->plan_stow('perl'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'bin' && -l 'info' && -l 'lib' && -l 'man' && readlink('bin') eq 'stow/perl/bin' && readlink('info') eq 'stow/perl/info' && @@ -64,11 +63,9 @@ ok( => 'stow perl into an empty target' ); - # # stow perl into a non-empty target # -reset_state(); # clean up previous stow remove_link('bin'); @@ -80,10 +77,11 @@ make_dir('bin'); make_dir('lib'); make_dir('man/man1'); -stow_contents('stow/perl','./','stow/perl'); -process_tasks(); +$stow = new_Stow(dir => 'stow'); +$stow->plan_stow('perl'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -d 'bin' && -d 'lib' && -d 'man' && -d 'man/man1' && -l 'info' && -l 'bin/perl' && -l 'bin/a2p' && -l 'lib/perl' && -l 'man/man1/perl.1' && @@ -99,7 +97,6 @@ ok( # # Install perl into an empty target and then install emacs # -reset_state(); # clean up previous stow remove_link('info'); @@ -107,11 +104,11 @@ remove_dir('bin'); remove_dir('lib'); remove_dir('man'); -stow_contents('stow/perl', './','stow/perl'); -stow_contents('stow/emacs','./','stow/emacs'); -process_tasks(); +$stow = new_Stow(dir => 'stow'); +$stow->plan_stow('perl', 'emacs'); +$stow->process_tasks(); +is(scalar($stow->get_conflicts), 0, 'no conflicts'); ok( - scalar(@Conflicts) == 0 && -d 'bin' && -l 'bin/perl' && -l 'bin/emacs' && @@ -151,30 +148,22 @@ ok( # Q. the original empty directory should remain # behaviour is the same as if the empty directory had nothing to do with stow # -reset_state(); make_dir('stow/pkg1a/bin1'); make_dir('stow/pkg1b/bin1'); make_file('stow/pkg1b/bin1/file1b'); -stow_contents('stow/pkg1a', './', 'stow/pkg1a'); -stow_contents('stow/pkg1b', './', 'stow/pkg1b'); -unstow_contents('stow/pkg1b', './', 'stow/pkg1b'); -process_tasks(); - -ok( - scalar(@Conflicts) == 0 && - -d 'bin1' - => 'bug 1: stowing empty dirs' -); - +$stow = new_Stow(dir => 'stow'); +$stow->plan_stow('pkg1a', 'pkg1b'); +$stow->plan_unstow('pkg1b'); +$stow->process_tasks(); +is(scalar($stow->get_conflicts), 0, 'no conflicts stowing empty dirs'); +ok(-d 'bin1' => 'bug 1: stowing empty dirs'); # # BUG 2: split open tree-folding symlinks pointing inside different stow # directories # -reset_state(); - make_dir('stow2a/pkg2a/bin2'); make_file('stow2a/pkg2a/bin2/file2a'); make_file('stow2a/.stow'); @@ -182,8 +171,15 @@ make_dir('stow2b/pkg2b/bin2'); make_file('stow2b/pkg2b/bin2/file2b'); make_file('stow2b/.stow'); -stow_contents('stow2a/pkg2a','./', 'stow2a/pkg2a'); -stow_contents('stow2b/pkg2b','./', 'stow2b/pkg2b'); -process_tasks(); +$stow = new_Stow(dir => 'stow2a'); +$stow->plan_stow('pkg2a'); +$stow->set_stow_dir('stow2b'); +$stow->plan_stow('pkg2b'); +$stow->process_tasks(); + +is(scalar($stow->get_conflicts), 0, 'no conflicts splitting tree-folding symlinks'); +ok(-d 'bin2' => 'tree got split by packages from multiple stow directories'); +ok(-f 'bin2/file2a' => 'file from 1st stow dir'); +ok(-f 'bin2/file2b' => 'file from 2nd stow dir'); ## Finish this test diff --git a/t/find_stowed_path.t b/t/find_stowed_path.t old mode 100644 new mode 100755 index 03a7c73..199a534 --- a/t/find_stowed_path.t +++ b/t/find_stowed_path.t @@ -4,39 +4,43 @@ # Testing find_stowed_path() # -BEGIN { require "t/util.pm"; require "stow"; } +use strict; +use warnings; -use Test::More tests => 5; +use testutil; -eval { remove_dir('t/target'); }; -eval { remove_dir('t/stow'); }; -make_dir('t/target'); -make_dir('t/stow'); +use Test::More tests => 6; + +make_fresh_stow_and_target_dirs(); + +my $stow = new_Stow(dir => 't/stow'); -$Stow_Path = 't/stow'; is( - 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', => 'from root' ); -$Stow_Path = '../stow'; +cd('t/target'); +$stow->set_stow_dir('../stow'); is( - 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', => 'from target directory' ); -$Stow_Path = 't/target/stow'; +make_dir('stow'); +cd('../..'); +$stow->set_stow_dir('t/target/stow'); is( - 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', => 'stow is subdir of target directory' ); is( - find_stowed_path('t/target/a/b/c','../../empty'), + $stow->find_stowed_path('t/target/a/b/c','../../empty'), '', => 'target is not stowed' ); @@ -45,7 +49,15 @@ make_dir('t/target/stow2'); make_file('t/target/stow2/.stow'); is( - 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' => 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','../../..'), + '' + => q(corner case - link points to ancestor of stow dir) +); diff --git a/t/foldable.t b/t/foldable.t index 171907c..6815ec7 100755 --- a/t/foldable.t +++ b/t/foldable.t @@ -4,21 +4,18 @@ # Testing foldable() # -# load as a library -BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; } +use strict; +use warnings; + +use testutil; use Test::More tests => 4; use English qw(-no_match_vars); -### setup -# be very careful with these -eval { remove_dir('t/target'); }; -eval { remove_dir('t/stow'); }; -make_dir('t/target'); -make_dir('t/stow'); +make_fresh_stow_and_target_dirs(); +cd('t/target'); -chdir 't/target'; -$Stow_Path= '../stow'; +my $stow = new_Stow(dir => '../stow'); # Note that each of the following tests use a distinct set of files @@ -31,7 +28,7 @@ make_file('../stow/pkg1/bin1/file1'); make_dir('bin1'); make_link('bin1/file1','../../stow/pkg1/bin1/file1'); -is( foldable('bin1'), '../stow/pkg1/bin1' => q(can fold a simple tree) ); +is( $stow->foldable('bin1'), '../stow/pkg1/bin1' => q(can fold a simple tree) ); # # can't fold an empty directory @@ -41,7 +38,7 @@ make_dir('../stow/pkg2/bin2'); make_file('../stow/pkg2/bin2/file2'); make_dir('bin2'); -is( foldable('bin2'), '' => q(can't fold an empty directory) ); +is( $stow->foldable('bin2'), '' => q(can't fold an empty directory) ); # # can't fold if dir contains a non-link @@ -53,7 +50,7 @@ make_dir('bin3'); make_link('bin3/file3','../../stow/pkg3/bin3/file3'); make_file('bin3/non-link'); -is( foldable('bin3'), '' => q(can't fold a dir containing non-links) ); +is( $stow->foldable('bin3'), '' => q(can't fold a dir containing non-links) ); # # can't fold if links point to different directories @@ -67,4 +64,4 @@ make_dir('../stow/pkg4b/bin4'); make_file('../stow/pkg4b/bin4/file4b'); make_link('bin4/file4b','../../stow/pkg4b/bin4/file4b'); -is( foldable('bin4'), '' => q(can't fold if links point to different dirs) ); +is( $stow->foldable('bin4'), '' => q(can't fold if links point to different dirs) ); diff --git a/t/join_paths.t b/t/join_paths.t old mode 100644 new mode 100755 index 1fc6b24..b310416 --- a/t/join_paths.t +++ b/t/join_paths.t @@ -4,8 +4,10 @@ # Testing join_paths(); # -# load as a library -BEGIN { use lib qw(. ..); require "stow"; } +use strict; +use warnings; + +use Stow::Util qw(join_paths); use Test::More tests => 13; diff --git a/t/parent.t b/t/parent.t old mode 100644 new mode 100755 index 52a4bea..52a99bc --- a/t/parent.t +++ b/t/parent.t @@ -4,8 +4,10 @@ # Testing parent() # -# load as a library -BEGIN { use lib qw(. ..); require "stow"; } +use strict; +use warnings; + +use Stow::Util qw(parent); use Test::More tests => 5; diff --git a/t/stow.t b/t/stow.t index 49d671a..2ad0fc8 100755 --- a/t/stow.t +++ b/t/stow.t @@ -4,11 +4,17 @@ # Testing core application # -# load as a library -BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; } +use strict; +use warnings; use Test::More tests => 10; +use testutil; + +require 'stow'; + +make_fresh_stow_and_target_dirs(); + local @ARGV = ( '-v', '-d t/stow', @@ -16,23 +22,19 @@ local @ARGV = ( 'dummy' ); -### setup -eval { remove_dir('t/target'); }; -eval { remove_dir('t/stow'); }; -make_dir('t/target'); -make_dir('t/stow'); +my ($options, $pkgs_to_delete, $pkgs_to_stow) = process_options(); -ok eval {process_options(); 1} => 'process options'; -ok eval {set_stow_path(); 1} => 'set stow path'; +is($options->{verbose}, 1, 'verbose option'); +is($options->{dir}, 't/stow', 'stow dir option'); -is($Stow_Path,"../stow" => 'stow dir'); -is_deeply(\@Pkgs_To_Stow, [ 'dummy' ] => 'default to stow'); +my $stow = new_Stow(%$options); +is($stow->{stow_path}, "../stow" => 'stow dir'); +is_deeply($pkgs_to_stow, [ 'dummy' ] => 'default to stow'); # # Check mixed up package options # -%Option=(); local @ARGV = ( '-v', '-D', 'd1', 'd2', @@ -43,55 +45,53 @@ local @ARGV = ( '-R', 'r2', ); -@Pkgs_To_Stow = (); -@Pkgs_To_Delete = (); -process_options(); -is_deeply(\@Pkgs_To_Delete, [ 'd1', 'd2', 'r1', 'd3', 'r2' ] => 'mixed deletes'); -is_deeply(\@Pkgs_To_Stow, [ 's1', 'r1', 's2', 's3', 'r2' ] => 'mixed stows'); +($options, $pkgs_to_delete, $pkgs_to_stow) = process_options(); +is_deeply($pkgs_to_delete, [ 'd1', 'd2', 'r1', 'd3', 'r2' ] => 'mixed deletes'); +is_deeply($pkgs_to_stow, [ 's1', 'r1', 's2', 's3', 'r2' ] => 'mixed stows'); # -# Check setting defered paths +# Check setting deferred paths # -%Option=(); local @ARGV = ( '--defer=man', - '--defer=info' + '--defer=info', + 'dummy' ); -process_options(); -is_deeply($Option{'defer'}, [ qr(\Aman), qr(\Ainfo) ] => 'defer man and info'); +($options, $pkgs_to_delete, $pkgs_to_stow) = process_options(); +is_deeply($options->{'defer'}, [ qr(\Aman), qr(\Ainfo) ] => 'defer man and info'); # # Check setting override paths # -%Option=(); local @ARGV = ( '--override=man', - '--override=info' + '--override=info', + 'dummy' ); -process_options(); -is_deeply($Option{'override'}, [qr(\Aman), qr(\Ainfo)] => 'override man and info'); +($options, $pkgs_to_delete, $pkgs_to_stow) = process_options(); +is_deeply($options->{'override'}, [qr(\Aman), qr(\Ainfo)] => 'override man and info'); # # Check stripping any matched quotes # -%Option=(); local @ARGV = ( "--override='man'", '--override="info"', + 'dummy' ); -process_options(); -is_deeply($Option{'override'}, [qr(\Aman), qr(\Ainfo)] => 'strip shell quoting'); +($options, $pkgs_to_delete, $pkgs_to_stow) = process_options(); +is_deeply($options->{'override'}, [qr(\Aman), qr(\Ainfo)] => 'strip shell quoting'); # # Check setting ignored paths # -%Option=(); local @ARGV = ( '--ignore="~"', - '--ignore="\.#.*"' + '--ignore="\.#.*"', + 'dummy' ); -process_options(); -is_deeply($Option{'ignore'}, [ qr(~\z), qr(\.#.*\z) ] => 'ignore temp files'); +($options, $pkgs_to_delete, $pkgs_to_stow) = process_options(); +is_deeply($options->{'ignore'}, [ qr(~\z), qr(\.#.*\z) ] => 'ignore temp files'); # vim:ft=perl diff --git a/t/stow_contents.t b/t/stow_contents.t index 7cae0df..ad3b47f 100755 --- a/t/stow_contents.t +++ b/t/stow_contents.t @@ -1,36 +1,37 @@ #!/usr/local/bin/perl # -# Testing +# Testing stow_contents() # -# load as a library -BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; } +use strict; +use warnings; -use Test::More tests => 16; +use Test::More tests => 19; use Test::Output; use English qw(-no_match_vars); -### setup -eval { remove_dir('t/target'); }; -eval { remove_dir('t/stow'); }; -make_dir('t/target'); -make_dir('t/stow'); +use testutil; -chdir 't/target'; -$Stow_Path= '../stow'; +make_fresh_stow_and_target_dirs(); +cd('t/target'); + +my $stow; +my @conflicts; # Note that each of the following tests use a distinct set of files # # stow a simple tree minimally # -reset_state(); +$stow = new_Stow(dir => '../stow'); make_dir('../stow/pkg1/bin1'); make_file('../stow/pkg1/bin1/file1'); -stow_contents('../stow/pkg1', './', '../stow/pkg1'); -process_tasks(); + +$stow->plan_stow('pkg1'); +$stow->process_tasks(); +is($stow->get_conflicts(), 0, 'no conflicts with minimal stow'); is( readlink('bin1'), '../stow/pkg1/bin1', @@ -40,13 +41,13 @@ is( # # stow a simple tree into an existing directory # -reset_state(); +$stow = new_Stow(); make_dir('../stow/pkg2/lib2'); make_file('../stow/pkg2/lib2/file2'); make_dir('lib2'); -stow_contents('../stow/pkg2', '.', '../stow/pkg2'); -process_tasks(); +$stow->plan_stow('pkg2'); +$stow->process_tasks(); is( readlink('lib2/file2'), '../../stow/pkg2/lib2/file2', @@ -56,7 +57,7 @@ is( # # unfold existing tree # -reset_state(); +$stow = new_Stow(); make_dir('../stow/pkg3a/bin3'); make_file('../stow/pkg3a/bin3/file3a'); @@ -64,8 +65,8 @@ make_link('bin3' => '../stow/pkg3a/bin3'); # emulate stow make_dir('../stow/pkg3b/bin3'); make_file('../stow/pkg3b/bin3/file3b'); -stow_contents('../stow/pkg3b', './', '../stow/pkg3b'); -process_tasks(); +$stow->plan_stow('pkg3b'); +$stow->process_tasks(); ok( -d 'bin3' && readlink('bin3/file3a') eq '../../stow/pkg3a/bin3/file3a' && @@ -74,42 +75,45 @@ ok( ); # -# Link to a new dir conflicts with existing non-dir (can't unfold) +# Link to a new dir conflicts with existing non-dir (can't unfold) # -reset_state(); +$stow = new_Stow(); make_file('bin4'); # this is a file but named like a directory make_dir('../stow/pkg4/bin4'); make_file('../stow/pkg4/bin4/file4'); -stow_contents('../stow/pkg4', './', '../stow/pkg4'); -like( - $Conflicts[-1], qr(CONFLICT:.*existing target is neither a link nor a directory) +$stow->plan_stow('pkg4'); +@conflicts = $stow->get_conflicts(); +like( + $conflicts[-1], qr(CONFLICT:.*existing target is neither a link nor a directory) => 'link to new dir conflicts with existing non-directory' ); # # Target already exists but is not owned by stow # -reset_state(); +$stow = new_Stow(); make_dir('bin5'); make_link('bin5/file5','../../empty'); make_dir('../stow/pkg5/bin5/file5'); -stow_contents('../stow/pkg5', './', '../stow/pkg5'); +$stow->plan_stow('pkg5'); +@conflicts = $stow->get_conflicts(); like( - $Conflicts[-1], qr(CONFLICT:.*not owned by stow) + $conflicts[-1], qr(CONFLICT:.*not owned by stow) => 'target already exists but is not owned by stow' ); # # Replace existing but invalid target # -reset_state(); +$stow = new_Stow(); make_link('file6','../stow/path-does-not-exist'); make_dir('../stow/pkg6'); make_file('../stow/pkg6/file6'); -eval{ stow_contents('../stow/pkg6', './', '../stow/pkg6'); process_tasks() }; +$stow->plan_stow('pkg6'); +$stow->process_tasks(); is( readlink('file6'), '../stow/pkg6/file6' @@ -120,7 +124,7 @@ is( # Target already exists, is owned by stow, but points to a non-directory # (can't unfold) # -reset_state(); +$stow = new_Stow(); make_dir('bin7'); make_dir('../stow/pkg7a/bin7'); @@ -128,16 +132,17 @@ make_file('../stow/pkg7a/bin7/node7'); make_link('bin7/node7','../../stow/pkg7a/bin7/node7'); make_dir('../stow/pkg7b/bin7/node7'); make_file('../stow/pkg7b/bin7/node7/file7'); -stow_contents('../stow/pkg7b', './', '../stow/pkg7b'); -like( - $Conflicts[-1], qr(CONFLICT:.*existing target is stowed to a different package) +$stow->plan_stow('pkg7b'); +@conflicts = $stow->get_conflicts(); +like( + $conflicts[-1], qr(CONFLICT:.*existing target is stowed to a different package) => 'link to new dir conflicts with existing stowed non-directory' ); # # stowing directories named 0 # -reset_state(); +$stow = new_Stow(); make_dir('../stow/pkg8a/0'); make_file('../stow/pkg8a/0/file8a'); @@ -145,10 +150,10 @@ make_link('0' => '../stow/pkg8a/0'); # emulate stow make_dir('../stow/pkg8b/0'); make_file('../stow/pkg8b/0/file8b'); -stow_contents('../stow/pkg8b', './', '../stow/pkg8b'); -process_tasks(); +$stow->plan_stow('pkg8b'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -d '0' && readlink('0/file8a') eq '../../stow/pkg8a/0/file8a' && readlink('0/file8b') eq '../../stow/pkg8b/0/file8b' @@ -158,8 +163,7 @@ ok( # # overriding already stowed documentation # -reset_state(); -$Option{'override'} = ['man9', 'info9']; +$stow = new_Stow(override => ['man9', 'info9']); make_dir('../stow/pkg9a/man9/man1'); make_file('../stow/pkg9a/man9/man1/file9.1'); @@ -168,10 +172,10 @@ make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emu make_dir('../stow/pkg9b/man9/man1'); make_file('../stow/pkg9b/man9/man1/file9.1'); -stow_contents('../stow/pkg9b', './', '../stow/pkg9b'); -process_tasks(); +$stow->plan_stow('pkg9b'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && readlink('man9/man1/file9.1') eq '../../../stow/pkg9b/man9/man1/file9.1' => 'overriding existing documentation files' ); @@ -179,8 +183,7 @@ ok( # # deferring to already stowed documentation # -reset_state(); -$Option{'defer'} = ['man10', 'info10']; +$stow = new_Stow(defer => ['man10', 'info10']); make_dir('../stow/pkg10a/man10/man1'); make_file('../stow/pkg10a/man10/man1/file10.1'); @@ -189,14 +192,15 @@ make_link('man10/man1/file10.1' => '../../../stow/pkg10a/man10/man1/file10.1'); make_dir('../stow/pkg10b/man10/man1'); make_file('../stow/pkg10b/man10/man1/file10.1'); -stow_contents('../stow/pkg10b', './', '../stow/pkg10b'); +$stow->plan_stow('pkg10b'); + stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && readlink('man10/man1/file10.1') eq '../../../stow/pkg10a/man10/man1/file10.1' => 'defer to existing documentation files' ); @@ -204,8 +208,7 @@ ok( # # Ignore temp files # -reset_state(); -$Option{'ignore'} = ['~', '\.#.*']; +$stow = new_Stow(ignore => ['~', '\.#.*']); make_dir('../stow/pkg11/man11/man1'); make_file('../stow/pkg11/man11/man1/file11.1'); @@ -213,10 +216,10 @@ make_file('../stow/pkg11/man11/man1/file11.1~'); make_file('../stow/pkg11/man11/man1/.#file11.1'); make_dir('man11/man1'); -stow_contents('../stow/pkg11', './', '../stow/pkg11'); -process_tasks(); +$stow->plan_stow('pkg11'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && readlink('man11/man1/file11.1') eq '../../../stow/pkg11/man11/man1/file11.1' && !-e 'man11/man1/file11.1~' && !-e 'man11/man1/.#file11.1' @@ -226,17 +229,17 @@ ok( # # stowing links library files # -reset_state(); +$stow = new_Stow(); make_dir('../stow/pkg12/lib12/'); make_file('../stow/pkg12/lib12/lib.so'); make_link('../stow/pkg12/lib12/lib.so.1','lib.so'); make_dir('lib12/'); -stow_contents('../stow/pkg12', './', '../stow/pkg12'); -process_tasks(); +$stow->plan_stow('pkg12'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && readlink('lib12/lib.so.1') eq '../../stow/pkg12/lib12/lib.so.1' => 'stow links to libraries' ); @@ -244,7 +247,7 @@ ok( # # unfolding to stow links to library files # -reset_state(); +$stow = new_Stow(); make_dir('../stow/pkg13a/lib13/'); make_file('../stow/pkg13a/lib13/liba.so'); @@ -255,10 +258,10 @@ make_dir('../stow/pkg13b/lib13/'); make_file('../stow/pkg13b/lib13/libb.so'); make_link('../stow/pkg13b/lib13/libb.so.1', 'libb.so'); -stow_contents('../stow/pkg13b', './', '../stow/pkg13b'); -process_tasks(); +$stow->plan_stow('pkg13b'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && readlink('lib13/liba.so.1') eq '../../stow/pkg13a/lib13/liba.so.1' && readlink('lib13/libb.so.1') eq '../../stow/pkg13b/lib13/libb.so.1' => 'unfolding to stow links to libraries' @@ -267,20 +270,38 @@ ok( # # stowing to stow dir should fail # -reset_state(); -$Stow_Path= 'stow'; +make_dir('stow'); +$stow = new_Stow(dir => 'stow'); make_dir('stow/pkg14/stow/pkg15'); make_file('stow/pkg14/stow/pkg15/node15'); -stow_contents('stow/pkg14', '.', 'stow/pkg14'); +$stow->plan_stow('pkg14'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && ! -l 'stow/pkg15' => "stowing to stow dir should fail" ); + +# +# stow a simple tree minimally when cwd isn't target +# +cd('../..'); +$stow = new_Stow(dir => 't/stow', target => 't/target'); + +make_dir('t/stow/pkg16/bin16'); +make_file('t/stow/pkg16/bin16/file16'); + +$stow->plan_stow('pkg16'); +$stow->process_tasks(); +is($stow->get_conflicts(), 0, 'no conflicts with minimal stow'); +is( + readlink('t/target/bin16'), + '../stow/pkg16/bin16', + => 'minimal stow of a simple tree' +); diff --git a/t/util.pm b/t/testutil.pm similarity index 83% rename from t/util.pm rename to t/testutil.pm index 7241cf6..5c71a20 100755 --- a/t/util.pm +++ b/t/testutil.pm @@ -7,22 +7,31 @@ use strict; use warnings; +use Stow; +use Stow::Util qw(parent); -#===== SUBROUTINE =========================================================== -# Name : reset_state() -# Purpose : reset internal state machine -# Parameters: none -# Returns : n/a -# Throws : n/a -# Comments : none -#============================================================================ -sub reset_state { - @::Tasks = (); - @::Conflicts = (); - %::Link_Task_For = (); - %::Dir_Task_For = (); - %::Option = ( testmode => 1 ); - return; +sub make_fresh_stow_and_target_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); }; + make_dir($dir); + } +} + +sub new_Stow { + my %opts = @_; + $opts{dir} ||= '../stow'; + $opts{target} ||= '.'; + $opts{test_mode} = 1; + return new Stow(%opts); +} + +sub new_compat_Stow { + my %opts = @_; + $opts{compat} = 1; + return new_Stow(%opts); } #===== SUBROUTINE =========================================================== @@ -38,13 +47,13 @@ sub make_link { my ($target, $source) = @_; if (-l $target) { - my $old_source = readlink join('/',parent($target),$source) + my $old_source = readlink join('/', parent($target), $source) or die "could not read link $target/$source"; if ($old_source ne $source) { die "$target already exists but points elsewhere\n"; } } - elsif (-e $target ) { + elsif (-e $target) { die "$target already exists and is not a link\n"; } else { @@ -56,7 +65,7 @@ sub make_link { #===== SUBROUTINE =========================================================== # Name : make_dir() -# Purpose : create a directory and any requiste parents +# Purpose : create a directory and any requisite parents # Parameters: $dir => path to the new directory # Returns : n/a # Throws : fatal error if the directory or any of its parents cannot be @@ -174,4 +183,23 @@ sub remove_dir { return; } +#===== SUBROUTINE =========================================================== +# Name : cd() +# Purpose : wrapper around chdir +# Parameters: $dir => path to chdir to +# Returns : n/a +# Throws : fatal error if the chdir fails +# Comments : none +#============================================================================ +sub cd { + my ($dir) = @_; + chdir $dir or die "Failed to chdir($dir): $!\n"; +} + 1; + +# Local variables: +# mode: perl +# cperl-indent-level: 4 +# end: +# vim: ft=perl diff --git a/t/unstow_contents.t b/t/unstow_contents.t index 80fccc5..cd5fd3a 100755 --- a/t/unstow_contents.t +++ b/t/unstow_contents.t @@ -4,38 +4,36 @@ # Testing unstow_contents() # -# load as a library -BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; } +use strict; +use warnings; -use Test::More tests => 20; +use testutil; + +use Test::More tests => 21; use Test::Output; use English qw(-no_match_vars); -### setup -eval { remove_dir('t/target'); }; -eval { remove_dir('t/stow'); }; -make_dir('t/target'); -make_dir('t/stow'); - -chdir 't/target'; -$Stow_Path= '../stow'; +make_fresh_stow_and_target_dirs(); +cd('t/target'); # Note that each of the following tests use a distinct set of files +my $stow; +my @conflicts; + # # unstow a simple tree minimally # - -reset_state(); +$stow = new_Stow(); make_dir('../stow/pkg1/bin1'); make_file('../stow/pkg1/bin1/file1'); -make_link('bin1','../stow/pkg1/bin1'); +make_link('bin1', '../stow/pkg1/bin1'); -unstow_contents('../stow/pkg1','.'); -process_tasks(); +$stow->plan_unstow('pkg1'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -f '../stow/pkg1/bin1/file1' && ! -e 'bin1' => 'unstow a simple tree' ); @@ -43,16 +41,16 @@ ok( # # unstow a simple tree from an existing directory # -reset_state(); +$stow = new_Stow(); make_dir('lib2'); make_dir('../stow/pkg2/lib2'); make_file('../stow/pkg2/lib2/file2'); make_link('lib2/file2', '../../stow/pkg2/lib2/file2'); -unstow_contents('../stow/pkg2','.'); -process_tasks(); +$stow->plan_unstow('pkg2'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -f '../stow/pkg2/lib2/file2' && -d 'lib2' => 'unstow simple tree from a pre-existing directory' ); @@ -60,7 +58,7 @@ ok( # # fold tree after unstowing # -reset_state(); +$stow = new_Stow(); make_dir('bin3'); @@ -71,10 +69,10 @@ make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow make_dir('../stow/pkg3b/bin3'); make_file('../stow/pkg3b/bin3/file3b'); make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow -unstow_contents('../stow/pkg3b', '.'); -process_tasks(); +$stow->plan_unstow('pkg3b'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'bin3' && readlink('bin3') eq '../stow/pkg3a/bin3' => 'fold tree after unstowing' @@ -83,17 +81,17 @@ ok( # # existing link is owned by stow but is invalid so it gets removed anyway # -reset_state(); +$stow = new_Stow(); make_dir('bin4'); make_dir('../stow/pkg4/bin4'); make_file('../stow/pkg4/bin4/file4'); make_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist'); -unstow_contents('../stow/pkg4', '.'); -process_tasks(); +$stow->plan_unstow('pkg4'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && ! -e 'bin4/file4' => q(remove invalid link owned by stow) ); @@ -101,20 +99,22 @@ ok( # # Existing link is not owned by stow # -reset_state(); +$stow = new_Stow(); make_dir('../stow/pkg5/bin5'); make_link('bin5', '../not-stow'); -unstow_contents('../stow/pkg5', '.'); +$stow->plan_unstow('pkg5'); +@conflicts = $stow->get_conflicts; like( - $Conflicts[-1], qr(CONFLICT:.*existing target is not owned by stow) + $conflicts[-1], qr(CONFLICT:.*existing target is not owned by stow) => q(existing link not owned by stow) ); + # # Target already exists, is owned by stow, but points to a different package # -reset_state(); +$stow = new_Stow(); make_dir('bin6'); make_dir('../stow/pkg6a/bin6'); @@ -124,10 +124,10 @@ make_link('bin6/file6', '../../stow/pkg6a/bin6/file6'); make_dir('../stow/pkg6b/bin6'); make_file('../stow/pkg6b/bin6/file6'); -unstow_contents('../stow/pkg6b', '.'); +$stow->plan_unstow('pkg6b'); ok( - scalar(@Conflicts) == 0 && - -l 'bin6/file6' && + scalar($stow->get_conflicts) == 0 && + -l 'bin6/file6' && readlink('bin6/file6') eq '../../stow/pkg6a/bin6/file6' => q(ignore existing link that points to a different package) ); @@ -135,24 +135,22 @@ ok( # # Don't unlink anything under the stow directory # -reset_state(); - make_dir('stow'); # make out stow dir a subdir of target -$Stow_Path = 'stow'; +$stow = new_Stow(dir => 'stow'); # emulate stowing into ourself (bizarre corner case or accident) make_dir('stow/pkg7a/stow/pkg7b'); make_file('stow/pkg7a/stow/pkg7b/file7b'); make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b'); -unstow_contents('stow/pkg7b', '.'); +$stow->plan_unstow('pkg7b'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg7b' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'stow/pkg7b' && readlink('stow/pkg7b') eq '../stow/pkg7a/stow/pkg7b' => q(don't unlink any nodes under the stow directory) @@ -161,10 +159,7 @@ ok( # # Don't unlink any nodes under another stow directory # -reset_state(); - -make_dir('stow'); # make out stow dir a subdir of target -$Stow_Path = 'stow'; +$stow = new_Stow(dir => 'stow'); make_dir('stow2'); # make our alternate stow dir a subdir of target make_file('stow2/.stow'); @@ -174,14 +169,14 @@ make_dir('stow/pkg8a/stow2/pkg8b'); make_file('stow/pkg8a/stow2/pkg8b/file8b'); make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b'); -unstow_contents('stow/pkg8a', '.'); +$stow->plan_unstow('pkg8a'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg8a' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'stow2/pkg8b' && readlink('stow2/pkg8b') eq '../stow/pkg8a/stow2/pkg8b' => q(don't unlink any nodes under another stow directory) @@ -190,10 +185,8 @@ ok( # # overriding already stowed documentation # -reset_state(); +$stow = new_Stow(override => ['man9', 'info9']); make_file('stow/.stow'); -$Stow_Path = '../stow'; -$Option{'override'} = ['man9', 'info9']; make_dir('../stow/pkg9a/man9/man1'); make_file('../stow/pkg9a/man9/man1/file9.1'); @@ -202,10 +195,10 @@ make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emu make_dir('../stow/pkg9b/man9/man1'); make_file('../stow/pkg9b/man9/man1/file9.1'); -unstow_contents('../stow/pkg9b', '.'); -process_tasks(); +$stow->plan_unstow('pkg9b'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && !-l 'man9/man1/file9.1' => 'overriding existing documentation files' ); @@ -213,8 +206,7 @@ ok( # # deferring to already stowed documentation # -reset_state(); -$Option{'defer'} = ['man10', 'info10']; +$stow = new_Stow(defer => ['man10', 'info10']); make_dir('../stow/pkg10a/man10/man1'); make_file('../stow/pkg10a/man10/man1/file10a.1'); @@ -229,14 +221,14 @@ make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1' make_dir('../stow/pkg10c/man10/man1'); make_file('../stow/pkg10c/man10/man1/file10a.1'); -unstow_contents('../stow/pkg10c', '.'); +$stow->plan_unstow('pkg10c'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg10c' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && readlink('man10/man1/file10a.1') eq '../../../stow/pkg10a/man10/man1/file10a.1' => 'defer to existing documentation files' ); @@ -244,8 +236,7 @@ ok( # # Ignore temp files # -reset_state(); -$Option{'ignore'} = ['~', '\.#.*']; +$stow = new_Stow(ignore => ['~', '\.#.*']); make_dir('../stow/pkg12/man12/man1'); make_file('../stow/pkg12/man12/man1/file12.1'); @@ -254,10 +245,10 @@ make_file('../stow/pkg12/man12/man1/.#file12.1'); make_dir('man12/man1'); make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1'); -unstow_contents('../stow/pkg12', '.'); -process_tasks(); +$stow->plan_unstow('pkg12'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && !-e 'man12/man1/file12.1' => 'ignore temp files' ); @@ -265,15 +256,15 @@ ok( # # Unstow an already unstowed package # -reset_state(); -unstow_contents('../stow/pkg12', '.'); +$stow = new_Stow(); +$stow->plan_unstow('pkg12'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg12' ); ok( - scalar(@Conflicts) == 0 + scalar($stow->get_conflicts) == 0 => 'unstow already unstowed package pkg12' ); @@ -284,15 +275,15 @@ ok( eval { remove_dir('t/target'); }; mkdir('t/target'); -reset_state(); -unstow_contents('../stow/pkg12', '.'); +$stow = new_Stow(); +$stow->plan_unstow('pkg12'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg12 which was never stowed' ); ok( - scalar(@Conflicts) == 0 + scalar($stow->get_conflicts) == 0 => 'unstow never stowed package pkg12' ); @@ -301,19 +292,38 @@ ok( # make_file('man12/man1/file12.1'); -reset_state(); -unstow_contents('../stow/pkg12', '.'); +$stow = new_Stow(); +$stow->plan_unstow('pkg12'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg12 for third time' ); +@conflicts = $stow->get_conflicts; ok( - scalar(@Conflicts) == 1 && - $Conflicts[0] =~ m!existing target is neither a link nor a directory: man12/man1/file12\.1! + @conflicts == 1 && + $conflicts[0] =~ m!existing target is neither a link nor a directory: man12/man1/file12\.1! => 'unstow pkg12 for third time' ); +# +# unstow a simple tree minimally when cwd isn't target +# +cd('../..'); +$stow = new_Stow(dir => 't/stow', target => 't/target'); + +make_dir('t/stow/pkg13/bin13'); +make_file('t/stow/pkg13/bin13/file13'); +make_link('t/target/bin13', '../stow/pkg13/bin13'); + +$stow->plan_unstow('pkg13'); +$stow->process_tasks(); +ok( + scalar($stow->get_conflicts) == 0 && + -f 't/stow/pkg13/bin13/file13' && ! -e 't/target/bin13' + => 'unstow a simple tree' +); + # Todo # diff --git a/t/unstow_contents_orig.t b/t/unstow_contents_orig.t index d41d9c1..e120480 100755 --- a/t/unstow_contents_orig.t +++ b/t/unstow_contents_orig.t @@ -4,38 +4,37 @@ # Testing unstow_contents_orig() # -# load as a library -BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; } +use strict; +use warnings; -use Test::More tests => 20; +use testutil; + +use Test::More tests => 21; use Test::Output; use English qw(-no_match_vars); -### setup -eval { remove_dir('t/target'); }; -eval { remove_dir('t/stow'); }; -make_dir('t/target'); -make_dir('t/stow'); - -chdir 't/target'; -$Stow_Path= '../stow'; +make_fresh_stow_and_target_dirs(); +cd('t/target'); # Note that each of the following tests use a distinct set of files +my $stow; +my @conflicts; + # # unstow a simple tree minimally # -reset_state(); +$stow = new_compat_Stow(); make_dir('../stow/pkg1/bin1'); make_file('../stow/pkg1/bin1/file1'); -make_link('bin1','../stow/pkg1/bin1'); +make_link('bin1', '../stow/pkg1/bin1'); -unstow_contents_orig('../stow/pkg1','.'); -process_tasks(); +$stow->plan_unstow('pkg1'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -f '../stow/pkg1/bin1/file1' && ! -e 'bin1' => 'unstow a simple tree' ); @@ -43,16 +42,16 @@ ok( # # unstow a simple tree from an existing directory # -reset_state(); +$stow = new_compat_Stow(); make_dir('lib2'); make_dir('../stow/pkg2/lib2'); make_file('../stow/pkg2/lib2/file2'); make_link('lib2/file2', '../../stow/pkg2/lib2/file2'); -unstow_contents_orig('../stow/pkg2','.'); -process_tasks(); +$stow->plan_unstow('pkg2'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -f '../stow/pkg2/lib2/file2' && -d 'lib2' => 'unstow simple tree from a pre-existing directory' ); @@ -60,7 +59,7 @@ ok( # # fold tree after unstowing # -reset_state(); +$stow = new_compat_Stow(); make_dir('bin3'); @@ -71,10 +70,10 @@ make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow make_dir('../stow/pkg3b/bin3'); make_file('../stow/pkg3b/bin3/file3b'); make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow -unstow_contents_orig('../stow/pkg3b', '.'); -process_tasks(); +$stow->plan_unstow('pkg3b'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'bin3' && readlink('bin3') eq '../stow/pkg3a/bin3' => 'fold tree after unstowing' @@ -83,17 +82,17 @@ ok( # # existing link is owned by stow but is invalid so it gets removed anyway # -reset_state(); +$stow = new_compat_Stow(); make_dir('bin4'); make_dir('../stow/pkg4/bin4'); make_file('../stow/pkg4/bin4/file4'); make_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist'); -unstow_contents_orig('../stow/pkg4', '.'); -process_tasks(); +$stow->plan_unstow('pkg4'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && ! -e 'bin4/file4' => q(remove invalid link owned by stow) ); @@ -101,12 +100,12 @@ ok( # # Existing link is not owned by stow # -reset_state(); +$stow = new_compat_Stow(); make_dir('../stow/pkg5/bin5'); make_link('bin5', '../not-stow'); -unstow_contents_orig('../stow/pkg5', '.'); +$stow->plan_unstow('pkg5'); #like( # $Conflicts[-1], qr(CONFLICT:.*can't unlink.*not owned by stow) # => q(existing link not owned by stow) @@ -115,10 +114,11 @@ ok( -l 'bin5' && readlink('bin5') eq '../not-stow' => q(existing link not owned by stow) ); + # # Target already exists, is owned by stow, but points to a different package # -reset_state(); +$stow = new_compat_Stow(); make_dir('bin6'); make_dir('../stow/pkg6a/bin6'); @@ -128,9 +128,9 @@ make_link('bin6/file6', '../../stow/pkg6a/bin6/file6'); make_dir('../stow/pkg6b/bin6'); make_file('../stow/pkg6b/bin6/file6'); -unstow_contents_orig('../stow/pkg6b', '.'); +$stow->plan_unstow('pkg6b'); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'bin6/file6' && readlink('bin6/file6') eq '../../stow/pkg6a/bin6/file6' => q(ignore existing link that points to a different package) @@ -139,24 +139,22 @@ ok( # # Don't unlink anything under the stow directory # -reset_state(); - make_dir('stow'); # make out stow dir a subdir of target -$Stow_Path = 'stow'; +$stow = new_compat_Stow(dir => 'stow'); # emulate stowing into ourself (bizarre corner case or accident) make_dir('stow/pkg7a/stow/pkg7b'); make_file('stow/pkg7a/stow/pkg7b/file7b'); make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b'); -unstow_contents_orig('stow/pkg7b', '.'); +$stow->plan_unstow('pkg7b'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg7b' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'stow/pkg7b' && readlink('stow/pkg7b') eq '../stow/pkg7a/stow/pkg7b' => q(don't unlink any nodes under the stow directory) @@ -165,10 +163,7 @@ ok( # # Don't unlink any nodes under another stow directory # -reset_state(); - -make_dir('stow'); # make out stow dir a subdir of target -$Stow_Path = 'stow'; +$stow = new_compat_Stow(dir => 'stow'); make_dir('stow2'); # make our alternate stow dir a subdir of target make_file('stow2/.stow'); @@ -178,14 +173,14 @@ make_dir('stow/pkg8a/stow2/pkg8b'); make_file('stow/pkg8a/stow2/pkg8b/file8b'); make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b'); -unstow_contents_orig('stow/pkg8a', '.'); +$stow->plan_unstow('pkg8a'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg8a' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && -l 'stow2/pkg8b' && readlink('stow2/pkg8b') eq '../stow/pkg8a/stow2/pkg8b' => q(don't unlink any nodes under another stow directory) @@ -194,10 +189,8 @@ ok( # # overriding already stowed documentation # -reset_state(); +$stow = new_compat_Stow(override => ['man9', 'info9']); make_file('stow/.stow'); -$Stow_Path = '../stow'; -$Option{'override'} = ['man9', 'info9']; make_dir('../stow/pkg9a/man9/man1'); make_file('../stow/pkg9a/man9/man1/file9.1'); @@ -206,10 +199,10 @@ make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emu make_dir('../stow/pkg9b/man9/man1'); make_file('../stow/pkg9b/man9/man1/file9.1'); -unstow_contents_orig('../stow/pkg9b', '.'); -process_tasks(); +$stow->plan_unstow('pkg9b'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && !-l 'man9/man1/file9.1' => 'overriding existing documentation files' ); @@ -217,8 +210,7 @@ ok( # # deferring to already stowed documentation # -reset_state(); -$Option{'defer'} = ['man10', 'info10']; +$stow = new_compat_Stow(defer => ['man10', 'info10']); make_dir('../stow/pkg10a/man10/man1'); make_file('../stow/pkg10a/man10/man1/file10a.1'); @@ -233,14 +225,14 @@ make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1' make_dir('../stow/pkg10c/man10/man1'); make_file('../stow/pkg10c/man10/man1/file10a.1'); -unstow_contents_orig('../stow/pkg10c', '.'); +$stow->plan_unstow('pkg10c'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg10c' ); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && readlink('man10/man1/file10a.1') eq '../../../stow/pkg10a/man10/man1/file10a.1' => 'defer to existing documentation files' ); @@ -248,8 +240,7 @@ ok( # # Ignore temp files # -reset_state(); -$Option{'ignore'} = ['~', '\.#.*']; +$stow = new_compat_Stow(ignore => ['~', '\.#.*']); make_dir('../stow/pkg12/man12/man1'); make_file('../stow/pkg12/man12/man1/file12.1'); @@ -258,10 +249,10 @@ make_file('../stow/pkg12/man12/man1/.#file12.1'); make_dir('man12/man1'); make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1'); -unstow_contents_orig('../stow/pkg12', '.'); -process_tasks(); +$stow->plan_unstow('pkg12'); +$stow->process_tasks(); ok( - scalar(@Conflicts) == 0 && + scalar($stow->get_conflicts) == 0 && !-e 'man12/man1/file12.1' => 'ignore temp files' ); @@ -269,15 +260,15 @@ ok( # # Unstow an already unstowed package # -reset_state(); -unstow_contents_orig('../stow/pkg12', '.'); +$stow = new_compat_Stow(); +$stow->plan_unstow('pkg12'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg12' ); ok( - scalar(@Conflicts) == 0 + scalar($stow->get_conflicts) == 0 => 'unstow already unstowed package pkg12' ); @@ -288,15 +279,15 @@ ok( eval { remove_dir('t/target'); }; mkdir('t/target'); -reset_state(); -unstow_contents_orig('../stow/pkg12', '.'); +$stow = new_compat_Stow(); +$stow->plan_unstow('pkg12'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg12 which was never stowed' ); ok( - scalar(@Conflicts) == 0 + scalar($stow->get_conflicts) == 0 => 'unstow never stowed package pkg12' ); @@ -305,19 +296,38 @@ ok( # make_file('man12/man1/file12.1'); -reset_state(); -unstow_contents('../stow/pkg12', '.'); +$stow = new_compat_Stow(); +$stow->plan_unstow('pkg12'); stderr_like( - sub { process_tasks(); }, + sub { $stow->process_tasks(); }, qr/There are no outstanding operations to perform/, 'no tasks to process when unstowing pkg12 for third time' ); +@conflicts = $stow->get_conflicts; ok( - scalar(@Conflicts) == 1 && - $Conflicts[0] =~ m!existing target is neither a link nor a directory: man12/man1/file12\.1! + @conflicts == 1 && + $conflicts[0] =~ m!existing target is neither a link nor a directory: man12/man1/file12\.1! => 'unstow pkg12 for third time' ); +# +# unstow a simple tree minimally when cwd isn't target +# +cd('../..'); +$stow = new_Stow(dir => 't/stow', target => 't/target'); + +make_dir('t/stow/pkg13/bin13'); +make_file('t/stow/pkg13/bin13/file13'); +make_link('t/target/bin13', '../stow/pkg13/bin13'); + +$stow->plan_unstow('pkg13'); +$stow->process_tasks(); +ok( + scalar($stow->get_conflicts) == 0 && + -f 't/stow/pkg13/bin13/file13' && ! -e 't/target/bin13' + => 'unstow a simple tree' +); + # Todo #