1676 lines
53 KiB
Perl
Executable file
1676 lines
53 KiB
Perl
Executable file
#!/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</usr/local/stow/emacs> vs. C</usr/local/stow/perl>, for example)
|
|
while making them appear to be installed in the same place
|
|
(C</usr/local>).
|
|
|
|
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<dir> parameter passed
|
|
to the L<new()> 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<get_conflicts()>.
|
|
|
|
=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<get_conflicts()>.
|
|
|
|
=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
|