1#!./perl -w 2 3BEGIN { 4 if ($ENV{PERL_CORE}) { 5 chdir 't'; 6 @INC = '../lib'; 7 } 8} 9use Cwd; 10chdir 't'; 11 12use strict; 13use Config; 14use File::Spec; 15use File::Path; 16 17use lib File::Spec->catdir('t', 'lib'); 18use Test::More; 19require VMS::Filespec if $^O eq 'VMS'; 20 21my $tests = 30; 22# _perl_abs_path() currently only works when the directory separator 23# is '/', so don't test it when it won't work. 24my $EXTRA_ABSPATH_TESTS = ($Config{prefix} =~ m/\//) && $^O ne 'cygwin'; 25$tests += 4 if $EXTRA_ABSPATH_TESTS; 26plan tests => $tests; 27 28SKIP: { 29 skip "no need to check for blib/ in the core", 1 if $ENV{PERL_CORE}; 30 like $INC{'Cwd.pm'}, qr{blib}i, "Cwd should be loaded from blib/ during testing"; 31} 32 33my $IsVMS = $^O eq 'VMS'; 34my $IsMacOS = $^O eq 'MacOS'; 35 36# check imports 37can_ok('main', qw(cwd getcwd fastcwd fastgetcwd)); 38ok( !defined(&chdir), 'chdir() not exported by default' ); 39ok( !defined(&abs_path), ' nor abs_path()' ); 40ok( !defined(&fast_abs_path), ' nor fast_abs_path()'); 41 42{ 43 my @fields = qw(PATH IFS CDPATH ENV BASH_ENV); 44 my $before = grep exists $ENV{$_}, @fields; 45 cwd(); 46 my $after = grep exists $ENV{$_}, @fields; 47 is($before, $after, "cwd() shouldn't create spurious entries in %ENV"); 48} 49 50# XXX force Cwd to bootsrap its XSUBs since we have set @INC = "../lib" 51# XXX and subsequent chdir()s can make them impossible to find 52eval { fastcwd }; 53 54# Must find an external pwd (or equivalent) command. 55 56my $pwd = $^O eq 'MSWin32' ? "cmd" : "pwd"; 57my $pwd_cmd = 58 ($^O eq "NetWare") ? 59 "cd" : 60 ($IsMacOS) ? 61 "pwd" : 62 (grep { -x && -f } map { "$_/$pwd$Config{exe_ext}" } 63 split m/$Config{path_sep}/, $ENV{PATH})[0]; 64 65$pwd_cmd = 'SHOW DEFAULT' if $IsVMS; 66if ($^O eq 'MSWin32') { 67 $pwd_cmd =~ s,/,\\,g; 68 $pwd_cmd = "$pwd_cmd /c cd"; 69} 70$pwd_cmd =~ s=\\=/=g if ($^O eq 'dos'); 71 72SKIP: { 73 skip "No native pwd command found to test against", 4 unless $pwd_cmd; 74 75 print "# native pwd = '$pwd_cmd'\n"; 76 77 local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; 78 my ($pwd_cmd_untainted) = $pwd_cmd =~ /^(.+)$/; # Untaint. 79 chomp(my $start = `$pwd_cmd_untainted`); 80 81 # Win32's cd returns native C:\ style 82 $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare"); 83 # DCL SHOW DEFAULT has leading spaces 84 $start =~ s/^\s+// if $IsVMS; 85 SKIP: { 86 skip("'$pwd_cmd' failed, nothing to test against", 4) if $?; 87 skip("/afs seen, paths unlikely to match", 4) if $start =~ m|/afs/|; 88 89 # Darwin's getcwd(3) (which Cwd.xs:bsd_realpath() uses which 90 # Cwd.pm:getcwd uses) has some magic related to the PWD 91 # environment variable: if PWD is set to a directory that 92 # looks about right (guess: has the same (dev,ino) as the '.'?), 93 # the PWD is returned. However, if that path contains 94 # symlinks, the path will not be equal to the one returned by 95 # /bin/pwd (which probably uses the usual walking upwards in 96 # the path -trick). This situation is easy to reproduce since 97 # /tmp is a symlink to /private/tmp. Therefore we invalidate 98 # the PWD to force getcwd(3) to (re)compute the cwd in full. 99 # Admittedly fixing this in the Cwd module would be better 100 # long-term solution but deleting $ENV{PWD} should not be 101 # done light-heartedly. --jhi 102 delete $ENV{PWD} if $^O eq 'darwin'; 103 104 my $cwd = cwd; 105 my $getcwd = getcwd; 106 my $fastcwd = fastcwd; 107 my $fastgetcwd = fastgetcwd; 108 109 is($cwd, $start, 'cwd()'); 110 is($getcwd, $start, 'getcwd()'); 111 is($fastcwd, $start, 'fastcwd()'); 112 is($fastgetcwd, $start, 'fastgetcwd()'); 113 } 114} 115 116my @test_dirs = qw{_ptrslt_ _path_ _to_ _a_ _dir_}; 117my $Test_Dir = File::Spec->catdir(@test_dirs); 118 119mkpath([$Test_Dir], 0, 0777); 120Cwd::chdir $Test_Dir; 121 122foreach my $func (qw(cwd getcwd fastcwd fastgetcwd)) { 123 my $result = eval "$func()"; 124 is $@, ''; 125 dir_ends_with( $result, $Test_Dir, "$func()" ); 126} 127 128{ 129 # Some versions of File::Path (e.g. that shipped with perl 5.8.5) 130 # call getcwd() with an argument (perhaps by calling it as a 131 # method?), so make sure that doesn't die. 132 is getcwd(), getcwd('foo'), "Call getcwd() with an argument"; 133} 134 135# Cwd::chdir should also update $ENV{PWD} 136dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' ); 137my $updir = File::Spec->updir; 138Cwd::chdir $updir; 139print "#$ENV{PWD}\n"; 140Cwd::chdir $updir; 141print "#$ENV{PWD}\n"; 142Cwd::chdir $updir; 143print "#$ENV{PWD}\n"; 144Cwd::chdir $updir; 145print "#$ENV{PWD}\n"; 146Cwd::chdir $updir; 147print "#$ENV{PWD}\n"; 148 149rmtree($test_dirs[0], 0, 0); 150 151{ 152 my $check = ($IsVMS ? qr|\b((?i)t)\]$| : 153 $IsMacOS ? qr|\bt:$| : 154 qr|\bt$| ); 155 156 like($ENV{PWD}, $check); 157} 158 159{ 160 # Make sure abs_path() doesn't trample $ENV{PWD} 161 my $start_pwd = $ENV{PWD}; 162 mkpath([$Test_Dir], 0, 0777); 163 Cwd::abs_path($Test_Dir); 164 is $ENV{PWD}, $start_pwd; 165 rmtree($test_dirs[0], 0, 0); 166} 167 168SKIP: { 169 skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink}; 170 171 mkpath([$Test_Dir], 0, 0777); 172 symlink $Test_Dir, "linktest"; 173 174 my $abs_path = Cwd::abs_path("linktest"); 175 my $fast_abs_path = Cwd::fast_abs_path("linktest"); 176 my $want = File::Spec->catdir("t", $Test_Dir); 177 178 like($abs_path, qr|$want$|); 179 like($fast_abs_path, qr|$want$|); 180 like(Cwd::_perl_abs_path("linktest"), qr|$want$|) if $EXTRA_ABSPATH_TESTS; 181 182 rmtree($test_dirs[0], 0, 0); 183 unlink "linktest"; 184} 185 186if ($ENV{PERL_CORE}) { 187 chdir '../ext/Cwd/t'; 188 unshift @INC, '../../../lib'; 189} 190 191# Make sure we can run abs_path() on files, not just directories 192my $path = 'cwd.t'; 193path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file'); 194path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file'); 195path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file') 196 if $EXTRA_ABSPATH_TESTS; 197 198$path = File::Spec->catfile(File::Spec->updir, 't', $path); 199path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file'); 200path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file'); 201path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file') 202 if $EXTRA_ABSPATH_TESTS; 203 204 205 206SKIP: { 207 my $file; 208 { 209 my $root = Cwd::abs_path(File::Spec->rootdir); # Add drive letter? 210 local *FH; 211 opendir FH, $root or skip("Can't opendir($root): $!", 2+$EXTRA_ABSPATH_TESTS); 212 ($file) = grep {-f $_ and not -l $_} map File::Spec->catfile($root, $_), readdir FH; 213 closedir FH; 214 } 215 skip "No plain file in root directory to test with", 2+$EXTRA_ABSPATH_TESTS unless $file; 216 217 $file = VMS::Filespec::rmsexpand($file) if $^O eq 'VMS'; 218 is Cwd::abs_path($file), $file, 'abs_path() works on files in the root directory'; 219 is Cwd::fast_abs_path($file), $file, 'fast_abs_path() works on files in the root directory'; 220 is Cwd::_perl_abs_path($file), $file, '_perl_abs_path() works on files in the root directory' 221 if $EXTRA_ABSPATH_TESTS; 222} 223 224 225############################################# 226# These routines give us sort of a poor-man's cross-platform 227# directory or path comparison capability. 228 229sub bracketed_form_dir { 230 return join '', map "[$_]", 231 grep length, File::Spec->splitdir(File::Spec->canonpath( shift() )); 232} 233 234sub dir_ends_with { 235 my ($dir, $expect) = (shift, shift); 236 my $bracketed_expect = quotemeta bracketed_form_dir($expect); 237 like( bracketed_form_dir($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) ); 238} 239 240sub bracketed_form_path { 241 return join '', map "[$_]", 242 grep length, File::Spec->splitpath(File::Spec->canonpath( shift() )); 243} 244 245sub path_ends_with { 246 my ($dir, $expect) = (shift, shift); 247 my $bracketed_expect = quotemeta bracketed_form_path($expect); 248 like( bracketed_form_path($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) ); 249} 250