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

Make join_paths correctly handle absolute paths

Browse source 
Previously join_paths() was incorrectly handling absolute paths, for
example join_paths('a/b', '/c/d') would return 'a/b/c/d' rather than
'/c/d'.  This was a problem when following a symlink in
find_stowed_path(), because if the symlink was not owned by Stow and
pointed to an absolute path, find_stowed_path() might accidentally
deem the link owned by Stow, if c/d was a valid path relative to the
current directory.
This commit is contained in:
Adam Spiers 2024-03-29 22:52:12 +00:00
parent ff4d87efaf
commit 4d711fc4ac
2 changed files with 61 additions and 97 deletions
Download patch file Download diff file Expand all files Collapse all files

41
lib/Stow/Util.pm.in
View file

@ -32,6 +32,7 @@ Supporting utility routines for L<Stow>.
use strict;
use warnings;
use File::Spec;
use POSIX qw(getcwd);
use base qw(Exporter);
@ -147,29 +148,43 @@ sub debug {
# Parameters: path1, path2, ... => paths
# Returns : concatenation of given paths
# Throws : n/a
# Comments : factors out redundant path elements:
# : '//' => '/' and 'a/b/../c' => 'a/c'
# Comments : Factors out some redundant path elements:
# : '//' => '/', and 'a/b/../c' => 'a/c'. This is needed even
# : though b could be a symlink to elsewhere as noted in the
# : perldoc for File::Spec->canonpath(), because the way
# : join_paths() is used relies on this.
#============================================================================
sub join_paths {
my @paths = @_;
# weed out empty components and concatenate
my $result = join '/', grep {! /\A\z/} @paths;
debug(5, 5, "| Joining: @paths");
my $result = '';
for my $part (@paths) {
next if ! length $part; # probably shouldn't happen?
$part = File::Spec->canonpath($part);
# 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;
if (substr($part, 0, 1) eq '/') {
$result = $part; # absolute path, so ignore all previous parts
}
else {
push @result, $part;
$result .= '/' if length $result && $result ne '/';
$result .= $part;
}
debug(7, 6, "| Join now: $result");
}
debug(6, 5, "| Joined: $result");
return join '/', @result;
# Need this to remove any initial ./
$result = File::Spec->canonpath($result);
# remove foo/..
1 while $result =~ s,(^|/)(?!\.\.)[^/]+/\.\.(/|$),$1,;
debug(6, 5, "| After .. removal: $result");
$result = File::Spec->canonpath($result);
debug(5, 5, "| Final join: $result");
return $result;
}
#===== METHOD ===============================================================