stow/lib/Stow.pm.in

#!/usr/bin/perl

package Stow;

=head1 NAME

Stow - manage the installation of multiple software packages

=head1 SYNOPSIS

    my $stow = new Stow(%$options);

    $stow->plan_unstow(@pkgs_to_unstow);
    $stow->plan_stow  (@pkgs_to_stow);

    my @conflicts = $stow->get_conflicts;
    $stow->process_tasks() unless @conflicts;

=head1 DESCRIPTION

This is the backend Perl module for GNU Stow, a program for managing
the installation of software packages, keeping them separate
(C</usr/local/stow/emacs> vs. C</usr/local/stow/perl>, for example)
while making them appear to be installed in the same place
(C</usr/local>).

Stow doesn't store an extra state between runs, so there's no danger
of mangling directories when file hierarchies don't match the
database. Also, stow will never delete any files, directories, or
links that appear in a stow directory, so it is always possible to
rebuild the target tree.

=cut

use strict;
use warnings;

use Carp qw(carp cluck croak confess);
use File::Spec;
use POSIX qw(getcwd);

use Stow::Util qw(set_debug_level debug error set_test_mode
                  join_paths restore_cwd canon_path parent);

our $ProgramName = 'stow';
our $VERSION = '@VERSION@';

# These are the default options for each Stow instance.
our %DEFAULT_OPTIONS = (
    conflicts  => 0,
    simulate   => 0,
    verbose    => 0,
    paranoid   => 0,
    compat     => 0,
    test_mode  => 0,
    ignore     => [],
    override   => [],
    defer      => [],
);

=head1 CONSTRUCTORS

=head2 new(%options)

=head3 Required options

=over 4

=item * dir - the stow directory

=item * target - the target directory

=back

=head3 Non-mandatory options

=over 4

=item * conflicts

=item * simulate

=item * verbose

=item * paranoid

=item * ignore

=item * override

=item * defer

=back

N.B. This sets the current working directory to the target directory.

=cut

sub new {
    my $self = shift;
    my $class = ref($self) || $self;
    my %opts = @_;

    my $new = bless { }, $class;

    for my $required_arg (qw(dir target)) {
        croak "$class->new() called without '$required_arg' parameter\n"
            unless exists $opts{$required_arg};
        $new->{$required_arg} = delete $opts{$required_arg};
    }

    for my $opt (keys %DEFAULT_OPTIONS) {
        $new->{$opt} = exists $opts{$opt} ? delete $opts{$opt}
                                          : $DEFAULT_OPTIONS{$opt};
    }

    if (%opts) {
        croak "$class->new() called with unrecognised parameter(s): ",
            join(", ", keys %opts), "\n";
    }

    $opts{'simulate'} = 1 if $opts{'conflicts'};

    set_debug_level($new->get_verbosity());
    set_test_mode($new->{test_mode});
    $new->set_stow_dir();
    $new->init_state();

    return $new;
}

sub get_verbosity {
    my $self = shift;

    return $self->{verbose} unless $self->{test_mode};

    return 0 unless length $ENV{TEST_VERBOSE};

    # Convert TEST_VERBOSE=y into numeric value
    $ENV{TEST_VERBOSE} = 3 if $ENV{TEST_VERBOSE} !~ /^\d+$/;

    return $ENV{TEST_VERBOSE};
}

=head2 set_stow_dir([$dir])

Sets a new stow directory.  This allows the use of multiple stow
directories within one Stow instance, e.g.

    $stow->plan_stow('foo');
    $stow->set_stow_dir('/different/stow/dir');
    $stow->plan_stow('bar');
    $stow->process_tasks;

If C<$dir> is omitted, uses the value of the C<dir> parameter passed
to the L<new()> constructor.

=cut

sub set_stow_dir {
    my $self = shift;
    my ($dir) = @_;
    if (defined $dir) {
        $self->{dir} = $dir;
    }

    my $stow_dir = canon_path($self->{dir});

    $self->{stow_path} = File::Spec->abs2rel($stow_dir, $self->{target});

    debug(2, "stow dir is $stow_dir");
    debug(2, "stow dir path relative to target $self->{target} is $self->{stow_path}");
}

sub init_state {
    my $self = shift;

    # Store conflicts during pre-processing
    $self->{conflicts} = [];

    # Store command line packages to stow (-S and -R)
    $self->{pkgs_to_stow}   = [];

    # Store command line packages to unstow (-D and -R)
    $self->{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.

    # $self->{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)
    #   }
    $self->{tasks} = [];

    # $self->{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.
    $self->{dir_task_for} = {};

    # $self->{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.
    $self->{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).
}

=head1 METHODS

=head2 plan_unstow(@packages)

Plan which symlink/directory creation/removal tasks need to be executed
in order to unstow the given packages.  Any potential conflicts are then
accessible via L<get_conflicts()>.

=cut

sub plan_unstow {
    my $self = shift;
    my @packages = @_;

    $self->within_target_do(sub {
        for my $package (@packages) {
            if (not -d join_paths($self->{stow_path}, $package)) {
                error("The given package name ($package) is not in your stow path $self->{stow_path}");
            }
            debug(2, "Planning unstow of package $package...");
            if ($self->{'compat'}) {
                $self->unstow_contents_orig(
                    join_paths($self->{stow_path}, $package), # path to package
                    '.',                                      # target is current_dir
                );
            }
            else {
                $self->unstow_contents(
                    join_paths($self->{stow_path}, $package), # path to package
                    '.',                                      # target is current_dir
                );
            }
            debug(2, "Planning unstow of package $package... done");
        }
    });
}

=head2 plan_stow(@packages)

Plan which symlink/directory creation/removal tasks need to be executed
in order to stow the given packages.  Any potential conflicts are then
accessible via L<get_conflicts()>.

=cut

sub plan_stow {
    my $self = shift;
    my @packages = @_;

    $self->within_target_do(sub {
        for my $package (@packages) {
            if (not -d join_paths($self->{stow_path}, $package)) {
                error("The given package name ($package) is not in your stow path $self->{stow_path}");
            }
            debug(2, "Planning stow of package $package...");
            $self->stow_contents(
                join_paths($self->{stow_path}, $package), # path package
                '.',                                      # target is current dir
                join_paths($self->{stow_path}, $package), # source from target
            );
            debug(2, "Planning stow of package $package... done");
        }
    });
}

#===== METHOD ===============================================================
# Name      : within_target_do()
# Purpose   : execute code within target directory, preserving cwd
# Parameters: $code => anonymous subroutine to execute within target dir
# Returns   : n/a
# Throws    : n/a
# Comments  : This is done to ensure that the consumer of the Stow interface
#           : doesn't have to worry about (a) what their cwd is, and
#           : (b) that their cwd might change.
#============================================================================
sub within_target_do {
    my $self = shift;
    my ($code) = @_;

    my $cwd = getcwd();
    chdir($self->{'target'})
        or error("Cannot chdir to target tree: $self->{'target'}");
    debug(3, "cwd now $self->{target}");

    $self->$code();

    restore_cwd($cwd);
    debug(3, "cwd restored to $cwd");
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path, $target, $source) = @_;

    return if $self->should_skip_stow_dir_target($target);

    my $cwd = getcwd();
    my $msg = "Stowing contents of $path (cwd=$cwd, stow dir=$self->{stow_path})";
    $msg =~ s!$ENV{HOME}/!~/!g;
    debug(2, $msg);
    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 $self->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 $self->ignore($node);
        $self->stow_node(
            join_paths($path,   $node),   # path
            join_paths($target, $node),   # target
            join_paths($source, $node),   # source
        );
    }
}

#===== METHOD ===============================================================
# 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 $self = shift;
    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 = $self->read_a_link($source);
        if ($second_source =~ m{\A/}) {
            $self->conflict("source is an absolute symlink $source => $second_source");
            debug(3, "absolute symlinks cannot be unstowed");
            return;
        }
    }

    # Does the target already exist?
    if ($self->is_a_link($target)) {

        # Where is the link pointing?
        my $old_source = $self->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 = $self->find_stowed_path($target, $old_source);
        if (not $old_path) {
            $self->conflict("existing target is not owned by stow: $target");
            return; # XXX #
        }

        # Does the existing $target actually point to anything?
        if ($self->is_a_node($old_path)) {
            if ($old_source eq $source) {
                debug(3, "--- Skipping $target as it already points to $source");
            }
            elsif ($self->defer($target)) {
                debug(3, "--- deferring installation of: $target");
            }
            elsif ($self->override($target)) {
                debug(3, "--- overriding installation of: $target");
                $self->do_unlink($target);
                $self->do_link($source, $target);
            }
            elsif ($self->is_a_dir(join_paths(parent($target), $old_source)) &&
                   $self->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");
                $self->do_unlink($target);
                $self->do_mkdir($target);
                $self->stow_contents($old_path, $target, join_paths('..', $old_source));
                $self->stow_contents($path,     $target, join_paths('..', $source));
            }
            else {
                $self->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");
            $self->do_unlink($target);
            $self->do_link($source, $target);
        }
    }
    elsif ($self->is_a_node($target)) {
        debug(3, "--- Evaluate existing node: $target");
        if ($self->is_a_dir($target)) {
            $self->stow_contents($path, $target, join_paths('..', $source));
        }
        else {
            $self->conflict(
                qq{existing target is neither a link nor a directory: $target}
            );
        }
    }
    else {
        $self->do_link($source, $target);
    }
    return;
}

#===== METHOD ===============================================================
# Name      : should_skip_stow_dir_target()
# Purpose   : determine whether target is a stow directory and should be skipped
# Parameters: $target => relative path to symlink target from the current directory
# Returns   : true iff target is a stow directory
# Throws    : n/a
# Comments  : none
#============================================================================
sub should_skip_stow_dir_target {
    my $self = shift;
    my ($target) = @_;

    # Don't try to remove anything under a stow directory
    if ($target eq $self->{stow_path}) {
        debug(2, "Skipping target which was current stow directory $target");
        return 1;
    }

    if ($self->protected_dir($target)) {
        debug(2, "Skipping protected directory $target");
        return 1;
    }

    debug (4, "$target not protected");
    return 0;
}

sub protected_dir {
    my $self = shift;
    my ($target) = @_;
    for my $f (".stow", ".nonstow") {
        if (-e join_paths($target, $f)) {
            debug(4, "$target contained $f");
            return 1;
        }
    }
    return 0;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path, $target) = @_;

    return if $self->should_skip_stow_dir_target($target);

    my $cwd = getcwd();
    my $msg = "Unstowing from $target (compat mode, cwd=$cwd, stow dir=$self->{stow_path})";
    $msg =~ s!$ENV{HOME}/!~/!g;
    debug(2, $msg);
    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 $self->ignore($node);
        $self->unstow_node_orig(
            join_paths($path,   $node), # path
            join_paths($target, $node), # target
        );
    }
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path, $target) = @_;

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

    # Does the target exist?
    if ($self->is_a_link($target)) {
        debug(3, "Evaluate existing link: $target");

        # Where is the link pointing?
        my $old_source = $self->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 = $self->find_stowed_path($target, $old_source);
        if (not $old_path) {
            # We're traversing the target tree not the package tree,
            # so we definitely expect to find stuff not owned by stow.
            # Therefore we can't flag a conflict.
            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) {
                $self->do_unlink($target);
            }
            elsif ($self->override($target)) {
                debug(3, "--- overriding installation of: $target");
                $self->do_unlink($target);
            }
            # else leave it alone
        }
        else {
            debug(3, "--- removing invalid link into a stow directory: $path");
            $self->do_unlink($target);
        }
    }
    elsif (-d $target) {
        $self->unstow_contents_orig($path, $target);

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

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path, $target) = @_;

    return if $self->should_skip_stow_dir_target($target);

    my $cwd = getcwd();
    my $msg = "Unstowing from $target (cwd=$cwd, stow dir=$self->{stow_path})";
    $msg =~ s!$ENV{HOME}/!~/!g;
    debug(2, $msg);
    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 $self->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 $self->ignore($node);
        $self->unstow_node(
            join_paths($path,   $node), # path
            join_paths($target, $node), # target
        );
    }
    if (-d $target) {
        $self->cleanup_invalid_links($target);
    }
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path, $target) = @_;

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

    # Does the target exist?
    if ($self->is_a_link($target)) {
        debug(3, "Evaluate existing link: $target");

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

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

        # Does it point to a node under our stow directory?
        my $old_path = $self->find_stowed_path($target, $old_source);
        if (not $old_path) {
             $self->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) {
                $self->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 ($self->override($target)) {
            #    debug(3, "--- overriding installation of: $target");
            #    $self->do_unlink($target);
            #}
            #else {
            #    $self->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");
            $self->do_unlink($target);
        }
    }
    elsif (-e $target) {
        debug(3, "Evaluate existing node: $target");
        if (-d $target) {
            $self->unstow_contents($path, $target);

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

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($target, $source) = @_;

    # Evaluate softlink relative to its target
    my $path = join_paths(parent($target), $source);
    debug(4, "  is path $path under $self->{stow_path} ?");

    # Search for .stow files
    my $dir = '';
    for my $part (split m{/+}, $path) {
        $dir = join_paths($dir, $part);
        return $path if $self->protected_dir($dir);
    }

    # Compare with $self->{stow_path}
    my @path = split m{/+}, $path;
    my @stow_path = split m{/+}, $self->{stow_path};

    # Strip off common prefixes until one is empty
    while (@path && @stow_path) {
        if ((shift @path) ne (shift @stow_path)) {
            debug(4, "    no - either $path not under $self->{stow_path} or vice-versa");
            return '';
        }
    }

    if (@stow_path) { # @path must be empty
        debug(4, "    no - $path is not under $self->{stow_path}");
        return '';
    }

    debug(4, "    yes - in " . join_paths(@path));
    return $path;
}

#===== METHOD ================================================================
# 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 $self = shift;
    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 $self->{link_task_for}{$node_path}) {

            # Where is the link pointing?
            # (don't 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
                $self->find_stowed_path($node_path, $source) # owned by stow
            ){
                debug(3, "--- removing stale link: $node_path => " .
                          join_paths($dir, $source));
                $self->do_unlink($node_path);
            }
        }
    }
    return;
}


#===== METHOD ===============================================================
# 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 $self = shift;
    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 $self->is_a_node($path);

        # If it's not a link then we can't fold its parent
        return '' if not $self->is_a_link($path);

        # Where is the link pointing?
        my $source = $self->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 ($self->find_stowed_path($target, $parent)) {
        debug(3, "--- $target is foldable");
        return $parent;
    }
    else {
        return '';
    }
}

#===== METHOD ===============================================================
# 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 $self = shift;
    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 $self->is_a_node(join_paths($target, $node));
        $self->do_unlink(join_paths($target, $node));
    }
    $self->do_rmdir($target);
    $self->do_link($source, $target);
    return;
}


#===== METHOD ===============================================================
# 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 $self = shift;
    my ($format, @args) = @_;

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

    debug(1, "CONFLICT: $message");
    push @{ $self->{conflicts} }, "CONFLICT: $message\n";
    return;
}

=head2 get_conflicts()

Returns a list of all potential conflicts discovered.

=cut

sub get_conflicts {
    my $self = shift;
    return @{ $self->{conflicts} };
}

=head2 get_tasks()

Returns a list of all symlink/directory creation/removal tasks.

=cut

sub get_tasks {
    my $self = shift;
    return @{ $self->{tasks} };
}

#===== METHOD ================================================================
# 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 $self = shift;
    my ($path) = @_;

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

#===== METHOD ================================================================
# 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 $self = shift;
    my ($path) = @_;

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

#===== METHOD ================================================================
# Name      : override
# 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 $self = shift;
    my ($path) = @_;

    for my $regex (@{$self->{'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.
#
##############################################################################

#===== METHOD ===============================================================
# Name      : process_tasks()
# Purpose   : process each task in the tasks list
# Parameters: none
# Returns   : n/a
# Throws    : fatal error if tasks list is corrupted or a task fails
# Comments  : none
#============================================================================
sub process_tasks {
    my $self = shift;

    debug(2, "Processing tasks...");

    if ($self->{'simulate'}) {
        warn "WARNING: simulating so all operations are deferred.\n";
        return;
    }

    # Strip out all tasks with a skip action
    $self->{tasks} = [ grep { $_->{'action'} ne 'skip' } @{ $self->{tasks} } ];

    if (not @{ $self->{tasks} }) {
        warn "There are no outstanding operations to perform.\n";
        return;
    }

    $self->within_target_do(sub {
        for my $task (@{ $self->{tasks} }) {
            $self->process_task($task);
        }
    });

    debug(2, "Processing tasks... done");
}

#===== METHOD ===============================================================
# Name      : process_task()
# Purpose   : process a single task
# Parameters: $task => the task to process
# Returns   : n/a
# Throws    : fatal error if task fails
# Comments  : Must run from within target directory.
#           : Task involve either creating or deleting dirs and symlinks
#           : an action is set to 'skip' if it is found to be redundant
#============================================================================
sub process_task {
    my $self = shift;
    my ($task) = @_;

    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'}));
    }
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path) = @_;

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

    my $action = $self->{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;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path) = @_;

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

    my $action = $self->{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;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    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 $self->{link_task_for}{$prefix} and
             $self->{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;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path) = @_;
    debug(4, "  is_a_link($path)");

    if (my $action = $self->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 $self->parent_link_scheduled_for_removal($path) ? 0 : 1;
    }

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

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path) = @_;
    debug(4, "  is_a_dir($path)");

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

    return 0 if $self->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;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path) = @_;
    debug(4, "  is_a_node($path)");

    my $laction = $self->link_task_action($path);
    my $daction = $self->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 $self->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;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($path) = @_;

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

        if ($action eq 'create') {
            return $self->{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");
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($oldfile, $newfile) = @_;

    if (exists $self->{dir_task_for}{$newfile}) {
        my $task_ref = $self->{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 $self->{link_task_for}{$newfile}) {
        my $task_ref = $self->{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)");
                $self->{link_task_for}{$newfile}->{'action'} = 'skip';
                delete $self->{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 @{ $self->{tasks} }, $task;
    $self->{link_task_for}{$newfile} = $task;

    return;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($file) = @_;

    if (exists $self->{link_task_for}{$file}) {
        my $task_ref = $self->{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)");
            $self->{link_task_for}{$file}->{'action'} = 'skip';
            delete $self->{link_task_for}{$file};
            return;
        }
        else {
            internal_error("bad task action: $task_ref->{'action'}");
        }
    }

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

    # Remove the link
    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 @{ $self->{tasks} }, $task;
    $self->{link_task_for}{$file} = $task;

    return;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($dir) = @_;

    if (exists $self->{link_task_for}{$dir}) {
        my $task_ref = $self->{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 $self->{dir_task_for}{$dir}) {
        my $task_ref = $self->{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)");
            $self->{dir_task_for}{$dir}->{'action'} = 'skip';
            delete $self->{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 @{ $self->{tasks} }, $task;
    $self->{dir_task_for}{$dir} = $task;

    return;
}

#===== METHOD ===============================================================
# 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 $self = shift;
    my ($dir) = @_;

    if (exists $self->{link_task_for}{$dir}) {
        my $task_ref = $self->{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 $self->{dir_task_for}{$dir}) {
        my $task_ref = $self->{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)");
            $self->{link_task_for}{$dir}->{'action'} = 'skip';
            delete $self->{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 @{ $self->{tasks} }, $task;
    $self->{dir_task_for}{$dir} = $task;

    return;
}


#############################################################################
#
# End of methods; subroutines follow.
# FIXME: Ideally these should be in a separate module.


#===== PRIVATE 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";
}

=head1 BUGS

=head1 SEE ALSO

=cut

1;

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