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

1730 lines
56 KiB
Perl
Executable file
Raw Blame History

#!@PERL@
# GNU Stow - manage the installation of multiple software packages
# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
# Copyright (C) 2000, 2001 Guillaume Morin
# Copyright (C) 2007 Kahlil Hodgson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
use strict;
use warnings;
require 5.6.1;
use File::Spec;
use POSIX qw(getcwd);
use Getopt::Long;
my $Version = '@VERSION@';
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.
# 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 => [],
);
# 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();
# 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");
}
# --verbose: tell me what you are planning to do
# --simulate: don't execute planned operations
# --conflicts: just list any detected conflicts
if (scalar @Conflicts) {
warn "WARNING: conflicts detected.\n";
if ($Option{'conflicts'}) {
map { warn $_ } @Conflicts;
}
warn "WARNING: all operations aborted.\n";
}
else {
process_tasks();
}
}
#===== SUBROUTINE ===========================================================
# Name : process_options()
# Purpose : parse command line options and update the %Option hash
# Parameters: none
# Returns : n/a
# Throws : a fatal error if a bad command line option is given
# Comments : checks @ARGV for valid package names
#============================================================================
sub process_options {
get_defaults();
#$,="\n"; print @ARGV,"\n"; # for debugging rc file
Getopt::Long::config('no_ignore_case', 'bundling', 'permute');
GetOptions(
\%Option,
'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 {
my $regex = strip_quotes($_[1]);
push @{$Option{'ignore'}}, qr($regex\z)
},
'override=s' =>
sub {
my $regex = strip_quotes($_[1]);
push @{$Option{'override'}}, qr(\A$regex)
},
'defer=s' =>
sub {
my $regex = strip_quotes($_[1]);
push @{$Option{'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' },
'<>' =>
sub {
if ($Option{'action'} eq 'restow') {
push @Pkgs_To_Delete, $_[0];
push @Pkgs_To_Stow, $_[0];
}
elsif ($Option{'action'} eq 'delete') {
push @Pkgs_To_Delete, $_[0];
}
else {
push @Pkgs_To_Stow, $_[0];
}
},
) or usage();
#print "$Option{'dir'}\n"; print "$Option{'target'}\n"; exit;
# clean any leading and trailing whitespace in paths
if ($Option{'dir'}) {
$Option{'dir'} =~ s/\A +//;
$Option{'dir'} =~ s/ +\z//;
}
if ($Option{'target'}) {
$Option{'target'} =~ s/\A +//;
$Option{'target'} =~ s/ +\z//;
}
if ($Option{'help'}) {
usage();
}
if ($Option{'version'}) {
version();
}
if ($Option{'conflicts'}) {
$Option{'simulate'} = 1;
}
if (not scalar @Pkgs_To_Stow and not scalar @Pkgs_To_Delete) {
usage("No packages named");
}
# check package arguments
for my $package ((@Pkgs_To_Stow, @Pkgs_To_Delete)) {
$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'}) {
print "# $msg\n" if $ENV{TEST_VERBOSE};
}
elsif ($Option{'verbose'} >= $level) {
warn "$msg\n";
}
}
#===== SUBROUTINE ============================================================
# Name : get_defaults()
# Purpose : search for default settings in any .stow files
# Parameters: none
# Returns : n/a
# Throws : no exceptions
# Comments : prepends the contents '~/.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 {
my @defaults = ();
for my $file ($ENV{'HOME'}.'/.stowrc', '.stowrc') {
if (-r $file) {
warn "Loading defaults from $file\n";
open my $FILE, '<', $file
or die "Could not open $file for reading\n";
while (my $line = <$FILE>){
chomp $line;
push @defaults, split " ", $line;
}
close $FILE or die "Could not close open file: $file\n";
}
}
# doing this inline does not seem to work
unshift @ARGV, @defaults;
return;
}
#===== SUBROUTINE ===========================================================
# Name : usage()
# Purpose : print program usage message and exit
# Parameters: $msg => string to prepend to the usage message
# Returns : n/a
# Throws : n/a
# Comments : if 'msg' is given, then exit with non-zero status
#============================================================================
sub usage {
my ($msg) = @_;
if ($msg) {
print "$ProgramName: $msg\n\n";
}
print <<"EOT";
$ProgramName (GNU Stow) version $Version
SYNOPSIS:
$ProgramName [OPTION ...] [-D|-S|-R] PACKAGE ... [-D|-S|-R] PACKAGE ...
OPTIONS:
-n, --no Do not actually make any filesystem changes
-c, --conflicts Scan for and print any conflicts, implies -n
-d DIR, --dir=DIR Set stow dir to DIR (default is current dir)
-t DIR, --target=DIR Set target to DIR (default is parent of stow dir)
-v, --verbose[=N] Increase verbosity (levels are 0,1,2,3;
-v or --verbose adds 1; --verbose=N sets level)
-S, --stow Stow the package names that follow this option
-D, --delete Unstow the package names that follow this option
-R, --restow Restow (like stow -D followed by stow -S)
-p, --compat use legacy algorithm for unstowing
--ignore=REGEX ignore files ending in this perl regex
--defer=REGEX defer stowing files begining with this perl regex
if the file is already stowed to another package
--override=REGEX force stowing files begining with this perl regex
if the file is already stowed to another package
-V, --version Show stow version number
-h, --help Show this help
EOT
exit $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");
}
#===== 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) = @_;
my $cwd = getcwd();
debug(2, "Stowing contents of $path (cwd is $cwd)");
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 : 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) = @_;
# don't try to remove anything under a stow directory
if ($target eq $Stow_Path or -e "$target/.stow" or -e "$target/.nonstow") {
return;
}
my $cwd = getcwd();
debug(2, "Unstowing from $target (compat mode, cwd is $cwd)");
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);
}
}
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) = @_;
# don't try to remove anything under a stow directory
if ($target eq $Stow_Path or -e "$target/.stow") {
return;
}
my $cwd = getcwd();
debug(2, "Unstowing from $target (cwd is $cwd)");
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},
);
}
}
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 ============================================================
# Name : strip_quotes
# Purpose : remove matching outer quotes from the given string
# Parameters: none
# Returns : n/a
# Throws : no exceptions
# Comments : none
#=============================================================================
sub strip_quotes {
my ($string) = @_;
if ($string =~ m{\A\s*'(.*)'\s*\z}) {
return $1;
}
elsif ($string =~ m{\A\s*"(.*)"\s*\z}) {
return $1
}
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
# cperl-indent-level: 4
# end:
# vim: ft=perl
Reference in a new issue View git blame Copy permalink