#!/usr/bin/perl
#
# GNU Stow in a single file
#
# Just a hacked up version of stow to make it live and work in a single file.
# Doesn't really change much except the way the module is constructed,
# duplicates the parent function, and removes the __DATA__ section of the Stow
# module.
#

{
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 longmess);
use File::Copy qw(move);
use File::Spec;
use POSIX qw(getcwd);

=head1 NAME

Stow::Util - general utilities

=head1 SYNOPSIS

    use Stow::Util qw(debug set_debug_level error ...);

=head1 DESCRIPTION

Supporting utility routines for L<Stow>.

=cut

use base qw(Exporter);
our @EXPORT_OK = qw(
    error debug set_debug_level set_test_mode
    join_paths parent canon_path restore_cwd
);

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

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

=head1 IMPORTABLE SUBROUTINES

=head2 error($format, @args)

Outputs an error message in a consistent form and then dies.

=cut

sub error {
    my ($format, @args) = @_;
    die "$ProgramName: ERROR: " . sprintf($format, @args) . "\n";
}

=head2 set_debug_level($level)

Sets verbosity level for C<debug()>.

=cut

our $debug_level = 0;

sub set_debug_level {
    my ($level) = @_;
    $debug_level = $level;
}

=head2 set_test_mode($on_or_off)

Sets testmode on or off.

=cut

our $test_mode = 0;

sub set_test_mode {
    my ($on_or_off) = @_;
    if ($on_or_off) {
        $test_mode = 1;
    }
    else {
        $test_mode = 0;
    }
}

=head2 debug($level, $msg)

Logs to STDERR based on C<$debug_level> setting.  C<$level> is the
minimum verbosity level required to output C<$msg>.  All output is to
STDERR to preserve backward compatibility, except for in test mode,
when STDOUT is used instead.  In test mode, the verbosity can be
overridden via the C<TEST_VERBOSE> environment variable.

Verbosity rules:

=over 4

=item    0: errors only

=item >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR/MV

=item >= 2: print operation exceptions

e.g. "_this_ already points to _that_", skipping, deferring,
overriding, fixing invalid links

=item >= 3: print trace detail: trace: stow/unstow/package/contents/node

=item >= 4: debug helper routines

=item >= 5: debug ignore lists

=back

=cut

sub debug {
    my ($level, $msg) = @_;
    if ($debug_level >= $level) {
        if ($test_mode) {
            print "# $msg\n";
        }
        else {
            warn "$msg\n";
        }
    }
}

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

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

#===== METHOD ===============================================================
# Name      : canon_path
# Purpose   : find absolute canonical path of given path
# Parameters: $path
# Returns   : absolute canonical path
# Throws    : n/a
# Comments  : is this significantly different from File::Spec->rel2abs?
#============================================================================
sub canon_path {
    my ($path) = @_;

    my $cwd = getcwd();
    chdir($path) or error("canon_path: cannot chdir to $path from $cwd");
    my $canon_path = getcwd();
    restore_cwd($cwd);

    return $canon_path;
}

sub restore_cwd {
    my ($prev) = @_;
    chdir($prev) or error("Your current directory $prev seems to have vanished");
}

=head1 BUGS

=head1 SEE ALSO

=cut


our $LOCAL_IGNORE_FILE  = '.stow-local-ignore';
our $GLOBAL_IGNORE_FILE = '.stow-global-ignore';

our @default_global_ignore_regexps =
    __PACKAGE__->get_default_global_ignore_regexps();

# 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,
    adopt        => 0,
    'no-folding' => 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

See the documentation for the F<stow> CLI front-end for information on these.

=over 4

=item * conflicts

=item * simulate

=item * verbose

=item * paranoid

=item * compat

=item * test_mode

=item * adopt

=item * no-folding

=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;

    $new->{action_count} = 0;

    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";
    }

    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 exists $ENV{TEST_VERBOSE};
    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});
    my $target = canon_path($self->{target});
    $self->{stow_path} = File::Spec->abs2rel($stow_dir, $target);

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

sub init_state {
    my $self = shift;

    # Store conflicts during pre-processing
    $self->{conflicts}      = {};
    $self->{conflict_count} = 0;

    # 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 => ...  ('create' or 'remove' or 'move')
    #       type   => ...  ('link' or 'dir' or 'file')
    #       path   => ...  (unique)
    #       source => ...  (only for links)
    #       dest   => ...  (only for moving files)
    #   }
    $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) {
            my $path = join_paths($self->{stow_path}, $package);
            if (not -d $path) {
                error("The stow directory $self->{stow_path} does not contain package $package");
            }
            debug(2, "Planning unstow of package $package...");
            if ($self->{compat}) {
                $self->unstow_contents_orig(
                    $self->{stow_path},
                    $package,
                    '.',
                );
            }
            else {
                $self->unstow_contents(
                    $self->{stow_path},
                    $package,
                    '.',
                );
            }
            debug(2, "Planning unstow of package $package... done");
            $self->{action_count}++;
        }
    });
}

=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) {
            my $path = join_paths($self->{stow_path}, $package);
            if (not -d $path) {
                error("The stow directory $self->{stow_path} does not contain package $package");
            }
            debug(2, "Planning stow of package $package...");
            $self->stow_contents(
                $self->{stow_path},
                $package,
                '.',
                $path, # source from target
            );
            debug(2, "Planning stow of package $package... done");
            $self->{action_count}++;
        }
    });
}

#===== 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: $stow_path => relative path from current (i.e. target) directory
#           :               to the stow dir containing the package to be stowed
#           : $package => the package whose contents are being stowed
#           : $target => subpath relative to package and target directories
#           : $source => relative path from the (sub)dir of target
#           :            to symlink source
# 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 ($stow_path, $package, $target, $source) = @_;

    my $path = join_paths($stow_path, $package, $target);

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

    my $cwd = getcwd();
    my $msg = "Stowing contents of $path (cwd=$cwd)";
    $msg =~ s!$ENV{HOME}(/|$)!~$1!g;
    debug(3, $msg);
    debug(4, "  => $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 '..';
        my $node_target = join_paths($target, $node);
        next NODE if $self->ignore($stow_path, $package, $node_target);
        $self->stow_node(
            $stow_path,
            $package,
            $node_target,                 # target
            join_paths($source, $node),   # source
        );
    }
}

#===== METHOD ===============================================================
# Name      : stow_node()
# Purpose   : stow the given node
# Parameters: $stow_path => relative path from current (i.e. target) directory
#           :               to the stow dir containing the node to be stowed
#           : $package => the package containing the node being stowed
#           : $target => subpath relative to package and target directories
#           : $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 ($stow_path, $package, $target, $source) = @_;

    my $path = join_paths($stow_path, $package, $target);

    debug(3, "Stowing $stow_path / $package / $target");
    debug(4, "  => $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(
                'stow',
                $package,
                "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 $existing_source = $self->read_a_link($target);
        if (not $existing_source) {
            error("Could not read link: $target");
        }
        debug(4, "  Evaluate existing link: $target => $existing_source");

        # Does it point to a node under any stow directory?
        my ($existing_path, $existing_stow_path, $existing_package) =
            $self->find_stowed_path($target, $existing_source);
        if (not $existing_path) {
            $self->conflict(
                'stow',
                $package,
                "existing target is not owned by stow: $target"
            );
            return; # XXX #
        }

        # Does the existing $target actually point to anything?
        if ($self->is_a_node($existing_path)) {
            if ($existing_source eq $source) {
                debug(2, "--- Skipping $target as it already points to $source");
            }
            elsif ($self->defer($target)) {
                debug(2, "--- Deferring installation of: $target");
            }
            elsif ($self->override($target)) {
                debug(2, "--- Overriding installation of: $target");
                $self->do_unlink($target);
                $self->do_link($source, $target);
            }
            elsif ($self->is_a_dir(join_paths(parent($target), $existing_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(2, "--- Unfolding $target which was already owned by $existing_package");
                $self->do_unlink($target);
                $self->do_mkdir($target);
                $self->stow_contents(
                    $existing_stow_path,
                    $existing_package,
                    $target,
                    join_paths('..', $existing_source),
                );
                $self->stow_contents(
                    $self->{stow_path},
                    $package,
                    $target,
                    join_paths('..', $source),
                );
            }
            else {
                $self->conflict(
                    'stow',
                    $package,
                    "existing target is stowed to a different package: "
                    . "$target => $existing_source"
                );
            }
        }
        else {
            # The existing link is invalid, so replace it with a good link
            debug(2, "--- replacing invalid link: $path");
            $self->do_unlink($target);
            $self->do_link($source, $target);
        }
    }
    elsif ($self->is_a_node($target)) {
        debug(4, "  Evaluate existing node: $target");
        if ($self->is_a_dir($target)) {
            $self->stow_contents(
                $self->{stow_path},
                $package,
                $target,
                join_paths('..', $source),
            );
        }
        else {
            if ($self->{adopt}) {
                $self->do_mv($target, $path);
                $self->do_link($source, $target);
            }
            else {
                $self->conflict(
                    'stow',
                    $package,
                    "existing target is neither a link nor a directory: $target"
                );
            }
        }
    }
    elsif ($self->{'no-folding'} && -d $path && ! -l $path) {
        $self->do_mkdir($target);
        $self->stow_contents(
            $self->{stow_path},
            $package,
            $target,
            join_paths('..', $source),
        );
    }
    else {
        $self->do_link($source, $target);
    }
    return;
}

#===== METHOD ===============================================================
# Name      : should_skip_target_which_is_stow_dir()
# Purpose   : determine whether target is a stow directory which should
#           : not be stowed to or unstowed from
# 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_target_which_is_stow_dir {
    my $self = shift;
    my ($target) = @_;

    # Don't try to remove anything under a stow directory
    if ($target eq $self->{stow_path}) {
        warn "WARNING: skipping target which was current stow directory $target\n";
        return 1;
    }

    if ($self->marked_stow_dir($target)) {
        warn "WARNING: skipping protected directory $target\n";
        return 1;
    }

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

sub marked_stow_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: $stow_path => relative path from current (i.e. target) directory
#           :               to the stow dir containing the package to be unstowed
#           : $package => the package whose contents are being unstowed
#           : $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 ($stow_path, $package, $target) = @_;

    my $path = join_paths($stow_path, $package, $target);

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

    my $cwd = getcwd();
    my $msg = "Unstowing from $target (compat mode, cwd=$cwd, stow dir=$self->{stow_path})";
    $msg =~ s!$ENV{HOME}(/|$)!~$1!g;
    debug(3, $msg);
    debug(4, "  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 '..';
        my $node_target = join_paths($target, $node);
        next NODE if $self->ignore($stow_path, $package, $node_target);
        $self->unstow_node_orig($stow_path, $package, $node_target);
    }
}

#===== METHOD ===============================================================
# Name      : unstow_node_orig()
# Purpose   : unstow the given node
# Parameters: $stow_path => relative path from current (i.e. target) directory
#           :               to the stow dir containing the node to be stowed
#           : $package => the package containing the node being stowed
#           : $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 ($stow_path, $package, $target) = @_;

    my $path = join_paths($stow_path, $package, $target);

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

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

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

        # Does it point to a node under any stow directory?
        my ($existing_path, $existing_stow_path, $existing_package) =
            $self->find_stowed_path($target, $existing_source);
        if (not $existing_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 $existing_path) {
            # Does link point to the right place?
            if ($existing_path eq $path) {
                $self->do_unlink($target);
            }
            elsif ($self->override($target)) {
                debug(2, "--- overriding installation of: $target");
                $self->do_unlink($target);
            }
            # else leave it alone
        }
        else {
            debug(2, "--- removing invalid link into a stow directory: $path");
            $self->do_unlink($target);
        }
    }
    elsif (-d $target) {
        $self->unstow_contents_orig($stow_path, $package, $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(
            'unstow',
            $package,
            "existing target is neither a link nor a directory: $target",
        );
    }
    else {
        debug(2, "$target did not exist to be unstowed");
    }
    return;
}

#===== METHOD ===============================================================
# Name      : unstow_contents()
# Purpose   : unstow the contents of the given directory
# Parameters: $stow_path => relative path from current (i.e. target) directory
#           :               to the stow dir containing the package to be unstowed
#           : $package => the package whose contents are being unstowed
#           : $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 ($stow_path, $package, $target) = @_;

    my $path = join_paths($stow_path, $package, $target);

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

    my $cwd = getcwd();
    my $msg = "Unstowing from $target (cwd=$cwd, stow dir=$self->{stow_path})";
    $msg =~ s!$ENV{HOME}/!~/!g;
    debug(3, $msg);
    debug(4, "  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 '..';
        my $node_target = join_paths($target, $node);
        next NODE if $self->ignore($stow_path, $package, $node_target);
        $self->unstow_node($stow_path, $package, $node_target);
    }
    if (-d $target) {
        $self->cleanup_invalid_links($target);
    }
}

#===== METHOD ===============================================================
# Name      : unstow_node()
# Purpose   : unstow the given node
# Parameters: $stow_path => relative path from current (i.e. target) directory
#           :               to the stow dir containing the node to be stowed
#           : $package => the package containing the node being unstowed
#           : $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 ($stow_path, $package, $target) = @_;

    my $path = join_paths($stow_path, $package, $target);

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

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

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

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

        # Does it point to a node under any stow directory?
        my ($existing_path, $existing_stow_path, $existing_package) =
            $self->find_stowed_path($target, $existing_source);
        if (not $existing_path) {
             $self->conflict(
                 'unstow',
                 $package,
                 "existing target is not owned by stow: $target => $existing_source"
             );
            return; # XXX #
        }

        # Does the existing $target actually point to anything?
        if (-e $existing_path) {
            # Does link points to the right place?
            if ($existing_path eq $path) {
                $self->do_unlink($target);
            }

            # XXX we quietly ignore links that are stowed to a different
            # package.

            #elsif (defer($target)) {
            #    debug(2, "--- deferring to installation of: $target");
            #}
            #elsif ($self->override($target)) {
            #    debug(2, "--- overriding installation of: $target");
            #    $self->do_unlink($target);
            #}
            #else {
            #    $self->conflict(
            #        'unstow',
            #        $package,
            #        "existing target is stowed to a different package: "
            #        . "$target => $existing_source"
            #    );
            #}
        }
        else {
            debug(2, "--- removing invalid link into a stow directory: $path");
            $self->do_unlink($target);
        }
    }
    elsif (-e $target) {
        debug(4, "  Evaluate existing node: $target");
        if (-d $target) {
            $self->unstow_contents($stow_path, $package, $target);

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

#===== METHOD ===============================================================
# Name      : path_owned_by_package()
# Purpose   : determine whether 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   : the package iff link is owned by stow, otherwise ''
# Throws    : n/a
# Comments  : lossy wrapper around find_stowed_path()
#============================================================================
sub path_owned_by_package {
    my $self = shift;
    my ($target, $source) = @_;

    my ($path, $stow_path, $package) =
        $self->find_stowed_path($target, $source);
    return $package;
}

#===== METHOD ===============================================================
# Name      : find_stowed_path()
# Purpose   : determine whether 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 (needed because link
#           :            might not exist yet due to two-phase approach,
#           :            so we can't just call readlink())
# Returns   : ($path, $stow_path, $package) where $path and $stow_path are
#           : relative from the current (i.e. target) directory.  $path
#           : is the full relative path, $stow_path is the relative path
#           : to the stow directory, and $package is the name of the package.
#           : or ('', '', '') if link is not owned by stow
# Throws    : n/a
# Comments  : Needs
#           : 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 owned by stow?");

    # Search for .stow files - this allows us to detect links
    # owned by stow directories other than the current one.
    my $dir = '';
    my @path = split m{/+}, $path;
    for my $i (0 .. $#path) {
        my $part = $path[$i];
        $dir = join_paths($dir, $part);
        if ($self->marked_stow_dir($dir)) {
            # FIXME - not sure if this can ever happen
            internal_error("find_stowed_path() called directly on stow dir")
                if $i == $#path;

            debug(4, "    yes - $dir was marked as a stow dir");
            my $package = $path[$i + 1];
            return ($path, $dir, $package);
        }
    }

    # If no .stow file was found, we need to find out whether it's
    # owned by the current stow directory, in which case $path will be
    # a prefix of $self->{stow_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 ('', '', '');
    }

    my $package = shift @path;

    debug(4, "    yes - by $package in " . join_paths(@path));
    return ($path, $self->{stow_path}, $package);
}

#===== 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->path_owned_by_package($node_path, $source) # owned by stow
            ){
                debug(2, "--- removing stale link: $node_path => " .
                          join_paths($dir, $source));
                $self->do_unlink($node_path);
            }
        }
    }
    return;
}


#===== METHOD ===============================================================
# Name      : foldable()
# Purpose   : determine whether 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?");
    if ($self->{'no-folding'}) {
        debug(3, "--- no because --no-folding enabled");
        return '';
    }

    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->path_owned_by_package($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: $package => the package involved with the conflicting operation
#           : $message => a description of the conflict
# Returns   : n/a
# Throws    : none
# Comments  : none
#============================================================================
sub conflict {
    my $self = shift;
    my ($action, $package, $message) = @_;

    debug(2, "CONFLICT when ${action}ing $package: $message");
    $self->{conflicts}{$action}{$package} ||= [];
    push @{ $self->{conflicts}{$action}{$package} }, $message;
    $self->{conflict_count}++;

    return;
}

=head2 get_conflicts()

Returns a nested hash of all potential conflicts discovered: the keys
are actions ('stow' or 'unstow'), and the values are hashrefs whose
keys are stow package names and whose values are conflict
descriptions, e.g.:

    (
        stow => {
            perl => [
                "existing target is not owned by stow: bin/a2p"
                "existing target is neither a link nor a directory: bin/perl"
            ]
        }
    )

=cut

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

=head2 get_conflict_count()

Returns the number of conflicts found.

=cut

sub get_conflict_count {
    my $self = shift;
    return $self->{conflict_count};
}

=head2 get_tasks()

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

=cut

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

=head2 get_action_count()

Returns the number of actions planned for this Stow instance.

=cut

sub get_action_count {
    my $self = shift;
    return $self->{action_count};
}

#===== METHOD ================================================================
# Name      : ignore
# Purpose   : determine if the given path matches a regex in our ignore list
# Parameters: $stow_path => the stow directory containing the package
#           : $package   => the package containing the path
#           : $target    => the path to check against the ignore list
#           :               relative to its package directory
# Returns   : true iff the path should be ignored
# Throws    : no exceptions
# Comments  : none
#=============================================================================
sub ignore {
    my $self = shift;
    my ($stow_path, $package, $target) = @_;

    internal_error(__PACKAGE__ . "::ignore() called with empty target")
        unless length $target;

    for my $suffix (@{ $self->{ignore} }) {
        if ($target =~ m/$suffix/) {
            debug(4, "  Ignoring path $target due to --ignore=$suffix");
            return 1;
        }
    }

    my $package_dir = join_paths($stow_path, $package);
    my ($path_regexp, $segment_regexp) =
        $self->get_ignore_regexps($package_dir);
    debug(5, "    Ignore list regexp for paths:    " .
             (defined $path_regexp ? "/$path_regexp/" : "none"));
    debug(5, "    Ignore list regexp for segments: " .
             (defined $segment_regexp ? "/$segment_regexp/" : "none"));

    if (defined $path_regexp and "/$target" =~ $path_regexp) {
        debug(4, "  Ignoring path /$target");
        return 1;
    }

    (my $basename = $target) =~ s!.+/!!;
    if (defined $segment_regexp and $basename =~ $segment_regexp) {
        debug(4, "  Ignoring path segment $basename");
        return 1;
    }

    debug(5, "  Not ignoring $target");
    return 0;
}

sub get_ignore_regexps {
    my $self = shift;
    my ($dir) = @_;

    # N.B. the local and global stow ignore files have to have different
    # names so that:
    #   1. the global one can be a symlink to within a stow
    #      package, managed by stow itself, and
    #   2. the local ones can be ignored via hardcoded logic in
    #      GlobsToRegexp(), so that they always stay within their stow packages.

    my $local_stow_ignore  = join_paths($dir,       $LOCAL_IGNORE_FILE);
    my $global_stow_ignore = join_paths($ENV{HOME}, $GLOBAL_IGNORE_FILE);

    for my $file ($local_stow_ignore, $global_stow_ignore) {
        if (-e $file) {
            debug(5, "  Using ignore file: $file");
            return $self->get_ignore_regexps_from_file($file);
        }
        else {
            debug(5, "  $file didn't exist");
        }
    }

    debug(4, "  Using built-in ignore list");
    return @default_global_ignore_regexps;
}

my %ignore_file_regexps;

sub get_ignore_regexps_from_file {
    my $self = shift;
    my ($file) = @_;

    if (exists $ignore_file_regexps{$file}) {
        debug(4, "    Using memoized regexps from $file");
        return @{ $ignore_file_regexps{$file} };
    }

    if (! open(REGEXPS, $file)) {
        debug(4, "    Failed to open $file: $!");
        return undef;
    }

    my @regexps = $self->get_ignore_regexps_from_fh(\*REGEXPS);
    close(REGEXPS);

    $ignore_file_regexps{$file} = [ @regexps ];
    return @regexps;
}

=head2 invalidate_memoized_regexp($file)

For efficiency of performance, regular expressions are compiled from
each ignore list file the first time it is used by the Stow process,
and then memoized for future use.  If you expect the contents of these
files to change during a single run, you will need to invalidate the
memoized value from this cache.  This method allows you to do that.

=cut

sub invalidate_memoized_regexp {
    my $self = shift;
    my ($file) = @_;
    if (exists $ignore_file_regexps{$file}) {
        debug(4, "    Invalidated memoized regexp for $file");
        delete $ignore_file_regexps{$file};
    }
    else {
        debug(2, "  WARNING: no memoized regexp for $file to invalidate");
    }
}

sub get_ignore_regexps_from_fh {
    my $self = shift;
    my ($fh) = @_;
    my %regexps;
    while (<$fh>) {
        chomp;
        s/^\s+//;
        s/\s+$//;
        next if /^#/ or length($_) == 0;
        s/\s+#.+//; # strip comments to right of pattern
        s/\\#/#/g;
        $regexps{$_}++;
    }

    # Local ignore lists should *always* stay within the stow directory,
    # because this is the only place stow looks for them.
    $regexps{"^/\Q$LOCAL_IGNORE_FILE\E\$"}++;

    return $self->compile_ignore_regexps(%regexps);
}

sub compile_ignore_regexps {
    my $self = shift;
    my (%regexps) = @_;

    my @segment_regexps;
    my @path_regexps;
    for my $regexp (keys %regexps) {
        if (index($regexp, '/') < 0) {
            # No / found in regexp, so use it for matching against basename
            push @segment_regexps, $regexp;
        }
        else {
            # / found in regexp, so use it for matching against full path
            push @path_regexps, $regexp;
        }
    }

    my $segment_regexp = join '|', @segment_regexps;
    my $path_regexp    = join '|', @path_regexps;
    $segment_regexp = @segment_regexps ?
        $self->compile_regexp("^($segment_regexp)\$") : undef;
    $path_regexp    = @path_regexps    ?
        $self->compile_regexp("(^|/)($path_regexp)(/|\$)") : undef;

    return ($path_regexp, $segment_regexp);
}

sub compile_regexp {
    my $self = shift;
    my ($regexp) = @_;
    my $compiled = eval { qr/$regexp/ };
    die "Failed to compile regexp: $@\n" if $@;
    return $compiled;
}

sub get_default_global_ignore_regexps {
    my $class = shift;
    # Bootstrap issue - first time we stow, we will be stowing
    # .cvsignore so it might not exist in ~ yet, or if it does, it could
    # be an old version missing the entries we need.  So we make sure
    # they are there by hardcoding some crucial entries.

    my %regexps;

    $regexps{"RCS"}++;
    $regexps{".+,v"}++;
    $regexps{"CVS"}++;
    $regexps{"\.\#.+"}++;
    $regexps{"\.cvsignore"}++;
    $regexps{"\.svn"}++;
    $regexps{"_darcs"}++;
    $regexps{"\.hg"}++;
    $regexps{"\.git"}++;
    $regexps{"\.gitignore"}++;
    $regexps{".+~"}++;
    $regexps{"\#.*\#"}++;
    $regexps{"^/README.*"}++;
    $regexps{"^/LICENSE.*"}++;
    $regexps{"^/COPYING"}++;

    # Local ignore lists should *always* stay within the stow directory,
    # because this is the only place stow looks for them.
    $regexps{"^/\Q$LOCAL_IGNORE_FILE\E\$"}++;

    return $class->compile_ignore_regexps(%regexps);
}

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

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

    if (not @{ $self->{tasks} }) {
        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("Could not create directory: $task->{path} ($!)");
            return;
        }
        elsif ($task->{type} eq 'link') {
            symlink $task->{source}, $task->{path}
                or error(
                    "Could not create symlink: %s => %s ($!)",
                    $task->{path},
                    $task->{source}
            );
            return;
        }
    }
    elsif ($task->{action} eq 'remove') {
        if ($task->{type} eq 'dir') {
            rmdir $task->{path}
                or error("Could not remove directory: $task->{path} ($!)");
            return;
        }
        elsif ($task->{type} eq 'link') {
            unlink $task->{path}
                or error("Could not remove link: $task->{path} ($!)");
            return;
        }
    }
    elsif ($task->{action} eq 'move') {
        if ($task->{type} eq 'file') {
            # rename() not good enough, since the stow directory
            # might be on a different filesystem to the target.
            move $task->{path}, $task->{dest}
                or error("Could not move $task->{path} -> $task->{dest} ($!)");
            return;
        }
    }

    # Should never happen.
    internal_error("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   : determine 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   : determine if the given path is 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') {
            debug(4, "  is_a_link($path): returning 0 (remove action found)");
            return 0;
        }
        elsif ($action eq 'create') {
            debug(4, "  is_a_link($path): returning 1 (create action found)");
            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 0");
    return 0;
}

#===== METHOD ===============================================================
# Name      : is_a_dir()
# Purpose   : determine if the given path is 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   : determine whether the given path is 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");
        my $target = readlink $path or error("Could not read link: $path ($!)");
        return $target;
    }
    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;
}

#===== METHOD ===============================================================
# Name      : do_mv()
# Purpose   : wrap 'move' operation for later processing
# Parameters: $src => the file to move
#           : $dst => the path to move it to
# Returns   : n/a
# Throws    : error if this clashes with an existing planned operation
# Comments  : alters contents of package installation image in stow dir
#============================================================================
sub do_mv {
    my $self = shift;
    my ($src, $dst) = @_;

    if (exists $self->{link_task_for}{$src}) {
        # I don't *think* this should ever happen, but I'm not
        # 100% sure.
        my $task_ref = $self->{link_task_for}{$src};
        internal_error(
            "do_mv: pre-existing link task for $src; action: %s, source: %s",
            $task_ref->{action}, $task_ref->{source}
        );
    }
    elsif (exists $self->{dir_task_for}{$src}) {
        my $task_ref = $self->{dir_task_for}{$src};
        internal_error(
            "do_mv: pre-existing dir task for %s?! action: %s",
            $src, $task_ref->{action}
        );
    }

    # Remove the link
    debug(1, "MV: $src -> $dst");

    my $task = {
        action  => 'move',
        type    => 'file',
        path    => $src,
        dest    => $dst,
    };
    push @{ $self->{tasks} }, $task;

    # FIXME: do we need this for anything?
    #$self->{mv_task_for}{$file} = $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) = @_;
    my $error = sprintf($format, @args);
    my $stacktrace = Carp::longmess();
    die <<EOF;

$ProgramName: INTERNAL ERROR: $error$stacktrace

This _is_ a bug. Please submit a bug report so we can fix it! :-)
See http://www.gnu.org/software/stow/ for how to do this.
EOF
}

=head1 BUGS

=head1 SEE ALSO

=cut

1;

}

use FindBin;
use lib "$FindBin::Bin";

# 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
# Copyright (C) 2011 Adam Spiers
#
# 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, see <http://www.gnu.org/licenses/>.

=head1 NAME

stow - software package installation manager

=head1 SYNOPSIS

stow [ options ] package ...

=head1 DESCRIPTION

This manual page describes GNU Stow 2.2.2, a program for managing
the installation of software packages. This is not the definitive
documentation for stow; for that, see the info manual.

Stow is a tool for managing the installation of multiple software
packages in the same run-time directory tree. One historical
difficulty of this task has been the need to administer, upgrade,
install, and remove files in independent packages without confusing
them with other files sharing the same filesystem space. For instance,
it is common to install Perl and Emacs in F</usr/local>.  When one
does so, one winds up (as of Perl 4.036 and Emacs 19.22) with the
following files in F</usr/local/man/man1>: F<a2p.1>; F<ctags.1>;
F<emacs.1>; F<etags.1>; F<h2ph.1>; F<perl.1>; and F<s2p.1>.  Now
suppose it's time to uninstall Perl. Which man pages get removed?
Obviously F<perl.1> is one of them, but it should not be the
administrator's responsibility to memorize the ownership of individual
files by separate packages.

The approach used by Stow is to install each package into its own
tree, then use symbolic links to make it appear as though the files
are installed in the common tree. Administration can be performed in
the package's private tree in isolation from clutter from other
packages.  Stow can then be used to update the symbolic links. The
structure of each private tree should reflect the desired structure in
the common tree; i.e. (in the typical case) there should be a F<bin>
directory containing executables, a F<man/man1> directory containing
section 1 man pages, and so on.

Stow was inspired by Carnegie Mellon's Depot program, but is
substantially simpler and safer. Whereas Depot required database files
to keep things in sync, Stow stores no extra state between runs, so
there's no danger (as there was in Depot) of mangling directories when
file hierarchies don't match the database. Also unlike Depot, Stow
will never delete any files, directories, or links that appear in a
Stow directory (e.g., F</usr/local/stow/emacs>), so it's always
possible to rebuild the target tree (e.g., F</usr/local>).

=head1 TERMINOLOGY

A "package" is a related collection of files and directories that
you wish to administer as a unit -- e.g., Perl or Emacs -- and that
needs to be installed in a particular directory structure -- e.g.,
with F<bin>, F<lib>, and F<man> subdirectories.

A "target directory" is the root of a tree in which one or more
packages wish to B<appear> to be installed. A common, but by no means
the only such location is F</usr/local>.  The examples in this manual
page will use F</usr/local> as the target directory.

A "stow directory" is the root of a tree containing separate
packages in private subtrees. When Stow runs, it uses the current
directory as the default stow directory. The examples in this manual
page will use F</usr/local/stow> as the stow directory, so that
individual packages will be, for example, F</usr/local/stow/perl> and
F</usr/local/stow/emacs>.

An "installation image" is the layout of files and directories
required by a package, relative to the target directory. Thus, the
installation image for Perl includes: a F<bin> directory containing
F<perl> and F<a2p> (among others); an F<info> directory containing
Texinfo documentation; a F<lib/perl> directory containing Perl
libraries; and a F<man/man1> directory containing man pages.

A "package directory" is the root of a tree containing the
installation image for a particular package. Each package directory
must reside in a stow directory -- e.g., the package directory
F</usr/local/stow/perl> must reside in the stow directory
F</usr/local/stow>.  The "name" of a package is the name of its
directory within the stow directory -- e.g., F<perl>.

Thus, the Perl executable might reside in
F</usr/local/stow/perl/bin/perl>, where F</usr/local> is the target
directory, F</usr/local/stow> is the stow directory,
F</usr/local/stow/perl> is the package directory, and F<bin/perl>
within is part of the installation image.

A "symlink" is a symbolic link. A symlink can be "relative" or
"absolute". An absolute symlink names a full path; that is, one
starting from F</>.  A relative symlink names a relative path; that
is, one not starting from F</>.  The target of a relative symlink is
computed starting from the symlink's own directory.  Stow only creates
relative symlinks.

=head1 OPTIONS

The stow directory is assumed to be the value of the C<STOW_DIR>
environment variable or if unset the current directory, and the target
directory is assumed to be the parent of the current directory (so it
is typical to execute F<stow> from the directory F</usr/local/stow>).
Each F<package> given on the command line is the name of a package in
the stow directory (e.g., F<perl>).  By default, they are installed
into the target directory (but they can be deleted instead using
C<-D>).

=over 4

=item -n

=item --no

Do not perform any operations that modify the filesystem; merely show
what would happen.

=item -d DIR

=item --dir=DIR

Set the stow directory to C<DIR> instead of the current directory.
This also has the effect of making the default target directory be the
parent of C<DIR>.

=item -t DIR

=item --target=DIR

Set the target directory to C<DIR> instead of the parent of the stow
directory.

=item -v

=item --verbose[=N]

Send verbose output to standard error describing what Stow is
doing. Verbosity levels are 0, 1, 2, 3, and 4; 0 is the default.
Using C<-v> or C<--verbose> increases the verbosity by one; using
`--verbose=N' sets it to N.

=item -S

=item --stow

Stow the packages that follow this option into the target directory.
This is the default action and so can be omitted if you are only
stowing packages rather than performing a mixture of
stow/delete/restow actions.

=item -D

=item --delete

Unstow the packages that follow this option from the target directory rather
than installing them.

=item -R

=item --restow

Restow packages (first unstow, then stow again). This is useful
for pruning obsolete symlinks from the target tree after updating
the software in a package.

=item --adopt

B<Warning!>  This behaviour is specifically intended to alter the
contents of your stow directory.  If you do not want that, this option
is not for you.

When stowing, if a target is encountered which already exists but is a
plain file (and hence not owned by any existing stow package), then
normally Stow will register this as a conflict and refuse to proceed.
This option changes that behaviour so that the file is moved to the
same relative place within the package's installation image within the
stow directory, and then stowing proceeds as before.  So effectively,
the file becomes adopted by the stow package, without its contents
changing.

=item --no-folding

Disable folding of newly stowed directories when stowing, and
refolding of newly foldable directories when unstowing.

=item --ignore=REGEX

Ignore files ending in this Perl regex.

=item --defer=REGEX

Don't stow files beginning with this Perl regex if the file is already
stowed to another package.

=item --override=REGEX

Force stowing files beginning with this Perl regex if the file is
already stowed to another package.

=item -V

=item --version

Show Stow version number, and exit.

=item -h

=item --help

Show Stow command syntax, and exit.

=back

=head1 INSTALLING PACKAGES

The default action of Stow is to install a package. This means
creating symlinks in the target tree that point into the package tree.
Stow attempts to do this with as few symlinks as possible; in other
words, if Stow can create a single symlink that points to an entire
subtree within the package tree, it will choose to do that rather than
create a directory in the target tree and populate it with symlinks.

For example, suppose that no packages have yet been installed in
F</usr/local>; it's completely empty (except for the F<stow>
subdirectory, of course). Now suppose the Perl package is installed.
Recall that it includes the following directories in its installation
image: F<bin>; F<info>; F<lib/perl>; F<man/man1>.  Rather than
creating the directory F</usr/local/bin> and populating it with
symlinks to F<../stow/perl/bin/perl> and F<../stow/perl/bin/a2p> (and
so on), Stow will create a single symlink, F</usr/local/bin>, which
points to F<stow/perl/bin>.  In this way, it still works to refer to
F</usr/local/bin/perl> and F</usr/local/bin/a2p>, and fewer symlinks
have been created. This is called "tree folding", since an entire
subtree is "folded" into a single symlink.

To complete this example, Stow will also create the symlink
F</usr/local/info> pointing to F<stow/perl/info>; the symlink
F</usr/local/lib> pointing to F<stow/perl/lib>; and the symlink
F</usr/local/man> pointing to F<stow/perl/man>.

Now suppose that instead of installing the Perl package into an empty
target tree, the target tree is not empty to begin with. Instead, it
contains several files and directories installed under a different
system-administration philosophy. In particular, F</usr/local/bin>
already exists and is a directory, as are F</usr/local/lib> and
F</usr/local/man/man1>.  In this case, Stow will descend into
F</usr/local/bin> and create symlinks to F<../stow/perl/bin/perl> and
F<../stow/perl/bin/a2p> (etc.), and it will descend into
F</usr/local/lib> and create the tree-folding symlink F<perl> pointing
to F<../stow/perl/lib/perl>, and so on. As a rule, Stow only descends
as far as necessary into the target tree when it can create a
tree-folding symlink.

The time often comes when a tree-folding symlink has to be undone
because another package uses one or more of the folded subdirectories
in its installation image. This operation is called "splitting open"
a folded tree. It involves removing the original symlink from the
target tree, creating a true directory in its place, and then
populating the new directory with symlinks to the newly-installed
package B<and> to the old package that used the old symlink. For
example, suppose that after installing Perl into an empty
F</usr/local>, we wish to install Emacs.  Emacs's installation image
includes a F<bin> directory containing the F<emacs> and F<etags>
executables, among others. Stow must make these files appear to be
installed in F</usr/local/bin>, but presently F</usr/local/bin> is a
symlink to F<stow/perl/bin>.  Stow therefore takes the following
steps: the symlink F</usr/local/bin> is deleted; the directory
F</usr/local/bin> is created; links are made from F</usr/local/bin> to
F<../stow/emacs/bin/emacs> and F<../stow/emacs/bin/etags>; and links
are made from F</usr/local/bin> to F<../stow/perl/bin/perl> and
F<../stow/perl/bin/a2p>.

When splitting open a folded tree, Stow makes sure that the symlink
it is about to remove points inside a valid package in the current stow
directory.

=head2 Stow will never delete anything that it doesn't own.

Stow "owns" everything living in the target tree that points into a
package in the stow directory. Anything Stow owns, it can recompute if
lost. Note that by this definition, Stow doesn't "own" anything
B<in> the stow directory or in any of the packages.

If Stow needs to create a directory or a symlink in the target tree
and it cannot because that name is already in use and is not owned by
Stow, then a conflict has arisen. See the "Conflicts" section in the
info manual.

=head1 DELETING PACKAGES

When the C<-D> option is given, the action of Stow is to delete a
package from the target tree. Note that Stow will not delete anything
it doesn't "own". Deleting a package does B<not> mean removing it from
the stow directory or discarding the package tree.

To delete a package, Stow recursively scans the target tree, skipping
over the stow directory (since that is usually a subdirectory of the
target tree) and any other stow directories it encounters (see
"Multiple stow directories" in the info manual). Any symlink it
finds that points into the package being deleted is removed. Any
directory that contained only symlinks to the package being deleted is
removed. Any directory that, after removing symlinks and empty
subdirectories, contains only symlinks to a single other package, is
considered to be a previously "folded" tree that was "split open."
Stow will re-fold the tree by removing the symlinks to the surviving
package, removing the directory, then linking the directory back to
the surviving package.

=head1 SEE ALSO

The full documentation for F<stow> is maintained as a Texinfo manual.
If the F<info> and F<stow> programs are properly installed at your site, the command

    info stow

should give you access to the complete manual.

=head1 BUGS

Please report bugs in Stow using the Debian bug tracking system.

Currently known bugs include:

=over 4

=item * The empty-directory problem.

If package F<foo> includes an empty directory -- say, F<foo/bar> --
then if no other package has a F<bar> subdirectory, everything's fine.
If another stowed package F<quux>, has a F<bar> subdirectory, then
when stowing, F<targetdir/bar> will be "split open" and the contents
of F<quux/bar> will be individually stowed.  So far, so good. But when
unstowing F<quux>, F<targetdir/bar> will be removed, even though
F<foo/bar> needs it to remain.  A workaround for this problem is to
create a file in F<foo/bar> as a placeholder. If you name that file
F<.placeholder>, it will be easy to find and remove such files when
this bug is fixed.

=item *

When using multiple stow directories (see "Multiple stow directories"
in the info manual), Stow fails to "split open" tree-folding symlinks
(see "Installing packages" in the info manual) that point into a stow
directory which is not the one in use by the current Stow
command. Before failing, it should search the target of the link to
see whether any element of the path contains a F<.stow> file. If it
finds one, it can "learn" about the cooperating stow directory to
short-circuit the F<.stow> search the next time it encounters a
tree-folding symlink.

=back

=head1 AUTHOR

This man page was originally constructed by Charles Briscoe-Smith from
parts of Stow's info manual, and then converted to POD format by Adam
Spiers.  The info manual contains the following notice, which, as it
says, applies to this manual page, too.  The text of the section
entitled "GNU General Public License" can be found in the file
F</usr/share/common-licenses/GPL> on any Debian GNU/Linux system.  If
you don't have access to a Debian system, or the GPL is not there,
write to the Free Software Foundation, Inc., 59 Temple Place, Suite
330, Boston, MA, 02111-1307, USA.

=head1 COPYRIGHT

Copyright (C)
1993, 1994, 1995, 1996 by Bob Glickstein <bobg+stow@zanshin.com>;
2000, 2001 by Guillaume Morin;
2007 by Kahlil Hodgson;
2011 by Adam Spiers;
and others.

Permission is granted to make and distribute verbatim copies of this
manual provided the copyright notice and this permission notice are
preserved on all copies.

Permission is granted to copy and distribute modified versions of this
manual under the conditions for verbatim copying, provided also that
the section entitled "GNU General Public License" is included with the
modified manual, and provided that the entire resulting derived work
is distributed under the terms of a permission notice identical to
this one.

Permission is granted to copy and distribute translations of this
manual into another language, under the above conditions for modified
versions, except that this permission notice may be stated in a
translation approved by the Free Software Foundation.

=cut

use strict;
use warnings;

require 5.006_001;

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


my $ProgramName = $0;
$ProgramName =~ s{.*/}{};

main() unless caller();

sub parent {
    my @path = @_;
    my $path = join '/', @_;
    my @elts = split m{/+}, $path;
    pop @elts;
    return join '/', @elts;
}

sub main {
    my ($options, $pkgs_to_unstow, $pkgs_to_stow) = process_options();

    my $stow = new Stow(%$options);
    # current dir is now the target directory

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

    my %conflicts = $stow->get_conflicts;

    if (%conflicts) {
        foreach my $action ('unstow', 'stow') {
            next unless $conflicts{$action};
            foreach my $package (sort keys %{ $conflicts{$action} }) {
                warn "WARNING! ${action}ing $package would cause conflicts:\n";
                    #if $stow->get_action_count > 1;
                foreach my $message (sort @{ $conflicts{$action}{$package} }) {
                    warn "  * $message\n";
                }
            }
        }
        warn "All operations aborted.\n";
        exit 1;
    }
    else {
        if ($options->{simulate}) {
            warn "WARNING: in simulation mode so not modifying filesystem.\n";
            return;
        }

        $stow->process_tasks();
    }
}


#===== SUBROUTINE ===========================================================
# Name      : process_options()
# Purpose   : parse command line options
# Parameters: none
# Returns   : (\%options, \@pkgs_to_unstow, \@pkgs_to_stow)
# Throws    : a fatal error if a bad command line option is given
# Comments  : checks @ARGV for valid package names
#============================================================================
sub process_options {
    my %options        = ();
    my @pkgs_to_unstow = ();
    my @pkgs_to_stow   = ();
    my $action = 'stow';

    unshift @ARGV, get_config_file_options();
    #$,="\n"; print @ARGV,"\n"; # for debugging rc file

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

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

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

        'defer=s' =>
        sub {
            my $regex = $_[1];
            push @{$options{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 { $action = 'unstow' },
        'S|stow'    => sub { $action = 'stow'   },
        'R|restow'  => sub { $action = 'restow' },

        # Handler for non-option arguments
        '<>' =>
        sub {
            if ($action eq 'restow') {
                push @pkgs_to_unstow, $_[0];
                push @pkgs_to_stow, $_[0];
            }
            elsif ($action eq 'unstow') {
                push @pkgs_to_unstow, $_[0];
            }
            else {
                push @pkgs_to_stow, $_[0];
            }
        },
    ) or usage();

    usage()   if $options{help};
    version() if $options{version};

    sanitize_path_options(\%options);
    check_packages(\@pkgs_to_unstow, \@pkgs_to_stow);

    return (\%options, \@pkgs_to_unstow, \@pkgs_to_stow);
}

sub sanitize_path_options {
    my ($options) = @_;

    if (exists $options->{dir}) {
        $options->{dir}    =~ s/\A +//;
        $options->{dir}    =~ s/ +\z//;
    }
    else {
        $options->{dir} = exists $ENV{STOW_DIR} ? $ENV{STOW_DIR} : getcwd();
    }

    if (exists $options->{target}) {
        $options->{target} =~ s/\A +//;
        $options->{target} =~ s/ +\z//;
    }
    else {
        $options->{target} = parent($options->{dir}) || '.';
    }
}

sub check_packages {
    my ($pkgs_to_stow, $pkgs_to_unstow) = @_;

    if (not @$pkgs_to_stow and not @$pkgs_to_unstow) {
        usage("No packages to stow or unstow");
    }

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


#===== SUBROUTINE ============================================================
# Name      : get_config_file_options()
# Purpose   : search for default settings in any .stowrc files
# Parameters: none
# Returns   : a list of default options
# Throws    : no exceptions
# Comments  : prepends the contents of '~/.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_config_file_options {
    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";
        }
    }
    return @defaults;
}

#===== 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 $Stow::VERSION

SYNOPSIS:

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

OPTIONS:

    -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)

    -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)

    --ignore=REGEX        Ignore files ending in this Perl regex
    --defer=REGEX         Don't stow files beginning with this Perl regex
                          if the file is already stowed to another package
    --override=REGEX      Force stowing files beginning with this Perl regex
                          if the file is already stowed to another package
    --adopt               (Use with care!)  Import existing files into stow package
                          from target.  Please read docs before using.
    -p, --compat          Use legacy algorithm for unstowing

    -n, --no, --simulate  Do not actually make any filesystem changes
    -v, --verbose[=N]     Increase verbosity (levels are 0,1,2,3;
                            -v or --verbose adds 1; --verbose=N sets level)
    -V, --version         Show stow version number
    -h, --help            Show this help

Report bugs to: bug-stow\@gnu.org
Stow home page: <http://www.gnu.org/software/stow/>
General help using GNU software: <http://www.gnu.org/gethelp/>
EOT
    exit defined $msg ? 1 : 0;
}

sub version {
    print "$ProgramName (GNU Stow) version $Stow::VERSION\n";
    exit 0;
}

1; # This file is required by t/stow.t

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