00dani/stow
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

numerous refactorings and comments to improve legibility

Browse source
This commit is contained in:
adam 2006-01-01 23:38:00 +00:00 committed by Adam Spiers
parent d21d1dd629
commit 61a1944b81
1 changed files with 157 additions and 114 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

259
Stow.pm
View file

@ -32,12 +32,15 @@
# Hacked into a Perl module # Hacked into a Perl module
##################################################################### #####################################################################
package Stow;
use strict; use strict;
use warnings; use warnings;
use File::Spec; use File::Spec;
use FindBin qw($RealBin $RealScript); use FindBin qw($RealBin $RealScript);
use Getopt::Long; use Getopt::Long;
use POSIX;
use lib "$RealBin/../lib/perl5"; use lib "$RealBin/../lib/perl5";
use Sh 'glob_to_re'; use Sh 'glob_to_re';
@ -74,7 +77,7 @@ sub CheckCollections {
foreach my $package (@_) { foreach my $package (@_) {
$package =~ s,/+$,,; # delete trailing slashes $package =~ s,/+$,,; # delete trailing slashes
if ($package =~ m,/,) { if ($package =~ m,/,) {
die "$RealScript: slashes not permitted in package names\n"; die "$RealScript: slashes not permitted in package names ($package)\n";
} }
} }
} }
@ -113,84 +116,112 @@ sub RelativePath {
&JoinPaths(@b); &JoinPaths(@b);
} }
# Basically concatenates the paths given # Concatenates the paths given as arguments, removing double slashes.
# as arguments
sub JoinPaths { sub JoinPaths {
my(@paths, @parts); # The code that was previously here from 1.3.3 was strangely complex
my ($x, $y); # for no obvious reason. I (Adam) wrote a test suite and found this
my($result) = ''; # drop-in replacement to behave identically.
# my $result = join '/', @_;
$result = '/' if ($_[0] =~ /^\//); # $result =~ s!//!/!g;
foreach $x (@_) { # return $result;
@parts = split(/\/+/, $x); # So does this, but is also portable.
foreach $y (@parts) { return File::Spec->join(@_);
push(@paths, $y) if ($y ne "");
}
}
$result .= join('/', @paths);
return $result;
} }
sub Unstow { # This removes stow-controlled symlinks from $targetdir for the
my($targetdir, $stow, $Collections) = @_; # packages in the %$to_unstow hash, and is called recursively to
my($pure, $othercollection) = (1, ''); # process subdirectories. It returns XXX FIXME
my($subpure, $subother);
my($empty) = (1);
my(@puresubdirs);
return (0, '') if (&JoinPaths($opts{target}, $targetdir) eq $opts{stow}); sub Unstow {
return (0, '') if (-e &JoinPaths($opts{target}, $targetdir, '.stow')); my($targetdir, $stow, $to_unstow) = @_;
warn sprintf("Unstowing in %s\n", &JoinPaths($opts{target}, $targetdir)) # Note $targetdir is relative to the top of the target hierarchy,
if ($opts{verbose} > 1); # i.e. $opts{target}.
my $dir = &JoinPaths($opts{target}, $targetdir); #
if (!opendir(DIR, $dir)) { # $stow is the stow directory (the one containing the source
warn "Warning: $RealScript: Cannot read directory \"$dir\" ($!). Stow might leave some links. If you think, it does. Rerun Stow with appropriate rights.\n"; # packages), and is always relative to $targetdir. So as we
# recursively descend into $opts{target}, $stow gets longer because
# we have to move up out of that hierarchy and back into the stow
# directory.
# Does this directory only contain symlinks to the packages we are
# removing? We assume so and scan the directory until we find out
# otherwise.
my $pure = 1;
# FIXME what is this?
my $othercollection = '';
# We assume $targetdir is empty until we find something.
my $empty = 1;
my $targetdirPath = &JoinPaths($opts{target}, $targetdir);
return (0, '') if $targetdirPath eq $opts{stow};
return (0, '') if -e &JoinPaths($targetdirPath, '.stow');
warn "Unstowing in $targetdirPath\n"
if $opts{verbose} > 1;
if (!opendir(DIR, $targetdirPath)) {
warn "Warning: $RealScript: Cannot read directory \"$targetdirPath\" ($!). Stow might leave some links. If you think, it does. Rerun Stow with appropriate rights.\n";
} }
my @contents = readdir(DIR); my @contents = readdir(DIR);
closedir(DIR); closedir(DIR);
my @puresubdirs;
foreach my $content (@contents) { foreach my $content (@contents) {
next if (($content eq '.') || ($content eq '..')); next if ($content eq '.') || ($content eq '..');
$empty = 0; $empty = 0;
if (-l &JoinPaths($opts{target}, $targetdir, $content)) { my $contentPath = &JoinPaths($targetdirPath, $content);
(my $linktarget = readlink(&JoinPaths($opts{target}, if (-l $contentPath) {
$targetdir, # We found a link; now let's see if we should remove it.
$content))) my $linktarget = readlink $contentPath;
|| die sprintf("%s: Cannot read link %s (%s)\n", $linktarget or die "$RealScript: Cannot read link $contentPath ($!)\n";
$RealScript,
&JoinPaths($opts{target}, $targetdir, $content), # Does the link point to somewhere within the stow directory?
$!); my $stowmember = &FindStowMember(
if (my $stowmember = &FindStowMember(&JoinPaths($opts{target}, $targetdirPath,
$targetdir), $linktarget,
$linktarget)) { );
if ($stowmember) {
# Yes it does, but does it point within one of the package
# collections we are unstowing?
my @stowmember = split(/\/+/, $stowmember); my @stowmember = split(/\/+/, $stowmember);
my $collection = shift(@stowmember); my $collection = shift(@stowmember);
if (grep(($collection eq $_), @$Collections)) { if ($to_unstow->{$collection}) {
&DoUnlink(&JoinPaths($opts{target}, $targetdir, $content)); # Yep, so get rid of it.
} elsif ($pure) { &DoUnlink($contentPath);
} else {
# No, it points to another package collection.
if ($pure) {
if ($othercollection) { if ($othercollection) {
$pure = 0 if ($collection ne $othercollection); $pure = 0 if $collection ne $othercollection;
} else { } else {
$othercollection = $collection; $othercollection = $collection;
} }
} }
}
} else { } else {
$pure = 0; $pure = 0;
} }
} elsif (-d &JoinPaths($opts{target}, $targetdir, $content)) { }
($subpure, $subother) = &Unstow(&JoinPaths($targetdir, $content), elsif (-d $contentPath) {
&JoinPaths('..', $stow)); # recurse
my ($subpure, $subother) = &Unstow(
&JoinPaths($targetdir, $content),
&JoinPaths('..', $stow),
$to_unstow,
);
if ($subpure) { if ($subpure) {
push(@puresubdirs, "$content/$subother"); push(@puresubdirs, "$content/$subother");
} }
if ($pure) { if ($pure) {
if ($subpure) { if ($subpure) {
if ($othercollection) { if ($othercollection) {
if ($subother) { if ($subother and $othercollection ne $subother) {
if ($othercollection ne $subother) {
$pure = 0; $pure = 0;
} }
}
} elsif ($subother) { } elsif ($subother) {
$othercollection = $subother; $othercollection = $subother;
} }
@ -203,12 +234,12 @@ sub Unstow {
} }
} }
# This directory was an initially empty directory therefore # This directory was an initially empty directory therefore
# We do not remove it. # we do not remove it.
$pure = 0 if $empty; $pure = 0 if $empty;
if ((!$pure || !$targetdir) && @puresubdirs) { if ((!$pure || !$targetdir) && @puresubdirs) {
&CoalesceTrees($targetdir, $stow, @puresubdirs); &CoalesceTrees($targetdir, $stow, @puresubdirs);
} }
($pure, $othercollection); return ($pure, $othercollection);
} }
sub CoalesceTrees { sub CoalesceTrees {
@ -248,7 +279,7 @@ sub EmptyTree {
sub StowContents { sub StowContents {
my($dir, $stow) = @_; my($dir, $stow) = @_;
warn "Stowing contents of $dir\n" if ($opts{verbose} > 1); warn "Stowing contents of $dir\n" if $opts{verbose} > 1;
my $joined = &JoinPaths($opts{stow}, $dir); my $joined = &JoinPaths($opts{stow}, $dir);
opendir(DIR, $joined) opendir(DIR, $joined)
|| die "$RealScript: Cannot read directory \"$dir\" ($!)\n"; || die "$RealScript: Cannot read directory \"$dir\" ($!)\n";
@ -278,51 +309,53 @@ sub StowDir {
my($dir, $stow) = @_; my($dir, $stow) = @_;
my(@dir) = split(/\/+/, $dir); my(@dir) = split(/\/+/, $dir);
my($collection) = shift(@dir); my($collection) = shift(@dir);
my($subdir) = join('/', @dir); my($subdir) = &JoinPaths('/', @dir);
my($linktarget, $stowsubdir); my($linktarget, $stowsubdir);
warn "Stowing directory $dir\n" if ($opts{verbose} > 1); warn "Stowing directory $dir\n" if ($opts{verbose} > 1);
if (-l &JoinPaths($opts{target}, $subdir)) {
($linktarget = readlink(&JoinPaths($opts{target}, $subdir))) my $subdirPath = &JoinPaths($opts{target}, $subdir);
|| die sprintf("%s: Could not read link %s (%s)\n", if (-l $subdirPath) {
$RealScript, ($linktarget = readlink($subdirPath))
&JoinPaths($opts{target}, $subdir), || die "$RealScript: Could not read link $subdirPath ($!)\n";
$!); my $stowsubdir = &FindStowMember(
($stowsubdir = &JoinPaths($opts{target}, @dir[0..($#dir - 1)]),
&FindStowMember(sprintf('%s/%s', $opts{target}, $linktarget
join('/', @dir[0..($#dir - 1)])), );
$linktarget)) unless ($stowsubdir) {
|| (&Conflict($dir, $subdir, 1), return); &Conflict($dir, $subdir, 1);
return;
}
if (-e &JoinPaths($opts{stow}, $stowsubdir)) { if (-e &JoinPaths($opts{stow}, $stowsubdir)) {
if ($stowsubdir eq $dir) { if ($stowsubdir eq $dir) {
warn sprintf("%s already points to %s\n", warn sprintf("%s already points to %s\n",
&JoinPaths($opts{target}, $subdir), $subdirPath,
&JoinPaths($opts{stow}, $dir)) &JoinPaths($opts{stow}, $dir))
if ($opts{verbose} > 2); if ($opts{verbose} > 2);
return; return;
} }
if (-d &JoinPaths($opts{stow}, $stowsubdir)) { if (-d &JoinPaths($opts{stow}, $stowsubdir)) {
&DoUnlink(&JoinPaths($opts{target}, $subdir)); &DoUnlink($subdirPath);
&DoMkdir(&JoinPaths($opts{target}, $subdir)); &DoMkdir($subdirPath);
&StowContents($stowsubdir, &JoinPaths('..', $stow)); &StowContents($stowsubdir, &JoinPaths('..', $stow));
&StowContents($dir, &JoinPaths('..', $stow)); &StowContents($dir, &JoinPaths('..', $stow));
} else { } else {
(&Conflict($dir, $subdir, 2), return); (&Conflict($dir, $subdir, 2), return);
} }
} else { } else {
&DoUnlink(&JoinPaths($opts{target}, $subdir)); &DoUnlink($subdirPath);
&DoLink(&JoinPaths($stow, $dir), &DoLink(&JoinPaths($stow, $dir),
&JoinPaths($opts{target}, $subdir)); $subdirPath);
} }
} elsif (-e &JoinPaths($opts{target}, $subdir)) { } elsif (-e $subdirPath) {
if (-d &JoinPaths($opts{target}, $subdir)) { if (-d $subdirPath) {
&StowContents($dir, &JoinPaths('..', $stow)); &StowContents($dir, &JoinPaths('..', $stow));
} else { } else {
&Conflict($dir, $subdir, 3); &Conflict($dir, $subdir, 3);
} }
} else { } else {
&DoLink(&JoinPaths($stow, $dir), &DoLink(&JoinPaths($stow, $dir),
&JoinPaths($opts{target}, $subdir)); $subdirPath);
} }
} }
@ -330,37 +363,36 @@ sub StowNondir {
my($file, $stow) = @_; my($file, $stow) = @_;
my(@file) = split(/\/+/, $file); my(@file) = split(/\/+/, $file);
my($collection) = shift(@file); my($collection) = shift(@file);
my($subfile) = join('/', @file); my($subfile) = &JoinPaths(@file);
my($linktarget, $stowsubfile); my($linktarget, $stowsubfile);
if (-l &JoinPaths($opts{target}, $subfile)) { my $subfilePath = &JoinPaths($opts{target}, $subfile);
($linktarget = readlink(&JoinPaths($opts{target}, $subfile))) if (-l $subfilePath) {
|| die sprintf("%s: Could not read link %s (%s)\n", my $linktarget = readlink($subfilePath);
$RealScript, $linktarget or die "$RealScript: Could not read link $subfilePath ($!)\n";
&JoinPaths($opts{target}, $subfile), my $stowsubfile = &FindStowMember(
$!); &JoinPaths($opts{target}, @file[0..($#file - 1)]),
($stowsubfile = $linktarget
&FindStowMember(sprintf('%s/%s', $opts{target}, );
join('/', @file[0..($#file - 1)])), if (! $stowsubfile) {
$linktarget)) &Conflict($file, $subfile, 4);
|| (&Conflict($file, $subfile, 4), return); return;
}
if (-e &JoinPaths($opts{stow}, $stowsubfile)) { if (-e &JoinPaths($opts{stow}, $stowsubfile)) {
(&Conflict($file, $subfile, 5), return) (&Conflict($file, $subfile, 5), return)
unless ($stowsubfile eq $file); unless ($stowsubfile eq $file);
warn sprintf("%s already points to %s\n", warn sprintf("%s already points to %s\n",
&JoinPaths($opts{target}, $subfile), $subfilePath,
&JoinPaths($opts{stow}, $file)) &JoinPaths($opts{stow}, $file))
if ($opts{verbose} > 2); if ($opts{verbose} > 2);
} else { } else {
&DoUnlink(&JoinPaths($opts{target}, $subfile)); &DoUnlink($subfilePath);
&DoLink(&JoinPaths($stow, $file), &DoLink(&JoinPaths($stow, $file), $subfilePath);
&JoinPaths($opts{target}, $subfile));
} }
} elsif (-e &JoinPaths($opts{target}, $subfile)) { } elsif (-e $subfilePath) {
&Conflict($file, $subfile, 6); &Conflict($file, $subfile, 6);
} else { } else {
&DoLink(&JoinPaths($stow, $file), &DoLink(&JoinPaths($stow, $file), $subfilePath);
&JoinPaths($opts{target}, $subfile));
} }
} }
@ -412,29 +444,40 @@ sub Conflict {
} }
} }
# Given an absolute starting directory and a relative path obtained by
# calling readlink() on a symlink in that starting directory,
# FindStowMember() figures out whether the symlink points to somewhere
# within the stow directory. If so, it returns the target of the
# symlink relative to the stow directory, otherwise it returns ''.
sub FindStowMember { sub FindStowMember {
my($start, $path) = @_; my($startDir, $targetPath) = @_;
my(@x) = split(/\/+/, $start); my @startDirSegments = split(/\/+/, $startDir);
my(@path) = split(/\/+/, $path); my @targetSegments = split(/\/+/, $targetPath);
my($x); my @stowDirSegments = split(/\/+/, $opts{stow});
my(@d) = split(/\/+/, $opts{stow});
while (@path) { # Start in $startDir and navigate to target, one path segment at a time.
$x = shift(@path); my @current = @startDirSegments;
while (@targetSegments) {
my $x = shift(@targetSegments);
if ($x eq '..') { if ($x eq '..') {
pop(@x); pop(@current);
return '' unless @x; return '' unless @current; # We can't go higher than /, must be
# an invalid symlink.
} elsif ($x) { } elsif ($x) {
push(@x, $x); push(@current, $x);
} }
} }
while (@x && @d) {
if (($x = shift(@x)) ne shift(@d)) { # Now @current describes the absolute path to the symlink's target,
# so if @current and @stowDirSegments have a common prefix, the
# symlink points within the stow directory.
while (@current && @stowDirSegments) {
if (shift(@current) ne shift(@stowDirSegments)) {
return ''; return '';
} }
} }
return '' if @d; return '' if @stowDirSegments;
return join('/', @x); return join('/', @current);
} }
sub parent { sub parent {