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