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