ext/Cwd/t/cwd.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use Config;
   9 use Cwd;
  10 use strict;
  11 use warnings;
  12 use File::Spec;
  13 use File::Path;
  14
  15 use Test::More tests => 16;
  16
  17 my $IsVMS = $^O eq 'VMS';
  18 my $IsMacOS = $^O eq 'MacOS';
  19
  20 # check imports
  21 can_ok('main', qw(cwd getcwd fastcwd fastgetcwd));
  22 ok( !defined(&chdir),           'chdir() not exported by default' );
  23 ok( !defined(&abs_path),        '  nor abs_path()' );
  24 ok( !defined(&fast_abs_path),   '  nor fast_abs_path()');
  25
  26
  27 # XXX force Cwd to bootsrap its XSUBs since we have set @INC = "../lib"
  28 # XXX and subsequent chdir()s can make them impossible to find
  29 eval { fastcwd };
  30
  31 # Must find an external pwd (or equivalent) command.
  32
  33 my $pwd = $^O eq 'MSWin32' ? "cmd" : "pwd";
  34 my $pwd_cmd =
  35     ($^O eq "NetWare") ?
  36         "cd" :
  37     ($IsMacOS) ?
  38         "pwd" :
  39         (grep { -x && -f } map { "$_/$pwd$Config{exe_ext}" }
  40                            split m/$Config{path_sep}/, $ENV{PATH})[0];
  41
  42 $pwd_cmd = 'SHOW DEFAULT' if $IsVMS;
  43 if ($^O eq 'MSWin32') {
  44     $pwd_cmd =~ s,/,\\,g;
  45     $pwd_cmd = "$pwd_cmd /c cd";
  46 }
  47 $pwd_cmd =~ s=\\=/=g if ($^O eq 'dos');
  48
  49 SKIP: {
  50     skip "No native pwd command found to test against", 4 unless $pwd_cmd;
  51
  52     print "# native pwd = '$pwd_cmd'\n";
  53
  54     local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
  55     my ($pwd_cmd_untainted) = $pwd_cmd =~ /^(.+)$/; # Untaint.
  56     chomp(my $start = `$pwd_cmd_untainted`);
  57
  58     # Win32's cd returns native C:\ style
  59     $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare");
  60     # DCL SHOW DEFAULT has leading spaces
  61     $start =~ s/^\s+// if $IsVMS;
  62     SKIP: {
  63         skip("'$pwd_cmd' failed, nothing to test against", 4) if $?;
  64         skip("/afs seen, paths unlikely to match", 4) if $start =~ m|/afs/|;
  65
  66         # Darwin's getcwd(3) (which Cwd.xs:bsd_realpath() uses which
  67         # Cwd.pm:getcwd uses) has some magic related to the PWD
  68         # environment variable: if PWD is set to a directory that
  69         # looks about right (guess: has the same (dev,ino) as the '.'?),
  70         # the PWD is returned.  However, if that path contains
  71         # symlinks, the path will not be equal to the one returned by
  72         # /bin/pwd (which probably uses the usual walking upwards in
  73         # the path -trick).  This situation is easy to reproduce since
  74         # /tmp is a symlink to /private/tmp.  Therefore we invalidate
  75         # the PWD to force getcwd(3) to (re)compute the cwd in full.
  76         # Admittedly fixing this in the Cwd module would be better
  77         # long-term solution but deleting $ENV{PWD} should not be
  78         # done light-heartedly. --jhi
  79         delete $ENV{PWD} if $^O eq 'darwin';
  80
  81         my $cwd        = cwd;
  82         my $getcwd     = getcwd;
  83         my $fastcwd    = fastcwd;
  84         my $fastgetcwd = fastgetcwd;
  85
  86         is($cwd,        $start, 'cwd()');
  87         is($getcwd,     $start, 'getcwd()');
  88         is($fastcwd,    $start, 'fastcwd()');
  89         is($fastgetcwd, $start, 'fastgetcwd()');
  90     }
  91 }
  92
  93 my $Top_Test_Dir = '_ptrslt_';
  94 my $Test_Dir     = "$Top_Test_Dir/_path_/_to_/_a_/_dir_";
  95 my $want = "t/$Test_Dir";
  96 if( $IsVMS ) {
  97     # translate the unixy path to VMSish
  98     $want =~ s|/|\.|g;
  99     $want .= '\]';
 100     $want = '((?i)' . $want . ')';  # might be ODS-2 or ODS-5
 101 } elsif ( $IsMacOS ) {
 102     $_ = ":$_" for ($Top_Test_Dir, $Test_Dir);
 103     s|/|:|g, s|$|:| for ($want, $Test_Dir);
 104 }
 105
 106 mkpath(["$Test_Dir"], 0, 0777);
 107 Cwd::chdir "$Test_Dir";
 108
 109 like(cwd(),        qr|$want$|, 'chdir() + cwd()');
 110 like(getcwd(),     qr|$want$|, '        + getcwd()');
 111 like(fastcwd(),    qr|$want$|, '        + fastcwd()');
 112 like(fastgetcwd(), qr|$want$|, '        + fastgetcwd()');
 113
 114 # Cwd::chdir should also update $ENV{PWD}
 115 like($ENV{PWD}, qr|$want$|,      'Cwd::chdir() updates $ENV{PWD}');
 116 my $updir = File::Spec->updir;
 117 Cwd::chdir $updir;
 118 print "#$ENV{PWD}\n";
 119 Cwd::chdir $updir;
 120 print "#$ENV{PWD}\n";
 121 Cwd::chdir $updir;
 122 print "#$ENV{PWD}\n";
 123 Cwd::chdir $updir;
 124 print "#$ENV{PWD}\n";
 125 Cwd::chdir $updir;
 126 print "#$ENV{PWD}\n";
 127
 128 rmtree([$Top_Test_Dir], 0, 0);
 129
 130 if ($IsVMS) {
 131     like($ENV{PWD}, qr|\b((?i)t)\]$|);
 132 }
 133 elsif ($IsMacOS) {
 134     like($ENV{PWD}, qr|\bt:$|);
 135 }
 136 else {
 137     like($ENV{PWD}, qr|\bt$|);
 138 }
 139
 140 SKIP: {
 141     skip "no symlinks on this platform", 2 unless $Config{d_symlink};
 142
 143     mkpath([$Test_Dir], 0, 0777);
 144     symlink $Test_Dir => "linktest";
 145
 146     my $abs_path      =  Cwd::abs_path("linktest");
 147     my $fast_abs_path =  Cwd::fast_abs_path("linktest");
 148     my $want          =  File::Spec->catdir("t", $Test_Dir);
 149
 150     like($abs_path,      qr|$want$|);
 151     like($fast_abs_path, qr|$want$|);
 152
 153     rmtree([$Top_Test_Dir], 0, 0);
 154     unlink "linktest";
 155 }