1#!./perl -w
2
3BEGIN {
4    if ($ENV{PERL_CORE}) {
5        chdir 't';
6        @INC = '../lib';
7    }
8}
9use Cwd;
10chdir 't';
11
12use strict;
13use Config;
14use File::Spec;
15use File::Path;
16
17use lib File::Spec->catdir('t', 'lib');
18use Test::More;
19require VMS::Filespec if $^O eq 'VMS';
20
21my $tests = 29;
22# _perl_abs_path() currently only works when the directory separator
23# is '/', so don't test it when it won't work.
24my $EXTRA_ABSPATH_TESTS = ($Config{prefix} =~ m/\//) && $^O ne 'cygwin';
25$tests += 4 if $EXTRA_ABSPATH_TESTS;
26plan tests => $tests;
27
28SKIP: {
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";
31}
32
33my $IsVMS = $^O eq 'VMS';
34my $IsMacOS = $^O eq 'MacOS';
35
36# check imports
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
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}
49
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
54# Must find an external pwd (or equivalent) command.
55
56my $pwd = $^O eq 'MSWin32' ? "cmd" : "pwd";
57my $pwd_cmd =
58    ($^O eq "NetWare") ?
59        "cd" :
60    ($IsMacOS) ?
61        "pwd" :
62        (grep { -x && -f } map { "$_/$pwd$Config{exe_ext}" }
63	                   split m/$Config{path_sep}/, $ENV{PATH})[0];
64
65$pwd_cmd = 'SHOW DEFAULT' if $IsVMS;
66if ($^O eq 'MSWin32') {
67    $pwd_cmd =~ s,/,\\,g;
68    $pwd_cmd = "$pwd_cmd /c cd";
69}
70$pwd_cmd =~ s=\\=/=g if ($^O eq 'dos');
71
72SKIP: {
73    skip "No native pwd command found to test against", 4 unless $pwd_cmd;
74
75    print "# native pwd = '$pwd_cmd'\n";
76
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
81    # Win32's cd returns native C:\ style
82    $start =~ s,\\,/,g if ($^O eq 'MSWin32' || $^O eq "NetWare");
83    # DCL SHOW DEFAULT has leading spaces
84    $start =~ s/^\s+// if $IsVMS;
85    SKIP: {
86        skip("'$pwd_cmd' failed, nothing to test against", 4) if $?;
87        skip("/afs seen, paths unlikely to match", 4) if $start =~ m|/afs/|;
88
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
104	my $cwd        = cwd;
105	my $getcwd     = getcwd;
106	my $fastcwd    = fastcwd;
107	my $fastgetcwd = fastgetcwd;
108
109	is($cwd,        $start, 'cwd()');
110	is($getcwd,     $start, 'getcwd()');
111	is($fastcwd,    $start, 'fastcwd()');
112	is($fastgetcwd, $start, 'fastgetcwd()');
113    }
114}
115
116my @test_dirs = qw{_ptrslt_ _path_ _to_ _a_ _dir_};
117my $Test_Dir     = File::Spec->catdir(@test_dirs);
118
119mkpath([$Test_Dir], 0, 0777);
120Cwd::chdir $Test_Dir;
121
122foreach my $func (qw(cwd getcwd fastcwd fastgetcwd)) {
123  my $result = eval "$func()";
124  is $@, '';
125  dir_ends_with( $result, $Test_Dir, "$func()" );
126}
127
128# Cwd::chdir should also update $ENV{PWD}
129dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' );
130my $updir = File::Spec->updir;
131Cwd::chdir $updir;
132print "#$ENV{PWD}\n";
133Cwd::chdir $updir;
134print "#$ENV{PWD}\n";
135Cwd::chdir $updir;
136print "#$ENV{PWD}\n";
137Cwd::chdir $updir;
138print "#$ENV{PWD}\n";
139Cwd::chdir $updir;
140print "#$ENV{PWD}\n";
141
142rmtree($test_dirs[0], 0, 0);
143
144{
145  my $check = ($IsVMS   ? qr|\b((?i)t)\]$| :
146	       $IsMacOS ? qr|\bt:$| :
147			  qr|\bt$| );
148
149  like($ENV{PWD}, $check);
150}
151
152{
153  # Make sure abs_path() doesn't trample $ENV{PWD}
154  my $start_pwd = $ENV{PWD};
155  mkpath([$Test_Dir], 0, 0777);
156  Cwd::abs_path($Test_Dir);
157  is $ENV{PWD}, $start_pwd;
158  rmtree($test_dirs[0], 0, 0);
159}
160
161SKIP: {
162    skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink};
163
164    mkpath([$Test_Dir], 0, 0777);
165    symlink $Test_Dir, "linktest";
166
167    my $abs_path      =  Cwd::abs_path("linktest");
168    my $fast_abs_path =  Cwd::fast_abs_path("linktest");
169    my $want          =  File::Spec->catdir("t", $Test_Dir);
170
171    like($abs_path,      qr|$want$|);
172    like($fast_abs_path, qr|$want$|);
173    like(Cwd::_perl_abs_path("linktest"), qr|$want$|) if $EXTRA_ABSPATH_TESTS;
174
175    rmtree($test_dirs[0], 0, 0);
176    unlink "linktest";
177}
178
179if ($ENV{PERL_CORE}) {
180    chdir '../ext/Cwd/t';
181    unshift @INC, '../../../lib';
182}
183
184# Make sure we can run abs_path() on files, not just directories
185my $path = 'cwd.t';
186path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
187path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
188path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
189  if $EXTRA_ABSPATH_TESTS;
190
191$path = File::Spec->catfile(File::Spec->updir, 't', $path);
192path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
193path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
194path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
195  if $EXTRA_ABSPATH_TESTS;
196
197
198
199SKIP: {
200  my $file;
201  {
202    my $root = Cwd::abs_path(File::Spec->rootdir);	# Add drive letter?
203    local *FH;
204    opendir FH, $root or skip("Can't opendir($root): $!", 2+$EXTRA_ABSPATH_TESTS);
205    ($file) = grep {-f $_ and not -l $_} map File::Spec->catfile($root, $_), readdir FH;
206    closedir FH;
207  }
208  skip "No plain file in root directory to test with", 2+$EXTRA_ABSPATH_TESTS unless $file;
209
210  $file = VMS::Filespec::rmsexpand($file) if $^O eq 'VMS';
211  is Cwd::abs_path($file), $file, 'abs_path() works on files in the root directory';
212  is Cwd::fast_abs_path($file), $file, 'fast_abs_path() works on files in the root directory';
213  is Cwd::_perl_abs_path($file), $file, '_perl_abs_path() works on files in the root directory'
214    if $EXTRA_ABSPATH_TESTS;
215}
216
217
218#############################################
219# These routines give us sort of a poor-man's cross-platform
220# directory or path comparison capability.
221
222sub bracketed_form_dir {
223  return join '', map "[$_]",
224    grep length, File::Spec->splitdir(File::Spec->canonpath( shift() ));
225}
226
227sub dir_ends_with {
228  my ($dir, $expect) = (shift, shift);
229  my $bracketed_expect = quotemeta bracketed_form_dir($expect);
230  like( bracketed_form_dir($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) );
231}
232
233sub bracketed_form_path {
234  return join '', map "[$_]",
235    grep length, File::Spec->splitpath(File::Spec->canonpath( shift() ));
236}
237
238sub path_ends_with {
239  my ($dir, $expect) = (shift, shift);
240  my $bracketed_expect = quotemeta bracketed_form_path($expect);
241  like( bracketed_form_path($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) );
242}
243