X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FCwd%2Ft%2Fcwd.t;h=2c7d6c5598cec1eea7814b95e7390e7d01939c2c;hb=275e8705031e539ec9999f68482039d1bcfb1608;hp=09b45d600488e531543d506672cc7245e9a4d1de;hpb=ea7154893ee587d7e47bcebff9e70757b48a38bd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Cwd/t/cwd.t b/ext/Cwd/t/cwd.t index 09b45d6..2c7d6c5 100644 --- a/ext/Cwd/t/cwd.t +++ b/ext/Cwd/t/cwd.t @@ -2,26 +2,34 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + if ($ENV{PERL_CORE}) { + @INC = '../lib'; + } } +use Cwd; use Config; -use Cwd; use strict; use warnings; +use File::Spec; +use File::Path; + +use Test::More; + +my $tests = 24; +my $EXTRA_ABSPATH_TESTS = $ENV{PERL_CORE} || $ENV{TEST_PERL_CWD_CODE}; +$tests += 3 if $EXTRA_ABSPATH_TESTS; +plan tests => $tests; -print "1..14\n"; +my $IsVMS = $^O eq 'VMS'; +my $IsMacOS = $^O eq 'MacOS'; # check imports -print +(defined(&cwd) && - defined(&getcwd) && - defined(&fastcwd) && - defined(&fastgetcwd) ? - "" : "not "), "ok 1\n"; -print +(!defined(&chdir) && - !defined(&abs_path) && - !defined(&fast_abs_path) ? - "" : "not "), "ok 2\n"; +can_ok('main', qw(cwd getcwd fastcwd fastgetcwd)); +ok( !defined(&chdir), 'chdir() not exported by default' ); +ok( !defined(&abs_path), ' nor abs_path()' ); +ok( !defined(&fast_abs_path), ' nor fast_abs_path()'); + # XXX force Cwd to bootsrap its XSUBs since we have set @INC = "../lib" # XXX and subsequent chdir()s can make them impossible to find @@ -29,106 +37,161 @@ eval { fastcwd }; # Must find an external pwd (or equivalent) command. +my $pwd = $^O eq 'MSWin32' ? "cmd" : "pwd"; my $pwd_cmd = - ($^O eq "MSWin32" || $^O eq "NetWare") ? "cd" : (grep { -x && -f } map { "$_/pwd" } - split m/$Config{path_sep}/, $ENV{PATH})[0]; + ($^O eq "NetWare") ? + "cd" : + ($IsMacOS) ? + "pwd" : + (grep { -x && -f } map { "$_/$pwd$Config{exe_ext}" } + split m/$Config{path_sep}/, $ENV{PATH})[0]; + +$pwd_cmd = 'SHOW DEFAULT' if $IsVMS; +if ($^O eq 'MSWin32') { + $pwd_cmd =~ s,/,\\,g; + $pwd_cmd = "$pwd_cmd /c cd"; +} +$pwd_cmd =~ s=\\=/=g if ($^O eq 'dos'); + +SKIP: { + skip "No native pwd command found to test against", 4 unless $pwd_cmd; + + print "# native pwd = '$pwd_cmd'\n"; -if ($^O eq 'VMS') { $pwd_cmd = 'SHOW DEFAULT'; } + local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; + my ($pwd_cmd_untainted) = $pwd_cmd =~ /^(.+)$/; # Untaint. + chomp(my $start = `$pwd_cmd_untainted`); -if (defined $pwd_cmd) { - chomp(my $start = `$pwd_cmd`); # Win32's cd returns native C:\ style $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare"); # DCL SHOW DEFAULT has leading spaces - $start =~ s/^\s+// if $^O eq 'VMS'; - if ($?) { - for (3..6) { - print "ok $_ # Skip: '$pwd_cmd' failed\n"; - } - } else { + $start =~ s/^\s+// if $IsVMS; + SKIP: { + skip("'$pwd_cmd' failed, nothing to test against", 4) if $?; + skip("/afs seen, paths unlikely to match", 4) if $start =~ m|/afs/|; + + # Darwin's getcwd(3) (which Cwd.xs:bsd_realpath() uses which + # Cwd.pm:getcwd uses) has some magic related to the PWD + # environment variable: if PWD is set to a directory that + # looks about right (guess: has the same (dev,ino) as the '.'?), + # the PWD is returned. However, if that path contains + # symlinks, the path will not be equal to the one returned by + # /bin/pwd (which probably uses the usual walking upwards in + # the path -trick). This situation is easy to reproduce since + # /tmp is a symlink to /private/tmp. Therefore we invalidate + # the PWD to force getcwd(3) to (re)compute the cwd in full. + # Admittedly fixing this in the Cwd module would be better + # long-term solution but deleting $ENV{PWD} should not be + # done light-heartedly. --jhi + delete $ENV{PWD} if $^O eq 'darwin'; + my $cwd = cwd; my $getcwd = getcwd; my $fastcwd = fastcwd; my $fastgetcwd = fastgetcwd; - print +($cwd eq $start ? "" : "not "), "ok 3\n"; - print +($getcwd eq $start ? "" : "not "), "ok 4\n"; - print +($fastcwd eq $start ? "" : "not "), "ok 5\n"; - print +($fastgetcwd eq $start ? "" : "not "), "ok 6\n"; - } -} else { - for (3..6) { - print "ok $_ # Skip: no pwd command found\n"; + + is($cwd, $start, 'cwd()'); + is($getcwd, $start, 'getcwd()'); + is($fastcwd, $start, 'fastcwd()'); + is($fastgetcwd, $start, 'fastgetcwd()'); } } -mkdir "pteerslt", 0777; -mkdir "pteerslt/path", 0777; -mkdir "pteerslt/path/to", 0777; -mkdir "pteerslt/path/to/a", 0777; -mkdir "pteerslt/path/to/a/dir", 0777; -Cwd::chdir "pteerslt/path/to/a/dir"; -my $cwd = cwd; -my $getcwd = getcwd; -my $fastcwd = fastcwd; -my $fastgetcwd = fastgetcwd; -my $want = "t/pteerslt/path/to/a/dir"; -print "# cwd = '$cwd'\n"; -print "# getcwd = '$getcwd'\n"; -print "# fastcwd = '$fastcwd'\n"; -print "# fastgetcwd = '$fastgetcwd'\n"; -# This checked out OK on ODS-2 and ODS-5: -$want = "T\.PTEERSLT\.PATH\.TO\.A\.DIR\]" if $^O eq 'VMS'; -print +($cwd =~ m|$want$| ? "" : "not "), "ok 7\n"; -print +($getcwd =~ m|$want$| ? "" : "not "), "ok 8\n"; -print +($fastcwd =~ m|$want$| ? "" : "not "), "ok 9\n"; -print +($fastgetcwd =~ m|$want$| ? "" : "not "), "ok 10\n"; +my @test_dirs = qw{_ptrslt_ _path_ _to_ _a_ _dir_}; +my $Test_Dir = File::Spec->catdir(@test_dirs); + +mkpath([$Test_Dir], 0, 0777); +Cwd::chdir $Test_Dir; + +foreach my $func (qw(cwd getcwd fastcwd fastgetcwd)) { + my $result = eval "$func()"; + is $@, ''; + dir_ends_with( $result, $Test_Dir, "$func()" ); +} # Cwd::chdir should also update $ENV{PWD} +dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' ); +my $updir = File::Spec->updir; +Cwd::chdir $updir; print "#$ENV{PWD}\n"; -print +($ENV{PWD} =~ m|$want$| ? "" : "not "), "ok 11\n"; -Cwd::chdir ".."; rmdir "dir"; +Cwd::chdir $updir; print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "a"; +Cwd::chdir $updir; print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "to"; +Cwd::chdir $updir; print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "path"; +Cwd::chdir $updir; print "#$ENV{PWD}\n"; -Cwd::chdir ".."; rmdir "pteerslt"; -print "#$ENV{PWD}\n"; -if ($^O eq 'VMS') { - # This checked out OK on ODS-2 and ODS-5: - print +($ENV{PWD} =~ m|\bT\]$| ? "" : "not "), "ok 12\n"; -} -else { - print +($ENV{PWD} =~ m|\bt$| ? "" : "not "), "ok 12\n"; + +rmtree($test_dirs[0], 0, 0); + +{ + my $check = ($IsVMS ? qr|\b((?i)t)\]$| : + $IsMacOS ? qr|\bt:$| : + qr|\bt$| ); + + like($ENV{PWD}, $check); } -if ($Config{d_symlink}) { - mkdir "pteerslt", 0777; - mkdir "pteerslt/path", 0777; - mkdir "pteerslt/path/to", 0777; - mkdir "pteerslt/path/to/a", 0777; - mkdir "pteerslt/path/to/a/dir", 0777; - symlink "pteerslt/path/to/a/dir" => "linktest"; +SKIP: { + skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink}; + + mkpath([$Test_Dir], 0, 0777); + symlink $Test_Dir, "linktest"; my $abs_path = Cwd::abs_path("linktest"); my $fast_abs_path = Cwd::fast_abs_path("linktest"); - my $want = "t/pteerslt/path/to/a/dir"; - - print "# abs_path $abs_path\n"; - print "# fast_abs_path $fast_abs_path\n"; - print "# want $want\n"; - print +($abs_path =~ m|$want$| ? "" : "not "), "ok 13\n"; - print +($fast_abs_path =~ m|$want$| ? "" : "not "), "ok 14\n"; - - rmdir "pteerslt/path/to/a/dir"; - rmdir "pteerslt/path/to/a"; - rmdir "pteerslt/path/to"; - rmdir "pteerslt/path"; - rmdir "pteerslt"; + my $want = File::Spec->catdir("t", $Test_Dir); + + like($abs_path, qr|$want$|); + like($fast_abs_path, qr|$want$|); + like(Cwd::_perl_abs_path("linktest"), qr|$want$|) if $EXTRA_ABSPATH_TESTS; + + rmtree($test_dirs[0], 0, 0); unlink "linktest"; -} else { - print "ok 13 # skipped\n"; - print "ok 14 # skipped\n"; +} + +if ($ENV{PERL_CORE}) { + chdir '../ext/Cwd/t'; + unshift @INC, '../../../lib'; +} + +# Make sure we can run abs_path() on files, not just directories +my $path = 'cwd.t'; +path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file'); +path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file'); +path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file') + if $EXTRA_ABSPATH_TESTS; + +$path = File::Spec->catfile(File::Spec->updir, 't', $path); +path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file'); +path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file'); +path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file') + if $EXTRA_ABSPATH_TESTS; + + +############################################# +# These routines give us sort of a poor-man's cross-platform +# directory or path comparison capability. + +sub bracketed_form_dir { + return join '', map "[$_]", + grep length, File::Spec->splitdir(File::Spec->canonpath( shift() )); +} + +sub dir_ends_with { + my ($dir, $expect) = (shift, shift); + my $bracketed_expect = quotemeta bracketed_form_dir($expect); + like( bracketed_form_dir($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) ); +} + +sub bracketed_form_path { + return join '', map "[$_]", + grep length, File::Spec->splitpath(File::Spec->canonpath( shift() )); +} + +sub path_ends_with { + my ($dir, $expect) = (shift, shift); + my $bracketed_expect = quotemeta bracketed_form_path($expect); + like( bracketed_form_path($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) ); }