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