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