stop stowing Local:: perl5 libs into HOME

AFAICT pointless complexity.

16 files changed, 4150 insertions, 0 deletions

diff --git a/perl5/File/XDG.pm b/perl5/File/XDG.pm
new file mode 100644
index 00000000..30dc672e
--- /dev/null
+++ b/perl5/File/XDG.pm
@@ -0,0 +1,237 @@
+package File::XDG;
+
+use strict;
+use warnings;
+use feature qw(:5.10);
+
+our $VERSION = 0.04;
+
+use Carp qw(croak);
+
+use Path::Class qw(dir file);
+use File::HomeDir;
+
+=head1 NAME
+
+C<File::XDG> - Basic implementation of the XDG base directory specification
+
+=head1 SYNOPSIS
+
+ use File::XDG;
+
+ my $xdg = File::XDG->new(name => 'foo');
+
+ # user config
+ $xdg->config_home
+
+ # user data
+ $xdg->data_home
+
+ # user cache
+ $xdg->cache_home
+
+ # system config
+ $xdg->config_dirs
+
+ # system data
+ $xdg->data_dirs
+
+=head1 DESCRIPTION
+
+This module provides a basic implementation of the XDG base directory
+specification as exists by the Free Desktop Organization (FDO). It supports
+all XDG directories except for the runtime directories, which require session
+management support in order to function.
+
+=cut
+
+=head1 CONSTRUCTOR
+
+=cut
+
+=head2 $xdg = File::XDG->new( %args )
+
+Returns a new instance of a C<File::XDG> object. This must be called with an
+application name as the C<name> argument.
+
+Takes the following named arguments:
+
+=over 8
+
+=item name => STRING
+
+Name of the application for which File::XDG is being used.
+
+=back
+
+=cut
+
+sub new {
+    my $class = shift;
+    my %args = (@_);
+
+    my $self = {
+        name => delete $args{name} // croak('application name required'),
+    };
+
+    return bless $self, $class || ref $class;
+}
+
+sub _win {
+    my ($type) = @_;
+
+    return File::HomeDir->my_data;
+}
+
+sub _home {
+    my ($type) = @_;
+    my $home = $ENV{HOME};
+
+    return _win($type) if ($^O eq 'MSWin32');
+
+    given ($type) {
+        when ('data') {
+            return ($ENV{XDG_DATA_HOME} || "$home/.local/share/")
+        } when ('config') {
+            return ($ENV{XDG_CONFIG_HOME} || "$home/.config/")
+        } when ('cache') {
+            return ($ENV{XDG_CACHE_HOME} || "$home/.cache/")
+        } default {
+            croak 'invalid _home requested'
+        }
+    }
+}
+
+sub _dirs {
+    my $type = shift;
+
+    given ($type) {
+        when ('data') {
+            return ($ENV{XDG_DATA_DIRS} || '/usr/local/share:/usr/share')
+        } when ('config') {
+            return ($ENV{XDG_CONFIG_DIRS} || '/etc/xdg')
+        } default {
+            croak 'invalid _dirs requested'
+        }
+    }
+}
+
+sub _lookup_file {
+    my ($self, $type, @subpath) = @_;
+
+    unless (@subpath) {
+        croak 'subpath not specified';
+    }
+
+    my @dirs = (_home($type), split(':', _dirs($type)));
+    my @paths = map { file($_, @subpath) } @dirs;
+    my ($match) = grep { -f $_ } @paths;
+
+    return $match;
+}
+
+=head1 METHODS
+
+=cut
+
+=head2 $xdg->data_home()
+
+Returns the user-specific data directory for the application as a C<Path::Class> object.
+
+=cut
+
+sub data_home {
+    my $self = shift;
+    my $xdg = _home('data');
+    return dir($xdg, $self->{name});
+}
+
+=head2 $xdg->config_home()
+
+Returns the user-specific configuration directory for the application as a C<Path::Class> object.
+
+=cut
+
+sub config_home {
+    my $self = shift;
+    my $xdg = _home('config');
+    return dir($xdg, $self->{name});
+}
+
+=head2 $xdg->cache_home()
+
+Returns the user-specific cache directory for the application as a C<Path::Class> object.
+
+=cut
+
+sub cache_home {
+    my $self = shift;
+    my $xdg = _home('cache');
+    return dir($xdg, $self->{name});
+}
+
+=head2 $xdg->data_dirs()
+
+Returns the system data directories, not modified for the application. Per the
+specification, the returned string is :-delimited.
+
+=cut
+
+sub data_dirs {
+    return _dirs('data');
+}
+
+=head2 $xdg->config_dirs()
+
+Returns the system config directories, not modified for the application. Per
+the specification, the returned string is :-delimited.
+
+=cut
+
+sub config_dirs {
+    return _dirs('config');
+}
+
+=head2 $xdg->lookup_data_file('subdir', 'filename');
+
+Looks up the data file by searching for ./subdir/filename relative to all base
+directories indicated by $XDG_DATA_HOME and $XDG_DATA_DIRS. If an environment
+variable is either not set or empty, its default value as defined by the
+specification is used instead. Returns a C<Path::Class> object.
+
+=cut
+
+sub lookup_data_file {
+    my ($self, @subpath) = @_;
+    return $self->_lookup_file('data', @subpath);
+}
+
+=head2 $xdg->lookup_config_file('subdir', 'filename');
+
+Looks up the configuration file by searching for ./subdir/filename relative to
+all base directories indicated by $XDG_CONFIG_HOME and $XDG_CONFIG_DIRS. If an
+environment variable is either not set or empty, its default value as defined
+by the specification is used instead. Returns a C<Path::Class> object.
+
+=cut
+
+sub lookup_config_file {
+    my ($self, @subpath) = @_;
+    return $self->_lookup_file('config', @subpath);
+}
+
+=head1 SEE ALSO
+
+L<XDG Base Directory specification, version 0.7|http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>
+
+=head1 ACKNOWLEDGEMENTS
+
+This module's Windows support is made possible by C<File::HomeDir>. I would also like to thank C<Path::Class> and C<File::Spec>.
+
+=head1 AUTHOR
+
+Kiyoshi Aman <kiyoshi.aman@gmail.com>
+
+=cut
+
+1;
diff --git a/perl5/Local/Homedir.pm b/perl5/Local/Homedir.pm
new file mode 100644
index 00000000..63b37fb0
--- /dev/null
+++ b/perl5/Local/Homedir.pm
@@ -0,0 +1,178 @@
+package Local::Homedir;
+
+# homedir management functions
+#
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+
+
+# This code must be as portable as possible.  Only core perl modules.
+
+use strict;
+use warnings;
+use autodie;
+
+use Cwd;
+use File::Find;
+use File::Spec::Functions;
+use Exporter 'import';
+
+our @EXPORT = qw( normalise_mrconfig src_register_all src_cleanup );
+
+sub normalise_mrconfig {
+    my $master = $ENV{HOME} . "/src/dotfiles/.mrconfig.in";
+    my $target = $ENV{HOME} . "/.mrconfig";
+
+    unlink $target if (-e $target && !-f $target);
+
+    my %master_blocks = blocks_from_file($master);
+    my %target_blocks = -f $target ? blocks_from_file($target) : ();
+    for (keys %master_blocks) {
+        $target_blocks{$_} =
+          "# DO NOT EDIT THIS BLOCK; automatically updated from\n#   $master\n"
+          . join "\n", grep !/^\s*#|^\s*$/, split "\n", $master_blocks{$_};
+    }
+
+    open my $fh, '>', $target;
+    print $fh "# -*- mode: conf -*-\n";
+
+    # any DEFAULT has to come first to have effect on the proceding
+    # blocks
+    if (defined $target_blocks{"DEFAULT"}) {
+        say_block($fh, "DEFAULT", $target_blocks{"DEFAULT"});
+        delete $target_blocks{"DEFAULT"};
+    }
+    say_block($fh, $_, $target_blocks{$_}) foreach keys %target_blocks;
+
+    return 0;
+}
+
+sub blocks_from_file ($) {
+    my $file = shift;
+
+    my %blocks;
+    my $current_block;
+    open my $fh, '<', $file;
+    while (<$fh>) {
+        if (/^\[(.+)\]$/) {
+            $current_block = $1;
+        } elsif (defined $current_block) {
+            $blocks{$current_block} .= $_;
+        }
+    }
+    # drop trailing newlines from the text of each block
+    { local $/ = ''; chomp $blocks{$_} foreach keys %blocks }
+    return %blocks;
+}
+
+sub src_register_all {
+    chdir;
+    my @known_repos;
+    open my $fh, "<", ".mrconfig";
+    while (<$fh>) {
+        if (/^\[(src\/.+)\]$/) {
+            push @known_repos, $ENV{HOME}."/$1";
+        }
+    }
+    find({wanted => sub {
+              return unless is_repo($_);
+              chdir $_;
+              my $register_out = `mr -c $ENV{HOME}/.mrconfig register 2>&1`;
+              unless ($? == 0) {
+                  print STDERR "mr register: $File::Find::name\n";
+                  print STDERR $register_out."\n";
+                  die "src_register_all mr register attempt failed";
+              }
+              chdir "..";
+          }, preprocess => sub {
+              my $cwd = getcwd();
+              # once we've found a repo, don't search inside it for more repos
+              return () if is_repo($cwd);
+              my @entries;
+              # don't process repos mr already knows about
+              foreach my $entry (@_) {
+                  my $entry_path = $cwd."/$entry";
+                  push @entries, $entry
+                    unless grep /\A$entry_path\z/, @known_repos;
+              }
+              return @entries;
+          }}, "src");
+}
+
+sub src_cleanup {
+    return unless eval "use Dpkg::Changelog::Parse; use Dpkg::Version; 1";
+
+    my @debian_source_repos;
+    find({wanted => sub {
+              my $dir = $_;
+              my $ch = catfile($dir, "debian", "changelog");
+              return unless -f $ch;
+              my $changelog_entry = changelog_parse(file => $ch);
+              push @debian_source_repos,
+                {source => $changelog_entry->{source},
+                 dir => catfile(getcwd(), $dir)};
+          }, preprocess => sub {
+              # once we've found a source package, don't search inside
+              # for more source packages
+              return (-f catfile("debian", "changelog")) ? () : @_;
+          }}, "$ENV{HOME}/src");
+    foreach my $debian_source_repo (@debian_source_repos) {
+        # binary package names may not be source package names, so
+        # have to handle those separately
+        unlink glob catfile($debian_source_repo->{dir}, "..", "*.deb");
+        my $prefix = catfile($debian_source_repo->{dir}, "..",
+                             $debian_source_repo->{source} . "_");
+        unlink glob $prefix . "*" . $_
+          for ".dsc", ".diff.gz", ".upload", ".inmulti", ".changes",
+          ".build", ".buildinfo", ".debian.tar.*", "[0-9~].tar.*";
+        # ^ last one is native package tarballs but not orig.tars,
+        # which are handled separately
+
+        # we keep the two most recent orig.tar
+        my @origs = sort {
+            $a =~ /_([^_]+)\.orig\.tar/;
+            my $ver_a = Dpkg::Version->new("$1");
+            $b =~ /_([^_]+)\.orig\.tar/;
+            my $ver_b = Dpkg::Version->new("$1");
+            version_compare($ver_b, $ver_a);
+        } grep { !/\.asc\z/ } glob("$prefix*.orig.tar.*");
+        if (@origs > 2) {
+            shift @origs;
+            shift @origs;
+            for (@origs) {
+                unlink;
+                unlink "$_.asc" if -e "$_.asc";
+            }
+        }
+    }
+
+    # could also run `clean-patch-queues -y` here
+}
+
+sub say_block (*$$) {
+    my ($fh, $block, $text) = @_;
+
+    print $fh "\n[$block]\n";
+    print $fh $text;
+    print $fh "\n";
+}
+
+sub is_repo {
+    my $repo = shift;
+    return -d "$repo/.git" || -d "$repo/.hg";
+}
+
+1;
diff --git a/perl5/Local/Homedir/Mail.pm b/perl5/Local/Homedir/Mail.pm
new file mode 100644
index 00000000..b8140e05
--- /dev/null
+++ b/perl5/Local/Homedir/Mail.pm
@@ -0,0 +1,142 @@
+package Local::Homedir::Mail;
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+use 5.028;
+use strict;
+use warnings;
+use constant THIRTYONE => 31 * 24 * 60 * 60;
+
+use File::Spec::Functions qw(catfile);
+use File::Temp qw(tempdir);
+use File::Path qw(remove_tree);
+use IO::Compress::Gzip qw(gzip $GzipError);
+use IO::Uncompress::Gunzip qw(gunzip $GunzipError);
+use Mail::Box::Manager;
+use Exporter 'import';
+
+our @EXPORT_OK = qw( archive_to_mbox expand_mbox );
+
+sub archive_to_mbox {
+    my ($source_path, $mbox_path, $expanded_path) = @_;
+
+    # bail out if compressed mbox exists: that means this month's
+    # archive has already happened.  it's okay to append to a
+    # not-yet-compressed mbox, as that probably means that the
+    # archival process was interrupted
+    die
+"wanted to archive $source_path to $mbox_path but $mbox_path.gz already exists"
+      if -e "$mbox_path.gz";
+
+    # each invocation of the archive subroutine has its own
+    # Mail::Box::Manager because we want to call closeAllFolders and
+    # thereby perform all the moves and copies
+    my $mgr = Mail::Box::Manager->new();
+
+    my $source
+      = $mgr->open($source_path, access => 'rw', create => 0, keep_dups => 1);
+    my $mbox = $mgr->open(
+        $mbox_path,
+        access    => 'a',
+        create    => 1,
+        keep_dups => 1,
+        type      => 'mbox'
+    );
+    my $expanded = $mgr->open(
+        $expanded_path,
+        access    => 'a',
+        create    => 1,
+        keep_dups => 1,
+        type      => 'maildir',
+    );
+
+    my $now = time();
+    foreach my $message ($source->messages()) {
+        next unless $now - $message->timestamp > THIRTYONE;
+        next unless $message->label('seen');
+        next if $message->label('flagged');
+
+        $mgr->copyMessage($expanded, $message);
+        $mgr->moveMessage($mbox, $message);
+    }
+
+    $mgr->closeAllFolders;
+    gzip($mbox_path, "$mbox_path.gz")
+      or die "gzip failed: $GzipError\n";
+    unlink $mbox_path if -e "$mbox_path.gz";
+    make_maildir_readonly($expanded_path);
+}
+
+sub expand_mbox {
+    my ($source_path, $expanded_path) = @_;
+    my $lockfile = $expanded_path . ".lock";
+
+    # check whether we got halfway there, or we finished it
+    if (-e $lockfile) {
+        remove_tree($expanded_path);
+        unlink $lockfile;
+    } elsif (-e $expanded_path) {
+        return;
+    }
+
+    # lock this one
+    open my $touch_fh, '>', $lockfile;
+    close $touch_fh;
+
+    # unzip it to (what is hopefully a) tmpfs, since Mail::Box can
+    # only accept a path to an unzipped mbox
+    my $dir = tempdir(CLEANUP => 1, DIR => "/tmp");
+    chmod 0700, $dir;
+    my $unzipped = catfile($dir, "unzip.mbox");
+    gunzip($source_path, $unzipped) or die "gunzip failed: $GunzipError\n";
+
+    my $mgr    = Mail::Box::Manager->new();
+    my $source = $mgr->open(
+        $unzipped,
+        access    => 'r',
+        keep_dups => 1,
+        type      => 'mbox'
+    );
+    my $expanded = $mgr->open(
+        $expanded_path,
+        access    => 'a',
+        create    => 1,
+        keep_dups => 1,
+        type      => 'maildir'
+    );
+
+    foreach my $message ($source->messages()) {
+        $message->label(flagged => 0, seen => 1);
+        $mgr->copyMessage($expanded, $message);
+    }
+    $mgr->closeAllFolders;
+    make_maildir_readonly($expanded_path);
+
+    # mark as done
+    unlink $lockfile;
+
+    # nuke the tempdir now to avoid running out of ramdisk if we're
+    # expanding a lot of mboxes
+    remove_tree($dir);
+}
+
+sub make_maildir_readonly {
+    chmod 0500, catfile($_[0], "cur"), catfile($_[0], "new"),
+      catfile($_[0], "tmp");
+    chmod 0400, glob "$_[0]/cur/* $_[0]/new/* $_[0]/tmp/*";
+}
+
+1;
diff --git a/perl5/Local/Interactive.pm b/perl5/Local/Interactive.pm
new file mode 100644
index 00000000..f33533a2
--- /dev/null
+++ b/perl5/Local/Interactive.pm
@@ -0,0 +1,272 @@
+package Local::Interactive;
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+use strict;
+use warnings;
+
+use Cwd;
+use File::Temp qw(tempfile tempdir);
+use File::Path qw(remove_tree);
+use Exporter 'import';
+use Term::ANSIColor;
+use Local::ScriptStatus;
+use Sys::Hostname;
+
+# Quoting perldoc perlmodlib: "As a general rule, if the module is
+# trying to be object oriented then export nothing. If it's just a
+# collection of functions then @EXPORT_OK anything but use @EXPORT
+# with caution."
+our @EXPORT_OK = qw(
+                       interactive_ensure_subroutine
+                       interactive_ensure_subroutine_success
+                       interactive_ensure_subroutine_no_output
+                       system_pty_capture
+                       prompt prompt_yn prompt_Yn prompt_yN
+                       get_ack show_user
+                  );
+
+=head1 IMPORTABLE SUBROUTINES
+
+=head2 interactive_ensure_subroutine($cmd_fn, $check_fn, $dir, $hint)
+
+Call anonymous subroutine C<$cmd_fn> with no arguments, and expect it
+to return a scalar.  Pass this to C<$check_fn>.  Do this repeatedly
+until C<$check_fn> returns a true value.  When C<$check_fn> returns a
+false value, print C<$hint> and start an interactive shell in C<$dir>.
+Continue the loop when it exits.
+
+Usual usage is to have C<$cmd_fn> return the value of an invocation of
+C<system_pty_capture()>.
+
+=cut
+
+sub interactive_ensure_subroutine {
+    my ($cmd_fn, $check_fn, $dir, $hint) = @_;
+
+    $dir //= $ENV{HOME};
+    my $cwd;
+    my $cmd_result;
+    while (1) {
+        $cmd_result = $cmd_fn->();
+        return if $check_fn->($cmd_result);
+        return if prompt_yN("Give up and ignore this problem?");
+        say_bold("Hint: to resolve this situation, $hint") if defined $hint;
+        script_status("hit C-d to exit the shell and try again");
+        $cwd = getcwd();
+        chdir $dir;
+        system $ENV{SHELL};
+        chdir $cwd;
+    }
+}
+
+=head2 interactive_ensure_subroutine_success($cmd_fn, $dir, $hint)
+
+Like C<interactive_ensure_subroutine()>, except the C<$check_fn>
+argument is supplied for you.  Checks that C<$cmd_fn> returns an
+anonymous hash containing a key 'exit' with value 0.
+
+=cut
+
+sub interactive_ensure_subroutine_success {
+    my ($cmd_fn, $dir, $hint) = @_;
+
+    interactive_ensure_subroutine($cmd_fn, sub {
+                                      my $result = shift;
+
+                                      if (exists $result->{exit}
+                                          && $result->{exit} == 0) {
+                                          return 1;
+                                      } else {
+                                          say_bold("uh oh, command unexpectedly exited nonzero");
+                                          return 0;
+                                      }}, $dir, $hint);
+}
+
+=head2 interactive_ensure_subroutine_no_output($cmd_fn, $dir, $hint)
+
+Like C<interactive_ensure_subroutine()>, except the C<$check_fn>
+argument is supplied for you.  Checks that C<$cmd_fn> returns an
+anonymous hash containing a key 'output' which is empty except
+possibly for newlines.
+
+=cut
+
+sub interactive_ensure_subroutine_no_output {
+    my ($cmd_fn, $dir, $hint) = @_;
+
+    my $check_fn = sub {
+        my $result = shift;
+
+        if (exists $result->{output}) {
+            chomp($result->{output});
+            if ($result->{output} eq '') {
+                return 1;
+            } else {
+                say_bold("uh oh, command unexpectedly produced output");
+                return 0;
+            }
+        } else {
+            return 1;
+        }
+    };
+    interactive_ensure_subroutine($cmd_fn, $check_fn, $dir, $hint);
+}
+
+=head2 system_pty_capture($cmd)
+
+Run a command C<$cmd> with STDOUT & STDERR connected to the terminal,
+and also capture the (merged) output for inspection in Perl.  Programs
+will usually still output ANSI escape sequences, so the capturing
+should be transparent to the user.  sudo password prompts work, too.
+
+We use script(1) because it's widely available.  An alternative is
+unbuffer(1) from the 'expect' package, or see perl function
+C<terminal_friendly_spawn()> in the myrepos program.
+
+Note that if C<$cmd> will cause sudo to prompt for a password, that
+will be forgotten when system_pty_capture() returns.  So sequential
+system_pty_capture("sudo ...") calls will each prompt the user for
+their password, bypassing sudo's usual timeout between requiring a
+password.
+
+=cut
+
+sub system_pty_capture {
+    my ($cmd) = @_;
+
+    # the point of creating a tempdir and then putting a file inside
+    # it is that then we can chmod that dir.  File::Temp apparently
+    # uses secure permissions on files it creates in /tmp, but this
+    # but it is not documented, so let's not rely on it
+    my $dir = tempdir("sysptycap." . hostname() . ".$$.XXXX",
+                      CLEANUP => 1, TMPDIR => 1);
+    chmod 0700, $dir;
+    my (undef, $filename) = tempfile("sysptycap.XXXX",
+                                     OPEN => 0, DIR => $dir);
+    system qw(script --quiet --command), $cmd, $filename;
+
+    open my $fh, '<', $filename;
+    chomp(my @output = <$fh>);
+    close $fh;
+    remove_tree($dir);
+
+    $output[$#output] =~ /COMMAND_EXIT_CODE="([0-9]+)"/;
+    my $exit = $1;
+    @output = splice @output, 1, -1;
+
+    return { exit => $exit, output => join("\n", @output) };
+}
+
+=head prompt($prompt)
+
+Prompt with C<$prompt> for a single line of input.
+
+=cut
+
+sub prompt {
+    my ($prompt) = @_;
+
+    local $| = 1;
+    print colored("$prompt ", 'bold');
+    chomp(my $response = <STDIN>);
+    return $response;
+}
+
+=head prompt_yn($prompt)
+
+Prompt with C<$prompt> for input of either 'y' or 'n', returning a
+true or false value respectively.  No default response; just hitting
+RET is invalid.
+
+=cut
+
+sub prompt_yn {
+    my ($prompt) = @_;
+
+    my $response;
+    while (1) {
+        $response = prompt("$prompt (y/n)");
+        return 1 if lc($response) eq 'y';
+        return 0 if lc($response) eq 'n';
+        print "invalid response\n";
+    }
+}
+
+=head prompt_Yn($prompt)
+
+Prompt with C<$prompt> for input of either 'y' or 'n', returning a
+true or false value respectively.  Hitting RET is equivalent to
+answering 'y'.
+
+=cut
+
+sub prompt_Yn {
+    my ($prompt) = @_;
+
+    my $response;
+    while (1) {
+        $response = prompt("$prompt (Y/n)");
+        return 1 if lc($response) eq 'y' or $response eq '';
+        return 0 if lc($response) eq 'n';
+        print "invalid response\n";
+    }
+}
+
+=head prompt_yN($prompt)
+
+Prompt with C<$prompt> for input of either 'y' or 'n', returning a
+true or false value respectively.  Hitting RET is equivalent to
+answering 'n'.
+
+=cut
+
+sub prompt_yN {
+    my ($prompt) = @_;
+
+    my $response;
+    while (1) {
+        $response = prompt("$prompt (y/N)");
+        return 1 if lc($response) eq 'y';
+        return 0 if lc($response) eq 'n' or $response eq '';
+        print "invalid response\n";
+    }
+}
+
+=head get_ack()
+
+Wait for user to hit RET.
+
+=cut
+
+sub get_ack { prompt("[acknowledge]") };
+
+=head show_user($cmd, $comment)
+
+Show the output of command C<$cmd> to the user, make a comment on it,
+prompt for acknowledgement.
+
+=cut
+
+sub show_user {
+    my ($cmd, $comment) = @_;
+
+    system $cmd;
+    say_spaced_bullet($comment);
+    get_ack();
+}
+
+1;
diff --git a/perl5/Local/MrRepo.pm b/perl5/Local/MrRepo.pm
new file mode 100644
index 00000000..c5aa7cfe
--- /dev/null
+++ b/perl5/Local/MrRepo.pm
@@ -0,0 +1,114 @@
+package Local::MrRepo;
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+use strict;
+use warnings;
+use lib "$ENV{HOME}/lib/perl5";
+
+use Cwd;
+use File::Spec::Functions qw(catfile rel2abs);
+use Exporter 'import';
+use File::Find;
+
+# Quoting perldoc perlmodlib: "As a general rule, if the module is
+# trying to be object oriented then export nothing. If it's just a
+# collection of functions then @EXPORT_OK anything but use @EXPORT
+# with caution."
+our @EXPORT_OK = qw( new_repo );
+
+# Local::MrRepo::Repo::Git and its subclass require non-core
+# modules, so we might not be able to load them.  If so we'll fall
+# back on Local::MrRepo::Repo
+#
+# ~/bin/locmaint and Local::Homedir use the simpler technique of just
+#
+#     return unless eval "use Foo::Bar; 1";
+#
+# at the top of functions that require use Foo::Bar.  However, for
+# MrRepo classes we want to rethrow exceptions (other than import
+# failures) to make it easier to debug those classes.
+#
+# The purpose of wrapping conditional module inclusion in BEGIN is to
+# provide subroutine definitions etc. to the compiler as early as
+# possible.  AFAICT that's not really needed when importing modules
+# providing only an OO interface, however, because they don't usually
+# export anything at all.  That's why the simpler technique suffices
+# over in ~/bin/locmaint and Local::Homedir, for Data::Manip and
+# Git::Wrapper.
+#
+# References: Perl Cookbook 12.2, "Trapping Errors in require or use"
+#             Modern Perl, ch. 8, "Catching Exceptions"
+my $have_mrrepo_git;            # must not initialise here
+BEGIN {
+    local $@;
+    eval "require Local::MrRepo::Repo::Git";
+    if (my $exception = $@) {
+        die $exception unless $exception =~ /^Can't locate .+ in \@INC/;
+        $have_mrrepo_git = 0;
+    } else {
+        Local::MrRepo::Git->import();
+        local $@;
+        eval "require Local::MrRepo::Repo::Git::Annex";
+        if (my $exception = $@) {
+            die $exception unless $exception =~ /^Can't locate .+ in \@INC/;
+            $have_mrrepo_git = 0;
+        } else {
+            Local::MrRepo::Git::Annex->import();
+            $have_mrrepo_git = 1;
+        }
+    }
+}
+
+sub new_repo {
+    my $dir = shift;
+
+    if ($have_mrrepo_git && -d catfile($dir, ".git")) {
+        if (has_annex_objects($dir)) {
+            return Local::MrRepo::Repo::Git::Annex->new($dir);
+        } else {
+            return Local::MrRepo::Repo::Git->new($dir);
+        }
+    } else {
+        return Local::MrRepo::Repo->new($dir);
+    }
+}
+
+sub has_annex_objects {
+    my $repo = rel2abs(shift);
+
+    my $objects_dir = catfile($repo, ".git", "annex", "objects");
+    return 0 unless -d $objects_dir;
+    # File::Find::find changes the working directory; undo that
+    # (no_chdir doesn't seem to be sufficient)
+    my $cwd   = getcwd();
+    my $found = 0;
+    find(
+        sub {
+            if (-f $File::Find::name) {
+                $found = 1;
+                # File::Find does not really support exiting the search
+                goto MRREPO_DONE_ANNEX_OBJECTS;
+            }
+        },
+        $objects_dir
+    );
+  MRREPO_DONE_ANNEX_OBJECTS:
+    chdir $cwd;
+    return $found;
+}
+
+1;
diff --git a/perl5/Local/MrRepo/Repo.pm b/perl5/Local/MrRepo/Repo.pm
new file mode 100644
index 00000000..5dc367c6
--- /dev/null
+++ b/perl5/Local/MrRepo/Repo.pm
@@ -0,0 +1,82 @@
+package Local::MrRepo::Repo;
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+use strict;
+use warnings;
+
+use Exporter 'import';
+use File::Spec::Functions qw(rel2abs);
+use Local::Interactive qw(system_pty_capture);
+
+# Quoting perldoc perlmodlib: "As a general rule, if the module is
+# trying to be object oriented then export nothing. If it's just a
+# collection of functions then @EXPORT_OK anything but use @EXPORT
+# with caution."
+our @EXPORT_OK = ();
+
+# constructor
+sub new {
+    my ($class, $toplevel) = @_;
+
+    bless {toplevel => rel2abs($toplevel), updated => 0}, $class;
+}
+
+# attributes
+sub toplevel { return shift->{toplevel} }
+sub updated  { return shift->{updated}  }
+
+# public methods
+sub auto_commit {
+    my $self = shift;
+
+    return $self->_mr_cmd("-m", "autoci");
+}
+sub update {
+    my $self = shift;
+
+    # note that this also restows
+    my $result = $self->_mr_cmd("update");
+    $self->{updated} = 1
+      if $result->{exit} == 0
+      # permit nonzero exit for package that might still be in NEW
+      || $result->{output}
+      =~ /^dgit: source package [a-z0-9+.-]+ does not exist in suite [a-z]+\s*$/m;
+    return $result;
+}
+sub status {
+    my $self = shift;
+
+    my $toplevel = $self->toplevel; # TODO avoid need for this var!
+
+    my $result = $self->_mr_cmd("-m", "status");
+
+    # Special case: there was no visible output because mr's minimal
+    # mode kicked in; override that in our hash
+    $result->{output} = ""
+      if ($result->{output} =~ /\Amr status: $toplevel[^[:print:]]/);
+
+    return $result;
+}
+
+# private methods
+sub _mr_cmd {
+    my $self = shift;
+
+    return system_pty_capture("mr -d " . $self->toplevel . " @_");
+}
+
+1;
diff --git a/perl5/Local/MrRepo/Repo/Git.pm b/perl5/Local/MrRepo/Repo/Git.pm
new file mode 100644
index 00000000..90dc8f4c
--- /dev/null
+++ b/perl5/Local/MrRepo/Repo/Git.pm
@@ -0,0 +1,146 @@
+package Local::MrRepo::Repo::Git;
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+use 5.018;
+use strict;
+use warnings;
+use lib "$ENV{HOME}/lib/perl5";
+use parent 'Local::MrRepo::Repo';
+
+use Exporter 'import';
+use File::Spec::Functions qw(rel2abs);
+use Git::Wrapper;
+use Local::ScriptStatus;
+use Local::Interactive qw(get_ack);
+use Local::Util::Git qw(unpushed_tags);
+use Try::Tiny;
+
+our @EXPORT_OK = ();
+
+# constructor
+sub new {
+    my ($class, $toplevel) = @_;
+
+    bless {
+        toplevel => rel2abs($toplevel),
+        updated  => 0,
+        git      => Git::Wrapper->new(rel2abs($toplevel)),
+    }, $class;
+}
+
+# attributes
+sub git { return shift->{git} }
+
+# public methods
+
+# could make this runnable from a ~/bin/git-reviewrepo script or
+# something.  Initialise a MrRepo::Repo::Git object in that script
+sub review {
+    my $self = shift;
+
+    my $issues = 0;
+
+    # 1. Check for a detached HEAD which is not contained in any local
+    # or remote ref, and might therefore contain useful work
+    try {
+        $self->git->symbolic_ref({ quiet => 1 }, "HEAD");
+    } catch {
+        if ($_->status == 1) {  # HEAD is detached
+            my ($commit) = $self->git->rev_parse('HEAD^{commit}');
+            my @containing_refs =
+              $self->git->for_each_ref({ contains => $commit },
+                                       "refs/heads", "refs/remotes");
+            if (@containing_refs == 0) { # HEAD contains work
+                say_spaced_bullet("The HEAD is detached and contains commits not in any branch.");
+                $issues = 1;
+            }
+        }
+    };
+    # 2. Check for uncommitted changes.  Note this won't work for
+    #    direct mode git annexes (but I I no longer use any of those).
+    #
+    # check for uncommitted staged changes, unstaged changes to
+    # tracked files and untracked files
+    my @porcelain_status = $self->git->RUN("status", {porcelain => 1});
+    # check for stashes
+    my @stash_list = $self->git->stash("list");
+
+    unless (@porcelain_status == 0 && @stash_list == 0) {
+        my @status_lines = map { s/^/  /r }
+          $self->git->RUN("-c", "color.status=always", "status", "--short"),
+          # there doesn't appear to be a color output option for git stash
+          "", $self->git->stash("list");
+        say_spaced_bullet("There is uncommitted work:");
+        say for @status_lines;
+        $issues = 1;
+    }
+    # 3. Check for unpushed branches.  The porcelain equivalent is
+    #     git --no-pager log --branches --not --remotes --simplify-by-decoration --decorate --oneline
+    my @local_branches = grep { not m|\Arefs/heads/adjusted/| }
+      $self->git->for_each_ref({format => '%(refname)'}, "refs/heads");
+    my @unpushed_branches;
+    foreach my $branch (@local_branches) {
+        my @containing_remotes
+          = $self->git->for_each_ref({ contains => $branch }, "refs/remotes");
+        @containing_remotes
+          = grep { not m|refs/remotes/dgit/| } @containing_remotes
+          unless $branch =~ m|\Arefs/heads/dgit/|;
+        @containing_remotes
+          = grep { not m|refs/remotes/develacc/| } @containing_remotes;
+        push @unpushed_branches, $branch unless @containing_remotes;
+    }
+    unless (@unpushed_branches == 0) {
+        my @log_lines;
+        push @log_lines, map { s/^/  /r }
+          $self->git->RUN("log", "--decorate", "--oneline", "--color=always",
+                          "-1", $_)
+          foreach @unpushed_branches;
+
+        say_spaced_bullet
+          ("There are local branches which are not pushed anywhere:");
+        say for @log_lines;
+        say_bold
+          ("\n  Maybe you want to `git push-all' or `git branchmove' them to a remote.");
+        $issues = 1;
+    }
+
+    # 4. Check for tags not pushed to any remote
+    local $@;
+    my @unpushed_tags;
+    eval { @unpushed_tags = unpushed_tags($self->toplevel) };
+    if (my $exception = $@) {
+        die $exception unless $exception =~ /failed to list git remote/;
+        say_bullet("Warning: could not check for unpushed tags: $exception");
+        get_ack();
+    }
+    unless (@unpushed_tags == 0) {
+        say_bold("There are tags not pushed to any remote:");
+        print "\n";
+        print "  $_\n" for @unpushed_tags;
+        $issues = 1;
+    }
+
+    return $issues;
+}
+
+sub git_path {
+    my $self = shift;
+    my ($path) = $self->git->rev_parse({ git_path => 1 }, $_[0]);
+    return rel2abs($path, $self->toplevel);
+}
+
+1;
diff --git a/perl5/Local/MrRepo/Repo/Git/Annex.pm b/perl5/Local/MrRepo/Repo/Git/Annex.pm
new file mode 100644
index 00000000..7bf976f5
--- /dev/null
+++ b/perl5/Local/MrRepo/Repo/Git/Annex.pm
@@ -0,0 +1,325 @@
+package Local::MrRepo::Repo::Git::Annex;
+
+# Copyright (C) 2019-2020 Sean Whitton
+#
+# 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 3 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/>.
+
+use 5.018;
+use strict;
+use warnings;
+use lib "$ENV{HOME}/lib/perl5";
+use parent 'Local::MrRepo::Repo::Git';
+
+use Data::Compare;
+use Exporter 'import';
+use File::Spec::Functions qw(rel2abs catfile);
+use Git::Wrapper;
+use JSON;
+use Local::ScriptStatus;
+use Try::Tiny;
+use Term::ReadKey;
+use Local::Interactive qw(prompt prompt_yn);
+use Storable;
+use List::Util qw(all);
+
+our @EXPORT_OK = ();
+
+sub review {
+    my $self = shift;
+
+    my $issues = $self->SUPER::review(@_);
+
+    # if there were git issues, fail now, as the annex issues can
+    # produce copious output and it is nice to know there were no git
+    # issues when reviewing the annex issues
+    return $issues if $issues;
+
+    # another command we could consider running is `git annex fsck --fast`
+
+    # 1. Check for files stored only locally where that's not okay
+    my @annex_find_output = $self->git->annex("find", "--json",
+  "--in", "here", "--and", "--not", "--copies=2", "--and", "--lackingcopies=1");
+    unless (@annex_find_output == 0) {
+        say_spaced_bullet("Some annex content is present only locally:");
+        say "  $_" for map { ${decode_json($_)}{file} } @annex_find_output;
+        print "\n";
+        say_bold
+          ("  use `git annex sync --content' to fix this (`mr push' should be");
+        say_bold
+          ("  configured to run that command with the right remotes)");
+        $issues = 1;
+    }
+    # 2. Check for unused files which we should be able to clean up
+    my ($review_unused) = $self->git->config(qw(--local --get --type=bool
+                                                --default true
+                                                mrrepo.review-unused));
+    $issues = $self->review_unused(interactive => 0) || $issues
+      if $review_unused eq 'true';
+
+    return $issues;
+}
+
+sub review_unused {
+    my $self = shift;
+    my %opts = @_;
+
+    my $used_refspec_config;
+    try { ($used_refspec_config) = $self->git->config("annex.used-refspec") };
+
+    $opts{interactive} //= 0;
+    # only supply a default value for this if annex.used-refspec has
+    # not been configured, so that annex.used-refspec takes effect if
+    # our caller does not supply a used_refspec
+    $opts{used_refspec} //= "+refs/heads/*:-refs/heads/synced/*"
+      unless defined $used_refspec_config;
+
+    my %unused_args = ();
+    $unused_args{used_refspec} = $opts{used_refspec}
+      if exists $opts{used_refspec};
+    my %dropunused_args = (force => 1);
+    $unused_args{from} = $dropunused_args{from} = $opts{from}
+      if defined $opts{from};
+
+    my @to_drop      = ();
+    my $unused_files = $self->unused_files(\%unused_args);
+    $self->log_unused();
+    my @unused_files = @$unused_files;
+    return 0 if @unused_files == 0;
+    unless ($opts{interactive}) {
+        say_spaced_bullet("There are unused files you can drop with"
+              . " `git annex dropunused':");
+        say "    " . $_->{number} . "     " . $_->{key} for @unused_files;
+        print "\n";
+    }
+
+    my ($uuid) = $self->git->config("remote." . $opts{from} . ".annex-uuid")
+      if defined $opts{from};
+
+    my $i = 0;
+  UNUSED: while ($i < @unused_files) {
+        my $unused_file = $unused_files[$i];
+
+        # check the unused file still exists i.e. has not been dropped
+        # already (in the case of reviewing unused files at a remote,
+        # just check that it's not been dropped according to the local
+        # git-annex branch) use checkpresentkey in that case
+        my $contentlocation = $self->abs_contentlocation($unused_file->{key});
+        if (defined $opts{from}) {
+            try {
+                $self->git->annex("readpresentkey", $unused_file->{key},
+                    $uuid);
+            }
+            catch {
+                splice @unused_files, $i, 1;
+                next UNUSED;
+            };
+        } elsif (!defined $contentlocation) {
+            splice @unused_files, $i, 1;
+            next UNUSED;
+        }
+
+        system('clear', '-x') if $opts{interactive};
+        say_bold("unused file #" . $unused_file->{number} . ":");
+
+        if ($unused_file->{bad} || $unused_file->{tmp}) {
+            say "  looks like stale tmp or bad file, with key "
+              . $unused_file->{key};
+        } else {
+            my @log_lines = @{ $unused_file->{log_lines} };
+            if ($opts{interactive}) {
+                # truncate log output if necessary to ensure user's
+                # terminal does not scroll
+                my (undef, $height, undef, undef) = GetTerminalSize();
+                splice @log_lines, (($height - 5) - @log_lines)
+                  if @log_lines > ($height - 5);
+            }
+            print "\n";
+            say for @log_lines;
+            if ($opts{interactive}) {
+                my $response;
+                while (1) {
+                    # before prompting, clear out stdin, to avoid
+                    # registered a keypress more than once
+                    ReadMode 4;
+                    while (defined ReadKey(-1)) { }
+
+                    my @opts = ('y', 'n');
+                    push @opts, 'o' if defined $contentlocation;
+                    push @opts, ('d', 'b') if $i > 0;
+                    print "Drop this unused files?  ("
+                      . join('/', @opts) . ") ";
+
+                    # Term::ReadKey docs recommend ReadKey(-1) but
+                    # that means we need an infinite loop calling
+                    # ReadKey(-1) over and over, which ramps up system
+                    # load
+                    my $response = ReadKey(0);
+                    ReadMode 0;
+
+                    # respond to C-c
+                    exit 0 if ord($response) == 3;
+
+                    say $response;
+                    $response = lc($response);
+                    if ($response eq 'y') {
+                        push @to_drop, $unused_file->{number};
+                        last;
+                    } elsif ($response eq 'n') {
+                        last;
+                    } elsif ($response eq 'o' and defined $contentlocation) {
+                        system('xdg-open', $contentlocation);
+                    } elsif ($response eq 'b' and $i > 0) {
+                        $i--;
+                        pop @to_drop
+                          if @to_drop
+                          and $to_drop[$#to_drop] eq
+                          $unused_files[$i]->{number};
+                        next UNUSED;
+                    } elsif ($response eq 'd' and $i > 0) {
+                        # user wants to drop the list we've
+                        # accumulated up until now and get out of this
+                        # script
+                        last UNUSED;
+                    } else {
+                        say "invalid response";
+                    }
+                }
+            }
+        }
+        print "\n";
+        $i++;
+    }
+
+    if (@to_drop) {
+        say_spaced_bullet("Will dropunused"
+              . (exists $dropunused_args{force} ? " with --force:" : ":"));
+        say "@to_drop\n";
+        $self->git->annex("dropunused", \%dropunused_args, @to_drop)
+          if prompt_yn("Go ahead with this?");
+    }
+    # return boolean value representing whether or not there are any
+    # unused files left after this run.  note in non-interactive mode
+    # @to_drop will be empty so will always return 1 if we got this
+    # far in the subroutine
+    if (@to_drop == @unused_files) {
+        delete $self->{_unused_files};
+        unlink $self->_unused_cache_file;
+        return 0;
+    } else {
+        return 1;
+    }
+}
+
+
+sub unused_files {
+    my ($self, $unused_args) = @_;
+
+    my $cache_file = $self->_unused_cache_file;
+    $self->{_unused_files} //= retrieve($cache_file) if -e $cache_file;
+
+    # see if cached result needs to be invalidated
+    if (defined $self->{_unused_files}) {
+        my $annex_dir = $self->git_path("annex");
+        my $last_unused = (stat(catfile($annex_dir, "unused")))[9];
+        my %branch_timestamps
+          = map { split ' ' }
+          $self->git->for_each_ref(
+            { format => '%(refname:short) %(committerdate:unix)' },
+            "refs/heads/");
+
+        # we don't need to invalidate the cache if the git-annex
+        # branch has changed, because the worst that can happen is we
+        # try to drop a file which has already been dropped
+        delete $branch_timestamps{'git-annex'};
+
+        if (    $last_unused <= $self->{_unused_files}->{timestamp}
+            and Compare($unused_args, $self->{_unused_files}->{unused_args})
+            and all { $_ < $last_unused } values %branch_timestamps) {
+            return $self->{_unused_files}->{unused};
+        } else {
+            delete $self->{_unused_files};
+        }
+    }
+
+    # if we're still in the method at this point then the cache was
+    # invalidated; regenerate it
+    my ($bad, $tmp) = (0, 0);
+    %{ $self->{_unused_files}->{unused_args} } = %$unused_args;
+    foreach ($self->git->annex("unused", $unused_args)) {
+        if (/Some corrupted files have been preserved by fsck, just in case/) {
+            ($bad, $tmp) = (1, 0);
+        } elsif (/Some partially transferred data exists in temporary files/) {
+            ($bad, $tmp) = (0, 1);
+        } elsif (/^    ([0-9]+) +([^ ]+)$/) {
+            push @{ $self->{_unused_files}->{unused} },
+              { number => $1, key => $2, bad => $bad, tmp => $tmp };
+        }
+    }
+    $self->{_unused_files}->{timestamp} = time();
+    $self->_store_unused();
+    return $self->{_unused_files}->{unused};
+}
+
+sub log_unused {
+    my $self = shift;
+
+    foreach my $unused_file (@{ $self->{_unused_files}->{unused} }) {
+        next if defined $unused_file->{log_lines};
+        # We need the RUN here to avoid special postprocessing but
+        # also to get the -c option passed -- unclear how to pass
+        # short options to git itself, not the 'log' subcommand,
+        # with Git::Wrapper except by using RUN (passing long
+        # options to git itself is easy, per Git::Wrapper docs)
+        @{ $unused_file->{log_lines} } = map { s/^/  /r } $self->git->RUN(
+            "-c",
+            "diff.renameLimit=3000",
+            "log",
+            {
+                stat        => 1,
+                no_textconv => 1
+            },
+            "--color=always",
+            "-S",
+            $unused_file->{key});
+    }
+    $self->_store_unused();
+}
+
+sub _store_unused {
+    my $self = shift;
+    store($self->{_unused_files}, $self->_unused_cache_file);
+}
+
+sub _unused_cache_file {
+    my $annex_dir = shift->git_path("annex");
+    return catfile($annex_dir, "unused_info");
+}
+
+sub abs_contentlocation {
+    my $self = shift;
+    my $key  = shift;
+
+    my $contentlocation;
+    try {
+        ($contentlocation) = $self->git->annex("contentlocation", $key);
+    }
+    catch {
+        undef $contentlocation;
+    };
+    return (defined $contentlocation)
+      ? rel2abs($contentlocation, $self->toplevel)
+      : undef;
+}
+
+1;
diff --git a/perl5/Local/ScriptStatus.pm b/perl5/Local/ScriptStatus.pm
new file mode 100644
index 00000000..3500e274
--- /dev/null
+++ b/perl5/Local/ScriptStatus.pm
@@ -0,0 +1,27 @@
+package Local::ScriptStatus;
+
+use strict;
+use warnings;
+use parent 'Exporter';
+
+use Term::ANSIColor;
+use File::Basename;
+
+our @EXPORT = qw( script_status say_bold say_bullet say_spaced_bullet );
+
+my $us = basename($0);
+
+sub script_status {
+    print colored(['bold'], "[");
+    print colored(['bold red'], $us);
+    print colored(['bold'], "] ");
+    say_bold(@_);
+}
+
+sub say_bold { print colored(['bold'], @_), "\n" }
+
+sub say_bullet { say_bold(" • ", @_) }
+
+sub say_spaced_bullet { say_bold("\n", " • ", @_, "\n") }
+
+1;
diff --git a/perl5/Local/Util.pm b/perl5/Local/Util.pm
new file mode 100644
index 00000000..a9d3d13f
--- /dev/null
+++ b/perl5/Local/Util.pm
@@ -0,0 +1,50 @@
+package Local::Util;
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+use strict;
+use warnings;
+
+use Exporter 'import';
+
+our @EXPORT_OK = qw(as_root);
+
+# Prefix a command if that's necessary to run it as root.  Currently
+# supports only sudo(1).  If passed more than one argument, prepends
+# this list with 'sudo'.  If passed a single string argument, returns
+# a list or a string depending on context and whether the string
+# argument contains spaces
+sub as_root {
+    my $context = wantarray();
+    return unless defined $context;
+    if (@_ == 0) {
+        return $context ? () : "";
+    } elsif (@_ == 1) {
+        my $prepend = $context && $_[0] !~ /\s/;
+        if ($> == 0) {
+            return $prepend ? @_ : $_[0];
+        } else {
+            return $prepend ? ("sudo", @_) : "sudo ".$_[0];
+        }
+    } else {
+        # Ignore context in this case, because joining the list of
+        # arguments into a single string completely correctly is
+        # fairly involved
+        return $> == 0 ? @_ : ("sudo", @_);
+    }
+}
+
+1;
diff --git a/perl5/Local/Util/Git.pm b/perl5/Local/Util/Git.pm
new file mode 100644
index 00000000..55e65eb8
--- /dev/null
+++ b/perl5/Local/Util/Git.pm
@@ -0,0 +1,88 @@
+package Local::Util::Git;
+
+# Copyright (C) 2019 Sean Whitton
+#
+# 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 3 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/>.
+
+
+# Probably best if this module has no non-core dependencies.
+
+use strict;
+use warnings;
+
+use Exporter 'import';
+
+our @EXPORT_OK = qw(unpushed_tags);
+
+sub unpushed_tags {
+    my ($dir) = shift;
+
+    my $git = "git";
+    $git .= " -C $dir" if defined $dir;
+
+    # allow skipping this check on a whole repo
+    chomp(my $ignore =
+          `$git config --local --get --type=bool unpushed-tags.ignore`);
+    return () if $ignore eq 'true';
+
+    # archive/debian/foo tags are pushed only to dgit repos in split
+    # brain mode.  Also, it is highly unlikely they don't get pushed
+    # there, so we aren't going to check.  We probably don't want to
+    # ls-remote dgit-repos because that's not really a supported API
+    # (note that dgit doesn't create an origin remote pointing to
+    # dgit-repos anymore)
+    #
+    # We also ignore a debian/foo tag where the corresponding
+    # archive/debian/foo tag exists, because that means the former has
+    # been pushed to dgit repos
+    chomp(my @all_tags = `$git tag`);
+    die "failed to get git tags" unless ($? == 0);
+    my @tags;
+    my %dgit_archive_tags;
+    for (@all_tags) {
+        if (m|^archive/debian/|) {
+            $dgit_archive_tags{$_} = undef;
+        } else {
+            push @tags, $_;
+        }
+    }
+    @tags
+      = grep { !(m|^debian/| and exists $dgit_archive_tags{"archive/$_"}) }
+      @tags;
+
+    chomp(my @remotes = `$git remote`);
+    die "failed to get git remotes" unless ($? == 0);
+    @remotes = grep !/\Adgit\z/, @remotes;
+
+    my %pushed_tags;
+    foreach my $remote (@remotes) {
+        # allow skipping remotes which don't like 'ls-remote'
+        chomp(my $ignore =
+              `$git config --local --get --type=bool remote.$remote.unpushed-tags-ignore`);
+        next if $ignore eq 'true';
+
+        # remotes without URIs are probably git-annex special remotes; skip them
+        `$git config --local --get remote.$remote.url`;
+        next unless $? == 0;
+
+        chomp(my @ls_remote = `$git ls-remote --tags $remote`);
+        die "failed to list git remote $remote" unless ($? == 0);
+        $pushed_tags{$_} = undef
+          for map { m|^[0-9a-f]+\s+refs/tags/([^^]+)|; $1 // () } @ls_remote;
+    }
+
+    return grep { ! exists $pushed_tags{$_} } @tags;
+}
+
+1;
diff --git a/perl5/ScriptStatus.pm b/perl5/ScriptStatus.pm
new file mode 100644
index 00000000..021dafdc
--- /dev/null
+++ b/perl5/ScriptStatus.pm
@@ -0,0 +1,20 @@
+package ScriptStatus;
+
+use strict;
+use warnings;
+
+use parent 'Exporter';
+our @EXPORT = qw( status );
+
+use Term::ANSIColor;
+use File::Basename;
+
+sub status {
+    my $me = basename($0);
+    print "[";
+    print colored("$me", 'yellow');
+    print "] ";
+    print colored(@_, 'bright_white'), "\n";
+}
+
+1;
diff --git a/perl5/ShellSequence.pm b/perl5/ShellSequence.pm
new file mode 100644
index 00000000..7b07c798
--- /dev/null
+++ b/perl5/ShellSequence.pm
@@ -0,0 +1,133 @@
+package ShellSequence;
+
+use strict;
+use warnings;
+
+use Capture::Tiny 'tee_stdout';
+use Array::Iterator;
+use Term::UI;
+use Term::ReadLine;
+use ScriptStatus;
+
+sub new {
+    my $class = shift;
+
+    my $self = {
+                'commands' => []
+               };
+    bless $self, $class;
+
+    return $self;
+}
+
+# the advantage of using the add_ functions and queuing up commands is
+# that the user will be informed what the next command will be, which
+# helps them decide whether to give up and skip the command (e.g.: `mr
+# autoci` is failing, and `mr push` will be next)
+
+sub add_should_zero {
+    my $self = shift;
+    my @args = @_;
+
+    my $cmd = ['ZERO', @args];
+
+    push @{$self->{'commands'}}, $cmd;
+}
+
+sub add_should_succeed {
+    my $self = shift;
+    my @args = @_;
+
+    my $cmd = ['SUCCEED', @args];
+
+    push @{$self->{'commands'}}, $cmd;
+}
+
+sub should_zero {
+    my $self = shift;
+    my @args = @_;
+
+    $self->add_should_zero(@args);
+    $self->run();
+}
+
+sub should_succeed {
+    my $self = shift;
+    my @args = @_;
+
+    $self->add_should_succeed(@args);
+    $self->run();
+}
+
+sub choice {
+    my $i = shift @_;
+    my @args = @_;
+    my $term = Term::ReadLine->new('brand');
+
+
+    my $shell = $term->ask_yn(
+                              prompt => 'Spawn a shell to investigate?',
+                              default => 'n',
+                             );
+    if ($shell) {
+        status "I will try running `@args' again when this shell exits";
+        system $ENV{'SHELL'};
+        return 1;
+    } else {
+        if ($i->peek()) {
+            my @maybe_next = @{$i->peek()};
+            shift @maybe_next;
+            my @next = @maybe_next;
+            status "info: if you skip, the next command will be `@next'";
+        }
+        my $give_up = $term->ask_yn(
+                                    prompt => 'Give up and skip this command?',
+                                    default => 'n',
+                                   );
+        return !$give_up;
+    }
+}
+
+sub run {
+    my $self = shift;
+
+    my $i = Array::Iterator->new($self->{'commands'});
+
+    while ( my $cmd = $i->get_next() ) {
+        my $require = shift @$cmd;
+        my @args = @$cmd;
+
+        # previously we always used tee_stdout, and then looked at
+        # both $output and its exit code.  However, tee_stdout works
+        # badly for ncurses, such as debconf prompts which appeared
+        # during apt runs.  So don't use tee_stdout except when we
+        # have to
+        while (42) {
+            status "running `@args'";
+            if ($require eq 'SUCCEED') {
+                system @args;
+                my $exit = $? >> 8;
+                if ($exit != 0) {
+                    status "`@args' failed but it was required to succeed";
+                    choice($i, @args) || last;
+                } else {
+                    last;
+                }
+            } else {
+                (my $output, undef) = tee_stdout {
+                    system @args;
+                };
+                if (length($output)) {
+                    status "`@args' was required to produce no output";
+                    choice($i, @args) || last;
+                } else {
+                    last;
+                }
+            }
+        }
+    }
+
+    $self->{'commands'} = [];
+}
+
+1;
diff --git a/perl5/Stow.pm b/perl5/Stow.pm
new file mode 100644
index 00000000..bda7d3ab
--- /dev/null
+++ b/perl5/Stow.pm
@@ -0,0 +1,2110 @@
+#!/usr/bin/perl
+
+package Stow;
+
+=head1 NAME
+
+Stow - manage the installation of multiple software packages
+
+=head1 SYNOPSIS
+
+    my $stow = new Stow(%$options);
+
+    $stow->plan_unstow(@pkgs_to_unstow);
+    $stow->plan_stow  (@pkgs_to_stow);
+
+    my %conflicts = $stow->get_conflicts;
+    $stow->process_tasks() unless %conflicts;
+
+=head1 DESCRIPTION
+
+This is the backend Perl module for GNU Stow, a program for managing
+the installation of software packages, keeping them separate
+(C</usr/local/stow/emacs> vs. C</usr/local/stow/perl>, for example)
+while making them appear to be installed in the same place
+(C</usr/local>).
+
+Stow doesn't store an extra state between runs, so there's no danger
+of mangling directories when file hierarchies don't match the
+database. Also, stow will never delete any files, directories, or
+links that appear in a stow directory, so it is always possible to
+rebuild the target tree.
+
+=cut
+
+use strict;
+use warnings;
+
+use Carp qw(carp cluck croak confess longmess);
+use File::Copy qw(move);
+use File::Spec;
+use POSIX qw(getcwd);
+
+use Stow::Util qw(set_debug_level debug error set_test_mode
+                  join_paths restore_cwd canon_path parent);
+
+our $ProgramName = 'stow';
+our $VERSION = '2.2.2';
+
+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.
+    return $class->get_ignore_regexps_from_fh(\*DATA);
+}
+
+#===== 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;
+
+# Local variables:
+# mode: perl
+# cperl-indent-level: 4
+# end:
+# vim: ft=perl
+
+#############################################################################
+# Default global list of ignore regexps follows
+# (automatically appended by the Makefile)
+
+__DATA__
+# Comments and blank lines are allowed.
+
+RCS
+.+,v
+
+CVS
+\.\#.+       # CVS conflict files / emacs lock files
+\.cvsignore
+
+\.svn
+_darcs
+\.hg
+
+\.git
+\.gitignore
+
+.+~          # emacs backup files
+\#.*\#       # emacs autosave files
+
+^/README.*
+^/LICENSE.*
+^/COPYING
diff --git a/perl5/Stow/Util.pm b/perl5/Stow/Util.pm
new file mode 100644
index 00000000..c22d7b87
--- /dev/null
+++ b/perl5/Stow/Util.pm
@@ -0,0 +1,208 @@
+package Stow::Util;
+
+=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 strict;
+use warnings;
+
+use POSIX qw(getcwd);
+
+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
+
+1;
+
+# Local variables:
+# mode: perl
+# cperl-indent-level: 4
+# end:
+# vim: ft=perl
diff --git a/perl5/TestExec.pm b/perl5/TestExec.pm
new file mode 100755
index 00000000..cf7bcd86
--- /dev/null
+++ b/perl5/TestExec.pm
@@ -0,0 +1,18 @@
+#!/usr/bin/perl
+
+package TestExec;
+
+use strict;
+use warnings;
+
+use Exporter;
+our @ISA = ('Exporter');
+our @EXPORT = ('test_exec');
+
+test_exec() unless caller(0);
+
+sub test_exec {
+    print "this is what I do\n";
+}
+
+1;