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