ext/Cwd/t/cwd.t

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