This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
correct error returns from fast_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();
a97021b9 465 defined $cwd or return undef;
4d6b4052 466 require File::Spec;
3ee63918
MS
467 my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
468
469 # Detaint else we'll explode in taint mode. This is safe because
470 # we're not doing anything dangerous with it.
9f28c638
JB
471 ($path) = $path =~ /(.*)/s;
472 ($cwd) = $cwd =~ /(.*)/s;
3ee63918 473
09122b95 474 unless (-e $path) {
a97021b9
Z
475 require Errno;
476 $! = Errno::ENOENT();
477 return undef;
09122b95
RGS
478 }
479
480 unless (-d _) {
481 # Make sure we can be invoked on plain files, not just directories.
482
483 my ($vol, $dir, $file) = File::Spec->splitpath($path);
484 return File::Spec->catfile($cwd, $path) unless length $dir;
485
486 if (-l $path) {
487 my $link_target = readlink($path);
a97021b9 488 defined $link_target or return undef;
09122b95
RGS
489
490 $link_target = File::Spec->catpath($vol, $dir, $link_target)
491 unless File::Spec->file_name_is_absolute($link_target);
492
493 return fast_abs_path($link_target);
494 }
495
d6802e43 496 return $dir eq File::Spec->rootdir
99f36a73
RGS
497 ? File::Spec->catpath($vol, $dir, $file)
498 : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
09122b95
RGS
499 }
500
e2ba406b 501 if (!CORE::chdir($path)) {
a97021b9 502 return undef;
e2ba406b 503 }
96e4d5b1 504 my $realpath = getcwd();
e2ba406b 505 if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
a9939470 506 _croak("Cannot chdir back to $cwd: $!");
e2ba406b 507 }
96e4d5b1 508 $realpath;
8b88ae92
NIS
509}
510
e4c51978
GS
511# added function alias to follow principle of least surprise
512# based on previous aliasing. --tchrist 27-Jan-00
513*fast_realpath = \&fast_abs_path;
514
4633a7c4
LW
515
516# --- PORTING SECTION ---
517
518# VMS: $ENV{'DEFAULT'} points to default directory at all times
bd3fa61c 519# 06-Mar-1996 Charles Bailey bailey@newman.upenn.edu
c6538b72 520# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
8b88ae92
NIS
521# in the process logical name table as the default device and directory
522# seen by Perl. This may not be the same as the default device
4633a7c4
LW
523# and directory seen by DCL after Perl exits, since the effects
524# the CRTL chdir() function persist only until Perl exits.
4633a7c4
LW
525
526sub _vms_cwd {
96e4d5b1
PP
527 return $ENV{'DEFAULT'};
528}
529
530sub _vms_abs_path {
531 return $ENV{'DEFAULT'} unless @_;
61729915 532 my $path = shift;
9d7d9729 533
53e80d0b
JM
534 my $efs = _vms_efs;
535 my $unix_rpt = _vms_unix_rpt;
536
537 if (defined &VMS::Filespec::vmsrealpath) {
538 my $path_unix = 0;
539 my $path_vms = 0;
540
541 $path_unix = 1 if ($path =~ m#(?<=\^)/#);
542 $path_unix = 1 if ($path =~ /^\.\.?$/);
543 $path_vms = 1 if ($path =~ m#[\[<\]]#);
544 $path_vms = 1 if ($path =~ /^--?$/);
545
546 my $unix_mode = $path_unix;
547 if ($efs) {
548 # In case of a tie, the Unix report mode decides.
549 if ($path_vms == $path_unix) {
550 $unix_mode = $unix_rpt;
551 } else {
552 $unix_mode = 0 if $path_vms;
553 }
554 }
9d7d9729 555
53e80d0b 556 if ($unix_mode) {
bf7c0a3d 557 # Unix format
53e80d0b 558 return VMS::Filespec::unixrealpath($path);
bf7c0a3d
SP
559 }
560
561 # VMS format
562
53e80d0b 563 my $new_path = VMS::Filespec::vmsrealpath($path);
bf7c0a3d
SP
564
565 # Perl expects directories to be in directory format
566 $new_path = VMS::Filespec::pathify($new_path) if -d $path;
567 return $new_path;
568 }
569
570 # Fallback to older algorithm if correct ones are not
571 # available.
572
53e80d0b
JM
573 if (-l $path) {
574 my $link_target = readlink($path);
575 die "Can't resolve link $path: $!" unless defined $link_target;
576
577 return _vms_abs_path($link_target);
578 }
579
61729915
CB
580 # may need to turn foo.dir into [.foo]
581 my $pathified = VMS::Filespec::pathify($path);
582 $path = $pathified if defined $pathified;
583
96e4d5b1 584 return VMS::Filespec::rmsexpand($path);
4633a7c4 585}
68dc0745 586
4633a7c4 587sub _os2_cwd {
3480fbaa
DD
588 my $pwd = `cmd /c cd`;
589 chomp $pwd;
590 $pwd =~ s:\\:/:g ;
591 $ENV{'PWD'} = $pwd;
592 return $pwd;
4633a7c4
LW
593}
594
8440aeb0 595sub _win32_cwd_simple {
3480fbaa
DD
596 my $pwd = `cd`;
597 chomp $pwd;
598 $pwd =~ s:\\:/:g ;
599 $ENV{'PWD'} = $pwd;
600 return $pwd;
8440aeb0 601}
602
96e4d5b1 603sub _win32_cwd {
3480fbaa 604 my $pwd;
8f1332ed 605 $pwd = Win32::GetCwd();
3480fbaa
DD
606 $pwd =~ s:\\:/:g ;
607 $ENV{'PWD'} = $pwd;
608 return $pwd;
96e4d5b1
PP
609}
610
8440aeb0 611*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_win32_cwd_simple;
68dc0745 612
39e571d4 613sub _dos_cwd {
3480fbaa 614 my $pwd;
39e571d4 615 if (!defined &Dos::GetCwd) {
3480fbaa
DD
616 chomp($pwd = `command /c cd`);
617 $pwd =~ s:\\:/:g ;
39e571d4 618 } else {
3480fbaa 619 $pwd = Dos::GetCwd();
39e571d4 620 }
3480fbaa
DD
621 $ENV{'PWD'} = $pwd;
622 return $pwd;
55497cff
PP
623}
624
7fbf1995 625sub _qnx_cwd {
35b807ef
NA
626 local $ENV{PATH} = '';
627 local $ENV{CDPATH} = '';
628 local $ENV{ENV} = '';
3480fbaa
DD
629 my $pwd = `/usr/bin/fullpath -t`;
630 chomp $pwd;
631 $ENV{'PWD'} = $pwd;
632 return $pwd;
7fbf1995
NA
633}
634
635sub _qnx_abs_path {
35b807ef
NA
636 local $ENV{PATH} = '';
637 local $ENV{CDPATH} = '';
638 local $ENV{ENV} = '';
fa921dc6 639 my $path = @_ ? shift : '.';
39741d73
MS
640 local *REALPATH;
641
99f36a73 642 defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
39741d73
MS
643 die "Can't open /usr/bin/fullpath: $!";
644 my $realpath = <REALPATH>;
645 close REALPATH;
646 chomp $realpath;
7fbf1995
NA
647 return $realpath;
648}
649
09122b95
RGS
650# Now that all the base-level functions are set up, alias the
651# user-level functions to the right places
652
653if (exists $METHOD_MAP{$^O}) {
654 my $map = $METHOD_MAP{$^O};
655 foreach my $name (keys %$map) {
99f36a73 656 local $^W = 0; # assignments trigger 'subroutine redefined' warning
09122b95
RGS
657 no strict 'refs';
658 *{$name} = \&{$map->{$name}};
659 }
55497cff 660}
4633a7c4 661
99f36a73
RGS
662# In case the XS version doesn't load.
663*abs_path = \&_perl_abs_path unless defined &abs_path;
a7a23d71 664*getcwd = \&_perl_getcwd unless defined &getcwd;
99f36a73
RGS
665
666# added function alias for those of us more
667# used to the libc function. --tchrist 27-Jan-00
668*realpath = \&abs_path;
4633a7c4 669
a0d0e21e 6701;
f4eedc6b
DD
671__END__
672
673=head1 NAME
674
675Cwd - get pathname of current working directory
676
677=head1 SYNOPSIS
678
679 use Cwd;
680 my $dir = getcwd;
681
682 use Cwd 'abs_path';
683 my $abs_path = abs_path($file);
684
685=head1 DESCRIPTION
686
687This module provides functions for determining the pathname of the
688current working directory. It is recommended that getcwd (or another
689*cwd() function) be used in I<all> code to ensure portability.
690
691By default, it exports the functions cwd(), getcwd(), fastcwd(), and
692fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
693
694
695=head2 getcwd and friends
696
697Each of these functions are called without arguments and return the
698absolute path of the current working directory.
699
700=over 4
701
702=item getcwd
703
704 my $cwd = getcwd();
705
d2e38af7
Z
706Returns the current working directory. On error returns C<undef>,
707with C<$!> set to indicate the error.
f4eedc6b
DD
708
709Exposes the POSIX function getcwd(3) or re-implements it if it's not
710available.
711
712=item cwd
713
714 my $cwd = cwd();
715
716The cwd() is the most natural form for the current architecture. For
717most systems it is identical to `pwd` (but without the trailing line
718terminator).
719
720=item fastcwd
721
722 my $cwd = fastcwd();
723
724A more dangerous version of getcwd(), but potentially faster.
725
726It might conceivably chdir() you out of a directory that it can't
727chdir() you back into. If fastcwd encounters a problem it will return
728undef but will probably leave you in a different directory. For a
729measure of extra security, if everything appears to have worked, the
730fastcwd() function will check that it leaves you in the same directory
731that it started in. If it has changed it will C<die> with the message
732"Unstable directory path, current directory changed
733unexpectedly". That should never happen.
734
735=item fastgetcwd
736
737 my $cwd = fastgetcwd();
738
739The fastgetcwd() function is provided as a synonym for cwd().
740
741=item getdcwd
742
743 my $cwd = getdcwd();
744 my $cwd = getdcwd('C:');
745
746The getdcwd() function is also provided on Win32 to get the current working
747directory on the specified drive, since Windows maintains a separate current
748working directory for each drive. If no drive is specified then the current
749drive is assumed.
750
751This function simply calls the Microsoft C library _getdcwd() function.
752
753=back
754
755
756=head2 abs_path and friends
757
758These functions are exported only on request. They each take a single
759argument and return the absolute pathname for it. If no argument is
760given they'll use the current working directory.
761
762=over 4
763
764=item abs_path
765
766 my $abs_path = abs_path($file);
767
768Uses the same algorithm as getcwd(). Symbolic links and relative-path
769components ("." and "..") are resolved to return the canonical
d2e38af7
Z
770pathname, just like realpath(3). On error returns C<undef>, with C<$!>
771set to indicate the error.
f4eedc6b
DD
772
773=item realpath
774
775 my $abs_path = realpath($file);
776
777A synonym for abs_path().
778
779=item fast_abs_path
780
781 my $abs_path = fast_abs_path($file);
782
783A more dangerous, but potentially faster version of abs_path.
784
785=back
786
787=head2 $ENV{PWD}
788
789If you ask to override your chdir() built-in function,
790
791 use Cwd qw(chdir);
792
793then your PWD environment variable will be kept up to date. Note that
794it will only be kept up to date if all packages which use chdir import
795it from Cwd.
796
797
798=head1 NOTES
799
800=over 4
801
802=item *
803
804Since the path separators are different on some operating systems ('/'
805on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
806modules wherever portability is a concern.
807
808=item *
809
810Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
811functions are all aliases for the C<cwd()> function, which, on Mac OS,
812calls `pwd`. Likewise, the C<abs_path()> function is an alias for
813C<fast_abs_path()>.
814
815=back
816
817=head1 AUTHOR
818
819Originally by the perl5-porters.
820
821Maintained by Ken Williams <KWILLIAMS@cpan.org>
822
823=head1 COPYRIGHT
824
825Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
826
827This program is free software; you can redistribute it and/or modify
828it under the same terms as Perl itself.
829
830Portions of the C code in this library are copyright (c) 1994 by the
831Regents of the University of California. All rights reserved. The
832license on this code is compatible with the licensing of the rest of
833the distribution - please see the source code in F<Cwd.xs> for the
834details.
835
836=head1 SEE ALSO
837
838L<File::chdir>
839
840=cut