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