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