如何检查一个路径是否是perl中另一个路径的子路径？

Question

这个问题在其他语言中有一些答案。我是 perl 的新手，我正在这样做（比较字符串比使用文件系统函数更多）：

use File::Spec;

sub has_common_prefix {
  my ($path, $subpath) = @_;
  $path = uc (File::Spec->canonpath($path))."\";
  $subpath = uc (File::Spec->canonpath($subpath));

  if ( substr($subpath, 0, length($path)) eq $path ) return 1;
  return 0;
};

has_common_prefix('c:\/abCD/EFgh', 'C:\abcd\efgh/ijk.txt');

我想知道是否有更好的方法来做到这一点，还有更多"perlisch" :-)

谢谢。

Answer 1

好吧，我破解了这个，但我并不为此感到自豪，我希望有人想出更好的东西。我搜索了 CPAN，但很惊讶没有找到任何相关内容

我的想法是使用 File::Spec::Functions 中的 abs2rel 函数。没关系，只是它为此目的太过努力，并且 return ../.. abs2rel('/usr', '/usr/a/b')。它还将 return 在使用路径中的卷的系统上保持第一个值不变

这只是将 abs2rel 包装在一个函数 is_within 中，该函数拒绝这两种情况，但 return 的相对路径（真值）完好无损。这意味着 is within('/usr', '/usr') 将 return .，这是事实，但如果您认为目录不应该包含自身

，则可以针对特定情况对其进行测试

注意这不会检查路径是否指向目录，也不检查路径是否存在

use strict;
use warnings 'all';

use File::Spec::Functions qw/ abs2rel  file_name_is_absolute  updir /;

my @pairs = (
    [qw{ /usr      /usr/bin } ],
    [qw{ /usr/etc  /usr/bin } ],
    [qw{ /var      /usr/bin } ],
    [qw{ /usr/bin  /usr/bin } ],
);

for ( @pairs ) {
    my ($path, $subpath) = @$_;
    my $within = is_within($subpath, $path);
    printf qq{"%s" is %swithin "%s"  (%s)\n},
            $subpath,
            ($within ? '' : 'not '),
            $path,
            $within // 'undef';
}


sub is_within {
    my ($path, $container) = @_;

    my $a2r = abs2rel($path, $container);

    return if file_name_is_absolute($a2r) or index($a2r, updir) == 0;

    $a2r;
}

产出

"/usr/bin" is within "/usr"  (bin)
"/usr/bin" is not within "/usr/etc"  (undef)
"/usr/bin" is not within "/var"  (undef)
"/usr/bin" is within "/usr/bin"  (.)

Answer 2

File::Spec 及其替代品 Path::Class 不涉及文件系统，因此它们不处理大小写差异，也不处理短格式和长格式。

use Path::Class qw( dir file );
use Win32       qw( );

sub subsumes {
   my $dir  = dir(Win32::GetLongPathName($_[0]));
   my $file = file(Win32::GetLongPathName($_[1]));
   return $dir->subsumes($file);
}

如何检查一个路径是否是perl中另一个路径的子路径？

How to check if a path is a subpath of an other in perl?

filesystems

perl

产出