This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
remove excess whitespace from warnings.pm
[perl5.git] / dist / PathTools / 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
ef47896b 174$VERSION = '3.50';
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
96dcbc37
DD
245if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) {
246 eval {#eval is questionable since we are handling potential errors like
ef47896b 247 #"Cwd object version 3.48 does not match bootstrap parameter 3.50
96dcbc37 248 #at lib/DynaLoader.pm line 216." by having this eval
07f43755
Z
249 if ( $] >= 5.006 ) {
250 require XSLoader;
251 XSLoader::load( __PACKAGE__, $xs_version);
252 } else {
253 require DynaLoader;
254 push @ISA, 'DynaLoader';
255 __PACKAGE__->bootstrap( $xs_version );
256 }
257 };
258}
4633a7c4 259
09122b95
RGS
260# Big nasty table of function aliases
261my %METHOD_MAP =
262 (
263 VMS =>
264 {
265 cwd => '_vms_cwd',
266 getcwd => '_vms_cwd',
267 fastcwd => '_vms_cwd',
268 fastgetcwd => '_vms_cwd',
269 abs_path => '_vms_abs_path',
270 fast_abs_path => '_vms_abs_path',
271 },
272
273 MSWin32 =>
274 {
275 # We assume that &_NT_cwd is defined as an XSUB or in the core.
276 cwd => '_NT_cwd',
277 getcwd => '_NT_cwd',
278 fastcwd => '_NT_cwd',
279 fastgetcwd => '_NT_cwd',
280 abs_path => 'fast_abs_path',
281 realpath => 'fast_abs_path',
282 },
283
284 dos =>
285 {
286 cwd => '_dos_cwd',
287 getcwd => '_dos_cwd',
288 fastgetcwd => '_dos_cwd',
289 fastcwd => '_dos_cwd',
290 abs_path => 'fast_abs_path',
291 },
292
58ccccf6 293 # QNX4. QNX6 has a $os of 'nto'.
09122b95
RGS
294 qnx =>
295 {
296 cwd => '_qnx_cwd',
297 getcwd => '_qnx_cwd',
298 fastgetcwd => '_qnx_cwd',
299 fastcwd => '_qnx_cwd',
300 abs_path => '_qnx_abs_path',
301 fast_abs_path => '_qnx_abs_path',
302 },
303
304 cygwin =>
305 {
306 getcwd => 'cwd',
307 fastgetcwd => 'cwd',
308 fastcwd => 'cwd',
309 abs_path => 'fast_abs_path',
310 realpath => 'fast_abs_path',
311 },
312
313 epoc =>
314 {
315 cwd => '_epoc_cwd',
316 getcwd => '_epoc_cwd',
317 fastgetcwd => '_epoc_cwd',
318 fastcwd => '_epoc_cwd',
319 abs_path => 'fast_abs_path',
320 },
321
322 MacOS =>
323 {
324 getcwd => 'cwd',
325 fastgetcwd => 'cwd',
326 fastcwd => 'cwd',
327 abs_path => 'fast_abs_path',
328 },
329 );
330
331$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
09122b95 332
96e4d5b1 333
3547aa9a
MS
334# Find the pwd command in the expected locations. We assume these
335# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
336# so everything works under taint mode.
337my $pwd_cmd;
889f7a4f
RGS
338foreach my $try ('/bin/pwd',
339 '/usr/bin/pwd',
340 '/QOpenSys/bin/pwd', # OS/400 PASE.
341 ) {
342
3547aa9a
MS
343 if( -x $try ) {
344 $pwd_cmd = $try;
345 last;
346 }
347}
b2fc9074
BF
348
349# Android has a built-in pwd. Using $pwd_cmd will DTRT if
350# this perl was compiled with -Dd_useshellcmds, which is the
351# default for Android, but the block below is needed for the
352# miniperl running on the host when cross-compiling, and
353# potentially for native builds with -Ud_useshellcmds.
354if ($^O =~ /android/) {
355 # If targetsh is executable, then we're either a full
356 # perl, or a miniperl for a native build.
357 if (-x $Config::Config{targetsh}) {
358 $pwd_cmd = "$Config::Config{targetsh} -c pwd"
359 }
360 else {
e7d73da9
BF
361 my $sh = $Config::Config{sh} || (-x '/system/bin/sh' ? '/system/bin/sh' : 'sh');
362 $pwd_cmd = "$sh -c pwd"
b2fc9074
BF
363 }
364}
365
fa52125f 366my $found_pwd_cmd = defined($pwd_cmd);
522b859a 367unless ($pwd_cmd) {
2d3da5df 368 # Isn't this wrong? _backtick_pwd() will fail if someone has
889f7a4f
RGS
369 # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
370 # See [perl #16774]. --jhi
371 $pwd_cmd = 'pwd';
522b859a 372}
3547aa9a 373
a9939470
NC
374# Lazy-load Carp
375sub _carp { require Carp; Carp::carp(@_) }
376sub _croak { require Carp; Carp::croak(@_) }
377
3547aa9a 378# The 'natural and safe form' for UNIX (pwd may be setuid root)
8b88ae92 379sub _backtick_pwd {
f6342b4b
RGS
380 # Localize %ENV entries in a way that won't create new hash keys
381 my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
382 local @ENV{@localize};
383
3547aa9a 384 my $cwd = `$pwd_cmd`;
ac3b20cb 385 # Belt-and-suspenders in case someone said "undef $/".
5cf6da5f 386 local $/ = "\n";
ac3b20cb 387 # `pwd` may fail e.g. if the disk is full
7e03f963 388 chomp($cwd) if defined $cwd;
4633a7c4 389 $cwd;
8b88ae92 390}
4633a7c4
LW
391
392# Since some ports may predefine cwd internally (e.g., NT)
393# we take care not to override an existing definition for cwd().
394
09122b95 395unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
ea54c8bd 396 # The pwd command is not available in some chroot(2)'ed environments
09122b95 397 my $sep = $Config::Config{path_sep} || ':';
60598624 398 my $os = $^O; # Protect $^O from tainting
fa52125f
SP
399
400
401 # Try again to find a pwd, this time searching the whole PATH.
402 if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
403 my @candidates = split($sep, $ENV{PATH});
404 while (!$found_pwd_cmd and @candidates) {
405 my $candidate = shift @candidates;
406 $found_pwd_cmd = 1 if -x "$candidate/pwd";
407 }
408 }
409
410 # MacOS has some special magic to make `pwd` work.
411 if( $os eq 'MacOS' || $found_pwd_cmd )
73b801a6 412 {
ea54c8bd
EC
413 *cwd = \&_backtick_pwd;
414 }
415 else {
416 *cwd = \&getcwd;
417 }
418}
a0d0e21e 419
23bb49fa
SP
420if ($^O eq 'cygwin') {
421 # We need to make sure cwd() is called with no args, because it's
422 # got an arg-less prototype and will die if args are present.
423 local $^W = 0;
424 my $orig_cwd = \&cwd;
425 *cwd = sub { &$orig_cwd() }
426}
427
428
1f4f94f5
RS
429# set a reasonable (and very safe) default for fastgetcwd, in case it
430# isn't redefined later (20001212 rspier)
431*fastgetcwd = \&cwd;
748a9306 432
c47834cd
RGS
433# A non-XS version of getcwd() - also used to bootstrap the perl build
434# process, when miniperl is running and no XS loading happens.
a7a23d71
NC
435sub _perl_getcwd
436{
437 abs_path('.');
438}
439
a0c9c202
JH
440# By John Bazik
441#
442# Usage: $cwd = &fastcwd;
443#
444# This is a faster version of getcwd. It's also more dangerous because
445# you might chdir out of a directory that you can't chdir back into.
446
99f36a73 447sub fastcwd_ {
a0c9c202
JH
448 my($odev, $oino, $cdev, $cino, $tdev, $tino);
449 my(@path, $path);
450 local(*DIR);
451
452 my($orig_cdev, $orig_cino) = stat('.');
453 ($cdev, $cino) = ($orig_cdev, $orig_cino);
454 for (;;) {
455 my $direntry;
456 ($odev, $oino) = ($cdev, $cino);
457 CORE::chdir('..') || return undef;
458 ($cdev, $cino) = stat('.');
459 last if $odev == $cdev && $oino == $cino;
460 opendir(DIR, '.') || return undef;
461 for (;;) {
462 $direntry = readdir(DIR);
463 last unless defined $direntry;
464 next if $direntry eq '.';
465 next if $direntry eq '..';
466
467 ($tdev, $tino) = lstat($direntry);
468 last unless $tdev != $odev || $tino != $oino;
469 }
470 closedir(DIR);
471 return undef unless defined $direntry; # should never happen
472 unshift(@path, $direntry);
473 }
474 $path = '/' . join('/', @path);
475 if ($^O eq 'apollo') { $path = "/".$path; }
476 # At this point $path may be tainted (if tainting) and chdir would fail.
248785eb
RGS
477 # Untaint it then check that we landed where we started.
478 $path =~ /^(.*)\z/s # untaint
479 && CORE::chdir($1) or return undef;
a0c9c202
JH
480 ($cdev, $cino) = stat('.');
481 die "Unstable directory path, current directory changed unexpectedly"
482 if $cdev != $orig_cdev || $cino != $orig_cino;
483 $path;
484}
99f36a73 485if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
a0c9c202
JH
486
487
4633a7c4 488# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
489# Usage:
490# use Cwd 'chdir';
491# chdir $newdir;
492
4633a7c4 493my $chdir_init = 0;
a0d0e21e 494
4633a7c4 495sub chdir_init {
3b8e3443 496 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
a0d0e21e
LW
497 my($dd,$di) = stat('.');
498 my($pd,$pi) = stat($ENV{'PWD'});
499 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 500 $ENV{'PWD'} = cwd();
a0d0e21e
LW
501 }
502 }
503 else {
3b8e3443
GS
504 my $wd = cwd();
505 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
506 $ENV{'PWD'} = $wd;
a0d0e21e 507 }
4633a7c4 508 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
3b8e3443 509 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
a0d0e21e
LW
510 my($pd,$pi) = stat($2);
511 my($dd,$di) = stat($1);
512 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
513 $ENV{'PWD'}="$2$3";
514 }
515 }
516 $chdir_init = 1;
517}
518
519sub chdir {
22978713 520 my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
3b8e3443 521 $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
a0d0e21e 522 chdir_init() unless $chdir_init;
4ffa1610
JH
523 my $newpwd;
524 if ($^O eq 'MSWin32') {
525 # get the full path name *before* the chdir()
526 $newpwd = Win32::GetFullPathName($newdir);
527 }
528
4633a7c4 529 return 0 unless CORE::chdir $newdir;
4ffa1610 530
3b8e3443
GS
531 if ($^O eq 'VMS') {
532 return $ENV{'PWD'} = $ENV{'DEFAULT'}
533 }
4aecb5b5
JH
534 elsif ($^O eq 'MacOS') {
535 return $ENV{'PWD'} = cwd();
536 }
3b8e3443 537 elsif ($^O eq 'MSWin32') {
4ffa1610 538 $ENV{'PWD'} = $newpwd;
3b8e3443
GS
539 return 1;
540 }
748a9306 541
e9475de8
SP
542 if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
543 $ENV{'PWD'} = cwd();
544 } elsif ($newdir =~ m#^/#s) {
a0d0e21e 545 $ENV{'PWD'} = $newdir;
4633a7c4
LW
546 } else {
547 my @curdir = split(m#/#,$ENV{'PWD'});
548 @curdir = ('') unless @curdir;
549 my $component;
a0d0e21e
LW
550 foreach $component (split(m#/#, $newdir)) {
551 next if $component eq '.';
552 pop(@curdir),next if $component eq '..';
553 push(@curdir,$component);
554 }
555 $ENV{'PWD'} = join('/',@curdir) || '/';
556 }
4633a7c4 557 1;
a0d0e21e
LW
558}
559
a0c9c202 560
99f36a73 561sub _perl_abs_path
a0c9c202
JH
562{
563 my $start = @_ ? shift : '.';
564 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
565
566 unless (@cst = stat( $start ))
567 {
a9939470 568 _carp("stat($start): $!");
a0c9c202
JH
569 return '';
570 }
09122b95
RGS
571
572 unless (-d _) {
573 # Make sure we can be invoked on plain files, not just directories.
574 # NOTE that this routine assumes that '/' is the only directory separator.
575
576 my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
577 or return cwd() . '/' . $start;
578
275e8705
RGS
579 # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
580 if (-l $start) {
09122b95
RGS
581 my $link_target = readlink($start);
582 die "Can't resolve link $start: $!" unless defined $link_target;
583
584 require File::Spec;
585 $link_target = $dir . '/' . $link_target
586 unless File::Spec->file_name_is_absolute($link_target);
587
588 return abs_path($link_target);
589 }
590
99f36a73 591 return $dir ? abs_path($dir) . "/$file" : "/$file";
09122b95
RGS
592 }
593
a0c9c202
JH
594 $cwd = '';
595 $dotdots = $start;
596 do
597 {
598 $dotdots .= '/..';
599 @pst = @cst;
a25ef67d 600 local *PARENT;
a0c9c202
JH
601 unless (opendir(PARENT, $dotdots))
602 {
bf7c0a3d 603 # probably a permissions issue. Try the native command.
cdce0d84 604 require File::Spec;
bf7c0a3d 605 return File::Spec->rel2abs( $start, _backtick_pwd() );
a0c9c202
JH
606 }
607 unless (@cst = stat($dotdots))
608 {
a9939470 609 _carp("stat($dotdots): $!");
a0c9c202
JH
610 closedir(PARENT);
611 return '';
612 }
613 if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
614 {
615 $dir = undef;
616 }
617 else
618 {
619 do
620 {
621 unless (defined ($dir = readdir(PARENT)))
622 {
a9939470 623 _carp("readdir($dotdots): $!");
a0c9c202
JH
624 closedir(PARENT);
625 return '';
626 }
627 $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
628 }
629 while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
630 $tst[1] != $pst[1]);
631 }
632 $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
633 closedir(PARENT);
634 } while (defined $dir);
635 chop($cwd) unless $cwd eq '/'; # drop the trailing /
636 $cwd;
637}
638
639
3ee63918 640my $Curdir;
96e4d5b1 641sub fast_abs_path {
99f36a73 642 local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
96e4d5b1 643 my $cwd = getcwd();
4d6b4052 644 require File::Spec;
3ee63918
MS
645 my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
646
647 # Detaint else we'll explode in taint mode. This is safe because
648 # we're not doing anything dangerous with it.
9f28c638
JB
649 ($path) = $path =~ /(.*)/s;
650 ($cwd) = $cwd =~ /(.*)/s;
3ee63918 651
09122b95
RGS
652 unless (-e $path) {
653 _croak("$path: No such file or directory");
654 }
655
656 unless (-d _) {
657 # Make sure we can be invoked on plain files, not just directories.
658
659 my ($vol, $dir, $file) = File::Spec->splitpath($path);
660 return File::Spec->catfile($cwd, $path) unless length $dir;
661
662 if (-l $path) {
663 my $link_target = readlink($path);
664 die "Can't resolve link $path: $!" unless defined $link_target;
665
666 $link_target = File::Spec->catpath($vol, $dir, $link_target)
667 unless File::Spec->file_name_is_absolute($link_target);
668
669 return fast_abs_path($link_target);
670 }
671
d6802e43 672 return $dir eq File::Spec->rootdir
99f36a73
RGS
673 ? File::Spec->catpath($vol, $dir, $file)
674 : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
09122b95
RGS
675 }
676
e2ba406b 677 if (!CORE::chdir($path)) {
a9939470 678 _croak("Cannot chdir to $path: $!");
e2ba406b 679 }
96e4d5b1 680 my $realpath = getcwd();
e2ba406b 681 if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
a9939470 682 _croak("Cannot chdir back to $cwd: $!");
e2ba406b 683 }
96e4d5b1 684 $realpath;
8b88ae92
NIS
685}
686
e4c51978
GS
687# added function alias to follow principle of least surprise
688# based on previous aliasing. --tchrist 27-Jan-00
689*fast_realpath = \&fast_abs_path;
690
4633a7c4
LW
691
692# --- PORTING SECTION ---
693
694# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c 695# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72 696# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
697# in the process logical name table as the default device and directory
698# seen by Perl. This may not be the same as the default device
4633a7c4
LW
699# and directory seen by DCL after Perl exits, since the effects
700# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
701
702sub _vms_cwd {
96e4d5b1
PP
703 return $ENV{'DEFAULT'};
704}
705
706sub _vms_abs_path {
707 return $ENV{'DEFAULT'} unless @_;
61729915 708 my $path = shift;
9d7d9729 709
53e80d0b
JM
710 my $efs = _vms_efs;
711 my $unix_rpt = _vms_unix_rpt;
712
713 if (defined &VMS::Filespec::vmsrealpath) {
714 my $path_unix = 0;
715 my $path_vms = 0;
716
717 $path_unix = 1 if ($path =~ m#(?<=\^)/#);
718 $path_unix = 1 if ($path =~ /^\.\.?$/);
719 $path_vms = 1 if ($path =~ m#[\[<\]]#);
720 $path_vms = 1 if ($path =~ /^--?$/);
721
722 my $unix_mode = $path_unix;
723 if ($efs) {
724 # In case of a tie, the Unix report mode decides.
725 if ($path_vms == $path_unix) {
726 $unix_mode = $unix_rpt;
727 } else {
728 $unix_mode = 0 if $path_vms;
729 }
730 }
9d7d9729 731
53e80d0b 732 if ($unix_mode) {
bf7c0a3d 733 # Unix format
53e80d0b 734 return VMS::Filespec::unixrealpath($path);
bf7c0a3d
SP
735 }
736
737 # VMS format
738
53e80d0b 739 my $new_path = VMS::Filespec::vmsrealpath($path);
bf7c0a3d
SP
740
741 # Perl expects directories to be in directory format
742 $new_path = VMS::Filespec::pathify($new_path) if -d $path;
743 return $new_path;
744 }
745
746 # Fallback to older algorithm if correct ones are not
747 # available.
748
53e80d0b
JM
749 if (-l $path) {
750 my $link_target = readlink($path);
751 die "Can't resolve link $path: $!" unless defined $link_target;
752
753 return _vms_abs_path($link_target);
754 }
755
61729915
CB
756 # may need to turn foo.dir into [.foo]
757 my $pathified = VMS::Filespec::pathify($path);
758 $path = $pathified if defined $pathified;
759
96e4d5b1 760 return VMS::Filespec::rmsexpand($path);
4633a7c4 761}
68dc0745 762
4633a7c4
LW
763sub _os2_cwd {
764 $ENV{'PWD'} = `cmd /c cd`;
39741d73 765 chomp $ENV{'PWD'};
aa6b7957 766 $ENV{'PWD'} =~ s:\\:/:g ;
4633a7c4
LW
767 return $ENV{'PWD'};
768}
769
8440aeb0 770sub _win32_cwd_simple {
771 $ENV{'PWD'} = `cd`;
772 chomp $ENV{'PWD'};
773 $ENV{'PWD'} =~ s:\\:/:g ;
774 return $ENV{'PWD'};
775}
776
96e4d5b1 777sub _win32_cwd {
5ec06e76
NC
778 # Need to avoid taking any sort of reference to the typeglob or the code in
779 # the optree, so that this tests the runtime state of things, as the
780 # ExtUtils::MakeMaker tests for "miniperl" need to be able to fake things at
781 # runtime by deleting the subroutine. *foo{THING} syntax on a symbol table
782 # lookup avoids needing a string eval, which has been reported to cause
783 # problems (for reasons that we haven't been able to get to the bottom of -
784 # rt.cpan.org #56225)
785 if (*{$DynaLoader::{boot_DynaLoader}}{CODE}) {
cf2f24a4
JD
786 $ENV{'PWD'} = Win32::GetCwd();
787 }
788 else { # miniperl
789 chomp($ENV{'PWD'} = `cd`);
790 }
aa6b7957 791 $ENV{'PWD'} =~ s:\\:/:g ;
96e4d5b1
PP
792 return $ENV{'PWD'};
793}
794
8440aeb0 795*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
68dc0745 796
39e571d4
ML
797sub _dos_cwd {
798 if (!defined &Dos::GetCwd) {
799 $ENV{'PWD'} = `command /c cd`;
39741d73 800 chomp $ENV{'PWD'};
aa6b7957 801 $ENV{'PWD'} =~ s:\\:/:g ;
39e571d4
ML
802 } else {
803 $ENV{'PWD'} = Dos::GetCwd();
804 }
55497cff
PP
805 return $ENV{'PWD'};
806}
807
7fbf1995 808sub _qnx_cwd {
35b807ef
NA
809 local $ENV{PATH} = '';
810 local $ENV{CDPATH} = '';
811 local $ENV{ENV} = '';
7fbf1995 812 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
39741d73 813 chomp $ENV{'PWD'};
7fbf1995
NA
814 return $ENV{'PWD'};
815}
816
817sub _qnx_abs_path {
35b807ef
NA
818 local $ENV{PATH} = '';
819 local $ENV{CDPATH} = '';
820 local $ENV{ENV} = '';
fa921dc6 821 my $path = @_ ? shift : '.';
39741d73
MS
822 local *REALPATH;
823
99f36a73 824 defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
39741d73
MS
825 die "Can't open /usr/bin/fullpath: $!";
826 my $realpath = <REALPATH>;
827 close REALPATH;
828 chomp $realpath;
7fbf1995
NA
829 return $realpath;
830}
831
ed79a026
OF
832sub _epoc_cwd {
833 $ENV{'PWD'} = EPOC::getcwd();
834 return $ENV{'PWD'};
835}
836
4633a7c4 837
09122b95
RGS
838# Now that all the base-level functions are set up, alias the
839# user-level functions to the right places
840
841if (exists $METHOD_MAP{$^O}) {
842 my $map = $METHOD_MAP{$^O};
843 foreach my $name (keys %$map) {
99f36a73 844 local $^W = 0; # assignments trigger 'subroutine redefined' warning
09122b95
RGS
845 no strict 'refs';
846 *{$name} = \&{$map->{$name}};
847 }
55497cff 848}
4633a7c4 849
99f36a73
RGS
850# In case the XS version doesn't load.
851*abs_path = \&_perl_abs_path unless defined &abs_path;
a7a23d71 852*getcwd = \&_perl_getcwd unless defined &getcwd;
99f36a73
RGS
853
854# added function alias for those of us more
855# used to the libc function. --tchrist 27-Jan-00
856*realpath = \&abs_path;
4633a7c4 857
a0d0e21e 8581;