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

fix RelativePath for relative paths and other corner cases

Browse source
This commit is contained in:
adam 2011-10-23 23:20:42 +00:00 committed by Adam Spiers
parent a37e8f00ed
commit ec7d169446
1 changed files with 33 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
Stow.pm
View file

@ -85,36 +85,54 @@ sub CheckCollections {
sub CommonParent { sub CommonParent {
my($dir1, $dir2) = @_; my($dir1, $dir2) = @_;
my($result, $x); my $result = '';
my(@d1) = split(/\/+/, $dir1); my(@d1) = split(/\/+/, $dir1);
my(@d2) = split(/\/+/, $dir2); my(@d2) = split(/\/+/, $dir2);
while (@d1 && @d2 && (($x = shift(@d1)) eq shift(@d2))) { while (@d1 && @d2 && ((my $x = shift(@d1)) eq shift(@d2))) {
$result .= "$x/"; $result .= "$x/";
} }
return '/' if ! $result and $dir1 =~ m!^/! and $dir2 =~ m!^/!;
chop($result); chop($result);
return $result; return $result;
} }
# Find the relative patch between # Find the relative path to $b from $a
# two paths given as arguments.
sub RelativePath { sub RelativePath {
my($a, $b) = @_; my($a, $b) = @_;
die "Both paths must be relative or absolute"
if substr($a, 0, 1) ne '/' and substr($b, 0, 1) eq '/';
return '.' if $a eq $b;
my($c) = &CommonParent($a, $b); my($c) = &CommonParent($a, $b);
my(@a) = split(/\/+/, $a); my(@a) = split(/\/+/, $a);
my(@b) = split(/\/+/, $b); my(@b) = split(/\/+/, $b);
my(@c) = split(/\/+/, $c); my(@c) = split(/\/+/, $c);
# if $c == "/something", scalar(@c) >= 2 # get rid of any empty 1st element due to absolute paths
# but if $c == "/", scalar(@c) == 0 shift @a if substr($a, 0, 1) eq '/';
# but we want 1 shift @b if substr($b, 0, 1) eq '/';
my $length = scalar(@c) ? scalar(@c) : 1; shift @c if substr($c, 0, 1) eq '/';
splice(@a, 0, $length);
splice(@b, 0, $length);
unshift(@b, (('..') x (@a + 0))); # Trim common path segments from @c off @a and @b
&JoinPaths(@b); #
# If $c == "/something", scalar(@c) == 1 after shift @c
# If $c == "/something/else", scalar(@c) == 2 after shift @c
# So in general, trim scalar(@c) segments off @a and @b
my $length = @c;
# but if $c eq "/", scalar(@c) == 0 but we want to remove the first undef:
#$length = 1 if $c eq "/";
# otherwise if $c eq "" we must have been dealing with at least one relative path:
#$length = 1 if $c eq "";
# and if $a eq $b, we want to keep the last element:
$length-- if $a eq $b;
splice @a, 0, $length;
splice @b, 0, $length;
unshift @b, (('..') x scalar(@a));
return &JoinPaths(@b);
} }
# Concatenates the paths given as arguments, removing double and # Concatenates the paths given as arguments, removing double and
@ -124,6 +142,8 @@ sub JoinPaths {
my(@paths, @parts); my(@paths, @parts);
my ($x, $y); my ($x, $y);
my($result) = ''; my($result) = '';
use Carp qw(carp cluck croak confess);
confess "nothing to join" unless defined $_[0];
$result = '/' if ($_[0] =~ /^\//); $result = '/' if ($_[0] =~ /^\//);
foreach $x (@_) { foreach $x (@_) {