diff options
| author | Sean Whitton <spwhitton@spwhitton.name> | 2022-11-11 23:32:12 -0700 |
|---|---|---|
| committer | Sean Whitton <spwhitton@spwhitton.name> | 2022-11-12 11:23:53 -0700 |
| commit | f223f38fcab3c94402603d1fadb2d6fa0ac3d05a (patch) | |
| tree | 8036d67f8e96d335368d8b1ff19d3c98770fd754 /archive | |
| parent | 74585ec4711667c76ecdad7eb53590cb912501ba (diff) | |
| download | dotfiles-f223f38fcab3c94402603d1fadb2d6fa0ac3d05a.tar.gz | |
GNU Stow -> hstow, and follow-up tidying & simplifications
Diffstat (limited to 'archive')
| -rw-r--r-- | archive/Rexfile | 2 | ||||
| -rwxr-xr-x | archive/bin/apple-setup.sh | 2 | ||||
| -rwxr-xr-x | archive/bin/chkstow | 113 | ||||
| -rwxr-xr-x | archive/bin/stow | 665 | ||||
| -rw-r--r-- | archive/lib-src/mr/stow | 273 | ||||
| -rw-r--r-- | archive/perl5/Stow.pm | 2110 | ||||
| -rw-r--r-- | archive/perl5/Stow/Util.pm | 208 |
7 files changed, 3371 insertions, 2 deletions
diff --git a/archive/Rexfile b/archive/Rexfile index 00bebe09..cd523e76 100644 --- a/archive/Rexfile +++ b/archive/Rexfile @@ -126,7 +126,7 @@ task "dotfiles" => sub { die "unimplemented"; } - run "~/src/dotfiles/bin/bstraph.sh"; + run "~/src/dotfiles/bin/bstraph"; }; 1; diff --git a/archive/bin/apple-setup.sh b/archive/bin/apple-setup.sh index 71101fc2..21f382f1 100755 --- a/archive/bin/apple-setup.sh +++ b/archive/bin/apple-setup.sh @@ -54,7 +54,7 @@ if ! [ -d "$HOME/src/dotfiles/.git" ]; then git clone https://git.spwhitton.name/dotfiles $HOME/src/dotfiles # this is currently out of action because GNU stow installs but # doesn't seem to actually do anything on Mac OS - # $HOME/src/dotfiles/bin/bstraph.sh + # $HOME/src/dotfiles/bin/bstraph cp $HOME/src/dotfiles/{.zshrc,.shenv} $HOME # instead fi pkill firefox diff --git a/archive/bin/chkstow b/archive/bin/chkstow new file mode 100755 index 00000000..a74d1b90 --- /dev/null +++ b/archive/bin/chkstow @@ -0,0 +1,113 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +require 5.006_001; + +use File::Find; +use Getopt::Long; + +my $DEFAULT_TARGET = '/usr/local/'; + +our $Wanted = \&bad_links; +our %Package = (); +our $Stow_dir = ''; +our $Target = $DEFAULT_TARGET; + +# put the main loop into a block so that tests can load this as a module +if ( not caller() ) { + if (@ARGV == 0) { + usage(); + } + process_options(); + #check_stow($Target, $Wanted); + check_stow(); +} + +sub process_options { + GetOptions( + 'b|badlinks' => sub { $Wanted = \&bad_links }, + 'a|aliens' => sub { $Wanted = \&aliens }, + 'l|list' => sub { $Wanted = \&list }, + 't|target=s' => \$Target, + ) or usage(); + return; +} + +sub usage { + print <<"EOT"; +USAGE: chkstow [options] + +Options: + -t DIR, --target=DIR Set the target directory to DIR + (default is $DEFAULT_TARGET) + -b, --badlinks Report symlinks that point to non-existent files + -a, --aliens Report non-symlinks in the target directory + -l, --list List packages in the target directory + +--badlinks is the default mode. +EOT + exit(0); +} + +sub check_stow { + #my ($Target, $Wanted) = @_; + + my (%options) = ( + wanted => $Wanted, + preprocess => \&skip_dirs, + ); + + find(\%options, $Target); + + if ($Wanted == \&list) { + delete $Package{''}; + delete $Package{'..'}; + + if (keys %Package) { + print map "$_\n", sort(keys %Package); + } + } + return; +} + +sub skip_dirs { + # skip stow source and unstowed targets + if (-e ".stow" || -e ".notstowed" ) { + warn "skipping $File::Find::dir\n"; + return (); + } + else { + return @_; + } +} + +# checking for files that do not link to anything +sub bad_links { + -l && !-e && print "Bogus link: $File::Find::name\n"; +} + +# checking for files that are not owned by stow +sub aliens { + !-l && !-d && print "Unstowed file: $File::Find::name\n"; +} + +# just list the packages in the the target directory +# FIXME: what if the stow dir is not called 'stow'? +sub list { + if (-l) { + $_ = readlink; + s{\A(?:\.\./)+stow/}{}g; + s{/.*}{}g; + $Package{$_} = 1; + } +} + +1; # Hey, it's a module! + +# Local variables: +# mode: perl +# cperl-indent-level: 4 +# End: +# vim: ft=perl diff --git a/archive/bin/stow b/archive/bin/stow new file mode 100755 index 00000000..b94dc88d --- /dev/null +++ b/archive/bin/stow @@ -0,0 +1,665 @@ +#!/usr/bin/env perl + +# GNU Stow - manage the installation of multiple software packages +# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein +# Copyright (C) 2000, 2001 Guillaume Morin +# Copyright (C) 2007 Kahlil Hodgson +# Copyright (C) 2011 Adam Spiers +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, see <http://www.gnu.org/licenses/>. + +=head1 NAME + +stow - software package installation manager + +=head1 SYNOPSIS + +stow [ options ] package ... + +=head1 DESCRIPTION + +This manual page describes GNU Stow 2.2.2, a program for managing +the installation of software packages. This is not the definitive +documentation for stow; for that, see the info manual. + +Stow is a tool for managing the installation of multiple software +packages in the same run-time directory tree. One historical +difficulty of this task has been the need to administer, upgrade, +install, and remove files in independent packages without confusing +them with other files sharing the same filesystem space. For instance, +it is common to install Perl and Emacs in F</usr/local>. When one +does so, one winds up (as of Perl 4.036 and Emacs 19.22) with the +following files in F</usr/local/man/man1>: F<a2p.1>; F<ctags.1>; +F<emacs.1>; F<etags.1>; F<h2ph.1>; F<perl.1>; and F<s2p.1>. Now +suppose it's time to uninstall Perl. Which man pages get removed? +Obviously F<perl.1> is one of them, but it should not be the +administrator's responsibility to memorize the ownership of individual +files by separate packages. + +The approach used by Stow is to install each package into its own +tree, then use symbolic links to make it appear as though the files +are installed in the common tree. Administration can be performed in +the package's private tree in isolation from clutter from other +packages. Stow can then be used to update the symbolic links. The +structure of each private tree should reflect the desired structure in +the common tree; i.e. (in the typical case) there should be a F<bin> +directory containing executables, a F<man/man1> directory containing +section 1 man pages, and so on. + +Stow was inspired by Carnegie Mellon's Depot program, but is +substantially simpler and safer. Whereas Depot required database files +to keep things in sync, Stow stores no extra state between runs, so +there's no danger (as there was in Depot) of mangling directories when +file hierarchies don't match the database. Also unlike Depot, Stow +will never delete any files, directories, or links that appear in a +Stow directory (e.g., F</usr/local/stow/emacs>), so it's always +possible to rebuild the target tree (e.g., F</usr/local>). + +=head1 TERMINOLOGY + +A "package" is a related collection of files and directories that +you wish to administer as a unit -- e.g., Perl or Emacs -- and that +needs to be installed in a particular directory structure -- e.g., +with F<bin>, F<lib>, and F<man> subdirectories. + +A "target directory" is the root of a tree in which one or more +packages wish to B<appear> to be installed. A common, but by no means +the only such location is F</usr/local>. The examples in this manual +page will use F</usr/local> as the target directory. + +A "stow directory" is the root of a tree containing separate +packages in private subtrees. When Stow runs, it uses the current +directory as the default stow directory. The examples in this manual +page will use F</usr/local/stow> as the stow directory, so that +individual packages will be, for example, F</usr/local/stow/perl> and +F</usr/local/stow/emacs>. + +An "installation image" is the layout of files and directories +required by a package, relative to the target directory. Thus, the +installation image for Perl includes: a F<bin> directory containing +F<perl> and F<a2p> (among others); an F<info> directory containing +Texinfo documentation; a F<lib/perl> directory containing Perl +libraries; and a F<man/man1> directory containing man pages. + +A "package directory" is the root of a tree containing the +installation image for a particular package. Each package directory +must reside in a stow directory -- e.g., the package directory +F</usr/local/stow/perl> must reside in the stow directory +F</usr/local/stow>. The "name" of a package is the name of its +directory within the stow directory -- e.g., F<perl>. + +Thus, the Perl executable might reside in +F</usr/local/stow/perl/bin/perl>, where F</usr/local> is the target +directory, F</usr/local/stow> is the stow directory, +F</usr/local/stow/perl> is the package directory, and F<bin/perl> +within is part of the installation image. + +A "symlink" is a symbolic link. A symlink can be "relative" or +"absolute". An absolute symlink names a full path; that is, one +starting from F</>. A relative symlink names a relative path; that +is, one not starting from F</>. The target of a relative symlink is +computed starting from the symlink's own directory. Stow only creates +relative symlinks. + +=head1 OPTIONS + +The stow directory is assumed to be the value of the C<STOW_DIR> +environment variable or if unset the current directory, and the target +directory is assumed to be the parent of the current directory (so it +is typical to execute F<stow> from the directory F</usr/local/stow>). +Each F<package> given on the command line is the name of a package in +the stow directory (e.g., F<perl>). By default, they are installed +into the target directory (but they can be deleted instead using +C<-D>). + +=over 4 + +=item -n + +=item --no + +Do not perform any operations that modify the filesystem; merely show +what would happen. + +=item -d DIR + +=item --dir=DIR + +Set the stow directory to C<DIR> instead of the current directory. +This also has the effect of making the default target directory be the +parent of C<DIR>. + +=item -t DIR + +=item --target=DIR + +Set the target directory to C<DIR> instead of the parent of the stow +directory. + +=item -v + +=item --verbose[=N] + +Send verbose output to standard error describing what Stow is +doing. Verbosity levels are 0, 1, 2, 3, and 4; 0 is the default. +Using C<-v> or C<--verbose> increases the verbosity by one; using +`--verbose=N' sets it to N. + +=item -S + +=item --stow + +Stow the packages that follow this option into the target directory. +This is the default action and so can be omitted if you are only +stowing packages rather than performing a mixture of +stow/delete/restow actions. + +=item -D + +=item --delete + +Unstow the packages that follow this option from the target directory rather +than installing them. + +=item -R + +=item --restow + +Restow packages (first unstow, then stow again). This is useful +for pruning obsolete symlinks from the target tree after updating +the software in a package. + +=item --adopt + +B<Warning!> This behaviour is specifically intended to alter the +contents of your stow directory. If you do not want that, this option +is not for you. + +When stowing, if a target is encountered which already exists but is a +plain file (and hence not owned by any existing stow package), then +normally Stow will register this as a conflict and refuse to proceed. +This option changes that behaviour so that the file is moved to the +same relative place within the package's installation image within the +stow directory, and then stowing proceeds as before. So effectively, +the file becomes adopted by the stow package, without its contents +changing. + +=item --no-folding + +Disable folding of newly stowed directories when stowing, and +refolding of newly foldable directories when unstowing. + +=item --ignore=REGEX + +Ignore files ending in this Perl regex. + +=item --defer=REGEX + +Don't stow files beginning with this Perl regex if the file is already +stowed to another package. + +=item --override=REGEX + +Force stowing files beginning with this Perl regex if the file is +already stowed to another package. + +=item -V + +=item --version + +Show Stow version number, and exit. + +=item -h + +=item --help + +Show Stow command syntax, and exit. + +=back + +=head1 INSTALLING PACKAGES + +The default action of Stow is to install a package. This means +creating symlinks in the target tree that point into the package tree. +Stow attempts to do this with as few symlinks as possible; in other +words, if Stow can create a single symlink that points to an entire +subtree within the package tree, it will choose to do that rather than +create a directory in the target tree and populate it with symlinks. + +For example, suppose that no packages have yet been installed in +F</usr/local>; it's completely empty (except for the F<stow> +subdirectory, of course). Now suppose the Perl package is installed. +Recall that it includes the following directories in its installation +image: F<bin>; F<info>; F<lib/perl>; F<man/man1>. Rather than +creating the directory F</usr/local/bin> and populating it with +symlinks to F<../stow/perl/bin/perl> and F<../stow/perl/bin/a2p> (and +so on), Stow will create a single symlink, F</usr/local/bin>, which +points to F<stow/perl/bin>. In this way, it still works to refer to +F</usr/local/bin/perl> and F</usr/local/bin/a2p>, and fewer symlinks +have been created. This is called "tree folding", since an entire +subtree is "folded" into a single symlink. + +To complete this example, Stow will also create the symlink +F</usr/local/info> pointing to F<stow/perl/info>; the symlink +F</usr/local/lib> pointing to F<stow/perl/lib>; and the symlink +F</usr/local/man> pointing to F<stow/perl/man>. + +Now suppose that instead of installing the Perl package into an empty +target tree, the target tree is not empty to begin with. Instead, it +contains several files and directories installed under a different +system-administration philosophy. In particular, F</usr/local/bin> +already exists and is a directory, as are F</usr/local/lib> and +F</usr/local/man/man1>. In this case, Stow will descend into +F</usr/local/bin> and create symlinks to F<../stow/perl/bin/perl> and +F<../stow/perl/bin/a2p> (etc.), and it will descend into +F</usr/local/lib> and create the tree-folding symlink F<perl> pointing +to F<../stow/perl/lib/perl>, and so on. As a rule, Stow only descends +as far as necessary into the target tree when it can create a +tree-folding symlink. + +The time often comes when a tree-folding symlink has to be undone +because another package uses one or more of the folded subdirectories +in its installation image. This operation is called "splitting open" +a folded tree. It involves removing the original symlink from the +target tree, creating a true directory in its place, and then +populating the new directory with symlinks to the newly-installed +package B<and> to the old package that used the old symlink. For +example, suppose that after installing Perl into an empty +F</usr/local>, we wish to install Emacs. Emacs's installation image +includes a F<bin> directory containing the F<emacs> and F<etags> +executables, among others. Stow must make these files appear to be +installed in F</usr/local/bin>, but presently F</usr/local/bin> is a +symlink to F<stow/perl/bin>. Stow therefore takes the following +steps: the symlink F</usr/local/bin> is deleted; the directory +F</usr/local/bin> is created; links are made from F</usr/local/bin> to +F<../stow/emacs/bin/emacs> and F<../stow/emacs/bin/etags>; and links +are made from F</usr/local/bin> to F<../stow/perl/bin/perl> and +F<../stow/perl/bin/a2p>. + +When splitting open a folded tree, Stow makes sure that the symlink +it is about to remove points inside a valid package in the current stow +directory. + +=head2 Stow will never delete anything that it doesn't own. + +Stow "owns" everything living in the target tree that points into a +package in the stow directory. Anything Stow owns, it can recompute if +lost. Note that by this definition, Stow doesn't "own" anything +B<in> the stow directory or in any of the packages. + +If Stow needs to create a directory or a symlink in the target tree +and it cannot because that name is already in use and is not owned by +Stow, then a conflict has arisen. See the "Conflicts" section in the +info manual. + +=head1 DELETING PACKAGES + +When the C<-D> option is given, the action of Stow is to delete a +package from the target tree. Note that Stow will not delete anything +it doesn't "own". Deleting a package does B<not> mean removing it from +the stow directory or discarding the package tree. + +To delete a package, Stow recursively scans the target tree, skipping +over the stow directory (since that is usually a subdirectory of the +target tree) and any other stow directories it encounters (see +"Multiple stow directories" in the info manual). Any symlink it +finds that points into the package being deleted is removed. Any +directory that contained only symlinks to the package being deleted is +removed. Any directory that, after removing symlinks and empty +subdirectories, contains only symlinks to a single other package, is +considered to be a previously "folded" tree that was "split open." +Stow will re-fold the tree by removing the symlinks to the surviving +package, removing the directory, then linking the directory back to +the surviving package. + +=head1 SEE ALSO + +The full documentation for F<stow> is maintained as a Texinfo manual. +If the F<info> and F<stow> programs are properly installed at your site, the command + + info stow + +should give you access to the complete manual. + +=head1 BUGS + +Please report bugs in Stow using the Debian bug tracking system. + +Currently known bugs include: + +=over 4 + +=item * The empty-directory problem. + +If package F<foo> includes an empty directory -- say, F<foo/bar> -- +then if no other package has a F<bar> subdirectory, everything's fine. +If another stowed package F<quux>, has a F<bar> subdirectory, then +when stowing, F<targetdir/bar> will be "split open" and the contents +of F<quux/bar> will be individually stowed. So far, so good. But when +unstowing F<quux>, F<targetdir/bar> will be removed, even though +F<foo/bar> needs it to remain. A workaround for this problem is to +create a file in F<foo/bar> as a placeholder. If you name that file +F<.placeholder>, it will be easy to find and remove such files when +this bug is fixed. + +=item * + +When using multiple stow directories (see "Multiple stow directories" +in the info manual), Stow fails to "split open" tree-folding symlinks +(see "Installing packages" in the info manual) that point into a stow +directory which is not the one in use by the current Stow +command. Before failing, it should search the target of the link to +see whether any element of the path contains a F<.stow> file. If it +finds one, it can "learn" about the cooperating stow directory to +short-circuit the F<.stow> search the next time it encounters a +tree-folding symlink. + +=back + +=head1 AUTHOR + +This man page was originally constructed by Charles Briscoe-Smith from +parts of Stow's info manual, and then converted to POD format by Adam +Spiers. The info manual contains the following notice, which, as it +says, applies to this manual page, too. The text of the section +entitled "GNU General Public License" can be found in the file +F</usr/share/common-licenses/GPL> on any Debian GNU/Linux system. If +you don't have access to a Debian system, or the GPL is not there, +write to the Free Software Foundation, Inc., 59 Temple Place, Suite +330, Boston, MA, 02111-1307, USA. + +=head1 COPYRIGHT + +Copyright (C) +1993, 1994, 1995, 1996 by Bob Glickstein <bobg+stow@zanshin.com>; +2000, 2001 by Guillaume Morin; +2007 by Kahlil Hodgson; +2011 by Adam Spiers; +and others. + +Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided also that +the section entitled "GNU General Public License" is included with the +modified manual, and provided that the entire resulting derived work +is distributed under the terms of a permission notice identical to +this one. + +Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be stated in a +translation approved by the Free Software Foundation. + +=cut + +use strict; +use warnings; + +require 5.006_001; + +use POSIX qw(getcwd); +use Getopt::Long; + +use lib "$ENV{HOME}/src/dotfiles/perl5"; +use Stow; +use Stow::Util qw(parent error); + +my $ProgramName = $0; +$ProgramName =~ s{.*/}{}; + +main() unless caller(); + +sub main { + my ($options, $pkgs_to_unstow, $pkgs_to_stow) = process_options(); + + my $stow = new Stow(%$options); + # current dir is now the target directory + + $stow->plan_unstow(@$pkgs_to_unstow); + $stow->plan_stow (@$pkgs_to_stow); + + my %conflicts = $stow->get_conflicts; + + if (%conflicts) { + foreach my $action ('unstow', 'stow') { + next unless $conflicts{$action}; + foreach my $package (sort keys %{ $conflicts{$action} }) { + warn "WARNING! ${action}ing $package would cause conflicts:\n"; + #if $stow->get_action_count > 1; + foreach my $message (sort @{ $conflicts{$action}{$package} }) { + warn " * $message\n"; + } + } + } + warn "All operations aborted.\n"; + exit 1; + } + else { + if ($options->{simulate}) { + warn "WARNING: in simulation mode so not modifying filesystem.\n"; + return; + } + + $stow->process_tasks(); + } +} + + +#===== SUBROUTINE =========================================================== +# Name : process_options() +# Purpose : parse command line options +# Parameters: none +# Returns : (\%options, \@pkgs_to_unstow, \@pkgs_to_stow) +# Throws : a fatal error if a bad command line option is given +# Comments : checks @ARGV for valid package names +#============================================================================ +sub process_options { + my %options = (); + my @pkgs_to_unstow = (); + my @pkgs_to_stow = (); + my $action = 'stow'; + + unshift @ARGV, get_config_file_options(); + #$,="\n"; print @ARGV,"\n"; # for debugging rc file + + Getopt::Long::config('no_ignore_case', 'bundling', 'permute'); + GetOptions( + \%options, + 'verbose|v:+', 'help|h', 'simulate|n|no', + 'version|V', 'compat|p', 'dir|d=s', 'target|t=s', + 'adopt', 'no-folding', + + # clean and pre-compile any regex's at parse time + 'ignore=s' => + sub { + my $regex = $_[1]; + push @{$options{ignore}}, qr($regex\z); + }, + + 'override=s' => + sub { + my $regex = $_[1]; + push @{$options{override}}, qr(\A$regex); + }, + + 'defer=s' => + sub { + my $regex = $_[1]; + push @{$options{defer}}, qr(\A$regex); + }, + + # a little craziness so we can do different actions on the same line: + # a -D, -S, or -R changes the action that will be performed on the + # package arguments that follow it. + 'D|delete' => sub { $action = 'unstow' }, + 'S|stow' => sub { $action = 'stow' }, + 'R|restow' => sub { $action = 'restow' }, + + # Handler for non-option arguments + '<>' => + sub { + if ($action eq 'restow') { + push @pkgs_to_unstow, $_[0]; + push @pkgs_to_stow, $_[0]; + } + elsif ($action eq 'unstow') { + push @pkgs_to_unstow, $_[0]; + } + else { + push @pkgs_to_stow, $_[0]; + } + }, + ) or usage(); + + usage() if $options{help}; + version() if $options{version}; + + sanitize_path_options(\%options); + check_packages(\@pkgs_to_unstow, \@pkgs_to_stow); + + return (\%options, \@pkgs_to_unstow, \@pkgs_to_stow); +} + +sub sanitize_path_options { + my ($options) = @_; + + if (exists $options->{dir}) { + $options->{dir} =~ s/\A +//; + $options->{dir} =~ s/ +\z//; + } + else { + $options->{dir} = exists $ENV{STOW_DIR} ? $ENV{STOW_DIR} : getcwd(); + } + + if (exists $options->{target}) { + $options->{target} =~ s/\A +//; + $options->{target} =~ s/ +\z//; + } + else { + $options->{target} = parent($options->{dir}) || '.'; + } +} + +sub check_packages { + my ($pkgs_to_stow, $pkgs_to_unstow) = @_; + + if (not @$pkgs_to_stow and not @$pkgs_to_unstow) { + usage("No packages to stow or unstow"); + } + + # check package arguments + for my $package (@$pkgs_to_stow, @$pkgs_to_unstow) { + $package =~ s{/+$}{}; # delete trailing slashes + if ($package =~ m{/}) { + error("Slashes are not permitted in package names"); + } + } +} + + +#===== SUBROUTINE ============================================================ +# Name : get_config_file_options() +# Purpose : search for default settings in any .stowrc files +# Parameters: none +# Returns : a list of default options +# Throws : no exceptions +# Comments : prepends the contents of '~/.stowrc' and '.stowrc' to the command +# : line so they get parsed just like normal arguments. (This was +# : hacked in so that Emil and I could set different preferences). +#============================================================================= +sub get_config_file_options { + my @defaults = (); + for my $file ("$ENV{HOME}/.stowrc", '.stowrc') { + if (-r $file) { + warn "Loading defaults from $file\n"; + open my $FILE, '<', $file + or die "Could not open $file for reading\n"; + while (my $line = <$FILE>){ + chomp $line; + push @defaults, split " ", $line; + } + close $FILE or die "Could not close open file: $file\n"; + } + } + return @defaults; +} + +#===== SUBROUTINE =========================================================== +# Name : usage() +# Purpose : print program usage message and exit +# Parameters: $msg => string to prepend to the usage message +# Returns : n/a +# Throws : n/a +# Comments : if 'msg' is given, then exit with non-zero status +#============================================================================ +sub usage { + my ($msg) = @_; + + if ($msg) { + print "$ProgramName: $msg\n\n"; + } + + print <<"EOT"; +$ProgramName (GNU Stow) version $Stow::VERSION + +SYNOPSIS: + + $ProgramName [OPTION ...] [-D|-S|-R] PACKAGE ... [-D|-S|-R] PACKAGE ... + +OPTIONS: + + -d DIR, --dir=DIR Set stow dir to DIR (default is current dir) + -t DIR, --target=DIR Set target to DIR (default is parent of stow dir) + + -S, --stow Stow the package names that follow this option + -D, --delete Unstow the package names that follow this option + -R, --restow Restow (like stow -D followed by stow -S) + + --ignore=REGEX Ignore files ending in this Perl regex + --defer=REGEX Don't stow files beginning with this Perl regex + if the file is already stowed to another package + --override=REGEX Force stowing files beginning with this Perl regex + if the file is already stowed to another package + --adopt (Use with care!) Import existing files into stow package + from target. Please read docs before using. + -p, --compat Use legacy algorithm for unstowing + + -n, --no, --simulate Do not actually make any filesystem changes + -v, --verbose[=N] Increase verbosity (levels are 0,1,2,3; + -v or --verbose adds 1; --verbose=N sets level) + -V, --version Show stow version number + -h, --help Show this help + +Report bugs to: bug-stow\@gnu.org +Stow home page: <http://www.gnu.org/software/stow/> +General help using GNU software: <http://www.gnu.org/gethelp/> +EOT + exit defined $msg ? 1 : 0; +} + +sub version { + print "$ProgramName (GNU Stow) version $Stow::VERSION\n"; + exit 0; +} + +1; # This file is required by t/stow.t + +# Local variables: +# mode: perl +# cperl-indent-level: 4 +# end: +# vim: ft=perl diff --git a/archive/lib-src/mr/stow b/archive/lib-src/mr/stow new file mode 100644 index 00000000..254bd0c3 --- /dev/null +++ b/archive/lib-src/mr/stow @@ -0,0 +1,273 @@ +# Plug-in to use GNU Stow to manage symlinks whose targets lie in a +# repository managed with myrepos +# +# The standard use case is for managing dotfiles inside one's home +# directory. +# +# Original author (2011): +# Adam Spiers <mr@adamspiers.org> +# +# This version reworked (2016, 2017) & maintained (2017) by: +# Sean Whitton <spwhitton@spwhitton.name> + +# BASIC USAGE INSTRUCTIONS +# +# To make mr use this file, add a line like this inside the [DEFAULT] +# section of your ~/.mrconfig: +# +# include = cat /usr/share/mr/stow +# +# and then inside each [repo] section of your ~/.mrconfig for +# which you want the contents to be stowed, add this line: +# +# stowable = true +# +# You must have at least version 2.1.0 of stow available. [1] +# +# If stow is not in your $PATH, you can export STOW_COMMAND to tell +# this plug-in where it is. +# +# The default behaviour is to stow on checkout, and restow on update. +# The manual actions 'stow', 'restow', 'unstow' and 'adopt' are also +# available. +# +# By default, ~/.STOW is used as the stow directory, and ~ as the +# target directory. You can export STOW_DIR and STOW_TARGET to +# override these defaults. +# +# DEALING WITH APPLICATIONS THAT MISTREAT SYMLINKS +# +# Some programs will replace a symlink to a stowed file with a regular +# copy of the file, and a subset of these will do this even if they +# haven't edited the file. This will cause stow operations to fail. +# +# To deal with this, run 'mr adopt'. This will move the modified file +# into your repository, and restore the usual symlink. Then you can +# use your VCS tools ('git diff', 'hg diff') to decide whether you +# want to keep the changes. +# +# FOLDING +# +# By default, this library passes --no-folding to stow. This allows +# you to have more than one repository stowing files into a single +# subdirectory in your home directory. For example, you might have a +# private and a public repository both stowing into ~/.gnupg. If you +# don't want this behaviour, set MR_FOLD. For example, in a +# repository's myrepos config section or in [DEFAULT]: +# +# lib = MR_FOLD= +# +# FIXUPS THAT CREATE FILES TO BE STOWED +# +# Stowing is automatically performed via post_checkout, and restowing +# via post_update, as can be seen from below (search for 'Automatic +# actions'). Note that these run before fixups, which allows fixups +# to refer to stowed files, but isn't ideal if the fixups are +# responsible for creating the stow package's installation image, +# e.g. via a typical './configure && make install' sequence. Here's a +# suggested mrconfig chunk to handle this particular use case: +# +# stowable = true +# lib = +# STOW_PKG_TYPE=directory +# STOW_NO_AUTOMATIC_ACTIONS=yes +# mr_pre_unstow () { +# install-info --delete --info-dir=$HOME/share/info $STOW_PKG_PATH/share/info/*.info +# } +# mr_post_stow () { +# install-info --info-dir=$HOME/share/info $STOW_PKG_PATH/share/info/*.info +# } +# fixups = +# if ! [ -e configure ]; then +# bash ./autogen.sh +# fi +# set_stow_common_opts +# ./configure --prefix=$STOW_PKG_PATH +# make install prefix=$STOW_PKG_PATH +# rm $STOW_PKG_PATH/share/info/dir +# mr_restow_regardless +# +# [1] Older versions could create a frankenstein ~/.git/ directory +# containing symlinks to multiple .git/ sub-directories in different +# stow packages! 2.1.0 onwards does not have this problem - it +# supports local per-directory .stow-local-ignore and global +# ~/.stow-global-ignore files, and even without configuration of +# these, it chooses sensible default ignore lists which prevent +# stowing of a package's .git/ sub-directory. These ignore lists are +# also ideal if you only want to stow a subset of a stow package's +# contents. + +lib = + : ${STOW_DIR:=$HOME/.STOW} + : ${STOW_TARGET:=$HOME} + STOW_NAME=$(echo "$MR_REPO" | tr / _) + # + if ! [ -d "$STOW_TARGET" ]; then mkdir -p "$STOW_TARGET"; fi + if ! [ -d "$STOW_DIR" ]; then mkdir -p "$STOW_DIR" ; fi + if ! [ -f "$STOW_DIR/.stow" ]; then touch "$STOW_DIR/.stow"; fi + # + #MR_STOWABLE=no + is_stowable () { + [ -z "$MR_DISABLE_STOW" ] && + ( cd "$MR_REPO" && mr stowable >/dev/null 2>&1 ) + #[ "$MR_STOWABLE" = yes ] + } + stowable_then_continue () { + if is_stowable; then + return 0 + else + if [ -n "$1" ]; then + info "$STOW_NAME isn't stowable; skipping $MR_ACTION" + fi + return 1 + fi + } + # + set_stow_common_opts () { + : ${STOW_PKG_TYPE:=symlink} + STOW_PKG_PATH="$STOW_DIR/$STOW_NAME" + # canonicalise -t and -d params with readlink if available + # stow can fail if they aren't canonical + if which readlink >/dev/null 2>&1; then + stow_common_opts="-t $(readlink -f $STOW_TARGET) -d $(readlink -f $STOW_DIR)" + else + stow_common_opts="-t $STOW_TARGET -d $STOW_DIR" + fi + STOW="${STOW_COMMAND:-$HOME/src/dotfiles/lib-src/stow/stow}" + case "`$STOW --version`" in + 'version 1.*') + stow_common_opts="$stow_common_opts -p" + ;; + *) + ;; + esac + if [ -n "$MR_STOW_OPTIONS" ]; then + stow_common_opts="$stow_common_opts $MR_STOW_OPTIONS" + fi + if [ -n "$MR_STOW_OVER" ]; then + stow_common_opts="$stow_common_opts --override=$MR_STOW_OVER" + fi + if ! (: "${MR_FOLD?}") 2>/dev/null; then + stow_common_opts="$stow_common_opts --no-folding" + fi + } + # + mr_stow () { + stowable_then_continue || return 0 + set_stow_common_opts + ensure_package_exists + command "$STOW" $stow_common_opts "$@" "$STOW_NAME" + mr_post_stow + info "Stowed $STOW_NAME" + } + mr_restow_if_already_stowed () { + stowable_then_continue || return 0 + if ! [ -L "$STOW_PKG_PATH" ]; then + info "$MR_REPO wasn't stowed yet; won't restow." + return + fi + mr_restow_regardless "$@" + } + mr_restow_regardless () { + stowable_then_continue || return 0 + set_stow_common_opts + ensure_package_exists + mr_pre_unstow + command "$STOW" -R $stow_common_opts "$@" "$STOW_NAME" + mr_post_stow + info "Restowed $STOW_NAME" + } + mr_pre_unstow () { + : # This can be "overridden" by the lib section of a repo definition + #info "no mr_pre_unstow hook" + } + mr_post_stow () { + : # This can be "overridden" by the lib section of a repo definition + #info "no mr_post_stow hook" + } + mr_unstow () { + stowable_then_continue || return 0 + set_stow_common_opts + if ! [ -d "$STOW_PKG_PATH" ]; then + info "$MR_REPO wasn't stowed yet in $STOW_PKG_PATH; can't unstow." + return + fi + mr_pre_unstow + command "$STOW" -D $stow_common_opts "$@" "$STOW_NAME" + if [ "$STOW_PKG_TYPE" = 'symlink' ]; then + rm -f "$STOW_PKG_PATH" + fi + info "Unstowed $STOW_NAME" + } + # + ensure_symlink_exists () { + [ $# = 2 ] || error "CONFIG BUG: Usage: ensure_symlink_exists SYMLINK TARGET" + symlink="$1" + required_target="$2" + if [ -L "$symlink" ]; then + actual_target="`readlink $symlink`" + if [ "$actual_target" = "$required_target" ]; then + return + else + error "Symlink $symlink already points to $actual_target, cannot point to $required_target; aborting." + fi + fi + if [ -e "$symlink" ]; then + error "Cannot create symlink $symlink - already exists; aborting." + fi + ln -s "$required_target" "$symlink" + } + # + mr_adopt () { + stowable_then_continue || return 0 + set_stow_common_opts + ensure_package_exists + mr_pre_unstow + command "$STOW" --adopt $stow_common_opts "$@" "$STOW_NAME" + mr_post_stow + info "Stowed $STOW_NAME with adoption" + } + # + ensure_package_exists () { + case "$STOW_PKG_TYPE" in + symlink) + ensure_symlink_exists "$STOW_PKG_PATH" "$MR_REPO" + ;; + directory) + [ -e "$STOW_PKG_PATH" ] || mkdir "$STOW_PKG_PATH" + [ -d "$STOW_PKG_PATH" ] || error "Expected $STOW_PKG_PATH to be a directory; aborting." + if [ -L "$STOW_PKG_PATH" ]; then + error "Didn't expect $STOW_PKG_PATH to be a symlink; aborting." + fi + ;; + *) + error "Unrecognised value '$STOW_PKG_TYPE' for \$STOW_PKG_TYPE; aborting." + ;; + esac + } + +#stowable = is_stowable +stowable = false +showstowable = + if is_stowable; then + echo "$STOW_NAME is stowable" + else + echo "$STOW_NAME is not stowable" + fi + +# Automatic actions +post_checkout_append = [ -n "$STOW_NO_AUTOMATIC_ACTIONS" ] || mr_stow +#post_update_append = mr_restow_if_already_stowed +post_update_append = [ -n "$STOW_NO_AUTOMATIC_ACTIONS" ] || mr_restow_regardless + +# Manual actions +stow = mr_stow "$@" +stowover = MR_STOW_OVER=. mr_stow "$@" +unstow = mr_unstow "$@" +restow = mr_restow_regardless "$@" +restowover = MR_STOW_OVER=. mr_restow_regardless "$@" +adopt = mr_adopt "$@" + +# Local variables: +# mode: sh +# End: diff --git a/archive/perl5/Stow.pm b/archive/perl5/Stow.pm new file mode 100644 index 00000000..bda7d3ab --- /dev/null +++ b/archive/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/archive/perl5/Stow/Util.pm b/archive/perl5/Stow/Util.pm new file mode 100644 index 00000000..c22d7b87 --- /dev/null +++ b/archive/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 |