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