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