From f223f38fcab3c94402603d1fadb2d6fa0ac3d05a Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Fri, 11 Nov 2022 23:32:12 -0700 Subject: GNU Stow -> hstow, and follow-up tidying & simplifications --- .bash_defns | 10 - .hstow-always-adopt | 1 + .hstow-local-ignore | 11 + .stow-local-ignore | 14 - Downloads | 1 + README | 6 +- archive/Rexfile | 2 +- archive/bin/apple-setup.sh | 2 +- archive/bin/chkstow | 113 +++ archive/bin/stow | 665 +++++++++++++ archive/lib-src/mr/stow | 273 ++++++ archive/perl5/Stow.pm | 2110 ++++++++++++++++++++++++++++++++++++++++ archive/perl5/Stow/Util.pm | 208 ++++ bin/bstraph | 78 ++ bin/bstraph.sh | 27 - bin/git-dotfiles-update-master | 6 - bin/hstow | 172 ++++ bin/insinuate-dotfiles | 2 +- bin/unskel | 25 - lib-src/mr/config | 175 +--- lib-src/mr/stow | 273 ------ lib-src/stow/chkstow | 113 --- lib-src/stow/stow | 665 ------------- perl5/Local/MrRepo/Repo.pm | 2 +- perl5/Stow.pm | 2110 ---------------------------------------- perl5/Stow/Util.pm | 208 ---- 26 files changed, 3664 insertions(+), 3608 deletions(-) create mode 100644 .hstow-always-adopt create mode 100644 .hstow-local-ignore delete mode 100644 .stow-local-ignore create mode 120000 Downloads create mode 100755 archive/bin/chkstow create mode 100755 archive/bin/stow create mode 100644 archive/lib-src/mr/stow create mode 100644 archive/perl5/Stow.pm create mode 100644 archive/perl5/Stow/Util.pm create mode 100755 bin/bstraph delete mode 100755 bin/bstraph.sh create mode 100755 bin/hstow delete mode 100755 bin/unskel delete mode 100644 lib-src/mr/stow delete mode 100755 lib-src/stow/chkstow delete mode 100755 lib-src/stow/stow delete mode 100644 perl5/Stow.pm delete mode 100644 perl5/Stow/Util.pm diff --git a/.bash_defns b/.bash_defns index 76a76097..d1a994d7 100644 --- a/.bash_defns +++ b/.bash_defns @@ -50,16 +50,6 @@ package-plan-unpack () { ~/src/dotfiles/scripts/debian/package-plan-unpack "$1"; cd "/tmp/$1" } -# tidy up if I deleted files from stowed repos without properly -# restowing -kill-broken-stowed-symlinks () { - find "$HOME" -xtype l | while read -r link; do - if readlink "$link" | grep --quiet "^[../]*/.STOW/"; then - rm "$link" - fi - done -} - # install package(s) and immediately mark as auto installed, so it # will get cleaned up by the next autoclean. # --no-install-recommends is needed as otherwise packages are manually diff --git a/.hstow-always-adopt b/.hstow-always-adopt new file mode 100644 index 00000000..a75cc276 --- /dev/null +++ b/.hstow-always-adopt @@ -0,0 +1 @@ +.config/mimeapps.list diff --git a/.hstow-local-ignore b/.hstow-local-ignore new file mode 100644 index 00000000..c2f6b18e --- /dev/null +++ b/.hstow-local-ignore @@ -0,0 +1,11 @@ +archive/* +bin/* +hooks/* +lib-src/* +perl5/* +scripts/* + +GTAGS +GRTAGS +GPATH +README diff --git a/.stow-local-ignore b/.stow-local-ignore deleted file mode 100644 index 769c716d..00000000 --- a/.stow-local-ignore +++ /dev/null @@ -1,14 +0,0 @@ -^/archive -^/bin -^/hooks -^/lib-src -^/perl5 -^/scripts - -^/\.git -^/\.gitignore - -^/GTAGS -^/GRTAGS -^/GPATH -^/README diff --git a/Downloads b/Downloads new file mode 120000 index 00000000..f1fde8c1 --- /dev/null +++ b/Downloads @@ -0,0 +1 @@ +../../tmp \ No newline at end of file diff --git a/README b/README index 7d4998f0..387a994d 100644 --- a/README +++ b/README @@ -30,13 +30,13 @@ cloning this repo into HOME on arbitrary machines less intrusive. Minimal system requirements ================================ -git; Perl 5/7; POSIX.2 shell and utilities +POSIX.2 shell and utilities ================================ Recommended pre-installed extras ================================ -Git::Wrapper +git; Perl 5/7; Git::Wrapper ================================ Minimal setup @@ -48,4 +48,4 @@ Git::Wrapper 2. Run bootstrap script: - % $HOME/src/dotfiles/bin/bstraph.sh + % $HOME/src/dotfiles/bin/bstraph 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 . + +=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. When one +does so, one winds up (as of Perl 4.036 and Emacs 19.22) with the +following files in F: F; F; +F; F; F; F; and F. Now +suppose it's time to uninstall Perl. Which man pages get removed? +Obviously F 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 +directory containing executables, a F 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), so it's always +possible to rebuild the target tree (e.g., F). + +=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, F, and F subdirectories. + +A "target directory" is the root of a tree in which one or more +packages wish to B to be installed. A common, but by no means +the only such location is F. The examples in this manual +page will use F 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 as the stow directory, so that +individual packages will be, for example, F and +F. + +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 directory containing +F and F (among others); an F directory containing +Texinfo documentation; a F directory containing Perl +libraries; and a F 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 must reside in the stow directory +F. The "name" of a package is the name of its +directory within the stow directory -- e.g., F. + +Thus, the Perl executable might reside in +F, where F is the target +directory, F is the stow directory, +F is the package directory, and F +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 +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 from the directory F). +Each F given on the command line is the name of a package in +the stow directory (e.g., F). 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 instead of the current directory. +This also has the effect of making the default target directory be the +parent of C. + +=item -t DIR + +=item --target=DIR + +Set the target directory to C 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 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; it's completely empty (except for the F +subdirectory, of course). Now suppose the Perl package is installed. +Recall that it includes the following directories in its installation +image: F; F; F; F. Rather than +creating the directory F 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, which +points to F. In this way, it still works to refer to +F and F, 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 pointing to F; the symlink +F pointing to F; and the symlink +F pointing to F. + +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 +already exists and is a directory, as are F and +F. In this case, Stow will descend into +F and create symlinks to F<../stow/perl/bin/perl> and +F<../stow/perl/bin/a2p> (etc.), and it will descend into +F and create the tree-folding symlink F 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 to the old package that used the old symlink. For +example, suppose that after installing Perl into an empty +F, we wish to install Emacs. Emacs's installation image +includes a F directory containing the F and F +executables, among others. Stow must make these files appear to be +installed in F, but presently F is a +symlink to F. Stow therefore takes the following +steps: the symlink F is deleted; the directory +F is created; links are made from F to +F<../stow/emacs/bin/emacs> and F<../stow/emacs/bin/etags>; and links +are made from F 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 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 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 is maintained as a Texinfo manual. +If the F and F 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 includes an empty directory -- say, F -- +then if no other package has a F subdirectory, everything's fine. +If another stowed package F, has a F subdirectory, then +when stowing, F will be "split open" and the contents +of F will be individually stowed. So far, so good. But when +unstowing F, F will be removed, even though +F needs it to remain. A workaround for this problem is to +create a file in F 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 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 ; +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: +General help using GNU software: +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 +# +# This version reworked (2016, 2017) & maintained (2017) by: +# Sean Whitton + +# 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 vs. C, for example) +while making them appear to be installed in the same place +(C). + +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 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 parameter passed +to the L 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. + +=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. + +=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 <. + +=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. + +=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 environment variable. + +Verbosity rules: + +=over 4 + +=item 0: errors only + +=item >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR/MV + +=item >= 2: print operation exceptions + +e.g. "_this_ already points to _that_", skipping, deferring, +overriding, fixing invalid links + +=item >= 3: print trace detail: trace: stow/unstow/package/contents/node + +=item >= 4: debug helper routines + +=item >= 5: debug ignore lists + +=back + +=cut + +sub debug { + my ($level, $msg) = @_; + if ($debug_level >= $level) { + if ($test_mode) { + print "# $msg\n"; + } + else { + warn "$msg\n"; + } + } +} + +#===== METHOD =============================================================== +# Name : join_paths() +# Purpose : concatenates given paths +# Parameters: path1, path2, ... => paths +# Returns : concatenation of given paths +# Throws : n/a +# Comments : factors out redundant path elements: +# : '//' => '/' and 'a/b/../c' => 'a/c' +#============================================================================ +sub join_paths { + my @paths = @_; + + # weed out empty components and concatenate + my $result = join '/', grep {! /\A\z/} @paths; + + # factor out back references and remove redundant /'s) + my @result = (); + PART: + for my $part (split m{/+}, $result) { + next PART if $part eq '.'; + if (@result && $part eq '..' && $result[-1] ne '..') { + pop @result; + } + else { + push @result, $part; + } + } + + return join '/', @result; +} + +#===== METHOD =============================================================== +# Name : parent +# Purpose : find the parent of the given path +# Parameters: @path => components of the path +# Returns : returns a path string +# Throws : n/a +# Comments : allows you to send multiple chunks of the path +# : (this feature is currently not used) +#============================================================================ +sub parent { + my @path = @_; + my $path = join '/', @_; + my @elts = split m{/+}, $path; + pop @elts; + return join '/', @elts; +} + +#===== METHOD =============================================================== +# Name : canon_path +# Purpose : find absolute canonical path of given path +# Parameters: $path +# Returns : absolute canonical path +# Throws : n/a +# Comments : is this significantly different from File::Spec->rel2abs? +#============================================================================ +sub canon_path { + my ($path) = @_; + + my $cwd = getcwd(); + chdir($path) or error("canon_path: cannot chdir to $path from $cwd"); + my $canon_path = getcwd(); + restore_cwd($cwd); + + return $canon_path; +} + +sub restore_cwd { + my ($prev) = @_; + chdir($prev) or error("Your current directory $prev seems to have vanished"); +} + +=head1 BUGS + +=head1 SEE ALSO + +=cut + +1; + +# Local variables: +# mode: perl +# cperl-indent-level: 4 +# end: +# vim: ft=perl diff --git a/bin/bstraph b/bin/bstraph new file mode 100755 index 00000000..7d729ff3 --- /dev/null +++ b/bin/bstraph @@ -0,0 +1,78 @@ +#!/bin/sh + +# Bootstrap home directory after dotfiles repository successfully cloned (see +# INSINUATE-DOTFILES Consfigurator property and 'insinuate-dotfiles' script). +# This script should be POSIX sh and idempotent. This is the 'mr fixups' +# action for src/dotfiles, here rather than in src/dotfiles/lib-src/mr/config +# so that we can run it even if we don't have a Perl interpreter. + +set -e + +cd "$HOME/src/dotfiles" + +if [ -d /etc/skel ]; then + cd /etc/skel + for file in $(find . -type f); do + [ -e "$HOME/$file" -a ! -h "$HOME/$file" ] \ + && cmp "$file" "$HOME/$file" >/dev/null && rm "$HOME/$file" + done + cd "$HOME/src/dotfiles" +fi + +# On Debian systems root gets a special .bashrc and .profile. +for f in bashrc profile; do + [ -e /usr/share/base-files/dot.$f \ + -a -e "$HOME/.$f" -a ! -h "$HOME/.$f" ] \ + && cmp /usr/share/base-files/dot.$f "$HOME/.$f" >/dev/null \ + && rm "$HOME/.$f" +done + +# These will often end up created by, e.g., insinuate-dotfiles. +# Remove them so that the initial stow will not involve any conflicts. +for f in gpg.conf gpg-agent.conf dirmngr.conf .gpg-v21-migrated; do + [ -h "$HOME/.gnupg/$f" ] || rm -f "$HOME/.gnupg/$f" +done + +bin/hstow stow . + +if command -v git >/dev/null; then + # Use a rebase workflow as I'm the only committer. + git config pull.rebase true + + git config user.signingkey 8DC2487E51ABDD90B5C4753F0F56D0553B6D411B + + # Pushing and pulling are always done explicitly. + for branch in $(git for-each-ref \ + --format='%(refname:short)' refs/heads/); do + git rev-parse "$branch"@{upstream} >/dev/null 2>&1 \ + && git branch --unset-upstream "$branch" + done + git config push.default nothing + + # This is just for `magit-status'. + git config remote.pushDefault origin + + # Don't set up any tracking branches, or fetch it. + [ -z "$(git remote)" ] \ + && git remote add origin https://git.spwhitton.name/dotfiles + + # Non-POSIX cleanup: eventually drop. + rm -f .git/hooks/post-checkout{,_01gpgsign} + find bin lib/aid lib/backup lib/perl5 lib/hooks lib/athena lib/bins \ + lib/img lib/mr lib/src local/anacron/spool -type d -empty -delete \ + 2>/dev/null ||: + + # Eventually move to 'if ! [ "$MR_ACTION" = fixups ]; then' part, above. + bin/install-git-hooks dotfiles +fi + +cd "$HOME" +[ -e .mrconfig ] || cat >.mrconfig <"$HOME/.mrconfig" </dev/null || true -# done - # Could generalise to a script that reads a git config value for the # fingerprint to look for, updates branches specified by user and is # able to handle updating by both merge and rebase diff --git a/bin/hstow b/bin/hstow new file mode 100755 index 00000000..d151504b --- /dev/null +++ b/bin/hstow @@ -0,0 +1,172 @@ +#!/bin/sh + +# hstow -- POSIX sh minimal reimplementation of GNU Stow for dotfiles +# +# Copyright (C) 2022 Sean Whitton +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or (at +# your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# The point of this script is to obtain minimally functional dotfiles +# handling in one's home directory on even machines that lack a Perl +# interpreter. As such, many of GNU Stow's more advanced features are +# not reimplemented. Git depends on Perl, for now, but my two methods +# for deploying my dotfiles to remote machines -- my INSINUATE-DOTFILES +# Consfigurator property and 'insinuate-dotfiles' shell script -- do not +# depend on having Git on the remote side. See also 'bstraph' script. +# +# We completely skip filenames containing control characters, including +# newline and tab, as POSIX find(1) lacks -print0, and it's unlikely +# you'd need to stow any such files. +# Technique from . + +set -efu +IFS="$(printf '\n\t')" +export LC_ALL=C +tab="$(printf '\t')" +cchars="$(printf '*[\001-\037\177]*')" + +if ! command -v readlink >/dev/null; then + readlink () { + # Safe parse of ls(1) output given its POSIX specification. + ls -ld "$1" | tr -s ' ' \ + | cut -d' ' -f9- | cut -c$((4 + $(echo "$1" | wc -c)))- + } +fi + +read_globs_file () { + if [ -e "$DIR/$1" ]; then + while read -r line; do + printf "|./%s" "$line" + done <"$DIR/$1" | cut -c2- + fi +} + +dir_contents () { + ( cd "$1"; find . ! -name . ! -name "$cchars" ) +} + +fail () { + echo >&2 "hstow: $*" + exit 127 +} + +usage () { + fail "usage: hstow stow|unstow|restow|adopt DIRECTORY" +} + +stow () { + cd "$DIR" + [ -d "$HOME/.STOW" ] || mkdir "$HOME/.STOW" + [ -f "$HOME/.STOW/.stow" ] || touch "$HOME/.STOW/.stow" + [ -h "$HOME/.STOW/$NAME" ] \ + || ( cd "$HOME/.STOW"; ln -s "$DIR" "$NAME" ) + conflicts= + ignores="$(read_globs_file .hstow-local-ignore)" + + # Files that (i) always/often have their symlinks replaced with + # regular files when applications access them; and (ii) we don't + # ever want to edit the copy under $DIR directly, but only via the + # link/copy under $HOME. + $always_adopt || adoptions="$(read_globs_file .hstow-always-adopt)" + + for file in $(find . ! -name . ! -type d ! -name "$cchars" \ + ! -name .gitignore \ + ! -name .hstow-local-ignore \ + ! -name .hstow-always-adopt \ + | grep -v '^\./\.git/'); do + file_dir="$(dirname $file)" + if [ -n "$ignores" ]; then + eval case "'$file'" in "${ignores})" continue ";;" esac + eval case "'$file_dir'" in "${ignores})" continue ";;" esac + fi + + rel="$(echo $file | sed -E 's#/dot[-.]([^/]+)#/.\1#g; s#^\./##')" + dotdotslashes="$(echo $rel | sed -E 's#[^/]*$##; s#[^/]+#..#g')" + target="${dotdotslashes}.STOW/$NAME/$rel" + link="$HOME/$rel" + link_target= + [ -h "$link" ] && link_target="$(readlink $link)" + + [ "$target" = "$link_target" ] && continue + + if [ ! -h "$link" -a ! -h "$file" -a -f "$link" ]; then + if $always_adopt \ + || ( [ -n "$adoptions" ] \ + && eval case "'$file'" in \ + "${adoptions})" exit 0 ";;" \ + "*)" exit 1 ";;" \ + esac ); then + mv -f "$link" "$file" + ln -s "$target" "$link" + else + conflicts="$conflicts${tab}$file" + fi + elif [ -h "$link" ]; then + # With at least GNU ln(1), passing -f, but not also -T, does not + # replace an existing link in some cases. + # -T is not POSIX, so we just remove any existing link first. + rm "$link" + ln -s "$target" "$link" + else + mkdir -p "$HOME/$file_dir" + ln -s "$target" "$link" + fi + done + [ -z "$conflicts" ] && return + echo >&2 "hstow: encountered conflicts:" + for conflict in $conflicts; do echo >&2 " $conflict"; done + exit 127 +} + +unstow () { + cd "$HOME" + dir_pat="^.$(echo $DIR | cut -c$(echo $HOME | wc -c)-)/" + for file in $(find . -type l ! -name . ! -name "$cchars" \ + | grep -v "$dir_pat"); do + if readlink "$file" | grep -Eq '^(\.\./)*\.STOW/'"$NAME/"; then + rm "$file" + while true; do + file="$(dirname $file)" + [ "$file" = . ] && break + if [ -z "$(dir_contents $file)" ]; then + rmdir "$file" + else + break + fi + done + fi + done + [ -e "$HOME/.STOW/$NAME" ] && rm "$HOME/.STOW/$NAME" + if [ -d "$HOME/.STOW" ] \ + && [ "$(dir_contents $HOME/.STOW)" = "./.stow" ]; then + rm "$HOME/.STOW/.stow" + rmdir "$HOME/.STOW" + fi +} + +[ $# = 2 ] || usage +[ -d "$2" ] || fail "$2 is not an existing directory" +DIR="$(cd $2; pwd)" +[ "$(echo $DIR | cut -c-$(($(echo $HOME | wc -c) - 1)))" = "$HOME" ] \ + || fail "$DIR is not below $HOME" + +NAME="$(echo $DIR | tr / _)" +always_adopt=false +case "$1" in + 'stow') stow ;; + 'unstow') unstow ;; + 'restow') unstow; stow ;; + 'adopt') always_adopt=true; stow ;; + *) usage ;; +esac diff --git a/bin/insinuate-dotfiles b/bin/insinuate-dotfiles index 6cc5e5a4..d7ec9178 100755 --- a/bin/insinuate-dotfiles +++ b/bin/insinuate-dotfiles @@ -58,4 +58,4 @@ if ssh "$1" which gpg >/dev/null; then | ssh "$1" gpg --import fi # stow dotfiles into $HOME -ssh "$1" 'sh src/dotfiles/bin/bstraph.sh' +ssh "$1" 'sh src/dotfiles/bin/bstraph' diff --git a/bin/unskel b/bin/unskel deleted file mode 100755 index 80f77d53..00000000 --- a/bin/unskel +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/sh - -# Removes contents of /etc/skel in home directory. Checks for -# modifications, so should always be safe to run. - -SKEL="/etc/skel" -torm="" - -for skelfile in $(find $SKEL -maxdepth 1 -type f | sed -e "s|${SKEL}/||"); do - # The following conditional passes if the file in $HOME is the - # *same* as the file in $SKEL, so it ought to be deleted. - if diff -q "$SKEL/$skelfile" "$HOME/$skelfile" >/dev/null 2>&1; then - torm="$torm $HOME/$skelfile" - fi -done - -[ "$torm" = "" ] || rm -rf $torm - -# on Debian systems root gets a special .bashrc and .profile -if diff -q /usr/share/base-files/dot.bashrc "$HOME/.bashrc" >/dev/null 2>&1; then - rm -f "$HOME/.bashrc" -fi -if diff -q /usr/share/base-files/dot.profile "$HOME/.profile" >/dev/null 2>&1; then - rm -f "$HOME/.profile" -fi diff --git a/lib-src/mr/config b/lib-src/mr/config index 06af1b6e..9cd84fe2 100644 --- a/lib-src/mr/config +++ b/lib-src/mr/config @@ -23,6 +23,11 @@ git_isclean = git is-clean git_clean = git clean -xdff +stow = hstow stow "$MR_REPO" +unstow = hstow unstow "$MR_REPO" +restow = hstow restow "$MR_REPO" +adopt = hstow adopt "$MR_REPO" + # --- Plugin for dgit repos # actually shipped with upstream mr, but use an include command that @@ -40,17 +45,6 @@ include = cat ~/src/dotfiles/lib-src/mr/dgit # after we include the dgit lib, which also redefines git_update) git_update = git pull-safe -# --- Adam Spiers' plugin for managing dotfile symlinks with mr - -# actually shipped with upstream mr, but use an include command that -# will always work -include = - # stow is not available on Windows - if [ -e "$HOME/src/dotfiles/lib-src/mr/stow" ] \ - && ! [ "$(perl -e 'print $^O')" = "msys" ]; then - cat "$HOME/src/dotfiles/lib-src/mr/stow" - fi - # --- joeyh's code for specifying what machine we're on for repo skip # --- tests, plus my code for detecting Git-on-Windows @@ -106,66 +100,6 @@ lib = # --- standard procedures lib = - homedir_mkdirs() { - ( - cd $HOME - mkdir -p \ - .ssh \ - tmp \ - src \ - lib \ - mnt \ - local/mutt \ - local/src \ - local/bin \ - local/big \ - local/lib \ - local/log \ - local/pub \ - local/tmp \ - local/auth \ - local/info - # lib/athena \ - # lib/backup \ - # local/anacron/spool \ - chmod 700 local/auth - # [ -L "src/build-area" ] || ln -s -T /tmp/debuild src/build-area - [ -e "Downloads" ] || ln -s tmp Downloads - # clean up after additions to .stow-local-ignore - find bin lib -type l 2>/dev/null | while read -r link; do - if readlink "$link" | grep --quiet "^[../]*/.STOW/"; then - rm "$link" - fi - done - # cleanup some old dirs if they're empty - find \ - bin \ - lib/aid \ - lib/backup \ - lib/perl5 \ - lib/hooks \ - lib/athena \ - lib/bins \ - lib/img \ - lib/mr \ - lib/src \ - local/anacron/spool \ - -type d -empty -delete 2>/dev/null ||: - ) - } - # specify files that should automatically be adopted because - # programs convert them from symlinks to regular files. Arguments - # to this function should be paths relative to the stow target - # (usually $HOME) - always_adopt () { - for f in $@; do - if ! [ -L "$STOW_TARGET/$f" ]; then - # ignore errors; if it doesn't work, the user will - # have to fix up manually - mv 2>/dev/null "$STOW_TARGET/$f" "$MR_REPO/$f" || true - fi - done - } # export plain text Org agenda in post_ hooks of ~/doc repo (not currently used) export_org_agenda () { if on athena; then @@ -179,72 +113,18 @@ lib = # --- primary dotfiles repository -# TODO we need to unstow before switching branches, and stow -# afterwards, or else do some sort of automatic cleanup of dangling -# symlinks before a restow, so a broken situation is easy to fix? -# Also see kill-broken-stowed-symlink() in .bashrc. -# -# Note that the scan is expensive. So actually we probably don't want -# the cleanup to happen automatically. Also, it should exclude -# lib/annex, src/*/ (but not src/) because I don't stow files into -# those dirs. -# -# Maybe just run it as part of sysmaint -# -# Hmm. Situation is not as bad as I thought. stow manages to clean -# up quite a few of the symlinks. So running it as part of sysmaint -# seems like a sufficient fix - [src/dotfiles] checkout = git clone https://git.spwhitton.name/dotfiles.git dotfiles -stowable = true -# we have a script to update master, and all other branches should -# only be checked out and committed to on a single host +# We have a script to update master, and all other branches should be checked +# out and committed to on only a single host, so no need to pull them, and +# they'll always be rebaseable. update = git dotfiles-update-master -push = git push origin master -# use `git dotfiles-rebase` instead -# rebase = -# # usual rebasing pattern. Per dotfiles repo policy (excluding -# # win32 case), the branch being rebased will always be rebaseable -# # on master, since it is only checked out and committed to on this -# # host -# branch="$(git rev-parse --abbrev-ref HEAD)" -# hostname="$(hostname -s)" -# if [ "$branch" = "win32" -o "$branch" = "$hostname" -o "$branch" = "develacc-$hostname" ]; then -# git rebase master -# fi -fixups = - # Use a rebase workflow as I'm the only committer - git config pull.rebase true - # Pushing and pulling are always done explicitly - for head in $(git for-each-ref --format='%(refname)' refs/heads/); do - branch=$(echo "$head" | cut -d/ -f3) - git branch --unset-upstream "$branch" 2>/dev/null || true - done - git config push.default nothing - # this is just for M-x magit-status - git config remote.pushDefault origin - # - homedir_mkdirs - chmod -Rf u+rwX,go= $HOME/local/auth/* || true - # eventually move the following two lines from fixups to post_checkout - install-git-hooks dotfiles - git config user.signingkey 8DC2487E51ABDD90B5C4753F0F56D0553B6D411B - # eventually drop this - rm -f .git/hooks/post-checkout{,_01gpgsign} - -# clean-ups so that initial stow will be successful -pre_stow = - homedir_mkdirs - $HOME/src/dotfiles/bin/unskel - # these will often end up created, e.g. by insinuate-dotfiles script - rm -f $HOME/.gnupg/{gpg.conf,gpg-agent.conf,dirmngr.conf,.gpg-v21-migrated} - -# this file frequently gets desymlinked -pre_unstow_append = always_adopt .config/mimeapps.list -pre_restow_append = always_adopt .config/mimeapps.list -pre_stow_append = always_adopt .config/mimeapps.list -pre_update_append = always_adopt .config/mimeapps.list +push = git dotfiles-rebase +# Restowing is expensive, and most dangling symlinks into ~/.STOW do no harm, +# so we leave it to be run manually -- bstraph stows but does not restow. +# Possibly restowing could be done by locmaint, or we could have hstow skip +# annex/ and src/, into which I don't stow anything. +fixups = bstraph # --- private dotfiles repositories @@ -252,7 +132,9 @@ pre_update_append = always_adopt .config/mimeapps.list checkout = git clone athenag:libpriv.git priv update = git annex sync --content cloud origin push = git annex sync --content cloud origin -stowable = true +post_update = + hstow stow ~/lib/priv + load-trustdb sync = mr autoci && git annex sync --no-commit --content cloud origin skip = lazy @@ -261,6 +143,11 @@ post_checkout = git annex init git annex enableremote cloud git annex group . backup + # Delete any pubring.kbx created by INSINUATE-DOTFILES Consfigurator + # property / 'insinuate-dotfiles' shell script: don't want to adopt it. + rm -f ~/.gnupg/pubring.kbx + hstow stow ~/lib/priv + load-trustdb fixups = chmod 600 .passwddb.pet \ @@ -282,21 +169,18 @@ fixups = git config mrrepo.review-unused false autoci = + hstow stow ~/lib/priv # to perform adoptions git annex add .passwddb.pet .labbook.gpg .gnupg/pubring.kbx git commit -a -m \ "auto passwddb, pubring and labbook commit on $(hostname -s)" || true pre_update = mr autoci -# since dotfiles repo also stows into ~/.gnupg, and athpriv repo stows -# into ~/.duply, make the dirs first -pre_stow = homedir_mkdirs -post_stow = load-trustdb - [src/athpriv] checkout = git clone demeterp:athpriv athpriv pre_update = on athena || git annex sync origin athenah pre_push = on athena || git annex sync --content origin athenah -stowable = true +post_update = hstow stow ~/src/athpriv +post_checkout = hstow stow ~/src/athpriv skip = ! mine post_checkout = @@ -321,15 +205,6 @@ autoci = git annex add News/* git commit News -m"auto commit of Gnus score files" ||: -# since priv repo also stows into ~/.duply, make the dir first -pre_stow = homedir_mkdirs - -# r2e always desymlinks this file -pre_stow_append = always_adopt .config/rss2email.cfg -pre_unstow_append = always_adopt .config/rss2email.cfg -pre_restow_append = always_adopt .config/rss2email.cfg -pre_update_append = always_adopt .config/rss2email.cfg - # --- hosts configuration [src/propellor] diff --git a/lib-src/mr/stow b/lib-src/mr/stow deleted file mode 100644 index 254bd0c3..00000000 --- a/lib-src/mr/stow +++ /dev/null @@ -1,273 +0,0 @@ -# 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 -# -# This version reworked (2016, 2017) & maintained (2017) by: -# Sean Whitton - -# 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/lib-src/stow/chkstow b/lib-src/stow/chkstow deleted file mode 100755 index a74d1b90..00000000 --- a/lib-src/stow/chkstow +++ /dev/null @@ -1,113 +0,0 @@ -#!/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/lib-src/stow/stow b/lib-src/stow/stow deleted file mode 100755 index b94dc88d..00000000 --- a/lib-src/stow/stow +++ /dev/null @@ -1,665 +0,0 @@ -#!/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 . - -=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. When one -does so, one winds up (as of Perl 4.036 and Emacs 19.22) with the -following files in F: F; F; -F; F; F; F; and F. Now -suppose it's time to uninstall Perl. Which man pages get removed? -Obviously F 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 -directory containing executables, a F 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), so it's always -possible to rebuild the target tree (e.g., F). - -=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, F, and F subdirectories. - -A "target directory" is the root of a tree in which one or more -packages wish to B to be installed. A common, but by no means -the only such location is F. The examples in this manual -page will use F 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 as the stow directory, so that -individual packages will be, for example, F and -F. - -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 directory containing -F and F (among others); an F directory containing -Texinfo documentation; a F directory containing Perl -libraries; and a F 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 must reside in the stow directory -F. The "name" of a package is the name of its -directory within the stow directory -- e.g., F. - -Thus, the Perl executable might reside in -F, where F is the target -directory, F is the stow directory, -F is the package directory, and F -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 -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 from the directory F). -Each F given on the command line is the name of a package in -the stow directory (e.g., F). 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 instead of the current directory. -This also has the effect of making the default target directory be the -parent of C. - -=item -t DIR - -=item --target=DIR - -Set the target directory to C 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 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; it's completely empty (except for the F -subdirectory, of course). Now suppose the Perl package is installed. -Recall that it includes the following directories in its installation -image: F; F; F; F. Rather than -creating the directory F 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, which -points to F. In this way, it still works to refer to -F and F, 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 pointing to F; the symlink -F pointing to F; and the symlink -F pointing to F. - -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 -already exists and is a directory, as are F and -F. In this case, Stow will descend into -F and create symlinks to F<../stow/perl/bin/perl> and -F<../stow/perl/bin/a2p> (etc.), and it will descend into -F and create the tree-folding symlink F 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 to the old package that used the old symlink. For -example, suppose that after installing Perl into an empty -F, we wish to install Emacs. Emacs's installation image -includes a F directory containing the F and F -executables, among others. Stow must make these files appear to be -installed in F, but presently F is a -symlink to F. Stow therefore takes the following -steps: the symlink F is deleted; the directory -F is created; links are made from F to -F<../stow/emacs/bin/emacs> and F<../stow/emacs/bin/etags>; and links -are made from F 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 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 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 is maintained as a Texinfo manual. -If the F and F 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 includes an empty directory -- say, F -- -then if no other package has a F subdirectory, everything's fine. -If another stowed package F, has a F subdirectory, then -when stowing, F will be "split open" and the contents -of F will be individually stowed. So far, so good. But when -unstowing F, F will be removed, even though -F needs it to remain. A workaround for this problem is to -create a file in F 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 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 ; -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: -General help using GNU software: -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/perl5/Local/MrRepo/Repo.pm b/perl5/Local/MrRepo/Repo.pm index edc87e92..937d0a0e 100644 --- a/perl5/Local/MrRepo/Repo.pm +++ b/perl5/Local/MrRepo/Repo.pm @@ -45,7 +45,7 @@ sub auto_commit { shift->_mr_cmd("-m", "autoci") } sub update { my $self = shift; - # note that this also restows + # note that this may also stow my $result = $self->_mr_cmd("update"); $self->{updated} = 1 if $result->{exit} == 0 diff --git a/perl5/Stow.pm b/perl5/Stow.pm deleted file mode 100644 index bda7d3ab..00000000 --- a/perl5/Stow.pm +++ /dev/null @@ -1,2110 +0,0 @@ -#!/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 vs. C, for example) -while making them appear to be installed in the same place -(C). - -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 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 parameter passed -to the L 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. - -=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. - -=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 <. - -=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. - -=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 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 -- cgit v1.2.3