stow/stow.in

#!@PERL@

# GNU Stow - manage the installation of multiple software packages
# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
# Copyright (C) 2000, 2001 Guillaume Morin
# Copyright (C) 2007 Kahlil Hodgson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

use strict;
use warnings;

require 5.6.1;

use File::Spec;
use POSIX qw(getcwd);
use Getopt::Long;

my $Version = '@VERSION@';
my $ProgramName = $0;
$ProgramName =~ s{.*/}{};

# Verbosity rules:
#
#    0: errors only
# >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR
# >= 2: print trace: stow/unstow package/contents/node
# >= 3: print trace detail: "_this_ already points to _that_"
# >= 4: debug helper routines
#
# All output (except for version() and usage()) is to stderr to preserve
# backward compatibility.

# These are the defaults for command line options
our %Option = (
    help       => 0,
    conflicts  => 0,
    action     => 'stow',
    simulate   => 0,
    verbose    => 0,
    paranoid   => 0,
    dir        => undef,
    target     => undef,
    ignore     => [],
    override   => [],
    defer      => [],
);

# This becomes static after option processing
our $Stow_Path; # only use in main loop and find_stowed_path()

# Store conflicts during pre-processing
our @Conflicts = ();

# Store command line packages to stow (-S and -R)
our @Pkgs_To_Stow   = ();

# Store command line packages to unstow (-D and -R)
our @Pkgs_To_Delete = ();

# The following structures are used by the abstractions that allow us to 
# defer operating on the filesystem until after all potential conflicts have
# been assessed.

# our @Tasks:  list of operations to be performed (in order)
# each element is a hash ref of the form 
#   { 
#       action => ...
#       type   => ... 
#       path   => ...  (unique)
#       source => ...  (only for links) 
#   } 
our @Tasks    = (); 

# my %Dir_Task_For: map a path to the corresponding directory task reference
# This structure allows us to quickly determine if a path has an existing
# directory task associated with it.
our %Dir_Task_For = ();

# my %Link_Task_For: map a path to the corresponding directory task reference
# This structure allows us to quickly determine if a path has an existing
# directory task associated with it.
our %Link_Task_For = ();

# N.B.: directory tasks and link tasks are NOT mutually exclusive due
# to tree splitting (which involves a remove link task followed by
# a create directory task).

# put the main loop in this block so we can load the 
# rest of the code as a module for testing
if (not caller()) {

    process_options();
    set_stow_path();
    
    # current dir is now the target directory
    
    for my $package (@Pkgs_To_Delete) {
        if (not -d join_paths($Stow_Path, $package)) {
            error("The given package name ($package) is not in your stow path");
        }
        debug(2, "Unstowing package $package...");
        if ($Option{'compat'}) {
            unstow_contents_orig(
                join_paths($Stow_Path, $package), # path to package
                '.',                              # target is current_dir
            );
        }
        else {
            unstow_contents(
                join_paths($Stow_Path, $package), # path to package
                '.',                              # target is current_dir
            );
        }
        debug(2, "Unstowing package $package... done");
    }

    for my $package (@Pkgs_To_Stow) {
        if (not -d join_paths($Stow_Path, $package)) {
            error("The given package name ($package) is not in your stow path");
        }
        debug(2, "Stowing package $package...");
        stow_contents(
            join_paths($Stow_Path, $package), # path package
            '.',                              # target is current dir
            join_paths($Stow_Path, $package), # source from target
        );
        debug(2, "Stowing package $package... done");
    }

    # --verbose:   tell me what you are planning to do
    # --simulate:  don't execute planned operations
    # --conflicts: just list any detected conflicts

    if (scalar @Conflicts) {
        warn "WARNING: conflicts detected.\n";
        if ($Option{'conflicts'}) {
            map { warn $_ } @Conflicts;
        }
        warn "WARNING: all operations aborted.\n";
    }
    else {
        process_tasks();
    }
}


#===== SUBROUTINE ===========================================================
# Name      : process_options()
# Purpose   : parse command line options and update the %Option hash
# Parameters: none
# Returns   : n/a
# Throws    : a fatal error if a bad command line option is given
# Comments  : checks @ARGV for valid package names
#============================================================================
sub process_options {
    get_defaults();
    #$,="\n"; print @ARGV,"\n"; # for debugging rc file

    Getopt::Long::config('no_ignore_case', 'bundling', 'permute');
    GetOptions(
        \%Option,
        'verbose|v:+', 'help|h', 'simulate|n|no', 'conflicts|c',
        'version|V', 'compat|p', 'dir|d=s', 'target|t=s',

        # clean and pre-compile any regex's at parse time
        'ignore=s' => 
        sub { 
            my $regex = strip_quotes($_[1]);
            push @{$Option{'ignore'}}, qr($regex\z) 
        },

        'override=s' => 
        sub { 
            my $regex = strip_quotes($_[1]);
            push @{$Option{'override'}}, qr(\A$regex) 
        },

        'defer=s' => 
        sub { 
            my $regex = strip_quotes($_[1]);
            push @{$Option{'defer'}}, qr(\A$regex) ;
        },

        # a little craziness so we can do different actions on the same line:
        # a -D, -S, or -R changes the action that will be performed on the 
        # package arguments that follow it.
        'D|delete'  => sub { $Option{'action'} = 'delete'    },
        'S|stow'    => sub { $Option{'action'} = 'stow'      },
        'R|restow'  => sub { $Option{'action'} = 'restow'    },
        '<>' => 
        sub {
            if ($Option{'action'} eq 'restow') {
                push @Pkgs_To_Delete, $_[0];
                push @Pkgs_To_Stow, $_[0];
            }
            elsif ($Option{'action'} eq 'delete') {
                push @Pkgs_To_Delete, $_[0];
            }
            else {
                push @Pkgs_To_Stow, $_[0];
            }
        },
    ) or usage();

    #print "$Option{'dir'}\n"; print "$Option{'target'}\n"; exit;

    # clean any leading and trailing whitespace in paths
    if ($Option{'dir'}) {
        $Option{'dir'}    =~ s/\A +//;
        $Option{'dir'}    =~ s/ +\z//;
    }
    if ($Option{'target'}) {
        $Option{'target'} =~ s/\A +//;
        $Option{'target'} =~ s/ +\z//;
    }

    if ($Option{'help'}) {
        usage();
    }    
    if ($Option{'version'}) {
        version();
    }
    if ($Option{'conflicts'}) {
        $Option{'simulate'} = 1;
    }

    if (not scalar @Pkgs_To_Stow and not scalar @Pkgs_To_Delete) {
        usage("No packages named");
    }

    # check package arguments
    for my $package ((@Pkgs_To_Stow, @Pkgs_To_Delete)) {
        $package =~ s{/+$}{};    # delete trailing slashes
        if ($package =~ m{/}) {
            error("Slashes are not permitted in package names");
        }
    }

    return;
}

#===== SUBROUTINE ============================================================
# Name      : debug()
# Purpose   : log to STDERR based on verbosity setting
# Parameters: $level => minimum verbosity level required to output this message
#           : $msg => the message
# Returns   : n/a
# Throws    : no exceptions
# Comments  : none
#=============================================================================
sub debug {
    my ($level, $msg) = @_;
    if ($Option{'testmode'}) {
        print "# $msg\n" if $ENV{TEST_VERBOSE};
    }
    elsif ($Option{'verbose'} >= $level) {
        warn "$msg\n";
    }
}

#===== SUBROUTINE ============================================================
# Name      : get_defaults()  
# Purpose   : search for default settings in any .stow files
# Parameters: none
# Returns   : n/a
# Throws    : no exceptions
# Comments  : prepends the contents '~/.stowrc' and '.stowrc' to the command
#           : line so they get parsed just like normal arguments. (This was
#           : hacked in so that Emil and I could set different preferences).
#=============================================================================
sub get_defaults {
    my @defaults = ();
    for my $file ($ENV{'HOME'}.'/.stowrc', '.stowrc') {
        if (-r $file) {
            warn "Loading defaults from $file\n";
            open my $FILE, '<', $file 
                or die "Could not open $file for reading\n";
            while (my $line = <$FILE>){
                chomp $line;
                push @defaults, split " ", $line;
            }
            close $FILE or die "Could not close open file: $file\n";
        }
    }
    # doing this inline does not seem to work
    unshift @ARGV, @defaults;
    return;
}                                                              

#===== SUBROUTINE ===========================================================
# Name      : usage()
# Purpose   : print program usage message and exit
# Parameters: $msg => string to prepend to the usage message
# Returns   : n/a 
# Throws    : n/a
# Comments  : if 'msg' is given, then exit with non-zero status
#============================================================================
sub usage {
    my ($msg) = @_;

    if ($msg) {
        print "$ProgramName: $msg\n\n";
    }

    print <<"EOT";
$ProgramName (GNU Stow) version $Version

SYNOPSIS:

    $ProgramName [OPTION ...] [-D|-S|-R] PACKAGE ... [-D|-S|-R] PACKAGE ...

OPTIONS:

    -n, --no              Do not actually make any filesystem changes
    -c, --conflicts       Scan for and print any conflicts, implies -n
    -d DIR, --dir=DIR     Set stow dir to DIR (default is current dir)
    -t DIR, --target=DIR  Set target to DIR (default is parent of stow dir)
    -v, --verbose[=N]     Increase verbosity (levels are 0,1,2,3;
                            -v or --verbose adds 1; --verbose=N sets level)

    -S, --stow            Stow the package names that follow this option
    -D, --delete          Unstow the package names that follow this option
    -R, --restow          Restow (like stow -D followed by stow -S)
    -p, --compat          use legacy algorithm for unstowing

    --ignore=REGEX        ignore files ending in this perl regex
    --defer=REGEX         defer stowing files begining with this perl regex
                          if the file is already stowed to another package
    --override=REGEX      force stowing files begining with this perl regex
                          if the file is already stowed to another package
    -V, --version         Show stow version number
    -h, --help            Show this help
EOT
    exit $msg ? 1 : 0;
}

#===== SUBROUTINE ===========================================================
# Name      : set_stow_path()
# Purpose   : find the relative path to the stow directory
# Parameters: none
# Returns   : a relative path
# Throws    : fatal error if either default directories or those set by the 
#           : the command line flags are not valid.
# Comments  : This sets the current working directory to $Option{target}
#============================================================================
sub set_stow_path {
    # Changing dirs helps a lot when soft links are used
    # Also prevents problems when 'stow_dir' or 'target' are 
    # supplied as relative paths (FIXME: examples?)

    my $current_dir = getcwd();

    # default stow dir is $STOW_DIR if set, otherwise the current
    # directory
    if (not $Option{'dir'}) {
        $Option{'dir'} = exists $ENV{STOW_DIR} ? $ENV{STOW_DIR} : getcwd();
    }
    if (not chdir($Option{'dir'})) {
        error("Cannot chdir to target tree: '$Option{'dir'}'");
    }
    my $stow_dir = getcwd();

    # back to start in case target is relative
    if (not chdir($current_dir)) {
        error("Your directory does not seem to exist anymore");
    }

    # default target is the parent of the stow directory
    if (not $Option{'target'}) {
        $Option{'target'} = parent($Option{'dir'});
    }
    if (not chdir($Option{'target'})) {
        error("Cannot chdir to target tree: $Option{'target'}");
    }

    # set our one global
    $Stow_Path = File::Spec->abs2rel($stow_dir);

    debug(2, "current dir is " . getcwd());
    debug(2, "stow dir path relative to cwd is $Stow_Path");
}

#===== SUBROUTINE ===========================================================
# Name      : stow_contents()
# Purpose   : stow the contents of the given directory
# Parameters: $path   => relative path to source dir from current directory
#           : $target => relative path to symlink target from the current directory
#           : $source => relative path to symlink source from the dir of target
# Returns   : n/a
# Throws    : a fatal error if directory cannot be read
# Comments  : stow_node() and stow_contents() are mutually recursive
#           : $source and $target are used for creating the symlink
#           : $path is used for folding/unfolding trees as necessary
#============================================================================
sub stow_contents {
    my ($path, $target, $source) = @_;

    my $cwd = getcwd();
    debug(2, "Stowing contents of $path (cwd is $cwd)");
    debug(3, "--- $target => $source");

    error("stow_contents() called with non-directory path: $path")
        unless -d $path;
    error("stow_contents() called with non-directory target: $target")
        unless is_a_node($target);

    opendir my $DIR, $path 
        or error("cannot read directory: $path");
    my @listing = readdir $DIR;
    closedir $DIR;

    NODE:
    for my $node (@listing) {
        next NODE if $node eq '.'; 
        next NODE if $node eq '..';
        next NODE if ignore($node);
        stow_node(
            join_paths($path,   $node),   # path
            join_paths($target, $node),   # target
            join_paths($source, $node),   # source
        );
    }
}

#===== SUBROUTINE ===========================================================
# Name      : stow_node()
# Purpose   : stow the given node 
# Parameters: $path   => relative path to source node from the current directory
#           : $target => relative path to symlink target from the current directory
#           : $source => relative path to symlink source from the dir of target
# Returns   : n/a
# Throws    : fatal exception if a conflict arises
# Comments  : stow_node() and stow_contents() are mutually recursive
#           : $source and $target are used for creating the symlink
#           : $path is used for folding/unfolding trees as necessary
#============================================================================
sub stow_node {
    my ($path, $target, $source) = @_;

    debug(2, "Stowing from $path");
    debug(3, "--- $target => $source");

    # don't try to stow absolute symlinks (they can't be unstowed)
    if (-l $source) {
        my $second_source = read_a_link($source); 
        if ($second_source =~ m{\A/}) {
            conflict("source is an absolute symlink $source => $second_source");
            debug(3, "absolute symlinks cannot be unstowed");
            return;
        }
    }

    # does the target already exist?
    if (is_a_link($target)) {

        # where is the link pointing?
        my $old_source = read_a_link($target); 
        if (not $old_source) {
            error("Could not read link: $target");
        }
        debug(3, "--- Evaluate existing link: $target => $old_source");

        # does it point to a node under our stow directory?
        my $old_path = find_stowed_path($target, $old_source);
        if (not $old_path) {
            conflict("existing target is not owned by stow: $target");
            return; # XXX #
        }

        # does the existing $target actually point to anything?
        if (is_a_node($old_path)) {
            if ($old_source eq $source) {
                debug(3, "--- Skipping $target as it already points to $source");
            }
            elsif (defer($target)) {
                debug(3, "--- deferring installation of: $target");
            }
            elsif (override($target)) {
                debug(3, "--- overriding installation of: $target");
                do_unlink($target);
                do_link($source, $target);
            }
            elsif (is_a_dir(join_paths(parent($target), $old_source)) &&
                   is_a_dir(join_paths(parent($target), $source))     ) {

                # if the existing link points to a directory,
                # and the proposed new link points to a directory,
                # then we can unfold (split open) the tree at that point

                debug(3, "--- Unfolding $target");
                do_unlink($target);
                do_mkdir($target);
                stow_contents($old_path, $target, join_paths('..', $old_source));
                stow_contents($path,     $target, join_paths('..', $source));
            }
            else {
                conflict(
                    q{existing target is stowed to a different package: %s => %s},
                    $target,
                    $old_source,
                );
            }
        }
        else {
            # the existing link is invalid, so replace it with a good link
            debug(3, "--- replacing invalid link: $path");
            do_unlink($target);
            do_link($source, $target);
        }
    }
    elsif (is_a_node($target)) {
        debug(3, "--- Evaluate existing node: $target");
        if (is_a_dir($target)) {
            stow_contents($path, $target, join_paths('..', $source));
        }
        else {
            conflict(
                qq{existing target is neither a link nor a directory: $target}
            );
        }
    }
    else {
        do_link($source, $target);
    }
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : unstow_contents_orig()
# Purpose   : unstow the contents of the given directory
# Parameters: $path   => relative path to source dir from current directory
#           : $target => relative path to symlink target from the current directory
# Returns   : n/a
# Throws    : a fatal error if directory cannot be read
# Comments  : unstow_node_orig() and unstow_contents_orig() are mutually recursive
#           : Here we traverse the target tree, rather than the source tree.
#============================================================================
sub unstow_contents_orig {
    my ($path, $target) = @_;

    #  don't try to remove anything under a stow directory
    if ($target eq $Stow_Path or -e "$target/.stow" or -e "$target/.nonstow") {
        return;
    }
    my $cwd = getcwd();
    debug(2, "Unstowing from $target (compat mode, cwd is $cwd)");
    debug(3, "--- source path is $path");
    # In compat mode we traverse the target tree not the source tree,
    # so we're unstowing the contents of /target/foo, there's no
    # guarantee that the corresponding /stow/mypkg/foo exists.
    error("unstow_contents_orig() called with non-directory target: $target")
        unless -d $target;

    opendir my $DIR, $target
        or error("cannot read directory: $target");
    my @listing = readdir $DIR;
    closedir $DIR;

    NODE:
    for my $node (@listing) {
        next NODE if $node eq '.';
        next NODE if $node eq '..';
        next NODE if ignore($node);
        unstow_node_orig(
            join_paths($path,   $node), # path 
            join_paths($target, $node), # target
        );
    }
}

#===== SUBROUTINE ===========================================================
# Name      : unstow_node_orig()
# Purpose   : unstow the given node 
# Parameters: $path   => relative path to source node from the current directory
#           : $target => relative path to symlink target from the current directory
# Returns   : n/a
# Throws    : fatal error if a conflict arises
# Comments  : unstow_node() and unstow_contents() are mutually recursive
#============================================================================
sub unstow_node_orig {
    my ($path, $target) = @_;

    debug(2, "Unstowing $target (compat mode)");
    debug(3, "--- source path is $path");

    # does the target exist
    if (is_a_link($target)) {
        debug(3, "Evaluate existing link: $target");

        # where is the link pointing?
        my $old_source = read_a_link($target); 
        if (not $old_source) {
            error("Could not read link: $target");
        }

        # does it point to a node under our stow directory?
        my $old_path = find_stowed_path($target, $old_source);
        if (not $old_path) {
            # skip links not owned by stow
            return; # XXX #
        }

        # does the existing $target actually point to anything?
        if (-e  $old_path) {
            # does link point to the right place?
            if ($old_path eq $path) {
                do_unlink($target);
            }
            elsif (override($target)) {
                debug(3, "--- overriding installation of: $target");
                do_unlink($target);
            }
            # else leave it alone
        }
        else {
            debug(3, "--- removing invalid link into a stow directory: $path");
            do_unlink($target);
        }
    }
    elsif (-d $target) {
        unstow_contents_orig($path, $target);

        # this action may have made the parent directory foldable
        if (my $parent = foldable($target)) {
            fold_tree($target, $parent);
        }
    }
    else {
        debug(3, "$target did not exist to be unstowed");
    }
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : unstow_contents()
# Purpose   : unstow the contents of the given directory
# Parameters: $path   => relative path to source dir from current directory
#           : $target => relative path to symlink target from the current directory
# Returns   : n/a
# Throws    : a fatal error if directory cannot be read
# Comments  : unstow_node() and unstow_contents() are mutually recursive
#           : Here we traverse the source tree, rather than the target tree.
#============================================================================
sub unstow_contents {
    my ($path, $target) = @_;

    #  don't try to remove anything under a stow directory
    if ($target eq $Stow_Path or -e "$target/.stow") {
        return;
    }
    my $cwd = getcwd();
    debug(2, "Unstowing from $target (cwd is $cwd)");
    debug(3, "--- source path is $path");
    # We traverse the source tree not the target tree, so $path must exist.
    error("unstow_contents() called with non-directory path: $path")
        unless -d $path;
    # When called at the top level, $target should exist.  And
    # unstow_node() should only call this via mutual recursion if
    # $target exists.
    error("unstow_contents() called with invalid target: $target")
        unless is_a_node($target);

    opendir my $DIR, $path
        or error("cannot read directory: $path");
    my @listing = readdir $DIR;
    closedir $DIR;

    NODE:
    for my $node (@listing) {
        next NODE if $node eq '.';
        next NODE if $node eq '..';
        next NODE if ignore($node);
        unstow_node(
            join_paths($path,   $node), # path 
            join_paths($target, $node), # target
        );
    }
    if (-d $target) {
        cleanup_invalid_links($target);
    }
}

#===== SUBROUTINE ===========================================================
# Name      : unstow_node()
# Purpose   : unstow the given node 
# Parameters: $path   => relative path to source node from the current directory
#           : $target => relative path to symlink target from the current directory
# Returns   : n/a
# Throws    : fatal error if a conflict arises
# Comments  : unstow_node() and unstow_contents() are mutually recursive
#============================================================================
sub unstow_node {
    my ($path, $target) = @_;

    debug(2, "Unstowing $path");
    debug(3, "--- target is $target");

    # does the target exist
    if (is_a_link($target)) {
        debug(3, "Evaluate existing link: $target");

        # where is the link pointing?
        my $old_source = read_a_link($target); 
        if (not $old_source) {
            error("Could not read link: $target");
        }

        if ($old_source =~ m{\A/}) {
            warn "ignoring a absolute symlink: $target => $old_source\n";
            return; # XXX #
        }

        # does it point to a node under our stow directory?
        my $old_path = find_stowed_path($target, $old_source);
        if (not $old_path) {
             conflict(
                 qq{existing target is not owned by stow: $target => $old_source}
             );
            return; # XXX #
        }

        # does the existing $target actually point to anything
        if (-e $old_path) {
            # does link points to the right place
            if ($old_path eq $path) {
                do_unlink($target);
            }
            
            # XXX we quietly ignore links that are stowed to a different
            # package.

            #elsif (defer($target)) {
            #    debug(3, "--- deferring to installation of: $target");
            #}
            #elsif (override($target)) {
            #    debug(3, "--- overriding installation of: $target");
            #    do_unlink($target);
            #}
            #else {
            #    conflict(
            #        q{existing target is stowed to a different package: %s => %s},
            #        $target,
            #        $old_source
            #    );
            #}
        }
        else {
            debug(3, "--- removing invalid link into a stow directory: $path");
            do_unlink($target);
        }
    }
    elsif (-e $target) {
        debug(3, "Evaluate existing node: $target");
        if (-d $target) {
            unstow_contents($path, $target);

            # this action may have made the parent directory foldable
            if (my $parent = foldable($target)) {
                fold_tree($target, $parent);
            }
        }
        else {
            conflict(
                qq{existing target is neither a link nor a directory: $target},
            );
        }
    }
    else {
        debug(3, "$target did not exist to be unstowed");
    }
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : find_stowed_path()
# Purpose   : determine if the given link points to a member of a
#           : stowed package
# Parameters: $target => path to a symbolic link under current directory
#           : $source => where that link points to
# Returns   : relative path to stowed node (from the current directory) 
#           : or '' if link is not owned by stow
# Throws    : fatal exception if link is unreadable
# Comments  : allow for stow dir not being under target dir 
#           : we could put more logic under here for multiple stow dirs
#============================================================================
sub find_stowed_path {
    my ($target, $source) = @_;

    # evaluate softlink relative to its target
    my $path = join_paths(parent($target), $source);

    # search for .stow files 
    my $dir = '';
    for my $part (split m{/+}, $path) {
       $dir = join_paths($dir, $part);
       if (-f "$dir/.stow") {
            return $path;
       }
    }

    # compare with $Stow_Path
    my @path = split m{/+}, $path;
    my @stow_path = split m{/+}, $Stow_Path;

    # strip off common prefixes
    while (@path && @stow_path) {
        if ((shift @path) ne (shift @stow_path)) {
            return '';
        }
    }
    if (@stow_path) {
        # @path is not under @stow_dir
        return ''; 
    }

    return $path
}

#===== SUBROUTINE ============================================================
# Name      : cleanup_invalid_links()
# Purpose   : clean up invalid links that may block folding
# Parameters: $dir => path to directory to check
# Returns   : n/a
# Throws    : no exceptions
# Comments  : removing files from a stowed package is probably a bad practice
#           : so this kind of clean up is not _really_ stow's responsibility;
#           : however, failing to clean up can block tree folding, so we'll do
#           : it anyway
#=============================================================================
sub cleanup_invalid_links {
    my ($dir) = @_;

    if (not -d $dir) {
        error("cleanup_invalid_links() called with a non-directory: $dir");
    }

    opendir my $DIR, $dir 
        or error("cannot read directory: $dir");
    my @listing = readdir $DIR;
    closedir $DIR;

    NODE:
    for my $node (@listing) {
        next NODE if $node eq '.';
        next NODE if $node eq '..';

        my $node_path = join_paths($dir, $node);

        if (-l $node_path and not exists $Link_Task_For{$node_path}) {
            
            # where is the link pointing?
            # (dont use read_a_link here)
            my $source = readlink($node_path); 
            if (not $source) {
                error("Could not read link $node_path");
            }

            if (
                not -e join_paths($dir, $source) and  # bad link
                find_stowed_path($node_path, $source) # owned by stow
            ){
                debug(3, "--- removing stale link: $node_path => " .
                          join_paths($dir, $source));
                do_unlink($node_path);
            }
        }
    }
    return;
} 


#===== SUBROUTINE ===========================================================
# Name      : foldable()
# Purpose   : determine if a tree can be folded
# Parameters: $target => path to a directory
# Returns   : path to the parent dir iff the tree can be safely folded
# Throws    : n/a
# Comments  : the path returned is relative to the parent of $target,
#           : that is, it can be used as the source for a replacement symlink
#============================================================================
sub foldable {
    my ($target) = @_;

    debug(3, "--- Is $target foldable?");

    opendir my $DIR, $target 
        or error(qq{Cannot read directory "$target" ($!)\n});
    my @listing = readdir $DIR;
    closedir $DIR;

    my $parent = '';
    NODE:
    for my $node (@listing) {

        next NODE if $node eq '.';
        next NODE if $node eq '..';

        my $path =  join_paths($target, $node);

        # skip nodes scheduled for removal
        next NODE if not is_a_node($path);

        # if its not a link then we can't fold its parent
        return '' if not is_a_link($path);

        # where is the link pointing?
        my $source = read_a_link($path); 
        if (not $source) {
            error("Could not read link $path");
        }
        if ($parent eq '') {
            $parent = parent($source)
        }
        elsif ($parent ne parent($source)) {
            return '';
        }
    }
    return '' if not $parent;

    # if we get here then all nodes inside $target are links, and those links
    # point to nodes inside the same directory.

    # chop of leading '..' to get the path to the common parent directory 
    # relative to the parent of our $target
    $parent =~ s{\A\.\./}{};

    # if the resulting path is owned by stow, we can fold it
    if (find_stowed_path($target, $parent)) {
        debug(3, "--- $target is foldable");
        return $parent;
    }
    else {
        return '';
    }
}

#===== SUBROUTINE ===========================================================
# Name      : fold_tree()
# Purpose   : fold the given tree
# Parameters: $source  => link to the folded tree source
#           : $target => directory that we will replace with a link to $source
# Returns   : n/a
# Throws    : none
# Comments  : only called iff foldable() is true so we can remove some checks
#============================================================================
sub fold_tree {
    my ($target, $source) = @_;

    debug(3, "--- Folding tree: $target => $source");
     
    opendir my $DIR, $target 
        or error(qq{Cannot read directory "$target" ($!)\n});
    my @listing = readdir $DIR;
    closedir $DIR;

    NODE:
    for my $node (@listing) {
        next NODE if $node eq '.';
        next NODE if $node eq '..';
        next NODE if not is_a_node(join_paths($target, $node));
        do_unlink(join_paths($target, $node));
    }
    do_rmdir($target);
    do_link($source, $target);
    return;
}


#===== SUBROUTINE ===========================================================
# Name      : conflict()
# Purpose   : handle conflicts in stow operations
# Parameters: $format => message printf format
#           : @args   => paths that conflict
# Returns   : n/a
# Throws    : fatal exception unless 'conflicts' option is set
# Comments  : indicates what type of conflict it is
#============================================================================
sub conflict {
    my ($format, @args) = @_;

    my $message = sprintf($format, @args);

    debug(1, "CONFLICT: $message");
    push @Conflicts, "CONFLICT: $message\n";
    return;
}

#===== SUBROUTINE ============================================================
# Name      : ignore
# Purpose   : determine if the given path matches a regex in our ignore list
# Parameters: $path
# Returns   : Boolean
# Throws    : no exceptions
# Comments  : none
#=============================================================================
sub ignore {
    my ($path) = @_;

    for my $suffix (@{$Option{'ignore'}}) {
        return 1 if $path =~ m/$suffix/;
    }
    return 0;
}

#===== SUBROUTINE ============================================================
# Name      : defer
# Purpose   : determine if the given path matches a regex in our defer list
# Parameters: $path
# Returns   : Boolean
# Throws    : no exceptions
# Comments  : none
#=============================================================================
sub defer {
    my ($path) = @_;

    for my $prefix (@{$Option{'defer'}}) {
        return 1 if $path =~ m/$prefix/;
    }
    return 0;
}

#===== SUBROUTINE ============================================================
# Name      : overide
# Purpose   : determine if the given path matches a regex in our override list
# Parameters: $path
# Returns   : Boolean
# Throws    : no exceptions
# Comments  : none
#=============================================================================
sub override {
    my ($path) = @_;

    for my $regex (@{$Option{'override'}}) {
        return 1 if $path =~ m/$regex/;
    }
    return 0;
}

##############################################################################
#
# The following code provides the abstractions that allow us to defer operating
# on the filesystem until after all potential conflcits have been assessed.
#
##############################################################################

#===== SUBROUTINE ===========================================================
# Name      : process_tasks()
# Purpose   : process each task in the @Tasks list
# Parameters: none
# Returns   : n/a
# Throws    : fatal error if @Tasks is corrupted or a task fails
# Comments  : task involve either creating or deleting dirs and symlinks
#           : an action is set to 'skip' if it is found to be redundant
#============================================================================
sub process_tasks {
    debug(2, "Processing tasks...");

    # strip out all tasks with a skip action
    @Tasks = grep { $_->{'action'} ne 'skip' } @Tasks;

    if (not scalar @Tasks) {
        warn "There are no outstanding operations to perform.\n";
        return;
    }
    if ($Option{'simulate'}) {
        warn "WARNING: simulating so all operations are deferred.\n";
        return;
    } 

    for my $task (@Tasks) {

        if ($task->{'action'} eq 'create') {
            if ($task->{'type'} eq 'dir') {
                mkdir($task->{'path'}, 0777) 
                    or error(qq(Could not create directory: $task->{'path'}));
            }
            elsif ($task->{'type'} eq 'link') {
                symlink $task->{'source'}, $task->{'path'} 
                    or error(
                        q(Could not create symlink: %s => %s),
                        $task->{'path'},
                        $task->{'source'}
                );
            }
            else {
                internal_error(qq(bad task type: $task->{'type'}));
            }
        }
        elsif ($task->{'action'} eq 'remove') {
            if ($task->{'type'} eq 'dir') {
                rmdir $task->{'path'} 
                    or error(qq(Could not remove directory: $task->{'path'}));
            }
            elsif ($task->{'type'} eq 'link') {
                unlink $task->{'path'} 
                    or error(qq(Could not remove link: $task->{'path'}));
            }
            else {
                internal_error(qq(bad task type: $task->{'type'}));
            }
        }
        else {
            internal_error(qq(bad task action: $task->{'action'}));
        }
    }
    debug(2, "Processing tasks... done");
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : link_task_action()
# Purpose   : finds the link task action for the given path, if there is one
# Parameters: $path
# Returns   : 'remove', 'create', or '' if there is no action
# Throws    : a fatal exception if an invalid action is found
# Comments  : none
#============================================================================
sub link_task_action {
    my ($path) = @_;

    if (! exists $Link_Task_For{$path}) {
        debug(4, "  link_task_action($path): no task");
        return '';
    }

    my $action = $Link_Task_For{$path}->{'action'};
    internal_error("bad task action: $action")
        unless $action eq 'remove' or $action eq 'create';

    debug(4, "  link_task_action($path): link task exists with action $action");
    return $action;
}

#===== SUBROUTINE ===========================================================
# Name      : dir_task_action()
# Purpose   : finds the dir task action for the given path, if there is one
# Parameters: $path
# Returns   : 'remove', 'create', or '' if there is no action
# Throws    : a fatal exception if an invalid action is found
# Comments  : none
#============================================================================
sub dir_task_action {
    my ($path) = @_;

    if (! exists $Dir_Task_For{$path}) {
        debug(4, "  dir_task_action($path): no task");
        return '';
    }

    my $action = $Dir_Task_For{$path}->{'action'};
    internal_error("bad task action: $action")
        unless $action eq 'remove' or $action eq 'create';

    debug(4, "  dir_task_action($path): dir task exists with action $action");
    return $action;
}

#===== SUBROUTINE ===========================================================
# Name      : parent_link_scheduled_for_removal()
# Purpose   : determines whether the given path or any parent thereof
#           : is a link scheduled for removal
# Parameters: $path
# Returns   : Boolean
# Throws    : none
# Comments  : none
#============================================================================
sub parent_link_scheduled_for_removal {
    my ($path) = @_;

    my $prefix = '';
    for my $part (split m{/+}, $path) {
        $prefix = join_paths($prefix, $part);
        debug(4, "    parent_link_scheduled_for_removal($path): prefix $prefix");
        if (exists $Link_Task_For{$prefix} and
             $Link_Task_For{$prefix}->{'action'} eq 'remove') {
            debug(4, "    parent_link_scheduled_for_removal($path): link scheduled for removal");
            return 1;
        }
    }

    debug(4, "    parent_link_scheduled_for_removal($path): returning false");
    return 0;
}

#===== SUBROUTINE ===========================================================
# Name      : is_a_link()
# Purpose   : is the given path a current or planned link
# Parameters: $path
# Returns   : Boolean
# Throws    : none
# Comments  : returns false if an existing link is scheduled for removal
#           : and true if a non-existent link is scheduled for creation
#============================================================================
sub is_a_link {
    my ($path) = @_;
    debug(4, "  is_a_link($path)");

    if (my $action = link_task_action($path)) {
        if ($action eq 'remove') {
            return 0;
        }
        elsif ($action eq 'create') {
            return 1;
        }
    }

    if (-l $path) {
        # check if any of its parent are links scheduled for removal
        # (need this for edge case during unfolding)
        debug(4, "  is_a_link($path): is a real link");
        return parent_link_scheduled_for_removal($path) ? 0 : 1;
    }

    debug(4, "  is_a_link($path): returning false");
    return 0;
}

#===== SUBROUTINE ===========================================================
# Name      : is_a_dir()
# Purpose   : is the given path a current or planned directory
# Parameters: $path
# Returns   : Boolean
# Throws    : none
# Comments  : returns false if an existing directory is scheduled for removal
#           : and true if a non-existent directory is scheduled for creation
#           : we also need to be sure we are not just following a link
#============================================================================
sub is_a_dir {
    my ($path) = @_;
    debug(4, "  is_a_dir($path)");

    if (my $action = dir_task_action($path)) {
        if ($action eq 'remove') {
            return 0;
        }
        elsif ($action eq 'create') {
            return 1;
        }
    }

    return 0 if parent_link_scheduled_for_removal($path);

    if (-d $path) {
        debug(4, "  is_a_dir($path): real dir");
        return 1;
    }

    debug(4, "  is_a_dir($path): returning false");
    return 0;
}

#===== SUBROUTINE ===========================================================
# Name      : is_a_node()
# Purpose   : is the given path a current or planned node
# Parameters: $path
# Returns   : Boolean
# Throws    : none
# Comments  : returns false if an existing node is scheduled for removal
#           : true if a non-existent node is scheduled for creation
#           : we also need to be sure we are not just following a link
#============================================================================
sub is_a_node {
    my ($path) = @_;
    debug(4, "  is_a_node($path)");

    my $laction = link_task_action($path);
    my $daction = dir_task_action($path);

    if ($laction eq 'remove') {
        if ($daction eq 'remove') {
            internal_error("removing link and dir: $path");
            return 0;
        }
        elsif ($daction eq 'create') {
            # Assume that we're unfolding $path, and that the link
            # removal action is earlier than the dir creation action
            # in the task queue.  FIXME: is this a safe assumption?
            return 1;
        }
        else { # no dir action
            return 0;
        }
    }
    elsif ($laction eq 'create') {
        if ($daction eq 'remove') {
            # Assume that we're folding $path, and that the dir
            # removal action is earlier than the link creation action
            # in the task queue.  FIXME: is this a safe assumption?
            return 1;
        }
        elsif ($daction eq 'create') {
            internal_error("creating link and dir: $path");
            return 1;
        }
        else { # no dir action
            return 1;
        }
    }
    else {
        # No link action
        if ($daction eq 'remove') {
            return 0;
        }
        elsif ($daction eq 'create') {
            return 1;
        }
        else { # no dir action
            # fall through to below
        }
    }

    return 0 if parent_link_scheduled_for_removal($path);

    if (-e $path) {
        debug(4, "  is_a_node($path): really exists");
        return 1;
    }

    debug(4, "  is_a_node($path): returning false");
    return 0;
}

#===== SUBROUTINE ===========================================================
# Name      : read_a_link()
# Purpose   : return the source of a current or planned link
# Parameters: $path => path to the link target
# Returns   : a string
# Throws    : fatal exception if the given path is not a current or planned 
#           : link
# Comments  : none
#============================================================================
sub read_a_link {
    my ($path) = @_;

    if (my $action = link_task_action($path)) {
        debug(4, "  read_a_link($path): task exists with action $action");

        if ($action eq 'create') {
            return $Link_Task_For{$path}->{'source'};
        }
        elsif ($action eq 'remove') {
            internal_error(
                "read_a_link() passed a path that is scheduled for removal: $path"
            );
        }
    }
    elsif (-l $path) {
        debug(4, "  read_a_link($path): real link");
        return readlink $path
            or error("Could not read link: $path");
    }
    internal_error("read_a_link() passed a non link path: $path\n");
}

#===== SUBROUTINE ===========================================================
# Name      : do_link()
# Purpose   : wrap 'link' operation for later processing
# Parameters: $oldfile => the existing file to link to
#           : $newfile => the file to link
# Returns   : n/a
# Throws    : error if this clashes with an existing planned operation 
# Comments  : cleans up operations that undo previous operations
#============================================================================
sub do_link {
    my ($oldfile, $newfile) = @_;

    if (exists $Dir_Task_For{$newfile}) {
        my $task_ref = $Dir_Task_For{$newfile};

        if ($task_ref->{'action'} eq 'create') {
            if ($task_ref->{'type'} eq 'dir') {
                internal_error(
                    "new link (%s => %s) clashes with planned new directory",
                    $newfile, 
                    $oldfile,
                );
            }
        }
        elsif ($task_ref->{'action'} eq 'remove') {
            # we may need to remove a directory before creating a link so continue;
        }
        else {
            internal_error("bad task action: $task_ref->{'action'}");
        }
    }

    if (exists $Link_Task_For{$newfile}) {
        my $task_ref = $Link_Task_For{$newfile};

        if ($task_ref->{'action'} eq 'create') {
            if ($task_ref->{'source'} ne $oldfile) {
                internal_error(
                    "new link clashes with planned new link: %s => %s", 
                    $task_ref->{'path'},
                    $task_ref->{'source'},
                )   
            }
            else {
                debug(1, "LINK: $newfile => $oldfile (duplicates previous action)");
                return;
            }
        }
        elsif ($task_ref->{'action'} eq 'remove') {
            if ($task_ref->{'source'} eq $oldfile) {
                # no need to remove a link we are going to recreate
                debug(1, "LINK: $newfile => $oldfile (reverts previous action)");
                $Link_Task_For{$newfile}->{'action'} = 'skip';
                delete $Link_Task_For{$newfile};
                return;
            }
            # we may need to remove a link to replace it so continue
        }
        else {
            internal_error("bad task action: $task_ref->{'action'}");
        }
    }

    # creating a new link
    debug(1, "LINK: $newfile => $oldfile");
    my $task = { 
        action  => 'create',
        type    => 'link',
        path    => $newfile,
        source  => $oldfile,
    };
    push @Tasks, $task;
    $Link_Task_For{$newfile} = $task;

    return;
}

#===== SUBROUTINE ===========================================================
# Name      : do_unlink()
# Purpose   : wrap 'unlink' operation for later processing
# Parameters: $file => the file to unlink
# Returns   : n/a
# Throws    : error if this clashes with an existing planned operation 
# Comments  : will remove an existing planned link
#============================================================================
sub do_unlink {
    my ($file) = @_;

    if (exists $Link_Task_For{$file}) {
        my $task_ref = $Link_Task_For{$file};
        if ($task_ref->{'action'} eq 'remove') {
            debug(1, "UNLINK: $file (duplicates previous action)");
            return;
        }
        elsif ($task_ref->{'action'} eq 'create') {
            # do need to create a link then remove it
            debug(1, "UNLINK: $file (reverts previous action)");
            $Link_Task_For{$file}->{'action'} = 'skip';
            delete $Link_Task_For{$file};
            return;
        }
        else {
            internal_error("bad task action: $task_ref->{'action'}");
        }
    }

    if (exists $Dir_Task_For{$file} and $Dir_Task_For{$file} eq 'create') { 
        internal_error(
            "new unlink operation clashes with planned operation: %s dir %s",
            $Dir_Task_For{$file}->{'action'},
            $file 
        );
    }

    # remove the link
    #debug(1, "UNLINK: $file (" . (caller())[2] . ")");
    debug(1, "UNLINK: $file");

    my $source = readlink $file or error("could not readlink $file");

    my $task = { 
        action  => 'remove',
        type    => 'link',
        path    => $file,
        source  => $source,
    };
    push @Tasks, $task;
    $Link_Task_For{$file} = $task;

    return;
}

#===== SUBROUTINE ===========================================================
# Name      : do_mkdir()
# Purpose   : wrap 'mkdir' operation
# Parameters: $dir => the directory to remove
# Returns   : n/a
# Throws    : fatal exception if operation fails
# Comments  : outputs a message if 'verbose' option is set
#           : does not perform operation if 'simulate' option is set
# Comments  : cleans up operations that undo previous operations
#============================================================================
sub do_mkdir {
    my ($dir) = @_;

    if (exists $Link_Task_For{$dir}) {
        my $task_ref = $Link_Task_For{$dir};

        if ($task_ref->{'action'} eq 'create') {
            internal_error(
                "new dir clashes with planned new link (%s => %s)", 
                $task_ref->{'path'},
                $task_ref->{'source'},
            );
        }
        elsif ($task_ref->{'action'} eq 'remove') {
            # may need to remove a link before creating a directory so continue
        }
        else {
            internal_error("bad task action: $task_ref->{'action'}");
        }
    }

    if (exists $Dir_Task_For{$dir}) {
        my $task_ref = $Dir_Task_For{$dir};

        if ($task_ref->{'action'} eq 'create') {
            debug(1, "MKDIR: $dir (duplicates previous action)");
            return;
        }
        elsif ($task_ref->{'action'} eq 'remove') {
            debug(1, "MKDIR: $dir (reverts previous action)");
            $Dir_Task_For{$dir}->{'action'} = 'skip';
            delete $Dir_Task_For{$dir};
            return;
        }
        else {
            internal_error("bad task action: $task_ref->{'action'}");
        }   
    }

    debug(1, "MKDIR: $dir");
    my $task = { 
        action  => 'create',
        type    => 'dir',
        path    => $dir,
        source  => undef,
    };
    push @Tasks, $task;
    $Dir_Task_For{$dir} = $task;
    
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : do_rmdir()
# Purpose   : wrap 'rmdir' operation
# Parameters: $dir => the directory to remove
# Returns   : n/a
# Throws    : fatal exception if operation fails
# Comments  : outputs a message if 'verbose' option is set
#           : does not perform operation if 'simulate' option is set
#============================================================================
sub do_rmdir {
    my ($dir) = @_;

    if (exists $Link_Task_For{$dir}) {
        my $task_ref = $Link_Task_For{$dir};
        internal_error(
            "rmdir clashes with planned operation: %s link %s => %s",
            $task_ref->{'action'},
            $task_ref->{'path'},
            $task_ref->{'source'}
        );
    }

    if (exists $Dir_Task_For{$dir}) {
        my $task_ref = $Link_Task_For{$dir};

        if ($task_ref->{'action'} eq 'remove') {
            debug(1, "RMDIR $dir (duplicates previous action)");
            return;
        }
        elsif ($task_ref->{'action'} eq 'create') {
            debug(1, "MKDIR $dir (reverts previous action)");
            $Link_Task_For{$dir}->{'action'} = 'skip';
            delete $Link_Task_For{$dir};
            return;
        }
        else {
            internal_error("bad task action: $task_ref->{'action'}");
        }
    }

    debug(1, "RMDIR $dir");
    my $task = { 
        action  => 'remove',
        type    => 'dir',
        path    => $dir,
        source  => '',
    };
    push @Tasks, $task;
    $Dir_Task_For{$dir} = $task;

    return;
}

#############################################################################
#
# General Utilities: nothing stow specific here.
#
#############################################################################

#===== SUBROUTINE ============================================================
# Name      : strip_quotes 
# Purpose   : remove matching outer quotes from the given string
# Parameters: none
# Returns   : n/a
# Throws    : no exceptions
# Comments  : none
#=============================================================================
sub strip_quotes {
    my ($string) = @_;

    if ($string =~ m{\A\s*'(.*)'\s*\z}) {
        return $1;
    }
    elsif ($string =~ m{\A\s*"(.*)"\s*\z}) {
        return $1
    }
    return $string;
}

#===== SUBROUTINE ===========================================================
# Name      : join_paths()
# Purpose   : concatenates given paths
# Parameters: path1, path2, ... => paths
# Returns   : concatenation of given paths
# Throws    : n/a
# Comments  : factors out redundant path elements:
#           : '//' => '/' and 'a/b/../c' => 'a/c'
#============================================================================
sub join_paths {
    my @paths = @_;

    # weed out empty components and concatenate
    my $result = join '/', grep {!/\A\z/} @paths;

    # factor out back references and remove redundant /'s)
    my @result = ();
    PART:
    for my $part (split m{/+}, $result) {
        next PART if $part eq '.';
        if (@result && $part eq '..' && $result[-1] ne '..') {
            pop @result;
        }
        else {
            push @result, $part;
        }
    }

    return join '/', @result;
}

#===== SUBROUTINE ===========================================================
# Name      : parent
# Purpose   : find the parent of the given path
# Parameters: @path => components of the path
# Returns   : returns a path string
# Throws    : n/a
# Comments  : allows you to send multiple chunks of the path
#           : (this feature is currently not used)
#============================================================================
sub parent {
    my @path = @_;
    my $path = join '/', @_;
    my @elts = split m{/+}, $path;
    pop @elts;
    return join '/', @elts; 
}

#===== SUBROUTINE ===========================================================
# Name      : internal_error()
# Purpose   : output internal error message in a consistent form and die
# Parameters: $message => error message to output 
# Returns   : n/a
# Throws    : n/a
# Comments  : none
#============================================================================
sub internal_error {
    my ($format, @args) = @_;
    die "$ProgramName: INTERNAL ERROR: " . sprintf($format, @args) . "\n",
        "This _is_ a bug. Please submit a bug report so we can fix it:-)\n";
}

#===== SUBROUTINE ===========================================================
# Name      : error()
# Purpose   : output error message in a consistent form and die
# Parameters: $message => error message to output 
# Returns   : n/a
# Throws    : n/a
# Comments  : none
#============================================================================
sub error {
    my ($format, @args) = @_;
    die "$ProgramName: ERROR: " . sprintf($format, @args) . " ($!)\n";
}

#===== SUBROUTINE ===========================================================
# Name      : version()
# Purpose   : print this programs verison and exit
# Parameters: none
# Returns   : n/a
# Throws    : n/a
# Comments  : none
#============================================================================
sub version {
    print "$ProgramName (GNU Stow) version $Version\n";
    exit 0;
}

1; # return true so we can load this script as a module during unit testing

# Local variables:
# mode: perl
# cperl-indent-level: 4
# end:
# vim: ft=perl