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