This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix missing skip counts in PathTools' cwd.t
[perl5.git] / dist / PathTools / t / cwd.t
CommitLineData
99f36a73 1#!./perl -w
ed4a5f99 2
2adbc9b6
NC
3use strict;
4
78321866 5use Cwd;
2adbc9b6 6
99f36a73 7chdir 't';
cb8c8458 8@INC = '../../../lib' if $ENV{PERL_CORE};
ed4a5f99 9
99f36a73 10use Config;
e69a2255 11use File::Spec;
1279e177 12use File::Path;
ed4a5f99 13
99f36a73 14use lib File::Spec->catdir('t', 'lib');
275e8705 15use Test::More;
53e80d0b
JM
16
17my $IsVMS = $^O eq 'VMS';
53e80d0b
JM
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}
275e8705 39
52ee8d0a 40my $tests = 31;
14815b0c
RGS
41# _perl_abs_path() currently only works when the directory separator
42# is '/', so don't test it when it won't work.
99f36a73
RGS
43my $EXTRA_ABSPATH_TESTS = ($Config{prefix} =~ m/\//) && $^O ne 'cygwin';
44$tests += 4 if $EXTRA_ABSPATH_TESTS;
275e8705 45plan tests => $tests;
ca7ced35 46
99f36a73 47SKIP: {
b04f6d36
RGS
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";
99f36a73
RGS
50}
51
ed4a5f99
BS
52
53# check imports
ca7ced35
MS
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
f6342b4b
RGS
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}
ed4a5f99 66
c4a6f826 67# XXX force Cwd to bootstrap its XSUBs since we have set @INC = "../lib"
0d2079fa
BS
68# XXX and subsequent chdir()s can make them impossible to find
69eval { fastcwd };
70
da3f15f4
JH
71# Must find an external pwd (or equivalent) command.
72
38f52085 73my $pwd = $^O eq 'MSWin32' ? "cmd" : "pwd";
da3f15f4 74my $pwd_cmd =
38f52085 75 ($^O eq "NetWare") ?
023b4a43 76 "cd" :
38f52085 77 (grep { -x && -f } map { "$_/$pwd$Config{exe_ext}" }
023b4a43 78 split m/$Config{path_sep}/, $ENV{PATH})[0];
da3f15f4 79
ca7ced35 80$pwd_cmd = 'SHOW DEFAULT' if $IsVMS;
38f52085
GS
81if ($^O eq 'MSWin32') {
82 $pwd_cmd =~ s,/,\\,g;
83 $pwd_cmd = "$pwd_cmd /c cd";
84}
e8f7eed0
JH
85$pwd_cmd =~ s=\\=/=g if ($^O eq 'dos');
86
ca7ced35
MS
87SKIP: {
88 skip "No native pwd command found to test against", 4 unless $pwd_cmd;
2390ecbc 89
d80cbc32
JH
90 print "# native pwd = '$pwd_cmd'\n";
91
926cbafe
JH
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
14107c42 96 # Win32's cd returns native C:\ style
2986a63f 97 $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare");
53e80d0b
JM
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 }
ca7ced35 109 SKIP: {
12b7537a
JH
110 skip("'$pwd_cmd' failed, nothing to test against", 4) if $?;
111 skip("/afs seen, paths unlikely to match", 4) if $start =~ m|/afs/|;
ca7ced35 112
164336fe
JH
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
da3f15f4
JH
128 my $cwd = cwd;
129 my $getcwd = getcwd;
130 my $fastcwd = fastcwd;
131 my $fastgetcwd = fastgetcwd;
12b7537a 132
1c26fec0
JH
133 is($cwd, $start, 'cwd()');
134 is($getcwd, $start, 'getcwd()');
135 is($fastcwd, $start, 'fastcwd()');
136 is($fastgetcwd, $start, 'fastgetcwd()');
da3f15f4
JH
137 }
138}
139
ea067225
RGS
140my @test_dirs = qw{_ptrslt_ _path_ _to_ _a_ _dir_};
141my $Test_Dir = File::Spec->catdir(@test_dirs);
ca7ced35 142
889f7a4f
RGS
143mkpath([$Test_Dir], 0, 0777);
144Cwd::chdir $Test_Dir;
ca7ced35 145
ad78113d
RGS
146foreach my $func (qw(cwd getcwd fastcwd fastgetcwd)) {
147 my $result = eval "$func()";
148 is $@, '';
ea067225 149 dir_ends_with( $result, $Test_Dir, "$func()" );
ad78113d 150}
ed4a5f99 151
23bb49fa
SP
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
ed4a5f99 159# Cwd::chdir should also update $ENV{PWD}
ea067225 160dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' );
e69a2255 161my $updir = File::Spec->updir;
bf7c0a3d
SP
162
163for (1..@test_dirs) {
164 Cwd::chdir $updir;
165 print "#$ENV{PWD}\n";
166}
1279e177 167
ea067225 168rmtree($test_dirs[0], 0, 0);
1279e177 169
889f7a4f 170{
53e80d0b 171 my $check = ($vms_mode ? qr|\b((?i)t)\]$| :
53e80d0b 172 qr|\bt$| );
889f7a4f
RGS
173
174 like($ENV{PWD}, $check);
2390ecbc 175}
ed4a5f99 176
99f36a73
RGS
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
ca7ced35 186SKIP: {
1662bcf4 187 skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink} && $^O !~ m!^(qnx|nto)!;
ca7ced35 188
fa89a9ae 189 my $file = "linktest";
ca7ced35 190 mkpath([$Test_Dir], 0, 0777);
fa89a9ae 191 symlink $Test_Dir, $file;
7040f5d5 192
fa89a9ae
NC
193 my $abs_path = Cwd::abs_path($file);
194 my $fast_abs_path = Cwd::fast_abs_path($file);
53e80d0b
JM
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 }
7040f5d5 207
61729915
CB
208 like($abs_path, qr|$want$|i);
209 like($fast_abs_path, qr|$want$|i);
fa89a9ae 210 like(Cwd::_perl_abs_path($file), qr|$want$|i) if $EXTRA_ABSPATH_TESTS;
7040f5d5 211
ea067225 212 rmtree($test_dirs[0], 0, 0);
fa89a9ae 213 1 while unlink $file;
ed4a5f99 214}
ea067225 215
78321866
RGS
216# Make sure we can run abs_path() on files, not just directories
217my $path = 'cwd.t';
9d7d9729
CB
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');
275e8705
RGS
220path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
221 if $EXTRA_ABSPATH_TESTS;
78321866
RGS
222
223$path = File::Spec->catfile(File::Spec->updir, 't', $path);
9d7d9729
CB
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');
275e8705
RGS
226path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
227 if $EXTRA_ABSPATH_TESTS;
78321866
RGS
228
229
99f36a73
RGS
230
231SKIP: {
232 my $file;
233 {
f5f48b4d 234 my $root = Cwd::abs_path(File::Spec->rootdir); # Add drive letter?
99f36a73
RGS
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
52ee8d0a
FC
249SKIP: {
250 my $dir = "${$}a\nx";
0cdc775e
DIM
251 mkdir $dir or skip "OS does not support dir names containing LF", 1;
252 chdir $dir or skip "OS cannot chdir into LF", 1;
52ee8d0a
FC
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
99f36a73 259
ea067225 260#############################################
9d7d9729
CB
261# These routines give us sort of a poor-man's cross-platform
262# directory or path comparison capability.
ea067225 263
9d7d9729 264sub bracketed_form_dir {
ea067225
RGS
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);
9d7d9729
CB
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 : ()) );
ea067225 284}