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