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 = 30;
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{
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
135# Cwd::chdir should also update $ENV{PWD}
136dir_ends_with( $ENV{PWD}, $Test_Dir, 'Cwd::chdir() updates $ENV{PWD}' );
137my $updir = File::Spec->updir;
138Cwd::chdir $updir;
139print "#$ENV{PWD}\n";
140Cwd::chdir $updir;
141print "#$ENV{PWD}\n";
142Cwd::chdir $updir;
143print "#$ENV{PWD}\n";
144Cwd::chdir $updir;
145print "#$ENV{PWD}\n";
146Cwd::chdir $updir;
147print "#$ENV{PWD}\n";
148
149rmtree($test_dirs[0], 0, 0);
150
151{
152  my $check = ($IsVMS   ? qr|\b((?i)t)\]$| :
153	       $IsMacOS ? qr|\bt:$| :
154			  qr|\bt$| );
155  
156  like($ENV{PWD}, $check);
157}
158
159{
160  # Make sure abs_path() doesn't trample $ENV{PWD}
161  my $start_pwd = $ENV{PWD};
162  mkpath([$Test_Dir], 0, 0777);
163  Cwd::abs_path($Test_Dir);
164  is $ENV{PWD}, $start_pwd;
165  rmtree($test_dirs[0], 0, 0);
166}
167
168SKIP: {
169    skip "no symlinks on this platform", 2+$EXTRA_ABSPATH_TESTS unless $Config{d_symlink};
170
171    mkpath([$Test_Dir], 0, 0777);
172    symlink $Test_Dir, "linktest";
173
174    my $abs_path      =  Cwd::abs_path("linktest");
175    my $fast_abs_path =  Cwd::fast_abs_path("linktest");
176    my $want          =  File::Spec->catdir("t", $Test_Dir);
177
178    like($abs_path,      qr|$want$|);
179    like($fast_abs_path, qr|$want$|);
180    like(Cwd::_perl_abs_path("linktest"), qr|$want$|) if $EXTRA_ABSPATH_TESTS;
181
182    rmtree($test_dirs[0], 0, 0);
183    unlink "linktest";
184}
185
186if ($ENV{PERL_CORE}) {
187    chdir '../ext/Cwd/t';
188    unshift @INC, '../../../lib';
189}
190
191# Make sure we can run abs_path() on files, not just directories
192my $path = 'cwd.t';
193path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
194path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
195path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
196  if $EXTRA_ABSPATH_TESTS;
197
198$path = File::Spec->catfile(File::Spec->updir, 't', $path);
199path_ends_with(Cwd::abs_path($path), 'cwd.t', 'abs_path() can be invoked on a file');
200path_ends_with(Cwd::fast_abs_path($path), 'cwd.t', 'fast_abs_path() can be invoked on a file');
201path_ends_with(Cwd::_perl_abs_path($path), 'cwd.t', '_perl_abs_path() can be invoked on a file')
202  if $EXTRA_ABSPATH_TESTS;
203
204
205  
206SKIP: {
207  my $file;
208  {
209    my $root = Cwd::abs_path(File::Spec->rootdir);	# Add drive letter?
210    local *FH;
211    opendir FH, $root or skip("Can't opendir($root): $!", 2+$EXTRA_ABSPATH_TESTS);
212    ($file) = grep {-f $_ and not -l $_} map File::Spec->catfile($root, $_), readdir FH;
213    closedir FH;
214  }
215  skip "No plain file in root directory to test with", 2+$EXTRA_ABSPATH_TESTS unless $file;
216  
217  $file = VMS::Filespec::rmsexpand($file) if $^O eq 'VMS';
218  is Cwd::abs_path($file), $file, 'abs_path() works on files in the root directory';
219  is Cwd::fast_abs_path($file), $file, 'fast_abs_path() works on files in the root directory';
220  is Cwd::_perl_abs_path($file), $file, '_perl_abs_path() works on files in the root directory'
221    if $EXTRA_ABSPATH_TESTS;
222}
223
224
225#############################################
226# These routines give us sort of a poor-man's cross-platform
227# directory or path comparison capability.
228
229sub bracketed_form_dir {
230  return join '', map "[$_]", 
231    grep length, File::Spec->splitdir(File::Spec->canonpath( shift() ));
232}
233
234sub dir_ends_with {
235  my ($dir, $expect) = (shift, shift);
236  my $bracketed_expect = quotemeta bracketed_form_dir($expect);
237  like( bracketed_form_dir($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) );
238}
239
240sub bracketed_form_path {
241  return join '', map "[$_]", 
242    grep length, File::Spec->splitpath(File::Spec->canonpath( shift() ));
243}
244
245sub path_ends_with {
246  my ($dir, $expect) = (shift, shift);
247  my $bracketed_expect = quotemeta bracketed_form_path($expect);
248  like( bracketed_form_path($dir), qr|$bracketed_expect$|i, (@_ ? shift : ()) );
249}
250