1795 lines
56 KiB
Perl
Executable file
1795 lines
56 KiB
Perl
Executable file
#!@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.005;
|
|
use POSIX qw(getcwd);
|
|
use Getopt::Long;
|
|
|
|
my $Version = '@VERSION@';
|
|
my $ProgramName = $0;
|
|
$ProgramName =~ s{.*/}{};
|
|
|
|
# Verbosity rules:
|
|
#
|
|
# 0: errors only
|
|
# > 0: print operations: LINK/UNLINK/MKDIR/RMDIR
|
|
# > 1: print trace: stow/unstow package/contents/node
|
|
# > 2: print trace detail: "_this_ already points to _that_"
|
|
#
|
|
# 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 packges 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 conflcits 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 structurew 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 structurew allows us to quickly determine if a path has an existing
|
|
# directory task associated with it.
|
|
our %Link_Task_For = ();
|
|
|
|
# NB: directory tasks and link tasks are NOT mutually exclusive
|
|
|
|
# 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");
|
|
}
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Unstowing package $package...\n";
|
|
}
|
|
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
|
|
);
|
|
}
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Unstowing package $package...done\n";
|
|
}
|
|
}
|
|
|
|
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");
|
|
}
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Stowing package $package...\n";
|
|
}
|
|
stow_contents(
|
|
join_paths($Stow_Path,$package), # path package
|
|
'', # target is current dir
|
|
join_paths($Stow_Path,$package), # source from target
|
|
);
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Stowing package $package...done\n";
|
|
}
|
|
}
|
|
|
|
# --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(
|
|
'v' => sub { $Option{'verbose'}++ },
|
|
'verbose=s' => sub { $Option{'verbose'} = $_[1] },
|
|
'h|help' => sub { $Option{'help'} = '1' },
|
|
'n|no|simulate' => sub { $Option{'simulate'} = '1' },
|
|
'c|conflicts' => sub { $Option{'conflicts'} = '1' },
|
|
'V|version' => sub { $Option{'version'} = '1' },
|
|
'p|compat' => sub { $Option{'compat'} = '1' },
|
|
'd|dir=s' => sub { $Option{'dir'} = $_[1] },
|
|
't|target=s' => sub { $Option{'target'} = $_[1] },
|
|
|
|
# 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 : 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 noremal 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 the current directory
|
|
if (not $Option{'dir'} ) {
|
|
$Option{'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 = relative_path(getcwd(),$stow_dir);
|
|
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "current dir is ".getcwd()."\n";
|
|
warn "stow dir path is $Stow_Path\n";
|
|
}
|
|
}
|
|
|
|
#===== SUBROUTINE ===========================================================
|
|
# Name : stow_contents()
|
|
# Purpose : stow the contents of the given directory
|
|
# Parameters: $path => relative path to source dir from current directory
|
|
# : $source => relative path to symlink source from the dir of target
|
|
# : $target => relative path to symlink target from the current directory
|
|
# 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) = @_;
|
|
|
|
if ($Option{'verbose'} > 1){
|
|
warn "Stowing contents of $path\n";
|
|
}
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- $target => $source\n";
|
|
}
|
|
|
|
if (not -d $path) {
|
|
error("stow_contents() called on a non-directory: $path");
|
|
}
|
|
|
|
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 => realtive path to source node from the current directory
|
|
# : $target => realtive path to symlink target from the current directory
|
|
# : $source => realtive 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) = @_;
|
|
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Stowing $path\n";
|
|
}
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- $target => $source\n";
|
|
}
|
|
|
|
# don't try to stow absolute symlinks (they cant 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");
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "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");
|
|
}
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- Evaluate existing link: $target => $old_source\n";
|
|
}
|
|
|
|
# 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) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- Skipping $target as it already points to $source\n";
|
|
}
|
|
}
|
|
elsif (defer($target)) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- deferring installation of: $target\n";
|
|
}
|
|
}
|
|
elsif (override($target)) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- overriding installation of: $target\n";
|
|
}
|
|
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 the tree at that point
|
|
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- Unfolding $target\n";
|
|
}
|
|
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
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- replacing invalid link: $path\n";
|
|
}
|
|
do_unlink($target);
|
|
do_link($source, $target);
|
|
}
|
|
}
|
|
elsif (is_a_node($target)) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn("--- Evaluate existing node: $target\n");
|
|
}
|
|
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() and unstow_contents() 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;
|
|
}
|
|
if ($Option{'verbose'} > 1){
|
|
warn "Unstowing in $target\n";
|
|
}
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- path is $path\n";
|
|
}
|
|
if (not -d $target) {
|
|
error("unstow_contents() called on a non-directory: $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) = @_;
|
|
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Unstowing $target\n";
|
|
}
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- path is $path\n";
|
|
}
|
|
|
|
# does the target exist
|
|
if (is_a_link($target)) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn("Evaluate existing link: $target\n");
|
|
}
|
|
|
|
# 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 points to the right place
|
|
if ($old_path eq $path) {
|
|
do_unlink($target);
|
|
}
|
|
elsif (override($target)) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn("--- overriding installation of: $target\n");
|
|
}
|
|
do_unlink($target);
|
|
}
|
|
# else leave it alone
|
|
}
|
|
else {
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- removing invalid link into a stow directory: $path\n";
|
|
}
|
|
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 target tree, rather than the source 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;
|
|
}
|
|
if ($Option{'verbose'} > 1){
|
|
warn "Unstowing in $target\n";
|
|
}
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- path is $path\n";
|
|
}
|
|
if (not -d $path) {
|
|
error("unstow_contents() called on a non-directory: $path");
|
|
}
|
|
|
|
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) = @_;
|
|
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Unstowing $path\n";
|
|
}
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- target is $target\n";
|
|
}
|
|
|
|
# does the target exist
|
|
if (is_a_link($target)) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn("Evaluate existing link: $target\n");
|
|
}
|
|
|
|
# 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)) {
|
|
# if ($Option{'verbose'} > 2) {
|
|
# warn("--- deferring to installation of: $target\n");
|
|
# }
|
|
#}
|
|
#elsif (override($target)) {
|
|
# if ($Option{'verbose'} > 2) {
|
|
# warn("--- overriding installation of: $target\n");
|
|
# }
|
|
# do_unlink($target);
|
|
#}
|
|
#else {
|
|
# conflict(
|
|
# q{existing target is stowed to a different package: %s => %s},
|
|
# $target,
|
|
# $old_source
|
|
# );
|
|
#}
|
|
}
|
|
else {
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- removing invalid link into a stow directory: $path\n";
|
|
}
|
|
do_unlink($target);
|
|
}
|
|
}
|
|
elsif (-e $target) {
|
|
if ($Option{'verbose'} > 2) {
|
|
warn("Evaluate existing node: $target\n");
|
|
}
|
|
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
|
|
){
|
|
if ($Option{'verbose'} > 2) {
|
|
warn "--- removing stale link: $node_path => ",
|
|
join_paths($dir,$source), "\n";
|
|
}
|
|
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) = @_;
|
|
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- Is $target foldable?\n";
|
|
}
|
|
|
|
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)) {
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- $target is foldable\n";
|
|
}
|
|
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) = @_;
|
|
|
|
if ($Option{'verbose'} > 2){
|
|
warn "--- Folding tree: $target => $source\n";
|
|
}
|
|
|
|
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: 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);
|
|
|
|
if ($Option{'verbose'}) {
|
|
warn qq{CONFLICT: $message\n};
|
|
}
|
|
push @Conflicts, qq{CONFLICT: $message\n};
|
|
return;
|
|
}
|
|
|
|
#===== SUBROUTINE ============================================================
|
|
# Name : ignore
|
|
# Purpose : determine if the given path matches a regex in our ignore list
|
|
# Parameters: none
|
|
# 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: none
|
|
# 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: none
|
|
# 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 {
|
|
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Processing tasks...\n"
|
|
}
|
|
|
|
# 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'}));
|
|
}
|
|
}
|
|
if ($Option{'verbose'} > 1) {
|
|
warn "Processing tasks...done\n"
|
|
}
|
|
return;
|
|
}
|
|
|
|
#===== SUBROUTINE ===========================================================
|
|
# Name : is_a_link()
|
|
# Purpose : is the given path a current or planned link
|
|
# Parameters: none
|
|
# Returns : Boolean
|
|
# Throws : none
|
|
# Comments : returns false if an existing link is scheduled for removal
|
|
# : and true if a non-exsitent link is scheduled for creation
|
|
#============================================================================
|
|
sub is_a_link {
|
|
my ($path) = @_;
|
|
|
|
|
|
if ( exists $Link_Task_For{$path} ) {
|
|
|
|
my $action = $Link_Task_For{$path}->{'action'};
|
|
|
|
if ($action eq 'remove') {
|
|
return 0;
|
|
}
|
|
elsif ($action eq 'create') {
|
|
return 1;
|
|
}
|
|
else {
|
|
internal_error("bad task action: $action");
|
|
}
|
|
}
|
|
elsif (-l $path) {
|
|
# check if any of its parent are links scheduled for removal
|
|
# (need this for edge case during unfolding)
|
|
my $parent = '';
|
|
for my $part (split m{/+}, $path ) {
|
|
$parent = join_paths($parent,$part);
|
|
if ( exists $Link_Task_For{$parent} ) {
|
|
if ($Link_Task_For{$parent}->{'action'} eq 'remove') {
|
|
return 0;
|
|
}
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
|
|
#===== SUBROUTINE ===========================================================
|
|
# Name : is_a_dir()
|
|
# Purpose : is the given path a current or planned directory
|
|
# Parameters: none
|
|
# 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) = @_;
|
|
|
|
if ( exists $Dir_Task_For{$path} ) {
|
|
my $action = $Dir_Task_For{$path}->{'action'};
|
|
if ($action eq 'remove') {
|
|
return 0;
|
|
}
|
|
elsif ($action eq 'create') {
|
|
return 1;
|
|
}
|
|
else {
|
|
internal_error("bad task action: $action");
|
|
}
|
|
}
|
|
|
|
# are we really following a link that is scheduled for removal
|
|
my $prefix = '';
|
|
for my $part (split m{/+}, $path) {
|
|
$prefix = join_paths($prefix,$part);
|
|
if (exists $Link_Task_For{$prefix} and
|
|
$Link_Task_For{$prefix}->{'action'} eq 'remove') {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
if (-d $path) {
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
#===== SUBROUTINE ===========================================================
|
|
# Name : is_a_node()
|
|
# Purpose : is the given path a current or planned node
|
|
# Parameters: none
|
|
# 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) = @_;
|
|
|
|
if ( exists $Link_Task_For{$path} ) {
|
|
|
|
my $action = $Link_Task_For{$path}->{'action'};
|
|
|
|
if ($action eq 'remove') {
|
|
return 0;
|
|
}
|
|
elsif ($action eq 'create') {
|
|
return 1;
|
|
}
|
|
else {
|
|
internal_error("bad task action: $action");
|
|
}
|
|
}
|
|
|
|
if ( exists $Dir_Task_For{$path} ) {
|
|
|
|
my $action = $Dir_Task_For{$path}->{'action'};
|
|
|
|
if ($action eq 'remove') {
|
|
return 0;
|
|
}
|
|
elsif ($action eq 'create') {
|
|
return 1;
|
|
}
|
|
else {
|
|
internal_error("bad task action: $action");
|
|
}
|
|
}
|
|
|
|
# are we really following a link that is scheduled for removal
|
|
my $prefix = '';
|
|
for my $part (split m{/+}, $path) {
|
|
$prefix = join_paths($prefix,$part);
|
|
if ( exists $Link_Task_For{$prefix} and
|
|
$Link_Task_For{$prefix}->{'action'} eq 'remove') {
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
if (-e $path) {
|
|
return 1;
|
|
}
|
|
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 ( exists $Link_Task_For{$path} ) {
|
|
my $action = $Link_Task_For{$path}->{'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"
|
|
);
|
|
}
|
|
else {
|
|
internal_error("bad task action: $action");
|
|
}
|
|
}
|
|
elsif (-l $path) {
|
|
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: file => 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 {
|
|
if ($Option{'verbose'}) {
|
|
warn "LINK: $newfile => $oldfile (duplicates previous action)\n";
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
elsif ( $task_ref->{'action'} eq 'remove' ) {
|
|
if ( $task_ref->{'source'} eq $oldfile ) {
|
|
# no need to remove a link we are going to recreate
|
|
if ($Option{'verbose'}) {
|
|
warn "LINK: $newfile => $oldfile (reverts previous action)\n";
|
|
}
|
|
$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
|
|
if ($Option{'verbose'}) {
|
|
warn "LINK: $newfile => $oldfile\n";
|
|
}
|
|
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' ) {
|
|
if ($Option{'verbose'}) {
|
|
warn "UNLINK: $file (duplicates previous action)\n";
|
|
}
|
|
return;
|
|
}
|
|
elsif ( $task_ref->{'action'} eq 'create' ) {
|
|
# do need to create a link then remove it
|
|
if ($Option{'verbose'}) {
|
|
warn "UNLINK: $file (reverts previous action)\n";
|
|
}
|
|
$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
|
|
if ($Option{'verbose'}) {
|
|
#warn "UNLINK: $file (".(caller())[2].")\n";
|
|
warn "UNLINK: $file\n";
|
|
}
|
|
|
|
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') {
|
|
if ($Option{'verbose'}) {
|
|
warn "MKDIR: $dir (duplicates previous action)\n";
|
|
}
|
|
return;
|
|
}
|
|
elsif ($task_ref->{'action'} eq 'remove') {
|
|
if ($Option{'verbose'}) {
|
|
warn "MKDIR: $dir (reverts previous action)\n";
|
|
}
|
|
$Dir_Task_For{$dir}->{'action'} = 'skip';
|
|
delete $Dir_Task_For{$dir};
|
|
return;
|
|
}
|
|
else {
|
|
internal_error("bad task action: $task_ref->{'action'}");
|
|
}
|
|
}
|
|
|
|
if ($Option{'verbose'}) {
|
|
warn "MKDIR: $dir\n";
|
|
}
|
|
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' ) {
|
|
if ($Option{'verbose'}) {
|
|
warn "RMDIR $dir (duplicates previous action)\n";
|
|
}
|
|
return;
|
|
}
|
|
elsif ($task_ref->{'action'} eq 'create' ) {
|
|
if ($Option{'verbose'}) {
|
|
warn "MKDIR $dir (reverts previous action)\n";
|
|
}
|
|
$Link_Task_For{$dir}->{'action'} = 'skip';
|
|
delete $Link_Task_For{$dir};
|
|
return;
|
|
}
|
|
else {
|
|
internal_error("bad task action: $task_ref->{'action'}");
|
|
}
|
|
}
|
|
|
|
if ($Option{'verbose'}) {
|
|
warn "RMDIR $dir\n";
|
|
}
|
|
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 : relative_path()
|
|
# Purpose : find the relative path between two given paths
|
|
# Parameters: path1 => a directory path
|
|
# : path2 => a directory path
|
|
# Returns : path2 relative to path1
|
|
# Throws : n/a
|
|
# Comments : only used once by main interactive routine
|
|
# : factored out for testing
|
|
#============================================================================
|
|
sub relative_path {
|
|
|
|
my ($path1, $path2) = @_;
|
|
|
|
my (@path1) = split m{/+}, $path1;
|
|
my (@path2) = split m{/+}, $path2;
|
|
|
|
# drop common prefixes until we find a difference
|
|
PREFIX:
|
|
while ( @path1 && @path2 ) {
|
|
last PREFIX if $path1[0] ne $path2[0];
|
|
shift @path1;
|
|
shift @path2;
|
|
}
|
|
|
|
# prepend one '..' to $path2 for each component of $path1
|
|
while ( shift @path1 ) {
|
|
unshift @path2, '..';
|
|
}
|
|
|
|
return join_paths(@path2);
|
|
}
|
|
|
|
#===== SUBROUTINE ===========================================================
|
|
# Name : join_path()
|
|
# 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
|
|
# End:
|
|
# vim: ft=perl
|