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