This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Removed the ifdefs for INCOMPLETE_TAINTS
[perl5.git] / dist / Cwd / Cwd.pm
CommitLineData
a0d0e21e 1package Cwd;
a0d0e21e 2
f06db76b
AD
3=head1 NAME
4
902bacac 5Cwd - get pathname of current working directory
f06db76b
AD
6
7=head1 SYNOPSIS
8
4633a7c4 9 use Cwd;
04929354 10 my $dir = getcwd;
4633a7c4 11
04929354
MS
12 use Cwd 'abs_path';
13 my $abs_path = abs_path($file);
f06db76b 14
04929354 15=head1 DESCRIPTION
902bacac 16
04929354
MS
17This module provides functions for determining the pathname of the
18current working directory. It is recommended that getcwd (or another
19*cwd() function) be used in I<all> code to ensure portability.
f06db76b 20
04929354 21By default, it exports the functions cwd(), getcwd(), fastcwd(), and
09122b95 22fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
f06db76b 23
20408e3c 24
04929354 25=head2 getcwd and friends
20408e3c 26
04929354
MS
27Each of these functions are called without arguments and return the
28absolute path of the current working directory.
f06db76b 29
04929354
MS
30=over 4
31
32=item getcwd
33
34 my $cwd = getcwd();
35
36Returns the current working directory.
37
fa52125f
SP
38Exposes the POSIX function getcwd(3) or re-implements it if it's not
39available.
04929354
MS
40
41=item cwd
42
43 my $cwd = cwd();
44
d6ec5f13 45The cwd() is the most natural form for the current architecture. For
04929354
MS
46most systems it is identical to `pwd` (but without the trailing line
47terminator).
48
04929354
MS
49=item fastcwd
50
51 my $cwd = fastcwd();
52
53A more dangerous version of getcwd(), but potentially faster.
54
55It might conceivably chdir() you out of a directory that it can't
56chdir() you back into. If fastcwd encounters a problem it will return
57undef but will probably leave you in a different directory. For a
58measure of extra security, if everything appears to have worked, the
59fastcwd() function will check that it leaves you in the same directory
d6ec5f13 60that it started in. If it has changed it will C<die> with the message
04929354 61"Unstable directory path, current directory changed
d6ec5f13 62unexpectedly". That should never happen.
04929354
MS
63
64=item fastgetcwd
65
66 my $cwd = fastgetcwd();
f06db76b 67
902bacac 68The fastgetcwd() function is provided as a synonym for cwd().
fb73857a 69
09122b95
RGS
70=item getdcwd
71
72 my $cwd = getdcwd();
73 my $cwd = getdcwd('C:');
74
75The getdcwd() function is also provided on Win32 to get the current working
76directory on the specified drive, since Windows maintains a separate current
77working directory for each drive. If no drive is specified then the current
78drive is assumed.
79
80This function simply calls the Microsoft C library _getdcwd() function.
81
04929354
MS
82=back
83
902bacac 84
04929354
MS
85=head2 abs_path and friends
86
87These functions are exported only on request. They each take a single
3ee63918
MS
88argument and return the absolute pathname for it. If no argument is
89given they'll use the current working directory.
04929354
MS
90
91=over 4
92
93=item abs_path
94
95 my $abs_path = abs_path($file);
96
97Uses the same algorithm as getcwd(). Symbolic links and relative-path
98components ("." and "..") are resolved to return the canonical
99pathname, just like realpath(3).
100
101=item realpath
102
103 my $abs_path = realpath($file);
104
105A synonym for abs_path().
106
107=item fast_abs_path
108
510179aa 109 my $abs_path = fast_abs_path($file);
04929354
MS
110
111A more dangerous, but potentially faster version of abs_path.
112
113=back
114
115=head2 $ENV{PWD}
116
117If you ask to override your chdir() built-in function,
118
119 use Cwd qw(chdir);
120
121then your PWD environment variable will be kept up to date. Note that
122it will only be kept up to date if all packages which use chdir import
123it from Cwd.
4633a7c4 124
4633a7c4 125
4d6b4052
JH
126=head1 NOTES
127
128=over 4
129
130=item *
131
c4a6f826 132Since the path separators are different on some operating systems ('/'
04929354
MS
133on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
134modules wherever portability is a concern.
135
04929354 136=item *
4d6b4052
JH
137
138Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
d6ec5f13
FC
139functions are all aliases for the C<cwd()> function, which, on Mac OS,
140calls `pwd`. Likewise, the C<abs_path()> function is an alias for
4d6b4052
JH
141C<fast_abs_path()>.
142
143=back
144
02cc4877
NC
145=head1 AUTHOR
146
147Originally by the perl5-porters.
148
78321866 149Maintained by Ken Williams <KWILLIAMS@cpan.org>
02cc4877 150
99f36a73
RGS
151=head1 COPYRIGHT
152
153Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
154
155This program is free software; you can redistribute it and/or modify
156it under the same terms as Perl itself.
157
158Portions of the C code in this library are copyright (c) 1994 by the
159Regents of the University of California. All rights reserved. The
160license on this code is compatible with the licensing of the rest of
161the distribution - please see the source code in F<Cwd.xs> for the
162details.
163
04929354
MS
164=head1 SEE ALSO
165
166L<File::chdir>
167
f06db76b
AD
168=cut
169
b060a406 170use strict;
a9939470 171use Exporter;
99f36a73
RGS
172use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
173
adf4621a 174$VERSION = '3.45';
4a4ab19c 175my $xs_version = $VERSION;
3d2a0adf 176$VERSION =~ tr/_//;
96e4d5b1 177
a9939470
NC
178@ISA = qw/ Exporter /;
179@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
09122b95 180push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
a9939470 181@EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
a0d0e21e 182
f5f423e4
IZ
183# sys_cwd may keep the builtin command
184
185# All the functionality of this module may provided by builtins,
186# there is no sense to process the rest of the file.
187# The best choice may be to have this in BEGIN, but how to return from BEGIN?
188
a9939470 189if ($^O eq 'os2') {
f5f423e4 190 local $^W = 0;
a9939470
NC
191
192 *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
193 *getcwd = \&cwd;
194 *fastgetcwd = \&cwd;
195 *fastcwd = \&cwd;
196
197 *fast_abs_path = \&sys_abspath if defined &sys_abspath;
198 *abs_path = \&fast_abs_path;
199 *realpath = \&fast_abs_path;
200 *fast_realpath = \&fast_abs_path;
201
f5f423e4
IZ
202 return 1;
203}
204
53e80d0b
JM
205# Need to look up the feature settings on VMS. The preferred way is to use the
206# VMS::Feature module, but that may not be available to dual life modules.
207
208my $use_vms_feature;
209BEGIN {
210 if ($^O eq 'VMS') {
211 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
212 $use_vms_feature = 1;
213 }
214 }
215}
216
217# Need to look up the UNIX report mode. This may become a dynamic mode
218# in the future.
219sub _vms_unix_rpt {
220 my $unix_rpt;
221 if ($use_vms_feature) {
222 $unix_rpt = VMS::Feature::current("filename_unix_report");
223 } else {
224 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
a7884731 225 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
53e80d0b
JM
226 }
227 return $unix_rpt;
228}
229
230# Need to look up the EFS character set mode. This may become a dynamic
231# mode in the future.
232sub _vms_efs {
233 my $efs;
234 if ($use_vms_feature) {
235 $efs = VMS::Feature::current("efs_charset");
236 } else {
237 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
a7884731 238 $efs = $env_efs =~ /^[ET1]/i;
53e80d0b
JM
239 }
240 return $efs;
241}
242
243
b04f6d36 244# If loading the XS stuff doesn't work, we can fall back to pure perl
07f43755
Z
245unless (defined &getcwd) {
246 eval {
247 if ( $] >= 5.006 ) {
248 require XSLoader;
249 XSLoader::load( __PACKAGE__, $xs_version);
250 } else {
251 require DynaLoader;
252 push @ISA, 'DynaLoader';
253 __PACKAGE__->bootstrap( $xs_version );
254 }
255 };
256}
4633a7c4 257
09122b95
RGS
258# Big nasty table of function aliases
259my %METHOD_MAP =
260 (
261 VMS =>
262 {
263 cwd => '_vms_cwd',
264 getcwd => '_vms_cwd',
265 fastcwd => '_vms_cwd',
266 fastgetcwd => '_vms_cwd',
267 abs_path => '_vms_abs_path',
268 fast_abs_path => '_vms_abs_path',
269 },
270
271 MSWin32 =>
272 {
273 # We assume that &_NT_cwd is defined as an XSUB or in the core.
274 cwd => '_NT_cwd',
275 getcwd => '_NT_cwd',
276 fastcwd => '_NT_cwd',
277 fastgetcwd => '_NT_cwd',
278 abs_path => 'fast_abs_path',
279 realpath => 'fast_abs_path',
280 },
281
282 dos =>
283 {
284 cwd => '_dos_cwd',
285 getcwd => '_dos_cwd',
286 fastgetcwd => '_dos_cwd',
287 fastcwd => '_dos_cwd',
288 abs_path => 'fast_abs_path',
289 },
290
58ccccf6 291 # QNX4. QNX6 has a $os of 'nto'.
09122b95
RGS
292 qnx =>
293 {
294 cwd => '_qnx_cwd',
295 getcwd => '_qnx_cwd',
296 fastgetcwd => '_qnx_cwd',
297 fastcwd => '_qnx_cwd',
298 abs_path => '_qnx_abs_path',
299 fast_abs_path => '_qnx_abs_path',
300 },
301
302 cygwin =>
303 {
304 getcwd => 'cwd',
305 fastgetcwd => 'cwd',
306 fastcwd => 'cwd',
307 abs_path => 'fast_abs_path',
308 realpath => 'fast_abs_path',
309 },
310
311 epoc =>
312 {
313 cwd => '_epoc_cwd',
314 getcwd => '_epoc_cwd',
315 fastgetcwd => '_epoc_cwd',
316 fastcwd => '_epoc_cwd',
317 abs_path => 'fast_abs_path',
318 },
319
320 MacOS =>
321 {
322 getcwd => 'cwd',
323 fastgetcwd => 'cwd',
324 fastcwd => 'cwd',
325 abs_path => 'fast_abs_path',
326 },
327 );
328
329$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
09122b95 330
96e4d5b1 331
3547aa9a
MS
332# Find the pwd command in the expected locations. We assume these
333# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
334# so everything works under taint mode.
335my $pwd_cmd;
889f7a4f
RGS
336foreach my $try ('/bin/pwd',
337 '/usr/bin/pwd',
338 '/QOpenSys/bin/pwd', # OS/400 PASE.
339 ) {
340
3547aa9a
MS
341 if( -x $try ) {
342 $pwd_cmd = $try;
343 last;
344 }
345}
fa52125f 346my $found_pwd_cmd = defined($pwd_cmd);
522b859a 347unless ($pwd_cmd) {
2d3da5df 348 # Isn't this wrong? _backtick_pwd() will fail if someone has
889f7a4f
RGS
349 # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
350 # See [perl #16774]. --jhi
351 $pwd_cmd = 'pwd';
522b859a 352}
3547aa9a 353
a9939470
NC
354# Lazy-load Carp
355sub _carp { require Carp; Carp::carp(@_) }
356sub _croak { require Carp; Carp::croak(@_) }
357
3547aa9a 358# The 'natural and safe form' for UNIX (pwd may be setuid root)
8b88ae92 359sub _backtick_pwd {
f6342b4b
RGS
360 # Localize %ENV entries in a way that won't create new hash keys
361 my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
362 local @ENV{@localize};
363
3547aa9a 364 my $cwd = `$pwd_cmd`;
ac3b20cb 365 # Belt-and-suspenders in case someone said "undef $/".
5cf6da5f 366 local $/ = "\n";
ac3b20cb 367 # `pwd` may fail e.g. if the disk is full
7e03f963 368 chomp($cwd) if defined $cwd;
4633a7c4 369 $cwd;
8b88ae92 370}
4633a7c4
LW
371
372# Since some ports may predefine cwd internally (e.g., NT)
373# we take care not to override an existing definition for cwd().
374
09122b95 375unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
ea54c8bd 376 # The pwd command is not available in some chroot(2)'ed environments
09122b95 377 my $sep = $Config::Config{path_sep} || ':';
60598624 378 my $os = $^O; # Protect $^O from tainting
fa52125f
SP
379
380
381 # Try again to find a pwd, this time searching the whole PATH.
382 if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
383 my @candidates = split($sep, $ENV{PATH});
384 while (!$found_pwd_cmd and @candidates) {
385 my $candidate = shift @candidates;
386 $found_pwd_cmd = 1 if -x "$candidate/pwd";
387 }
388 }
389
390 # MacOS has some special magic to make `pwd` work.
391 if( $os eq 'MacOS' || $found_pwd_cmd )
73b801a6 392 {
ea54c8bd
EC
393 *cwd = \&_backtick_pwd;
394 }
395 else {
396 *cwd = \&getcwd;
397 }
398}
a0d0e21e 399
23bb49fa
SP
400if ($^O eq 'cygwin') {
401 # We need to make sure cwd() is called with no args, because it's
402 # got an arg-less prototype and will die if args are present.
403 local $^W = 0;
404 my $orig_cwd = \&cwd;
405 *cwd = sub { &$orig_cwd() }
406}
407
408
1f4f94f5
RS
409# set a reasonable (and very safe) default for fastgetcwd, in case it
410# isn't redefined later (20001212 rspier)
411*fastgetcwd = \&cwd;
748a9306 412
c47834cd
RGS
413# A non-XS version of getcwd() - also used to bootstrap the perl build
414# process, when miniperl is running and no XS loading happens.
a7a23d71
NC
415sub _perl_getcwd
416{
417 abs_path('.');
418}
419
a0c9c202
JH
420# By John Bazik
421#
422# Usage: $cwd = &fastcwd;
423#
424# This is a faster version of getcwd. It's also more dangerous because
425# you might chdir out of a directory that you can't chdir back into.
426
99f36a73 427sub fastcwd_ {
a0c9c202
JH
428 my($odev, $oino, $cdev, $cino, $tdev, $tino);
429 my(@path, $path);
430 local(*DIR);
431
432 my($orig_cdev, $orig_cino) = stat('.');
433 ($cdev, $cino) = ($orig_cdev, $orig_cino);
434 for (;;) {
435 my $direntry;
436 ($odev, $oino) = ($cdev, $cino);
437 CORE::chdir('..') || return undef;
438 ($cdev, $cino) = stat('.');
439 last if $odev == $cdev && $oino == $cino;
440 opendir(DIR, '.') || return undef;
441 for (;;) {
442 $direntry = readdir(DIR);
443 last unless defined $direntry;
444 next if $direntry eq '.';
445 next if $direntry eq '..';
446
447 ($tdev, $tino) = lstat($direntry);
448 last unless $tdev != $odev || $tino != $oino;
449 }
450 closedir(DIR);
451 return undef unless defined $direntry; # should never happen
452 unshift(@path, $direntry);
453 }
454 $path = '/' . join('/', @path);
455 if ($^O eq 'apollo') { $path = "/".$path; }
456 # At this point $path may be tainted (if tainting) and chdir would fail.
248785eb
RGS
457 # Untaint it then check that we landed where we started.
458 $path =~ /^(.*)\z/s # untaint
459 && CORE::chdir($1) or return undef;
a0c9c202
JH
460 ($cdev, $cino) = stat('.');
461 die "Unstable directory path, current directory changed unexpectedly"
462 if $cdev != $orig_cdev || $cino != $orig_cino;
463 $path;
464}
99f36a73 465if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
a0c9c202
JH
466
467
4633a7c4 468# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
469# Usage:
470# use Cwd 'chdir';
471# chdir $newdir;
472
4633a7c4 473my $chdir_init = 0;
a0d0e21e 474
4633a7c4 475sub chdir_init {
3b8e3443 476 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
a0d0e21e
LW
477 my($dd,$di) = stat('.');
478 my($pd,$pi) = stat($ENV{'PWD'});
479 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 480 $ENV{'PWD'} = cwd();
a0d0e21e
LW
481 }
482 }
483 else {
3b8e3443
GS
484 my $wd = cwd();
485 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
486 $ENV{'PWD'} = $wd;
a0d0e21e 487 }
4633a7c4 488 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
3b8e3443 489 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
a0d0e21e
LW
490 my($pd,$pi) = stat($2);
491 my($dd,$di) = stat($1);
492 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
493 $ENV{'PWD'}="$2$3";
494 }
495 }
496 $chdir_init = 1;
497}
498
499sub chdir {
22978713 500 my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
3b8e3443 501 $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
a0d0e21e 502 chdir_init() unless $chdir_init;
4ffa1610
JH
503 my $newpwd;
504 if ($^O eq 'MSWin32') {
505 # get the full path name *before* the chdir()
506 $newpwd = Win32::GetFullPathName($newdir);
507 }
508
4633a7c4 509 return 0 unless CORE::chdir $newdir;
4ffa1610 510
3b8e3443
GS
511 if ($^O eq 'VMS') {
512 return $ENV{'PWD'} = $ENV{'DEFAULT'}
513 }
4aecb5b5
JH
514 elsif ($^O eq 'MacOS') {
515 return $ENV{'PWD'} = cwd();
516 }
3b8e3443 517 elsif ($^O eq 'MSWin32') {
4ffa1610 518 $ENV{'PWD'} = $newpwd;
3b8e3443
GS
519 return 1;
520 }
748a9306 521
e9475de8
SP
522 if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
523 $ENV{'PWD'} = cwd();
524 } elsif ($newdir =~ m#^/#s) {
a0d0e21e 525 $ENV{'PWD'} = $newdir;
4633a7c4
LW
526 } else {
527 my @curdir = split(m#/#,$ENV{'PWD'});
528 @curdir = ('') unless @curdir;
529 my $component;
a0d0e21e
LW
530 foreach $component (split(m#/#, $newdir)) {
531 next if $component eq '.';
532 pop(@curdir),next if $component eq '..';
533 push(@curdir,$component);
534 }
535 $ENV{'PWD'} = join('/',@curdir) || '/';
536 }
4633a7c4 537 1;
a0d0e21e
LW
538}
539
a0c9c202 540
99f36a73 541sub _perl_abs_path
a0c9c202
JH
542{
543 my $start = @_ ? shift : '.';
544 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
545
546 unless (@cst = stat( $start ))
547 {
a9939470 548 _carp("stat($start): $!");
a0c9c202
JH
549 return '';
550 }
09122b95
RGS
551
552 unless (-d _) {
553 # Make sure we can be invoked on plain files, not just directories.
554 # NOTE that this routine assumes that '/' is the only directory separator.
555
556 my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
557 or return cwd() . '/' . $start;
558
275e8705
RGS
559 # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
560 if (-l $start) {
09122b95
RGS
561 my $link_target = readlink($start);
562 die "Can't resolve link $start: $!" unless defined $link_target;
563
564 require File::Spec;
565 $link_target = $dir . '/' . $link_target
566 unless File::Spec->file_name_is_absolute($link_target);
567
568 return abs_path($link_target);
569 }
570
99f36a73 571 return $dir ? abs_path($dir) . "/$file" : "/$file";
09122b95
RGS
572 }
573
a0c9c202
JH
574 $cwd = '';
575 $dotdots = $start;
576 do
577 {
578 $dotdots .= '/..';
579 @pst = @cst;
a25ef67d 580 local *PARENT;
a0c9c202
JH
581 unless (opendir(PARENT, $dotdots))
582 {
bf7c0a3d 583 # probably a permissions issue. Try the native command.
cdce0d84 584 require File::Spec;
bf7c0a3d 585 return File::Spec->rel2abs( $start, _backtick_pwd() );
a0c9c202
JH
586 }
587 unless (@cst = stat($dotdots))
588 {
a9939470 589 _carp("stat($dotdots): $!");
a0c9c202
JH
590 closedir(PARENT);
591 return '';
592 }
593 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
594 {
595 $dir = undef;
596 }
597 else
598 {
599 do
600 {
601 unless (defined ($dir = readdir(PARENT)))
602 {
a9939470 603 _carp("readdir($dotdots): $!");
a0c9c202
JH
604 closedir(PARENT);
605 return '';
606 }
607 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
608 }
609 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
610 $tst[1] != $pst[1]);
611 }
612 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
613 closedir(PARENT);
614 } while (defined $dir);
615 chop($cwd) unless $cwd eq '/'; # drop the trailing /
616 $cwd;
617}
618
619
3ee63918 620my $Curdir;
96e4d5b1 621sub fast_abs_path {
99f36a73 622 local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
96e4d5b1 623 my $cwd = getcwd();
4d6b4052 624 require File::Spec;
3ee63918
MS
625 my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
626
627 # Detaint else we'll explode in taint mode. This is safe because
628 # we're not doing anything dangerous with it.
9f28c638
JB
629 ($path) = $path =~ /(.*)/s;
630 ($cwd) = $cwd =~ /(.*)/s;
3ee63918 631
09122b95
RGS
632 unless (-e $path) {
633 _croak("$path: No such file or directory");
634 }
635
636 unless (-d _) {
637 # Make sure we can be invoked on plain files, not just directories.
638
639 my ($vol, $dir, $file) = File::Spec->splitpath($path);
640 return File::Spec->catfile($cwd, $path) unless length $dir;
641
642 if (-l $path) {
643 my $link_target = readlink($path);
644 die "Can't resolve link $path: $!" unless defined $link_target;
645
646 $link_target = File::Spec->catpath($vol, $dir, $link_target)
647 unless File::Spec->file_name_is_absolute($link_target);
648
649 return fast_abs_path($link_target);
650 }
651
d6802e43 652 return $dir eq File::Spec->rootdir
99f36a73
RGS
653 ? File::Spec->catpath($vol, $dir, $file)
654 : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
09122b95
RGS
655 }
656
e2ba406b 657 if (!CORE::chdir($path)) {
a9939470 658 _croak("Cannot chdir to $path: $!");
e2ba406b 659 }
96e4d5b1 660 my $realpath = getcwd();
e2ba406b 661 if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
a9939470 662 _croak("Cannot chdir back to $cwd: $!");
e2ba406b 663 }
96e4d5b1 664 $realpath;
8b88ae92
NIS
665}
666
e4c51978
GS
667# added function alias to follow principle of least surprise
668# based on previous aliasing. --tchrist 27-Jan-00
669*fast_realpath = \&fast_abs_path;
670
4633a7c4
LW
671
672# --- PORTING SECTION ---
673
674# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c 675# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72 676# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
677# in the process logical name table as the default device and directory
678# seen by Perl. This may not be the same as the default device
4633a7c4
LW
679# and directory seen by DCL after Perl exits, since the effects
680# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
681
682sub _vms_cwd {
96e4d5b1 683 return $ENV{'DEFAULT'};
684}
685
686sub _vms_abs_path {
687 return $ENV{'DEFAULT'} unless @_;
61729915 688 my $path = shift;
9d7d9729 689
53e80d0b
JM
690 my $efs = _vms_efs;
691 my $unix_rpt = _vms_unix_rpt;
692
693 if (defined &VMS::Filespec::vmsrealpath) {
694 my $path_unix = 0;
695 my $path_vms = 0;
696
697 $path_unix = 1 if ($path =~ m#(?<=\^)/#);
698 $path_unix = 1 if ($path =~ /^\.\.?$/);
699 $path_vms = 1 if ($path =~ m#[\[<\]]#);
700 $path_vms = 1 if ($path =~ /^--?$/);
701
702 my $unix_mode = $path_unix;
703 if ($efs) {
704 # In case of a tie, the Unix report mode decides.
705 if ($path_vms == $path_unix) {
706 $unix_mode = $unix_rpt;
707 } else {
708 $unix_mode = 0 if $path_vms;
709 }
710 }
9d7d9729 711
53e80d0b 712 if ($unix_mode) {
bf7c0a3d 713 # Unix format
53e80d0b 714 return VMS::Filespec::unixrealpath($path);
bf7c0a3d
SP
715 }
716
717 # VMS format
718
53e80d0b 719 my $new_path = VMS::Filespec::vmsrealpath($path);
bf7c0a3d
SP
720
721 # Perl expects directories to be in directory format
722 $new_path = VMS::Filespec::pathify($new_path) if -d $path;
723 return $new_path;
724 }
725
726 # Fallback to older algorithm if correct ones are not
727 # available.
728
53e80d0b
JM
729 if (-l $path) {
730 my $link_target = readlink($path);
731 die "Can't resolve link $path: $!" unless defined $link_target;
732
733 return _vms_abs_path($link_target);
734 }
735
61729915
CB
736 # may need to turn foo.dir into [.foo]
737 my $pathified = VMS::Filespec::pathify($path);
738 $path = $pathified if defined $pathified;
739
96e4d5b1 740 return VMS::Filespec::rmsexpand($path);
4633a7c4 741}
68dc0745 742
4633a7c4
LW
743sub _os2_cwd {
744 $ENV{'PWD'} = `cmd /c cd`;
39741d73 745 chomp $ENV{'PWD'};
aa6b7957 746 $ENV{'PWD'} =~ s:\\:/:g ;
4633a7c4
LW
747 return $ENV{'PWD'};
748}
749
8440aeb0 750sub _win32_cwd_simple {
751 $ENV{'PWD'} = `cd`;
752 chomp $ENV{'PWD'};
753 $ENV{'PWD'} =~ s:\\:/:g ;
754 return $ENV{'PWD'};
755}
756
96e4d5b1 757sub _win32_cwd {
5ec06e76
NC
758 # Need to avoid taking any sort of reference to the typeglob or the code in
759 # the optree, so that this tests the runtime state of things, as the
760 # ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at
761 # runtime by deleting the subroutine. *foo{THING} syntax on a symbol table
762 # lookup avoids needing a string eval, which has been reported to cause
763 # problems (for reasons that we haven't been able to get to the bottom of -
764 # rt.cpan.org #56225)
765 if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) {
cf2f24a4
JD
766 $ENV{'PWD'} = Win32::GetCwd();
767 }
768 else { # miniperl
769 chomp($ENV{'PWD'} = `cd`);
770 }
aa6b7957 771 $ENV{'PWD'} =~ s:\\:/:g ;
96e4d5b1 772 return $ENV{'PWD'};
773}
774
8440aeb0 775*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
68dc0745 776
39e571d4
LM
777sub _dos_cwd {
778 if (!defined &Dos::GetCwd) {
779 $ENV{'PWD'} = `command /c cd`;
39741d73 780 chomp $ENV{'PWD'};
aa6b7957 781 $ENV{'PWD'} =~ s:\\:/:g ;
39e571d4
LM
782 } else {
783 $ENV{'PWD'} = Dos::GetCwd();
784 }
55497cff 785 return $ENV{'PWD'};
786}
787
7fbf1995 788sub _qnx_cwd {
35b807ef
NA
789 local $ENV{PATH} = '';
790 local $ENV{CDPATH} = '';
791 local $ENV{ENV} = '';
7fbf1995 792 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
39741d73 793 chomp $ENV{'PWD'};
7fbf1995
NA
794 return $ENV{'PWD'};
795}
796
797sub _qnx_abs_path {
35b807ef
NA
798 local $ENV{PATH} = '';
799 local $ENV{CDPATH} = '';
800 local $ENV{ENV} = '';
fa921dc6 801 my $path = @_ ? shift : '.';
39741d73
MS
802 local *REALPATH;
803
99f36a73 804 defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
39741d73
MS
805 die "Can't open /usr/bin/fullpath: $!";
806 my $realpath = <REALPATH>;
807 close REALPATH;
808 chomp $realpath;
7fbf1995
NA
809 return $realpath;
810}
811
ed79a026
OF
812sub _epoc_cwd {
813 $ENV{'PWD'} = EPOC::getcwd();
814 return $ENV{'PWD'};
815}
816
4633a7c4 817
09122b95
RGS
818# Now that all the base-level functions are set up, alias the
819# user-level functions to the right places
820
821if (exists $METHOD_MAP{$^O}) {
822 my $map = $METHOD_MAP{$^O};
823 foreach my $name (keys %$map) {
99f36a73 824 local $^W = 0; # assignments trigger 'subroutine redefined' warning
09122b95
RGS
825 no strict 'refs';
826 *{$name} = \&{$map->{$name}};
827 }
55497cff 828}
4633a7c4 829
99f36a73
RGS
830# In case the XS version doesn't load.
831*abs_path = \&_perl_abs_path unless defined &abs_path;
a7a23d71 832*getcwd = \&_perl_getcwd unless defined &getcwd;
99f36a73
RGS
833
834# added function alias for those of us more
835# used to the libc function. --tchrist 27-Jan-00
836*realpath = \&abs_path;
4633a7c4 837
a0d0e21e 8381;