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
# > 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 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 = ();

# 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:i'      => sub { $Option{'verbose'}+= $_[1] || 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 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);

    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    => 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) = @_;

    if ($Option{'verbose'} > 1) {
        warn "Stowing $path\n";
    }
    if ($Option{'verbose'} > 2) {
        warn "--- $target => $source\n";
    }

    # 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");
            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 point 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-existent 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      : 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
# End:
# vim: ft=perl