#!/usr/bin/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 = '2.0.2';
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