This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typos (spelling errors) in dist/*
[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
45The cwd() is the most natural form for the current architecture. For
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
60that it started in. If it has changed it will C<die> with the message
61"Unstable directory path, current directory changed
62unexpectedly". That should never happen.
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()>
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
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
e57c1822 174$VERSION = '3.35';
4a4ab19c 175my $xs_version = $VERSION;
486bcc50 176$VERSION = eval $VERSION;
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'} || '';
225 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
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'} || '';
238 $efs = $env_efs =~ /^[ET1]/i;
239 }
240 return $efs;
241}
242
243
b04f6d36 244# If loading the XS stuff doesn't work, we can fall back to pure perl
f22d8e4b 245eval {
b04f6d36
RGS
246 if ( $] >= 5.006 ) {
247 require XSLoader;
4a4ab19c 248 XSLoader::load( __PACKAGE__, $xs_version);
b04f6d36
RGS
249 } else {
250 require DynaLoader;
251 push @ISA, 'DynaLoader';
4a4ab19c 252 __PACKAGE__->bootstrap( $xs_version );
b04f6d36 253 }
f22d8e4b 254};
4633a7c4 255
99f36a73
RGS
256# Must be after the DynaLoader stuff:
257$VERSION = eval $VERSION;
258
09122b95
RGS
259# Big nasty table of function aliases
260my %METHOD_MAP =
261 (
262 VMS =>
263 {
264 cwd => '_vms_cwd',
265 getcwd => '_vms_cwd',
266 fastcwd => '_vms_cwd',
267 fastgetcwd => '_vms_cwd',
268 abs_path => '_vms_abs_path',
269 fast_abs_path => '_vms_abs_path',
270 },
271
272 MSWin32 =>
273 {
274 # We assume that &_NT_cwd is defined as an XSUB or in the core.
275 cwd => '_NT_cwd',
276 getcwd => '_NT_cwd',
277 fastcwd => '_NT_cwd',
278 fastgetcwd => '_NT_cwd',
279 abs_path => 'fast_abs_path',
280 realpath => 'fast_abs_path',
281 },
282
283 dos =>
284 {
285 cwd => '_dos_cwd',
286 getcwd => '_dos_cwd',
287 fastgetcwd => '_dos_cwd',
288 fastcwd => '_dos_cwd',
289 abs_path => 'fast_abs_path',
290 },
291
58ccccf6 292 # QNX4. QNX6 has a $os of 'nto'.
09122b95
RGS
293 qnx =>
294 {
295 cwd => '_qnx_cwd',
296 getcwd => '_qnx_cwd',
297 fastgetcwd => '_qnx_cwd',
298 fastcwd => '_qnx_cwd',
299 abs_path => '_qnx_abs_path',
300 fast_abs_path => '_qnx_abs_path',
301 },
302
303 cygwin =>
304 {
305 getcwd => 'cwd',
306 fastgetcwd => 'cwd',
307 fastcwd => 'cwd',
308 abs_path => 'fast_abs_path',
309 realpath => 'fast_abs_path',
310 },
311
312 epoc =>
313 {
314 cwd => '_epoc_cwd',
315 getcwd => '_epoc_cwd',
316 fastgetcwd => '_epoc_cwd',
317 fastcwd => '_epoc_cwd',
318 abs_path => 'fast_abs_path',
319 },
320
321 MacOS =>
322 {
323 getcwd => 'cwd',
324 fastgetcwd => 'cwd',
325 fastcwd => 'cwd',
326 abs_path => 'fast_abs_path',
327 },
328 );
329
330$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
09122b95 331
96e4d5b1 332
3547aa9a
MS
333# Find the pwd command in the expected locations. We assume these
334# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
335# so everything works under taint mode.
336my $pwd_cmd;
889f7a4f
RGS
337foreach my $try ('/bin/pwd',
338 '/usr/bin/pwd',
339 '/QOpenSys/bin/pwd', # OS/400 PASE.
340 ) {
341
3547aa9a
MS
342 if( -x $try ) {
343 $pwd_cmd = $try;
344 last;
345 }
346}
fa52125f 347my $found_pwd_cmd = defined($pwd_cmd);
522b859a 348unless ($pwd_cmd) {
889f7a4f
RGS
349 # Isn't this wrong? _backtick_pwd() will fail if somenone has
350 # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
351 # See [perl #16774]. --jhi
352 $pwd_cmd = 'pwd';
522b859a 353}
3547aa9a 354
a9939470
NC
355# Lazy-load Carp
356sub _carp { require Carp; Carp::carp(@_) }
357sub _croak { require Carp; Carp::croak(@_) }
358
3547aa9a 359# The 'natural and safe form' for UNIX (pwd may be setuid root)
8b88ae92 360sub _backtick_pwd {
f6342b4b
RGS
361 # Localize %ENV entries in a way that won't create new hash keys
362 my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
363 local @ENV{@localize};
364
3547aa9a 365 my $cwd = `$pwd_cmd`;
ac3b20cb 366 # Belt-and-suspenders in case someone said "undef $/".
5cf6da5f 367 local $/ = "\n";
ac3b20cb 368 # `pwd` may fail e.g. if the disk is full
7e03f963 369 chomp($cwd) if defined $cwd;
4633a7c4 370 $cwd;
8b88ae92 371}
4633a7c4
LW
372
373# Since some ports may predefine cwd internally (e.g., NT)
374# we take care not to override an existing definition for cwd().
375
09122b95 376unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
ea54c8bd 377 # The pwd command is not available in some chroot(2)'ed environments
09122b95 378 my $sep = $Config::Config{path_sep} || ':';
60598624 379 my $os = $^O; # Protect $^O from tainting
fa52125f
SP
380
381
382 # Try again to find a pwd, this time searching the whole PATH.
383 if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
384 my @candidates = split($sep, $ENV{PATH});
385 while (!$found_pwd_cmd and @candidates) {
386 my $candidate = shift @candidates;
387 $found_pwd_cmd = 1 if -x "$candidate/pwd";
388 }
389 }
390
391 # MacOS has some special magic to make `pwd` work.
392 if( $os eq 'MacOS' || $found_pwd_cmd )
73b801a6 393 {
ea54c8bd
EC
394 *cwd = \&_backtick_pwd;
395 }
396 else {
397 *cwd = \&getcwd;
398 }
399}
a0d0e21e 400
23bb49fa
SP
401if ($^O eq 'cygwin') {
402 # We need to make sure cwd() is called with no args, because it's
403 # got an arg-less prototype and will die if args are present.
404 local $^W = 0;
405 my $orig_cwd = \&cwd;
406 *cwd = sub { &$orig_cwd() }
407}
408
409
1f4f94f5
RS
410# set a reasonable (and very safe) default for fastgetcwd, in case it
411# isn't redefined later (20001212 rspier)
412*fastgetcwd = \&cwd;
748a9306 413
c47834cd
RGS
414# A non-XS version of getcwd() - also used to bootstrap the perl build
415# process, when miniperl is running and no XS loading happens.
a7a23d71
NC
416sub _perl_getcwd
417{
418 abs_path('.');
419}
420
a0c9c202
JH
421# By John Bazik
422#
423# Usage: $cwd = &fastcwd;
424#
425# This is a faster version of getcwd. It's also more dangerous because
426# you might chdir out of a directory that you can't chdir back into.
427
99f36a73 428sub fastcwd_ {
a0c9c202
JH
429 my($odev, $oino, $cdev, $cino, $tdev, $tino);
430 my(@path, $path);
431 local(*DIR);
432
433 my($orig_cdev, $orig_cino) = stat('.');
434 ($cdev, $cino) = ($orig_cdev, $orig_cino);
435 for (;;) {
436 my $direntry;
437 ($odev, $oino) = ($cdev, $cino);
438 CORE::chdir('..') || return undef;
439 ($cdev, $cino) = stat('.');
440 last if $odev == $cdev && $oino == $cino;
441 opendir(DIR, '.') || return undef;
442 for (;;) {
443 $direntry = readdir(DIR);
444 last unless defined $direntry;
445 next if $direntry eq '.';
446 next if $direntry eq '..';
447
448 ($tdev, $tino) = lstat($direntry);
449 last unless $tdev != $odev || $tino != $oino;
450 }
451 closedir(DIR);
452 return undef unless defined $direntry; # should never happen
453 unshift(@path, $direntry);
454 }
455 $path = '/' . join('/', @path);
456 if ($^O eq 'apollo') { $path = "/".$path; }
457 # At this point $path may be tainted (if tainting) and chdir would fail.
248785eb
RGS
458 # Untaint it then check that we landed where we started.
459 $path =~ /^(.*)\z/s # untaint
460 && CORE::chdir($1) or return undef;
a0c9c202
JH
461 ($cdev, $cino) = stat('.');
462 die "Unstable directory path, current directory changed unexpectedly"
463 if $cdev != $orig_cdev || $cino != $orig_cino;
464 $path;
465}
99f36a73 466if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
a0c9c202
JH
467
468
4633a7c4 469# Keeps track of current working directory in PWD environment var
a0d0e21e
LW
470# Usage:
471# use Cwd 'chdir';
472# chdir $newdir;
473
4633a7c4 474my $chdir_init = 0;
a0d0e21e 475
4633a7c4 476sub chdir_init {
3b8e3443 477 if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
a0d0e21e
LW
478 my($dd,$di) = stat('.');
479 my($pd,$pi) = stat($ENV{'PWD'});
480 if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
4633a7c4 481 $ENV{'PWD'} = cwd();
a0d0e21e
LW
482 }
483 }
484 else {
3b8e3443
GS
485 my $wd = cwd();
486 $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
487 $ENV{'PWD'} = $wd;
a0d0e21e 488 }
4633a7c4 489 # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
3b8e3443 490 if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
a0d0e21e
LW
491 my($pd,$pi) = stat($2);
492 my($dd,$di) = stat($1);
493 if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
494 $ENV{'PWD'}="$2$3";
495 }
496 }
497 $chdir_init = 1;
498}
499
500sub chdir {
22978713 501 my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
3b8e3443 502 $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
a0d0e21e 503 chdir_init() unless $chdir_init;
4ffa1610
JH
504 my $newpwd;
505 if ($^O eq 'MSWin32') {
506 # get the full path name *before* the chdir()
507 $newpwd = Win32::GetFullPathName($newdir);
508 }
509
4633a7c4 510 return 0 unless CORE::chdir $newdir;
4ffa1610 511
3b8e3443
GS
512 if ($^O eq 'VMS') {
513 return $ENV{'PWD'} = $ENV{'DEFAULT'}
514 }
4aecb5b5
JH
515 elsif ($^O eq 'MacOS') {
516 return $ENV{'PWD'} = cwd();
517 }
3b8e3443 518 elsif ($^O eq 'MSWin32') {
4ffa1610 519 $ENV{'PWD'} = $newpwd;
3b8e3443
GS
520 return 1;
521 }
748a9306 522
e9475de8
SP
523 if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
524 $ENV{'PWD'} = cwd();
525 } elsif ($newdir =~ m#^/#s) {
a0d0e21e 526 $ENV{'PWD'} = $newdir;
4633a7c4
LW
527 } else {
528 my @curdir = split(m#/#,$ENV{'PWD'});
529 @curdir = ('') unless @curdir;
530 my $component;
a0d0e21e
LW
531 foreach $component (split(m#/#, $newdir)) {
532 next if $component eq '.';
533 pop(@curdir),next if $component eq '..';
534 push(@curdir,$component);
535 }
536 $ENV{'PWD'} = join('/',@curdir) || '/';
537 }
4633a7c4 538 1;
a0d0e21e
LW
539}
540
a0c9c202 541
99f36a73 542sub _perl_abs_path
a0c9c202
JH
543{
544 my $start = @_ ? shift : '.';
545 my($dotdots, $cwd, @pst, @cst, $dir, @tst);
546
547 unless (@cst = stat( $start ))
548 {
a9939470 549 _carp("stat($start): $!");
a0c9c202
JH
550 return '';
551 }
09122b95
RGS
552
553 unless (-d _) {
554 # Make sure we can be invoked on plain files, not just directories.
555 # NOTE that this routine assumes that '/' is the only directory separator.
556
557 my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
558 or return cwd() . '/' . $start;
559
275e8705
RGS
560 # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
561 if (-l $start) {
09122b95
RGS
562 my $link_target = readlink($start);
563 die "Can't resolve link $start: $!" unless defined $link_target;
564
565 require File::Spec;
566 $link_target = $dir . '/' . $link_target
567 unless File::Spec->file_name_is_absolute($link_target);
568
569 return abs_path($link_target);
570 }
571
99f36a73 572 return $dir ? abs_path($dir) . "/$file" : "/$file";
09122b95
RGS
573 }
574
a0c9c202
JH
575 $cwd = '';
576 $dotdots = $start;
577 do
578 {
579 $dotdots .= '/..';
580 @pst = @cst;
a25ef67d 581 local *PARENT;
a0c9c202
JH
582 unless (opendir(PARENT, $dotdots))
583 {
bf7c0a3d
SP
584 # probably a permissions issue. Try the native command.
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.
629 ($path) = $path =~ /(.*)/;
630 ($cwd) = $cwd =~ /(.*)/;
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 {
fc49d04a 758 if (eval 'defined &DynaLoader::boot_DynaLoader') {
cf2f24a4
JD
759 $ENV{'PWD'} = Win32::GetCwd();
760 }
761 else { # miniperl
762 chomp($ENV{'PWD'} = `cd`);
763 }
aa6b7957 764 $ENV{'PWD'} =~ s:\\:/:g ;
96e4d5b1 765 return $ENV{'PWD'};
766}
767
8440aeb0 768*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
68dc0745 769
39e571d4
LM
770sub _dos_cwd {
771 if (!defined &Dos::GetCwd) {
772 $ENV{'PWD'} = `command /c cd`;
39741d73 773 chomp $ENV{'PWD'};
aa6b7957 774 $ENV{'PWD'} =~ s:\\:/:g ;
39e571d4
LM
775 } else {
776 $ENV{'PWD'} = Dos::GetCwd();
777 }
55497cff 778 return $ENV{'PWD'};
779}
780
7fbf1995 781sub _qnx_cwd {
35b807ef
NA
782 local $ENV{PATH} = '';
783 local $ENV{CDPATH} = '';
784 local $ENV{ENV} = '';
7fbf1995 785 $ENV{'PWD'} = `/usr/bin/fullpath -t`;
39741d73 786 chomp $ENV{'PWD'};
7fbf1995
NA
787 return $ENV{'PWD'};
788}
789
790sub _qnx_abs_path {
35b807ef
NA
791 local $ENV{PATH} = '';
792 local $ENV{CDPATH} = '';
793 local $ENV{ENV} = '';
fa921dc6 794 my $path = @_ ? shift : '.';
39741d73
MS
795 local *REALPATH;
796
99f36a73 797 defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
39741d73
MS
798 die "Can't open /usr/bin/fullpath: $!";
799 my $realpath = <REALPATH>;
800 close REALPATH;
801 chomp $realpath;
7fbf1995
NA
802 return $realpath;
803}
804
ed79a026
OF
805sub _epoc_cwd {
806 $ENV{'PWD'} = EPOC::getcwd();
807 return $ENV{'PWD'};
808}
809
4633a7c4 810
09122b95
RGS
811# Now that all the base-level functions are set up, alias the
812# user-level functions to the right places
813
814if (exists $METHOD_MAP{$^O}) {
815 my $map = $METHOD_MAP{$^O};
816 foreach my $name (keys %$map) {
99f36a73 817 local $^W = 0; # assignments trigger 'subroutine redefined' warning
09122b95
RGS
818 no strict 'refs';
819 *{$name} = \&{$map->{$name}};
820 }
55497cff 821}
4633a7c4 822
99f36a73
RGS
823# In case the XS version doesn't load.
824*abs_path = \&_perl_abs_path unless defined &abs_path;
a7a23d71 825*getcwd = \&_perl_getcwd unless defined &getcwd;
99f36a73
RGS
826
827# added function alias for those of us more
828# used to the libc function. --tchrist 27-Jan-00
829*realpath = \&abs_path;
4633a7c4 830
a0d0e21e 8311;