--- t/abs_path.t (/vendor/PathTools) (revision 54975)
+++ t/abs_path.t (/local/PathTools) (revision 54975)
@@ -0,0 +1,108 @@
+#!./perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+use Cwd;
+chdir 't';
+
+use strict;
+use Carp;
+use Carp::Heavy; # because we chdir around later and it won't be found
+use Config;
+use File::Spec;
+BEGIN { package FS; our @ISA = qw(File::Spec) }
+use File::Path;
+
+use lib FS->catdir('t', 'lib');
+require VMS::Filespec if $^O eq 'VMS';
+
+use Test::More;
+
+sub cmp_path {
+ my($got, $expected, $name) = @_;
+
+ $expected = File::Spec->catdir(@$expected) if defined $expected;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ return is lc $got, lc $expected, $name;
+}
+
+# Set up the environment.
+my $starting_wd = Cwd::abs_path();
+my $x_but_no_r = 'x_but_no_r';
+my $test_dir = 'testdir';
+my $sub_dir = 'subdir';
+my $test_path = FS->catdir($x_but_no_r, $test_dir);
+my $sub_path = FS->catdir($test_path, $sub_dir);
+
+my $build_environment = eval {
+ mkpath($sub_path) or die;
+ chmod 0100, $x_but_no_r or die;
+
+ !opendir(my $dh, $x_but_no_r) or die;
+ chdir $x_but_no_r or die;
+ chdir $test_dir or die;
+};
+END {
+ chdir $starting_wd;
+ chmod 0700, $x_but_no_r;
+ rmtree $x_but_no_r;
+}
+
+if( !$build_environment ) {
+ plan skip_all =>
+ "restricted permission test environment could not be made"
+}
+else {
+ plan 'no_plan';
+}
+
+
+my %funcs = (
+ abs_path => \&Cwd::abs_path,
+ _perl_abs_path => \&Cwd::_perl_abs_path,
+);
+for my $name (sort keys %funcs) {
+ my $func = $funcs{$name};
+
+ cmp_path $func->(), [$starting_wd, $test_path], "$name w/no args";
+ cmp_path $func->($sub_dir), [$starting_wd, $sub_path], "$name w/subdir";
+
+ # All but the last component of pathname must exist when realpath()
+ # is called. -- BSD realpath man page.
+ my $dne_path = FS->catdir($test_path, "dne");
+ cmp_path $func->("dne"), [$starting_wd, $dne_path],
+ "$name w/non-existant filename";
+
+ my $double_dne = FS->catdir("dne", "sub_dne");
+ cmp_path $func->($double_dne), undef, "$name w/non-existant sub dir";
+
+ ok chdir $starting_wd;
+ cmp_path $func->("../t"), [$starting_wd];
+ cmp_path $func->("../t/../t"), [$starting_wd];
+ cmp_path $func->("../t/dne"), [$starting_wd, 'dne'];
+ cmp_path $func->('abs_path.t'), [$starting_wd, 'abs_path.t'],
+ "$name works on files";
+
+ ok chdir $x_but_no_r, 'chdir to the unreadable directory';
+ cmp_path $func->(), [$starting_wd, $x_but_no_r],
+ "$name when cwd unreadable";
+ ok chdir $test_dir, 'chdir back to the test dir';
+
+ cmp_path $func->(".."), [$starting_wd, $x_but_no_r];
+
+ TODO: {
+ local $TODO = '_perl_abs_path does not fold .. yet'
+ if $name eq '_perl_abs_path';
+
+ cmp_path $func->("../$test_dir"),
+ [$starting_wd, $x_but_no_r, $test_dir];
+ }
+ cmp_path $func->("/"), ["/"];
+ cmp_path $func->("/does_not_exist"), ["/does_not_exist"];
+ cmp_path $func->("/foo/"), undef;
+}
--- MANIFEST (/vendor/PathTools) (revision 54975)
+++ MANIFEST (/local/PathTools) (revision 54975)
@@ -16,16 +16,17 @@
MANIFEST This list of files
META.yml
ppport.h
+t/abs_path.t
t/crossplatform.t
t/cwd.t
t/Functions.t
t/lib/Test/Builder.pm
t/lib/Test/More.pm
t/lib/Test/Simple.pm
t/rel2abs2rel.t
t/Spec.t
t/taint.t
t/tmpdir.t
t/win32.t
--- Cwd.pm (/vendor/PathTools) (revision 54975)
+++ Cwd.pm (/local/PathTools) (revision 54975)
@@ -498,41 +498,38 @@
}
+use File::Basename;
sub _perl_abs_path
{
my $start = @_ ? shift : '.';
- my($dotdots, $cwd, @pst, @cst, $dir, @tst);
- unless (@cst = stat( $start ))
- {
- _carp("stat($start): $!");
- return '';
+ # The last element of the path is allowed to not exist.
+ my $start_dir = $start;
+ my $start_file = '';
+ if( !-e $start_dir or !-d $start_dir ) {
+ ($start_file, $start_dir) = fileparse($start);
+ $start_file = '' if $start_file eq '.';
}
- unless (-d _) {
- # Make sure we can be invoked on plain files, not just directories.
- # NOTE that this routine assumes that '/' is the only directory separator.
-
- my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
- or return cwd() . '/' . $start;
-
- # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
if (-l $start) {
- my $link_target = readlink($start);
- die "Can't resolve link $start: $!" unless defined $link_target;
-
require File::Spec;
- $link_target = $dir . '/' . $link_target
- unless File::Spec->file_name_is_absolute($link_target);
+ my $link_target = readlink( File::Spec->canonpath($start) );
+ die "Can't resolve link $start: $!" unless defined $link_target;
return abs_path($link_target);
}
- return $dir ? abs_path($dir) . "/$file" : "/$file";
+ my(@pst, @cst, @tst);
+
+ unless (@cst = stat( $start_dir ))
+ {
+ _carp("stat($start_dir): $!");
+ return undef;
}
- $cwd = '';
- $dotdots = $start;
+ my $cwd = '';
+ my $dotdots = $start_dir;
+ my $dir;
do
{
$dotdots .= '/..';
@@ -541,7 +538,8 @@
unless (opendir(PARENT, $dotdots))
{
# probably a permissions issue. Try the native command.
- return File::Spec->rel2abs( $start, _backtick_pwd() );
+ require File::Spec;
+ return File::Spec->rel2abs( $start, _backtick_pwd() )
}
unless (@cst = stat($dotdots))
{
@@ -571,8 +569,10 @@
$cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
closedir(PARENT);
} while (defined $dir);
- chop($cwd) unless $cwd eq '/'; # drop the trailing /
- $cwd;
+
+ chop($cwd) if $cwd ne '/' and !$start_file;
+ $cwd .= "$start_file" if $start_file;
+ return $cwd;
}
