From 4d711fc4ac6f37e2d77a6886a6b75a71cb9149e7 Mon Sep 17 00:00:00 2001 From: Adam Spiers Date: Fri, 29 Mar 2024 22:52:12 +0000 Subject: [PATCH] Make join_paths correctly handle absolute paths 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. --- lib/Stow/Util.pm.in | 41 +++++++++++----- t/join_paths.t | 117 +++++++++++++------------------------------- 2 files changed, 61 insertions(+), 97 deletions(-) diff --git a/lib/Stow/Util.pm.in b/lib/Stow/Util.pm.in index e182d1d..7c1c8d5 100644 --- a/lib/Stow/Util.pm.in +++ b/lib/Stow/Util.pm.in @@ -32,6 +32,7 @@ Supporting utility routines for L. 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 =============================================================== diff --git a/t/join_paths.t b/t/join_paths.t index fa96d66..40c5a8f 100755 --- a/t/join_paths.t +++ b/t/join_paths.t @@ -22,91 +22,40 @@ use strict; use warnings; -use Stow::Util qw(join_paths); +use Stow::Util qw(join_paths set_debug_level); -use Test::More tests => 14; +#set_debug_level(4); -is( - join_paths('a/b/c', 'd/e/f'), - 'a/b/c/d/e/f' - => 'simple' +use Test::More tests => 22; + +my @TESTS = ( + [['a/b/c', 'd/e/f'], 'a/b/c/d/e/f' => 'simple'], + [['a/b/c', '/d/e/f'], '/d/e/f' => 'relative then absolute'], + [['/a/b/c', 'd/e/f'], '/a/b/c/d/e/f' => 'absolute then relative'], + [['/a/b/c', '/d/e/f'], '/d/e/f' => 'two absolutes'], + [['/a/b/c/', '/d/e/f/'], '/d/e/f' => 'two absolutes with trailing /'], + [['///a/b///c//', '/d///////e/f'], '/d/e/f' => "multiple /'s, absolute"], + [['///a/b///c//', 'd///////e/f'], '/a/b/c/d/e/f' => "multiple /'s, relative"], + [['', 'a/b/c'], 'a/b/c' => 'first empty'], + [['a/b/c', ''], 'a/b/c' => 'second empty'], + [['/', 'a/b/c'], '/a/b/c' => 'first is /'], + [['a/b/c', '/'], '/' => 'second is /'], + [['../a1/b1/../c1/', 'a2/../b2/e2'], '../a1/c1/b2/e2' => 'relative with ../'], + [['../a1/b1/../c1/', '/a2/../b2/e2'], '/b2/e2' => 'absolute with ../'], + [['../a1/../../c1', 'a2/../../'], '../..' => 'lots of ../'], + [['./', '../a2'], '../a2' => 'drop any "./"'], + [['./a1', '../../a2'], '../a2' => 'drop any "./foo"'], + [['a/b/c', '.'], 'a/b/c' => '. on RHS'], + [['a/b/c', '.', 'd/e'], 'a/b/c/d/e' => '. in middle'], + [['0', 'a/b'], '0/a/b' => '0 at start'], + [['/0', 'a/b'], '/0/a/b' => '/0 at start'], + [['a/b/c', '0', 'd/e'], 'a/b/c/0/d/e' => '0 in middle'], + [['a/b', '0'], 'a/b/0' => '0 at end'], ); -is( - join_paths('/a/b/c', '/d/e/f'), - '/a/b/c/d/e/f' - => 'leading /' -); - -is( - join_paths('/a/b/c/', '/d/e/f/'), - '/a/b/c/d/e/f' - => 'trailing /' -); - -is( - join_paths('///a/b///c//', '/d///////e/f'), - '/a/b/c/d/e/f' - => 'mltiple /\'s' -); - -is( - join_paths('', 'a/b/c'), - 'a/b/c' - => 'first empty' -); - -is( - join_paths('a/b/c', ''), - 'a/b/c' - => 'second empty' -); - -is( - join_paths('/', 'a/b/c'), - '/a/b/c' - => 'first is /' -); - -is( - join_paths('a/b/c', '/'), - 'a/b/c' - => 'second is /' -); - -is( - join_paths('///a/b///c//', '/d///////e/f'), - '/a/b/c/d/e/f' - => 'multiple /\'s' -); - - -is( - join_paths('../a1/b1/../c1/', '/a2/../b2/e2'), - '../a1/c1/b2/e2' - => 'simple deref ".."' -); - -is( - join_paths('../a1/b1/../c1/d1/e1', '../a2/../b2/c2/d2/../e2'), - '../a1/c1/d1/b2/c2/e2' - => 'complex deref ".."' -); - -is( - join_paths('../a1/../../c1', 'a2/../../'), - '../..' - => 'too many ".."' -); - -is( - join_paths('./a1', '../../a2'), - '../a2' - => 'drop any "./"' -); - -is( - join_paths('a/b/c', '.'), - 'a/b/c' - => '. on RHS' -); +for my $test (@TESTS) { + my ($inputs, $expected, $scenario) = @$test; + my $got = join_paths(@$inputs); + my $descr = "$scenario: in=[" . join(', ', map "'$_'", @$inputs) . "] exp=[$expected] got=[$got]"; + is($got, $expected, $descr); +}